summaryrefslogtreecommitdiff
path: root/Master/tlpkg/installer
diff options
context:
space:
mode:
authorPiotr Strzelczyk <piotr@eps.gda.pl>2009-06-21 11:13:20 +0000
committerPiotr Strzelczyk <piotr@eps.gda.pl>2009-06-21 11:13:20 +0000
commit05222148264f62f02f26d3c065cc70570e9989d1 (patch)
tree190f9131be560fcfdef7e4ee55e3a63f05d18b9d /Master/tlpkg/installer
parent00c4aed63a3da9cadee2552180ea3433d499be91 (diff)
remove the other perl, installer uses tlperl now
git-svn-id: svn://tug.org/texlive/trunk@13854 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/installer')
-rwxr-xr-xMaster/tlpkg/installer/perl.exebin5632 -> 0 bytes
-rwxr-xr-xMaster/tlpkg/installer/perl58.dllbin1098752 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/AnyDBM_File.pm93
-rw-r--r--Master/tlpkg/installer/perllib/AutoLoader.pm343
-rw-r--r--Master/tlpkg/installer/perllib/B.pm1111
-rw-r--r--Master/tlpkg/installer/perllib/B/Asmdata.pm250
-rw-r--r--Master/tlpkg/installer/perllib/B/Assembler.pm328
-rw-r--r--Master/tlpkg/installer/perllib/B/Bblock.pm224
-rw-r--r--Master/tlpkg/installer/perllib/B/Bytecode.pm889
-rw-r--r--Master/tlpkg/installer/perllib/B/C.pm2272
-rw-r--r--Master/tlpkg/installer/perllib/B/CC.pm2005
-rw-r--r--Master/tlpkg/installer/perllib/B/Concise.pm1628
-rw-r--r--Master/tlpkg/installer/perllib/B/Debug.pm305
-rw-r--r--Master/tlpkg/installer/perllib/B/Deparse.pm4642
-rw-r--r--Master/tlpkg/installer/perllib/B/Disassembler.pm233
-rw-r--r--Master/tlpkg/installer/perllib/B/Lint.pm392
-rw-r--r--Master/tlpkg/installer/perllib/B/Showlex.pm205
-rw-r--r--Master/tlpkg/installer/perllib/B/Stackobj.pm349
-rw-r--r--Master/tlpkg/installer/perllib/B/Stash.pm52
-rw-r--r--Master/tlpkg/installer/perllib/B/Terse.pm103
-rw-r--r--Master/tlpkg/installer/perllib/B/Xref.pm430
-rw-r--r--Master/tlpkg/installer/perllib/B/assemble30
-rw-r--r--Master/tlpkg/installer/perllib/B/cc_harness12
-rw-r--r--Master/tlpkg/installer/perllib/B/disassemble22
-rw-r--r--Master/tlpkg/installer/perllib/B/makeliblinks54
-rw-r--r--Master/tlpkg/installer/perllib/Carp.pm274
-rw-r--r--Master/tlpkg/installer/perllib/Carp/Heavy.pm241
-rw-r--r--Master/tlpkg/installer/perllib/Class/ISA.pm214
-rw-r--r--Master/tlpkg/installer/perllib/Class/Struct.pm636
-rw-r--r--Master/tlpkg/installer/perllib/Config.pm95
-rw-r--r--Master/tlpkg/installer/perllib/Config_heavy.pl1185
-rw-r--r--Master/tlpkg/installer/perllib/Cwd.pm710
-rw-r--r--Master/tlpkg/installer/perllib/Data/Dumper.pm1264
-rw-r--r--Master/tlpkg/installer/perllib/Digest/MD5.pm376
-rw-r--r--Master/tlpkg/installer/perllib/Digest/base.pm100
-rw-r--r--Master/tlpkg/installer/perllib/Digest/file.pm85
-rw-r--r--Master/tlpkg/installer/perllib/DynaLoader.pm833
-rw-r--r--Master/tlpkg/installer/perllib/Encode.pm851
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Alias.pm341
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Byte.pm119
-rw-r--r--Master/tlpkg/installer/perllib/Encode/CJKConstants.pm66
-rw-r--r--Master/tlpkg/installer/perllib/Encode/CN.pm76
-rw-r--r--Master/tlpkg/installer/perllib/Encode/CN/HZ.pm196
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Changes.e2x7
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Config.pm166
-rw-r--r--Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x13
-rw-r--r--Master/tlpkg/installer/perllib/Encode/EBCDIC.pm43
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Encoder.pm249
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Encoding.pm341
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Guess.pm351
-rw-r--r--Master/tlpkg/installer/perllib/Encode/JP.pm97
-rw-r--r--Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm174
-rw-r--r--Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm165
-rw-r--r--Master/tlpkg/installer/perllib/Encode/KR.pm72
-rw-r--r--Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm79
-rw-r--r--Master/tlpkg/installer/perllib/Encode/MIME/Header.pm230
-rw-r--r--Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm127
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x180
-rw-r--r--Master/tlpkg/installer/perllib/Encode/PerlIO.pod167
-rw-r--r--Master/tlpkg/installer/perllib/Encode/README.e2x31
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Supported.pod890
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Symbol.pm42
-rw-r--r--Master/tlpkg/installer/perllib/Encode/TW.pm78
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Unicode.pm268
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Unicode/UTF7.pm118
-rw-r--r--Master/tlpkg/installer/perllib/Encode/_PM.e2x23
-rw-r--r--Master/tlpkg/installer/perllib/Encode/_T.e2x7
-rw-r--r--Master/tlpkg/installer/perllib/Encode/encode.h111
-rw-r--r--Master/tlpkg/installer/perllib/Errno.pm227
-rw-r--r--Master/tlpkg/installer/perllib/Exporter.pm440
-rw-r--r--Master/tlpkg/installer/perllib/Exporter/Heavy.pm248
-rw-r--r--Master/tlpkg/installer/perllib/Fcntl.pm236
-rw-r--r--Master/tlpkg/installer/perllib/File/Basename.pm398
-rw-r--r--Master/tlpkg/installer/perllib/File/CheckTree.pm229
-rw-r--r--Master/tlpkg/installer/perllib/File/Compare.pm178
-rw-r--r--Master/tlpkg/installer/perllib/File/Copy.pm459
-rw-r--r--Master/tlpkg/installer/perllib/File/DosGlob.pm571
-rw-r--r--Master/tlpkg/installer/perllib/File/Find.pm1275
-rw-r--r--Master/tlpkg/installer/perllib/File/Glob.pm496
-rw-r--r--Master/tlpkg/installer/perllib/File/Path.pm285
-rw-r--r--Master/tlpkg/installer/perllib/File/Spec.pm322
-rw-r--r--Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm93
-rw-r--r--Master/tlpkg/installer/perllib/File/Spec/Epoc.pm77
-rw-r--r--Master/tlpkg/installer/perllib/File/Spec/Functions.pm109
-rw-r--r--Master/tlpkg/installer/perllib/File/Spec/Mac.pm780
-rw-r--r--Master/tlpkg/installer/perllib/File/Spec/OS2.pm272
-rw-r--r--Master/tlpkg/installer/perllib/File/Spec/Unix.pm510
-rw-r--r--Master/tlpkg/installer/perllib/File/Spec/VMS.pm521
-rw-r--r--Master/tlpkg/installer/perllib/File/Spec/Win32.pm369
-rw-r--r--Master/tlpkg/installer/perllib/File/Temp.pm2244
-rw-r--r--Master/tlpkg/installer/perllib/File/stat.pm139
-rw-r--r--Master/tlpkg/installer/perllib/FileHandle.pm262
-rw-r--r--Master/tlpkg/installer/perllib/Getopt/Long.pm2504
-rw-r--r--Master/tlpkg/installer/perllib/Getopt/Std.pm294
-rw-r--r--Master/tlpkg/installer/perllib/IO.pm68
-rw-r--r--Master/tlpkg/installer/perllib/IO/Dir.pm246
-rw-r--r--Master/tlpkg/installer/perllib/IO/File.pm208
-rw-r--r--Master/tlpkg/installer/perllib/IO/Handle.pm625
-rw-r--r--Master/tlpkg/installer/perllib/IO/Pipe.pm257
-rw-r--r--Master/tlpkg/installer/perllib/IO/Poll.pm209
-rw-r--r--Master/tlpkg/installer/perllib/IO/Seekable.pm128
-rw-r--r--Master/tlpkg/installer/perllib/IO/Select.pm381
-rw-r--r--Master/tlpkg/installer/perllib/IO/Socket.pm476
-rw-r--r--Master/tlpkg/installer/perllib/IO/Socket/INET.pm431
-rw-r--r--Master/tlpkg/installer/perllib/IO/Socket/UNIX.pm144
-rw-r--r--Master/tlpkg/installer/perllib/List/Util.pm277
-rw-r--r--Master/tlpkg/installer/perllib/Opcode.pm578
-rw-r--r--Master/tlpkg/installer/perllib/POSIX.pm965
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Checker.pm1270
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Find.pm523
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Functions.pm376
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Html.pm2123
-rw-r--r--Master/tlpkg/installer/perllib/Pod/InputObjects.pm941
-rw-r--r--Master/tlpkg/installer/perllib/Pod/LaTeX.pm1876
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Man.pm1413
-rw-r--r--Master/tlpkg/installer/perllib/Pod/ParseLink.pm184
-rw-r--r--Master/tlpkg/installer/perllib/Pod/ParseUtils.pm852
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Parser.pm1799
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc.pm1762
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/BaseTo.pm28
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/GetOptsOO.pm106
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/ToChecker.pm72
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/ToMan.pm187
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/ToNroff.pm100
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/ToPod.pm90
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/ToRtf.pm85
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/ToText.pm91
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/ToTk.pm129
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Perldoc/ToXml.pm63
-rw-r--r--Master/tlpkg/installer/perllib/Pod/PlainText.pm705
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Plainer.pm69
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Select.pm754
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Text.pm848
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Text/Color.pm145
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Text/Overstrike.pm208
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Text/Termcap.pm180
-rw-r--r--Master/tlpkg/installer/perllib/Pod/Usage.pm659
-rw-r--r--Master/tlpkg/installer/perllib/Safe.pm576
-rw-r--r--Master/tlpkg/installer/perllib/Scalar/Util.pm147
-rw-r--r--Master/tlpkg/installer/perllib/SelectSaver.pm54
-rw-r--r--Master/tlpkg/installer/perllib/Symbol.pm170
-rw-r--r--Master/tlpkg/installer/perllib/Term/ANSIColor.pm472
-rw-r--r--Master/tlpkg/installer/perllib/Term/Cap.pm669
-rw-r--r--Master/tlpkg/installer/perllib/Term/Complete.pm188
-rw-r--r--Master/tlpkg/installer/perllib/Term/ReadLine.pm399
-rw-r--r--Master/tlpkg/installer/perllib/Text/Abbrev.pm84
-rw-r--r--Master/tlpkg/installer/perllib/Text/Balanced.pm2302
-rw-r--r--Master/tlpkg/installer/perllib/Text/ParseWords.pm263
-rw-r--r--Master/tlpkg/installer/perllib/Text/Soundex.pm150
-rw-r--r--Master/tlpkg/installer/perllib/Text/Tabs.pm121
-rw-r--r--Master/tlpkg/installer/perllib/Text/Wrap.pm223
-rw-r--r--Master/tlpkg/installer/perllib/Tie/Array.pm287
-rw-r--r--Master/tlpkg/installer/perllib/Tie/File.pm2632
-rw-r--r--Master/tlpkg/installer/perllib/Tie/Handle.pm234
-rw-r--r--Master/tlpkg/installer/perllib/Tie/Hash.pm257
-rw-r--r--Master/tlpkg/installer/perllib/Tie/Memoize.pm128
-rw-r--r--Master/tlpkg/installer/perllib/Tie/RefHash.pm170
-rw-r--r--Master/tlpkg/installer/perllib/Tie/Scalar.pm140
-rw-r--r--Master/tlpkg/installer/perllib/Tie/SubstrHash.pm215
-rw-r--r--Master/tlpkg/installer/perllib/Tie/Watch.pm560
-rw-r--r--Master/tlpkg/installer/perllib/Time/HiRes.pm500
-rw-r--r--Master/tlpkg/installer/perllib/Time/Local.pm366
-rw-r--r--Master/tlpkg/installer/perllib/Time/gmtime.pm90
-rw-r--r--Master/tlpkg/installer/perllib/Time/localtime.pm86
-rw-r--r--Master/tlpkg/installer/perllib/Time/tm.pm33
-rw-r--r--Master/tlpkg/installer/perllib/Tk.pm821
-rw-r--r--Master/tlpkg/installer/perllib/Tk/After.pm104
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Button.pm148
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Canvas.pm1436
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Checkbutton.pm42
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Clipboard.pm122
-rw-r--r--Master/tlpkg/installer/perllib/Tk/CmdLine.pm954
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Configure.pm69
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Derived.pm512
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Dialog.pm70
-rw-r--r--Master/tlpkg/installer/perllib/Tk/DialogBox.pm135
-rw-r--r--Master/tlpkg/installer/perllib/Tk/DummyEncode.pm46
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Entry.pm615
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Event.pm13
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Event/IO.pm132
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Font.pm163
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Frame.pm378
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Image.pm74
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Label.pm21
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Labelframe.pm16
-rw-r--r--Master/tlpkg/installer/perllib/Tk/MainWindow.pm213
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Menu.pm1145
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Menu/Item.pm180
-rw-r--r--Master/tlpkg/installer/perllib/Tk/PNG.pm43
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Photo.pm22
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Pretty.pm93
-rw-r--r--Master/tlpkg/installer/perllib/Tk/ProgressBar.pm498
-rw-r--r--Master/tlpkg/installer/perllib/Tk/ROText.pm43
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Radiobutton.pm45
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Scrollbar.pm429
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Submethods.pm46
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Text.pm1653
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Toplevel.pm211
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Trace.pm405
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Widget.pm1510
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Wm.pm174
-rw-r--r--Master/tlpkg/installer/perllib/UNIVERSAL.pm147
-rw-r--r--Master/tlpkg/installer/perllib/Win32.pm712
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API.pm745
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API.pm.orig741
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API/Callback.pm174
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API/Struct.pm532
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API/Test.pm120
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API/Type.pm446
-rw-r--r--Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm198
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Client.pl63
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Clipboard.pm369
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Console.pm1463
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Event.pm104
-rw-r--r--Master/tlpkg/installer/perllib/Win32/EventLog.pm471
-rw-r--r--Master/tlpkg/installer/perllib/Win32/File.pm118
-rw-r--r--Master/tlpkg/installer/perllib/Win32/FileSecurity.pm308
-rw-r--r--Master/tlpkg/installer/perllib/Win32/IPC.pm195
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Internet.pm3009
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Job.pm370
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Mutex.pm125
-rw-r--r--Master/tlpkg/installer/perllib/Win32/NetAdmin.pm419
-rw-r--r--Master/tlpkg/installer/perllib/Win32/NetResource.pm456
-rw-r--r--Master/tlpkg/installer/perllib/Win32/ODBC.pm1493
-rw-r--r--Master/tlpkg/installer/perllib/Win32/PerfLib.pm538
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Pipe.pm414
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Process.pm217
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Registry.pm547
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Semaphore.pm128
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Server.pl48
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Service.pm103
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Shortcut.pm323
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Sound.pm582
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Test.pl477
-rw-r--r--Master/tlpkg/installer/perllib/Win32/TieRegistry.pm3801
-rw-r--r--Master/tlpkg/installer/perllib/Win32/WinError.pm1017
-rw-r--r--Master/tlpkg/installer/perllib/Win32/test-async.pl129
-rw-r--r--Master/tlpkg/installer/perllib/Win32API/Registry.pm1792
-rw-r--r--Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc87
-rw-r--r--Master/tlpkg/installer/perllib/XSLoader.pm356
-rw-r--r--Master/tlpkg/installer/perllib/attributes.pm418
-rw-r--r--Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Cwd/Cwd.dllbin10240 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Digest/MD5/MD5.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Digest/MD5/MD5.dllbin15872 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix8
-rw-r--r--Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al34
-rw-r--r--Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al19
-rw-r--r--Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al115
-rw-r--r--Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dllbin112640 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Encode/Encode.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Encode/Encode.dllbin30208 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dllbin17920 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Fcntl/Fcntl.dllbin14848 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/IO/IO.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/IO/IO.dllbin16896 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/List/Util/Util.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/List/Util/Util.dllbin26624 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/POSIX.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/POSIX/POSIX.dllbin97792 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/abs.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/alarm.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/assert.al15
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/atan2.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/atexit.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/atof.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/atoi.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/atol.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/autosplit.ix159
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/bsearch.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/calloc.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/chdir.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/chmod.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/chown.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/clearerr.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/closedir.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/cos.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/creat.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/div.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/errno.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/execl.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/execle.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/execlp.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/execv.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/execve.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/execvp.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/exit.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/exp.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fabs.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fclose.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fcntl.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fdopen.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/feof.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/ferror.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fflush.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fgetc.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fgetpos.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fgets.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fileno.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fopen.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fork.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fprintf.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fputc.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fputs.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fread.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/free.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/freopen.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fscanf.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fseek.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fsetpos.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fstat.al17
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fsync.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/ftell.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/fwrite.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getc.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getchar.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getegid.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getenv.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/geteuid.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getgid.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getgrgid.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getgrnam.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getgroups.al14
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getlogin.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getpgrp.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getpid.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getppid.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getpwnam.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getpwuid.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/gets.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/getuid.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/gmtime.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/isatty.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/kill.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/labs.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/ldiv.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/link.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/load_imports.al225
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/localtime.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/log.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/longjmp.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/malloc.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/memchr.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/memcmp.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/memcpy.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/memmove.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/memset.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/mkdir.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/offsetof.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/opendir.al16
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/perror.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/pow.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/printf.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/putc.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/putchar.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/puts.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/qsort.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/raise.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/rand.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/readdir.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/realloc.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/redef.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/remove.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/rename.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/rewind.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/rewinddir.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/rmdir.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/scanf.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/setbuf.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/setjmp.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/setvbuf.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/siglongjmp.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/sigsetjmp.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/sin.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/sleep.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/sprintf.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/sqrt.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/srand.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/sscanf.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/stat.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strcat.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strchr.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strcmp.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strcpy.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strcspn.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strerror.al14
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strlen.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strncat.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strncmp.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strncpy.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strpbrk.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strrchr.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strspn.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strstr.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/strtok.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/system.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/time.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/tmpfile.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/tolower.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/toupper.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/umask.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/ungetc.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/unimpl.al14
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/unlink.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/usage.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/utime.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/vfprintf.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/vprintf.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/vsprintf.al12
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/wait.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/POSIX/waitpid.al13
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al15
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.dllbin153600 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix6
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al15
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dllbin41472 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Error.al20
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/Event/Event.dllbin56832 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/AddScrollbars.al52
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/FindMenu.al22
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix24
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/freeze_on_map.al18
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/label.al24
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/labelPack.al50
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/labelVariable.al27
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/packscrollbars.al86
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/queuePack.al18
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/sbset.al15
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/scrollbars.al24
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dllbin168960 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al16
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonDown.al55
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonUp.al26
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Drag.al43
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/EndDrag.al28
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Enter.al21
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Leave.al18
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Motion.al15
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByPages.al38
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByUnits.al37
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlToPos.al35
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlTopBottom.al32
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.dllbin21504 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Select.al59
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/StartDrag.al38
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/autosplit.ix30
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Text/Text.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/Text/Text.dllbin114176 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Text/autosplit.ix3
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Tk.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/Tk.dllbin804864 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix10
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix11
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al17
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al29
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al50
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al20
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix14
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al24
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix45
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al43
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/API/API.bs0
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/API/API.dllbin20480 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs0
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dllbin16384 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.bs0
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.dllbin29184 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dllbin181760 -> 0 bytes
-rw-r--r--Master/tlpkg/installer/perllib/base.pm226
-rw-r--r--Master/tlpkg/installer/perllib/bytes.pm88
-rw-r--r--Master/tlpkg/installer/perllib/bytes_heavy.pl40
-rw-r--r--Master/tlpkg/installer/perllib/constant.pm340
-rw-r--r--Master/tlpkg/installer/perllib/fields.pm319
-rw-r--r--Master/tlpkg/installer/perllib/lib.pm206
-rw-r--r--Master/tlpkg/installer/perllib/newgetopt.pl75
-rw-r--r--Master/tlpkg/installer/perllib/overload.pm1434
-rw-r--r--Master/tlpkg/installer/perllib/re.pm134
-rw-r--r--Master/tlpkg/installer/perllib/strict.pm136
-rw-r--r--Master/tlpkg/installer/perllib/subs.pm40
-rw-r--r--Master/tlpkg/installer/perllib/unicore/Canonical.pl1042
-rw-r--r--Master/tlpkg/installer/perllib/unicore/Exact.pl73
-rw-r--r--Master/tlpkg/installer/perllib/unicore/PVA.pl2044
-rw-r--r--Master/tlpkg/installer/perllib/unicore/To/Lower.pl905
-rw-r--r--Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl490
-rw-r--r--Master/tlpkg/installer/perllib/utf8.pm214
-rw-r--r--Master/tlpkg/installer/perllib/utf8_heavy.pl412
-rw-r--r--Master/tlpkg/installer/perllib/vars.pm82
-rw-r--r--Master/tlpkg/installer/perllib/warnings.pm497
-rw-r--r--Master/tlpkg/installer/perllib/warnings/register.pm51
498 files changed, 0 insertions, 124136 deletions
diff --git a/Master/tlpkg/installer/perl.exe b/Master/tlpkg/installer/perl.exe
deleted file mode 100755
index 30108d9a8cc..00000000000
--- a/Master/tlpkg/installer/perl.exe
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perl58.dll b/Master/tlpkg/installer/perl58.dll
deleted file mode 100755
index d783261a862..00000000000
--- a/Master/tlpkg/installer/perl58.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/AnyDBM_File.pm b/Master/tlpkg/installer/perllib/AnyDBM_File.pm
deleted file mode 100644
index d73abab0f9e..00000000000
--- a/Master/tlpkg/installer/perllib/AnyDBM_File.pm
+++ /dev/null
@@ -1,93 +0,0 @@
-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/installer/perllib/AutoLoader.pm b/Master/tlpkg/installer/perllib/AutoLoader.pm
deleted file mode 100644
index 4352d8b1fbe..00000000000
--- a/Master/tlpkg/installer/perllib/AutoLoader.pm
+++ /dev/null
@@ -1,343 +0,0 @@
-package AutoLoader;
-
-use strict;
-use 5.006_001;
-
-our($VERSION, $AUTOLOAD);
-
-my $is_dosish;
-my $is_epoc;
-my $is_vms;
-my $is_macos;
-
-BEGIN {
- $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
- $is_epoc = $^O eq 'epoc';
- $is_vms = $^O eq 'VMS';
- $is_macos = $^O eq 'MacOS';
- $VERSION = '5.60';
-}
-
-AUTOLOAD {
- my $sub = $AUTOLOAD;
- my $filename;
- # Braces used to preserve $1 et al.
- {
- # Try to find the autoloaded file from the package-qualified
- # name of the sub. e.g., if the sub needed is
- # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is
- # something like '/usr/lib/perl5/Getopt/Long.pm', and the
- # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'.
- #
- # However, if @INC is a relative path, this might not work. If,
- # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is
- # 'lib/Getopt/Long.pm', and we want to require
- # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib').
- # In this case, we simple prepend the 'auto/' and let the
- # C<require> take care of the searching for us.
-
- my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
- $pkg =~ s#::#/#g;
- if (defined($filename = $INC{"$pkg.pm"})) {
- if ($is_macos) {
- $pkg =~ tr#/#:#;
- $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
- } else {
- $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s;
- }
-
- # if the file exists, then make sure that it is a
- # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al',
- # or './lib/auto/foo/bar.al'. This avoids C<require> searching
- # (and failing) to find the 'lib/auto/foo/bar.al' because it
- # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
-
- if (-r $filename) {
- unless ($filename =~ m|^/|s) {
- if ($is_dosish) {
- unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
- if ($^O ne 'NetWare') {
- $filename = "./$filename";
- } else {
- $filename = "$filename";
- }
- }
- }
- elsif ($is_epoc) {
- unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
- $filename = "./$filename";
- }
- }
- elsif ($is_vms) {
- # XXX todo by VMSmiths
- $filename = "./$filename";
- }
- elsif (!$is_macos) {
- $filename = "./$filename";
- }
- }
- }
- else {
- $filename = undef;
- }
- }
- unless (defined $filename) {
- # let C<require> do the searching
- $filename = "auto/$sub.al";
- $filename =~ s#::#/#g;
- }
- }
- my $save = $@;
- local $!; # Do not munge the value.
- eval { local $SIG{__DIE__}; require $filename };
- if ($@) {
- if (substr($sub,-9) eq '::DESTROY') {
- no strict 'refs';
- *$sub = sub {};
- $@ = undef;
- } elsif ($@ =~ /^Can't locate/) {
- # The load might just have failed because the filename was too
- # long for some old SVR3 systems which treat long names as errors.
- # If we can successfully truncate a long name then it's worth a go.
- # There is a slight risk that we could pick up the wrong file here
- # but autosplit should have warned about that when splitting.
- if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
- eval { local $SIG{__DIE__}; require $filename };
- }
- }
- if ($@){
- $@ =~ s/ at .*\n//;
- my $error = $@;
- require Carp;
- Carp::croak($error);
- }
- }
- $@ = $save;
- goto &$sub;
-}
-
-sub import {
- my $pkg = shift;
- my $callpkg = caller;
-
- #
- # Export symbols, but not by accident of inheritance.
- #
-
- if ($pkg eq 'AutoLoader') {
- no strict 'refs';
- *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD
- if @_ and $_[0] =~ /^&?AUTOLOAD$/;
- }
-
- #
- # Try to find the autosplit index file. Eg., if the call package
- # is POSIX, then $INC{POSIX.pm} is something like
- # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in
- # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that.
- #
- # However, if @INC is a relative path, this might not work. If,
- # for example, @INC = ('lib'), then
- # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
- # 'auto/POSIX/autosplit.ix' (without the leading 'lib').
- #
-
- (my $calldir = $callpkg) =~ s#::#/#g;
- my $path = $INC{$calldir . '.pm'};
- if (defined($path)) {
- # Try absolute path name.
- if ($is_macos) {
- (my $malldir = $calldir) =~ tr#/#:#;
- $path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s;
- } else {
- $path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#;
- }
-
- eval { require $path; };
- # If that failed, try relative path with normal @INC searching.
- if ($@) {
- $path ="auto/$calldir/autosplit.ix";
- eval { require $path; };
- }
- if ($@) {
- my $error = $@;
- require Carp;
- Carp::carp($error);
- }
- }
-}
-
-sub unimport {
- my $callpkg = caller;
-
- no strict 'refs';
- my $symname = $callpkg . '::AUTOLOAD';
- undef *{ $symname } if \&{ $symname } == \&AUTOLOAD;
- *{ $symname } = \&{ $symname };
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-AutoLoader - load subroutines only on demand
-
-=head1 SYNOPSIS
-
- package Foo;
- use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
-
- package Bar;
- use AutoLoader; # don't import AUTOLOAD, define our own
- sub AUTOLOAD {
- ...
- $AutoLoader::AUTOLOAD = "...";
- goto &AutoLoader::AUTOLOAD;
- }
-
-=head1 DESCRIPTION
-
-The B<AutoLoader> module works with the B<AutoSplit> module and the
-C<__END__> token to defer the loading of some subroutines until they are
-used rather than loading them all at once.
-
-To use B<AutoLoader>, the author of a module has to place the
-definitions of subroutines to be autoloaded after an C<__END__> token.
-(See L<perldata>.) The B<AutoSplit> module can then be run manually to
-extract the definitions into individual files F<auto/funcname.al>.
-
-B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
-subroutine in is called in a client module of B<AutoLoader>,
-B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
-file with a name related to the location of the file from which the
-client module was read. As an example, if F<POSIX.pm> is located in
-F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
-subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
-the C<.al> file has the same name as the subroutine, sans package. If
-such a file exists, AUTOLOAD will read and evaluate it,
-thus (presumably) defining the needed subroutine. AUTOLOAD will then
-C<goto> the newly defined subroutine.
-
-Once this process completes for a given function, it is defined, so
-future calls to the subroutine will bypass the AUTOLOAD mechanism.
-
-=head2 Subroutine Stubs
-
-In order for object method lookup and/or prototype checking to operate
-correctly even when methods have not yet been defined it is necessary to
-"forward declare" each subroutine (as in C<sub NAME;>). See
-L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
-stubs", which are place holders with no code.
-
-The AutoSplit and B<AutoLoader> modules automate the creation of forward
-declarations. The AutoSplit module creates an 'index' file containing
-forward declarations of all the AutoSplit subroutines. When the
-AutoLoader module is 'use'd it loads these declarations into its callers
-package.
-
-Because of this mechanism it is important that B<AutoLoader> is always
-C<use>d and not C<require>d.
-
-=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
-
-In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
-explicitly import it:
-
- use AutoLoader 'AUTOLOAD';
-
-=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
-
-Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
-They typically need to check for some special cases (such as constants)
-and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
-
-Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
-Instead, they should define their own AUTOLOAD subroutines along these
-lines:
-
- use AutoLoader;
- use Carp;
-
- sub AUTOLOAD {
- my $sub = $AUTOLOAD;
- (my $constname = $sub) =~ s/.*:://;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
- if ($! =~ /Invalid/ || $!{EINVAL}) {
- $AutoLoader::AUTOLOAD = $sub;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- croak "Your vendor has not defined constant $constname";
- }
- }
- *$sub = sub { $val }; # same as: eval "sub $sub { $val }";
- goto &$sub;
- }
-
-If any module's own AUTOLOAD subroutine has no need to fallback to the
-AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
-subroutines), then that module should not use B<AutoLoader> at all.
-
-=head2 Package Lexicals
-
-Package lexicals declared with C<my> in the main block of a package
-using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
-the fact that the given scope ends at the C<__END__> marker. A module
-using such variables as package globals will not work properly under the
-B<AutoLoader>.
-
-The C<vars> pragma (see L<perlmod/"vars">) may be used in such
-situations as an alternative to explicitly qualifying all globals with
-the package namespace. Variables pre-declared with this pragma will be
-visible to any autoloaded routines (but will not be invisible outside
-the package, unfortunately).
-
-=head2 Not Using AutoLoader
-
-You can stop using AutoLoader by simply
-
- no AutoLoader;
-
-=head2 B<AutoLoader> vs. B<SelfLoader>
-
-The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
-loading of subroutines.
-
-B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
-While this avoids the use of a hierarchy of disk files and the
-associated open/close for each routine loaded, B<SelfLoader> suffers a
-startup speed disadvantage in the one-time parsing of the lines after
-C<__DATA__>, after which routines are cached. B<SelfLoader> can also
-handle multiple packages in a file.
-
-B<AutoLoader> only reads code as it is requested, and in many cases
-should be faster, but requires a mechanism like B<AutoSplit> be used to
-create the individual files. L<ExtUtils::MakeMaker> will invoke
-B<AutoSplit> automatically if B<AutoLoader> is used in a module source
-file.
-
-=head1 CAVEATS
-
-AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
-old modules which use B<AutoLoader> should be changed to the new calling
-style. Typically this just means changing a require to a use, adding
-the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
-from C<@ISA>.
-
-On systems with restrictions on file name length, the file corresponding
-to a subroutine may have a shorter name that the routine itself. This
-can lead to conflicting file names. The I<AutoSplit> package warns of
-these potential conflicts when used to split a module.
-
-AutoLoader may fail to find the autosplit files (or even find the wrong
-ones) in cases where C<@INC> contains relative paths, B<and> the program
-does C<chdir>.
-
-=head1 SEE ALSO
-
-L<SelfLoader> - an autoloader that doesn't use external files.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B.pm b/Master/tlpkg/installer/perllib/B.pm
deleted file mode 100644
index 12917347cd0..00000000000
--- a/Master/tlpkg/installer/perllib/B.pm
+++ /dev/null
@@ -1,1111 +0,0 @@
-# B.pm
-#
-# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-package B;
-
-our $VERSION = '1.09_01';
-
-use XSLoader ();
-require Exporter;
-@ISA = qw(Exporter);
-
-# walkoptree_slow comes from B.pm (you are there),
-# walkoptree comes from B.xs
-@EXPORT_OK = qw(minus_c ppname save_BEGINs
- class peekop cast_I32 cstring cchar hash threadsv_names
- main_root main_start main_cv svref_2object opnumber
- amagic_generation perlstring
- walkoptree_slow walkoptree walkoptree_exec walksymtable
- parents comppadlist sv_undef compile_stats timing_info
- begin_av init_av check_av end_av regex_padav dowarn
- defstash curstash warnhook diehook inc_gv
- );
-
-sub OPf_KIDS ();
-use strict;
-@B::SV::ISA = 'B::OBJECT';
-@B::NULL::ISA = 'B::SV';
-@B::PV::ISA = 'B::SV';
-@B::IV::ISA = 'B::SV';
-@B::NV::ISA = 'B::SV';
-@B::RV::ISA = 'B::SV';
-@B::PVIV::ISA = qw(B::PV B::IV);
-@B::PVNV::ISA = qw(B::PVIV B::NV);
-@B::PVMG::ISA = 'B::PVNV';
-# Change in the inheritance hierarchy post 5.9.0
-@B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG';
-@B::BM::ISA = 'B::PVMG';
-@B::AV::ISA = 'B::PVMG';
-@B::GV::ISA = 'B::PVMG';
-@B::HV::ISA = 'B::PVMG';
-@B::CV::ISA = 'B::PVMG';
-@B::IO::ISA = 'B::PVMG';
-@B::FM::ISA = 'B::CV';
-
-@B::OP::ISA = 'B::OBJECT';
-@B::UNOP::ISA = 'B::OP';
-@B::BINOP::ISA = 'B::UNOP';
-@B::LOGOP::ISA = 'B::UNOP';
-@B::LISTOP::ISA = 'B::BINOP';
-@B::SVOP::ISA = 'B::OP';
-@B::PADOP::ISA = 'B::OP';
-@B::PVOP::ISA = 'B::OP';
-@B::LOOP::ISA = 'B::LISTOP';
-@B::PMOP::ISA = 'B::LISTOP';
-@B::COP::ISA = 'B::OP';
-
-@B::SPECIAL::ISA = 'B::OBJECT';
-
-{
- # Stop "-w" from complaining about the lack of a real B::OBJECT class
- package B::OBJECT;
-}
-
-sub B::GV::SAFENAME {
- my $name = (shift())->NAME;
-
- # The regex below corresponds to the isCONTROLVAR macro
- # from toke.c
-
- $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
- chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;
-
- # When we say unicode_to_native we really mean ascii_to_native,
- # which matters iff this is a non-ASCII platform (EBCDIC).
-
- return $name;
-}
-
-sub B::IV::int_value {
- my ($self) = @_;
- return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
-}
-
-sub B::NULL::as_string() {""}
-sub B::IV::as_string() {goto &B::IV::int_value}
-sub B::PV::as_string() {goto &B::PV::PV}
-
-my $debug;
-my $op_count = 0;
-my @parents = ();
-
-sub debug {
- my ($class, $value) = @_;
- $debug = $value;
- walkoptree_debug($value);
-}
-
-sub class {
- my $obj = shift;
- my $name = ref $obj;
- $name =~ s/^.*:://;
- return $name;
-}
-
-sub parents { \@parents }
-
-# For debugging
-sub peekop {
- my $op = shift;
- return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
-}
-
-sub walkoptree_slow {
- my($op, $method, $level) = @_;
- $op_count++; # just for statistics
- $level ||= 0;
- warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
- $op->$method($level);
- if ($$op && ($op->flags & OPf_KIDS)) {
- my $kid;
- unshift(@parents, $op);
- for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
- walkoptree_slow($kid, $method, $level + 1);
- }
- shift @parents;
- }
- if (class($op) eq 'PMOP' && ref($op->pmreplroot) && ${$op->pmreplroot}) {
- unshift(@parents, $op);
- walkoptree_slow($op->pmreplroot, $method, $level + 1);
- shift @parents;
- }
-}
-
-sub compile_stats {
- return "Total number of OPs processed: $op_count\n";
-}
-
-sub timing_info {
- my ($sec, $min, $hr) = localtime;
- my ($user, $sys) = times;
- sprintf("%02d:%02d:%02d user=$user sys=$sys",
- $hr, $min, $sec, $user, $sys);
-}
-
-my %symtable;
-
-sub clearsym {
- %symtable = ();
-}
-
-sub savesym {
- my ($obj, $value) = @_;
-# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
- $symtable{sprintf("sym_%x", $$obj)} = $value;
-}
-
-sub objsym {
- my $obj = shift;
- return $symtable{sprintf("sym_%x", $$obj)};
-}
-
-sub walkoptree_exec {
- my ($op, $method, $level) = @_;
- $level ||= 0;
- my ($sym, $ppname);
- my $prefix = " " x $level;
- for (; $$op; $op = $op->next) {
- $sym = objsym($op);
- if (defined($sym)) {
- print $prefix, "goto $sym\n";
- return;
- }
- savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
- $op->$method($level);
- $ppname = $op->name;
- if ($ppname =~
- /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/)
- {
- print $prefix, uc($1), " => {\n";
- walkoptree_exec($op->other, $method, $level + 1);
- print $prefix, "}\n";
- } elsif ($ppname eq "match" || $ppname eq "subst") {
- my $pmreplstart = $op->pmreplstart;
- if ($$pmreplstart) {
- print $prefix, "PMREPLSTART => {\n";
- walkoptree_exec($pmreplstart, $method, $level + 1);
- print $prefix, "}\n";
- }
- } elsif ($ppname eq "substcont") {
- print $prefix, "SUBSTCONT => {\n";
- walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
- print $prefix, "}\n";
- $op = $op->other;
- } elsif ($ppname eq "enterloop") {
- print $prefix, "REDO => {\n";
- walkoptree_exec($op->redoop, $method, $level + 1);
- print $prefix, "}\n", $prefix, "NEXT => {\n";
- walkoptree_exec($op->nextop, $method, $level + 1);
- print $prefix, "}\n", $prefix, "LAST => {\n";
- walkoptree_exec($op->lastop, $method, $level + 1);
- print $prefix, "}\n";
- } elsif ($ppname eq "subst") {
- my $replstart = $op->pmreplstart;
- if ($$replstart) {
- print $prefix, "SUBST => {\n";
- walkoptree_exec($replstart, $method, $level + 1);
- print $prefix, "}\n";
- }
- }
- }
-}
-
-sub walksymtable {
- my ($symref, $method, $recurse, $prefix) = @_;
- my $sym;
- my $ref;
- my $fullname;
- no strict 'refs';
- $prefix = '' unless defined $prefix;
- while (($sym, $ref) = each %$symref) {
- $fullname = "*main::".$prefix.$sym;
- if ($sym =~ /::$/) {
- $sym = $prefix . $sym;
- if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
- walksymtable(\%$fullname, $method, $recurse, $sym);
- }
- } else {
- svref_2object(\*$fullname)->$method();
- }
- }
-}
-
-{
- package B::Section;
- my $output_fh;
- my %sections;
-
- sub new {
- my ($class, $section, $symtable, $default) = @_;
- $output_fh ||= FileHandle->new_tmpfile;
- my $obj = bless [-1, $section, $symtable, $default], $class;
- $sections{$section} = $obj;
- return $obj;
- }
-
- sub get {
- my ($class, $section) = @_;
- return $sections{$section};
- }
-
- sub add {
- my $section = shift;
- while (defined($_ = shift)) {
- print $output_fh "$section->[1]\t$_\n";
- $section->[0]++;
- }
- }
-
- sub index {
- my $section = shift;
- return $section->[0];
- }
-
- sub name {
- my $section = shift;
- return $section->[1];
- }
-
- sub symtable {
- my $section = shift;
- return $section->[2];
- }
-
- sub default {
- my $section = shift;
- return $section->[3];
- }
-
- sub output {
- my ($section, $fh, $format) = @_;
- my $name = $section->name;
- my $sym = $section->symtable || {};
- my $default = $section->default;
-
- seek($output_fh, 0, 0);
- while (<$output_fh>) {
- chomp;
- s/^(.*?)\t//;
- if ($1 eq $name) {
- s{(s\\_[0-9a-f]+)} {
- exists($sym->{$1}) ? $sym->{$1} : $default;
- }ge;
- printf $fh $format, $_;
- }
- }
- }
-}
-
-XSLoader::load 'B';
-
-1;
-
-__END__
-
-=head1 NAME
-
-B - The Perl Compiler
-
-=head1 SYNOPSIS
-
- use B;
-
-=head1 DESCRIPTION
-
-The C<B> module supplies classes which allow a Perl program to delve
-into its own innards. It is the module used to implement the
-"backends" of the Perl compiler. Usage of the compiler does not
-require knowledge of this module: see the F<O> module for the
-user-visible part. The C<B> module is of use to those who want to
-write new compiler backends. This documentation assumes that the
-reader knows a fair amount about perl's internals including such
-things as SVs, OPs and the internal symbol table and syntax tree
-of a program.
-
-=head1 OVERVIEW
-
-The C<B> module contains a set of utility functions for querying the
-current state of the Perl interpreter; typically these functions
-return objects from the B::SV and B::OP classes, or their derived
-classes. These classes in turn define methods for querying the
-resulting objects about their own internal state.
-
-=head1 Utility Functions
-
-The C<B> module exports a variety of functions: some are simple
-utility functions, others provide a Perl program with a way to
-get an initial "handle" on an internal object.
-
-=head2 Functions Returning C<B::SV>, C<B::AV>, C<B::HV>, and C<B::CV> objects
-
-For descriptions of the class hierarchy of these objects and the
-methods that can be called on them, see below, L<"OVERVIEW OF
-CLASSES"> and L<"SV-RELATED CLASSES">.
-
-=over 4
-
-=item sv_undef
-
-Returns the SV object corresponding to the C variable C<sv_undef>.
-
-=item sv_yes
-
-Returns the SV object corresponding to the C variable C<sv_yes>.
-
-=item sv_no
-
-Returns the SV object corresponding to the C variable C<sv_no>.
-
-=item svref_2object(SVREF)
-
-Takes a reference to any Perl value, and turns the referred-to value
-into an object in the appropriate B::OP-derived or B::SV-derived
-class. Apart from functions such as C<main_root>, this is the primary
-way to get an initial "handle" on an internal perl data structure
-which can then be followed with the other access methods.
-
-The returned object will only be valid as long as the underlying OPs
-and SVs continue to exist. Do not attempt to use the object after the
-underlying structures are freed.
-
-=item amagic_generation
-
-Returns the SV object corresponding to the C variable C<amagic_generation>.
-
-=item init_av
-
-Returns the AV object (i.e. in class B::AV) representing INIT blocks.
-
-=item check_av
-
-Returns the AV object (i.e. in class B::AV) representing CHECK blocks.
-
-=item begin_av
-
-Returns the AV object (i.e. in class B::AV) representing BEGIN blocks.
-
-=item end_av
-
-Returns the AV object (i.e. in class B::AV) representing END blocks.
-
-=item comppadlist
-
-Returns the AV object (i.e. in class B::AV) of the global comppadlist.
-
-=item regex_padav
-
-Only when perl was compiled with ithreads.
-
-=item main_cv
-
-Return the (faked) CV corresponding to the main part of the Perl
-program.
-
-=back
-
-=head2 Functions for Examining the Symbol Table
-
-=over 4
-
-=item walksymtable(SYMREF, METHOD, RECURSE, PREFIX)
-
-Walk the symbol table starting at SYMREF and call METHOD on each
-symbol (a B::GV object) visited. When the walk reaches package
-symbols (such as "Foo::") it invokes RECURSE, passing in the symbol
-name, and only recurses into the package if that sub returns true.
-
-PREFIX is the name of the SYMREF you're walking.
-
-For example:
-
- # Walk CGI's symbol table calling print_subs on each symbol.
- # Recurse only into CGI::Util::
- walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
- 'CGI::');
-
-print_subs() is a B::GV method you have declared. Also see L<"B::GV
-Methods">, below.
-
-=back
-
-=head2 Functions Returning C<B::OP> objects or for walking op trees
-
-For descriptions of the class hierarchy of these objects and the
-methods that can be called on them, see below, L<"OVERVIEW OF
-CLASSES"> and L<"OP-RELATED CLASSES">.
-
-=over 4
-
-=item main_root
-
-Returns the root op (i.e. an object in the appropriate B::OP-derived
-class) of the main part of the Perl program.
-
-=item main_start
-
-Returns the starting op of the main part of the Perl program.
-
-=item walkoptree(OP, METHOD)
-
-Does a tree-walk of the syntax tree based at OP and calls METHOD on
-each op it visits. Each node is visited before its children. If
-C<walkoptree_debug> (see below) has been called to turn debugging on then
-the method C<walkoptree_debug> is called on each op before METHOD is
-called.
-
-=item walkoptree_debug(DEBUG)
-
-Returns the current debugging flag for C<walkoptree>. If the optional
-DEBUG argument is non-zero, it sets the debugging flag to that. See
-the description of C<walkoptree> above for what the debugging flag
-does.
-
-=back
-
-=head2 Miscellaneous Utility Functions
-
-=over 4
-
-=item ppname(OPNUM)
-
-Return the PP function name (e.g. "pp_add") of op number OPNUM.
-
-=item hash(STR)
-
-Returns a string in the form "0x..." representing the value of the
-internal hash function used by perl on string STR.
-
-=item cast_I32(I)
-
-Casts I to the internal I32 type used by that perl.
-
-=item minus_c
-
-Does the equivalent of the C<-c> command-line option. Obviously, this
-is only useful in a BEGIN block or else the flag is set too late.
-
-=item cstring(STR)
-
-Returns a double-quote-surrounded escaped version of STR which can
-be used as a string in C source code.
-
-=item perlstring(STR)
-
-Returns a double-quote-surrounded escaped version of STR which can
-be used as a string in Perl source code.
-
-=item class(OBJ)
-
-Returns the class of an object without the part of the classname
-preceding the first C<"::">. This is used to turn C<"B::UNOP"> into
-C<"UNOP"> for example.
-
-=item threadsv_names
-
-In a perl compiled for threads, this returns a list of the special
-per-thread threadsv variables.
-
-=back
-
-
-
-
-=head1 OVERVIEW OF CLASSES
-
-The C structures used by Perl's internals to hold SV and OP
-information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
-class hierarchy and the C<B> module gives access to them via a true
-object hierarchy. Structure fields which point to other objects
-(whether types of SV or types of OP) are represented by the C<B>
-module as Perl objects of the appropriate class.
-
-The bulk of the C<B> module is the methods for accessing fields of
-these structures.
-
-Note that all access is read-only. You cannot modify the internals by
-using this module. Also, note that the B::OP and B::SV objects created
-by this module are only valid for as long as the underlying objects
-exist; their creation doesn't increase the reference counts of the
-underlying objects. Trying to access the fields of a freed object will
-give incomprehensible results, or worse.
-
-=head2 SV-RELATED CLASSES
-
-B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
-B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
-the obvious way to the underlying C structures of similar names. The
-inheritance hierarchy mimics the underlying C "inheritance". For 5.9.1
-and later this is:
-
- B::SV
- |
- +--------------+----------+------------+
- | | | |
- B::PV B::IV B::NV B::RV
- \ / /
- \ / /
- B::PVIV /
- \ /
- \ /
- \ /
- B::PVNV
- |
- |
- B::PVMG
- |
- +-----+----+------+-----+-----+
- | | | | | |
- B::BM B::AV B::GV B::HV B::CV B::IO
- | |
- B::PVLV |
- B::FM
-
-
-For 5.9.0 and earlier, PVLV is a direct subclass of PVMG, so the base
-of this diagram is
-
- |
- B::PVMG
- |
- +------+-----+----+------+-----+-----+
- | | | | | | |
- B::PVLV B::BM B::AV B::GV B::HV B::CV B::IO
- |
- |
- B::FM
-
-
-Access methods correspond to the underlying C macros for field access,
-usually with the leading "class indication" prefix removed (Sv, Av,
-Hv, ...). The leading prefix is only left in cases where its removal
-would cause a clash in method name. For example, C<GvREFCNT> stays
-as-is since its abbreviation would clash with the "superclass" method
-C<REFCNT> (corresponding to the C function C<SvREFCNT>).
-
-=head2 B::SV Methods
-
-=over 4
-
-=item REFCNT
-
-=item FLAGS
-
-=item object_2svref
-
-Returns a reference to the regular scalar corresponding to this
-B::SV object. In other words, this method is the inverse operation
-to the svref_2object() subroutine. This scalar and other data it points
-at should be considered read-only: modifying them is neither safe nor
-guaranteed to have a sensible effect.
-
-=back
-
-=head2 B::IV Methods
-
-=over 4
-
-=item IV
-
-Returns the value of the IV, I<interpreted as
-a signed integer>. This will be misleading
-if C<FLAGS & SVf_IVisUV>. Perhaps you want the
-C<int_value> method instead?
-
-=item IVX
-
-=item UVX
-
-=item int_value
-
-This method returns the value of the IV as an integer.
-It differs from C<IV> in that it returns the correct
-value regardless of whether it's stored signed or
-unsigned.
-
-=item needs64bits
-
-=item packiv
-
-=back
-
-=head2 B::NV Methods
-
-=over 4
-
-=item NV
-
-=item NVX
-
-=back
-
-=head2 B::RV Methods
-
-=over 4
-
-=item RV
-
-=back
-
-=head2 B::PV Methods
-
-=over 4
-
-=item PV
-
-This method is the one you usually want. It constructs a
-string using the length and offset information in the struct:
-for ordinary scalars it will return the string that you'd see
-from Perl, even if it contains null characters.
-
-=item RV
-
-Same as B::RV::RV, except that it will die() if the PV isn't
-a reference.
-
-=item PVX
-
-This method is less often useful. It assumes that the string
-stored in the struct is null-terminated, and disregards the
-length information.
-
-It is the appropriate method to use if you need to get the name
-of a lexical variable from a padname array. Lexical variable names
-are always stored with a null terminator, and the length field
-(SvCUR) is overloaded for other purposes and can't be relied on here.
-
-=back
-
-=head2 B::PVMG Methods
-
-=over 4
-
-=item MAGIC
-
-=item SvSTASH
-
-=back
-
-=head2 B::MAGIC Methods
-
-=over 4
-
-=item MOREMAGIC
-
-=item precomp
-
-Only valid on r-magic, returns the string that generated the regexp.
-
-=item PRIVATE
-
-=item TYPE
-
-=item FLAGS
-
-=item OBJ
-
-Will die() if called on r-magic.
-
-=item PTR
-
-=item REGEX
-
-Only valid on r-magic, returns the integer value of the REGEX stored
-in the MAGIC.
-
-=back
-
-=head2 B::PVLV Methods
-
-=over 4
-
-=item TARGOFF
-
-=item TARGLEN
-
-=item TYPE
-
-=item TARG
-
-=back
-
-=head2 B::BM Methods
-
-=over 4
-
-=item USEFUL
-
-=item PREVIOUS
-
-=item RARE
-
-=item TABLE
-
-=back
-
-=head2 B::GV Methods
-
-=over 4
-
-=item is_empty
-
-This method returns TRUE if the GP field of the GV is NULL.
-
-=item NAME
-
-=item SAFENAME
-
-This method returns the name of the glob, but if the first
-character of the name is a control character, then it converts
-it to ^X first, so that *^G would return "^G" rather than "\cG".
-
-It's useful if you want to print out the name of a variable.
-If you restrict yourself to globs which exist at compile-time
-then the result ought to be unambiguous, because code like
-C<${"^G"} = 1> is compiled as two ops - a constant string and
-a dereference (rv2gv) - so that the glob is created at runtime.
-
-If you're working with globs at runtime, and need to disambiguate
-*^G from *{"^G"}, then you should use the raw NAME method.
-
-=item STASH
-
-=item SV
-
-=item IO
-
-=item FORM
-
-=item AV
-
-=item HV
-
-=item EGV
-
-=item CV
-
-=item CVGEN
-
-=item LINE
-
-=item FILE
-
-=item FILEGV
-
-=item GvREFCNT
-
-=item FLAGS
-
-=back
-
-=head2 B::IO Methods
-
-=over 4
-
-=item LINES
-
-=item PAGE
-
-=item PAGE_LEN
-
-=item LINES_LEFT
-
-=item TOP_NAME
-
-=item TOP_GV
-
-=item FMT_NAME
-
-=item FMT_GV
-
-=item BOTTOM_NAME
-
-=item BOTTOM_GV
-
-=item SUBPROCESS
-
-=item IoTYPE
-
-=item IoFLAGS
-
-=item IsSTD
-
-Takes one arguments ( 'stdin' | 'stdout' | 'stderr' ) and returns true
-if the IoIFP of the object is equal to the handle whose name was
-passed as argument ( i.e. $io->IsSTD('stderr') is true if
-IoIFP($io) == PerlIO_stdin() ).
-
-=back
-
-=head2 B::AV Methods
-
-=over 4
-
-=item FILL
-
-=item MAX
-
-=item OFF
-
-=item ARRAY
-
-=item ARRAYelt
-
-Like C<ARRAY>, but takes an index as an argument to get only one element,
-rather than a list of all of them.
-
-=item AvFLAGS
-
-=back
-
-=head2 B::CV Methods
-
-=over 4
-
-=item STASH
-
-=item START
-
-=item ROOT
-
-=item GV
-
-=item FILE
-
-=item DEPTH
-
-=item PADLIST
-
-=item OUTSIDE
-
-=item OUTSIDE_SEQ
-
-=item XSUB
-
-=item XSUBANY
-
-For constant subroutines, returns the constant SV returned by the subroutine.
-
-=item CvFLAGS
-
-=item const_sv
-
-=back
-
-=head2 B::HV Methods
-
-=over 4
-
-=item FILL
-
-=item MAX
-
-=item KEYS
-
-=item RITER
-
-=item NAME
-
-=item PMROOT
-
-=item ARRAY
-
-=back
-
-=head2 OP-RELATED CLASSES
-
-C<B::OP>, C<B::UNOP>, C<B::BINOP>, C<B::LOGOP>, C<B::LISTOP>, C<B::PMOP>,
-C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<B::COP>.
-
-These classes correspond in the obvious way to the underlying C
-structures of similar names. The inheritance hierarchy mimics the
-underlying C "inheritance":
-
- B::OP
- |
- +---------------+--------+--------+
- | | | |
- B::UNOP B::SVOP B::PADOP B::COP
- ,' `-.
- / `--.
- B::BINOP B::LOGOP
- |
- |
- B::LISTOP
- ,' `.
- / \
- B::LOOP B::PMOP
-
-Access methods correspond to the underlying C structre field names,
-with the leading "class indication" prefix (C<"op_">) removed.
-
-=head2 B::OP Methods
-
-These methods get the values of similarly named fields within the OP
-data structure. See top of C<op.h> for more info.
-
-=over 4
-
-=item next
-
-=item sibling
-
-=item name
-
-This returns the op name as a string (e.g. "add", "rv2av").
-
-=item ppaddr
-
-This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
-"PL_ppaddr[OP_RV2AV]").
-
-=item desc
-
-This returns the op description from the global C PL_op_desc array
-(e.g. "addition" "array deref").
-
-=item targ
-
-=item type
-
-=item opt
-
-=item static
-
-=item flags
-
-=item private
-
-=item spare
-
-=back
-
-=head2 B::UNOP METHOD
-
-=over 4
-
-=item first
-
-=back
-
-=head2 B::BINOP METHOD
-
-=over 4
-
-=item last
-
-=back
-
-=head2 B::LOGOP METHOD
-
-=over 4
-
-=item other
-
-=back
-
-=head2 B::LISTOP METHOD
-
-=over 4
-
-=item children
-
-=back
-
-=head2 B::PMOP Methods
-
-=over 4
-
-=item pmreplroot
-
-=item pmreplstart
-
-=item pmnext
-
-=item pmregexp
-
-=item pmflags
-
-=item pmdynflags
-
-=item pmpermflags
-
-=item precomp
-
-=item pmoffset
-
-Only when perl was compiled with ithreads.
-
-=back
-
-=head2 B::SVOP METHOD
-
-=over 4
-
-=item sv
-
-=item gv
-
-=back
-
-=head2 B::PADOP METHOD
-
-=over 4
-
-=item padix
-
-=back
-
-=head2 B::PVOP METHOD
-
-=over 4
-
-=item pv
-
-=back
-
-=head2 B::LOOP Methods
-
-=over 4
-
-=item redoop
-
-=item nextop
-
-=item lastop
-
-=back
-
-=head2 B::COP Methods
-
-=over 4
-
-=item label
-
-=item stash
-
-=item stashpv
-
-=item file
-
-=item cop_seq
-
-=item arybase
-
-=item line
-
-=item warnings
-
-=item io
-
-=back
-
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Asmdata.pm b/Master/tlpkg/installer/perllib/B/Asmdata.pm
deleted file mode 100644
index 9e41d6dd757..00000000000
--- a/Master/tlpkg/installer/perllib/B/Asmdata.pm
+++ /dev/null
@@ -1,250 +0,0 @@
-# -#- buffer-read-only: t -#-
-#
-# Copyright (c) 1996-1999 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-#
-#
-# This file is autogenerated from bytecode.pl. Changes made here will be lost.
-#
-package B::Asmdata;
-
-our $VERSION = '1.01';
-
-use Exporter;
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
-our(%insn_data, @insn_name, @optype, @specialsv_name);
-
-@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
-@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE);
-
-# XXX insn_data is initialised this way because with a large
-# %insn_data = (foo => [...], bar => [...], ...) initialiser
-# I get a hard-to-track-down stack underflow and segfault.
-$insn_data{comment} = [35, \&PUT_comment_t, "GET_comment_t"];
-$insn_data{nop} = [10, \&PUT_none, "GET_none"];
-$insn_data{ret} = [0, \&PUT_none, "GET_none"];
-$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
-$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"];
-$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"];
-$insn_data{stop} = [4, \&PUT_U32, "GET_U32"];
-$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"];
-$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"];
-$insn_data{ldspecsvx} = [7, \&PUT_U8, "GET_U8"];
-$insn_data{newsv} = [8, \&PUT_U8, "GET_U8"];
-$insn_data{newsvx} = [9, \&PUT_U32, "GET_U32"];
-$insn_data{newop} = [11, \&PUT_U8, "GET_U8"];
-$insn_data{newopx} = [12, \&PUT_U16, "GET_U16"];
-$insn_data{newopn} = [13, \&PUT_U8, "GET_U8"];
-$insn_data{newpv} = [14, \&PUT_PV, "GET_PV"];
-$insn_data{pv_cur} = [15, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{pv_free} = [16, \&PUT_none, "GET_none"];
-$insn_data{sv_upgrade} = [17, \&PUT_U8, "GET_U8"];
-$insn_data{sv_refcnt} = [18, \&PUT_U32, "GET_U32"];
-$insn_data{sv_refcnt_add} = [19, \&PUT_I32, "GET_I32"];
-$insn_data{sv_flags} = [20, \&PUT_U32, "GET_U32"];
-$insn_data{xrv} = [21, \&PUT_svindex, "GET_svindex"];
-$insn_data{xpv} = [22, \&PUT_none, "GET_none"];
-$insn_data{xpv_cur} = [23, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{xpv_len} = [24, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{xiv} = [25, \&PUT_IV, "GET_IV"];
-$insn_data{xnv} = [26, \&PUT_NV, "GET_NV"];
-$insn_data{xlv_targoff} = [27, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{xlv_targlen} = [28, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{xlv_targ} = [29, \&PUT_svindex, "GET_svindex"];
-$insn_data{xlv_type} = [30, \&PUT_U8, "GET_U8"];
-$insn_data{xbm_useful} = [31, \&PUT_I32, "GET_I32"];
-$insn_data{xbm_previous} = [32, \&PUT_U16, "GET_U16"];
-$insn_data{xbm_rare} = [33, \&PUT_U8, "GET_U8"];
-$insn_data{xfm_lines} = [34, \&PUT_IV, "GET_IV"];
-$insn_data{xio_lines} = [36, \&PUT_IV, "GET_IV"];
-$insn_data{xio_page} = [37, \&PUT_IV, "GET_IV"];
-$insn_data{xio_page_len} = [38, \&PUT_IV, "GET_IV"];
-$insn_data{xio_lines_left} = [39, \&PUT_IV, "GET_IV"];
-$insn_data{xio_top_name} = [40, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{xio_top_gv} = [41, \&PUT_svindex, "GET_svindex"];
-$insn_data{xio_fmt_name} = [42, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{xio_fmt_gv} = [43, \&PUT_svindex, "GET_svindex"];
-$insn_data{xio_bottom_name} = [44, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{xio_bottom_gv} = [45, \&PUT_svindex, "GET_svindex"];
-$insn_data{xio_subprocess} = [46, \&PUT_U16, "GET_U16"];
-$insn_data{xio_type} = [47, \&PUT_U8, "GET_U8"];
-$insn_data{xio_flags} = [48, \&PUT_U8, "GET_U8"];
-$insn_data{xcv_xsubany} = [49, \&PUT_svindex, "GET_svindex"];
-$insn_data{xcv_stash} = [50, \&PUT_svindex, "GET_svindex"];
-$insn_data{xcv_start} = [51, \&PUT_opindex, "GET_opindex"];
-$insn_data{xcv_root} = [52, \&PUT_opindex, "GET_opindex"];
-$insn_data{xcv_gv} = [53, \&PUT_svindex, "GET_svindex"];
-$insn_data{xcv_file} = [54, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{xcv_depth} = [55, \&PUT_long, "GET_long"];
-$insn_data{xcv_padlist} = [56, \&PUT_svindex, "GET_svindex"];
-$insn_data{xcv_outside} = [57, \&PUT_svindex, "GET_svindex"];
-$insn_data{xcv_outside_seq} = [58, \&PUT_U32, "GET_U32"];
-$insn_data{xcv_flags} = [59, \&PUT_U16, "GET_U16"];
-$insn_data{av_extend} = [60, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{av_pushx} = [61, \&PUT_svindex, "GET_svindex"];
-$insn_data{av_push} = [62, \&PUT_svindex, "GET_svindex"];
-$insn_data{xav_fill} = [63, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{xav_max} = [64, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{xav_flags} = [65, \&PUT_U8, "GET_U8"];
-$insn_data{xhv_riter} = [66, \&PUT_I32, "GET_I32"];
-$insn_data{xhv_name} = [67, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{xhv_pmroot} = [68, \&PUT_opindex, "GET_opindex"];
-$insn_data{hv_store} = [69, \&PUT_svindex, "GET_svindex"];
-$insn_data{sv_magic} = [70, \&PUT_U8, "GET_U8"];
-$insn_data{mg_obj} = [71, \&PUT_svindex, "GET_svindex"];
-$insn_data{mg_private} = [72, \&PUT_U16, "GET_U16"];
-$insn_data{mg_flags} = [73, \&PUT_U8, "GET_U8"];
-$insn_data{mg_name} = [74, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{mg_namex} = [75, \&PUT_svindex, "GET_svindex"];
-$insn_data{xmg_stash} = [76, \&PUT_svindex, "GET_svindex"];
-$insn_data{gv_fetchpv} = [77, \&PUT_strconst, "GET_strconst"];
-$insn_data{gv_fetchpvx} = [78, \&PUT_strconst, "GET_strconst"];
-$insn_data{gv_stashpv} = [79, \&PUT_strconst, "GET_strconst"];
-$insn_data{gv_stashpvx} = [80, \&PUT_strconst, "GET_strconst"];
-$insn_data{gp_sv} = [81, \&PUT_svindex, "GET_svindex"];
-$insn_data{gp_refcnt} = [82, \&PUT_U32, "GET_U32"];
-$insn_data{gp_refcnt_add} = [83, \&PUT_I32, "GET_I32"];
-$insn_data{gp_av} = [84, \&PUT_svindex, "GET_svindex"];
-$insn_data{gp_hv} = [85, \&PUT_svindex, "GET_svindex"];
-$insn_data{gp_cv} = [86, \&PUT_svindex, "GET_svindex"];
-$insn_data{gp_file} = [87, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{gp_io} = [88, \&PUT_svindex, "GET_svindex"];
-$insn_data{gp_form} = [89, \&PUT_svindex, "GET_svindex"];
-$insn_data{gp_cvgen} = [90, \&PUT_U32, "GET_U32"];
-$insn_data{gp_line} = [91, \&PUT_U32, "GET_U32"];
-$insn_data{gp_share} = [92, \&PUT_svindex, "GET_svindex"];
-$insn_data{xgv_flags} = [93, \&PUT_U8, "GET_U8"];
-$insn_data{op_next} = [94, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_sibling} = [95, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_ppaddr} = [96, \&PUT_strconst, "GET_strconst"];
-$insn_data{op_targ} = [97, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{op_type} = [98, \&PUT_U16, "GET_U16"];
-$insn_data{op_seq} = [99, \&PUT_U16, "GET_U16"];
-$insn_data{op_flags} = [100, \&PUT_U8, "GET_U8"];
-$insn_data{op_private} = [101, \&PUT_U8, "GET_U8"];
-$insn_data{op_first} = [102, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_last} = [103, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_other} = [104, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_pmreplroot} = [105, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_pmreplstart} = [106, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_pmnext} = [107, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_pmstashpv} = [108, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{op_pmreplrootpo} = [109, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{op_pmstash} = [110, \&PUT_svindex, "GET_svindex"];
-$insn_data{op_pmreplrootgv} = [111, \&PUT_svindex, "GET_svindex"];
-$insn_data{pregcomp} = [112, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{op_pmflags} = [113, \&PUT_U16, "GET_U16"];
-$insn_data{op_pmpermflags} = [114, \&PUT_U16, "GET_U16"];
-$insn_data{op_pmdynflags} = [115, \&PUT_U8, "GET_U8"];
-$insn_data{op_sv} = [116, \&PUT_svindex, "GET_svindex"];
-$insn_data{op_padix} = [117, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{op_pv} = [118, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{op_pv_tr} = [119, \&PUT_op_tr_array, "GET_op_tr_array"];
-$insn_data{op_redoop} = [120, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_nextop} = [121, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_lastop} = [122, \&PUT_opindex, "GET_opindex"];
-$insn_data{cop_label} = [123, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{cop_stashpv} = [124, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{cop_file} = [125, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{cop_stash} = [126, \&PUT_svindex, "GET_svindex"];
-$insn_data{cop_filegv} = [127, \&PUT_svindex, "GET_svindex"];
-$insn_data{cop_seq} = [128, \&PUT_U32, "GET_U32"];
-$insn_data{cop_arybase} = [129, \&PUT_I32, "GET_I32"];
-$insn_data{cop_line} = [130, \&PUT_U32, "GET_U32"];
-$insn_data{cop_io} = [131, \&PUT_svindex, "GET_svindex"];
-$insn_data{cop_warnings} = [132, \&PUT_svindex, "GET_svindex"];
-$insn_data{main_start} = [133, \&PUT_opindex, "GET_opindex"];
-$insn_data{main_root} = [134, \&PUT_opindex, "GET_opindex"];
-$insn_data{main_cv} = [135, \&PUT_svindex, "GET_svindex"];
-$insn_data{curpad} = [136, \&PUT_svindex, "GET_svindex"];
-$insn_data{push_begin} = [137, \&PUT_svindex, "GET_svindex"];
-$insn_data{push_init} = [138, \&PUT_svindex, "GET_svindex"];
-$insn_data{push_end} = [139, \&PUT_svindex, "GET_svindex"];
-$insn_data{curstash} = [140, \&PUT_svindex, "GET_svindex"];
-$insn_data{defstash} = [141, \&PUT_svindex, "GET_svindex"];
-$insn_data{data} = [142, \&PUT_U8, "GET_U8"];
-$insn_data{incav} = [143, \&PUT_svindex, "GET_svindex"];
-$insn_data{load_glob} = [144, \&PUT_svindex, "GET_svindex"];
-$insn_data{regex_padav} = [145, \&PUT_svindex, "GET_svindex"];
-$insn_data{dowarn} = [146, \&PUT_U8, "GET_U8"];
-$insn_data{comppad_name} = [147, \&PUT_svindex, "GET_svindex"];
-$insn_data{xgv_stash} = [148, \&PUT_svindex, "GET_svindex"];
-$insn_data{signal} = [149, \&PUT_strconst, "GET_strconst"];
-$insn_data{formfeed} = [150, \&PUT_svindex, "GET_svindex"];
-
-my ($insn_name, $insn_data);
-while (($insn_name, $insn_data) = each %insn_data) {
- $insn_name[$insn_data->[0]] = $insn_name;
-}
-# Fill in any gaps
-@insn_name = map($_ || "unused", @insn_name);
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode
-
-=head1 SYNOPSIS
-
- use B::Asmdata qw(%insn_data @insn_name @optype @specialsv_name);
-
-=head1 DESCRIPTION
-
-Provides information about Perl ops in order to generate bytecode via
-a bunch of exported variables. Its mostly used by B::Assembler and
-B::Disassembler.
-
-=over 4
-
-=item %insn_data
-
- my($bytecode_num, $put_sub, $get_meth) = @$insn_data{$op_name};
-
-For a given $op_name (for example, 'cop_label', 'sv_flags', etc...)
-you get an array ref containing the bytecode number of the op, a
-reference to the subroutine used to 'PUT', and the name of the method
-used to 'GET'.
-
-=for _private
-Add more detail about what $put_sub and $get_meth are and how to use them.
-
-=item @insn_name
-
- my $op_name = $insn_name[$bytecode_num];
-
-A simple mapping of the bytecode number to the name of the op.
-Suitable for using with %insn_data like so:
-
- my $op_info = $insn_data{$insn_name[$bytecode_num]};
-
-=item @optype
-
- my $op_type = $optype[$op_type_num];
-
-A simple mapping of the op type number to its type (like 'COP' or 'BINOP').
-
-=item @specialsv_name
-
- my $sv_name = $specialsv_name[$sv_index];
-
-Certain SV types are considered 'special'. They're represented by
-B::SPECIAL and are referred to by a number from the specialsv_list.
-This array maps that number back to the name of the SV (like 'Nullsv'
-or '&PL_sv_undef').
-
-=back
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
-
-# ex: set ro:
diff --git a/Master/tlpkg/installer/perllib/B/Assembler.pm b/Master/tlpkg/installer/perllib/B/Assembler.pm
deleted file mode 100644
index f312273ce36..00000000000
--- a/Master/tlpkg/installer/perllib/B/Assembler.pm
+++ /dev/null
@@ -1,328 +0,0 @@
-# Assembler.pm
-#
-# Copyright (c) 1996 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-
-package B::Assembler;
-use Exporter;
-use B qw(ppname);
-use B::Asmdata qw(%insn_data @insn_name);
-use Config qw(%Config);
-require ByteLoader; # we just need its $VERSION
-
-no warnings; # XXX
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
-$VERSION = 0.07;
-
-use strict;
-my %opnumber;
-my ($i, $opname);
-for ($i = 0; defined($opname = ppname($i)); $i++) {
- $opnumber{$opname} = $i;
-}
-
-my($linenum, $errors, $out); # global state, set up by newasm
-
-sub error {
- my $str = shift;
- warn "$linenum: $str\n";
- $errors++;
-}
-
-my $debug = 0;
-sub debug { $debug = shift }
-
-sub limcheck($$$$){
- my( $val, $lo, $hi, $loc ) = @_;
- if( $val < $lo || $hi < $val ){
- error "argument for $loc outside [$lo, $hi]: $val";
- $val = $hi;
- }
- return $val;
-}
-
-#
-# First define all the data conversion subs to which Asmdata will refer
-#
-
-sub B::Asmdata::PUT_U8 {
- my $arg = shift;
- my $c = uncstring($arg);
- if (defined($c)) {
- if (length($c) != 1) {
- error "argument for U8 is too long: $c";
- $c = substr($c, 0, 1);
- }
- } else {
- $arg = limcheck( $arg, 0, 0xff, 'U8' );
- $c = chr($arg);
- }
- return $c;
-}
-
-sub B::Asmdata::PUT_U16 {
- my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
- pack("S", $arg);
-}
-sub B::Asmdata::PUT_U32 {
- my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
- pack("L", $arg);
-}
-sub B::Asmdata::PUT_I32 {
- my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
- pack("l", $arg);
-}
-sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
- # may not even be portable between compilers
-sub B::Asmdata::PUT_objindex { # could allow names here
- my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
- pack("L", $arg);
-}
-sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
-sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
-sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
-
-sub B::Asmdata::PUT_strconst {
- my $arg = shift;
- my $str = uncstring($arg);
- if (!defined($str)) {
- error "bad string constant: $arg";
- $str = '';
- }
- if ($str =~ s/\0//g) {
- error "string constant argument contains NUL: $arg";
- $str = '';
- }
- return $str . "\0";
-}
-
-sub B::Asmdata::PUT_pvcontents {
- my $arg = shift;
- error "extraneous argument: $arg" if defined $arg;
- return "";
-}
-sub B::Asmdata::PUT_PV {
- my $arg = shift;
- my $str = uncstring($arg);
- if( ! defined($str) ){
- error "bad string argument: $arg";
- $str = '';
- }
- return pack("L", length($str)) . $str;
-}
-sub B::Asmdata::PUT_comment_t {
- my $arg = shift;
- $arg = uncstring($arg);
- error "bad string argument: $arg" unless defined($arg);
- if ($arg =~ s/\n//g) {
- error "comment argument contains linefeed: $arg";
- }
- return $arg . "\n";
-}
-sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
-sub B::Asmdata::PUT_none {
- my $arg = shift;
- error "extraneous argument: $arg" if defined $arg;
- return "";
-}
-sub B::Asmdata::PUT_op_tr_array {
- my @ary = split /\s*,\s*/, shift;
- return pack "S*", @ary;
-}
-
-sub B::Asmdata::PUT_IV64 {
- return pack "Q", shift;
-}
-
-sub B::Asmdata::PUT_IV {
- $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
-}
-
-sub B::Asmdata::PUT_PADOFFSET {
- $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
-}
-
-sub B::Asmdata::PUT_long {
- $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
-}
-
-my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
- b => "\b", f => "\f", v => "\013");
-
-sub uncstring {
- my $s = shift;
- $s =~ s/^"// and $s =~ s/"$// or return undef;
- $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
- return $s;
-}
-
-sub strip_comments {
- my $stmt = shift;
- # Comments only allowed in instructions which don't take string arguments
- # Treat string as a single line so .* eats \n characters.
- $stmt =~ s{
- ^\s* # Ignore leading whitespace
- (
- [^"]* # A double quote '"' indicates a string argument. If we
- # find a double quote, the match fails and we strip nothing.
- )
- \s*\# # Any amount of whitespace plus the comment marker...
- .*$ # ...which carries on to end-of-string.
- }{$1}sx; # Keep only the instruction and optional argument.
- return $stmt;
-}
-
-# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
-# ptrsize, byteorder
-# nvtype is irrelevant (floats are stored as strings)
-# byteorder is strconst not U32 because of varying size issues
-
-sub gen_header {
- my $header = "";
-
- $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
- $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
- $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
- $header .= B::Asmdata::PUT_U32($Config{ivsize});
- $header .= B::Asmdata::PUT_U32($Config{ptrsize});
- $header;
-}
-
-sub parse_statement {
- my $stmt = shift;
- my ($insn, $arg) = $stmt =~ m{
- ^\s* # allow (but ignore) leading whitespace
- (.*?) # Instruction continues up until...
- (?: # ...an optional whitespace+argument group
- \s+ # first whitespace.
- (.*) # The argument is all the rest (newlines included).
- )?$ # anchor at end-of-line
- }sx;
- if (defined($arg)) {
- if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
- $arg = hex($arg);
- } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
- $arg = oct($arg);
- } elsif ($arg =~ /^pp_/) {
- $arg =~ s/\s*$//; # strip trailing whitespace
- my $opnum = $opnumber{$arg};
- if (defined($opnum)) {
- $arg = $opnum;
- } else {
- error qq(No such op type "$arg");
- $arg = 0;
- }
- }
- }
- return ($insn, $arg);
-}
-
-sub assemble_insn {
- my ($insn, $arg) = @_;
- my $data = $insn_data{$insn};
- if (defined($data)) {
- my ($bytecode, $putsub) = @{$data}[0, 1];
- my $argcode = &$putsub($arg);
- return chr($bytecode).$argcode;
- } else {
- error qq(no such instruction "$insn");
- return "";
- }
-}
-
-sub assemble_fh {
- my ($fh, $out) = @_;
- my $line;
- my $asm = newasm($out);
- while ($line = <$fh>) {
- assemble($line);
- }
- endasm();
-}
-
-sub newasm {
- my($outsub) = @_;
-
- die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
- die <<EOD if ref $out;
-Can't have multiple byteassembly sessions at once!
- (perhaps you forgot an endasm()?)
-EOD
-
- $linenum = $errors = 0;
- $out = $outsub;
-
- $out->(gen_header());
-}
-
-sub endasm {
- if ($errors) {
- die "There were $errors assembly errors\n";
- }
- $linenum = $errors = $out = 0;
-}
-
-sub assemble {
- my($line) = @_;
- my ($insn, $arg);
- $linenum++;
- chomp $line;
- if ($debug) {
- my $quotedline = $line;
- $quotedline =~ s/\\/\\\\/g;
- $quotedline =~ s/"/\\"/g;
- $out->(assemble_insn("comment", qq("$quotedline")));
- }
- if( $line = strip_comments($line) ){
- ($insn, $arg) = parse_statement($line);
- $out->(assemble_insn($insn, $arg));
- if ($debug) {
- $out->(assemble_insn("nop", undef));
- }
- }
-}
-
-### temporary workaround
-
-sub asm {
- return if $_[0] =~ /\s*\W/;
- if (defined $_[1]) {
- return if $_[1] eq "0" and
- $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;
- return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
- }
- assemble "@_";
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Assembler - Assemble Perl bytecode
-
-=head1 SYNOPSIS
-
- use B::Assembler qw(newasm endasm assemble);
- newasm(\&printsub); # sets up for assembly
- assemble($buf); # assembles one line
- endasm(); # closes down
-
- use B::Assembler qw(assemble_fh);
- assemble_fh($fh, \&printsub); # assemble everything in $fh
-
-=head1 DESCRIPTION
-
-See F<ext/B/B/Assembler.pm>.
-
-=head1 AUTHORS
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Bblock.pm b/Master/tlpkg/installer/perllib/B/Bblock.pm
deleted file mode 100644
index 9566d125aaa..00000000000
--- a/Master/tlpkg/installer/perllib/B/Bblock.pm
+++ /dev/null
@@ -1,224 +0,0 @@
-package B::Bblock;
-
-our $VERSION = '1.02_01';
-
-use Exporter ();
-@ISA = "Exporter";
-@EXPORT_OK = qw(find_leaders);
-
-use B qw(peekop walkoptree walkoptree_exec
- main_root main_start svref_2object
- OPf_SPECIAL OPf_STACKED );
-
-use B::Concise qw(concise_cv concise_main set_style_standard);
-use strict;
-
-my $bblock;
-my @bblock_ends;
-
-sub mark_leader {
- my $op = shift;
- if ($$op) {
- $bblock->{$$op} = $op;
- }
-}
-
-sub remove_sortblock{
- foreach (keys %$bblock){
- my $leader=$$bblock{$_};
- delete $$bblock{$_} if( $leader == 0);
- }
-}
-sub find_leaders {
- my ($root, $start) = @_;
- $bblock = {};
- mark_leader($start) if ( ref $start ne "B::NULL" );
- walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
- remove_sortblock();
- return $bblock;
-}
-
-# Debugging
-sub walk_bblocks {
- my ($root, $start) = @_;
- my ($op, $lastop, $leader, $bb);
- $bblock = {};
- mark_leader($start);
- walkoptree($root, "mark_if_leader");
- my @leaders = values %$bblock;
- while ($leader = shift @leaders) {
- $lastop = $leader;
- $op = $leader->next;
- while ($$op && !exists($bblock->{$$op})) {
- $bblock->{$$op} = $leader;
- $lastop = $op;
- $op = $op->next;
- }
- push(@bblock_ends, [$leader, $lastop]);
- }
- foreach $bb (@bblock_ends) {
- ($leader, $lastop) = @$bb;
- printf "%s .. %s\n", peekop($leader), peekop($lastop);
- for ($op = $leader; $$op != $$lastop; $op = $op->next) {
- printf " %s\n", peekop($op);
- }
- printf " %s\n", peekop($lastop);
- }
-}
-
-sub walk_bblocks_obj {
- my $cvref = shift;
- my $cv = svref_2object($cvref);
- walk_bblocks($cv->ROOT, $cv->START);
-}
-
-sub B::OP::mark_if_leader {}
-
-sub B::COP::mark_if_leader {
- my $op = shift;
- if ($op->label) {
- mark_leader($op);
- }
-}
-
-sub B::LOOP::mark_if_leader {
- my $op = shift;
- mark_leader($op->next);
- mark_leader($op->nextop);
- mark_leader($op->redoop);
- mark_leader($op->lastop->next);
-}
-
-sub B::LOGOP::mark_if_leader {
- my $op = shift;
- my $opname = $op->name;
- mark_leader($op->next);
- if ($opname eq "entertry") {
- mark_leader($op->other->next);
- } else {
- mark_leader($op->other);
- }
-}
-
-sub B::LISTOP::mark_if_leader {
- my $op = shift;
- my $first=$op->first;
- $first=$first->next while ($first->name eq "null");
- mark_leader($op->first) unless (exists( $bblock->{$$first}));
- mark_leader($op->next);
- if ($op->name eq "sort" and $op->flags & OPf_SPECIAL
- and $op->flags & OPf_STACKED){
- my $root=$op->first->sibling->first;
- my $leader=$root->first;
- $bblock->{$$leader} = 0;
- }
-}
-
-sub B::PMOP::mark_if_leader {
- my $op = shift;
- if ($op->name ne "pushre") {
- my $replroot = $op->pmreplroot;
- if ($$replroot) {
- mark_leader($replroot);
- mark_leader($op->next);
- mark_leader($op->pmreplstart);
- }
- }
-}
-
-# PMOP stuff omitted
-
-sub compile {
- my @options = @_;
- B::clearsym();
- if (@options) {
- return sub {
- my $objname;
- foreach $objname (@options) {
- $objname = "main::$objname" unless $objname =~ /::/;
- eval "walk_bblocks_obj(\\&$objname)";
- die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
- print "-------\n";
- set_style_standard("terse");
- eval "concise_cv('exec', \\&$objname)";
- die "concise_cv('exec', \\&$objname) failed: $@" if $@;
- }
- }
- } else {
- return sub {
- walk_bblocks(main_root, main_start);
- print "-------\n";
- set_style_standard("terse");
- concise_main("exec");
- };
- }
-}
-
-# Basic block leaders:
-# Any COP (pp_nextstate) with a non-NULL label
-# [The op after a pp_enter] Omit
-# [The op after a pp_entersub. Don't count this one.]
-# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
-# The ops pointed at by op_next and op_other of a LOGOP, except
-# for pp_entertry which has op_next and op_other->op_next
-# The op pointed at by op_pmreplstart of a PMOP
-# The op pointed at by op_other->op_pmreplstart of pp_substcont?
-# [The op after a pp_return] Omit
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Bblock - Walk basic blocks
-
-=head1 SYNOPSIS
-
- # External interface
- perl -MO=Bblock[,OPTIONS] foo.pl
-
- # Programmatic API
- use B::Bblock qw(find_leaders);
- my $leaders = find_leaders($root_op, $start_op);
-
-=head1 DESCRIPTION
-
-This module is used by the B::CC back end. It walks "basic blocks".
-A basic block is a series of operations which is known to execute from
-start to finish, with no possibility of branching or halting.
-
-It can be used either stand alone or from inside another program.
-
-=for _private
-Somebody who understands the stand-alone options document them, please.
-
-=head2 Functions
-
-=over 4
-
-=item B<find_leaders>
-
- my $leaders = find_leaders($root_op, $start_op);
-
-Given the root of the op tree and an op from which to start
-processing, it will return a hash ref representing all the ops which
-start a block.
-
-=for _private
-The above description may be somewhat wrong.
-
-The values of %$leaders are the op objects themselves. Keys are $$op
-addresses.
-
-=for _private
-Above cribbed from B::CC's comments. What's a $$op address?
-
-=back
-
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Bytecode.pm b/Master/tlpkg/installer/perllib/B/Bytecode.pm
deleted file mode 100644
index 250569ae57b..00000000000
--- a/Master/tlpkg/installer/perllib/B/Bytecode.pm
+++ /dev/null
@@ -1,889 +0,0 @@
-# B::Bytecode.pm
-# Copyright (c) 2003 Enache Adrian. All rights reserved.
-# This module is free software; you can redistribute and/or modify
-# it under the same terms as Perl itself.
-
-# Based on the original Bytecode.pm module written by Malcolm Beattie.
-
-package B::Bytecode;
-
-our $VERSION = '1.01_01';
-
-use strict;
-use Config;
-use B qw(class main_cv main_root main_start cstring comppadlist
- defstash curstash begin_av init_av end_av inc_gv warnhook diehook
- dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
- OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
-use B::Asmdata qw(@specialsv_name);
-use B::Assembler qw(asm newasm endasm);
-
-#################################################
-
-my ($varix, $opix, $savebegins, %walked, %files, @cloop);
-my %strtab = (0,0);
-my %svtab = (0,0);
-my %optab = (0,0);
-my %spectab = (0,0);
-my $tix = 1;
-sub asm;
-sub nice ($) { }
-
-BEGIN {
- my $ithreads = $Config{'useithreads'} eq 'define';
- eval qq{
- sub ITHREADS() { $ithreads }
- sub VERSION() { $] }
- }; die $@ if $@;
-}
-
-#################################################
-
-sub pvstring {
- my $pv = shift;
- defined($pv) ? cstring ($pv."\0") : "\"\"";
-}
-
-sub pvix {
- my $str = pvstring shift;
- my $ix = $strtab{$str};
- defined($ix) ? $ix : do {
- asm "newpv", $str;
- asm "stpv", $strtab{$str} = $tix;
- $tix++;
- }
-}
-
-sub B::OP::ix {
- my $op = shift;
- my $ix = $optab{$$op};
- defined($ix) ? $ix : do {
- nice "[".$op->name." $tix]";
- asm "newopx", $op->size | $op->type <<7;
- $optab{$$op} = $opix = $ix = $tix++;
- $op->bsave($ix);
- $ix;
- }
-}
-
-sub B::SPECIAL::ix {
- my $spec = shift;
- my $ix = $spectab{$$spec};
- defined($ix) ? $ix : do {
- nice '['.$specialsv_name[$$spec].']';
- asm "ldspecsvx", $$spec;
- $spectab{$$spec} = $varix = $tix++;
- }
-}
-
-sub B::SV::ix {
- my $sv = shift;
- my $ix = $svtab{$$sv};
- defined($ix) ? $ix : do {
- nice '['.class($sv).']';
- asm "newsvx", $sv->FLAGS;
- $svtab{$$sv} = $varix = $ix = $tix++;
- $sv->bsave($ix);
- $ix;
- }
-}
-
-sub B::GV::ix {
- my ($gv,$desired) = @_;
- my $ix = $svtab{$$gv};
- defined($ix) ? $ix : do {
- if ($gv->GP) {
- my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
- nice "[GV]";
- my $name = $gv->STASH->NAME . "::" . $gv->NAME;
- asm "gv_fetchpvx", cstring $name;
- $svtab{$$gv} = $varix = $ix = $tix++;
- asm "sv_flags", $gv->FLAGS;
- asm "sv_refcnt", $gv->REFCNT;
- asm "xgv_flags", $gv->GvFLAGS;
-
- asm "gp_refcnt", $gv->GvREFCNT;
- asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
- return $ix
- unless $desired || desired $gv;
- $svix = $gv->SV->ix;
- $avix = $gv->AV->ix;
- $hvix = $gv->HV->ix;
-
- # XXX {{{{
- my $cv = $gv->CV;
- $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
- my $form = $gv->FORM;
- $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
-
- $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
- # }}}} XXX
-
- nice "-GV-",
- asm "ldsv", $varix = $ix unless $ix == $varix;
- asm "gp_sv", $svix;
- asm "gp_av", $avix;
- asm "gp_hv", $hvix;
- asm "gp_cv", $cvix;
- asm "gp_io", $ioix;
- asm "gp_cvgen", $gv->CVGEN;
- asm "gp_form", $formix;
- asm "gp_file", pvix $gv->FILE;
- asm "gp_line", $gv->LINE;
- asm "formfeed", $svix if $name eq "main::\cL";
- } else {
- nice "[GV]";
- asm "newsvx", $gv->FLAGS;
- $svtab{$$gv} = $varix = $ix = $tix++;
- my $stashix = $gv->STASH->ix;
- $gv->B::PVMG::bsave($ix);
- asm "xgv_flags", $gv->GvFLAGS;
- asm "xgv_stash", $stashix;
- }
- $ix;
- }
-}
-
-sub B::HV::ix {
- my $hv = shift;
- my $ix = $svtab{$$hv};
- defined($ix) ? $ix : do {
- my ($ix,$i,@array);
- my $name = $hv->NAME;
- if ($name) {
- nice "[STASH]";
- asm "gv_stashpvx", cstring $name;
- asm "sv_flags", $hv->FLAGS;
- $svtab{$$hv} = $varix = $ix = $tix++;
- asm "xhv_name", pvix $name;
- # my $pmrootix = $hv->PMROOT->ix; # XXX
- asm "ldsv", $varix = $ix unless $ix == $varix;
- # asm "xhv_pmroot", $pmrootix; # XXX
- } else {
- nice "[HV]";
- asm "newsvx", $hv->FLAGS;
- $svtab{$$hv} = $varix = $ix = $tix++;
- my $stashix = $hv->SvSTASH->ix;
- for (@array = $hv->ARRAY) {
- next if $i = not $i;
- $_ = $_->ix;
- }
- nice "-HV-",
- asm "ldsv", $varix = $ix unless $ix == $varix;
- ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
- for @array;
- if (VERSION < 5.009) {
- asm "xnv", $hv->NVX;
- }
- asm "xmg_stash", $stashix;
- asm "xhv_riter", $hv->RITER;
- }
- asm "sv_refcnt", $hv->REFCNT;
- $ix;
- }
-}
-
-sub B::NULL::ix {
- my $sv = shift;
- $$sv ? $sv->B::SV::ix : 0;
-}
-
-sub B::NULL::opwalk { 0 }
-
-#################################################
-
-sub B::NULL::bsave {
- my ($sv,$ix) = @_;
-
- nice '-'.class($sv).'-',
- asm "ldsv", $varix = $ix unless $ix == $varix;
- asm "sv_refcnt", $sv->REFCNT;
-}
-
-sub B::SV::bsave;
- *B::SV::bsave = *B::NULL::bsave;
-
-sub B::RV::bsave {
- my ($sv,$ix) = @_;
- my $rvix = $sv->RV->ix;
- $sv->B::NULL::bsave($ix);
- asm "xrv", $rvix;
-}
-
-sub B::PV::bsave {
- my ($sv,$ix) = @_;
- $sv->B::NULL::bsave($ix);
- asm "newpv", pvstring $sv->PVBM;
- asm "xpv";
-}
-
-sub B::IV::bsave {
- my ($sv,$ix) = @_;
- $sv->B::NULL::bsave($ix);
- asm "xiv", $sv->IVX;
-}
-
-sub B::NV::bsave {
- my ($sv,$ix) = @_;
- $sv->B::NULL::bsave($ix);
- asm "xnv", sprintf "%.40g", $sv->NVX;
-}
-
-sub B::PVIV::bsave {
- my ($sv,$ix) = @_;
- $sv->POK ?
- $sv->B::PV::bsave($ix):
- $sv->ROK ?
- $sv->B::RV::bsave($ix):
- $sv->B::NULL::bsave($ix);
- if (VERSION >= 5.009) {
- # See note below in B::PVNV::bsave
- return if $sv->isa('B::AV');
- return if $sv->isa('B::HV');
- }
- asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
- "0 but true" : $sv->IVX;
-}
-
-sub B::PVNV::bsave {
- my ($sv,$ix) = @_;
- $sv->B::PVIV::bsave($ix);
- if (VERSION >= 5.009) {
- # Magical AVs end up here, but AVs now don't have an NV slot actually
- # allocated. Hence don't write out assembly to store the NV slot if
- # we're actually an array.
- return if $sv->isa('B::AV');
- # Likewise HVs have no NV slot actually allocated.
- # I don't think that they can get here, but better safe than sorry
- return if $sv->isa('B::HV');
- }
- asm "xnv", sprintf "%.40g", $sv->NVX;
-}
-
-sub B::PVMG::domagic {
- my ($sv,$ix) = @_;
- nice '-MAGICAL-';
- my @mglist = $sv->MAGIC;
- my (@mgix, @namix);
- for (@mglist) {
- push @mgix, $_->OBJ->ix;
- push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
- }
-
- nice '-'.class($sv).'-',
- asm "ldsv", $varix = $ix unless $ix == $varix;
- for (@mglist) {
- asm "sv_magic", cstring $_->TYPE;
- asm "mg_obj", shift @mgix;
- my $length = $_->LENGTH;
- if ($length == B::HEf_SVKEY) {
- asm "mg_namex", shift @namix;
- } elsif ($length) {
- asm "newpv", pvstring $_->PTR;
- asm "mg_name";
- }
- }
-}
-
-sub B::PVMG::bsave {
- my ($sv,$ix) = @_;
- my $stashix = $sv->SvSTASH->ix;
- $sv->B::PVNV::bsave($ix);
- asm "xmg_stash", $stashix;
- $sv->domagic($ix) if $sv->MAGICAL;
-}
-
-sub B::PVLV::bsave {
- my ($sv,$ix) = @_;
- my $targix = $sv->TARG->ix;
- $sv->B::PVMG::bsave($ix);
- asm "xlv_targ", $targix;
- asm "xlv_targoff", $sv->TARGOFF;
- asm "xlv_targlen", $sv->TARGLEN;
- asm "xlv_type", $sv->TYPE;
-
-}
-
-sub B::BM::bsave {
- my ($sv,$ix) = @_;
- $sv->B::PVMG::bsave($ix);
- asm "xpv_cur", $sv->CUR;
- asm "xbm_useful", $sv->USEFUL;
- asm "xbm_previous", $sv->PREVIOUS;
- asm "xbm_rare", $sv->RARE;
-}
-
-sub B::IO::bsave {
- my ($io,$ix) = @_;
- my $topix = $io->TOP_GV->ix;
- my $fmtix = $io->FMT_GV->ix;
- my $bottomix = $io->BOTTOM_GV->ix;
- $io->B::PVMG::bsave($ix);
- asm "xio_lines", $io->LINES;
- asm "xio_page", $io->PAGE;
- asm "xio_page_len", $io->PAGE_LEN;
- asm "xio_lines_left", $io->LINES_LEFT;
- asm "xio_top_name", pvix $io->TOP_NAME;
- asm "xio_top_gv", $topix;
- asm "xio_fmt_name", pvix $io->FMT_NAME;
- asm "xio_fmt_gv", $fmtix;
- asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
- asm "xio_bottom_gv", $bottomix;
- asm "xio_subprocess", $io->SUBPROCESS;
- asm "xio_type", ord $io->IoTYPE;
- # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
-}
-
-sub B::CV::bsave {
- my ($cv,$ix) = @_;
- my $stashix = $cv->STASH->ix;
- my $gvix = $cv->GV->ix;
- my $padlistix = $cv->PADLIST->ix;
- my $outsideix = $cv->OUTSIDE->ix;
- my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
- my $startix = $cv->START->opwalk;
- my $rootix = $cv->ROOT->ix;
-
- $cv->B::PVMG::bsave($ix);
- asm "xcv_stash", $stashix;
- asm "xcv_start", $startix;
- asm "xcv_root", $rootix;
- asm "xcv_xsubany", $constix;
- asm "xcv_gv", $gvix;
- asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
- asm "xcv_padlist", $padlistix;
- asm "xcv_outside", $outsideix;
- asm "xcv_flags", $cv->CvFLAGS;
- asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
- asm "xcv_depth", $cv->DEPTH;
-}
-
-sub B::FM::bsave {
- my ($form,$ix) = @_;
-
- $form->B::CV::bsave($ix);
- asm "xfm_lines", $form->LINES;
-}
-
-sub B::AV::bsave {
- my ($av,$ix) = @_;
- return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
- my @array = $av->ARRAY;
- $_ = $_->ix for @array;
- my $stashix = $av->SvSTASH->ix;
-
- nice "-AV-",
- asm "ldsv", $varix = $ix unless $ix == $varix;
- asm "av_extend", $av->MAX if $av->MAX >= 0;
- asm "av_pushx", $_ for @array;
- asm "sv_refcnt", $av->REFCNT;
- if (VERSION < 5.009) {
- asm "xav_flags", $av->AvFLAGS;
- }
- asm "xmg_stash", $stashix;
-}
-
-sub B::GV::desired {
- my $gv = shift;
- my ($cv, $form);
- $files{$gv->FILE} && $gv->LINE
- || ${$cv = $gv->CV} && $files{$cv->FILE}
- || ${$form = $gv->FORM} && $files{$form->FILE}
-}
-
-sub B::HV::bwalk {
- my $hv = shift;
- return if $walked{$$hv}++;
- my %stash = $hv->ARRAY;
- while (my($k,$v) = each %stash) {
- if ($v->SvTYPE == SVt_PVGV) {
- my $hash = $v->HV;
- if ($$hash && $hash->NAME) {
- $hash->bwalk;
- }
- $v->ix(1) if desired $v;
- } else {
- nice "[prototype]";
- asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
- $svtab{$$v} = $varix = $tix;
- $v->bsave($tix++);
- asm "sv_flags", $v->FLAGS;
- }
- }
-}
-
-######################################################
-
-
-sub B::OP::bsave_thin {
- my ($op, $ix) = @_;
- my $next = $op->next;
- my $nextix = $optab{$$next};
- $nextix = 0, push @cloop, $op unless defined $nextix;
- if ($ix != $opix) {
- nice '-'.$op->name.'-',
- asm "ldop", $opix = $ix;
- }
- asm "op_next", $nextix;
- asm "op_targ", $op->targ if $op->type; # tricky
- asm "op_flags", $op->flags;
- asm "op_private", $op->private;
-}
-
-sub B::OP::bsave;
- *B::OP::bsave = *B::OP::bsave_thin;
-
-sub B::UNOP::bsave {
- my ($op, $ix) = @_;
- my $name = $op->name;
- my $flags = $op->flags;
- my $first = $op->first;
- my $firstix =
- $name =~ /fl[io]p/
- # that's just neat
- || (!ITHREADS && $name eq 'regcomp')
- # trick for /$a/o in pp_regcomp
- || $name eq 'rv2sv'
- && $op->flags & OPf_MOD
- && $op->private & OPpLVAL_INTRO
- # change #18774 made my life hard
- ? $first->ix
- : 0;
-
- $op->B::OP::bsave($ix);
- asm "op_first", $firstix;
-}
-
-sub B::BINOP::bsave {
- my ($op, $ix) = @_;
- if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
- my $last = $op->last;
- my $lastix = do {
- local *B::OP::bsave = *B::OP::bsave_fat;
- local *B::UNOP::bsave = *B::UNOP::bsave_fat;
- $last->ix;
- };
- asm "ldop", $lastix unless $lastix == $opix;
- asm "op_targ", $last->targ;
- $op->B::OP::bsave($ix);
- asm "op_last", $lastix;
- } else {
- $op->B::OP::bsave($ix);
- }
-}
-
-# not needed if no pseudohashes
-
-*B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
-
-# deal with sort / formline
-
-sub B::LISTOP::bsave {
- my ($op, $ix) = @_;
- my $name = $op->name;
- sub blocksort() { OPf_SPECIAL|OPf_STACKED }
- if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
- my $first = $op->first;
- my $pushmark = $first->sibling;
- my $rvgv = $pushmark->first;
- my $leave = $rvgv->first;
-
- my $leaveix = $leave->ix;
-
- my $rvgvix = $rvgv->ix;
- asm "ldop", $rvgvix unless $rvgvix == $opix;
- asm "op_first", $leaveix;
-
- my $pushmarkix = $pushmark->ix;
- asm "ldop", $pushmarkix unless $pushmarkix == $opix;
- asm "op_first", $rvgvix;
-
- my $firstix = $first->ix;
- asm "ldop", $firstix unless $firstix == $opix;
- asm "op_sibling", $pushmarkix;
-
- $op->B::OP::bsave($ix);
- asm "op_first", $firstix;
- } elsif ($name eq 'formline') {
- $op->B::UNOP::bsave_fat($ix);
- } else {
- $op->B::OP::bsave($ix);
- }
-}
-
-# fat versions
-
-sub B::OP::bsave_fat {
- my ($op, $ix) = @_;
- my $siblix = $op->sibling->ix;
-
- $op->B::OP::bsave_thin($ix);
- asm "op_sibling", $siblix;
- # asm "op_seq", -1; XXX don't allocate OPs piece by piece
-}
-
-sub B::UNOP::bsave_fat {
- my ($op,$ix) = @_;
- my $firstix = $op->first->ix;
-
- $op->B::OP::bsave($ix);
- asm "op_first", $firstix;
-}
-
-sub B::BINOP::bsave_fat {
- my ($op,$ix) = @_;
- my $last = $op->last;
- my $lastix = $op->last->ix;
- if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
- asm "ldop", $lastix unless $lastix == $opix;
- asm "op_targ", $last->targ;
- }
-
- $op->B::UNOP::bsave($ix);
- asm "op_last", $lastix;
-}
-
-sub B::LOGOP::bsave {
- my ($op,$ix) = @_;
- my $otherix = $op->other->ix;
-
- $op->B::UNOP::bsave($ix);
- asm "op_other", $otherix;
-}
-
-sub B::PMOP::bsave {
- my ($op,$ix) = @_;
- my ($rrop, $rrarg, $rstart);
-
- # my $pmnextix = $op->pmnext->ix; # XXX
-
- if (ITHREADS) {
- if ($op->name eq 'subst') {
- $rrop = "op_pmreplroot";
- $rrarg = $op->pmreplroot->ix;
- $rstart = $op->pmreplstart->ix;
- } elsif ($op->name eq 'pushre') {
- $rrop = "op_pmreplrootpo";
- $rrarg = $op->pmreplroot;
- }
- $op->B::BINOP::bsave($ix);
- asm "op_pmstashpv", pvix $op->pmstashpv;
- } else {
- $rrop = "op_pmreplrootgv";
- $rrarg = $op->pmreplroot->ix;
- $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
- my $stashix = $op->pmstash->ix;
- $op->B::BINOP::bsave($ix);
- asm "op_pmstash", $stashix;
- }
-
- asm $rrop, $rrarg if $rrop;
- asm "op_pmreplstart", $rstart if $rstart;
-
- asm "op_pmflags", $op->pmflags;
- asm "op_pmpermflags", $op->pmpermflags;
- asm "op_pmdynflags", $op->pmdynflags;
- # asm "op_pmnext", $pmnextix; # XXX
- asm "newpv", pvstring $op->precomp;
- asm "pregcomp";
-}
-
-sub B::SVOP::bsave {
- my ($op,$ix) = @_;
- my $svix = $op->sv->ix;
-
- $op->B::OP::bsave($ix);
- asm "op_sv", $svix;
-}
-
-sub B::PADOP::bsave {
- my ($op,$ix) = @_;
-
- $op->B::OP::bsave($ix);
- asm "op_padix", $op->padix;
-}
-
-sub B::PVOP::bsave {
- my ($op,$ix) = @_;
- $op->B::OP::bsave($ix);
- return unless my $pv = $op->pv;
-
- if ($op->name eq 'trans') {
- asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
- } else {
- asm "newpv", pvstring $pv;
- asm "op_pv";
- }
-}
-
-sub B::LOOP::bsave {
- my ($op,$ix) = @_;
- my $nextix = $op->nextop->ix;
- my $lastix = $op->lastop->ix;
- my $redoix = $op->redoop->ix;
-
- $op->B::BINOP::bsave($ix);
- asm "op_redoop", $redoix;
- asm "op_nextop", $nextix;
- asm "op_lastop", $lastix;
-}
-
-sub B::COP::bsave {
- my ($cop,$ix) = @_;
- my $warnix = $cop->warnings->ix;
- my $ioix = $cop->io->ix;
- if (ITHREADS) {
- $cop->B::OP::bsave($ix);
- asm "cop_stashpv", pvix $cop->stashpv;
- asm "cop_file", pvix $cop->file;
- } else {
- my $stashix = $cop->stash->ix;
- my $fileix = $cop->filegv->ix(1);
- $cop->B::OP::bsave($ix);
- asm "cop_stash", $stashix;
- asm "cop_filegv", $fileix;
- }
- asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
- asm "cop_seq", $cop->cop_seq;
- asm "cop_arybase", $cop->arybase;
- asm "cop_line", $cop->line;
- asm "cop_warnings", $warnix;
- asm "cop_io", $ioix;
-}
-
-sub B::OP::opwalk {
- my $op = shift;
- my $ix = $optab{$$op};
- defined($ix) ? $ix : do {
- my $ix;
- my @oplist = $op->oplist;
- push @cloop, undef;
- $ix = $_->ix while $_ = pop @oplist;
- while ($_ = pop @cloop) {
- asm "ldop", $optab{$$_};
- asm "op_next", $optab{${$_->next}};
- }
- $ix;
- }
-}
-
-#################################################
-
-sub save_cq {
- my $av;
- if (($av=begin_av)->isa("B::AV")) {
- if ($savebegins) {
- for ($av->ARRAY) {
- next unless $_->FILE eq $0;
- asm "push_begin", $_->ix;
- }
- } else {
- for ($av->ARRAY) {
- next unless $_->FILE eq $0;
- # XXX BEGIN { goto A while 1; A: }
- for (my $op = $_->START; $$op; $op = $op->next) {
- next unless $op->name eq 'require' ||
- # this kludge needed for tests
- $op->name eq 'gv' && do {
- my $gv = class($op) eq 'SVOP' ?
- $op->gv :
- (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
- $$gv && $gv->NAME =~ /use_ok|plan/
- };
- asm "push_begin", $_->ix;
- last;
- }
- }
- }
- }
- if (($av=init_av)->isa("B::AV")) {
- for ($av->ARRAY) {
- next unless $_->FILE eq $0;
- asm "push_init", $_->ix;
- }
- }
- if (($av=end_av)->isa("B::AV")) {
- for ($av->ARRAY) {
- next unless $_->FILE eq $0;
- asm "push_end", $_->ix;
- }
- }
-}
-
-sub compile {
- my ($head, $scan, $T_inhinc, $keep_syn);
- my $cwd = '';
- $files{$0} = 1;
- sub keep_syn {
- $keep_syn = 1;
- *B::OP::bsave = *B::OP::bsave_fat;
- *B::UNOP::bsave = *B::UNOP::bsave_fat;
- *B::BINOP::bsave = *B::BINOP::bsave_fat;
- *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
- }
- sub bwarn { print STDERR "Bytecode.pm: @_\n" }
-
- for (@_) {
- if (/^-S/) {
- *newasm = *endasm = sub { };
- *asm = sub { print " @_\n" };
- *nice = sub ($) { print "\n@_\n" };
- } elsif (/^-H/) {
- require ByteLoader;
- $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
- } elsif (/^-k/) {
- keep_syn;
- } elsif (/^-o(.*)$/) {
- open STDOUT, ">$1" or die "open $1: $!";
- } elsif (/^-f(.*)$/) {
- $files{$1} = 1;
- } elsif (/^-s(.*)$/) {
- $scan = length($1) ? $1 : $0;
- } elsif (/^-b/) {
- $savebegins = 1;
- # this is here for the testsuite
- } elsif (/^-TI/) {
- $T_inhinc = 1;
- } elsif (/^-TF(.*)/) {
- my $thatfile = $1;
- *B::COP::file = sub { $thatfile };
- } else {
- bwarn "Ignoring '$_' option";
- }
- }
- if ($scan) {
- my $f;
- if (open $f, $scan) {
- while (<$f>) {
- /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
- /^#/ and next;
- if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
- bwarn "keeping the syntax tree: \"goto\" op found";
- keep_syn;
- }
- }
- } else {
- bwarn "cannot rescan '$scan'";
- }
- close $f;
- }
- binmode STDOUT;
- return sub {
- print $head if $head;
- newasm sub { print @_ };
-
- defstash->bwalk;
- asm "main_start", main_start->opwalk;
- asm "main_root", main_root->ix;
- asm "main_cv", main_cv->ix;
- asm "curpad", (comppadlist->ARRAY)[1]->ix;
-
- asm "signal", cstring "__WARN__" # XXX
- if warnhook->ix;
- asm "incav", inc_gv->AV->ix if $T_inhinc;
- save_cq;
- asm "incav", inc_gv->AV->ix if $T_inhinc;
- asm "dowarn", dowarn;
-
- {
- no strict 'refs';
- nice "<DATA>";
- my $dh = *{defstash->NAME."::DATA"};
- unless (eof $dh) {
- local undef $/;
- asm "data", ord 'D';
- print <$dh>;
- } else {
- asm "ret";
- }
- }
-
- endasm;
- }
-}
-
-1;
-
-=head1 NAME
-
-B::Bytecode - Perl compiler's bytecode backend
-
-=head1 SYNOPSIS
-
-B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
-
-=head1 DESCRIPTION
-
-Compiles a Perl script into a bytecode format that could be loaded
-later by the ByteLoader module and executed as a regular Perl script.
-
-=head1 EXAMPLE
-
- $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
- $ perl hi
- hi!
-
-=head1 OPTIONS
-
-=over 4
-
-=item B<-b>
-
-Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
-other files (ex. C<use Foo;>) are saved.
-
-=item B<-H>
-
-prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
-
-=item B<-k>
-
-keep the syntax tree - it is stripped by default.
-
-=item B<-o>I<outfile>
-
-put the bytecode in <outfile> instead of dumping it to STDOUT.
-
-=item B<-s>
-
-scan the script for C<# line ..> directives and for <goto LABEL>
-expressions. When gotos are found keep the syntax tree.
-
-=back
-
-=head1 KNOWN BUGS
-
-=over 4
-
-=item *
-
-C<BEGIN { goto A: while 1; A: }> won't even compile.
-
-=item *
-
-C<?...?> and C<reset> do not work as expected.
-
-=item *
-
-variables in C<(?{ ... })> constructs are not properly scoped.
-
-=item *
-
-scripts that use source filters will fail miserably.
-
-=back
-
-=head1 NOTICE
-
-There are also undocumented bugs and options.
-
-THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
-
-=head1 AUTHORS
-
-Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
-modified by Benjamin Stuhl <sho_pi@hotmail.com>.
-
-Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/C.pm b/Master/tlpkg/installer/perllib/B/C.pm
deleted file mode 100644
index cebf4132ffd..00000000000
--- a/Master/tlpkg/installer/perllib/B/C.pm
+++ /dev/null
@@ -1,2272 +0,0 @@
-# C.pm
-#
-# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-
-package B::C;
-
-our $VERSION = '1.04_01';
-
-package B::C::Section;
-
-use B ();
-use base B::Section;
-
-sub new
-{
- my $class = shift;
- my $o = $class->SUPER::new(@_);
- push @$o, { values => [] };
- return $o;
-}
-
-sub add
-{
- my $section = shift;
- push(@{$section->[-1]{values}},@_);
-}
-
-sub index
-{
- my $section = shift;
- return scalar(@{$section->[-1]{values}})-1;
-}
-
-sub output
-{
- my ($section, $fh, $format) = @_;
- my $sym = $section->symtable || {};
- my $default = $section->default;
- my $i;
- foreach (@{$section->[-1]{values}})
- {
- s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
- printf $fh $format, $_, $i;
- ++$i;
- }
-}
-
-package B::C::InitSection;
-
-# avoid use vars
-@B::C::InitSection::ISA = qw(B::C::Section);
-
-sub new {
- my $class = shift;
- my $max_lines = 10000; #pop;
- my $section = $class->SUPER::new( @_ );
-
- $section->[-1]{evals} = [];
- $section->[-1]{chunks} = [];
- $section->[-1]{nosplit} = 0;
- $section->[-1]{current} = [];
- $section->[-1]{count} = 0;
- $section->[-1]{max_lines} = $max_lines;
-
- return $section;
-}
-
-sub split {
- my $section = shift;
- $section->[-1]{nosplit}--
- if $section->[-1]{nosplit} > 0;
-}
-
-sub no_split {
- shift->[-1]{nosplit}++;
-}
-
-sub inc_count {
- my $section = shift;
-
- $section->[-1]{count} += $_[0];
- # this is cheating
- $section->add();
-}
-
-sub add {
- my $section = shift->[-1];
- my $current = $section->{current};
- my $nosplit = $section->{nosplit};
-
- push @$current, @_;
- $section->{count} += scalar(@_);
- if( !$nosplit && $section->{count} >= $section->{max_lines} ) {
- push @{$section->{chunks}}, $current;
- $section->{current} = [];
- $section->{count} = 0;
- }
-}
-
-sub add_eval {
- my $section = shift;
- my @strings = @_;
-
- foreach my $i ( @strings ) {
- $i =~ s/\"/\\\"/g;
- }
- push @{$section->[-1]{evals}}, @strings;
-}
-
-sub output {
- my( $section, $fh, $format, $init_name ) = @_;
- my $sym = $section->symtable || {};
- my $default = $section->default;
- push @{$section->[-1]{chunks}}, $section->[-1]{current};
-
- my $name = "aaaa";
- foreach my $i ( @{$section->[-1]{chunks}} ) {
- print $fh <<"EOT";
-static int perl_init_${name}()
-{
- dTARG;
- dSP;
-EOT
- foreach my $j ( @$i ) {
- $j =~ s{(s\\_[0-9a-f]+)}
- { exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
- print $fh "\t$j\n";
- }
- print $fh "\treturn 0;\n}\n";
-
- $section->SUPER::add( "perl_init_${name}();" );
- ++$name;
- }
- foreach my $i ( @{$section->[-1]{evals}} ) {
- $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i );
- }
-
- print $fh <<"EOT";
-static int ${init_name}()
-{
- dTARG;
- dSP;
-EOT
- $section->SUPER::output( $fh, $format );
- print $fh "\treturn 0;\n}\n";
-}
-
-
-package B::C;
-use Exporter ();
-our %REGEXP;
-
-{ # block necessary for caller to work
- my $caller = caller;
- if( $caller eq 'O' ) {
- require XSLoader;
- XSLoader::load( 'B::C' );
- }
-}
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
- init_sections set_callback save_unused_subs objsym save_context);
-
-use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
- class cstring cchar svref_2object compile_stats comppadlist hash
- threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation
- HEf_SVKEY SVf_POK SVf_ROK CVf_CONST);
-use B::Asmdata qw(@specialsv_name);
-
-use FileHandle;
-use Carp;
-use strict;
-use Config;
-
-my $hv_index = 0;
-my $gv_index = 0;
-my $re_index = 0;
-my $pv_index = 0;
-my $cv_index = 0;
-my $anonsub_index = 0;
-my $initsub_index = 0;
-
-my %symtable;
-my %xsub;
-my $warn_undefined_syms;
-my $verbose;
-my %unused_sub_packages;
-my $use_xsloader;
-my $nullop_count;
-my $pv_copy_on_grow = 0;
-my $optimize_ppaddr = 0;
-my $optimize_warn_sv = 0;
-my $use_perl_script_name = 0;
-my $save_data_fh = 0;
-my $save_sig = 0;
-my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
-my $max_string_len;
-
-my $ithreads = $Config{useithreads} eq 'define';
-
-my @threadsv_names;
-BEGIN {
- @threadsv_names = threadsv_names();
-}
-
-# Code sections
-my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
- $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
- $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
- $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
- $xrvsect, $xpvbmsect, $xpviosect );
-my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect,
- $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect,
- $unopsect );
-
-sub walk_and_save_optree;
-my $saveoptree_callback = \&walk_and_save_optree;
-sub set_callback { $saveoptree_callback = shift }
-sub saveoptree { &$saveoptree_callback(@_) }
-
-sub walk_and_save_optree {
- my ($name, $root, $start) = @_;
- walkoptree($root, "save");
- return objsym($start);
-}
-
-# Look this up here so we can do just a number compare
-# rather than looking up the name of every BASEOP in B::OP
-my $OP_THREADSV = opnumber('threadsv');
-
-sub savesym {
- my ($obj, $value) = @_;
- my $sym = sprintf("s\\_%x", $$obj);
- $symtable{$sym} = $value;
-}
-
-sub objsym {
- my $obj = shift;
- return $symtable{sprintf("s\\_%x", $$obj)};
-}
-
-sub getsym {
- my $sym = shift;
- my $value;
-
- return 0 if $sym eq "sym_0"; # special case
- $value = $symtable{$sym};
- if (defined($value)) {
- return $value;
- } else {
- warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
- return "UNUSED";
- }
-}
-
-sub savere {
- my $re = shift;
- my $sym = sprintf("re%d", $re_index++);
- $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
-
- return ($sym,length(pack "a*",$re));
-}
-
-sub savepv {
- my $pv = pack "a*", shift;
- my $pvsym = 0;
- my $pvmax = 0;
- if ($pv_copy_on_grow) {
- $pvsym = sprintf("pv%d", $pv_index++);
-
- if( defined $max_string_len && length($pv) > $max_string_len ) {
- my $chars = join ', ', map { cchar $_ } split //, $pv;
- $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars));
- }
- else {
- my $cstring = cstring($pv);
- if ($cstring ne "0") { # sic
- $decl->add(sprintf("static char %s[] = %s;",
- $pvsym, $cstring));
- }
- }
- } else {
- $pvmax = length(pack "a*",$pv) + 1;
- }
- return ($pvsym, $pvmax);
-}
-
-sub save_rv {
- my $sv = shift;
-# confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
- my $rv = $sv->RV->save;
-
- $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
-
- return $rv;
-}
-
-# savesym, pvmax, len, pv
-sub save_pv_or_rv {
- my $sv = shift;
-
- my $rok = $sv->FLAGS & SVf_ROK;
- my $pok = $sv->FLAGS & SVf_POK;
- my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 );
- if( $rok ) {
- $savesym = '(char*)' . save_rv( $sv );
- }
- else {
- $pv = $pok ? (pack "a*", $sv->PV) : undef;
- $len = $pok ? length($pv) : 0;
- ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 );
- }
-
- return ( $savesym, $pvmax, $len, $pv );
-}
-
-# see also init_op_ppaddr below; initializes the ppaddt to the
-# OpTYPE; init_op_ppaddr iterates over the ops and sets
-# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
-# in perl_init ( ~10 bytes/op with GCC/i386 )
-sub B::OP::fake_ppaddr {
- return $optimize_ppaddr ?
- sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) :
- 'NULL';
-}
-
-# This pair is needed becase B::FAKEOP::save doesn't scalar dereference
-# $op->next and $op->sibling
-
-{
- # For 5.9 the hard coded text is the values for op_opt and op_static in each
- # op. The value of op_opt is irrelevant, and the value of op_static needs to
- # be 1 to tell op_free that this is a statically defined op and that is
- # shouldn't be freed.
-
- # For 5.8:
- # Current workaround/fix for op_free() trying to free statically
- # defined OPs is to set op_seq = -1 and check for that in op_free().
- # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
- # so that it can be changed back easily if necessary. In fact, to
- # stop compilers from moaning about a U16 being initialised with an
- # uncast -1 (the printf format is %d so we can't tweak it), we have
- # to "know" that op_seq is a U16 and use 65535. Ugh.
-
- my $static = $] > 5.009 ? '0, 1, 0' : sprintf "%u", 65535;
- sub B::OP::_save_common_middle {
- my $op = shift;
- sprintf ("%s, %u, %u, $static, 0x%x, 0x%x",
- $op->fake_ppaddr, $op->targ, $op->type, $op->flags, $op->private);
- }
-}
-
-sub B::OP::_save_common {
- my $op = shift;
- return sprintf("s\\_%x, s\\_%x, %s",
- ${$op->next}, ${$op->sibling}, $op->_save_common_middle);
-}
-
-sub B::OP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- my $type = $op->type;
- $nullop_count++ unless $type;
- if ($type == $OP_THREADSV) {
- # saves looking up ppaddr but it's a bit naughty to hard code this
- $init->add(sprintf("(void)find_threadsv(%s);",
- cstring($threadsv_names[$op->targ])));
- }
- $opsect->add($op->_save_common);
- my $ix = $opsect->index;
- $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "&op_list[$ix]");
-}
-
-sub B::FAKEOP::new {
- my ($class, %objdata) = @_;
- bless \%objdata, $class;
-}
-
-sub B::FAKEOP::save {
- my ($op, $level) = @_;
- $opsect->add(sprintf("%s, %s, %s",
- $op->next, $op->sibling, $op->_save_common_middle));
- my $ix = $opsect->index;
- $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- return "&op_list[$ix]";
-}
-
-sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
-sub B::FAKEOP::type { $_[0]->{type} || 0}
-sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
-sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
-sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
-sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
-sub B::FAKEOP::private { $_[0]->{private} || 0 }
-
-sub B::UNOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $unopsect->add(sprintf("%s, s\\_%x", $op->_save_common, ${$op->first}));
- my $ix = $unopsect->index;
- $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&unop_list[$ix]");
-}
-
-sub B::BINOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $binopsect->add(sprintf("%s, s\\_%x, s\\_%x",
- $op->_save_common, ${$op->first}, ${$op->last}));
- my $ix = $binopsect->index;
- $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&binop_list[$ix]");
-}
-
-sub B::LISTOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $listopsect->add(sprintf("%s, s\\_%x, s\\_%x",
- $op->_save_common, ${$op->first}, ${$op->last}));
- my $ix = $listopsect->index;
- $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&listop_list[$ix]");
-}
-
-sub B::LOGOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $logopsect->add(sprintf("%s, s\\_%x, s\\_%x",
- $op->_save_common, ${$op->first}, ${$op->other}));
- my $ix = $logopsect->index;
- $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&logop_list[$ix]");
-}
-
-sub B::LOOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
- # peekop($op->redoop), peekop($op->nextop),
- # peekop($op->lastop)); # debug
- $loopsect->add(sprintf("%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
- $op->_save_common, ${$op->first}, ${$op->last},
- ${$op->redoop}, ${$op->nextop},
- ${$op->lastop}));
- my $ix = $loopsect->index;
- $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&loop_list[$ix]");
-}
-
-sub B::PVOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $pvopsect->add(sprintf("%s, %s", $op->_save_common, cstring($op->pv)));
- my $ix = $pvopsect->index;
- $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&pvop_list[$ix]");
-}
-
-sub B::SVOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- my $sv = $op->sv;
- my $svsym = '(SV*)' . $sv->save;
- my $is_const_addr = $svsym =~ m/Null|\&/;
- $svopsect->add(sprintf("%s, %s", $op->_save_common,
- ( $is_const_addr ? $svsym : 'Nullsv' )));
- my $ix = $svopsect->index;
- $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- $init->add("svop_list[$ix].op_sv = $svsym;")
- unless $is_const_addr;
- savesym($op, "(OP*)&svop_list[$ix]");
-}
-
-sub B::PADOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $padopsect->add(sprintf("%s, %d",
- $op->_save_common, $op->padix));
- my $ix = $padopsect->index;
- $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
-# $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
- savesym($op, "(OP*)&padop_list[$ix]");
-}
-
-sub B::COP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
- if $debug_cops;
- # shameless cut'n'paste from B::Deparse
- my $warn_sv;
- my $warnings = $op->warnings;
- my $is_special = $warnings->isa("B::SPECIAL");
- if ($is_special && $$warnings == 4) {
- # use warnings 'all';
- $warn_sv = $optimize_warn_sv ?
- 'INT2PTR(SV*,1)' :
- 'pWARN_ALL';
- }
- elsif ($is_special && $$warnings == 5) {
- # no warnings 'all';
- $warn_sv = $optimize_warn_sv ?
- 'INT2PTR(SV*,2)' :
- 'pWARN_NONE';
- }
- elsif ($is_special) {
- # use warnings;
- $warn_sv = $optimize_warn_sv ?
- 'INT2PTR(SV*,3)' :
- 'pWARN_STD';
- }
- else {
- # something else
- $warn_sv = $warnings->save;
- }
-
- $copsect->add(sprintf("%s, %s, NULL, NULL, %u, %d, %u, %s",
- $op->_save_common, cstring($op->label), $op->cop_seq,
- $op->arybase, $op->line,
- ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
- my $ix = $copsect->index;
- $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
- unless $optimize_warn_sv;
- $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
- sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
-
- savesym($op, "(OP*)&cop_list[$ix]");
-}
-
-sub B::PMOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- my $replroot = $op->pmreplroot;
- my $replstart = $op->pmreplstart;
- my $replrootfield;
- my $replstartfield = sprintf("s\\_%x", $$replstart);
- my $gvsym;
- my $ppaddr = $op->ppaddr;
- # under ithreads, OP_PUSHRE.op_replroot is an integer
- $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot;
- if($ithreads && $op->name eq "pushre") {
- $replrootfield = "INT2PTR(OP*,${replroot})";
- } elsif ($$replroot) {
- # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
- # argument to a split) stores a GV in op_pmreplroot instead
- # of a substitution syntax tree. We don't want to walk that...
- if ($op->name eq "pushre") {
- $gvsym = $replroot->save;
-# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
- $replrootfield = 0;
- } else {
- $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
- }
- }
- # pmnext handling is broken in perl itself, I think. Bad op_pmnext
- # fields aren't noticed in perl's runtime (unless you try reset) but we
- # segfault when trying to dereference it to find op->op_pmnext->op_type
- $pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
- $op->_save_common, ${$op->first}, ${$op->last},
- $replrootfield, $replstartfield,
- ( $ithreads ? $op->pmoffset : 0 ),
- $op->pmflags, $op->pmpermflags, $op->pmdynflags ));
- my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
- $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr))
- unless $optimize_ppaddr;
- my $re = $op->precomp;
- if (defined($re)) {
- my( $resym, $relen ) = savere( $re );
- $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
- $relen));
- }
- if ($gvsym) {
- $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
- }
- savesym($op, "(OP*)&$pm");
-}
-
-sub B::SPECIAL::save {
- my ($sv) = @_;
- # special case: $$sv is not the address but an index into specialsv_list
-# warn "SPECIAL::save specialsv $$sv\n"; # debug
- my $sym = $specialsv_name[$$sv];
- if (!defined($sym)) {
- confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
- }
- return $sym;
-}
-
-sub B::OBJECT::save {}
-
-sub B::NULL::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
-# warn "Saving SVt_NULL SV\n"; # debug
- # debug
- if ($$sv == 0) {
- warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
- return savesym($sv, "(void*)Nullsv /* XXX */");
- }
- $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::IV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
- $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
- $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::NV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my $val= $sv->NVX;
- $val .= '.00' if $val =~ /^-?\d+$/;
- $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
- $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
- $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub savepvn {
- my ($dest,$pv) = @_;
- my @res;
- # work with byte offsets/lengths
- my $pv = pack "a*", $pv;
- if (defined $max_string_len && length($pv) > $max_string_len) {
- push @res, sprintf("Newx(%s,%u,char);", $dest, length($pv)+1);
- my $offset = 0;
- while (length $pv) {
- my $str = substr $pv, 0, $max_string_len, '';
- push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
- cstring($str), length($str));
- $offset += length $str;
- }
- push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
- }
- else {
- push @res, sprintf("%s = savepvn(%s, %u);", $dest,
- cstring($pv), length($pv));
- }
- return @res;
-}
-
-sub B::PVLV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my $pv = $sv->PV;
- my $len = length($pv);
- my ($pvsym, $pvmax) = savepv($pv);
- my ($lvtarg, $lvtarg_sym);
- $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
- $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
- $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
- $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
- $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
- if (!$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
- $xpvlvsect->index), $pv));
- }
- $sv->save_magic;
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVIV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
- $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX));
- $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
- $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
- if (defined($pv) && !$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
- $xpvivsect->index), $pv));
- }
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVNV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
- my $val= $sv->NVX;
- $val .= '.00' if $val =~ /^-?\d+$/;
- $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
- $savesym, $len, $pvmax, $sv->IVX, $val));
- $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
- $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
- if (defined($pv) && !$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
- $xpvnvsect->index), $pv));
- }
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::BM::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE);
- my $len = length($pv);
- $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
- $len, $len + 258, $sv->IVX, $sv->NVX,
- $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
- $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
- $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
- $sv->save_magic;
- $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
- $xpvbmsect->index), $pv),
- sprintf("xpvbm_list[%d].xpv_cur = %u;",
- $xpvbmsect->index, $len - 257));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
- $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax));
- $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
- $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
- if (defined($pv) && !$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
- $xpvsect->index), $pv));
- }
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVMG::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
-
- $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
- $savesym, $len, $pvmax,
- $sv->IVX, $sv->NVX));
- $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
- $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
- if (defined($pv) && !$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
- $xpvmgsect->index), $pv));
- }
- $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
- $sv->save_magic;
- return $sym;
-}
-
-sub B::PVMG::save_magic {
- my ($sv) = @_;
- #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
- my $stash = $sv->SvSTASH;
- $stash->save;
- if ($$stash) {
- warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
- if $debug_mg;
- # XXX Hope stash is already going to be saved.
- $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
- }
- my @mgchain = $sv->MAGIC;
- my ($mg, $type, $obj, $ptr,$len,$ptrsv);
- foreach $mg (@mgchain) {
- $type = $mg->TYPE;
- $ptr = $mg->PTR;
- $len=$mg->LENGTH;
- if ($debug_mg) {
- warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
- class($sv), $$sv, class($obj), $$obj,
- cchar($type), cstring($ptr));
- }
-
- unless( $type eq 'r' ) {
- $obj = $mg->OBJ;
- $obj->save;
- }
-
- if ($len == HEf_SVKEY){
- #The pointer is an SV*
- $ptrsv=svref_2object($ptr)->save;
- $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
- $$sv, $$obj, cchar($type),$ptrsv,$len));
- }elsif( $type eq 'r' ){
- my $rx = $mg->REGEX;
- my $pmop = $REGEXP{$rx};
-
- confess "PMOP not found for REGEXP $rx" unless $pmop;
-
- my( $resym, $relen ) = savere( $mg->precomp );
- my $pmsym = $pmop->save;
- $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
-{
- REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym);
- sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
-}
-CODE
- }else{
- $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
- $$sv, $$obj, cchar($type),cstring($ptr),$len));
- }
- }
-}
-
-sub B::RV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my $rv = save_rv( $sv );
- # GVs need to be handled at runtime
- if( ref( $sv->RV ) eq 'B::GV' ) {
- $xrvsect->add( "(SV*)Nullgv" );
- $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
- }
- # and stashes, too
- elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
- $xrvsect->add( "(SV*)Nullhv" );
- $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
- }
- else {
- $xrvsect->add($rv);
- }
- $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
- $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub try_autoload {
- my ($cvstashname, $cvname) = @_;
- warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
- # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
- # use should be handled by the class itself.
- no strict 'refs';
- my $isa = \@{"$cvstashname\::ISA"};
- if (grep($_ eq "AutoLoader", @$isa)) {
- warn "Forcing immediate load of sub derived from AutoLoader\n";
- # Tweaked version of AutoLoader::AUTOLOAD
- my $dir = $cvstashname;
- $dir =~ s(::)(/)g;
- eval { require "auto/$dir/$cvname.al" };
- if ($@) {
- warn qq(failed require "auto/$dir/$cvname.al": $@\n);
- return 0;
- } else {
- return 1;
- }
- }
-}
-sub Dummy_initxs{};
-sub B::CV::save {
- my ($cv) = @_;
- my $sym = objsym($cv);
- if (defined($sym)) {
-# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
- return $sym;
- }
- # Reserve a place in svsect and xpvcvsect and record indices
- my $gv = $cv->GV;
- my ($cvname, $cvstashname);
- if ($$gv){
- $cvname = $gv->NAME;
- $cvstashname = $gv->STASH->NAME;
- }
- my $root = $cv->ROOT;
- my $cvxsub = $cv->XSUB;
- my $isconst = $cv->CvFLAGS & CVf_CONST;
- if( $isconst ) {
- my $value = $cv->XSUBANY;
- my $stash = $gv->STASH;
- my $vsym = $value->save;
- my $stsym = $stash->save;
- my $name = cstring($cvname);
- $decl->add( "static CV* cv$cv_index;" );
- $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" );
- my $sym = savesym( $cv, "cv$cv_index" );
- $cv_index++;
- return $sym;
- }
- #INIT is removed from the symbol table, so this call must come
- # from PL_initav->save. Re-bootstrapping will push INIT back in
- # so nullop should be sent.
- if (!$isconst && $cvxsub && ($cvname ne "INIT")) {
- my $egv = $gv->EGV;
- my $stashname = $egv->STASH->NAME;
- if ($cvname eq "bootstrap")
- {
- my $file = $gv->FILE;
- $decl->add("/* bootstrap $file */");
- warn "Bootstrap $stashname $file\n";
- # if it not isa('DynaLoader'), it should hopefully be XSLoaded
- # ( attributes being an exception, of course )
- if( $stashname ne 'attributes' &&
- !UNIVERSAL::isa($stashname,'DynaLoader') ) {
- $xsub{$stashname}='Dynamic-XSLoaded';
- $use_xsloader = 1;
- }
- else {
- $xsub{$stashname}='Dynamic';
- }
- # $xsub{$stashname}='Static' unless $xsub{$stashname};
- return qq/NULL/;
- }
- else
- {
- # XSUBs for IO::File, IO::Handle, IO::Socket,
- # IO::Seekable and IO::Poll
- # are defined in IO.xs, so let's bootstrap it
- svref_2object( \&IO::bootstrap )->save
- if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket
- IO::Seekable IO::Poll);
- }
- warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
- return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
- }
- if ($cvxsub && $cvname eq "INIT") {
- no strict 'refs';
- return svref_2object(\&Dummy_initxs)->save;
- }
- my $sv_ix = $svsect->index + 1;
- $svsect->add("svix$sv_ix");
- my $xpvcv_ix = $xpvcvsect->index + 1;
- $xpvcvsect->add("xpvcvix$xpvcv_ix");
- # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
- $sym = savesym($cv, "&sv_list[$sv_ix]");
- warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
- if (!$$root && !$cvxsub) {
- if (try_autoload($cvstashname, $cvname)) {
- # Recalculate root and xsub
- $root = $cv->ROOT;
- $cvxsub = $cv->XSUB;
- if ($$root || $cvxsub) {
- warn "Successful forced autoload\n";
- }
- }
- }
- my $startfield = 0;
- my $padlist = $cv->PADLIST;
- my $pv = $cv->PV;
- my $xsub = 0;
- my $xsubany = "Nullany";
- if ($$root) {
- warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
- $$cv, $$root) if $debug_cv;
- my $ppname = "";
- if ($$gv) {
- my $stashname = $gv->STASH->NAME;
- my $gvname = $gv->NAME;
- if ($gvname ne "__ANON__") {
- $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
- $ppname .= ($stashname eq "main") ?
- $gvname : "$stashname\::$gvname";
- $ppname =~ s/::/__/g;
- if ($gvname eq "INIT"){
- $ppname .= "_$initsub_index";
- $initsub_index++;
- }
- }
- }
- if (!$ppname) {
- $ppname = "pp_anonsub_$anonsub_index";
- $anonsub_index++;
- }
- $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
- warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
- $$cv, $ppname, $$root) if $debug_cv;
- if ($$padlist) {
- warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
- $$padlist, $$cv) if $debug_cv;
- $padlist->save;
- warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
- $$padlist, $$cv) if $debug_cv;
- }
- }
- else {
- warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
- $cvstashname, $cvname); # debug
- }
- $pv = '' unless defined $pv; # Avoid use of undef warnings
- $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x",
- $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
- $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
- $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS,
- $cv->OUTSIDE_SEQ));
-
- if (${$cv->OUTSIDE} == ${main_cv()}){
- $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
- $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
- }
-
- if ($$gv) {
- $gv->save;
- $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
- warn sprintf("done saving GV 0x%x for CV 0x%x\n",
- $$gv, $$cv) if $debug_cv;
- }
- if( $ithreads ) {
- $init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
- }
- else {
- $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
- }
- my $stash = $cv->STASH;
- if ($$stash) {
- $stash->save;
- $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
- warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
- $$stash, $$cv) if $debug_cv;
- }
- $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
- $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
- return $sym;
-}
-
-sub B::GV::save {
- my ($gv) = @_;
- my $sym = objsym($gv);
- if (defined($sym)) {
- #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
- return $sym;
- } else {
- my $ix = $gv_index++;
- $sym = savesym($gv, "gv_list[$ix]");
- #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
- }
- my $is_empty = $gv->is_empty;
- my $gvname = $gv->NAME;
- my $fullname = $gv->STASH->NAME . "::" . $gvname;
- my $name = cstring($fullname);
- #warn "GV name is $name\n"; # debug
- my $egvsym;
- unless ($is_empty) {
- my $egv = $gv->EGV;
- if ($$gv != $$egv) {
- #warn(sprintf("EGV name is %s, saving it now\n",
- # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
- $egvsym = $egv->save;
- }
- }
- $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
- sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
- sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
- $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
- # XXX hack for when Perl accesses PVX of GVs
- $init->add("SvPVX($sym) = emptystring;\n");
- # Shouldn't need to do save_magic since gv_fetchpv handles that
- #$gv->save_magic;
- # XXX will always be > 1!!!
- my $refcnt = $gv->REFCNT + 1;
- $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1;
-
- return $sym if $is_empty;
-
- # XXX B::walksymtable creates an extra reference to the GV
- my $gvrefcnt = $gv->GvREFCNT;
- if ($gvrefcnt > 1) {
- $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
- }
- # some non-alphavetic globs require some parts to be saved
- # ( ex. %!, but not $! )
- sub Save_HV() { 1 }
- sub Save_AV() { 2 }
- sub Save_SV() { 4 }
- sub Save_CV() { 8 }
- sub Save_FORM() { 16 }
- sub Save_IO() { 32 }
- my $savefields = 0;
- if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
- $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
- }
- elsif( $gvname eq '!' ) {
- $savefields = Save_HV;
- }
- # attributes::bootstrap is created in perl_parse
- # saving it would overwrite it, because perl_init() is
- # called after perl_parse()
- $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
-
- # save it
- # XXX is that correct?
- if (defined($egvsym) && $egvsym !~ m/Null/ ) {
- # Shared glob *foo = *bar
- $init->add("gp_free($sym);",
- "GvGP($sym) = GvGP($egvsym);");
- } elsif ($savefields) {
- # Don't save subfields of special GVs (*_, *1, *# and so on)
-# warn "GV::save saving subfields\n"; # debug
- my $gvsv = $gv->SV;
- if ($$gvsv && $savefields&Save_SV) {
- $gvsv->save;
- $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
-# warn "GV::save \$$name\n"; # debug
- }
- my $gvav = $gv->AV;
- if ($$gvav && $savefields&Save_AV) {
- $gvav->save;
- $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
-# warn "GV::save \@$name\n"; # debug
- }
- my $gvhv = $gv->HV;
- if ($$gvhv && $savefields&Save_HV) {
- $gvhv->save;
- $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
-# warn "GV::save \%$name\n"; # debug
- }
- my $gvcv = $gv->CV;
- if ($$gvcv && $savefields&Save_CV) {
- my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
- "::" . $gvcv->GV->EGV->NAME);
- if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
- # must save as a 'stub' so newXS() has a CV to populate
- $init->add("{ CV *cv;");
- $init->add("\tcv=perl_get_cv($origname,TRUE);");
- $init->add("\tGvCV($sym)=cv;");
- $init->add("\tSvREFCNT_inc((SV *)cv);");
- $init->add("}");
- } else {
- $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
-# warn "GV::save &$name\n"; # debug
- }
- }
- $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
-# warn "GV::save GvFILE(*$name)\n"; # debug
- my $gvform = $gv->FORM;
- if ($$gvform && $savefields&Save_FORM) {
- $gvform->save;
- $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
-# warn "GV::save GvFORM(*$name)\n"; # debug
- }
- my $gvio = $gv->IO;
- if ($$gvio && $savefields&Save_IO) {
- $gvio->save;
- $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
- if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
- no strict 'refs';
- my $fh = *{$fullname}{IO};
- use strict 'refs';
- $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
- }
-# warn "GV::save GvIO(*$name)\n"; # debug
- }
- }
- return $sym;
-}
-
-sub B::AV::save {
- my ($av) = @_;
- my $sym = objsym($av);
- return $sym if defined $sym;
- my $line = "0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0";
- $line .= sprintf(", 0x%x", $av->AvFLAGS) if $] < 5.009;
- $xpvavsect->add($line);
- $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
- $xpvavsect->index, $av->REFCNT , $av->FLAGS));
- my $sv_list_index = $svsect->index;
- my $fill = $av->FILL;
- $av->save_magic;
- if ($debug_av) {
- $line = sprintf("saving AV 0x%x FILL=$fill", $$av);
- $line .= sprintf(" AvFLAGS=0x%x", $av->AvFLAGS) if $] < 5.009;
- warn $line;
- }
- # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
- #if ($fill > -1 && ($avflags & AVf_REAL)) {
- if ($fill > -1) {
- my @array = $av->ARRAY;
- if ($debug_av) {
- my $el;
- my $i = 0;
- foreach $el (@array) {
- warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
- $$av, $i++, class($el), $$el);
- }
- }
-# my @names = map($_->save, @array);
- # XXX Better ways to write loop?
- # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
- # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
-
- # micro optimization: op/pat.t ( and other code probably )
- # has very large pads ( 20k/30k elements ) passing them to
- # ->add is a performance bottleneck: passing them as a
- # single string cuts runtime from 6min20sec to 40sec
-
- # you want to keep this out of the no_split/split
- # map("\t*svp++ = (SV*)$_;", @names),
- my $acc = '';
- foreach my $i ( 0..$#array ) {
- $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
- }
- $acc .= "\n";
-
- $init->no_split;
- $init->add("{",
- "\tSV **svp;",
- "\tAV *av = (AV*)&sv_list[$sv_list_index];",
- "\tav_extend(av, $fill);",
- "\tsvp = AvARRAY(av);" );
- $init->add($acc);
- $init->add("\tAvFILLp(av) = $fill;",
- "}");
- $init->split;
- # we really added a lot of lines ( B::C::InitSection->add
- # should really scan for \n, but that would slow
- # it down
- $init->inc_count( $#array );
- } else {
- my $max = $av->MAX;
- $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
- if $max > -1;
- }
- return savesym($av, "(AV*)&sv_list[$sv_list_index]");
-}
-
-sub B::HV::save {
- my ($hv) = @_;
- my $sym = objsym($hv);
- return $sym if defined $sym;
- my $name = $hv->NAME;
- if ($name) {
- # It's a stash
-
- # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
- # the only symptom is that sv_reset tries to reset the PMf_USED flag of
- # a trashed op but we look at the trashed op_type and segfault.
- #my $adpmroot = ${$hv->PMROOT};
- my $adpmroot = 0;
- $decl->add("static HV *hv$hv_index;");
- # XXX Beware of weird package names containing double-quotes, \n, ...?
- $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
- if ($adpmroot) {
- $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
- $adpmroot));
- }
- $sym = savesym($hv, "hv$hv_index");
- $hv_index++;
- return $sym;
- }
- # It's just an ordinary HV
- $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
- $hv->MAX, $hv->RITER));
- $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
- $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
- my $sv_list_index = $svsect->index;
- my @contents = $hv->ARRAY;
- if (@contents) {
- my $i;
- for ($i = 1; $i < @contents; $i += 2) {
- $contents[$i] = $contents[$i]->save;
- }
- $init->no_split;
- $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
- while (@contents) {
- my ($key, $value) = splice(@contents, 0, 2);
- $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
- cstring($key),length(pack "a*",$key),
- $value, hash($key)));
-# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
-# cstring($key),length($key),$value, 0));
- }
- $init->add("}");
- $init->split;
- }
- $hv->save_magic();
- return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
-}
-
-sub B::IO::save_data {
- my( $io, $globname, @data ) = @_;
- my $data = join '', @data;
-
- # XXX using $DATA might clobber it!
- my $sym = svref_2object( \\$data )->save;
- $init->add( split /\n/, <<CODE );
- {
- GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
- SV* sv = $sym;
- GvSV( gv ) = sv;
- }
-CODE
- # for PerlIO::scalar
- $use_xsloader = 1;
- $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
-}
-
-sub B::IO::save {
- my ($io) = @_;
- my $sym = objsym($io);
- return $sym if defined $sym;
- my $pv = $io->PV;
- $pv = '' unless defined $pv;
- my $len = length($pv);
- $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
- $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
- $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
- cstring($io->TOP_NAME), cstring($io->FMT_NAME),
- cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
- cchar($io->IoTYPE), $io->IoFLAGS));
- $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
- $xpviosect->index, $io->REFCNT , $io->FLAGS));
- $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
- # deal with $x = *STDIN/STDOUT/STDERR{IO}
- my $perlio_func;
- foreach ( qw(stdin stdout stderr) ) {
- $io->IsSTD($_) and $perlio_func = $_;
- }
- if( $perlio_func ) {
- $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
- $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
- }
-
- my ($field, $fsym);
- foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
- $fsym = $io->$field();
- if ($$fsym) {
- $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
- $fsym->save;
- }
- }
- $io->save_magic;
- return $sym;
-}
-
-sub B::SV::save {
- my $sv = shift;
- # This is where we catch an honest-to-goodness Nullsv (which gets
- # blessed into B::SV explicitly) and any stray erroneous SVs.
- return 0 unless $$sv;
- confess sprintf("cannot save that type of SV: %s (0x%x)\n",
- class($sv), $$sv);
-}
-
-sub output_all {
- my $init_name = shift;
- my $section;
- my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
- $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
- $loopsect, $copsect, $svsect, $xpvsect,
- $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
- $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
- $symsect->output(\*STDOUT, "#define %s\n");
- print "\n";
- output_declarations();
- foreach $section (@sections) {
- my $lines = $section->index + 1;
- if ($lines) {
- my $name = $section->name;
- my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
- print "Static $typename ${name}_list[$lines];\n";
- }
- }
- # XXX hack for when Perl accesses PVX of GVs
- print 'Static char emptystring[] = "\0";';
-
- $decl->output(\*STDOUT, "%s\n");
- print "\n";
- foreach $section (@sections) {
- my $lines = $section->index + 1;
- if ($lines) {
- my $name = $section->name;
- my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
- printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
- $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
- print "};\n\n";
- }
- }
-
- $init->output(\*STDOUT, "\t%s\n", $init_name );
- if ($verbose) {
- warn compile_stats();
- warn "NULLOP count: $nullop_count\n";
- }
-}
-
-sub output_declarations {
- print <<'EOT';
-#ifdef BROKEN_STATIC_REDECL
-#define Static extern
-#else
-#define Static static
-#endif /* BROKEN_STATIC_REDECL */
-
-#ifdef BROKEN_UNION_INIT
-/*
- * Cribbed from cv.h with ANY (a union) replaced by void*.
- * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
- */
-typedef struct {
- char * xpv_pv; /* pointer to malloced string */
- STRLEN xpv_cur; /* length of xp_pv as a C string */
- STRLEN xpv_len; /* allocated size */
- IV xof_off; /* integer value */
- NV xnv_nv; /* numeric value, if any */
- MAGIC* xmg_magic; /* magic for scalar array */
- HV* xmg_stash; /* class package */
-
- HV * xcv_stash;
- OP * xcv_start;
- OP * xcv_root;
- void (*xcv_xsub) (pTHX_ CV*);
- ANY xcv_xsubany;
- GV * xcv_gv;
- char * xcv_file;
- long xcv_depth; /* >= 2 indicates recursive call */
- AV * xcv_padlist;
- CV * xcv_outside;
-EOT
- print <<'EOT' if $] < 5.009;
-#ifdef USE_5005THREADS
- perl_mutex *xcv_mutexp;
- struct perl_thread *xcv_owner; /* current owner thread */
-#endif /* USE_5005THREADS */
-EOT
- print <<'EOT';
- cv_flags_t xcv_flags;
- U32 xcv_outside_seq; /* the COP sequence (at the point of our
- * compilation) in the lexically enclosing
- * sub */
-} XPVCV_or_similar;
-#define ANYINIT(i) i
-#else
-#define XPVCV_or_similar XPVCV
-#define ANYINIT(i) {i}
-#endif /* BROKEN_UNION_INIT */
-#define Nullany ANYINIT(0)
-
-#define UNUSED 0
-#define sym_0 0
-EOT
- print "static GV *gv_list[$gv_index];\n" if $gv_index;
- print "\n";
-}
-
-
-sub output_boilerplate {
- print <<'EOT';
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-/* Workaround for mapstart: the only op which needs a different ppaddr */
-#undef Perl_pp_mapstart
-#define Perl_pp_mapstart Perl_pp_grepstart
-#undef OP_MAPSTART
-#define OP_MAPSTART OP_GREPSTART
-#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
-EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
-
-static void xs_init (pTHX);
-static void dl_init (pTHX);
-static PerlInterpreter *my_perl;
-EOT
-}
-
-sub init_op_addr {
- my( $op_type, $num ) = @_;
- my $op_list = $op_type."_list";
-
- $init->add( split /\n/, <<EOT );
- {
- int i;
-
- for( i = 0; i < ${num}; ++i )
- {
- ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
- }
- }
-EOT
-}
-
-sub init_op_warn {
- my( $op_type, $num ) = @_;
- my $op_list = $op_type."_list";
-
- # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
- $init->add( split /\n/, <<EOT );
- {
- int i;
-
- for( i = 0; i < ${num}; ++i )
- {
- switch( (int)(${op_list}\[i].cop_warnings) )
- {
- case 1:
- ${op_list}\[i].cop_warnings = pWARN_ALL;
- break;
- case 2:
- ${op_list}\[i].cop_warnings = pWARN_NONE;
- break;
- case 3:
- ${op_list}\[i].cop_warnings = pWARN_STD;
- break;
- default:
- break;
- }
- }
- }
-EOT
-}
-
-sub output_main {
- print <<'EOT';
-/* if USE_IMPLICIT_SYS, we need a 'real' exit */
-#if defined(exit)
-#undef exit
-#endif
-
-int
-main(int argc, char **argv, char **env)
-{
- int exitstatus;
- int i;
- char **fakeargv;
- GV* tmpgv;
- SV* tmpsv;
- int options_count;
-
- PERL_SYS_INIT3(&argc,&argv,&env);
-
- if (!PL_do_undump) {
- my_perl = perl_alloc();
- if (!my_perl)
- exit(1);
- perl_construct( my_perl );
- PL_perl_destruct_level = 0;
- }
-EOT
- if( $ithreads ) {
- # XXX init free elems!
- my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
-
- print <<EOT;
-#ifdef USE_ITHREADS
- for( i = 0; i < $pad_len; ++i ) {
- av_push( PL_regex_padav, newSViv(0) );
- }
- PL_regex_pad = AvARRAY( PL_regex_padav );
-#endif
-EOT
- }
-
- print <<'EOT';
-#ifdef CSH
- if (!PL_cshlen)
- PL_cshlen = strlen(PL_cshname);
-#endif
-
-#ifdef ALLOW_PERL_OPTIONS
-#define EXTRA_OPTIONS 3
-#else
-#define EXTRA_OPTIONS 4
-#endif /* ALLOW_PERL_OPTIONS */
- Newx(fakeargv, argc + EXTRA_OPTIONS + 1, char *);
-
- fakeargv[0] = argv[0];
- fakeargv[1] = "-e";
- fakeargv[2] = "";
- options_count = 3;
-EOT
- # honour -T
- print <<EOT;
- if( ${^TAINT} ) {
- fakeargv[options_count] = "-T";
- ++options_count;
- }
-EOT
- print <<'EOT';
-#ifndef ALLOW_PERL_OPTIONS
- fakeargv[options_count] = "--";
- ++options_count;
-#endif /* ALLOW_PERL_OPTIONS */
- for (i = 1; i < argc; i++)
- fakeargv[i + options_count - 1] = argv[i];
- fakeargv[argc + options_count - 1] = 0;
-
- exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
- fakeargv, NULL);
-
- if (exitstatus)
- exit( exitstatus );
-
- TAINT;
-EOT
-
- if( $use_perl_script_name ) {
- my $dollar_0 = $0;
- $dollar_0 =~ s/\\/\\\\/g;
- $dollar_0 = '"' . $dollar_0 . '"';
-
- print <<EOT;
- if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
- tmpsv = GvSV(tmpgv);
- sv_setpv(tmpsv, ${dollar_0});
- SvSETMAGIC(tmpsv);
- }
-EOT
- }
- else {
- print <<EOT;
- if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
- tmpsv = GvSV(tmpgv);
- sv_setpv(tmpsv, argv[0]);
- SvSETMAGIC(tmpsv);
- }
-EOT
- }
-
- print <<'EOT';
- if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
- tmpsv = GvSV(tmpgv);
-#ifdef WIN32
- sv_setpv(tmpsv,"perl.exe");
-#else
- sv_setpv(tmpsv,"perl");
-#endif
- SvSETMAGIC(tmpsv);
- }
-
- TAINT_NOT;
-
- /* PL_main_cv = PL_compcv; */
- PL_compcv = 0;
-
- exitstatus = perl_init();
- if (exitstatus)
- exit( exitstatus );
- dl_init(aTHX);
-
- exitstatus = perl_run( my_perl );
-
- perl_destruct( my_perl );
- perl_free( my_perl );
-
- PERL_SYS_TERM();
-
- exit( exitstatus );
-}
-
-/* yanked from perl.c */
-static void
-xs_init(pTHX)
-{
- char *file = __FILE__;
- dTARG;
- dSP;
-EOT
- print "\n#ifdef USE_DYNAMIC_LOADING";
- print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
- print "\n#endif\n" ;
- # delete $xsub{'DynaLoader'};
- delete $xsub{'UNIVERSAL'};
- print("/* bootstrapping code*/\n\tSAVETMPS;\n");
- print("\ttarg=sv_newmortal();\n");
- print "#ifdef USE_DYNAMIC_LOADING\n";
- print "\tPUSHMARK(sp);\n";
- print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
- print qq/\tPUTBACK;\n/;
- print "\tboot_DynaLoader(aTHX_ NULL);\n";
- print qq/\tSPAGAIN;\n/;
- print "#endif\n";
- foreach my $stashname (keys %xsub){
- if ($xsub{$stashname} !~ m/Dynamic/ ) {
- my $stashxsub=$stashname;
- $stashxsub =~ s/::/__/g;
- print "\tPUSHMARK(sp);\n";
- print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
- print qq/\tPUTBACK;\n/;
- print "\tboot_$stashxsub(aTHX_ NULL);\n";
- print qq/\tSPAGAIN;\n/;
- }
- }
- print("\tFREETMPS;\n/* end bootstrapping code */\n");
- print "}\n";
-
-print <<'EOT';
-static void
-dl_init(pTHX)
-{
- char *file = __FILE__;
- dTARG;
- dSP;
-EOT
- print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
- print("\ttarg=sv_newmortal();\n");
- foreach my $stashname (@DynaLoader::dl_modules) {
- warn "Loaded $stashname\n";
- if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
- my $stashxsub=$stashname;
- $stashxsub =~ s/::/__/g;
- print "\tPUSHMARK(sp);\n";
- print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
- print qq/\tPUTBACK;\n/;
- print "#ifdef USE_DYNAMIC_LOADING\n";
- warn "bootstrapping $stashname added to xs_init\n";
- if( $xsub{$stashname} eq 'Dynamic' ) {
- print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
- }
- else {
- print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
- }
- print "#else\n";
- print "\tboot_$stashxsub(aTHX_ NULL);\n";
- print "#endif\n";
- print qq/\tSPAGAIN;\n/;
- }
- }
- print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
- print "}\n";
-}
-sub dump_symtable {
- # For debugging
- my ($sym, $val);
- warn "----Symbol table:\n";
- while (($sym, $val) = each %symtable) {
- warn "$sym => $val\n";
- }
- warn "---End of symbol table\n";
-}
-
-sub save_object {
- my $sv;
- foreach $sv (@_) {
- svref_2object($sv)->save;
- }
-}
-
-sub Dummy_BootStrap { }
-
-sub B::GV::savecv
-{
- my $gv = shift;
- my $package=$gv->STASH->NAME;
- my $name = $gv->NAME;
- my $cv = $gv->CV;
- my $sv = $gv->SV;
- my $av = $gv->AV;
- my $hv = $gv->HV;
-
- my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
-
- # We may be looking at this package just because it is a branch in the
- # symbol table which is on the path to a package which we need to save
- # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
- #
- return unless ($unused_sub_packages{$package});
- return unless ($$cv || $$av || $$sv || $$hv);
- $gv->save;
-}
-
-sub mark_package
-{
- my $package = shift;
- unless ($unused_sub_packages{$package})
- {
- no strict 'refs';
- $unused_sub_packages{$package} = 1;
- if (defined @{$package.'::ISA'})
- {
- foreach my $isa (@{$package.'::ISA'})
- {
- if ($isa eq 'DynaLoader')
- {
- unless (defined(&{$package.'::bootstrap'}))
- {
- warn "Forcing bootstrap of $package\n";
- eval { $package->bootstrap };
- }
- }
-# else
- {
- unless ($unused_sub_packages{$isa})
- {
- warn "$isa saved (it is in $package\'s \@ISA)\n";
- mark_package($isa);
- }
- }
- }
- }
- }
- return 1;
-}
-
-sub should_save
-{
- no strict qw(vars refs);
- my $package = shift;
- $package =~ s/::$//;
- return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
- # warn "Considering $package\n";#debug
- foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
- {
- # If this package is a prefix to something we are saving, traverse it
- # but do not mark it for saving if it is not already
- # e.g. to get to Getopt::Long we need to traverse Getopt but need
- # not save Getopt
- return 1 if ($u =~ /^$package\:\:/);
- }
- if (exists $unused_sub_packages{$package})
- {
- # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
- delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
- return $unused_sub_packages{$package};
- }
- # Omit the packages which we use (and which cause grief
- # because of fancy "goto &$AUTOLOAD" stuff).
- # XXX Surely there must be a nicer way to do this.
- if ($package eq "FileHandle" || $package eq "Config" ||
- $package eq "SelectSaver" || $package =~/^(B|IO)::/)
- {
- delete_unsaved_hashINC($package);
- return $unused_sub_packages{$package} = 0;
- }
- # Now see if current package looks like an OO class this is probably too strong.
- foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
- {
- if (UNIVERSAL::can($package, $m))
- {
- warn "$package has method $m: saving package\n";#debug
- return mark_package($package);
- }
- }
- delete_unsaved_hashINC($package);
- return $unused_sub_packages{$package} = 0;
-}
-sub delete_unsaved_hashINC{
- my $packname=shift;
- $packname =~ s/\:\:/\//g;
- $packname .= '.pm';
-# warn "deleting $packname" if $INC{$packname} ;# debug
- delete $INC{$packname};
-}
-sub walkpackages
-{
- my ($symref, $recurse, $prefix) = @_;
- my $sym;
- my $ref;
- no strict 'vars';
- $prefix = '' unless defined $prefix;
- while (($sym, $ref) = each %$symref)
- {
- local(*glob);
- *glob = $ref;
- if ($sym =~ /::$/)
- {
- $sym = $prefix . $sym;
- if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
- {
- walkpackages(\%glob, $recurse, $sym);
- }
- }
- }
-}
-
-
-sub save_unused_subs
-{
- no strict qw(refs);
- &descend_marked_unused;
- warn "Prescan\n";
- walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
- warn "Saving methods\n";
- walksymtable(\%{"main::"}, "savecv", \&should_save);
-}
-
-sub save_context
-{
- my $curpad_nam = (comppadlist->ARRAY)[0]->save;
- my $curpad_sym = (comppadlist->ARRAY)[1]->save;
- my $inc_hv = svref_2object(\%INC)->save;
- my $inc_av = svref_2object(\@INC)->save;
- my $amagic_generate= amagic_generation;
- $init->add( "PL_curpad = AvARRAY($curpad_sym);",
- "GvHV(PL_incgv) = $inc_hv;",
- "GvAV(PL_incgv) = $inc_av;",
- "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
- "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
- "PL_amagic_generation= $amagic_generate;" );
-}
-
-sub descend_marked_unused {
- foreach my $pack (keys %unused_sub_packages)
- {
- mark_package($pack);
- }
-}
-
-sub save_main {
- # this is mainly for the test suite
- my $warner = $SIG{__WARN__};
- local $SIG{__WARN__} = sub { print STDERR @_ };
-
- warn "Starting compile\n";
- warn "Walking tree\n";
- seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
- walkoptree(main_root, "save");
- warn "done main optree, walking symtable for extras\n" if $debug_cv;
- save_unused_subs();
- # XSLoader was used, force saving of XSLoader::load
- if( $use_xsloader ) {
- my $cv = svref_2object( \&XSLoader::load );
- $cv->save;
- }
- # save %SIG ( in case it was set in a BEGIN block )
- if( $save_sig ) {
- local $SIG{__WARN__} = $warner;
- $init->no_split;
- $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
- foreach my $k ( keys %SIG ) {
- next unless ref $SIG{$k};
- my $cv = svref_2object( \$SIG{$k} );
- my $sv = $cv->save;
- $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
- $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
- cstring($k),length(pack "a*",$k),
- 'sv', hash($k)));
- $init->add('mg_set(sv);','}');
- }
- $init->add('}');
- $init->split;
- }
- # honour -w
- $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
- #
- my $init_av = init_av->save;
- my $end_av = end_av->save;
- $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
- sprintf("PL_main_start = s\\_%x;", ${main_start()}),
- "PL_initav = (AV *) $init_av;",
- "PL_endav = (AV*) $end_av;");
- save_context();
- # init op addrs ( must be the last action, otherwise
- # some ops might not be initialized
- if( $optimize_ppaddr ) {
- foreach my $i ( @op_sections ) {
- my $section = $$i;
- next unless $section->index >= 0;
- init_op_addr( $section->name, $section->index + 1);
- }
- }
- init_op_warn( $copsect->name, $copsect->index + 1)
- if $optimize_warn_sv && $copsect->index >= 0;
-
- warn "Writing output\n";
- output_boilerplate();
- print "\n";
- output_all("perl_init");
- print "\n";
- output_main();
-}
-
-sub init_sections {
- my @sections = (decl => \$decl, sym => \$symsect,
- binop => \$binopsect, condop => \$condopsect,
- cop => \$copsect, padop => \$padopsect,
- listop => \$listopsect, logop => \$logopsect,
- loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
- pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
- sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
- xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
- xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
- xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
- xrv => \$xrvsect, xpvbm => \$xpvbmsect,
- xpvio => \$xpviosect);
- my ($name, $sectref);
- while (($name, $sectref) = splice(@sections, 0, 2)) {
- $$sectref = new B::C::Section $name, \%symtable, 0;
- }
- $init = new B::C::InitSection 'init', \%symtable, 0;
-}
-
-sub mark_unused
-{
- my ($arg,$val) = @_;
- $unused_sub_packages{$arg} = $val;
-}
-
-sub compile {
- my @options = @_;
- my ($option, $opt, $arg);
- my @eval_at_startup;
- my %option_map = ( 'cog' => \$pv_copy_on_grow,
- 'save-data' => \$save_data_fh,
- 'ppaddr' => \$optimize_ppaddr,
- 'warn-sv' => \$optimize_warn_sv,
- 'use-script-name' => \$use_perl_script_name,
- 'save-sig-hash' => \$save_sig,
- );
- my %optimization_map = ( 0 => [ qw() ], # special case
- 1 => [ qw(-fcog) ],
- 2 => [ qw(-fwarn-sv -fppaddr) ],
- );
- OPTION:
- while ($option = shift @options) {
- if ($option =~ /^-(.)(.*)/) {
- $opt = $1;
- $arg = $2;
- } else {
- unshift @options, $option;
- last OPTION;
- }
- if ($opt eq "-" && $arg eq "-") {
- shift @options;
- last OPTION;
- }
- if ($opt eq "w") {
- $warn_undefined_syms = 1;
- } elsif ($opt eq "D") {
- $arg ||= shift @options;
- foreach $arg (split(//, $arg)) {
- if ($arg eq "o") {
- B->debug(1);
- } elsif ($arg eq "c") {
- $debug_cops = 1;
- } elsif ($arg eq "A") {
- $debug_av = 1;
- } elsif ($arg eq "C") {
- $debug_cv = 1;
- } elsif ($arg eq "M") {
- $debug_mg = 1;
- } else {
- warn "ignoring unknown debug option: $arg\n";
- }
- }
- } elsif ($opt eq "o") {
- $arg ||= shift @options;
- open(STDOUT, ">$arg") or return "$arg: $!\n";
- } elsif ($opt eq "v") {
- $verbose = 1;
- } elsif ($opt eq "u") {
- $arg ||= shift @options;
- mark_unused($arg,undef);
- } elsif ($opt eq "f") {
- $arg ||= shift @options;
- $arg =~ m/(no-)?(.*)/;
- my $no = defined($1) && $1 eq 'no-';
- $arg = $no ? $2 : $arg;
- if( exists $option_map{$arg} ) {
- ${$option_map{$arg}} = !$no;
- } else {
- die "Invalid optimization '$arg'";
- }
- } elsif ($opt eq "O") {
- $arg = 1 if $arg eq "";
- my @opt;
- foreach my $i ( 1 .. $arg ) {
- push @opt, @{$optimization_map{$i}}
- if exists $optimization_map{$i};
- }
- unshift @options, @opt;
- } elsif ($opt eq "e") {
- push @eval_at_startup, $arg;
- } elsif ($opt eq "l") {
- $max_string_len = $arg;
- }
- }
- init_sections();
- foreach my $i ( @eval_at_startup ) {
- $init->add_eval( $i );
- }
- if (@options) {
- return sub {
- my $objname;
- foreach $objname (@options) {
- eval "save_object(\\$objname)";
- }
- output_all();
- }
- } else {
- return sub { save_main() };
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::C - Perl compiler's C backend
-
-=head1 SYNOPSIS
-
- perl -MO=C[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-This compiler backend takes Perl source and generates C source code
-corresponding to the internal structures that perl uses to run
-your program. When the generated C source is compiled and run, it
-cuts out the time which perl would have taken to load and parse
-your program into its internal semi-compiled form. That means that
-compiling with this backend will not help improve the runtime
-execution speed of your program but may improve the start-up time.
-Depending on the environment in which your program runs this may be
-either a help or a hindrance.
-
-=head1 OPTIONS
-
-If there are any non-option arguments, they are taken to be
-names of objects to be saved (probably doesn't work properly yet).
-Without extra arguments, it saves the main program.
-
-=over 4
-
-=item B<-ofilename>
-
-Output to filename instead of STDOUT
-
-=item B<-v>
-
-Verbose compilation (currently gives a few compilation statistics).
-
-=item B<-->
-
-Force end of options
-
-=item B<-uPackname>
-
-Force apparently unused subs from package Packname to be compiled.
-This allows programs to use eval "foo()" even when sub foo is never
-seen to be used at compile time. The down side is that any subs which
-really are never used also have code generated. This option is
-necessary, for example, if you have a signal handler foo which you
-initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
-to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
-options. The compiler tries to figure out which packages may possibly
-have subs in which need compiling but the current version doesn't do
-it very well. In particular, it is confused by nested packages (i.e.
-of the form C<A::B>) where package C<A> does not contain any subs.
-
-=item B<-D>
-
-Debug options (concatenated or separate flags like C<perl -D>).
-
-=item B<-Do>
-
-OPs, prints each OP as it's processed
-
-=item B<-Dc>
-
-COPs, prints COPs as processed (incl. file & line num)
-
-=item B<-DA>
-
-prints AV information on saving
-
-=item B<-DC>
-
-prints CV information on saving
-
-=item B<-DM>
-
-prints MAGIC information on saving
-
-=item B<-f>
-
-Force options/optimisations on or off one at a time. You can explicitly
-disable an option using B<-fno-option>. All options default to
-B<disabled>.
-
-=over 4
-
-=item B<-fcog>
-
-Copy-on-grow: PVs declared and initialised statically.
-
-=item B<-fsave-data>
-
-Save package::DATA filehandles ( only available with PerlIO ).
-
-=item B<-fppaddr>
-
-Optimize the initialization of op_ppaddr.
-
-=item B<-fwarn-sv>
-
-Optimize the initialization of cop_warnings.
-
-=item B<-fuse-script-name>
-
-Use the script name instead of the program name as $0.
-
-=item B<-fsave-sig-hash>
-
-Save compile-time modifications to the %SIG hash.
-
-=back
-
-=item B<-On>
-
-Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
-
-=over 4
-
-=item B<-O0>
-
-Disable all optimizations.
-
-=item B<-O1>
-
-Enable B<-fcog>.
-
-=item B<-O2>
-
-Enable B<-fppaddr>, B<-fwarn-sv>.
-
-=back
-
-=item B<-llimit>
-
-Some C compilers impose an arbitrary limit on the length of string
-constants (e.g. 2048 characters for Microsoft Visual C++). The
-B<-llimit> options tells the C backend not to generate string literals
-exceeding that limit.
-
-=back
-
-=head1 EXAMPLES
-
- perl -MO=C,-ofoo.c foo.pl
- perl cc_harness -o foo foo.c
-
-Note that C<cc_harness> lives in the C<B> subdirectory of your perl
-library directory. The utility called C<perlcc> may also be used to
-help make use of this compiler.
-
- perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
-
-=head1 BUGS
-
-Plenty. Current status: experimental.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/CC.pm b/Master/tlpkg/installer/perllib/B/CC.pm
deleted file mode 100644
index 079313a0a4e..00000000000
--- a/Master/tlpkg/installer/perllib/B/CC.pm
+++ /dev/null
@@ -1,2005 +0,0 @@
-# CC.pm
-#
-# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-package B::CC;
-
-our $VERSION = '1.00_01';
-
-use Config;
-use strict;
-use B qw(main_start main_root class comppadlist peekop svref_2object
- timing_info init_av sv_undef amagic_generation
- OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
- OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
- OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
- CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
- );
-use B::C qw(save_unused_subs objsym init_sections mark_unused
- output_all output_boilerplate output_main);
-use B::Bblock qw(find_leaders);
-use B::Stackobj qw(:types :flags);
-
-# These should probably be elsewhere
-# Flags for $op->flags
-
-my $module; # module name (when compiled with -m)
-my %done; # hash keyed by $$op of leaders of basic blocks
- # which have already been done.
-my $leaders; # ref to hash of basic block leaders. Keys are $$op
- # addresses, values are the $op objects themselves.
-my @bblock_todo; # list of leaders of basic blocks that need visiting
- # sometime.
-my @cc_todo; # list of tuples defining what PP code needs to be
- # saved (e.g. CV, main or PMOP repl code). Each tuple
- # is [$name, $root, $start, @padlist]. PMOP repl code
- # tuples inherit padlist.
-my @stack; # shadows perl's stack when contents are known.
- # Values are objects derived from class B::Stackobj
-my @pad; # Lexicals in current pad as Stackobj-derived objects
-my @padlist; # Copy of current padlist so PMOP repl code can find it
-my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
-my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
-my %constobj; # OP_CONST constants as Stackobj-derived objects
- # keyed by $$sv.
-my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
- # block or even to the end of each loop of blocks,
- # depending on optimisation options.
-my $know_op = 0; # Set when C variable op already holds the right op
- # (from an immediately preceding DOOP(ppname)).
-my $errors = 0; # Number of errors encountered
-my %skip_stack; # Hash of PP names which don't need write_back_stack
-my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
-my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
-my %ignore_op; # Hash of ops which do nothing except returning op_next
-my %need_curcop; # Hash of ops which need PL_curcop
-
-my %lexstate; #state of padsvs at the start of a bblock
-
-BEGIN {
- foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
- $ignore_op{$_} = 1;
- }
-}
-
-my ($module_name);
-my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
- $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
-
-# Optimisation options. On the command line, use hyphens instead of
-# underscores for compatibility with gcc-style options. We use
-# underscores here because they are OK in (strict) barewords.
-my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
-my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
- freetmps_each_loop => \$freetmps_each_loop,
- omit_taint => \$omit_taint);
-# perl patchlevel to generate code for (defaults to current patchlevel)
-my $patchlevel = int(0.5 + 1000 * ($] - 5));
-
-# Could rewrite push_runtime() and output_runtime() to use a
-# temporary file if memory is at a premium.
-my $ppname; # name of current fake PP function
-my $runtime_list_ref;
-my $declare_ref; # Hash ref keyed by C variable type of declarations.
-
-my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
- # tuples to be written out.
-
-my ($init, $decl);
-
-sub init_hash { map { $_ => 1 } @_ }
-
-#
-# Initialise the hashes for the default PP functions where we can avoid
-# either write_back_stack, write_back_lexicals or invalidate_lexicals.
-#
-%skip_lexicals = init_hash qw(pp_enter pp_enterloop);
-%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
-%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
- pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
- pp_entertry pp_enterloop pp_enteriter pp_entersub
- pp_enter pp_method);
-
-sub debug {
- if ($debug_runtime) {
- warn(@_);
- } else {
- my @tmp=@_;
- runtime(map { chomp; "/* $_ */"} @tmp);
- }
-}
-
-sub declare {
- my ($type, $var) = @_;
- push(@{$declare_ref->{$type}}, $var);
-}
-
-sub push_runtime {
- push(@$runtime_list_ref, @_);
- warn join("\n", @_) . "\n" if $debug_runtime;
-}
-
-sub save_runtime {
- push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
-}
-
-sub output_runtime {
- my $ppdata;
- print qq(#include "cc_runtime.h"\n);
- foreach $ppdata (@pp_list) {
- my ($name, $runtime, $declare) = @$ppdata;
- print "\nstatic\nCCPP($name)\n{\n";
- my ($type, $varlist, $line);
- while (($type, $varlist) = each %$declare) {
- print "\t$type ", join(", ", @$varlist), ";\n";
- }
- foreach $line (@$runtime) {
- print $line, "\n";
- }
- print "}\n";
- }
-}
-
-sub runtime {
- my $line;
- foreach $line (@_) {
- push_runtime("\t$line");
- }
-}
-
-sub init_pp {
- $ppname = shift;
- $runtime_list_ref = [];
- $declare_ref = {};
- runtime("dSP;");
- declare("I32", "oldsave");
- declare("SV", "**svp");
- map { declare("SV", "*$_") } qw(sv src dst left right);
- declare("MAGIC", "*mg");
- $decl->add("static OP * $ppname (pTHX);");
- debug "init_pp: $ppname\n" if $debug_queue;
-}
-
-# Initialise runtime_callback function for Stackobj class
-BEGIN { B::Stackobj::set_callback(\&runtime) }
-
-# Initialise saveoptree_callback for B::C class
-sub cc_queue {
- my ($name, $root, $start, @pl) = @_;
- debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
- if $debug_queue;
- if ($name eq "*ignore*") {
- $name = 0;
- } else {
- push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
- }
- my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
- $start = $fakeop->save;
- debug "cc_queue: name $name returns $start\n" if $debug_queue;
- return $start;
-}
-BEGIN { B::C::set_callback(\&cc_queue) }
-
-sub valid_int { $_[0]->{flags} & VALID_INT }
-sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
-sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
-sub valid_sv { $_[0]->{flags} & VALID_SV }
-
-sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
-sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
-sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
-sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
-sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
-
-sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
-sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
-sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
-sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
-sub pop_bool {
- if (@stack) {
- return ((pop @stack)->as_bool);
- } else {
- # Careful: POPs has an auto-decrement and SvTRUE evaluates
- # its argument more than once.
- runtime("sv = POPs;");
- return "SvTRUE(sv)";
- }
-}
-
-sub write_back_lexicals {
- my $avoid = shift || 0;
- debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
- if $debug_shadow;
- my $lex;
- foreach $lex (@pad) {
- next unless ref($lex);
- $lex->write_back unless $lex->{flags} & $avoid;
- }
-}
-
-sub save_or_restore_lexical_state {
- my $bblock=shift;
- unless( exists $lexstate{$bblock}){
- foreach my $lex (@pad) {
- next unless ref($lex);
- ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
- }
- }
- else {
- foreach my $lex (@pad) {
- next unless ref($lex);
- my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ;
- next if ( $old_flags eq $lex->{flags});
- if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){
- $lex->write_back;
- }
- if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){
- $lex->load_double;
- }
- if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){
- $lex->load_int;
- }
- }
- }
-}
-
-sub write_back_stack {
- my $obj;
- return unless @stack;
- runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
- foreach $obj (@stack) {
- runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
- }
- @stack = ();
-}
-
-sub invalidate_lexicals {
- my $avoid = shift || 0;
- debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
- if $debug_shadow;
- my $lex;
- foreach $lex (@pad) {
- next unless ref($lex);
- $lex->invalidate unless $lex->{flags} & $avoid;
- }
-}
-
-sub reload_lexicals {
- my $lex;
- foreach $lex (@pad) {
- next unless ref($lex);
- my $type = $lex->{type};
- if ($type == T_INT) {
- $lex->as_int;
- } elsif ($type == T_DOUBLE) {
- $lex->as_double;
- } else {
- $lex->as_sv;
- }
- }
-}
-
-{
- package B::Pseudoreg;
- #
- # This class allocates pseudo-registers (OK, so they're C variables).
- #
- my %alloc; # Keyed by variable name. A value of 1 means the
- # variable has been declared. A value of 2 means
- # it's in use.
-
- sub new_scope { %alloc = () }
-
- sub new ($$$) {
- my ($class, $type, $prefix) = @_;
- my ($ptr, $i, $varname, $status, $obj);
- $prefix =~ s/^(\**)//;
- $ptr = $1;
- $i = 0;
- do {
- $varname = "$prefix$i";
- $status = $alloc{$varname};
- } while $status == 2;
- if ($status != 1) {
- # Not declared yet
- B::CC::declare($type, "$ptr$varname");
- $alloc{$varname} = 2; # declared and in use
- }
- $obj = bless \$varname, $class;
- return $obj;
- }
- sub DESTROY {
- my $obj = shift;
- $alloc{$$obj} = 1; # no longer in use but still declared
- }
-}
-{
- package B::Shadow;
- #
- # This class gives a standard API for a perl object to shadow a
- # C variable and only generate reloads/write-backs when necessary.
- #
- # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
- # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
- # Use $obj->invalidate whenever an unknown function may have
- # set shadow itself.
-
- sub new {
- my ($class, $write_back) = @_;
- # Object fields are perl shadow variable, validity flag
- # (for *C* variable) and callback sub for write_back
- # (passed perl shadow variable as argument).
- bless [undef, 1, $write_back], $class;
- }
- sub load {
- my ($obj, $newval) = @_;
- $obj->[1] = 0; # C variable no longer valid
- $obj->[0] = $newval;
- }
- sub write_back {
- my $obj = shift;
- if (!($obj->[1])) {
- $obj->[1] = 1; # C variable will now be valid
- &{$obj->[2]}($obj->[0]);
- }
- }
- sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
-}
-my $curcop = new B::Shadow (sub {
- my $opsym = shift->save;
- runtime("PL_curcop = (COP*)$opsym;");
-});
-
-#
-# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
-#
-sub dopoptoloop {
- my $cxix = $#cxstack;
- while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
- $cxix--;
- }
- debug "dopoptoloop: returning $cxix" if $debug_cxstack;
- return $cxix;
-}
-
-sub dopoptolabel {
- my $label = shift;
- my $cxix = $#cxstack;
- while ($cxix >= 0 &&
- ($cxstack[$cxix]->{type} != CXt_LOOP ||
- $cxstack[$cxix]->{label} ne $label)) {
- $cxix--;
- }
- debug "dopoptolabel: returning $cxix" if $debug_cxstack;
- return $cxix;
-}
-
-sub error {
- my $format = shift;
- my $file = $curcop->[0]->file;
- my $line = $curcop->[0]->line;
- $errors++;
- if (@_) {
- warn sprintf("%s:%d: $format\n", $file, $line, @_);
- } else {
- warn sprintf("%s:%d: %s\n", $file, $line, $format);
- }
-}
-
-#
-# Load pad takes (the elements of) a PADLIST as arguments and loads
-# up @pad with Stackobj-derived objects which represent those lexicals.
-# If/when perl itself can generate type information (my int $foo) then
-# we'll take advantage of that here. Until then, we'll use various hacks
-# to tell the compiler when we want a lexical to be a particular type
-# or to be a register.
-#
-sub load_pad {
- my ($namelistav, $valuelistav) = @_;
- @padlist = @_;
- my @namelist = $namelistav->ARRAY;
- my @valuelist = $valuelistav->ARRAY;
- my $ix;
- @pad = ();
- debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
- # Temporary lexicals don't get named so it's possible for @valuelist
- # to be strictly longer than @namelist. We count $ix up to the end of
- # @valuelist but index into @namelist for the name. Any temporaries which
- # run off the end of @namelist will make $namesv undefined and we treat
- # that the same as having an explicit SPECIAL sv_undef object in @namelist.
- # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
- for ($ix = 1; $ix < @valuelist; $ix++) {
- my $namesv = $namelist[$ix];
- my $type = T_UNKNOWN;
- my $flags = 0;
- my $name = "tmp$ix";
- my $class = class($namesv);
- if (!defined($namesv) || $class eq "SPECIAL") {
- # temporaries have &PL_sv_undef instead of a PVNV for a name
- $flags = VALID_SV|TEMPORARY|REGISTER;
- } else {
- if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
- $name = $1;
- if ($2 eq "i") {
- $type = T_INT;
- $flags = VALID_SV|VALID_INT;
- } elsif ($2 eq "d") {
- $type = T_DOUBLE;
- $flags = VALID_SV|VALID_DOUBLE;
- }
- $flags |= REGISTER if $3;
- }
- }
- $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
- "i_$name", "d_$name");
-
- debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
- }
-}
-
-sub declare_pad {
- my $ix;
- for ($ix = 1; $ix <= $#pad; $ix++) {
- my $type = $pad[$ix]->{type};
- declare("IV", $type == T_INT ?
- sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
- declare("double", $type == T_DOUBLE ?
- sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
-
- }
-}
-#
-# Debugging stuff
-#
-sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
-
-#
-# OP stuff
-#
-
-sub label {
- my $op = shift;
- # XXX Preserve original label name for "real" labels?
- return sprintf("lab_%x", $$op);
-}
-
-sub write_label {
- my $op = shift;
- push_runtime(sprintf(" %s:", label($op)));
-}
-
-sub loadop {
- my $op = shift;
- my $opsym = $op->save;
- runtime("PL_op = $opsym;") unless $know_op;
- return $opsym;
-}
-
-sub doop {
- my $op = shift;
- my $ppname = $op->ppaddr;
- my $sym = loadop($op);
- runtime("DOOP($ppname);");
- $know_op = 1;
- return $sym;
-}
-
-sub gimme {
- my $op = shift;
- my $flags = $op->flags;
- return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
-}
-
-#
-# Code generation for PP code
-#
-
-sub pp_null {
- my $op = shift;
- return $op->next;
-}
-
-sub pp_stub {
- my $op = shift;
- my $gimme = gimme($op);
- if ($gimme != G_ARRAY) {
- my $obj= new B::Stackobj::Const(sv_undef);
- push(@stack, $obj);
- # XXX Change to push a constant sv_undef Stackobj onto @stack
- #write_back_stack();
- #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
- }
- return $op->next;
-}
-
-sub pp_unstack {
- my $op = shift;
- @stack = ();
- runtime("PP_UNSTACK;");
- return $op->next;
-}
-
-sub pp_and {
- my $op = shift;
- my $next = $op->next;
- reload_lexicals();
- unshift(@bblock_todo, $next);
- if (@stack >= 1) {
- my $bool = pop_bool();
- write_back_stack();
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
- } else {
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
- "*sp--;");
- }
- return $op->other;
-}
-
-sub pp_or {
- my $op = shift;
- my $next = $op->next;
- reload_lexicals();
- unshift(@bblock_todo, $next);
- if (@stack >= 1) {
- my $bool = pop_bool @stack;
- write_back_stack();
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
- $bool, label($next)));
- } else {
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
- "*sp--;");
- }
- return $op->other;
-}
-
-sub pp_cond_expr {
- my $op = shift;
- my $false = $op->next;
- unshift(@bblock_todo, $false);
- reload_lexicals();
- my $bool = pop_bool();
- write_back_stack();
- save_or_restore_lexical_state($$false);
- runtime(sprintf("if (!$bool) goto %s;", label($false)));
- return $op->other;
-}
-
-sub pp_padsv {
- my $op = shift;
- my $ix = $op->targ;
- push(@stack, $pad[$ix]);
- if ($op->flags & OPf_MOD) {
- my $private = $op->private;
- if ($private & OPpLVAL_INTRO) {
- runtime("SAVECLEARSV(PL_curpad[$ix]);");
- } elsif ($private & OPpDEREF) {
- runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
- $ix, $private & OPpDEREF));
- $pad[$ix]->invalidate;
- }
- }
- return $op->next;
-}
-
-sub pp_const {
- my $op = shift;
- my $sv = $op->sv;
- my $obj;
- # constant could be in the pad (under useithreads)
- if ($$sv) {
- $obj = $constobj{$$sv};
- if (!defined($obj)) {
- $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
- }
- }
- else {
- $obj = $pad[$op->targ];
- }
- push(@stack, $obj);
- return $op->next;
-}
-
-sub pp_nextstate {
- my $op = shift;
- $curcop->load($op);
- @stack = ();
- debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno;
- runtime("TAINT_NOT;") unless $omit_taint;
- runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
- if ($freetmps_each_bblock || $freetmps_each_loop) {
- $need_freetmps = 1;
- } else {
- runtime("FREETMPS;");
- }
- return $op->next;
-}
-
-sub pp_dbstate {
- my $op = shift;
- $curcop->invalidate; # XXX?
- return default_pp($op);
-}
-
-#default_pp will handle this:
-#sub pp_bless { $curcop->write_back; default_pp(@_) }
-#sub pp_repeat { $curcop->write_back; default_pp(@_) }
-# The following subs need $curcop->write_back if we decide to support arybase:
-# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
-#sub pp_caller { $curcop->write_back; default_pp(@_) }
-#sub pp_reset { $curcop->write_back; default_pp(@_) }
-
-sub pp_rv2gv{
- my $op =shift;
- $curcop->write_back;
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- my $sym=doop($op);
- if ($op->private & OPpDEREF) {
- $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));
- $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
- $op->first->type));
- }
- return $op->next;
-}
-sub pp_sort {
- my $op = shift;
- my $ppname = $op->ppaddr;
- if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
- #this indicates the sort BLOCK Array case
- #ugly surgery required.
- my $root=$op->first->sibling->first;
- my $start=$root->first;
- $op->first->save;
- $op->first->sibling->save;
- $root->save;
- my $sym=$start->save;
- my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
- $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
- }
- $curcop->write_back;
- write_back_lexicals();
- write_back_stack();
- doop($op);
- return $op->next;
-}
-
-sub pp_gv {
- my $op = shift;
- my $gvsym;
- if ($Config{useithreads}) {
- $gvsym = $pad[$op->padix]->as_sv;
- }
- else {
- $gvsym = $op->gv->save;
- }
- write_back_stack();
- runtime("XPUSHs((SV*)$gvsym);");
- return $op->next;
-}
-
-sub pp_gvsv {
- my $op = shift;
- my $gvsym;
- if ($Config{useithreads}) {
- $gvsym = $pad[$op->padix]->as_sv;
- }
- else {
- $gvsym = $op->gv->save;
- }
- write_back_stack();
- if ($op->private & OPpLVAL_INTRO) {
- runtime("XPUSHs(save_scalar($gvsym));");
- } else {
- runtime("XPUSHs(GvSV($gvsym));");
- }
- return $op->next;
-}
-
-sub pp_aelemfast {
- my $op = shift;
- my $gvsym;
- if ($Config{useithreads}) {
- $gvsym = $pad[$op->padix]->as_sv;
- }
- else {
- $gvsym = $op->gv->save;
- }
- my $ix = $op->private;
- my $flag = $op->flags & OPf_MOD;
- write_back_stack();
- runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
- "PUSHs(svp ? *svp : &PL_sv_undef);");
- return $op->next;
-}
-
-sub int_binop {
- my ($op, $operator) = @_;
- if ($op->flags & OPf_STACKED) {
- my $right = pop_int();
- if (@stack >= 1) {
- my $left = top_int();
- $stack[-1]->set_int(&$operator($left, $right));
- } else {
- runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
- }
- } else {
- my $targ = $pad[$op->targ];
- my $right = new B::Pseudoreg ("IV", "riv");
- my $left = new B::Pseudoreg ("IV", "liv");
- runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
- $targ->set_int(&$operator($$left, $$right));
- push(@stack, $targ);
- }
- return $op->next;
-}
-
-sub INTS_CLOSED () { 0x1 }
-sub INT_RESULT () { 0x2 }
-sub NUMERIC_RESULT () { 0x4 }
-
-sub numeric_binop {
- my ($op, $operator, $flags) = @_;
- my $force_int = 0;
- $force_int ||= ($flags & INT_RESULT);
- $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
- && valid_int($stack[-2]) && valid_int($stack[-1]));
- if ($op->flags & OPf_STACKED) {
- my $right = pop_numeric();
- if (@stack >= 1) {
- my $left = top_numeric();
- if ($force_int) {
- $stack[-1]->set_int(&$operator($left, $right));
- } else {
- $stack[-1]->set_numeric(&$operator($left, $right));
- }
- } else {
- if ($force_int) {
- my $rightruntime = new B::Pseudoreg ("IV", "riv");
- runtime(sprintf("$$rightruntime = %s;",$right));
- runtime(sprintf("sv_setiv(TOPs, %s);",
- &$operator("TOPi", $$rightruntime)));
- } else {
- my $rightruntime = new B::Pseudoreg ("double", "rnv");
- runtime(sprintf("$$rightruntime = %s;",$right));
- runtime(sprintf("sv_setnv(TOPs, %s);",
- &$operator("TOPn",$$rightruntime)));
- }
- }
- } else {
- my $targ = $pad[$op->targ];
- $force_int ||= ($targ->{type} == T_INT);
- if ($force_int) {
- my $right = new B::Pseudoreg ("IV", "riv");
- my $left = new B::Pseudoreg ("IV", "liv");
- runtime(sprintf("$$right = %s; $$left = %s;",
- pop_numeric(), pop_numeric));
- $targ->set_int(&$operator($$left, $$right));
- } else {
- my $right = new B::Pseudoreg ("double", "rnv");
- my $left = new B::Pseudoreg ("double", "lnv");
- runtime(sprintf("$$right = %s; $$left = %s;",
- pop_numeric(), pop_numeric));
- $targ->set_numeric(&$operator($$left, $$right));
- }
- push(@stack, $targ);
- }
- return $op->next;
-}
-
-sub pp_ncmp {
- my ($op) = @_;
- if ($op->flags & OPf_STACKED) {
- my $right = pop_numeric();
- if (@stack >= 1) {
- my $left = top_numeric();
- runtime sprintf("if (%s > %s){",$left,$right);
- $stack[-1]->set_int(1);
- $stack[-1]->write_back();
- runtime sprintf("}else if (%s < %s ) {",$left,$right);
- $stack[-1]->set_int(-1);
- $stack[-1]->write_back();
- runtime sprintf("}else if (%s == %s) {",$left,$right);
- $stack[-1]->set_int(0);
- $stack[-1]->write_back();
- runtime sprintf("}else {");
- $stack[-1]->set_sv("&PL_sv_undef");
- runtime "}";
- } else {
- my $rightruntime = new B::Pseudoreg ("double", "rnv");
- runtime(sprintf("$$rightruntime = %s;",$right));
- runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
- runtime sprintf("sv_setiv(TOPs,1);");
- runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
- runtime sprintf("sv_setiv(TOPs,-1);");
- runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
- runtime sprintf("sv_setiv(TOPs,0);");
- runtime sprintf(qq/}else {/);
- runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
- runtime "}";
- }
- } else {
- my $targ = $pad[$op->targ];
- my $right = new B::Pseudoreg ("double", "rnv");
- my $left = new B::Pseudoreg ("double", "lnv");
- runtime(sprintf("$$right = %s; $$left = %s;",
- pop_numeric(), pop_numeric));
- runtime sprintf("if (%s > %s){",$$left,$$right);
- $targ->set_int(1);
- $targ->write_back();
- runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
- $targ->set_int(-1);
- $targ->write_back();
- runtime sprintf("}else if (%s == %s) {",$$left,$$right);
- $targ->set_int(0);
- $targ->write_back();
- runtime sprintf("}else {");
- $targ->set_sv("&PL_sv_undef");
- runtime "}";
- push(@stack, $targ);
- }
- return $op->next;
-}
-
-sub sv_binop {
- my ($op, $operator, $flags) = @_;
- if ($op->flags & OPf_STACKED) {
- my $right = pop_sv();
- if (@stack >= 1) {
- my $left = top_sv();
- if ($flags & INT_RESULT) {
- $stack[-1]->set_int(&$operator($left, $right));
- } elsif ($flags & NUMERIC_RESULT) {
- $stack[-1]->set_numeric(&$operator($left, $right));
- } else {
- # XXX Does this work?
- runtime(sprintf("sv_setsv($left, %s);",
- &$operator($left, $right)));
- $stack[-1]->invalidate;
- }
- } else {
- my $f;
- if ($flags & INT_RESULT) {
- $f = "sv_setiv";
- } elsif ($flags & NUMERIC_RESULT) {
- $f = "sv_setnv";
- } else {
- $f = "sv_setsv";
- }
- runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
- }
- } else {
- my $targ = $pad[$op->targ];
- runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
- if ($flags & INT_RESULT) {
- $targ->set_int(&$operator("left", "right"));
- } elsif ($flags & NUMERIC_RESULT) {
- $targ->set_numeric(&$operator("left", "right"));
- } else {
- # XXX Does this work?
- runtime(sprintf("sv_setsv(%s, %s);",
- $targ->as_sv, &$operator("left", "right")));
- $targ->invalidate;
- }
- push(@stack, $targ);
- }
- return $op->next;
-}
-
-sub bool_int_binop {
- my ($op, $operator) = @_;
- my $right = new B::Pseudoreg ("IV", "riv");
- my $left = new B::Pseudoreg ("IV", "liv");
- runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
- my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
- $bool->set_int(&$operator($$left, $$right));
- push(@stack, $bool);
- return $op->next;
-}
-
-sub bool_numeric_binop {
- my ($op, $operator) = @_;
- my $right = new B::Pseudoreg ("double", "rnv");
- my $left = new B::Pseudoreg ("double", "lnv");
- runtime(sprintf("$$right = %s; $$left = %s;",
- pop_numeric(), pop_numeric()));
- my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
- $bool->set_numeric(&$operator($$left, $$right));
- push(@stack, $bool);
- return $op->next;
-}
-
-sub bool_sv_binop {
- my ($op, $operator) = @_;
- runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
- my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
- $bool->set_numeric(&$operator("left", "right"));
- push(@stack, $bool);
- return $op->next;
-}
-
-sub infix_op {
- my $opname = shift;
- return sub { "$_[0] $opname $_[1]" }
-}
-
-sub prefix_op {
- my $opname = shift;
- return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
-}
-
-BEGIN {
- my $plus_op = infix_op("+");
- my $minus_op = infix_op("-");
- my $multiply_op = infix_op("*");
- my $divide_op = infix_op("/");
- my $modulo_op = infix_op("%");
- my $lshift_op = infix_op("<<");
- my $rshift_op = infix_op(">>");
- my $scmp_op = prefix_op("sv_cmp");
- my $seq_op = prefix_op("sv_eq");
- my $sne_op = prefix_op("!sv_eq");
- my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
- my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
- my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
- my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
- my $eq_op = infix_op("==");
- my $ne_op = infix_op("!=");
- my $lt_op = infix_op("<");
- my $gt_op = infix_op(">");
- my $le_op = infix_op("<=");
- my $ge_op = infix_op(">=");
-
- #
- # XXX The standard perl PP code has extra handling for
- # some special case arguments of these operators.
- #
- sub pp_add { numeric_binop($_[0], $plus_op) }
- sub pp_subtract { numeric_binop($_[0], $minus_op) }
- sub pp_multiply { numeric_binop($_[0], $multiply_op) }
- sub pp_divide { numeric_binop($_[0], $divide_op) }
- sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
-
- sub pp_left_shift { int_binop($_[0], $lshift_op) }
- sub pp_right_shift { int_binop($_[0], $rshift_op) }
- sub pp_i_add { int_binop($_[0], $plus_op) }
- sub pp_i_subtract { int_binop($_[0], $minus_op) }
- sub pp_i_multiply { int_binop($_[0], $multiply_op) }
- sub pp_i_divide { int_binop($_[0], $divide_op) }
- sub pp_i_modulo { int_binop($_[0], $modulo_op) }
-
- sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
- sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
- sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
- sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
- sub pp_le { bool_numeric_binop($_[0], $le_op) }
- sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
-
- sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
- sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
- sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
- sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
- sub pp_i_le { bool_int_binop($_[0], $le_op) }
- sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
-
- sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
- sub pp_slt { bool_sv_binop($_[0], $slt_op) }
- sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
- sub pp_sle { bool_sv_binop($_[0], $sle_op) }
- sub pp_sge { bool_sv_binop($_[0], $sge_op) }
- sub pp_seq { bool_sv_binop($_[0], $seq_op) }
- sub pp_sne { bool_sv_binop($_[0], $sne_op) }
-}
-
-
-sub pp_sassign {
- my $op = shift;
- my $backwards = $op->private & OPpASSIGN_BACKWARDS;
- my ($dst, $src);
- if (@stack >= 2) {
- $dst = pop @stack;
- $src = pop @stack;
- ($src, $dst) = ($dst, $src) if $backwards;
- my $type = $src->{type};
- if ($type == T_INT) {
- $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
- } elsif ($type == T_DOUBLE) {
- $dst->set_numeric($src->as_numeric);
- } else {
- $dst->set_sv($src->as_sv);
- }
- push(@stack, $dst);
- } elsif (@stack == 1) {
- if ($backwards) {
- my $src = pop @stack;
- my $type = $src->{type};
- runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
- if ($type == T_INT) {
- if ($src->{flags} & VALID_UNSIGNED){
- runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
- }else{
- runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
- }
- } elsif ($type == T_DOUBLE) {
- runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
- } else {
- runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
- }
- runtime("SvSETMAGIC(TOPs);");
- } else {
- my $dst = $stack[-1];
- my $type = $dst->{type};
- runtime("sv = POPs;");
- runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
- if ($type == T_INT) {
- $dst->set_int("SvIV(sv)");
- } elsif ($type == T_DOUBLE) {
- $dst->set_double("SvNV(sv)");
- } else {
- runtime("SvSetMagicSV($dst->{sv}, sv);");
- $dst->invalidate;
- }
- }
- } else {
- if ($backwards) {
- runtime("src = POPs; dst = TOPs;");
- } else {
- runtime("dst = POPs; src = TOPs;");
- }
- runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
- "SvSetSV(dst, src);",
- "SvSETMAGIC(dst);",
- "SETs(dst);");
- }
- return $op->next;
-}
-
-sub pp_preinc {
- my $op = shift;
- if (@stack >= 1) {
- my $obj = $stack[-1];
- my $type = $obj->{type};
- if ($type == T_INT || $type == T_DOUBLE) {
- $obj->set_int($obj->as_int . " + 1");
- } else {
- runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
- $obj->invalidate();
- }
- } else {
- runtime sprintf("PP_PREINC(TOPs);");
- }
- return $op->next;
-}
-
-
-sub pp_pushmark {
- my $op = shift;
- write_back_stack();
- runtime("PUSHMARK(sp);");
- return $op->next;
-}
-
-sub pp_list {
- my $op = shift;
- write_back_stack();
- my $gimme = gimme($op);
- if ($gimme == G_ARRAY) { # sic
- runtime("POPMARK;"); # need this even though not a "full" pp_list
- } else {
- runtime("PP_LIST($gimme);");
- }
- return $op->next;
-}
-
-sub pp_entersub {
- my $op = shift;
- $curcop->write_back;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = doop($op);
- runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
- runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
- runtime("SPAGAIN;}");
- $know_op = 0;
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-sub pp_formline {
- my $op = shift;
- my $ppname = $op->ppaddr;
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- my $sym=doop($op);
- # See comment in pp_grepwhile to see why!
- $init->add("((LISTOP*)$sym)->op_first = $sym;");
- runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
- save_or_restore_lexical_state(${$op->first});
- runtime( sprintf("goto %s;",label($op->first)));
- runtime("}");
- return $op->next;
-}
-
-sub pp_goto{
-
- my $op = shift;
- my $ppname = $op->ppaddr;
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- my $sym=doop($op);
- runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
- invalidate_lexicals() unless $skip_invalidate{$ppname};
- return $op->next;
-}
-sub pp_enterwrite {
- my $op = shift;
- pp_entersub($op);
-}
-sub pp_leavesub{
- my $op = shift;
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
- runtime("\tPUTBACK;return 0;");
- runtime("}");
- doop($op);
- return $op->next;
-}
-sub pp_leavewrite {
- my $op = shift;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = doop($op);
- # XXX Is this the right way to distinguish between it returning
- # CvSTART(cv) (via doform) and pop_return()?
- #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
- runtime("SPAGAIN;");
- $know_op = 0;
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-
-sub doeval {
- my $op = shift;
- $curcop->write_back;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = loadop($op);
- my $ppaddr = $op->ppaddr;
- #runtime(qq/printf("$ppaddr type eval\n");/);
- runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
- $know_op = 1;
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-
-sub pp_entereval { doeval(@_) }
-sub pp_dofile { doeval(@_) }
-
-#pp_require is protected by pp_entertry, so no protection for it.
-sub pp_require {
- my $op = shift;
- $curcop->write_back;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = doop($op);
- runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
- runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
- runtime("SPAGAIN;}");
- $know_op = 1;
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-
-
-sub pp_entertry {
- my $op = shift;
- $curcop->write_back;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = doop($op);
- my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
- declare("JMPENV", $jmpbuf);
- runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-
-sub pp_leavetry{
- my $op=shift;
- default_pp($op);
- runtime("PP_LEAVETRY;");
- return $op->next;
-}
-
-sub pp_grepstart {
- my $op = shift;
- if ($need_freetmps && $freetmps_each_loop) {
- runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
- $need_freetmps = 0;
- }
- write_back_stack();
- my $sym= doop($op);
- my $next=$op->next;
- $next->save;
- my $nexttonext=$next->next;
- $nexttonext->save;
- save_or_restore_lexical_state($$nexttonext);
- runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
- label($nexttonext)));
- return $op->next->other;
-}
-
-sub pp_mapstart {
- my $op = shift;
- if ($need_freetmps && $freetmps_each_loop) {
- runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
- $need_freetmps = 0;
- }
- write_back_stack();
- # pp_mapstart can return either op_next->op_next or op_next->op_other and
- # we need to be able to distinguish the two at runtime.
- my $sym= doop($op);
- my $next=$op->next;
- $next->save;
- my $nexttonext=$next->next;
- $nexttonext->save;
- save_or_restore_lexical_state($$nexttonext);
- runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
- label($nexttonext)));
- return $op->next->other;
-}
-
-sub pp_grepwhile {
- my $op = shift;
- my $next = $op->next;
- unshift(@bblock_todo, $next);
- write_back_lexicals();
- write_back_stack();
- my $sym = doop($op);
- # pp_grepwhile can return either op_next or op_other and we need to
- # be able to distinguish the two at runtime. Since it's possible for
- # both ops to be "inlined", the fields could both be zero. To get
- # around that, we hack op_next to be our own op (purely because we
- # know it's a non-NULL pointer and can't be the same as op_other).
- $init->add("((LOGOP*)$sym)->op_next = $sym;");
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
- $know_op = 0;
- return $op->other;
-}
-
-sub pp_mapwhile {
- pp_grepwhile(@_);
-}
-
-sub pp_return {
- my $op = shift;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- doop($op);
- runtime("PUTBACK;", "return PL_op;");
- $know_op = 0;
- return $op->next;
-}
-
-sub nyi {
- my $op = shift;
- warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
- return default_pp($op);
-}
-
-sub pp_range {
- my $op = shift;
- my $flags = $op->flags;
- if (!($flags & OPf_WANT)) {
- error("context of range unknown at compile-time");
- }
- write_back_lexicals();
- write_back_stack();
- unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
- # We need to save our UNOP structure since pp_flop uses
- # it to find and adjust out targ. We don't need it ourselves.
- $op->save;
- save_or_restore_lexical_state(${$op->other});
- runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
- $op->targ, label($op->other));
- unshift(@bblock_todo, $op->other);
- }
- return $op->next;
-}
-
-sub pp_flip {
- my $op = shift;
- my $flags = $op->flags;
- if (!($flags & OPf_WANT)) {
- error("context of flip unknown at compile-time");
- }
- if (($flags & OPf_WANT)==OPf_WANT_LIST) {
- return $op->first->other;
- }
- write_back_lexicals();
- write_back_stack();
- # We need to save our UNOP structure since pp_flop uses
- # it to find and adjust out targ. We don't need it ourselves.
- $op->save;
- my $ix = $op->targ;
- my $rangeix = $op->first->targ;
- runtime(($op->private & OPpFLIP_LINENUM) ?
- "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
- : "if (SvTRUE(TOPs)) {");
- runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
- if ($op->flags & OPf_SPECIAL) {
- runtime("sv_setiv(PL_curpad[$ix], 1);");
- } else {
- save_or_restore_lexical_state(${$op->first->other});
- runtime("\tsv_setiv(PL_curpad[$ix], 0);",
- "\tsp--;",
- sprintf("\tgoto %s;", label($op->first->other)));
- }
- runtime("}",
- qq{sv_setpv(PL_curpad[$ix], "");},
- "SETs(PL_curpad[$ix]);");
- $know_op = 0;
- return $op->next;
-}
-
-sub pp_flop {
- my $op = shift;
- default_pp($op);
- $know_op = 0;
- return $op->next;
-}
-
-sub enterloop {
- my $op = shift;
- my $nextop = $op->nextop;
- my $lastop = $op->lastop;
- my $redoop = $op->redoop;
- $curcop->write_back;
- debug "enterloop: pushing on cxstack" if $debug_cxstack;
- push(@cxstack, {
- type => CXt_LOOP,
- op => $op,
- "label" => $curcop->[0]->label,
- nextop => $nextop,
- lastop => $lastop,
- redoop => $redoop
- });
- $nextop->save;
- $lastop->save;
- $redoop->save;
- return default_pp($op);
-}
-
-sub pp_enterloop { enterloop(@_) }
-sub pp_enteriter { enterloop(@_) }
-
-sub pp_leaveloop {
- my $op = shift;
- if (!@cxstack) {
- die "panic: leaveloop";
- }
- debug "leaveloop: popping from cxstack" if $debug_cxstack;
- pop(@cxstack);
- return default_pp($op);
-}
-
-sub pp_next {
- my $op = shift;
- my $cxix;
- if ($op->flags & OPf_SPECIAL) {
- $cxix = dopoptoloop();
- if ($cxix < 0) {
- error('"next" used outside loop');
- return $op->next; # ignore the op
- }
- } else {
- $cxix = dopoptolabel($op->pv);
- if ($cxix < 0) {
- error('Label not found at compile time for "next %s"', $op->pv);
- return $op->next; # ignore the op
- }
- }
- default_pp($op);
- my $nextop = $cxstack[$cxix]->{nextop};
- push(@bblock_todo, $nextop);
- save_or_restore_lexical_state($$nextop);
- runtime(sprintf("goto %s;", label($nextop)));
- return $op->next;
-}
-
-sub pp_redo {
- my $op = shift;
- my $cxix;
- if ($op->flags & OPf_SPECIAL) {
- $cxix = dopoptoloop();
- if ($cxix < 0) {
- error('"redo" used outside loop');
- return $op->next; # ignore the op
- }
- } else {
- $cxix = dopoptolabel($op->pv);
- if ($cxix < 0) {
- error('Label not found at compile time for "redo %s"', $op->pv);
- return $op->next; # ignore the op
- }
- }
- default_pp($op);
- my $redoop = $cxstack[$cxix]->{redoop};
- push(@bblock_todo, $redoop);
- save_or_restore_lexical_state($$redoop);
- runtime(sprintf("goto %s;", label($redoop)));
- return $op->next;
-}
-
-sub pp_last {
- my $op = shift;
- my $cxix;
- if ($op->flags & OPf_SPECIAL) {
- $cxix = dopoptoloop();
- if ($cxix < 0) {
- error('"last" used outside loop');
- return $op->next; # ignore the op
- }
- } else {
- $cxix = dopoptolabel($op->pv);
- if ($cxix < 0) {
- error('Label not found at compile time for "last %s"', $op->pv);
- return $op->next; # ignore the op
- }
- # XXX Add support for "last" to leave non-loop blocks
- if ($cxstack[$cxix]->{type} != CXt_LOOP) {
- error('Use of "last" for non-loop blocks is not yet implemented');
- return $op->next; # ignore the op
- }
- }
- default_pp($op);
- my $lastop = $cxstack[$cxix]->{lastop}->next;
- push(@bblock_todo, $lastop);
- save_or_restore_lexical_state($$lastop);
- runtime(sprintf("goto %s;", label($lastop)));
- return $op->next;
-}
-
-sub pp_subst {
- my $op = shift;
- write_back_lexicals();
- write_back_stack();
- my $sym = doop($op);
- my $replroot = $op->pmreplroot;
- if ($$replroot) {
- save_or_restore_lexical_state($$replroot);
- runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
- $sym, label($replroot));
- $op->pmreplstart->save;
- push(@bblock_todo, $replroot);
- }
- invalidate_lexicals();
- return $op->next;
-}
-
-sub pp_substcont {
- my $op = shift;
- write_back_lexicals();
- write_back_stack();
- doop($op);
- my $pmop = $op->other;
- # warn sprintf("substcont: op = %s, pmop = %s\n",
- # peekop($op), peekop($pmop));#debug
-# my $pmopsym = objsym($pmop);
- my $pmopsym = $pmop->save; # XXX can this recurse?
-# warn "pmopsym = $pmopsym\n";#debug
- save_or_restore_lexical_state(${$pmop->pmreplstart});
- runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
- $pmopsym, label($pmop->pmreplstart));
- invalidate_lexicals();
- return $pmop->next;
-}
-
-sub default_pp {
- my $op = shift;
- my $ppname = "pp_" . $op->name;
- if ($curcop and $need_curcop{$ppname}){
- $curcop->write_back;
- }
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- doop($op);
- # XXX If the only way that ops can write to a TEMPORARY lexical is
- # when it's named in $op->targ then we could call
- # invalidate_lexicals(TEMPORARY) and avoid having to write back all
- # the temporaries. For now, we'll play it safe and write back the lot.
- invalidate_lexicals() unless $skip_invalidate{$ppname};
- return $op->next;
-}
-
-sub compile_op {
- my $op = shift;
- my $ppname = "pp_" . $op->name;
- if (exists $ignore_op{$ppname}) {
- return $op->next;
- }
- debug peek_stack() if $debug_stack;
- if ($debug_op) {
- debug sprintf("%s [%s]\n",
- peekop($op),
- $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
- }
- no strict 'refs';
- if (defined(&$ppname)) {
- $know_op = 0;
- return &$ppname($op);
- } else {
- return default_pp($op);
- }
-}
-
-sub compile_bblock {
- my $op = shift;
- #warn "compile_bblock: ", peekop($op), "\n"; # debug
- save_or_restore_lexical_state($$op);
- write_label($op);
- $know_op = 0;
- do {
- $op = compile_op($op);
- } while (defined($op) && $$op && !exists($leaders->{$$op}));
- write_back_stack(); # boo hoo: big loss
- reload_lexicals();
- return $op;
-}
-
-sub cc {
- my ($name, $root, $start, @padlist) = @_;
- my $op;
- if($done{$$start}){
- #warn "repeat=>".ref($start)."$name,\n";#debug
- $decl->add(sprintf("#define $name %s",$done{$$start}));
- return;
- }
- init_pp($name);
- load_pad(@padlist);
- %lexstate=();
- B::Pseudoreg->new_scope;
- @cxstack = ();
- if ($debug_timings) {
- warn sprintf("Basic block analysis at %s\n", timing_info);
- }
- $leaders = find_leaders($root, $start);
- my @leaders= keys %$leaders;
- if ($#leaders > -1) {
- @bblock_todo = ($start, values %$leaders) ;
- } else{
- runtime("return PL_op?PL_op->op_next:0;");
- }
- if ($debug_timings) {
- warn sprintf("Compilation at %s\n", timing_info);
- }
- while (@bblock_todo) {
- $op = shift @bblock_todo;
- #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
- next if !defined($op) || !$$op || $done{$$op};
- #warn "...compiling it\n"; # debug
- do {
- $done{$$op} = $name;
- $op = compile_bblock($op);
- if ($need_freetmps && $freetmps_each_bblock) {
- runtime("FREETMPS;");
- $need_freetmps = 0;
- }
- } while defined($op) && $$op && !$done{$$op};
- if ($need_freetmps && $freetmps_each_loop) {
- runtime("FREETMPS;");
- $need_freetmps = 0;
- }
- if (!$$op) {
- runtime("PUTBACK;","return PL_op;");
- } elsif ($done{$$op}) {
- save_or_restore_lexical_state($$op);
- runtime(sprintf("goto %s;", label($op)));
- }
- }
- if ($debug_timings) {
- warn sprintf("Saving runtime at %s\n", timing_info);
- }
- declare_pad(@padlist) ;
- save_runtime();
-}
-
-sub cc_recurse {
- my $ccinfo;
- my $start;
- $start = cc_queue(@_) if @_;
- while ($ccinfo = shift @cc_todo) {
- cc(@$ccinfo);
- }
- return $start;
-}
-
-sub cc_obj {
- my ($name, $cvref) = @_;
- my $cv = svref_2object($cvref);
- my @padlist = $cv->PADLIST->ARRAY;
- my $curpad_sym = $padlist[1]->save;
- cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
-}
-
-sub cc_main {
- my @comppadlist = comppadlist->ARRAY;
- my $curpad_nam = $comppadlist[0]->save;
- my $curpad_sym = $comppadlist[1]->save;
- my $init_av = init_av->save;
- my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
- # Do save_unused_subs before saving inc_hv
- save_unused_subs();
- cc_recurse();
-
- my $inc_hv = svref_2object(\%INC)->save;
- my $inc_av = svref_2object(\@INC)->save;
- my $amagic_generate= amagic_generation;
- return if $errors;
- if (!defined($module)) {
- $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
- "PL_main_start = $start;",
- "PL_curpad = AvARRAY($curpad_sym);",
- "PL_initav = (AV *) $init_av;",
- "GvHV(PL_incgv) = $inc_hv;",
- "GvAV(PL_incgv) = $inc_av;",
- "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
- "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
- "PL_amagic_generation= $amagic_generate;",
- );
-
- }
- seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
- output_boilerplate();
- print "\n";
- output_all("perl_init");
- output_runtime();
- print "\n";
- output_main();
- if (defined($module)) {
- my $cmodule = $module;
- $cmodule =~ s/::/__/g;
- print <<"EOT";
-
-#include "XSUB.h"
-XS(boot_$cmodule)
-{
- dXSARGS;
- perl_init();
- ENTER;
- SAVETMPS;
- SAVEVPTR(PL_curpad);
- SAVEVPTR(PL_op);
- PL_curpad = AvARRAY($curpad_sym);
- PL_op = $start;
- pp_main(aTHX);
- FREETMPS;
- LEAVE;
- ST(0) = &PL_sv_yes;
- XSRETURN(1);
-}
-EOT
- }
- if ($debug_timings) {
- warn sprintf("Done at %s\n", timing_info);
- }
-}
-
-sub compile {
- my @options = @_;
- my ($option, $opt, $arg);
- OPTION:
- while ($option = shift @options) {
- if ($option =~ /^-(.)(.*)/) {
- $opt = $1;
- $arg = $2;
- } else {
- unshift @options, $option;
- last OPTION;
- }
- if ($opt eq "-" && $arg eq "-") {
- shift @options;
- last OPTION;
- } elsif ($opt eq "o") {
- $arg ||= shift @options;
- open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
- } elsif ($opt eq "n") {
- $arg ||= shift @options;
- $module_name = $arg;
- } elsif ($opt eq "u") {
- $arg ||= shift @options;
- mark_unused($arg,undef);
- } elsif ($opt eq "f") {
- $arg ||= shift @options;
- my $value = $arg !~ s/^no-//;
- $arg =~ s/-/_/g;
- my $ref = $optimise{$arg};
- if (defined($ref)) {
- $$ref = $value;
- } else {
- warn qq(ignoring unknown optimisation option "$arg"\n);
- }
- } elsif ($opt eq "O") {
- $arg = 1 if $arg eq "";
- my $ref;
- foreach $ref (values %optimise) {
- $$ref = 0;
- }
- if ($arg >= 2) {
- $freetmps_each_loop = 1;
- }
- if ($arg >= 1) {
- $freetmps_each_bblock = 1 unless $freetmps_each_loop;
- }
- } elsif ($opt eq "m") {
- $arg ||= shift @options;
- $module = $arg;
- mark_unused($arg,undef);
- } elsif ($opt eq "p") {
- $arg ||= shift @options;
- $patchlevel = $arg;
- } elsif ($opt eq "D") {
- $arg ||= shift @options;
- foreach $arg (split(//, $arg)) {
- if ($arg eq "o") {
- B->debug(1);
- } elsif ($arg eq "O") {
- $debug_op = 1;
- } elsif ($arg eq "s") {
- $debug_stack = 1;
- } elsif ($arg eq "c") {
- $debug_cxstack = 1;
- } elsif ($arg eq "p") {
- $debug_pad = 1;
- } elsif ($arg eq "r") {
- $debug_runtime = 1;
- } elsif ($arg eq "S") {
- $debug_shadow = 1;
- } elsif ($arg eq "q") {
- $debug_queue = 1;
- } elsif ($arg eq "l") {
- $debug_lineno = 1;
- } elsif ($arg eq "t") {
- $debug_timings = 1;
- }
- }
- }
- }
- init_sections();
- $init = B::Section->get("init");
- $decl = B::Section->get("decl");
-
- if (@options) {
- return sub {
- my ($objname, $ppname);
- foreach $objname (@options) {
- $objname = "main::$objname" unless $objname =~ /::/;
- ($ppname = $objname) =~ s/^.*?:://;
- eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
- die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
- return if $errors;
- }
- output_boilerplate();
- print "\n";
- output_all($module_name || "init_module");
- output_runtime();
- }
- } else {
- return sub { cc_main() };
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::CC - Perl compiler's optimized C translation backend
-
-=head1 SYNOPSIS
-
- perl -MO=CC[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-This compiler backend takes Perl source and generates C source code
-corresponding to the flow of your program. In other words, this
-backend is somewhat a "real" compiler in the sense that many people
-think about compilers. Note however that, currently, it is a very
-poor compiler in that although it generates (mostly, or at least
-sometimes) correct code, it performs relatively few optimisations.
-This will change as the compiler develops. The result is that
-running an executable compiled with this backend may start up more
-quickly than running the original Perl program (a feature shared
-by the B<C> compiler backend--see F<B::C>) and may also execute
-slightly faster. This is by no means a good optimising compiler--yet.
-
-=head1 OPTIONS
-
-If there are any non-option arguments, they are taken to be
-names of objects to be saved (probably doesn't work properly yet).
-Without extra arguments, it saves the main program.
-
-=over 4
-
-=item B<-ofilename>
-
-Output to filename instead of STDOUT
-
-=item B<-v>
-
-Verbose compilation (currently gives a few compilation statistics).
-
-=item B<-->
-
-Force end of options
-
-=item B<-uPackname>
-
-Force apparently unused subs from package Packname to be compiled.
-This allows programs to use eval "foo()" even when sub foo is never
-seen to be used at compile time. The down side is that any subs which
-really are never used also have code generated. This option is
-necessary, for example, if you have a signal handler foo which you
-initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
-to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
-options. The compiler tries to figure out which packages may possibly
-have subs in which need compiling but the current version doesn't do
-it very well. In particular, it is confused by nested packages (i.e.
-of the form C<A::B>) where package C<A> does not contain any subs.
-
-=item B<-mModulename>
-
-Instead of generating source for a runnable executable, generate
-source for an XSUB module. The boot_Modulename function (which
-DynaLoader can look for) does the appropriate initialisation and runs
-the main part of the Perl source that is being compiled.
-
-
-=item B<-D>
-
-Debug options (concatenated or separate flags like C<perl -D>).
-
-=item B<-Dr>
-
-Writes debugging output to STDERR just as it's about to write to the
-program's runtime (otherwise writes debugging info as comments in
-its C output).
-
-=item B<-DO>
-
-Outputs each OP as it's compiled
-
-=item B<-Ds>
-
-Outputs the contents of the shadow stack at each OP
-
-=item B<-Dp>
-
-Outputs the contents of the shadow pad of lexicals as it's loaded for
-each sub or the main program.
-
-=item B<-Dq>
-
-Outputs the name of each fake PP function in the queue as it's about
-to process it.
-
-=item B<-Dl>
-
-Output the filename and line number of each original line of Perl
-code as it's processed (C<pp_nextstate>).
-
-=item B<-Dt>
-
-Outputs timing information of compilation stages.
-
-=item B<-f>
-
-Force optimisations on or off one at a time.
-
-=item B<-ffreetmps-each-bblock>
-
-Delays FREETMPS from the end of each statement to the end of the each
-basic block.
-
-=item B<-ffreetmps-each-loop>
-
-Delays FREETMPS from the end of each statement to the end of the group
-of basic blocks forming a loop. At most one of the freetmps-each-*
-options can be used.
-
-=item B<-fomit-taint>
-
-Omits generating code for handling perl's tainting mechanism.
-
-=item B<-On>
-
-Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
-Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
-sets B<-ffreetmps-each-loop>.
-
-=back
-
-=head1 EXAMPLES
-
- perl -MO=CC,-O2,-ofoo.c foo.pl
- perl cc_harness -o foo foo.c
-
-Note that C<cc_harness> lives in the C<B> subdirectory of your perl
-library directory. The utility called C<perlcc> may also be used to
-help make use of this compiler.
-
- perl -MO=CC,-mFoo,-oFoo.c Foo.pm
- perl cc_harness -shared -c -o Foo.so Foo.c
-
-=head1 BUGS
-
-Plenty. Current status: experimental.
-
-=head1 DIFFERENCES
-
-These aren't really bugs but they are constructs which are heavily
-tied to perl's compile-and-go implementation and with which this
-compiler backend cannot cope.
-
-=head2 Loops
-
-Standard perl calculates the target of "next", "last", and "redo"
-at run-time. The compiler calculates the targets at compile-time.
-For example, the program
-
- sub skip_on_odd { next NUMBER if $_[0] % 2 }
- NUMBER: for ($i = 0; $i < 5; $i++) {
- skip_on_odd($i);
- print $i;
- }
-
-produces the output
-
- 024
-
-with standard perl but gives a compile-time error with the compiler.
-
-=head2 Context of ".."
-
-The context (scalar or array) of the ".." operator determines whether
-it behaves as a range or a flip/flop. Standard perl delays until
-runtime the decision of which context it is in but the compiler needs
-to know the context at compile-time. For example,
-
- @a = (4,6,1,0,0,1);
- sub range { (shift @a)..(shift @a) }
- print range();
- while (@a) { print scalar(range()) }
-
-generates the output
-
- 456123E0
-
-with standard Perl but gives a compile-time error with compiled Perl.
-
-=head2 Arithmetic
-
-Compiled Perl programs use native C arithmetic much more frequently
-than standard perl. Operations on large numbers or on boundary
-cases may produce different behaviour.
-
-=head2 Deprecated features
-
-Features of standard perl such as C<$[> which have been deprecated
-in standard perl since Perl5 was released have not been implemented
-in the compiler.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Concise.pm b/Master/tlpkg/installer/perllib/B/Concise.pm
deleted file mode 100644
index c84578e44c4..00000000000
--- a/Master/tlpkg/installer/perllib/B/Concise.pm
+++ /dev/null
@@ -1,1628 +0,0 @@
-package B::Concise;
-# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
-# This program is free software; you can redistribute and/or modify it
-# under the same terms as Perl itself.
-
-# Note: we need to keep track of how many use declarations/BEGIN
-# blocks this module uses, so we can avoid printing them when user
-# asks for the BEGIN blocks in her program. Update the comments and
-# the count in concise_specials if you add or delete one. The
-# -MO=Concise counts as use #1.
-
-use strict; # use #2
-use warnings; # uses #3 and #4, since warnings uses Carp
-
-use Exporter (); # use #5
-
-our $VERSION = "0.66";
-our @ISA = qw(Exporter);
-our @EXPORT_OK = qw( set_style set_style_standard add_callback
- concise_subref concise_cv concise_main
- add_style walk_output compile reset_sequence );
-our %EXPORT_TAGS =
- ( io => [qw( walk_output compile reset_sequence )],
- style => [qw( add_style set_style_standard )],
- cb => [qw( add_callback )],
- mech => [qw( concise_subref concise_cv concise_main )], );
-
-# use #6
-use B qw(class ppname main_start main_root main_cv cstring svref_2object
- SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
- CVf_ANON);
-
-my %style =
- ("terse" =>
- ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) "
- . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
- "(*( )*)goto #class (#addr)\n",
- "#class pp_#name"],
- "concise" =>
- ["#hyphseq2 (*( (x( ;)x))*)<#classsym> "
- . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n"
- , " (*( )*) goto #seq\n",
- "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
- "linenoise" =>
- ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
- "gt_#seq ",
- "(?(#seq)?)#noise#arg(?([#targarg])?)"],
- "debug" =>
- ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
- . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" .
- ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n")
- . "\top_flags\t#flagval\n\top_private\t#privval\n"
- . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
- . "(?(\top_sv\t\t#svaddr\n)?)",
- " GOTO #addr\n",
- "#addr"],
- "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
- $ENV{B_CONCISE_TREE_FORMAT}],
- );
-
-# Renderings, ie how Concise prints, is controlled by these vars
-# primary:
-our $stylename; # selects current style from %style
-my $order = "basic"; # how optree is walked & printed: basic, exec, tree
-
-# rendering mechanics:
-# these 'formats' are the line-rendering templates
-# they're updated from %style when $stylename changes
-my ($format, $gotofmt, $treefmt);
-
-# lesser players:
-my $base = 36; # how <sequence#> is displayed
-my $big_endian = 1; # more <sequence#> display
-my $tree_style = 0; # tree-order details
-my $banner = 1; # print banner before optree is traversed
-my $do_main = 0; # force printing of main routine
-
-# another factor: can affect all styles!
-our @callbacks; # allow external management
-
-set_style_standard("concise");
-
-my $curcv;
-my $cop_seq_base;
-
-sub set_style {
- ($format, $gotofmt, $treefmt) = @_;
- #warn "set_style: deprecated, use set_style_standard instead\n"; # someday
- die "expecting 3 style-format args\n" unless @_ == 3;
-}
-
-sub add_style {
- my ($newstyle,@args) = @_;
- die "style '$newstyle' already exists, choose a new name\n"
- if exists $style{$newstyle};
- die "expecting 3 style-format args\n" unless @args == 3;
- $style{$newstyle} = [@args];
- $stylename = $newstyle; # update rendering state
-}
-
-sub set_style_standard {
- ($stylename) = @_; # update rendering state
- die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
- set_style(@{$style{$stylename}});
-}
-
-sub add_callback {
- push @callbacks, @_;
-}
-
-# output handle, used with all Concise-output printing
-our $walkHandle; # public for your convenience
-BEGIN { $walkHandle = \*STDOUT }
-
-sub walk_output { # updates $walkHandle
- my $handle = shift;
- return $walkHandle unless $handle; # allow use as accessor
-
- if (ref $handle eq 'SCALAR') {
- require Config;
- die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
- unless $Config::Config{useperlio};
- # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
- open my $tmp, '>', $handle; # but cant re-set existing STDOUT
- $walkHandle = $tmp; # so use my $tmp as intermediate var
- return $walkHandle;
- }
- my $iotype = ref $handle;
- die "expecting argument/object that can print\n"
- unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
- $walkHandle = $handle;
-}
-
-sub concise_subref {
- my($order, $coderef, $name) = @_;
- my $codeobj = svref_2object($coderef);
-
- return concise_stashref(@_)
- unless ref $codeobj eq 'B::CV';
- concise_cv_obj($order, $codeobj, $name);
-}
-
-sub concise_stashref {
- my($order, $h) = @_;
- foreach my $k (sort keys %$h) {
- local *s = $h->{$k};
- my $coderef = *s{CODE} or next;
- reset_sequence();
- print "FUNC: ", *s, "\n";
- my $codeobj = svref_2object($coderef);
- next unless ref $codeobj eq 'B::CV';
- eval { concise_cv_obj($order, $codeobj) }
- or warn "err $@ on $codeobj";
- }
-}
-
-# This should have been called concise_subref, but it was exported
-# under this name in versions before 0.56
-*concise_cv = \&concise_subref;
-
-sub concise_cv_obj {
- my ($order, $cv, $name) = @_;
- # name is either a string, or a CODE ref (copy of $cv arg??)
-
- $curcv = $cv;
- if ($cv->XSUB) {
- print $walkHandle "$name is XS code\n";
- return;
- }
- if (class($cv->START) eq "NULL") {
- no strict 'refs';
- if (ref $name eq 'CODE') {
- print $walkHandle "coderef $name has no START\n";
- }
- elsif (exists &$name) {
- print $walkHandle "$name exists in stash, but has no START\n";
- }
- else {
- print $walkHandle "$name not in symbol table\n";
- }
- return;
- }
- sequence($cv->START);
- if ($order eq "exec") {
- walk_exec($cv->START);
- }
- elsif ($order eq "basic") {
- # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
- my $root = $cv->ROOT;
- unless (ref $root eq 'B::NULL') {
- walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0);
- } else {
- print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n";
- }
- } else {
- print $walkHandle tree($cv->ROOT, 0);
- }
-}
-
-sub concise_main {
- my($order) = @_;
- sequence(main_start);
- $curcv = main_cv;
- if ($order eq "exec") {
- return if class(main_start) eq "NULL";
- walk_exec(main_start);
- } elsif ($order eq "tree") {
- return if class(main_root) eq "NULL";
- print $walkHandle tree(main_root, 0);
- } elsif ($order eq "basic") {
- return if class(main_root) eq "NULL";
- walk_topdown(main_root,
- sub { $_[0]->concise($_[1]) }, 0);
- }
-}
-
-sub concise_specials {
- my($name, $order, @cv_s) = @_;
- my $i = 1;
- if ($name eq "BEGIN") {
- splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ??
- } elsif ($name eq "CHECK") {
- pop @cv_s; # skip the CHECK block that calls us
- }
- for my $cv (@cv_s) {
- print $walkHandle "$name $i:\n";
- $i++;
- concise_cv_obj($order, $cv, $name);
- }
-}
-
-my $start_sym = "\e(0"; # "\cN" sometimes also works
-my $end_sym = "\e(B"; # "\cO" respectively
-
-my @tree_decorations =
- ([" ", "--", "+-", "|-", "| ", "`-", "-", 1],
- [" ", "-", "+", "+", "|", "`", "", 0],
- [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
- [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
- );
-
-
-sub compileOpts {
- # set rendering state from options and args
- my (@options,@args);
- if (@_) {
- @options = grep(/^-/, @_);
- @args = grep(!/^-/, @_);
- }
- for my $o (@options) {
- # mode/order
- if ($o eq "-basic") {
- $order = "basic";
- } elsif ($o eq "-exec") {
- $order = "exec";
- } elsif ($o eq "-tree") {
- $order = "tree";
- }
- # tree-specific
- elsif ($o eq "-compact") {
- $tree_style |= 1;
- } elsif ($o eq "-loose") {
- $tree_style &= ~1;
- } elsif ($o eq "-vt") {
- $tree_style |= 2;
- } elsif ($o eq "-ascii") {
- $tree_style &= ~2;
- }
- # sequence numbering
- elsif ($o =~ /^-base(\d+)$/) {
- $base = $1;
- } elsif ($o eq "-bigendian") {
- $big_endian = 1;
- } elsif ($o eq "-littleendian") {
- $big_endian = 0;
- }
- elsif ($o eq "-nobanner") {
- $banner = 0;
- } elsif ($o eq "-banner") {
- $banner = 1;
- }
- elsif ($o eq "-main") {
- $do_main = 1;
- } elsif ($o eq "-nomain") {
- $do_main = 0;
- }
- # line-style options
- elsif (exists $style{substr($o, 1)}) {
- $stylename = substr($o, 1);
- set_style_standard($stylename);
- } else {
- warn "Option $o unrecognized";
- }
- }
- return (@args);
-}
-
-sub compile {
- my (@args) = compileOpts(@_);
- return sub {
- my @newargs = compileOpts(@_); # accept new rendering options
- warn "disregarding non-options: @newargs\n" if @newargs;
-
- for my $objname (@args) {
- next unless $objname; # skip null args to avoid noisy responses
-
- if ($objname eq "BEGIN") {
- concise_specials("BEGIN", $order,
- B::begin_av->isa("B::AV") ?
- B::begin_av->ARRAY : ());
- } elsif ($objname eq "INIT") {
- concise_specials("INIT", $order,
- B::init_av->isa("B::AV") ?
- B::init_av->ARRAY : ());
- } elsif ($objname eq "CHECK") {
- concise_specials("CHECK", $order,
- B::check_av->isa("B::AV") ?
- B::check_av->ARRAY : ());
- } elsif ($objname eq "END") {
- concise_specials("END", $order,
- B::end_av->isa("B::AV") ?
- B::end_av->ARRAY : ());
- }
- else {
- # convert function names to subrefs
- my $objref;
- if (ref $objname) {
- print $walkHandle "B::Concise::compile($objname)\n"
- if $banner;
- $objref = $objname;
- } else {
- $objname = "main::" . $objname unless $objname =~ /::/;
- print $walkHandle "$objname:\n";
- no strict 'refs';
- unless (exists &$objname) {
- print $walkHandle "err: unknown function ($objname)\n";
- return;
- }
- $objref = \&$objname;
- }
- concise_subref($order, $objref, $objname);
- }
- }
- if (!@args or $do_main) {
- print $walkHandle "main program:\n" if $do_main;
- concise_main($order);
- }
- return @args; # something
- }
-}
-
-my %labels;
-my $lastnext; # remembers op-chain, used to insert gotos
-
-my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
- 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
- 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
-
-no warnings 'qw'; # "Possible attempt to put comments..."; use #7
-my @linenoise =
- qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl
- ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I
- -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i<
- > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
- ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
- uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@
- a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
- v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o
- ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
- ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
- -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
- co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
- g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
- e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
- Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
-
-my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
-
-sub op_flags { # common flags (see BASOP.op_flags in op.h)
- my($x) = @_;
- my(@v);
- push @v, "v" if ($x & 3) == 1;
- push @v, "s" if ($x & 3) == 2;
- push @v, "l" if ($x & 3) == 3;
- push @v, "K" if $x & 4;
- push @v, "P" if $x & 8;
- push @v, "R" if $x & 16;
- push @v, "M" if $x & 32;
- push @v, "S" if $x & 64;
- push @v, "*" if $x & 128;
- return join("", @v);
-}
-
-sub base_n {
- my $x = shift;
- return "-" . base_n(-$x) if $x < 0;
- my $str = "";
- do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
- $str = reverse $str if $big_endian;
- return $str;
-}
-
-my %sequence_num;
-my $seq_max = 1;
-
-sub reset_sequence {
- # reset the sequence
- %sequence_num = ();
- $seq_max = 1;
- $lastnext = 0;
-}
-
-sub seq {
- my($op) = @_;
- return "-" if not exists $sequence_num{$$op};
- return base_n($sequence_num{$$op});
-}
-
-sub walk_topdown {
- my($op, $sub, $level) = @_;
- $sub->($op, $level);
- if ($op->flags & OPf_KIDS) {
- for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
- walk_topdown($kid, $sub, $level + 1);
- }
- }
- elsif (class($op) eq "PMOP") {
- my $maybe_root = $op->pmreplroot;
- if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
- # It really is the root of the replacement, not something
- # else stored here for lack of space elsewhere
- walk_topdown($maybe_root, $sub, $level + 1);
- }
- }
-}
-
-sub walklines {
- my($ar, $level) = @_;
- for my $l (@$ar) {
- if (ref($l) eq "ARRAY") {
- walklines($l, $level + 1);
- } else {
- $l->concise($level);
- }
- }
-}
-
-sub walk_exec {
- my($top, $level) = @_;
- my %opsseen;
- my @lines;
- my @todo = ([$top, \@lines]);
- while (@todo and my($op, $targ) = @{shift @todo}) {
- for (; $$op; $op = $op->next) {
- last if $opsseen{$$op}++;
- push @$targ, $op;
- my $name = $op->name;
- if (class($op) eq "LOGOP") {
- my $ar = [];
- push @$targ, $ar;
- push @todo, [$op->other, $ar];
- } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
- my $ar = [];
- push @$targ, $ar;
- push @todo, [$op->pmreplstart, $ar];
- } elsif ($name =~ /^enter(loop|iter)$/) {
- if ($] > 5.009) {
- $labels{${$op->nextop}} = "NEXT";
- $labels{${$op->lastop}} = "LAST";
- $labels{${$op->redoop}} = "REDO";
- } else {
- $labels{$op->nextop->seq} = "NEXT";
- $labels{$op->lastop->seq} = "LAST";
- $labels{$op->redoop->seq} = "REDO";
- }
- }
- }
- }
- walklines(\@lines, 0);
-}
-
-# The structure of this routine is purposely modeled after op.c's peep()
-sub sequence {
- my($op) = @_;
- my $oldop = 0;
- return if class($op) eq "NULL" or exists $sequence_num{$$op};
- for (; $$op; $op = $op->next) {
- last if exists $sequence_num{$$op};
- my $name = $op->name;
- if ($name =~ /^(null|scalar|lineseq|scope)$/) {
- next if $oldop and $ {$op->next};
- } else {
- $sequence_num{$$op} = $seq_max++;
- if (class($op) eq "LOGOP") {
- my $other = $op->other;
- $other = $other->next while $other->name eq "null";
- sequence($other);
- } elsif (class($op) eq "LOOP") {
- my $redoop = $op->redoop;
- $redoop = $redoop->next while $redoop->name eq "null";
- sequence($redoop);
- my $nextop = $op->nextop;
- $nextop = $nextop->next while $nextop->name eq "null";
- sequence($nextop);
- my $lastop = $op->lastop;
- $lastop = $lastop->next while $lastop->name eq "null";
- sequence($lastop);
- } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
- my $replstart = $op->pmreplstart;
- $replstart = $replstart->next while $replstart->name eq "null";
- sequence($replstart);
- }
- }
- $oldop = $op;
- }
-}
-
-sub fmt_line { # generate text-line for op.
- my($hr, $op, $text, $level) = @_;
-
- $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
-
- return '' if $hr->{SKIP}; # suppress line if a callback said so
- return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere
-
- # spec: (?(text1#varText2)?)
- $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
- $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
-
- # spec: (x(exec_text;basic_text)x)
- $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
-
- # spec: (*(text)*)
- $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
-
- # spec: (*(text1;text2)*)
- $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
-
- # convert #Var to tag=>val form: Var\t#var
- $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;
-
- # spec: #varN
- $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
-
- $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's
- $text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes
- chomp $text;
- return "$text\n" if $text ne "";
- return $text; # suppress empty lines
-}
-
-our %priv; # used to display each opcode's BASEOP.op_private values
-
-$priv{$_}{128} = "LVINTRO"
- for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
- "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
- "padav", "padhv", "enteriter");
-$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
-$priv{"aassign"}{64} = "COMMON";
-$priv{"aassign"}{32} = "PHASH" if $] < 5.009;
-$priv{"sassign"}{64} = "BKWARD";
-$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
-@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
- "COMPL", "GROWS");
-$priv{"repeat"}{64} = "DOLIST";
-$priv{"leaveloop"}{64} = "CONT";
-@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
- for (qw(rv2gv rv2sv padsv aelem helem));
-@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD");
-@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
-$priv{"gv"}{32} = "EARLYCV";
-$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
-$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
- "enteriter");
-$priv{$_}{16} = "TARGMY"
- for (map(($_,"s$_"),"chop", "chomp"),
- map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
- "add", "subtract", "negate"), "pow", "concat", "stringify",
- "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or",
- "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt",
- "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf",
- "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock",
- "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename",
- "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
- "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
- "setpriority", "time", "sleep");
-$priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
-@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN");
-$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
-$priv{"list"}{64} = "GUESSED";
-$priv{"delete"}{64} = "SLICE";
-$priv{"exists"}{64} = "SUB";
-$priv{$_}{64} = "LOCALE"
- for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge",
- "scmp", "lc", "uc", "lcfirst", "ucfirst");
-@{$priv{"sort"}}{1,2,4,8,16} = ("NUM", "INT", "REV", "INPLACE","DESC");
-$priv{"threadsv"}{64} = "SVREFd";
-@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
- for ("open", "backtick");
-$priv{"exit"}{128} = "VMS";
-$priv{$_}{2} = "FTACCESS"
- for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
-if ($] >= 5.009) {
- # Stacked filetests are post 5.8.x
- $priv{$_}{4} = "FTSTACKED"
- for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
- "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
- "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
- "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
- "ftbinary");
- # Lexical $_ is post 5.8.x
- $priv{$_}{2} = "GREPLEX"
- for ("mapwhile", "mapstart", "grepwhile", "grepstart");
-}
-
-sub private_flags {
- my($name, $x) = @_;
- my @s;
- for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) {
- if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) {
- $x -= $flag;
- push @s, $priv{$name}{$flag};
- }
- }
- push @s, $x if $x;
- return join(",", @s);
-}
-
-sub concise_sv {
- my($sv, $hr, $preferpv) = @_;
- $hr->{svclass} = class($sv);
- $hr->{svclass} = "UV"
- if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
- Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
- $hr->{svaddr} = sprintf("%#x", $$sv);
- if ($hr->{svclass} eq "GV") {
- my $gv = $sv;
- my $stash = $gv->STASH->NAME;
- if ($stash eq "main") {
- $stash = "";
- } else {
- $stash = $stash . "::";
- }
- $hr->{svval} = "*$stash" . $gv->SAFENAME;
- return "*$stash" . $gv->SAFENAME;
- } else {
- while (class($sv) eq "RV") {
- $hr->{svval} .= "\\";
- $sv = $sv->RV;
- }
- if (class($sv) eq "SPECIAL") {
- $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
- } elsif ($preferpv && $sv->FLAGS & SVf_POK) {
- $hr->{svval} .= cstring($sv->PV);
- } elsif ($sv->FLAGS & SVf_NOK) {
- $hr->{svval} .= $sv->NV;
- } elsif ($sv->FLAGS & SVf_IOK) {
- $hr->{svval} .= $sv->int_value;
- } elsif ($sv->FLAGS & SVf_POK) {
- $hr->{svval} .= cstring($sv->PV);
- } elsif (class($sv) eq "HV") {
- $hr->{svval} .= 'HASH';
- }
-
- $hr->{svval} = 'undef' unless defined $hr->{svval};
- my $out = $hr->{svclass};
- return $out .= " $hr->{svval}" ;
- }
-}
-
-sub concise_op {
- my ($op, $level, $format) = @_;
- my %h;
- $h{exname} = $h{name} = $op->name;
- $h{NAME} = uc $h{name};
- $h{class} = class($op);
- $h{extarg} = $h{targ} = $op->targ;
- $h{extarg} = "" unless $h{extarg};
- if ($h{name} eq "null" and $h{targ}) {
- # targ holds the old type
- $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
- $h{extarg} = "";
- } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
- # targ potentially holds a reference count
- if ($op->private & 64) {
- my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
- $h{targarglife} = $h{targarg} = "$h{targ} $refs";
- }
- } elsif ($h{targ}) {
- my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
- if (defined $padname and class($padname) ne "SPECIAL") {
- $h{targarg} = $padname->PVX;
- if ($padname->FLAGS & SVf_FAKE) {
- if ($] < 5.009) {
- $h{targarglife} = "$h{targarg}:FAKE";
- } else {
- # These changes relate to the jumbo closure fix.
- # See changes 19939 and 20005
- my $fake = '';
- $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON
- $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI
- $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON;
- $h{targarglife} = "$h{targarg}:FAKE:$fake";
- }
- }
- else {
- my $intro = $padname->NVX - $cop_seq_base;
- my $finish = int($padname->IVX) - $cop_seq_base;
- $finish = "end" if $finish == 999999999 - $cop_seq_base;
- $h{targarglife} = "$h{targarg}:$intro,$finish";
- }
- } else {
- $h{targarglife} = $h{targarg} = "t" . $h{targ};
- }
- }
- $h{arg} = "";
- $h{svclass} = $h{svaddr} = $h{svval} = "";
- if ($h{class} eq "PMOP") {
- my $precomp = $op->precomp;
- if (defined $precomp) {
- $precomp = cstring($precomp); # Escape literal control sequences
- $precomp = "/$precomp/";
- } else {
- $precomp = "";
- }
- my $pmreplroot = $op->pmreplroot;
- my $pmreplstart;
- if (ref($pmreplroot) eq "B::GV") {
- # with C<@stash_array = split(/pat/, str);>,
- # *stash_array is stored in /pat/'s pmreplroot.
- $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
- } elsif (!ref($pmreplroot) and $pmreplroot) {
- # same as the last case, except the value is actually a
- # pad offset for where the GV is kept (this happens under
- # ithreads)
- my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
- $h{arg} = "($precomp => \@" . $gv->NAME . ")";
- } elsif ($ {$op->pmreplstart}) {
- undef $lastnext;
- $pmreplstart = "replstart->" . seq($op->pmreplstart);
- $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
- } else {
- $h{arg} = "($precomp)";
- }
- } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
- $h{arg} = '("' . $op->pv . '")';
- $h{svval} = '"' . $op->pv . '"';
- } elsif ($h{class} eq "COP") {
- my $label = $op->label;
- $h{coplabel} = $label;
- $label = $label ? "$label: " : "";
- my $loc = $op->file;
- $loc =~ s[.*/][];
- $loc .= ":" . $op->line;
- my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
- my $arybase = $op->arybase;
- $arybase = $arybase ? ' $[=' . $arybase : "";
- $h{arg} = "($label$stash $cseq $loc$arybase)";
- } elsif ($h{class} eq "LOOP") {
- $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
- . " redo->" . seq($op->redoop) . ")";
- } elsif ($h{class} eq "LOGOP") {
- undef $lastnext;
- $h{arg} = "(other->" . seq($op->other) . ")";
- }
- elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
- unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
- my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
- my $preferpv = $h{name} eq "method_named";
- if ($h{class} eq "PADOP" or !${$op->sv}) {
- my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
- $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";
- $h{targarglife} = $h{targarg} = "";
- } else {
- $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")";
- }
- }
- }
- $h{seq} = $h{hyphseq} = seq($op);
- $h{seq} = "" if $h{seq} eq "-";
- if ($] > 5.009) {
- $h{opt} = $op->opt;
- $h{static} = $op->static;
- $h{label} = $labels{$$op};
- } else {
- $h{seqnum} = $op->seq;
- $h{label} = $labels{$op->seq};
- }
- $h{next} = $op->next;
- $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
- $h{nextaddr} = sprintf("%#x", $ {$op->next});
- $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
- $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
- $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
-
- $h{classsym} = $opclass{$h{class}};
- $h{flagval} = $op->flags;
- $h{flags} = op_flags($op->flags);
- $h{privval} = $op->private;
- $h{private} = private_flags($h{name}, $op->private);
- $h{addr} = sprintf("%#x", $$op);
- $h{typenum} = $op->type;
- $h{noise} = $linenoise[$op->type];
-
- return fmt_line(\%h, $op, $format, $level);
-}
-
-sub B::OP::concise {
- my($op, $level) = @_;
- if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
- # insert a 'goto' line
- my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
- "addr" => sprintf("%#x", $$lastnext),
- "goto" => seq($lastnext), # simplify goto '-' removal
- };
- print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
- }
- $lastnext = $op->next;
- print $walkHandle concise_op($op, $level, $format);
-}
-
-# B::OP::terse (see Terse.pm) now just calls this
-sub b_terse {
- my($op, $level) = @_;
-
- # This isn't necessarily right, but there's no easy way to get
- # from an OP to the right CV. This is a limitation of the
- # ->terse() interface style, and there isn't much to do about
- # it. In particular, we can die in concise_op if the main pad
- # isn't long enough, or has the wrong kind of entries, compared to
- # the pad a sub was compiled with. The fix for that would be to
- # make a backwards compatible "terse" format that never even
- # looked at the pad, just like the old B::Terse. I don't think
- # that's worth the effort, though.
- $curcv = main_cv unless $curcv;
-
- if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
- # insert a 'goto'
- my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
- "addr" => sprintf("%#x", $$lastnext)};
- print # $walkHandle
- fmt_line($h, $op, $style{"terse"}[1], $level+1);
- }
- $lastnext = $op->next;
- print # $walkHandle
- concise_op($op, $level, $style{"terse"}[0]);
-}
-
-sub tree {
- my $op = shift;
- my $level = shift;
- my $style = $tree_decorations[$tree_style];
- my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
- my $name = concise_op($op, $level, $treefmt);
- if (not $op->flags & OPf_KIDS) {
- return $name . "\n";
- }
- my @lines;
- for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
- push @lines, tree($kid, $level+1);
- }
- my $i;
- for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
- $lines[$i] = $space . $lines[$i];
- }
- if ($i > 0) {
- $lines[$i] = $last . $lines[$i];
- while ($i-- > 1) {
- if (substr($lines[$i], 0, 1) eq " ") {
- $lines[$i] = $nokid . $lines[$i];
- } else {
- $lines[$i] = $kid . $lines[$i];
- }
- }
- $lines[$i] = $kids . $lines[$i];
- } else {
- $lines[0] = $single . $lines[0];
- }
- return("$name$lead" . shift @lines,
- map(" " x (length($name)+$size) . $_, @lines));
-}
-
-# *** Warning: fragile kludge ahead ***
-# Because the B::* modules run in the same interpreter as the code
-# they're compiling, their presence tends to distort the view we have of
-# the code we're looking at. In particular, perl gives sequence numbers
-# to COPs. If the program we're looking at were run on its own, this
-# would start at 1. Because all of B::Concise and all the modules it
-# uses are compiled first, though, by the time we get to the user's
-# program the sequence number is already pretty high, which could be
-# distracting if you're trying to tell OPs apart. Therefore we'd like to
-# subtract an offset from all the sequence numbers we display, to
-# restore the simpler view of the world. The trick is to know what that
-# offset will be, when we're still compiling B::Concise! If we
-# hardcoded a value, it would have to change every time B::Concise or
-# other modules we use do. To help a little, what we do here is compile
-# a little code at the end of the module, and compute the base sequence
-# number for the user's program as being a small offset later, so all we
-# have to worry about are changes in the offset.
-
-# [For 5.8.x and earlier perl is generating sequence numbers for all ops,
-# and using them to reference labels]
-
-
-# When you say "perl -MO=Concise -e '$a'", the output should look like:
-
-# 4 <@> leave[t1] vKP/REFC ->(end)
-# 1 <0> enter ->2
- #^ smallest OP sequence number should be 1
-# 2 <;> nextstate(main 1 -e:1) v ->3
- # ^ smallest COP sequence number should be 1
-# - <1> ex-rv2sv vK/1 ->4
-# 3 <$> gvsv(*a) s ->4
-
-# If the second of the marked numbers there isn't 1, it means you need
-# to update the corresponding magic number in the next line.
-# Remember, this needs to stay the last things in the module.
-
-# Why is this different for MacOS? Does it matter?
-my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
-$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Concise - Walk Perl syntax tree, printing concise info about ops
-
-=head1 SYNOPSIS
-
- perl -MO=Concise[,OPTIONS] foo.pl
-
- use B::Concise qw(set_style add_callback);
-
-=head1 DESCRIPTION
-
-This compiler backend prints the internal OPs of a Perl program's syntax
-tree in one of several space-efficient text formats suitable for debugging
-the inner workings of perl or other compiler backends. It can print OPs in
-the order they appear in the OP tree, in the order they will execute, or
-in a text approximation to their tree structure, and the format of the
-information displayed is customizable. Its function is similar to that of
-perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
-sophisticated and flexible.
-
-=head1 EXAMPLE
-
-Here's an example of 2 outputs (aka 'renderings'), using the
--exec and -basic (i.e. default) formatting conventions on the same code
-snippet.
-
- % perl -MO=Concise,-exec -e '$a = $b + 42'
- 1 <0> enter
- 2 <;> nextstate(main 1 -e:1) v
- 3 <#> gvsv[*b] s
- 4 <$> const[IV 42] s
- * 5 <2> add[t3] sK/2
- 6 <#> gvsv[*a] s
- 7 <2> sassign vKS/2
- 8 <@> leave[1 ref] vKP/REFC
-
-Each line corresponds to an opcode. The opcode marked with '*' is used
-in a few examples below.
-
-The 1st column is the op's sequence number, starting at 1, and is
-displayed in base 36 by default. This rendering is in -exec (i.e.
-execution) order.
-
-The symbol between angle brackets indicates the op's type, for
-example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is
-used in threaded perls. (see L</"OP class abbreviations">).
-
-The opname, as in B<'add[t1]'>, which may be followed by op-specific
-information in parentheses or brackets (ex B<'[t1]'>).
-
-The op-flags (ex B<'sK/2'>) follow, and are described in (L</"OP flags
-abbreviations">).
-
- % perl -MO=Concise -e '$a = $b + 42'
- 8 <@> leave[1 ref] vKP/REFC ->(end)
- 1 <0> enter ->2
- 2 <;> nextstate(main 1 -e:1) v ->3
- 7 <2> sassign vKS/2 ->8
- * 5 <2> add[t1] sK/2 ->6
- - <1> ex-rv2sv sK/1 ->4
- 3 <$> gvsv(*b) s ->4
- 4 <$> const(IV 42) s ->5
- - <1> ex-rv2sv sKRM*/1 ->7
- 6 <$> gvsv(*a) s ->7
-
-The default rendering is top-down, so they're not in execution order.
-This form reflects the way the stack is used to parse and evaluate
-expressions; the add operates on the two terms below it in the tree.
-
-Nullops appear as C<ex-opname>, where I<opname> is an op that has been
-optimized away by perl. They're displayed with a sequence-number of
-'-', because they are not executed (they don't appear in previous
-example), they're printed here because they reflect the parse.
-
-The arrow points to the sequence number of the next op; they're not
-displayed in -exec mode, for obvious reasons.
-
-Note that because this rendering was done on a non-threaded perl, the
-PADOPs in the previous examples are now SVOPs, and some (but not all)
-of the square brackets have been replaced by round ones. This is a
-subtle feature to provide some visual distinction between renderings
-on threaded and un-threaded perls.
-
-
-=head1 OPTIONS
-
-Arguments that don't start with a hyphen are taken to be the names of
-subroutines to print the OPs of; if no such functions are specified,
-the main body of the program (outside any subroutines, and not
-including use'd or require'd files) is rendered. Passing C<BEGIN>,
-C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
-special blocks to be printed.
-
-Options affect how things are rendered (ie printed). They're presented
-here by their visual effect, 1st being strongest. They're grouped
-according to how they interrelate; within each group the options are
-mutually exclusive (unless otherwise stated).
-
-=head2 Options for Opcode Ordering
-
-These options control the 'vertical display' of opcodes. The display
-'order' is also called 'mode' elsewhere in this document.
-
-=over 4
-
-=item B<-basic>
-
-Print OPs in the order they appear in the OP tree (a preorder
-traversal, starting at the root). The indentation of each OP shows its
-level in the tree, and the '->' at the end of the line indicates the
-next opcode in execution order. This mode is the default, so the flag
-is included simply for completeness.
-
-=item B<-exec>
-
-Print OPs in the order they would normally execute (for the majority
-of constructs this is a postorder traversal of the tree, ending at the
-root). In most cases the OP that usually follows a given OP will
-appear directly below it; alternate paths are shown by indentation. In
-cases like loops when control jumps out of a linear path, a 'goto'
-line is generated.
-
-=item B<-tree>
-
-Print OPs in a text approximation of a tree, with the root of the tree
-at the left and 'left-to-right' order of children transformed into
-'top-to-bottom'. Because this mode grows both to the right and down,
-it isn't suitable for large programs (unless you have a very wide
-terminal).
-
-=back
-
-=head2 Options for Line-Style
-
-These options select the line-style (or just style) used to render
-each opcode, and dictates what info is actually printed into each line.
-
-=over 4
-
-=item B<-concise>
-
-Use the author's favorite set of formatting conventions. This is the
-default, of course.
-
-=item B<-terse>
-
-Use formatting conventions that emulate the output of B<B::Terse>. The
-basic mode is almost indistinguishable from the real B<B::Terse>, and the
-exec mode looks very similar, but is in a more logical order and lacks
-curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
-is only vaguely reminiscent of B<B::Terse>.
-
-=item B<-linenoise>
-
-Use formatting conventions in which the name of each OP, rather than being
-written out in full, is represented by a one- or two-character abbreviation.
-This is mainly a joke.
-
-=item B<-debug>
-
-Use formatting conventions reminiscent of B<B::Debug>; these aren't
-very concise at all.
-
-=item B<-env>
-
-Use formatting conventions read from the environment variables
-C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
-
-=back
-
-=head2 Options for tree-specific formatting
-
-=over 4
-
-=item B<-compact>
-
-Use a tree format in which the minimum amount of space is used for the
-lines connecting nodes (one character in most cases). This squeezes out
-a few precious columns of screen real estate.
-
-=item B<-loose>
-
-Use a tree format that uses longer edges to separate OP nodes. This format
-tends to look better than the compact one, especially in ASCII, and is
-the default.
-
-=item B<-vt>
-
-Use tree connecting characters drawn from the VT100 line-drawing set.
-This looks better if your terminal supports it.
-
-=item B<-ascii>
-
-Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
-look as clean as the VT100 characters, but they'll work with almost any
-terminal (or the horizontal scrolling mode of less(1)) and are suitable
-for text documentation or email. This is the default.
-
-=back
-
-These are pairwise exclusive, i.e. compact or loose, vt or ascii.
-
-=head2 Options controlling sequence numbering
-
-=over 4
-
-=item B<-base>I<n>
-
-Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
-digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
-for 37 will be 'A', and so on until 62. Values greater than 62 are not
-currently supported. The default is 36.
-
-=item B<-bigendian>
-
-Print sequence numbers with the most significant digit first. This is the
-usual convention for Arabic numerals, and the default.
-
-=item B<-littleendian>
-
-Print seqence numbers with the least significant digit first. This is
-obviously mutually exclusive with bigendian.
-
-=back
-
-=head2 Other options
-
-These are pairwise exclusive.
-
-=over 4
-
-=item B<-main>
-
-Include the main program in the output, even if subroutines were also
-specified. This rendering is normally suppressed when a subroutine
-name or reference is given.
-
-=item B<-nomain>
-
-This restores the default behavior after you've changed it with '-main'
-(it's not normally needed). If no subroutine name/ref is given, main is
-rendered, regardless of this flag.
-
-=item B<-nobanner>
-
-Renderings usually include a banner line identifying the function name
-or stringified subref. This suppresses the printing of the banner.
-
-TBC: Remove the stringified coderef; while it provides a 'cookie' for
-each function rendered, the cookies used should be 1,2,3.. not a
-random hex-address. It also complicates string comparison of two
-different trees.
-
-=item B<-banner>
-
-restores default banner behavior.
-
-=item B<-banneris> => subref
-
-TBC: a hookpoint (and an option to set it) for a user-supplied
-function to produce a banner appropriate for users needs. It's not
-ideal, because the rendering-state variables, which are a natural
-candidate for use in concise.t, are unavailable to the user.
-
-=back
-
-=head2 Option Stickiness
-
-If you invoke Concise more than once in a program, you should know that
-the options are 'sticky'. This means that the options you provide in
-the first call will be remembered for the 2nd call, unless you
-re-specify or change them.
-
-=head1 ABBREVIATIONS
-
-The concise style uses symbols to convey maximum info with minimal
-clutter (like hex addresses). With just a little practice, you can
-start to see the flowers, not just the branches, in the trees.
-
-=head2 OP class abbreviations
-
-These symbols appear before the op-name, and indicate the
-B:: namespace that represents the ops in your Perl code.
-
- 0 OP (aka BASEOP) An OP with no children
- 1 UNOP An OP with one child
- 2 BINOP An OP with two children
- | LOGOP A control branch OP
- @ LISTOP An OP that could have lots of children
- / PMOP An OP with a regular expression
- $ SVOP An OP with an SV
- " PVOP An OP with a string
- { LOOP An OP that holds pointers for a loop
- ; COP An OP that marks the start of a statement
- # PADOP An OP with a GV on the pad
-
-=head2 OP flags abbreviations
-
-OP flags are either public or private. The public flags alter the
-behavior of each opcode in consistent ways, and are represented by 0
-or more single characters.
-
- v OPf_WANT_VOID Want nothing (void context)
- s OPf_WANT_SCALAR Want single value (scalar context)
- l OPf_WANT_LIST Want list of any length (list context)
- Want is unknown
- K OPf_KIDS There is a firstborn child.
- P OPf_PARENS This operator was parenthesized.
- (Or block needs explicit scope entry.)
- R OPf_REF Certified reference.
- (Return container, not containee).
- M OPf_MOD Will modify (lvalue).
- S OPf_STACKED Some arg is arriving on the stack.
- * OPf_SPECIAL Do something weird for this op (see op.h)
-
-Private flags, if any are set for an opcode, are displayed after a '/'
-
- 8 <@> leave[1 ref] vKP/REFC ->(end)
- 7 <2> sassign vKS/2 ->8
-
-They're opcode specific, and occur less often than the public ones, so
-they're represented by short mnemonics instead of single-chars; see
-F<op.h> for gory details, or try this quick 2-liner:
-
- $> perl -MB::Concise -de 1
- DB<1> |x \%B::Concise::priv
-
-=head1 FORMATTING SPECIFICATIONS
-
-For each line-style ('concise', 'terse', 'linenoise', etc.) there are
-3 format-specs which control how OPs are rendered.
-
-The first is the 'default' format, which is used in both basic and exec
-modes to print all opcodes. The 2nd, goto-format, is used in exec
-mode when branches are encountered. They're not real opcodes, and are
-inserted to look like a closing curly brace. The tree-format is tree
-specific.
-
-When a line is rendered, the correct format-spec is copied and scanned
-for the following items; data is substituted in, and other
-manipulations like basic indenting are done, for each opcode rendered.
-
-There are 3 kinds of items that may be populated; special patterns,
-#vars, and literal text, which is copied verbatim. (Yes, it's a set
-of s///g steps.)
-
-=head2 Special Patterns
-
-These items are the primitives used to perform indenting, and to
-select text from amongst alternatives.
-
-=over 4
-
-=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
-
-Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
-
-=item B<(*(>I<text>B<)*)>
-
-Generates one copy of I<text> for each indentation level.
-
-=item B<(*(>I<text1>B<;>I<text2>B<)*)>
-
-Generates one fewer copies of I<text1> than the indentation level, followed
-by one copy of I<text2> if the indentation level is more than 0.
-
-=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
-
-If the value of I<var> is true (not empty or zero), generates the
-value of I<var> surrounded by I<text1> and I<Text2>, otherwise
-nothing.
-
-=item B<~>
-
-Any number of tildes and surrounding whitespace will be collapsed to
-a single space.
-
-=back
-
-=head2 # Variables
-
-These #vars represent opcode properties that you may want as part of
-your rendering. The '#' is intended as a private sigil; a #var's
-value is interpolated into the style-line, much like "read $this".
-
-These vars take 3 forms:
-
-=over 4
-
-=item B<#>I<var>
-
-A property named 'var' is assumed to exist for the opcodes, and is
-interpolated into the rendering.
-
-=item B<#>I<var>I<N>
-
-Generates the value of I<var>, left justified to fill I<N> spaces.
-Note that this means while you can have properties 'foo' and 'foo2',
-you cannot render 'foo2', but you could with 'foo2a'. You would be
-wise not to rely on this behavior going forward ;-)
-
-=item B<#>I<Var>
-
-This ucfirst form of #var generates a tag-value form of itself for
-display; it converts '#Var' into a 'Var => #var' style, which is then
-handled as described above. (Imp-note: #Vars cannot be used for
-conditional-fills, because the => #var transform is done after the check
-for #Var's value).
-
-=back
-
-The following variables are 'defined' by B::Concise; when they are
-used in a style, their respective values are plugged into the
-rendering of each opcode.
-
-Only some of these are used by the standard styles, the others are
-provided for you to delve into optree mechanics, should you wish to
-add a new style (see L</add_style> below) that uses them. You can
-also add new ones using L</add_callback>.
-
-=over 4
-
-=item B<#addr>
-
-The address of the OP, in hexadecimal.
-
-=item B<#arg>
-
-The OP-specific information of the OP (such as the SV for an SVOP, the
-non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
-
-=item B<#class>
-
-The B-determined class of the OP, in all caps.
-
-=item B<#classsym>
-
-A single symbol abbreviating the class of the OP.
-
-=item B<#coplabel>
-
-The label of the statement or block the OP is the start of, if any.
-
-=item B<#exname>
-
-The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
-
-=item B<#extarg>
-
-The target of the OP, or nothing for a nulled OP.
-
-=item B<#firstaddr>
-
-The address of the OP's first child, in hexadecimal.
-
-=item B<#flags>
-
-The OP's flags, abbreviated as a series of symbols.
-
-=item B<#flagval>
-
-The numeric value of the OP's flags.
-
-=item B<#hyphseq>
-
-The sequence number of the OP, or a hyphen if it doesn't have one.
-
-=item B<#label>
-
-'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
-mode, or empty otherwise.
-
-=item B<#lastaddr>
-
-The address of the OP's last child, in hexadecimal.
-
-=item B<#name>
-
-The OP's name.
-
-=item B<#NAME>
-
-The OP's name, in all caps.
-
-=item B<#next>
-
-The sequence number of the OP's next OP.
-
-=item B<#nextaddr>
-
-The address of the OP's next OP, in hexadecimal.
-
-=item B<#noise>
-
-A one- or two-character abbreviation for the OP's name.
-
-=item B<#private>
-
-The OP's private flags, rendered with abbreviated names if possible.
-
-=item B<#privval>
-
-The numeric value of the OP's private flags.
-
-=item B<#seq>
-
-The sequence number of the OP. Note that this is a sequence number
-generated by B::Concise.
-
-=item B<#seqnum>
-
-5.8.x and earlier only. 5.9 and later do not provide this.
-
-The real sequence number of the OP, as a regular number and not adjusted
-to be relative to the start of the real program. (This will generally be
-a fairly large number because all of B<B::Concise> is compiled before
-your program is).
-
-=item B<#opt>
-
-Whether or not the op has been optimised by the peephole optimiser.
-
-Only available in 5.9 and later.
-
-=item B<#static>
-
-Whether or not the op is statically defined. This flag is used by the
-B::C compiler backend and indicates that the op should not be freed.
-
-Only available in 5.9 and later.
-
-=item B<#sibaddr>
-
-The address of the OP's next youngest sibling, in hexadecimal.
-
-=item B<#svaddr>
-
-The address of the OP's SV, if it has an SV, in hexadecimal.
-
-=item B<#svclass>
-
-The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
-
-=item B<#svval>
-
-The value of the OP's SV, if it has one, in a short human-readable format.
-
-=item B<#targ>
-
-The numeric value of the OP's targ.
-
-=item B<#targarg>
-
-The name of the variable the OP's targ refers to, if any, otherwise the
-letter t followed by the OP's targ in decimal.
-
-=item B<#targarglife>
-
-Same as B<#targarg>, but followed by the COP sequence numbers that delimit
-the variable's lifetime (or 'end' for a variable in an open scope) for a
-variable.
-
-=item B<#typenum>
-
-The numeric value of the OP's type, in decimal.
-
-=back
-
-=head1 Using B::Concise outside of the O framework
-
-The common (and original) usage of B::Concise was for command-line
-renderings of simple code, as given in EXAMPLE. But you can also use
-B<B::Concise> from your code, and call compile() directly, and
-repeatedly. By doing so, you can avoid the compile-time only
-operation of O.pm, and even use the debugger to step through
-B::Concise::compile() itself.
-
-Once you're doing this, you may alter Concise output by adding new
-rendering styles, and by optionally adding callback routines which
-populate new variables, if such were referenced from those (just
-added) styles.
-
-=head2 Example: Altering Concise Renderings
-
- use B::Concise qw(set_style add_callback);
- add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
- add_callback
- ( sub {
- my ($h, $op, $format, $level, $stylename) = @_;
- $h->{variable} = some_func($op);
- });
- $walker = B::Concise::compile(@options,@subnames,@subrefs);
- $walker->();
-
-=head2 set_style()
-
-B<set_style> accepts 3 arguments, and updates the three format-specs
-comprising a line-style (basic-exec, goto, tree). It has one minor
-drawback though; it doesn't register the style under a new name. This
-can become an issue if you render more than once and switch styles.
-Thus you may prefer to use add_style() and/or set_style_standard()
-instead.
-
-=head2 set_style_standard($name)
-
-This restores one of the standard line-styles: C<terse>, C<concise>,
-C<linenoise>, C<debug>, C<env>, into effect. It also accepts style
-names previously defined with add_style().
-
-=head2 add_style()
-
-This subroutine accepts a new style name and three style arguments as
-above, and creates, registers, and selects the newly named style. It is
-an error to re-add a style; call set_style_standard() to switch between
-several styles.
-
-=head2 add_callback()
-
-If your newly minted styles refer to any new #variables, you'll need
-to define a callback subroutine that will populate (or modify) those
-variables. They are then available for use in the style you've
-chosen.
-
-The callbacks are called for each opcode visited by Concise, in the
-same order as they are added. Each subroutine is passed five
-parameters.
-
- 1. A hashref, containing the variable names and values which are
- populated into the report-line for the op
- 2. the op, as a B<B::OP> object
- 3. a reference to the format string
- 4. the formatting (indent) level
- 5. the selected stylename
-
-To define your own variables, simply add them to the hash, or change
-existing values if you need to. The level and format are passed in as
-references to scalars, but it is unlikely that they will need to be
-changed or even used.
-
-=head2 Running B::Concise::compile()
-
-B<compile> accepts options as described above in L</OPTIONS>, and
-arguments, which are either coderefs, or subroutine names.
-
-It constructs and returns a $treewalker coderef, which when invoked,
-traverses, or walks, and renders the optrees of the given arguments to
-STDOUT. You can reuse this, and can change the rendering style used
-each time; thereafter the coderef renders in the new style.
-
-B<walk_output> lets you change the print destination from STDOUT to
-another open filehandle, or into a string passed as a ref (unless
-you've built perl with -Uuseperlio).
-
- my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
- walk_output(\my $buf);
- $walker->(); # 1 renders -terse
- set_style_standard('concise'); # 2
- $walker->(); # 2 renders -concise
- $walker->(@new); # 3 renders whatever
- print "3 different renderings: terse, concise, and @new: $buf\n";
-
-When $walker is called, it traverses the subroutines supplied when it
-was created, and renders them using the current style. You can change
-the style afterwards in several different ways:
-
- 1. call C<compile>, altering style or mode/order
- 2. call C<set_style_standard>
- 3. call $walker, passing @new options
-
-Passing new options to the $walker is the easiest way to change
-amongst any pre-defined styles (the ones you add are automatically
-recognized as options), and is the only way to alter rendering order
-without calling compile again. Note however that rendering state is
-still shared amongst multiple $walker objects, so they must still be
-used in a coordinated manner.
-
-=head2 B::Concise::reset_sequence()
-
-This function (not exported) lets you reset the sequence numbers (note
-that they're numbered arbitrarily, their goal being to be human
-readable). Its purpose is mostly to support testing, i.e. to compare
-the concise output from two identical anonymous subroutines (but
-different instances). Without the reset, B::Concise, seeing that
-they're separate optrees, generates different sequence numbers in
-the output.
-
-=head2 Errors
-
-Errors in rendering (non-existent function-name, non-existent coderef)
-are written to the STDOUT, or wherever you've set it via
-walk_output().
-
-Errors using the various *style* calls, and bad args to walk_output(),
-result in die(). Use an eval if you wish to catch these errors and
-continue processing.
-
-=head1 AUTHOR
-
-Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Debug.pm b/Master/tlpkg/installer/perllib/B/Debug.pm
deleted file mode 100644
index cb369682d66..00000000000
--- a/Master/tlpkg/installer/perllib/B/Debug.pm
+++ /dev/null
@@ -1,305 +0,0 @@
-package B::Debug;
-
-our $VERSION = '1.02_01';
-
-use strict;
-use B qw(peekop class walkoptree walkoptree_exec
- main_start main_root cstring sv_undef);
-use B::Asmdata qw(@specialsv_name);
-
-my %done_gv;
-
-sub B::OP::debug {
- my ($op) = @_;
- printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type;
-%s (0x%lx)
- op_next 0x%x
- op_sibling 0x%x
- op_ppaddr %s
- op_targ %d
- op_type %d
-EOT
- if ($] > 5.009) {
- printf <<'EOT', $op->opt, $op->static;
- op_opt %d
- op_static %d
-EOT
- } else {
- printf <<'EOT', $op->seq;
- op_seq %d
-EOT
- }
- printf <<'EOT', $op->flags, $op->private;
- op_flags %d
- op_private %d
-EOT
-}
-
-sub B::UNOP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- printf "\top_first\t0x%x\n", ${$op->first};
-}
-
-sub B::BINOP::debug {
- my ($op) = @_;
- $op->B::UNOP::debug();
- printf "\top_last\t\t0x%x\n", ${$op->last};
-}
-
-sub B::LOOP::debug {
- my ($op) = @_;
- $op->B::BINOP::debug();
- printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop};
- op_redoop 0x%x
- op_nextop 0x%x
- op_lastop 0x%x
-EOT
-}
-
-sub B::LOGOP::debug {
- my ($op) = @_;
- $op->B::UNOP::debug();
- printf "\top_other\t0x%x\n", ${$op->other};
-}
-
-sub B::LISTOP::debug {
- my ($op) = @_;
- $op->B::BINOP::debug();
- printf "\top_children\t%d\n", $op->children;
-}
-
-sub B::PMOP::debug {
- my ($op) = @_;
- $op->B::LISTOP::debug();
- printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
- printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
- printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
- printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
- printf "\top_pmflags\t0x%x\n", $op->pmflags;
- $op->pmreplroot->debug;
-}
-
-sub B::COP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
- printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
- cop_label %s
- cop_stashpv %s
- cop_file %s
- cop_seq %d
- cop_arybase %d
- cop_line %d
- cop_warnings 0x%x
- cop_io %s
-EOT
-}
-
-sub B::SVOP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- printf "\top_sv\t\t0x%x\n", ${$op->sv};
- $op->sv->debug;
-}
-
-sub B::PVOP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- printf "\top_pv\t\t%s\n", cstring($op->pv);
-}
-
-sub B::PADOP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- printf "\top_padix\t\t%ld\n", $op->padix;
-}
-
-sub B::NULL::debug {
- my ($sv) = @_;
- if ($$sv == ${sv_undef()}) {
- print "&sv_undef\n";
- } else {
- printf "NULL (0x%x)\n", $$sv;
- }
-}
-
-sub B::SV::debug {
- my ($sv) = @_;
- if (!$$sv) {
- print class($sv), " = NULL\n";
- return;
- }
- printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
-%s (0x%x)
- REFCNT %d
- FLAGS 0x%x
-EOT
-}
-
-sub B::RV::debug {
- my ($rv) = @_;
- B::SV::debug($rv);
- printf <<'EOT', ${$rv->RV};
- RV 0x%x
-EOT
- $rv->RV->debug;
-}
-
-sub B::PV::debug {
- my ($sv) = @_;
- $sv->B::SV::debug();
- my $pv = $sv->PV();
- printf <<'EOT', cstring($pv), length($pv);
- xpv_pv %s
- xpv_cur %d
-EOT
-}
-
-sub B::IV::debug {
- my ($sv) = @_;
- $sv->B::SV::debug();
- printf "\txiv_iv\t\t%d\n", $sv->IV;
-}
-
-sub B::NV::debug {
- my ($sv) = @_;
- $sv->B::IV::debug();
- printf "\txnv_nv\t\t%s\n", $sv->NV;
-}
-
-sub B::PVIV::debug {
- my ($sv) = @_;
- $sv->B::PV::debug();
- printf "\txiv_iv\t\t%d\n", $sv->IV;
-}
-
-sub B::PVNV::debug {
- my ($sv) = @_;
- $sv->B::PVIV::debug();
- printf "\txnv_nv\t\t%s\n", $sv->NV;
-}
-
-sub B::PVLV::debug {
- my ($sv) = @_;
- $sv->B::PVNV::debug();
- printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
- printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
- printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
-}
-
-sub B::BM::debug {
- my ($sv) = @_;
- $sv->B::PVNV::debug();
- printf "\txbm_useful\t%d\n", $sv->USEFUL;
- printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
- printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
-}
-
-sub B::CV::debug {
- my ($sv) = @_;
- $sv->B::PVNV::debug();
- my ($stash) = $sv->STASH;
- my ($start) = $sv->START;
- my ($root) = $sv->ROOT;
- my ($padlist) = $sv->PADLIST;
- my ($file) = $sv->FILE;
- my ($gv) = $sv->GV;
- printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
- STASH 0x%x
- START 0x%x
- ROOT 0x%x
- GV 0x%x
- FILE %s
- DEPTH %d
- PADLIST 0x%x
- OUTSIDE 0x%x
- OUTSIDE_SEQ %d
-EOT
- $start->debug if $start;
- $root->debug if $root;
- $gv->debug if $gv;
- $padlist->debug if $padlist;
-}
-
-sub B::AV::debug {
- my ($av) = @_;
- $av->B::SV::debug;
- my(@array) = $av->ARRAY;
- print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
- printf <<'EOT', scalar(@array), $av->MAX, $av->OFF;
- FILL %d
- MAX %d
- OFF %d
-EOT
- printf <<'EOT', $av->AvFLAGS if $] < 5.009;
- AvFLAGS %d
-EOT
-}
-
-sub B::GV::debug {
- my ($gv) = @_;
- if ($done_gv{$$gv}++) {
- printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
- return;
- }
- my ($sv) = $gv->SV;
- my ($av) = $gv->AV;
- my ($cv) = $gv->CV;
- $gv->B::SV::debug;
- printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
- NAME %s
- STASH %s (0x%x)
- SV 0x%x
- GvREFCNT %d
- FORM 0x%x
- AV 0x%x
- HV 0x%x
- EGV 0x%x
- CV 0x%x
- CVGEN %d
- LINE %d
- FILE %s
- GvFLAGS 0x%x
-EOT
- $sv->debug if $sv;
- $av->debug if $av;
- $cv->debug if $cv;
-}
-
-sub B::SPECIAL::debug {
- my $sv = shift;
- print $specialsv_name[$$sv], "\n";
-}
-
-sub compile {
- my $order = shift;
- B::clearsym();
- if ($order && $order eq "exec") {
- return sub { walkoptree_exec(main_start, "debug") }
- } else {
- return sub { walkoptree(main_root, "debug") }
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Debug - Walk Perl syntax tree, printing debug info about ops
-
-=head1 SYNOPSIS
-
- perl -MO=Debug[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-See F<ext/B/README>.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Deparse.pm b/Master/tlpkg/installer/perllib/B/Deparse.pm
deleted file mode 100644
index 3db6fbe6e1f..00000000000
--- a/Master/tlpkg/installer/perllib/B/Deparse.pm
+++ /dev/null
@@ -1,4642 +0,0 @@
-# B::Deparse.pm
-# Copyright (c) 1998-2000, 2002, 2003 Stephen McCamant. All rights reserved.
-# This module is free software; you can redistribute and/or modify
-# it under the same terms as Perl itself.
-
-# This is based on the module of the same name by Malcolm Beattie,
-# but essentially none of his code remains.
-
-package B::Deparse;
-use Carp;
-use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
- OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
- OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
- OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
- OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
- OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
- OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
- SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
- CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION
- PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
- PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.71;
-use strict;
-use vars qw/$AUTOLOAD/;
-use warnings ();
-
-# Changes between 0.50 and 0.51:
-# - fixed nulled leave with live enter in sort { }
-# - fixed reference constants (\"str")
-# - handle empty programs gracefully
-# - handle infinte loops (for (;;) {}, while (1) {})
-# - differentiate between `for my $x ...' and `my $x; for $x ...'
-# - various minor cleanups
-# - moved globals into an object
-# - added `-u', like B::C
-# - package declarations using cop_stash
-# - subs, formats and code sorted by cop_seq
-# Changes between 0.51 and 0.52:
-# - added pp_threadsv (special variables under USE_5005THREADS)
-# - added documentation
-# Changes between 0.52 and 0.53:
-# - many changes adding precedence contexts and associativity
-# - added `-p' and `-s' output style options
-# - various other minor fixes
-# Changes between 0.53 and 0.54:
-# - added support for new `for (1..100)' optimization,
-# thanks to Gisle Aas
-# Changes between 0.54 and 0.55:
-# - added support for new qr// construct
-# - added support for new pp_regcreset OP
-# Changes between 0.55 and 0.56:
-# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
-# - fixed $# on non-lexicals broken in last big rewrite
-# - added temporary fix for change in opcode of OP_STRINGIFY
-# - fixed problem in 0.54's for() patch in `for (@ary)'
-# - fixed precedence in conditional of ?:
-# - tweaked list paren elimination in `my($x) = @_'
-# - made continue-block detection trickier wrt. null ops
-# - fixed various prototype problems in pp_entersub
-# - added support for sub prototypes that never get GVs
-# - added unquoting for special filehandle first arg in truncate
-# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
-# - added semicolons at the ends of blocks
-# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
-# Changes between 0.56 and 0.561:
-# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
-# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
-# Changes between 0.561 and 0.57:
-# - stylistic changes to symbolic constant stuff
-# - handled scope in s///e replacement code
-# - added unquote option for expanding "" into concats, etc.
-# - split method and proto parts of pp_entersub into separate functions
-# - various minor cleanups
-# Changes after 0.57:
-# - added parens in \&foo (patch by Albert Dvornik)
-# Changes between 0.57 and 0.58:
-# - fixed `0' statements that weren't being printed
-# - added methods for use from other programs
-# (based on patches from James Duncan and Hugo van der Sanden)
-# - added -si and -sT to control indenting (also based on a patch from Hugo)
-# - added -sv to print something else instead of '???'
-# - preliminary version of utf8 tr/// handling
-# Changes after 0.58:
-# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
-# - added support for Hugo's new OP_SETSTATE (like nextstate)
-# Changes between 0.58 and 0.59
-# - added support for Chip's OP_METHOD_NAMED
-# - added support for Ilya's OPpTARGET_MY optimization
-# - elided arrows before `()' subscripts when possible
-# Changes between 0.59 and 0.60
-# - support for method attribues was added
-# - some warnings fixed
-# - separate recognition of constant subs
-# - rewrote continue block handling, now recoginizing for loops
-# - added more control of expanding control structures
-# Changes between 0.60 and 0.61 (mostly by Robin Houston)
-# - many bug-fixes
-# - support for pragmas and 'use'
-# - support for the little-used $[ variable
-# - support for __DATA__ sections
-# - UTF8 support
-# - BEGIN, CHECK, INIT and END blocks
-# - scoping of subroutine declarations fixed
-# - compile-time output from the input program can be suppressed, so that the
-# output is just the deparsed code. (a change to O.pm in fact)
-# - our() declarations
-# - *all* the known bugs are now listed in the BUGS section
-# - comprehensive test mechanism (TEST -deparse)
-# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
-# - bug-fixes
-# - new switch -P
-# - support for command-line switches (-l, -0, etc.)
-# Changes between 0.63 and 0.64
-# - support for //, CHECK blocks, and assertions
-# - improved handling of foreach loops and lexicals
-# - option to use Data::Dumper for constants
-# - more bug fixes
-# - discovered lots more bugs not yet fixed
-
-# Todo:
-# (See also BUGS section at the end of this file)
-#
-# - finish tr/// changes
-# - add option for even more parens (generalize \&foo change)
-# - left/right context
-# - copy comments (look at real text with $^P?)
-# - avoid semis in one-statement blocks
-# - associativity of &&=, ||=, ?:
-# - ',' => '=>' (auto-unquote?)
-# - break long lines ("\r" as discretionary break?)
-# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
-# - more style options: brace style, hex vs. octal, quotes, ...
-# - print big ints as hex/octal instead of decimal (heuristic?)
-# - handle `my $x if 0'?
-# - version using op_next instead of op_first/sibling?
-# - avoid string copies (pass arrays, one big join?)
-# - here-docs?
-
-# Current test.deparse failures
-# comp/assertions 38 - disabled assertions should be like "my($x) if 0"
-# 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}'
-# comp/hints 6 - location of BEGIN blocks wrt. block openings
-# run/switchI 1 - missing -I switches entirely
-# perl -Ifoo -e 'print @INC'
-# op/caller 2 - warning mask propagates backwards before warnings::register
-# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
-# op/getpid 2 - can't assign to shared my() declaration (threads only)
-# 'my $x : shared = 5'
-# op/override 7 - parens on overriden require change v-string interpretation
-# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
-# c.f. 'BEGIN { *f = sub {0} }; f 2'
-# op/pat 774 - losing Unicode-ness of Latin1-only strings
-# 'use charnames ":short"; $x="\N{latin:a with acute}"'
-# op/recurse 12 - missing parens on recursive call makes it look like method
-# 'sub f { f($x) }'
-# op/subst 90 - inconsistent handling of utf8 under "use utf8"
-# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
-# op/tiehandle compile - "use strict" deparsed in the wrong place
-# uni/tr_ several
-# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
-# ext/Data/Dumper/t/dumper compile
-# ext/DB_file/several
-# ext/Encode/several
-# ext/Ernno/Errno warnings
-# ext/IO/lib/IO/t/io_sel 23
-# ext/PerlIO/t/encoding compile
-# ext/POSIX/t/posix 6
-# ext/Socket/Socket 8
-# ext/Storable/t/croak compile
-# lib/Attribute/Handlers/t/multi compile
-# lib/bignum/ several
-# lib/charnames 35
-# lib/constant 32
-# lib/English 40
-# lib/ExtUtils/t/bytes 4
-# lib/File/DosGlob compile
-# lib/Filter/Simple/t/data 1
-# lib/Math/BigInt/t/constant 1
-# lib/Net/t/config Deparse-warning
-# lib/overload compile
-# lib/Switch/ several
-# lib/Symbol 4
-# lib/Test/Simple several
-# lib/Term/Complete
-# lib/Tie/File/t/29_downcopy 5
-# lib/vars 22
-
-# Object fields (were globals):
-#
-# avoid_local:
-# (local($a), local($b)) and local($a, $b) have the same internal
-# representation but the short form looks better. We notice we can
-# use a large-scale local when checking the list, but need to prevent
-# individual locals too. This hash holds the addresses of OPs that
-# have already had their local-ness accounted for. The same thing
-# is done with my().
-#
-# curcv:
-# CV for current sub (or main program) being deparsed
-#
-# curcvlex:
-# Cached hash of lexical variables for curcv: keys are names,
-# each value is an array of pairs, indicating the cop_seq of scopes
-# in which a var of that name is valid.
-#
-# curcop:
-# COP for statement being deparsed
-#
-# curstash:
-# name of the current package for deparsed code
-#
-# subs_todo:
-# array of [cop_seq, CV, is_format?] for subs and formats we still
-# want to deparse
-#
-# protos_todo:
-# as above, but [name, prototype] for subs that never got a GV
-#
-# subs_done, forms_done:
-# keys are addresses of GVs for subs and formats we've already
-# deparsed (or at least put into subs_todo)
-#
-# subs_declared
-# keys are names of subs for which we've printed declarations.
-# That means we can omit parentheses from the arguments.
-#
-# subs_deparsed
-# Keeps track of fully qualified names of all deparsed subs.
-#
-# parens: -p
-# linenums: -l
-# unquote: -q
-# cuddle: ` ' or `\n', depending on -sC
-# indent_size: -si
-# use_tabs: -sT
-# ex_const: -sv
-
-# A little explanation of how precedence contexts and associativity
-# work:
-#
-# deparse() calls each per-op subroutine with an argument $cx (short
-# for context, but not the same as the cx* in the perl core), which is
-# a number describing the op's parents in terms of precedence, whether
-# they're inside an expression or at statement level, etc. (see
-# chart below). When ops with children call deparse on them, they pass
-# along their precedence. Fractional values are used to implement
-# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
-# parentheses hacks. The major disadvantage of this scheme is that
-# it doesn't know about right sides and left sides, so say if you
-# assign a listop to a variable, it can't tell it's allowed to leave
-# the parens off the listop.
-
-# Precedences:
-# 26 [TODO] inside interpolation context ("")
-# 25 left terms and list operators (leftward)
-# 24 left ->
-# 23 nonassoc ++ --
-# 22 right **
-# 21 right ! ~ \ and unary + and -
-# 20 left =~ !~
-# 19 left * / % x
-# 18 left + - .
-# 17 left << >>
-# 16 nonassoc named unary operators
-# 15 nonassoc < > <= >= lt gt le ge
-# 14 nonassoc == != <=> eq ne cmp
-# 13 left &
-# 12 left | ^
-# 11 left &&
-# 10 left ||
-# 9 nonassoc .. ...
-# 8 right ?:
-# 7 right = += -= *= etc.
-# 6 left , =>
-# 5 nonassoc list operators (rightward)
-# 4 right not
-# 3 left and
-# 2 left or xor
-# 1 statement modifiers
-# 0.5 statements, but still print scopes as do { ... }
-# 0 statement level
-
-# Nonprinting characters with special meaning:
-# \cS - steal parens (see maybe_parens_unop)
-# \n - newline and indent
-# \t - increase indent
-# \b - decrease indent (`outdent')
-# \f - flush left (no indent)
-# \cK - kill following semicolon, if any
-
-sub null {
- my $op = shift;
- return class($op) eq "NULL";
-}
-
-sub todo {
- my $self = shift;
- my($cv, $is_form) = @_;
- return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
- my $seq;
- if ($cv->OUTSIDE_SEQ) {
- $seq = $cv->OUTSIDE_SEQ;
- } elsif (!null($cv->START) and is_state($cv->START)) {
- $seq = $cv->START->cop_seq;
- } else {
- $seq = 0;
- }
- push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
- unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
- $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
- }
-}
-
-sub next_todo {
- my $self = shift;
- my $ent = shift @{$self->{'subs_todo'}};
- my $cv = $ent->[1];
- my $gv = $cv->GV;
- my $name = $self->gv_name($gv);
- if ($ent->[2]) {
- return "format $name =\n"
- . $self->deparse_format($ent->[1]). "\n";
- } else {
- $self->{'subs_declared'}{$name} = 1;
- if ($name eq "BEGIN") {
- my $use_dec = $self->begin_is_use($cv);
- if (defined ($use_dec) and $self->{'expand'} < 5) {
- return () if 0 == length($use_dec);
- return $use_dec;
- }
- }
- my $l = '';
- if ($self->{'linenums'}) {
- my $line = $gv->LINE;
- my $file = $gv->FILE;
- $l = "\n\f#line $line \"$file\"\n";
- }
- my $p = '';
- if (class($cv->STASH) ne "SPECIAL") {
- my $stash = $cv->STASH->NAME;
- if ($stash ne $self->{'curstash'}) {
- $p = "package $stash;\n";
- $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
- $self->{'curstash'} = $stash;
- }
- $name =~ s/^\Q$stash\E:://;
- }
- return "${p}${l}sub $name " . $self->deparse_sub($cv);
- }
-}
-
-# Return a "use" declaration for this BEGIN block, if appropriate
-sub begin_is_use {
- my ($self, $cv) = @_;
- my $root = $cv->ROOT;
- local @$self{qw'curcv curcvlex'} = ($cv);
-#require B::Debug;
-#B::walkoptree($cv->ROOT, "debug");
- my $lineseq = $root->first;
- return if $lineseq->name ne "lineseq";
-
- my $req_op = $lineseq->first->sibling;
- return if $req_op->name ne "require";
-
- my $module;
- if ($req_op->first->private & OPpCONST_BARE) {
- # Actually it should always be a bareword
- $module = $self->const_sv($req_op->first)->PV;
- $module =~ s[/][::]g;
- $module =~ s/.pm$//;
- }
- else {
- $module = $self->const($self->const_sv($req_op->first), 6);
- }
-
- my $version;
- my $version_op = $req_op->sibling;
- return if class($version_op) eq "NULL";
- if ($version_op->name eq "lineseq") {
- # We have a version parameter; skip nextstate & pushmark
- my $constop = $version_op->first->next->next;
-
- return unless $self->const_sv($constop)->PV eq $module;
- $constop = $constop->sibling;
- $version = $self->const_sv($constop);
- if (class($version) eq "IV") {
- $version = $version->int_value;
- } elsif (class($version) eq "NV") {
- $version = $version->NV;
- } elsif (class($version) ne "PVMG") {
- # Includes PVIV and PVNV
- $version = $version->PV;
- } else {
- # version specified as a v-string
- $version = 'v'.join '.', map ord, split //, $version->PV;
- }
- $constop = $constop->sibling;
- return if $constop->name ne "method_named";
- return if $self->const_sv($constop)->PV ne "VERSION";
- }
-
- $lineseq = $version_op->sibling;
- return if $lineseq->name ne "lineseq";
- my $entersub = $lineseq->first->sibling;
- if ($entersub->name eq "stub") {
- return "use $module $version ();\n" if defined $version;
- return "use $module ();\n";
- }
- return if $entersub->name ne "entersub";
-
- # See if there are import arguments
- my $args = '';
-
- my $svop = $entersub->first->sibling; # Skip over pushmark
- return unless $self->const_sv($svop)->PV eq $module;
-
- # Pull out the arguments
- for ($svop=$svop->sibling; $svop->name ne "method_named";
- $svop = $svop->sibling) {
- $args .= ", " if length($args);
- $args .= $self->deparse($svop, 6);
- }
-
- my $use = 'use';
- my $method_named = $svop;
- return if $method_named->name ne "method_named";
- my $method_name = $self->const_sv($method_named)->PV;
-
- if ($method_name eq "unimport") {
- $use = 'no';
- }
-
- # Certain pragmas are dealt with using hint bits,
- # so we ignore them here
- if ($module eq 'strict' || $module eq 'integer'
- || $module eq 'bytes' || $module eq 'warnings') {
- return "";
- }
-
- if (defined $version && length $args) {
- return "$use $module $version ($args);\n";
- } elsif (defined $version) {
- return "$use $module $version;\n";
- } elsif (length $args) {
- return "$use $module ($args);\n";
- } else {
- return "$use $module;\n";
- }
-}
-
-sub stash_subs {
- my ($self, $pack) = @_;
- my (@ret, $stash);
- if (!defined $pack) {
- $pack = '';
- $stash = \%::;
- }
- else {
- $pack =~ s/(::)?$/::/;
- no strict 'refs';
- $stash = \%$pack;
- }
- my %stash = svref_2object($stash)->ARRAY;
- while (my ($key, $val) = each %stash) {
- next if $key eq 'main::'; # avoid infinite recursion
- my $class = class($val);
- if ($class eq "PV") {
- # Just a prototype. As an ugly but fairly effective way
- # to find out if it belongs here is to see if the AUTOLOAD
- # (if any) for the stash was defined in one of our files.
- my $A = $stash{"AUTOLOAD"};
- if (defined ($A) && class($A) eq "GV" && defined($A->CV)
- && class($A->CV) eq "CV") {
- my $AF = $A->FILE;
- next unless $AF eq $0 || exists $self->{'files'}{$AF};
- }
- push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
- } elsif ($class eq "IV") {
- # Just a name. As above.
- my $A = $stash{"AUTOLOAD"};
- if (defined ($A) && class($A) eq "GV" && defined($A->CV)
- && class($A->CV) eq "CV") {
- my $AF = $A->FILE;
- next unless $AF eq $0 || exists $self->{'files'}{$AF};
- }
- push @{$self->{'protos_todo'}}, [$pack . $key, undef];
- } elsif ($class eq "GV") {
- if (class(my $cv = $val->CV) ne "SPECIAL") {
- next if $self->{'subs_done'}{$$val}++;
- next if $$val != ${$cv->GV}; # Ignore imposters
- $self->todo($cv, 0);
- }
- if (class(my $cv = $val->FORM) ne "SPECIAL") {
- next if $self->{'forms_done'}{$$val}++;
- next if $$val != ${$cv->GV}; # Ignore imposters
- $self->todo($cv, 1);
- }
- if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
- $self->stash_subs($pack . $key);
- }
- }
- }
-}
-
-sub print_protos {
- my $self = shift;
- my $ar;
- my @ret;
- foreach $ar (@{$self->{'protos_todo'}}) {
- my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
- push @ret, "sub " . $ar->[0] . "$proto;\n";
- }
- delete $self->{'protos_todo'};
- return @ret;
-}
-
-sub style_opts {
- my $self = shift;
- my $opts = shift;
- my $opt;
- while (length($opt = substr($opts, 0, 1))) {
- if ($opt eq "C") {
- $self->{'cuddle'} = " ";
- $opts = substr($opts, 1);
- } elsif ($opt eq "i") {
- $opts =~ s/^i(\d+)//;
- $self->{'indent_size'} = $1;
- } elsif ($opt eq "T") {
- $self->{'use_tabs'} = 1;
- $opts = substr($opts, 1);
- } elsif ($opt eq "v") {
- $opts =~ s/^v([^.]*)(.|$)//;
- $self->{'ex_const'} = $1;
- }
- }
-}
-
-sub new {
- my $class = shift;
- my $self = bless {}, $class;
- $self->{'cuddle'} = "\n";
- $self->{'curcop'} = undef;
- $self->{'curstash'} = "main";
- $self->{'ex_const'} = "'???'";
- $self->{'expand'} = 0;
- $self->{'files'} = {};
- $self->{'indent_size'} = 4;
- $self->{'linenums'} = 0;
- $self->{'parens'} = 0;
- $self->{'subs_todo'} = [];
- $self->{'unquote'} = 0;
- $self->{'use_dumper'} = 0;
- $self->{'use_tabs'} = 0;
-
- $self->{'ambient_arybase'} = 0;
- $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
- $self->{'ambient_hints'} = 0;
- $self->init();
-
- while (my $arg = shift @_) {
- if ($arg eq "-d") {
- $self->{'use_dumper'} = 1;
- require Data::Dumper;
- } elsif ($arg =~ /^-f(.*)/) {
- $self->{'files'}{$1} = 1;
- } elsif ($arg eq "-l") {
- $self->{'linenums'} = 1;
- } elsif ($arg eq "-p") {
- $self->{'parens'} = 1;
- } elsif ($arg eq "-P") {
- $self->{'noproto'} = 1;
- } elsif ($arg eq "-q") {
- $self->{'unquote'} = 1;
- } elsif (substr($arg, 0, 2) eq "-s") {
- $self->style_opts(substr $arg, 2);
- } elsif ($arg =~ /^-x(\d)$/) {
- $self->{'expand'} = $1;
- }
- }
- return $self;
-}
-
-{
- # Mask out the bits that L<warnings::register> uses
- my $WARN_MASK;
- BEGIN {
- $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
- }
- sub WARN_MASK () {
- return $WARN_MASK;
- }
-}
-
-# Initialise the contextual information, either from
-# defaults provided with the ambient_pragmas method,
-# or from perl's own defaults otherwise.
-sub init {
- my $self = shift;
-
- $self->{'arybase'} = $self->{'ambient_arybase'};
- $self->{'warnings'} = defined ($self->{'ambient_warnings'})
- ? $self->{'ambient_warnings'} & WARN_MASK
- : undef;
- $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
-
- # also a convenient place to clear out subs_declared
- delete $self->{'subs_declared'};
-}
-
-sub compile {
- my(@args) = @_;
- return sub {
- my $self = B::Deparse->new(@args);
- # First deparse command-line args
- if (defined $^I) { # deparse -i
- print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
- }
- if ($^W) { # deparse -w
- print qq(BEGIN { \$^W = $^W; }\n);
- }
- if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
- my $fs = perlstring($/) || 'undef';
- my $bs = perlstring($O::savebackslash) || 'undef';
- print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
- }
- my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
- my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
- my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
- my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
- for my $block (@BEGINs, @CHECKs, @INITs, @ENDs) {
- $self->todo($block, 0);
- }
- $self->stash_subs();
- local($SIG{"__DIE__"}) =
- sub {
- if ($self->{'curcop'}) {
- my $cop = $self->{'curcop'};
- my($line, $file) = ($cop->line, $cop->file);
- print STDERR "While deparsing $file near line $line,\n";
- }
- };
- $self->{'curcv'} = main_cv;
- $self->{'curcvlex'} = undef;
- print $self->print_protos;
- @{$self->{'subs_todo'}} =
- sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
- print $self->indent($self->deparse_root(main_root)), "\n"
- unless null main_root;
- my @text;
- while (scalar(@{$self->{'subs_todo'}})) {
- push @text, $self->next_todo;
- }
- print $self->indent(join("", @text)), "\n" if @text;
-
- # Print __DATA__ section, if necessary
- no strict 'refs';
- my $laststash = defined $self->{'curcop'}
- ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
- if (defined *{$laststash."::DATA"}{IO}) {
- print "package $laststash;\n"
- unless $laststash eq $self->{'curstash'};
- print "__DATA__\n";
- print readline(*{$laststash."::DATA"});
- }
- }
-}
-
-sub coderef2text {
- my $self = shift;
- my $sub = shift;
- croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
-
- $self->init();
- return $self->indent($self->deparse_sub(svref_2object($sub)));
-}
-
-sub ambient_pragmas {
- my $self = shift;
- my ($arybase, $hint_bits, $warning_bits) = (0, 0);
-
- while (@_ > 1) {
- my $name = shift();
- my $val = shift();
-
- if ($name eq 'strict') {
- require strict;
-
- if ($val eq 'none') {
- $hint_bits &= ~strict::bits(qw/refs subs vars/);
- next();
- }
-
- my @names;
- if ($val eq "all") {
- @names = qw/refs subs vars/;
- }
- elsif (ref $val) {
- @names = @$val;
- }
- else {
- @names = split' ', $val;
- }
- $hint_bits |= strict::bits(@names);
- }
-
- elsif ($name eq '$[') {
- $arybase = $val;
- }
-
- elsif ($name eq 'integer'
- || $name eq 'bytes'
- || $name eq 'utf8') {
- require "$name.pm";
- if ($val) {
- $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
- }
- else {
- $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
- }
- }
-
- elsif ($name eq 're') {
- require re;
- if ($val eq 'none') {
- $hint_bits &= ~re::bits(qw/taint eval/);
- next();
- }
-
- my @names;
- if ($val eq 'all') {
- @names = qw/taint eval/;
- }
- elsif (ref $val) {
- @names = @$val;
- }
- else {
- @names = split' ',$val;
- }
- $hint_bits |= re::bits(@names);
- }
-
- elsif ($name eq 'warnings') {
- if ($val eq 'none') {
- $warning_bits = $warnings::NONE;
- next();
- }
-
- my @names;
- if (ref $val) {
- @names = @$val;
- }
- else {
- @names = split/\s+/, $val;
- }
-
- $warning_bits = $warnings::NONE if !defined ($warning_bits);
- $warning_bits |= warnings::bits(@names);
- }
-
- elsif ($name eq 'warning_bits') {
- $warning_bits = $val;
- }
-
- elsif ($name eq 'hint_bits') {
- $hint_bits = $val;
- }
-
- else {
- croak "Unknown pragma type: $name";
- }
- }
- if (@_) {
- croak "The ambient_pragmas method expects an even number of args";
- }
-
- $self->{'ambient_arybase'} = $arybase;
- $self->{'ambient_warnings'} = $warning_bits;
- $self->{'ambient_hints'} = $hint_bits;
-}
-
-# This method is the inner loop, so try to keep it simple
-sub deparse {
- my $self = shift;
- my($op, $cx) = @_;
-
- Carp::confess("Null op in deparse") if !defined($op)
- || class($op) eq "NULL";
- my $meth = "pp_" . $op->name;
- return $self->$meth($op, $cx);
-}
-
-sub indent {
- my $self = shift;
- my $txt = shift;
- my @lines = split(/\n/, $txt);
- my $leader = "";
- my $level = 0;
- my $line;
- for $line (@lines) {
- my $cmd = substr($line, 0, 1);
- if ($cmd eq "\t" or $cmd eq "\b") {
- $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
- if ($self->{'use_tabs'}) {
- $leader = "\t" x ($level / 8) . " " x ($level % 8);
- } else {
- $leader = " " x $level;
- }
- $line = substr($line, 1);
- }
- if (substr($line, 0, 1) eq "\f") {
- $line = substr($line, 1); # no indent
- } else {
- $line = $leader . $line;
- }
- $line =~ s/\cK;?//g;
- }
- return join("\n", @lines);
-}
-
-sub deparse_sub {
- my $self = shift;
- my $cv = shift;
- my $proto = "";
-Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
-Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
- local $self->{'curcop'} = $self->{'curcop'};
- if ($cv->FLAGS & SVf_POK) {
- $proto = "(". $cv->PV . ") ";
- }
- if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) {
- $proto .= ": ";
- $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
- $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
- $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
- $proto .= "assertion " if $cv->CvFLAGS & CVf_ASSERTION;
- }
-
- local($self->{'curcv'}) = $cv;
- local($self->{'curcvlex'});
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'};
- my $body;
- if (not null $cv->ROOT) {
- my $lineseq = $cv->ROOT->first;
- if ($lineseq->name eq "lineseq") {
- my @ops;
- for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
- push @ops, $o;
- }
- $body = $self->lineseq(undef, @ops).";";
- my $scope_en = $self->find_scope_en($lineseq);
- if (defined $scope_en) {
- my $subs = join"", $self->seq_subs($scope_en);
- $body .= ";\n$subs" if length($subs);
- }
- }
- else {
- $body = $self->deparse($cv->ROOT->first, 0);
- }
- }
- else {
- my $sv = $cv->const_sv;
- if ($$sv) {
- # uh-oh. inlinable sub... format it differently
- return $proto . "{ " . $self->const($sv, 0) . " }\n";
- } else { # XSUB? (or just a declaration)
- return "$proto;\n";
- }
- }
- return $proto ."{\n\t$body\n\b}" ."\n";
-}
-
-sub deparse_format {
- my $self = shift;
- my $form = shift;
- my @text;
- local($self->{'curcv'}) = $form;
- local($self->{'curcvlex'});
- local($self->{'in_format'}) = 1;
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'};
- my $op = $form->ROOT;
- my $kid;
- return "\f." if $op->first->name eq 'stub'
- || $op->first->name eq 'nextstate';
- $op = $op->first->first; # skip leavewrite, lineseq
- while (not null $op) {
- $op = $op->sibling; # skip nextstate
- my @exprs;
- $kid = $op->first->sibling; # skip pushmark
- push @text, "\f".$self->const_sv($kid)->PV;
- $kid = $kid->sibling;
- for (; not null $kid; $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 0);
- }
- push @text, "\f".join(", ", @exprs)."\n" if @exprs;
- $op = $op->sibling;
- }
- return join("", @text) . "\f.";
-}
-
-sub is_scope {
- my $op = shift;
- return $op->name eq "leave" || $op->name eq "scope"
- || $op->name eq "lineseq"
- || ($op->name eq "null" && class($op) eq "UNOP"
- && (is_scope($op->first) || $op->first->name eq "enter"));
-}
-
-sub is_state {
- my $name = $_[0]->name;
- return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
-}
-
-sub is_miniwhile { # check for one-line loop (`foo() while $y--')
- my $op = shift;
- return (!null($op) and null($op->sibling)
- and $op->name eq "null" and class($op) eq "UNOP"
- and (($op->first->name =~ /^(and|or)$/
- and $op->first->first->sibling->name eq "lineseq")
- or ($op->first->name eq "lineseq"
- and not null $op->first->first->sibling
- and $op->first->first->sibling->name eq "unstack")
- ));
-}
-
-# Check if the op and its sibling are the initialization and the rest of a
-# for (..;..;..) { ... } loop
-sub is_for_loop {
- my $op = shift;
- # This OP might be almost anything, though it won't be a
- # nextstate. (It's the initialization, so in the canonical case it
- # will be an sassign.) The sibling is a lineseq whose first child
- # is a nextstate and whose second is a leaveloop.
- my $lseq = $op->sibling;
- if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
- if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
- && (my $sib = $lseq->first->sibling)) {
- return (!null($sib) && $sib->name eq "leaveloop");
- }
- }
- return 0;
-}
-
-sub is_scalar {
- my $op = shift;
- return ($op->name eq "rv2sv" or
- $op->name eq "padsv" or
- $op->name eq "gv" or # only in array/hash constructs
- $op->flags & OPf_KIDS && !null($op->first)
- && $op->first->name eq "gvsv");
-}
-
-sub maybe_parens {
- my $self = shift;
- my($text, $cx, $prec) = @_;
- if ($prec < $cx # unary ops nest just fine
- or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
- or $self->{'parens'})
- {
- $text = "($text)";
- # In a unop, let parent reuse our parens; see maybe_parens_unop
- $text = "\cS" . $text if $cx == 16;
- return $text;
- } else {
- return $text;
- }
-}
-
-# same as above, but get around the `if it looks like a function' rule
-sub maybe_parens_unop {
- my $self = shift;
- my($name, $kid, $cx) = @_;
- if ($cx > 16 or $self->{'parens'}) {
- $kid = $self->deparse($kid, 1);
- if ($name eq "umask" && $kid =~ /^\d+$/) {
- $kid = sprintf("%#o", $kid);
- }
- return "$name($kid)";
- } else {
- $kid = $self->deparse($kid, 16);
- if ($name eq "umask" && $kid =~ /^\d+$/) {
- $kid = sprintf("%#o", $kid);
- }
- if (substr($kid, 0, 1) eq "\cS") {
- # use kid's parens
- return $name . substr($kid, 1);
- } elsif (substr($kid, 0, 1) eq "(") {
- # avoid looks-like-a-function trap with extra parens
- # (`+' can lead to ambiguities)
- return "$name(" . $kid . ")";
- } else {
- return "$name $kid";
- }
- }
-}
-
-sub maybe_parens_func {
- my $self = shift;
- my($func, $text, $cx, $prec) = @_;
- if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
- return "$func($text)";
- } else {
- return "$func $text";
- }
-}
-
-sub maybe_local {
- my $self = shift;
- my($op, $cx, $text) = @_;
- my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
- if ($op->private & (OPpLVAL_INTRO|$our_intro)
- and not $self->{'avoid_local'}{$$op}) {
- my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
- if( $our_local eq 'our' ) {
- # XXX This assertion fails code with non-ASCII identifiers,
- # like ./ext/Encode/t/jperl.t
- die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
- $text =~ s/(\w+::)+//;
- }
- if (want_scalar($op)) {
- return "$our_local $text";
- } else {
- return $self->maybe_parens_func("$our_local", $text, $cx, 16);
- }
- } else {
- return $text;
- }
-}
-
-sub maybe_targmy {
- my $self = shift;
- my($op, $cx, $func, @args) = @_;
- if ($op->private & OPpTARGET_MY) {
- my $var = $self->padname($op->targ);
- my $val = $func->($self, $op, 7, @args);
- return $self->maybe_parens("$var = $val", $cx, 7);
- } else {
- return $func->($self, $op, $cx, @args);
- }
-}
-
-sub padname_sv {
- my $self = shift;
- my $targ = shift;
- return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
-}
-
-sub maybe_my {
- my $self = shift;
- my($op, $cx, $text) = @_;
- if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
- if (want_scalar($op)) {
- return "my $text";
- } else {
- return $self->maybe_parens_func("my", $text, $cx, 16);
- }
- } else {
- return $text;
- }
-}
-
-# The following OPs don't have functions:
-
-# pp_padany -- does not exist after parsing
-
-sub AUTOLOAD {
- if ($AUTOLOAD =~ s/^.*::pp_//) {
- warn "unexpected OP_".uc $AUTOLOAD;
- return "XXX";
- } else {
- die "Undefined subroutine $AUTOLOAD called";
- }
-}
-
-sub DESTROY {} # Do not AUTOLOAD
-
-# $root should be the op which represents the root of whatever
-# we're sequencing here. If it's undefined, then we don't append
-# any subroutine declarations to the deparsed ops, otherwise we
-# append appropriate declarations.
-sub lineseq {
- my($self, $root, @ops) = @_;
- my($expr, @exprs);
-
- my $out_cop = $self->{'curcop'};
- my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
- my $limit_seq;
- if (defined $root) {
- $limit_seq = $out_seq;
- my $nseq;
- $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
- $limit_seq = $nseq if !defined($limit_seq)
- or defined($nseq) && $nseq < $limit_seq;
- }
- $limit_seq = $self->{'limit_seq'}
- if defined($self->{'limit_seq'})
- && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
- local $self->{'limit_seq'} = $limit_seq;
- for (my $i = 0; $i < @ops; $i++) {
- $expr = "";
- if (is_state $ops[$i]) {
- $expr = $self->deparse($ops[$i], 0);
- $i++;
- if ($i > $#ops) {
- push @exprs, $expr;
- last;
- }
- }
- if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
- !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
- {
- if ($ls->first && !null($ls->first) && is_state($ls->first)
- && (my $sib = $ls->first->sibling)) {
- if (!null($sib) && $sib->name eq "leaveloop") {
- push @exprs, $expr . $self->for_loop($ops[$i], 0);
- $i++;
- next;
- }
- }
- }
- $expr .= $self->deparse($ops[$i], (@ops != 1)/2);
- $expr =~ s/;\n?\z//;
- push @exprs, $expr;
- }
- my $body = join(";\n", grep {length} @exprs);
- my $subs = "";
- if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
- $subs = join "\n", $self->seq_subs($limit_seq);
- }
- return join(";\n", grep {length} $body, $subs);
-}
-
-sub scopeop {
- my($real_block, $self, $op, $cx) = @_;
- my $kid;
- my @kids;
-
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'} if $real_block;
- if ($real_block) {
- $kid = $op->first->sibling; # skip enter
- if (is_miniwhile($kid)) {
- my $top = $kid->first;
- my $name = $top->name;
- if ($name eq "and") {
- $name = "while";
- } elsif ($name eq "or") {
- $name = "until";
- } else { # no conditional -> while 1 or until 0
- return $self->deparse($top->first, 1) . " while 1";
- }
- my $cond = $top->first;
- my $body = $cond->sibling->first; # skip lineseq
- $cond = $self->deparse($cond, 1);
- $body = $self->deparse($body, 1);
- return "$body $name $cond";
- }
- } else {
- $kid = $op->first;
- }
- for (; !null($kid); $kid = $kid->sibling) {
- push @kids, $kid;
- }
- if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
- return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
- } else {
- my $lineseq = $self->lineseq($op, @kids);
- return (length ($lineseq) ? "$lineseq;" : "");
- }
-}
-
-sub pp_scope { scopeop(0, @_); }
-sub pp_lineseq { scopeop(0, @_); }
-sub pp_leave { scopeop(1, @_); }
-
-# This is a special case of scopeop and lineseq, for the case of the
-# main_root. The difference is that we print the output statements as
-# soon as we get them, for the sake of impatient users.
-sub deparse_root {
- my $self = shift;
- my($op) = @_;
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'};
- my @kids;
- for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
- push @kids, $kid;
- }
- for (my $i = 0; $i < @kids; $i++) {
- my $expr = "";
- if (is_state $kids[$i]) {
- $expr = $self->deparse($kids[$i], 0);
- $i++;
- if ($i > $#kids) {
- print $self->indent($expr);
- last;
- }
- }
- if (is_for_loop($kids[$i])) {
- $expr .= $self->for_loop($kids[$i], 0);
- $expr .= ";\n" unless $i == $#kids;
- print $self->indent($expr);
- $i++;
- next;
- }
- $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
- $expr =~ s/;\n?\z//;
- $expr .= ";";
- print $self->indent($expr);
- print "\n" unless $i == $#kids;
- }
-}
-
-# The BEGIN {} is used here because otherwise this code isn't executed
-# when you run B::Deparse on itself.
-my %globalnames;
-BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
- "ENV", "ARGV", "ARGVOUT", "_"); }
-
-sub gv_name {
- my $self = shift;
- my $gv = shift;
-Carp::confess() unless ref($gv) eq "B::GV";
- my $stash = $gv->STASH->NAME;
- my $name = $gv->SAFENAME;
- if (($stash eq 'main' && $globalnames{$name})
- or ($stash eq $self->{'curstash'} && !$globalnames{$name})
- or $name =~ /^[^A-Za-z_:]/)
- {
- $stash = "";
- } else {
- $stash = $stash . "::";
- }
- if ($name =~ /^(\^..|{)/) {
- $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
- }
- return $stash . $name;
-}
-
-# Return the name to use for a stash variable.
-# If a lexical with the same name is in scope, it may need to be
-# fully-qualified.
-sub stash_variable {
- my ($self, $prefix, $name) = @_;
-
- return "$prefix$name" if $name =~ /::/;
-
- unless ($prefix eq '$' || $prefix eq '@' || #'
- $prefix eq '%' || $prefix eq '$#') {
- return "$prefix$name";
- }
-
- my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
- return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
- return "$prefix$name";
-}
-
-sub lex_in_scope {
- my ($self, $name) = @_;
- $self->populate_curcvlex() if !defined $self->{'curcvlex'};
-
- return 0 if !defined($self->{'curcop'});
- my $seq = $self->{'curcop'}->cop_seq;
- return 0 if !exists $self->{'curcvlex'}{$name};
- for my $a (@{$self->{'curcvlex'}{$name}}) {
- my ($st, $en) = @$a;
- return 1 if $seq > $st && $seq <= $en;
- }
- return 0;
-}
-
-sub populate_curcvlex {
- my $self = shift;
- for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
- my $padlist = $cv->PADLIST;
- # an undef CV still in lexical chain
- next if class($padlist) eq "SPECIAL";
- my @padlist = $padlist->ARRAY;
- my @ns = $padlist[0]->ARRAY;
-
- for (my $i=0; $i<@ns; ++$i) {
- next if class($ns[$i]) eq "SPECIAL";
- next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
- if (class($ns[$i]) eq "PV") {
- # Probably that pesky lexical @_
- next;
- }
- my $name = $ns[$i]->PVX;
- my ($seq_st, $seq_en) =
- ($ns[$i]->FLAGS & SVf_FAKE)
- ? (0, 999999)
- : ($ns[$i]->NVX, $ns[$i]->IVX);
-
- push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
- }
- }
-}
-
-sub find_scope_st { ((find_scope(@_))[0]); }
-sub find_scope_en { ((find_scope(@_))[1]); }
-
-# Recurses down the tree, looking for pad variable introductions and COPs
-sub find_scope {
- my ($self, $op, $scope_st, $scope_en) = @_;
- carp("Undefined op in find_scope") if !defined $op;
- return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
-
- for (my $o=$op->first; $$o; $o=$o->sibling) {
- if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
- my $s = int($self->padname_sv($o->targ)->NVX);
- my $e = $self->padname_sv($o->targ)->IVX;
- $scope_st = $s if !defined($scope_st) || $s < $scope_st;
- $scope_en = $e if !defined($scope_en) || $e > $scope_en;
- }
- elsif (is_state($o)) {
- my $c = $o->cop_seq;
- $scope_st = $c if !defined($scope_st) || $c < $scope_st;
- $scope_en = $c if !defined($scope_en) || $c > $scope_en;
- }
- elsif ($o->flags & OPf_KIDS) {
- ($scope_st, $scope_en) =
- $self->find_scope($o, $scope_st, $scope_en)
- }
- }
-
- return ($scope_st, $scope_en);
-}
-
-# Returns a list of subs which should be inserted before the COP
-sub cop_subs {
- my ($self, $op, $out_seq) = @_;
- my $seq = $op->cop_seq;
- # If we have nephews, then our sequence number indicates
- # the cop_seq of the end of some sort of scope.
- if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
- and my $nseq = $self->find_scope_st($op->sibling) ) {
- $seq = $nseq;
- }
- $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
- return $self->seq_subs($seq);
-}
-
-sub seq_subs {
- my ($self, $seq) = @_;
- my @text;
-#push @text, "# ($seq)\n";
-
- return "" if !defined $seq;
- while (scalar(@{$self->{'subs_todo'}})
- and $seq > $self->{'subs_todo'}[0][0]) {
- push @text, $self->next_todo;
- }
- return @text;
-}
-
-# Notice how subs and formats are inserted between statements here;
-# also $[ assignments and pragmas.
-sub pp_nextstate {
- my $self = shift;
- my($op, $cx) = @_;
- $self->{'curcop'} = $op;
- my @text;
- push @text, $self->cop_subs($op);
- push @text, $op->label . ": " if $op->label;
- my $stash = $op->stashpv;
- if ($stash ne $self->{'curstash'}) {
- push @text, "package $stash;\n";
- $self->{'curstash'} = $stash;
- }
-
- if ($self->{'arybase'} != $op->arybase) {
- push @text, '$[ = '. $op->arybase .";\n";
- $self->{'arybase'} = $op->arybase;
- }
-
- my $warnings = $op->warnings;
- my $warning_bits;
- if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
- $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
- }
- elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
- $warning_bits = $warnings::NONE;
- }
- elsif ($warnings->isa("B::SPECIAL")) {
- $warning_bits = undef;
- }
- else {
- $warning_bits = $warnings->PV & WARN_MASK;
- }
-
- if (defined ($warning_bits) and
- !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
- push @text, declare_warnings($self->{'warnings'}, $warning_bits);
- $self->{'warnings'} = $warning_bits;
- }
-
- if ($self->{'hints'} != $op->private) {
- push @text, declare_hints($self->{'hints'}, $op->private);
- $self->{'hints'} = $op->private;
- }
-
- # This should go after of any branches that add statements, to
- # increase the chances that it refers to the same line it did in
- # the original program.
- if ($self->{'linenums'}) {
- push @text, "\f#line " . $op->line .
- ' "' . $op->file, qq'"\n';
- }
-
- return join("", @text);
-}
-
-sub declare_warnings {
- my ($from, $to) = @_;
- if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
- return "use warnings;\n";
- }
- elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
- return "no warnings;\n";
- }
- return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
-}
-
-sub declare_hints {
- my ($from, $to) = @_;
- my $use = $to & ~$from;
- my $no = $from & ~$to;
- my $decls = "";
- for my $pragma (hint_pragmas($use)) {
- $decls .= "use $pragma;\n";
- }
- for my $pragma (hint_pragmas($no)) {
- $decls .= "no $pragma;\n";
- }
- return $decls;
-}
-
-sub hint_pragmas {
- my ($bits) = @_;
- my @pragmas;
- push @pragmas, "integer" if $bits & 0x1;
- push @pragmas, "strict 'refs'" if $bits & 0x2;
- push @pragmas, "bytes" if $bits & 0x8;
- return @pragmas;
-}
-
-sub pp_dbstate { pp_nextstate(@_) }
-sub pp_setstate { pp_nextstate(@_) }
-
-sub pp_unstack { return "" } # see also leaveloop
-
-sub baseop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- return $name;
-}
-
-sub pp_stub {
- my $self = shift;
- my($op, $cx, $name) = @_;
- if ($cx >= 1) {
- return "()";
- }
- else {
- return "();";
- }
-}
-sub pp_wantarray { baseop(@_, "wantarray") }
-sub pp_fork { baseop(@_, "fork") }
-sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
-sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
-sub pp_time { maybe_targmy(@_, \&baseop, "time") }
-sub pp_tms { baseop(@_, "times") }
-sub pp_ghostent { baseop(@_, "gethostent") }
-sub pp_gnetent { baseop(@_, "getnetent") }
-sub pp_gprotoent { baseop(@_, "getprotoent") }
-sub pp_gservent { baseop(@_, "getservent") }
-sub pp_ehostent { baseop(@_, "endhostent") }
-sub pp_enetent { baseop(@_, "endnetent") }
-sub pp_eprotoent { baseop(@_, "endprotoent") }
-sub pp_eservent { baseop(@_, "endservent") }
-sub pp_gpwent { baseop(@_, "getpwent") }
-sub pp_spwent { baseop(@_, "setpwent") }
-sub pp_epwent { baseop(@_, "endpwent") }
-sub pp_ggrent { baseop(@_, "getgrent") }
-sub pp_sgrent { baseop(@_, "setgrent") }
-sub pp_egrent { baseop(@_, "endgrent") }
-sub pp_getlogin { baseop(@_, "getlogin") }
-
-sub POSTFIX () { 1 }
-
-# I couldn't think of a good short name, but this is the category of
-# symbolic unary operators with interesting precedence
-
-sub pfixop {
- my $self = shift;
- my($op, $cx, $name, $prec, $flags) = (@_, 0);
- my $kid = $op->first;
- $kid = $self->deparse($kid, $prec);
- return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
- $cx, $prec);
-}
-
-sub pp_preinc { pfixop(@_, "++", 23) }
-sub pp_predec { pfixop(@_, "--", 23) }
-sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
-sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
-sub pp_i_preinc { pfixop(@_, "++", 23) }
-sub pp_i_predec { pfixop(@_, "--", 23) }
-sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
-sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
-sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
-
-sub pp_negate { maybe_targmy(@_, \&real_negate) }
-sub real_negate {
- my $self = shift;
- my($op, $cx) = @_;
- if ($op->first->name =~ /^(i_)?negate$/) {
- # avoid --$x
- $self->pfixop($op, $cx, "-", 21.5);
- } else {
- $self->pfixop($op, $cx, "-", 21);
- }
-}
-sub pp_i_negate { pp_negate(@_) }
-
-sub pp_not {
- my $self = shift;
- my($op, $cx) = @_;
- if ($cx <= 4) {
- $self->pfixop($op, $cx, "not ", 4);
- } else {
- $self->pfixop($op, $cx, "!", 21);
- }
-}
-
-sub unop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- my $kid;
- if ($op->flags & OPf_KIDS) {
- $kid = $op->first;
- if (defined prototype("CORE::$name")
- && prototype("CORE::$name") =~ /^;?\*/
- && $kid->name eq "rv2gv") {
- $kid = $kid->first;
- }
-
- return $self->maybe_parens_unop($name, $kid, $cx);
- } else {
- return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
- }
-}
-
-sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
-sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
-sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
-sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
-sub pp_defined { unop(@_, "defined") }
-sub pp_undef { unop(@_, "undef") }
-sub pp_study { unop(@_, "study") }
-sub pp_ref { unop(@_, "ref") }
-sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
-
-sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
-sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
-sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
-sub pp_srand { unop(@_, "srand") }
-sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
-sub pp_log { maybe_targmy(@_, \&unop, "log") }
-sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
-sub pp_int { maybe_targmy(@_, \&unop, "int") }
-sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
-sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
-sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
-
-sub pp_length { maybe_targmy(@_, \&unop, "length") }
-sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
-sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
-
-sub pp_each { unop(@_, "each") }
-sub pp_values { unop(@_, "values") }
-sub pp_keys { unop(@_, "keys") }
-sub pp_pop { unop(@_, "pop") }
-sub pp_shift { unop(@_, "shift") }
-
-sub pp_caller { unop(@_, "caller") }
-sub pp_reset { unop(@_, "reset") }
-sub pp_exit { unop(@_, "exit") }
-sub pp_prototype { unop(@_, "prototype") }
-
-sub pp_close { unop(@_, "close") }
-sub pp_fileno { unop(@_, "fileno") }
-sub pp_umask { unop(@_, "umask") }
-sub pp_untie { unop(@_, "untie") }
-sub pp_tied { unop(@_, "tied") }
-sub pp_dbmclose { unop(@_, "dbmclose") }
-sub pp_getc { unop(@_, "getc") }
-sub pp_eof { unop(@_, "eof") }
-sub pp_tell { unop(@_, "tell") }
-sub pp_getsockname { unop(@_, "getsockname") }
-sub pp_getpeername { unop(@_, "getpeername") }
-
-sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
-sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
-sub pp_readlink { unop(@_, "readlink") }
-sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
-sub pp_readdir { unop(@_, "readdir") }
-sub pp_telldir { unop(@_, "telldir") }
-sub pp_rewinddir { unop(@_, "rewinddir") }
-sub pp_closedir { unop(@_, "closedir") }
-sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
-sub pp_localtime { unop(@_, "localtime") }
-sub pp_gmtime { unop(@_, "gmtime") }
-sub pp_alarm { unop(@_, "alarm") }
-sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
-
-sub pp_dofile { unop(@_, "do") }
-sub pp_entereval { unop(@_, "eval") }
-
-sub pp_ghbyname { unop(@_, "gethostbyname") }
-sub pp_gnbyname { unop(@_, "getnetbyname") }
-sub pp_gpbyname { unop(@_, "getprotobyname") }
-sub pp_shostent { unop(@_, "sethostent") }
-sub pp_snetent { unop(@_, "setnetent") }
-sub pp_sprotoent { unop(@_, "setprotoent") }
-sub pp_sservent { unop(@_, "setservent") }
-sub pp_gpwnam { unop(@_, "getpwnam") }
-sub pp_gpwuid { unop(@_, "getpwuid") }
-sub pp_ggrnam { unop(@_, "getgrnam") }
-sub pp_ggrgid { unop(@_, "getgrgid") }
-
-sub pp_lock { unop(@_, "lock") }
-
-sub pp_exists {
- my $self = shift;
- my($op, $cx) = @_;
- my $arg;
- if ($op->private & OPpEXISTS_SUB) {
- # Checking for the existence of a subroutine
- return $self->maybe_parens_func("exists",
- $self->pp_rv2cv($op->first, 16), $cx, 16);
- }
- if ($op->flags & OPf_SPECIAL) {
- # Array element, not hash element
- return $self->maybe_parens_func("exists",
- $self->pp_aelem($op->first, 16), $cx, 16);
- }
- return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
- $cx, 16);
-}
-
-sub pp_delete {
- my $self = shift;
- my($op, $cx) = @_;
- my $arg;
- if ($op->private & OPpSLICE) {
- if ($op->flags & OPf_SPECIAL) {
- # Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
- $self->pp_aslice($op->first, 16),
- $cx, 16);
- }
- return $self->maybe_parens_func("delete",
- $self->pp_hslice($op->first, 16),
- $cx, 16);
- } else {
- if ($op->flags & OPf_SPECIAL) {
- # Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
- $self->pp_aelem($op->first, 16),
- $cx, 16);
- }
- return $self->maybe_parens_func("delete",
- $self->pp_helem($op->first, 16),
- $cx, 16);
- }
-}
-
-sub pp_require {
- my $self = shift;
- my($op, $cx) = @_;
- my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
- if (class($op) eq "UNOP" and $op->first->name eq "const"
- and $op->first->private & OPpCONST_BARE)
- {
- my $name = $self->const_sv($op->first)->PV;
- $name =~ s[/][::]g;
- $name =~ s/\.pm//g;
- return "$opname $name";
- } else {
- $self->unop($op, $cx, $opname);
- }
-}
-
-sub pp_scalar {
- my $self = shift;
- my($op, $cv) = @_;
- my $kid = $op->first;
- if (not null $kid->sibling) {
- # XXX Was a here-doc
- return $self->dquote($op);
- }
- $self->unop(@_, "scalar");
-}
-
-
-sub padval {
- my $self = shift;
- my $targ = shift;
- return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
-}
-
-sub pp_refgen {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first;
- if ($kid->name eq "null") {
- $kid = $kid->first;
- if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
- my($pre, $post) = @{{"anonlist" => ["[","]"],
- "anonhash" => ["{","}"]}->{$kid->name}};
- my($expr, @exprs);
- $kid = $kid->first->sibling; # skip pushmark
- for (; !null($kid); $kid = $kid->sibling) {
- $expr = $self->deparse($kid, 6);
- push @exprs, $expr;
- }
- return $pre . join(", ", @exprs) . $post;
- } elsif (!null($kid->sibling) and
- $kid->sibling->name eq "anoncode") {
- return "sub " .
- $self->deparse_sub($self->padval($kid->sibling->targ));
- } elsif ($kid->name eq "pushmark") {
- my $sib_name = $kid->sibling->name;
- if ($sib_name =~ /^(pad|rv2)[ah]v$/
- and not $kid->sibling->flags & OPf_REF)
- {
- # The @a in \(@a) isn't in ref context, but only when the
- # parens are there.
- return "\\(" . $self->pp_list($op->first) . ")";
- } elsif ($sib_name eq 'entersub') {
- my $text = $self->deparse($kid->sibling, 1);
- # Always show parens for \(&func()), but only with -p otherwise
- $text = "($text)" if $self->{'parens'}
- or $kid->sibling->private & OPpENTERSUB_AMPER;
- return "\\$text";
- }
- }
- }
- $self->pfixop($op, $cx, "\\", 20);
-}
-
-sub pp_srefgen { pp_refgen(@_) }
-
-sub pp_readline {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first;
- $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
- return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
- return $self->unop($op, $cx, "readline");
-}
-
-sub pp_rcatline {
- my $self = shift;
- my($op) = @_;
- return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
-}
-
-# Unary operators that can occur as pseudo-listops inside double quotes
-sub dq_unop {
- my $self = shift;
- my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
- my $kid;
- if ($op->flags & OPf_KIDS) {
- $kid = $op->first;
- # If there's more than one kid, the first is an ex-pushmark.
- $kid = $kid->sibling if not null $kid->sibling;
- return $self->maybe_parens_unop($name, $kid, $cx);
- } else {
- return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
- }
-}
-
-sub pp_ucfirst { dq_unop(@_, "ucfirst") }
-sub pp_lcfirst { dq_unop(@_, "lcfirst") }
-sub pp_uc { dq_unop(@_, "uc") }
-sub pp_lc { dq_unop(@_, "lc") }
-sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
-
-sub loopex {
- my $self = shift;
- my ($op, $cx, $name) = @_;
- if (class($op) eq "PVOP") {
- return "$name " . $op->pv;
- } elsif (class($op) eq "OP") {
- return $name;
- } elsif (class($op) eq "UNOP") {
- # Note -- loop exits are actually exempt from the
- # looks-like-a-func rule, but a few extra parens won't hurt
- return $self->maybe_parens_unop($name, $op->first, $cx);
- }
-}
-
-sub pp_last { loopex(@_, "last") }
-sub pp_next { loopex(@_, "next") }
-sub pp_redo { loopex(@_, "redo") }
-sub pp_goto { loopex(@_, "goto") }
-sub pp_dump { loopex(@_, "dump") }
-
-sub ftst {
- my $self = shift;
- my($op, $cx, $name) = @_;
- if (class($op) eq "UNOP") {
- # Genuine `-X' filetests are exempt from the LLAFR, but not
- # l?stat(); for the sake of clarity, give'em all parens
- return $self->maybe_parens_unop($name, $op->first, $cx);
- } elsif (class($op) =~ /^(SV|PAD)OP$/) {
- return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
- } else { # I don't think baseop filetests ever survive ck_ftst, but...
- return $name;
- }
-}
-
-sub pp_lstat { ftst(@_, "lstat") }
-sub pp_stat { ftst(@_, "stat") }
-sub pp_ftrread { ftst(@_, "-R") }
-sub pp_ftrwrite { ftst(@_, "-W") }
-sub pp_ftrexec { ftst(@_, "-X") }
-sub pp_fteread { ftst(@_, "-r") }
-sub pp_ftewrite { ftst(@_, "-w") }
-sub pp_fteexec { ftst(@_, "-x") }
-sub pp_ftis { ftst(@_, "-e") }
-sub pp_fteowned { ftst(@_, "-O") }
-sub pp_ftrowned { ftst(@_, "-o") }
-sub pp_ftzero { ftst(@_, "-z") }
-sub pp_ftsize { ftst(@_, "-s") }
-sub pp_ftmtime { ftst(@_, "-M") }
-sub pp_ftatime { ftst(@_, "-A") }
-sub pp_ftctime { ftst(@_, "-C") }
-sub pp_ftsock { ftst(@_, "-S") }
-sub pp_ftchr { ftst(@_, "-c") }
-sub pp_ftblk { ftst(@_, "-b") }
-sub pp_ftfile { ftst(@_, "-f") }
-sub pp_ftdir { ftst(@_, "-d") }
-sub pp_ftpipe { ftst(@_, "-p") }
-sub pp_ftlink { ftst(@_, "-l") }
-sub pp_ftsuid { ftst(@_, "-u") }
-sub pp_ftsgid { ftst(@_, "-g") }
-sub pp_ftsvtx { ftst(@_, "-k") }
-sub pp_fttty { ftst(@_, "-t") }
-sub pp_fttext { ftst(@_, "-T") }
-sub pp_ftbinary { ftst(@_, "-B") }
-
-sub SWAP_CHILDREN () { 1 }
-sub ASSIGN () { 2 } # has OP= variant
-sub LIST_CONTEXT () { 4 } # Assignment is in list context
-
-my(%left, %right);
-
-sub assoc_class {
- my $op = shift;
- my $name = $op->name;
- if ($name eq "concat" and $op->first->name eq "concat") {
- # avoid spurious `=' -- see comment in pp_concat
- return "concat";
- }
- if ($name eq "null" and class($op) eq "UNOP"
- and $op->first->name =~ /^(and|x?or)$/
- and null $op->first->sibling)
- {
- # Like all conditional constructs, OP_ANDs and OP_ORs are topped
- # with a null that's used as the common end point of the two
- # flows of control. For precedence purposes, ignore it.
- # (COND_EXPRs have these too, but we don't bother with
- # their associativity).
- return assoc_class($op->first);
- }
- return $name . ($op->flags & OPf_STACKED ? "=" : "");
-}
-
-# Left associative operators, like `+', for which
-# $a + $b + $c is equivalent to ($a + $b) + $c
-
-BEGIN {
- %left = ('multiply' => 19, 'i_multiply' => 19,
- 'divide' => 19, 'i_divide' => 19,
- 'modulo' => 19, 'i_modulo' => 19,
- 'repeat' => 19,
- 'add' => 18, 'i_add' => 18,
- 'subtract' => 18, 'i_subtract' => 18,
- 'concat' => 18,
- 'left_shift' => 17, 'right_shift' => 17,
- 'bit_and' => 13,
- 'bit_or' => 12, 'bit_xor' => 12,
- 'and' => 3,
- 'or' => 2, 'xor' => 2,
- );
-}
-
-sub deparse_binop_left {
- my $self = shift;
- my($op, $left, $prec) = @_;
- if ($left{assoc_class($op)} && $left{assoc_class($left)}
- and $left{assoc_class($op)} == $left{assoc_class($left)})
- {
- return $self->deparse($left, $prec - .00001);
- } else {
- return $self->deparse($left, $prec);
- }
-}
-
-# Right associative operators, like `=', for which
-# $a = $b = $c is equivalent to $a = ($b = $c)
-
-BEGIN {
- %right = ('pow' => 22,
- 'sassign=' => 7, 'aassign=' => 7,
- 'multiply=' => 7, 'i_multiply=' => 7,
- 'divide=' => 7, 'i_divide=' => 7,
- 'modulo=' => 7, 'i_modulo=' => 7,
- 'repeat=' => 7,
- 'add=' => 7, 'i_add=' => 7,
- 'subtract=' => 7, 'i_subtract=' => 7,
- 'concat=' => 7,
- 'left_shift=' => 7, 'right_shift=' => 7,
- 'bit_and=' => 7,
- 'bit_or=' => 7, 'bit_xor=' => 7,
- 'andassign' => 7,
- 'orassign' => 7,
- );
-}
-
-sub deparse_binop_right {
- my $self = shift;
- my($op, $right, $prec) = @_;
- if ($right{assoc_class($op)} && $right{assoc_class($right)}
- and $right{assoc_class($op)} == $right{assoc_class($right)})
- {
- return $self->deparse($right, $prec - .00001);
- } else {
- return $self->deparse($right, $prec);
- }
-}
-
-sub binop {
- my $self = shift;
- my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
- my $left = $op->first;
- my $right = $op->last;
- my $eq = "";
- if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
- $eq = "=";
- $prec = 7;
- }
- if ($flags & SWAP_CHILDREN) {
- ($left, $right) = ($right, $left);
- }
- $left = $self->deparse_binop_left($op, $left, $prec);
- $left = "($left)" if $flags & LIST_CONTEXT
- && $left !~ /^(my|our|local|)[\@\(]/;
- $right = $self->deparse_binop_right($op, $right, $prec);
- return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
-}
-
-sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
-sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
-sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
-sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
-sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
-sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
-sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
-sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
-sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
-sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
-sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
-
-sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
-sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
-sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
-sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
-sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
-
-sub pp_eq { binop(@_, "==", 14) }
-sub pp_ne { binop(@_, "!=", 14) }
-sub pp_lt { binop(@_, "<", 15) }
-sub pp_gt { binop(@_, ">", 15) }
-sub pp_ge { binop(@_, ">=", 15) }
-sub pp_le { binop(@_, "<=", 15) }
-sub pp_ncmp { binop(@_, "<=>", 14) }
-sub pp_i_eq { binop(@_, "==", 14) }
-sub pp_i_ne { binop(@_, "!=", 14) }
-sub pp_i_lt { binop(@_, "<", 15) }
-sub pp_i_gt { binop(@_, ">", 15) }
-sub pp_i_ge { binop(@_, ">=", 15) }
-sub pp_i_le { binop(@_, "<=", 15) }
-sub pp_i_ncmp { binop(@_, "<=>", 14) }
-
-sub pp_seq { binop(@_, "eq", 14) }
-sub pp_sne { binop(@_, "ne", 14) }
-sub pp_slt { binop(@_, "lt", 15) }
-sub pp_sgt { binop(@_, "gt", 15) }
-sub pp_sge { binop(@_, "ge", 15) }
-sub pp_sle { binop(@_, "le", 15) }
-sub pp_scmp { binop(@_, "cmp", 14) }
-
-sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
-sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
-
-# `.' is special because concats-of-concats are optimized to save copying
-# by making all but the first concat stacked. The effect is as if the
-# programmer had written `($a . $b) .= $c', except legal.
-sub pp_concat { maybe_targmy(@_, \&real_concat) }
-sub real_concat {
- my $self = shift;
- my($op, $cx) = @_;
- my $left = $op->first;
- my $right = $op->last;
- my $eq = "";
- my $prec = 18;
- if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
- $eq = "=";
- $prec = 7;
- }
- $left = $self->deparse_binop_left($op, $left, $prec);
- $right = $self->deparse_binop_right($op, $right, $prec);
- return $self->maybe_parens("$left .$eq $right", $cx, $prec);
-}
-
-# `x' is weird when the left arg is a list
-sub pp_repeat {
- my $self = shift;
- my($op, $cx) = @_;
- my $left = $op->first;
- my $right = $op->last;
- my $eq = "";
- my $prec = 19;
- if ($op->flags & OPf_STACKED) {
- $eq = "=";
- $prec = 7;
- }
- if (null($right)) { # list repeat; count is inside left-side ex-list
- my $kid = $left->first->sibling; # skip pushmark
- my @exprs;
- for (; !null($kid->sibling); $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
- }
- $right = $kid;
- $left = "(" . join(", ", @exprs). ")";
- } else {
- $left = $self->deparse_binop_left($op, $left, $prec);
- }
- $right = $self->deparse_binop_right($op, $right, $prec);
- return $self->maybe_parens("$left x$eq $right", $cx, $prec);
-}
-
-sub range {
- my $self = shift;
- my ($op, $cx, $type) = @_;
- my $left = $op->first;
- my $right = $left->sibling;
- $left = $self->deparse($left, 9);
- $right = $self->deparse($right, 9);
- return $self->maybe_parens("$left $type $right", $cx, 9);
-}
-
-sub pp_flop {
- my $self = shift;
- my($op, $cx) = @_;
- my $flip = $op->first;
- my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
- return $self->range($flip->first, $cx, $type);
-}
-
-# one-line while/until is handled in pp_leave
-
-sub logop {
- my $self = shift;
- my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
- my $left = $op->first;
- my $right = $op->first->sibling;
- if ($cx < 1 and is_scope($right) and $blockname
- and $self->{'expand'} < 7)
- { # if ($a) {$b}
- $left = $self->deparse($left, 1);
- $right = $self->deparse($right, 0);
- return "$blockname ($left) {\n\t$right\n\b}\cK";
- } elsif ($cx < 1 and $blockname and not $self->{'parens'}
- and $self->{'expand'} < 7) { # $b if $a
- $right = $self->deparse($right, 1);
- $left = $self->deparse($left, 1);
- return "$right $blockname $left";
- } elsif ($cx > $lowprec and $highop) { # $a && $b
- $left = $self->deparse_binop_left($op, $left, $highprec);
- $right = $self->deparse_binop_right($op, $right, $highprec);
- return $self->maybe_parens("$left $highop $right", $cx, $highprec);
- } else { # $a and $b
- $left = $self->deparse_binop_left($op, $left, $lowprec);
- $right = $self->deparse_binop_right($op, $right, $lowprec);
- return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
- }
-}
-
-sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
-sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
-sub pp_dor { logop(@_, "err", 2, "//", 10, "") }
-
-# xor is syntactically a logop, but it's really a binop (contrary to
-# old versions of opcode.pl). Syntax is what matters here.
-sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
-
-sub logassignop {
- my $self = shift;
- my ($op, $cx, $opname) = @_;
- my $left = $op->first;
- my $right = $op->first->sibling->first; # skip sassign
- $left = $self->deparse($left, 7);
- $right = $self->deparse($right, 7);
- return $self->maybe_parens("$left $opname $right", $cx, 7);
-}
-
-sub pp_andassign { logassignop(@_, "&&=") }
-sub pp_orassign { logassignop(@_, "||=") }
-sub pp_dorassign { logassignop(@_, "//=") }
-
-sub listop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- my(@exprs);
- my $parens = ($cx >= 5) || $self->{'parens'};
- my $kid = $op->first->sibling;
- return $name if null $kid;
- my $first;
- $name = "socketpair" if $name eq "sockpair";
- my $proto = prototype("CORE::$name");
- if (defined $proto
- && $proto =~ /^;?\*/
- && $kid->name eq "rv2gv") {
- $first = $self->deparse($kid->first, 6);
- }
- else {
- $first = $self->deparse($kid, 6);
- }
- if ($name eq "chmod" && $first =~ /^\d+$/) {
- $first = sprintf("%#o", $first);
- }
- $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
- push @exprs, $first;
- $kid = $kid->sibling;
- if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
- push @exprs, $self->deparse($kid->first, 6);
- $kid = $kid->sibling;
- }
- for (; !null($kid); $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
- }
- if ($parens) {
- return "$name(" . join(", ", @exprs) . ")";
- } else {
- return "$name " . join(", ", @exprs);
- }
-}
-
-sub pp_bless { listop(@_, "bless") }
-sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
-sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
-sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
-sub pp_index { maybe_targmy(@_, \&listop, "index") }
-sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
-sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
-sub pp_formline { listop(@_, "formline") } # see also deparse_format
-sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
-sub pp_unpack { listop(@_, "unpack") }
-sub pp_pack { listop(@_, "pack") }
-sub pp_join { maybe_targmy(@_, \&listop, "join") }
-sub pp_splice { listop(@_, "splice") }
-sub pp_push { maybe_targmy(@_, \&listop, "push") }
-sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
-sub pp_reverse { listop(@_, "reverse") }
-sub pp_warn { listop(@_, "warn") }
-sub pp_die { listop(@_, "die") }
-# Actually, return is exempt from the LLAFR (see examples in this very
-# module!), but for consistency's sake, ignore that fact
-sub pp_return { listop(@_, "return") }
-sub pp_open { listop(@_, "open") }
-sub pp_pipe_op { listop(@_, "pipe") }
-sub pp_tie { listop(@_, "tie") }
-sub pp_binmode { listop(@_, "binmode") }
-sub pp_dbmopen { listop(@_, "dbmopen") }
-sub pp_sselect { listop(@_, "select") }
-sub pp_select { listop(@_, "select") }
-sub pp_read { listop(@_, "read") }
-sub pp_sysopen { listop(@_, "sysopen") }
-sub pp_sysseek { listop(@_, "sysseek") }
-sub pp_sysread { listop(@_, "sysread") }
-sub pp_syswrite { listop(@_, "syswrite") }
-sub pp_send { listop(@_, "send") }
-sub pp_recv { listop(@_, "recv") }
-sub pp_seek { listop(@_, "seek") }
-sub pp_fcntl { listop(@_, "fcntl") }
-sub pp_ioctl { listop(@_, "ioctl") }
-sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
-sub pp_socket { listop(@_, "socket") }
-sub pp_sockpair { listop(@_, "sockpair") }
-sub pp_bind { listop(@_, "bind") }
-sub pp_connect { listop(@_, "connect") }
-sub pp_listen { listop(@_, "listen") }
-sub pp_accept { listop(@_, "accept") }
-sub pp_shutdown { listop(@_, "shutdown") }
-sub pp_gsockopt { listop(@_, "getsockopt") }
-sub pp_ssockopt { listop(@_, "setsockopt") }
-sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
-sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
-sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
-sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
-sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
-sub pp_link { maybe_targmy(@_, \&listop, "link") }
-sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
-sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
-sub pp_open_dir { listop(@_, "opendir") }
-sub pp_seekdir { listop(@_, "seekdir") }
-sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
-sub pp_system { maybe_targmy(@_, \&listop, "system") }
-sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
-sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
-sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
-sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
-sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
-sub pp_shmget { listop(@_, "shmget") }
-sub pp_shmctl { listop(@_, "shmctl") }
-sub pp_shmread { listop(@_, "shmread") }
-sub pp_shmwrite { listop(@_, "shmwrite") }
-sub pp_msgget { listop(@_, "msgget") }
-sub pp_msgctl { listop(@_, "msgctl") }
-sub pp_msgsnd { listop(@_, "msgsnd") }
-sub pp_msgrcv { listop(@_, "msgrcv") }
-sub pp_semget { listop(@_, "semget") }
-sub pp_semctl { listop(@_, "semctl") }
-sub pp_semop { listop(@_, "semop") }
-sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
-sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
-sub pp_gpbynumber { listop(@_, "getprotobynumber") }
-sub pp_gsbyname { listop(@_, "getservbyname") }
-sub pp_gsbyport { listop(@_, "getservbyport") }
-sub pp_syscall { listop(@_, "syscall") }
-
-sub pp_glob {
- my $self = shift;
- my($op, $cx) = @_;
- my $text = $self->dq($op->first->sibling); # skip pushmark
- if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
- or $text =~ /[<>]/) {
- return 'glob(' . single_delim('qq', '"', $text) . ')';
- } else {
- return '<' . $text . '>';
- }
-}
-
-# Truncate is special because OPf_SPECIAL makes a bareword first arg
-# be a filehandle. This could probably be better fixed in the core
-# by moving the GV lookup into ck_truc.
-
-sub pp_truncate {
- my $self = shift;
- my($op, $cx) = @_;
- my(@exprs);
- my $parens = ($cx >= 5) || $self->{'parens'};
- my $kid = $op->first->sibling;
- my $fh;
- if ($op->flags & OPf_SPECIAL) {
- # $kid is an OP_CONST
- $fh = $self->const_sv($kid)->PV;
- } else {
- $fh = $self->deparse($kid, 6);
- $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
- }
- my $len = $self->deparse($kid->sibling, 6);
- if ($parens) {
- return "truncate($fh, $len)";
- } else {
- return "truncate $fh, $len";
- }
-}
-
-sub indirop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- my($expr, @exprs);
- my $kid = $op->first->sibling;
- my $indir = "";
- if ($op->flags & OPf_STACKED) {
- $indir = $kid;
- $indir = $indir->first; # skip rv2gv
- if (is_scope($indir)) {
- $indir = "{" . $self->deparse($indir, 0) . "}";
- $indir = "{;}" if $indir eq "{}";
- } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
- $indir = $self->const_sv($indir)->PV;
- } else {
- $indir = $self->deparse($indir, 24);
- }
- $indir = $indir . " ";
- $kid = $kid->sibling;
- }
- if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
- $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
- : '{$a <=> $b} ';
- }
- elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
- $indir = '{$b cmp $a} ';
- }
- for (; !null($kid); $kid = $kid->sibling) {
- $expr = $self->deparse($kid, 6);
- push @exprs, $expr;
- }
- my $name2 = $name;
- if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
- $name2 = 'reverse sort';
- }
- if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
- return "$exprs[0] = $name2 $indir $exprs[0]";
- }
-
- my $args = $indir . join(", ", @exprs);
- if ($indir ne "" and $name eq "sort") {
- # We don't want to say "sort(f 1, 2, 3)", since perl -w will
- # give bareword warnings in that case. Therefore if context
- # requires, we'll put parens around the outside "(sort f 1, 2,
- # 3)". Unfortunately, we'll currently think the parens are
- # necessary more often that they really are, because we don't
- # distinguish which side of an assignment we're on.
- if ($cx >= 5) {
- return "($name2 $args)";
- } else {
- return "$name2 $args";
- }
- } else {
- return $self->maybe_parens_func($name2, $args, $cx, 5);
- }
-
-}
-
-sub pp_prtf { indirop(@_, "printf") }
-sub pp_print { indirop(@_, "print") }
-sub pp_sort { indirop(@_, "sort") }
-
-sub mapop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- my($expr, @exprs);
- my $kid = $op->first; # this is the (map|grep)start
- $kid = $kid->first->sibling; # skip a pushmark
- my $code = $kid->first; # skip a null
- if (is_scope $code) {
- $code = "{" . $self->deparse($code, 0) . "} ";
- } else {
- $code = $self->deparse($code, 24) . ", ";
- }
- $kid = $kid->sibling;
- for (; !null($kid); $kid = $kid->sibling) {
- $expr = $self->deparse($kid, 6);
- push @exprs, $expr if defined $expr;
- }
- return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
-}
-
-sub pp_mapwhile { mapop(@_, "map") }
-sub pp_grepwhile { mapop(@_, "grep") }
-sub pp_mapstart { baseop(@_, "map") }
-sub pp_grepstart { baseop(@_, "grep") }
-
-sub pp_list {
- my $self = shift;
- my($op, $cx) = @_;
- my($expr, @exprs);
- my $kid = $op->first->sibling; # skip pushmark
- my $lop;
- my $local = "either"; # could be local(...), my(...) or our(...)
- for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
- # This assumes that no other private flags equal 128, and that
- # OPs that store things other than flags in their op_private,
- # like OP_AELEMFAST, won't be immediate children of a list.
- #
- # OP_ENTERSUB can break this logic, so check for it.
- # I suspect that open and exit can too.
-
- if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
- or $lop->name eq "undef")
- or $lop->name eq "entersub"
- or $lop->name eq "exit"
- or $lop->name eq "open")
- {
- $local = ""; # or not
- last;
- }
- if ($lop->name =~ /^pad[ash]v$/) { # my()
- ($local = "", last) if $local eq "local" || $local eq "our";
- $local = "my";
- } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
- && $lop->private & OPpOUR_INTRO
- or $lop->name eq "null" && $lop->first->name eq "gvsv"
- && $lop->first->private & OPpOUR_INTRO) { # our()
- ($local = "", last) if $local eq "my" || $local eq "local";
- $local = "our";
- } elsif ($lop->name ne "undef"
- # specifically avoid the "reverse sort" optimisation,
- # where "reverse" is nullified
- && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
- {
- # local()
- ($local = "", last) if $local eq "my" || $local eq "our";
- $local = "local";
- }
- }
- $local = "" if $local eq "either"; # no point if it's all undefs
- return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
- for (; !null($kid); $kid = $kid->sibling) {
- if ($local) {
- if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
- $lop = $kid->first;
- } else {
- $lop = $kid;
- }
- $self->{'avoid_local'}{$$lop}++;
- $expr = $self->deparse($kid, 6);
- delete $self->{'avoid_local'}{$$lop};
- } else {
- $expr = $self->deparse($kid, 6);
- }
- push @exprs, $expr;
- }
- if ($local) {
- return "$local(" . join(", ", @exprs) . ")";
- } else {
- return $self->maybe_parens( join(", ", @exprs), $cx, 6);
- }
-}
-
-sub is_ifelse_cont {
- my $op = shift;
- return ($op->name eq "null" and class($op) eq "UNOP"
- and $op->first->name =~ /^(and|cond_expr)$/
- and is_scope($op->first->first->sibling));
-}
-
-sub pp_cond_expr {
- my $self = shift;
- my($op, $cx) = @_;
- my $cond = $op->first;
- my $true = $cond->sibling;
- my $false = $true->sibling;
- my $cuddle = $self->{'cuddle'};
- unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
- (is_scope($false) || is_ifelse_cont($false))
- and $self->{'expand'} < 7) {
- $cond = $self->deparse($cond, 8);
- $true = $self->deparse($true, 8);
- $false = $self->deparse($false, 8);
- return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
- }
-
- $cond = $self->deparse($cond, 1);
- $true = $self->deparse($true, 0);
- my $head = "if ($cond) {\n\t$true\n\b}";
- my @elsifs;
- while (!null($false) and is_ifelse_cont($false)) {
- my $newop = $false->first;
- my $newcond = $newop->first;
- my $newtrue = $newcond->sibling;
- $false = $newtrue->sibling; # last in chain is OP_AND => no else
- $newcond = $self->deparse($newcond, 1);
- $newtrue = $self->deparse($newtrue, 0);
- push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
- }
- if (!null($false)) {
- $false = $cuddle . "else {\n\t" .
- $self->deparse($false, 0) . "\n\b}\cK";
- } else {
- $false = "\cK";
- }
- return $head . join($cuddle, "", @elsifs) . $false;
-}
-
-sub loop_common {
- my $self = shift;
- my($op, $cx, $init) = @_;
- my $enter = $op->first;
- my $kid = $enter->sibling;
- local(@$self{qw'curstash warnings hints'})
- = @$self{qw'curstash warnings hints'};
- my $head = "";
- my $bare = 0;
- my $body;
- my $cond = undef;
- if ($kid->name eq "lineseq") { # bare or infinite loop
- if ($kid->last->name eq "unstack") { # infinite
- $head = "while (1) "; # Can't use for(;;) if there's a continue
- $cond = "";
- } else {
- $bare = 1;
- }
- $body = $kid;
- } elsif ($enter->name eq "enteriter") { # foreach
- my $ary = $enter->first->sibling; # first was pushmark
- my $var = $ary->sibling;
- if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
- # "reverse" was optimised away
- $ary = listop($self, $ary->first->sibling, 1, 'reverse');
- } elsif ($enter->flags & OPf_STACKED
- and not null $ary->first->sibling->sibling)
- {
- $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
- $self->deparse($ary->first->sibling->sibling, 9);
- } else {
- $ary = $self->deparse($ary, 1);
- }
- if (null $var) {
- if ($enter->flags & OPf_SPECIAL) { # thread special var
- $var = $self->pp_threadsv($enter, 1);
- } else { # regular my() variable
- $var = $self->pp_padsv($enter, 1);
- }
- } elsif ($var->name eq "rv2gv") {
- $var = $self->pp_rv2sv($var, 1);
- if ($enter->private & OPpOUR_INTRO) {
- # our declarations don't have package names
- $var =~ s/^(.).*::/$1/;
- $var = "our $var";
- }
- } elsif ($var->name eq "gv") {
- $var = "\$" . $self->deparse($var, 1);
- }
- $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
- if (!is_state $body->first and $body->first->name ne "stub") {
- confess unless $var eq '$_';
- $body = $body->first;
- return $self->deparse($body, 2) . " foreach ($ary)";
- }
- $head = "foreach $var ($ary) ";
- } elsif ($kid->name eq "null") { # while/until
- $kid = $kid->first;
- my $name = {"and" => "while", "or" => "until"}->{$kid->name};
- $cond = $self->deparse($kid->first, 1);
- $head = "$name ($cond) ";
- $body = $kid->first->sibling;
- } elsif ($kid->name eq "stub") { # bare and empty
- return "{;}"; # {} could be a hashref
- }
- # If there isn't a continue block, then the next pointer for the loop
- # will point to the unstack, which is kid's last child, except
- # in a bare loop, when it will point to the leaveloop. When neither of
- # these conditions hold, then the second-to-last child is the continue
- # block (or the last in a bare loop).
- my $cont_start = $enter->nextop;
- my $cont;
- if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
- if ($bare) {
- $cont = $body->last;
- } else {
- $cont = $body->first;
- while (!null($cont->sibling->sibling)) {
- $cont = $cont->sibling;
- }
- }
- my $state = $body->first;
- my $cuddle = $self->{'cuddle'};
- my @states;
- for (; $$state != $$cont; $state = $state->sibling) {
- push @states, $state;
- }
- $body = $self->lineseq(undef, @states);
- if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
- $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
- $cont = "\cK";
- } else {
- $cont = $cuddle . "continue {\n\t" .
- $self->deparse($cont, 0) . "\n\b}\cK";
- }
- } else {
- return "" if !defined $body;
- if (length $init) {
- $head = "for ($init; $cond;) ";
- }
- $cont = "\cK";
- $body = $self->deparse($body, 0);
- }
- $body =~ s/;?$/;\n/;
-
- return $head . "{\n\t" . $body . "\b}" . $cont;
-}
-
-sub pp_leaveloop { loop_common(@_, "") }
-
-sub for_loop {
- my $self = shift;
- my($op, $cx) = @_;
- my $init = $self->deparse($op, 1);
- return $self->loop_common($op->sibling->first->sibling, $cx, $init);
-}
-
-sub pp_leavetry {
- my $self = shift;
- return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
-}
-
-BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
-BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
-BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
-BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
-
-sub pp_null {
- my $self = shift;
- my($op, $cx) = @_;
- if (class($op) eq "OP") {
- # old value is lost
- return $self->{'ex_const'} if $op->targ == OP_CONST;
- } elsif ($op->first->name eq "pushmark") {
- return $self->pp_list($op, $cx);
- } elsif ($op->first->name eq "enter") {
- return $self->pp_leave($op, $cx);
- } elsif ($op->targ == OP_STRINGIFY) {
- return $self->dquote($op, $cx);
- } elsif (!null($op->first->sibling) and
- $op->first->sibling->name eq "readline" and
- $op->first->sibling->flags & OPf_STACKED) {
- return $self->maybe_parens($self->deparse($op->first, 7) . " = "
- . $self->deparse($op->first->sibling, 7),
- $cx, 7);
- } elsif (!null($op->first->sibling) and
- $op->first->sibling->name eq "trans" and
- $op->first->sibling->flags & OPf_STACKED) {
- return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
- . $self->deparse($op->first->sibling, 20),
- $cx, 20);
- } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
- return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
- } elsif (!null($op->first->sibling) and
- $op->first->sibling->name eq "null" and
- class($op->first->sibling) eq "UNOP" and
- $op->first->sibling->first->flags & OPf_STACKED and
- $op->first->sibling->first->name eq "rcatline") {
- return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
- . $self->deparse($op->first->sibling, 18),
- $cx, 18);
- } else {
- return $self->deparse($op->first, $cx);
- }
-}
-
-sub padname {
- my $self = shift;
- my $targ = shift;
- return $self->padname_sv($targ)->PVX;
-}
-
-sub padany {
- my $self = shift;
- my $op = shift;
- return substr($self->padname($op->targ), 1); # skip $/@/%
-}
-
-sub pp_padsv {
- my $self = shift;
- my($op, $cx) = @_;
- return $self->maybe_my($op, $cx, $self->padname($op->targ));
-}
-
-sub pp_padav { pp_padsv(@_) }
-sub pp_padhv { pp_padsv(@_) }
-
-my @threadsv_names;
-
-BEGIN {
- @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
- "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
- "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
- "!", "@");
-}
-
-sub pp_threadsv {
- my $self = shift;
- my($op, $cx) = @_;
- return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
-}
-
-sub gv_or_padgv {
- my $self = shift;
- my $op = shift;
- if (class($op) eq "PADOP") {
- return $self->padval($op->padix);
- } else { # class($op) eq "SVOP"
- return $op->gv;
- }
-}
-
-sub pp_gvsv {
- my $self = shift;
- my($op, $cx) = @_;
- my $gv = $self->gv_or_padgv($op);
- return $self->maybe_local($op, $cx, $self->stash_variable("\$",
- $self->gv_name($gv)));
-}
-
-sub pp_gv {
- my $self = shift;
- my($op, $cx) = @_;
- my $gv = $self->gv_or_padgv($op);
- return $self->gv_name($gv);
-}
-
-sub pp_aelemfast {
- my $self = shift;
- my($op, $cx) = @_;
- my $name;
- if ($op->flags & OPf_SPECIAL) { # optimised PADAV
- $name = $self->padname($op->targ);
- $name =~ s/^@/\$/;
- }
- else {
- my $gv = $self->gv_or_padgv($op);
- $name = $self->gv_name($gv);
- $name = $self->{'curstash'}."::$name"
- if $name !~ /::/ && $self->lex_in_scope('@'.$name);
- $name = '$' . $name;
- }
-
- return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
-}
-
-sub rv2x {
- my $self = shift;
- my($op, $cx, $type) = @_;
-
- if (class($op) eq 'NULL' || !$op->can("first")) {
- carp("Unexpected op in pp_rv2x");
- return 'XXX';
- }
- my $kid = $op->first;
- if ($kid->name eq "gv") {
- return $self->stash_variable($type, $self->deparse($kid, 0));
- } elsif (is_scalar $kid) {
- my $str = $self->deparse($kid, 0);
- if ($str =~ /^\$([^\w\d])\z/) {
- # "$$+" isn't a legal way to write the scalar dereference
- # of $+, since the lexer can't tell you aren't trying to
- # do something like "$$ + 1" to get one more than your
- # PID. Either "${$+}" or "$${+}" are workable
- # disambiguations, but if the programmer did the former,
- # they'd be in the "else" clause below rather than here.
- # It's not clear if this should somehow be unified with
- # the code in dq and re_dq that also adds lexer
- # disambiguation braces.
- $str = '$' . "{$1}"; #'
- }
- return $type . $str;
- } else {
- return $type . "{" . $self->deparse($kid, 0) . "}";
- }
-}
-
-sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
-sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
-sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
-
-# skip rv2av
-sub pp_av2arylen {
- my $self = shift;
- my($op, $cx) = @_;
- if ($op->first->name eq "padav") {
- return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
- } else {
- return $self->maybe_local($op, $cx,
- $self->rv2x($op->first, $cx, '$#'));
- }
-}
-
-# skip down to the old, ex-rv2cv
-sub pp_rv2cv {
- my ($self, $op, $cx) = @_;
- if (!null($op->first) && $op->first->name eq 'null' &&
- $op->first->targ eq OP_LIST)
- {
- return $self->rv2x($op->first->first->sibling, $cx, "&")
- }
- else {
- return $self->rv2x($op, $cx, "")
- }
-}
-
-sub list_const {
- my $self = shift;
- my($cx, @list) = @_;
- my @a = map $self->const($_, 6), @list;
- if (@a == 0) {
- return "()";
- } elsif (@a == 1) {
- return $a[0];
- } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
- # collapse (-1,0,1,2) into (-1..2)
- my ($s, $e) = @a[0,-1];
- my $i = $s;
- return $self->maybe_parens("$s..$e", $cx, 9)
- unless grep $i++ != $_, @a;
- }
- return $self->maybe_parens(join(", ", @a), $cx, 6);
-}
-
-sub pp_rv2av {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first;
- if ($kid->name eq "const") { # constant list
- my $av = $self->const_sv($kid);
- return $self->list_const($cx, $av->ARRAY);
- } else {
- return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
- }
- }
-
-sub is_subscriptable {
- my $op = shift;
- if ($op->name =~ /^[ahg]elem/) {
- return 1;
- } elsif ($op->name eq "entersub") {
- my $kid = $op->first;
- return 0 unless null $kid->sibling;
- $kid = $kid->first;
- $kid = $kid->sibling until null $kid->sibling;
- return 0 if is_scope($kid);
- $kid = $kid->first;
- return 0 if $kid->name eq "gv";
- return 0 if is_scalar($kid);
- return is_subscriptable($kid);
- } else {
- return 0;
- }
-}
-
-sub elem {
- my $self = shift;
- my ($op, $cx, $left, $right, $padname) = @_;
- my($array, $idx) = ($op->first, $op->first->sibling);
- unless ($array->name eq $padname) { # Maybe this has been fixed
- $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
- }
- if ($array->name eq $padname) {
- $array = $self->padany($array);
- } elsif (is_scope($array)) { # ${expr}[0]
- $array = "{" . $self->deparse($array, 0) . "}";
- } elsif ($array->name eq "gv") {
- $array = $self->gv_name($self->gv_or_padgv($array));
- if ($array !~ /::/) {
- my $prefix = ($left eq '[' ? '@' : '%');
- $array = $self->{curstash}.'::'.$array
- if $self->lex_in_scope($prefix . $array);
- }
- } elsif (is_scalar $array) { # $x[0], $$x[0], ...
- $array = $self->deparse($array, 24);
- } else {
- # $x[20][3]{hi} or expr->[20]
- my $arrow = is_subscriptable($array) ? "" : "->";
- return $self->deparse($array, 24) . $arrow .
- $left . $self->deparse($idx, 1) . $right;
- }
- $idx = $self->deparse($idx, 1);
-
- # Outer parens in an array index will confuse perl
- # if we're interpolating in a regular expression, i.e.
- # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
- #
- # If $self->{parens}, then an initial '(' will
- # definitely be paired with a final ')'. If
- # !$self->{parens}, the misleading parens won't
- # have been added in the first place.
- #
- # [You might think that we could get "(...)...(...)"
- # where the initial and final parens do not match
- # each other. But we can't, because the above would
- # only happen if there's an infix binop between the
- # two pairs of parens, and *that* means that the whole
- # expression would be parenthesized as well.]
- #
- $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
-
- # Hash-element braces will autoquote a bareword inside themselves.
- # We need to make sure that C<$hash{warn()}> doesn't come out as
- # C<$hash{warn}>, which has a quite different meaning. Currently
- # B::Deparse will always quote strings, even if the string was a
- # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
- # for constant strings.) So we can cheat slightly here - if we see
- # a bareword, we know that it is supposed to be a function call.
- #
- $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
-
- return "\$" . $array . $left . $idx . $right;
-}
-
-sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
-sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
-
-sub pp_gelem {
- my $self = shift;
- my($op, $cx) = @_;
- my($glob, $part) = ($op->first, $op->last);
- $glob = $glob->first; # skip rv2gv
- $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
- my $scope = is_scope($glob);
- $glob = $self->deparse($glob, 0);
- $part = $self->deparse($part, 1);
- return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
-}
-
-sub slice {
- my $self = shift;
- my ($op, $cx, $left, $right, $regname, $padname) = @_;
- my $last;
- my(@elems, $kid, $array, $list);
- if (class($op) eq "LISTOP") {
- $last = $op->last;
- } else { # ex-hslice inside delete()
- for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
- $last = $kid;
- }
- $array = $last;
- $array = $array->first
- if $array->name eq $regname or $array->name eq "null";
- if (is_scope($array)) {
- $array = "{" . $self->deparse($array, 0) . "}";
- } elsif ($array->name eq $padname) {
- $array = $self->padany($array);
- } else {
- $array = $self->deparse($array, 24);
- }
- $kid = $op->first->sibling; # skip pushmark
- if ($kid->name eq "list") {
- $kid = $kid->first->sibling; # skip list, pushmark
- for (; !null $kid; $kid = $kid->sibling) {
- push @elems, $self->deparse($kid, 6);
- }
- $list = join(", ", @elems);
- } else {
- $list = $self->deparse($kid, 1);
- }
- return "\@" . $array . $left . $list . $right;
-}
-
-sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
-sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
-
-sub pp_lslice {
- my $self = shift;
- my($op, $cx) = @_;
- my $idx = $op->first;
- my $list = $op->last;
- my(@elems, $kid);
- $list = $self->deparse($list, 1);
- $idx = $self->deparse($idx, 1);
- return "($list)" . "[$idx]";
-}
-
-sub want_scalar {
- my $op = shift;
- return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
-}
-
-sub want_list {
- my $op = shift;
- return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
-}
-
-sub method {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first->sibling; # skip pushmark
- my($meth, $obj, @exprs);
- if ($kid->name eq "list" and want_list $kid) {
- # When an indirect object isn't a bareword but the args are in
- # parens, the parens aren't part of the method syntax (the LLAFR
- # doesn't apply), but they make a list with OPf_PARENS set that
- # doesn't get flattened by the append_elem that adds the method,
- # making a (object, arg1, arg2, ...) list where the object
- # usually is. This can be distinguished from
- # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
- # object) because in the later the list is in scalar context
- # as the left side of -> always is, while in the former
- # the list is in list context as method arguments always are.
- # (Good thing there aren't method prototypes!)
- $meth = $kid->sibling;
- $kid = $kid->first->sibling; # skip pushmark
- $obj = $kid;
- $kid = $kid->sibling;
- for (; not null $kid; $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
- }
- } else {
- $obj = $kid;
- $kid = $kid->sibling;
- for (; !null ($kid->sibling) && $kid->name ne "method_named";
- $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
- }
- $meth = $kid;
- }
- $obj = $self->deparse($obj, 24);
- if ($meth->name eq "method_named") {
- $meth = $self->const_sv($meth)->PV;
- } else {
- $meth = $meth->first;
- if ($meth->name eq "const") {
- # As of 5.005_58, this case is probably obsoleted by the
- # method_named case above
- $meth = $self->const_sv($meth)->PV; # needs to be bare
- } else {
- $meth = $self->deparse($meth, 1);
- }
- }
- my $args = join(", ", @exprs);
- $kid = $obj . "->" . $meth;
- if (length $args) {
- return $kid . "(" . $args . ")"; # parens mandatory
- } else {
- return $kid;
- }
-}
-
-# returns "&" if the prototype doesn't match the args,
-# or ("", $args_after_prototype_demunging) if it does.
-sub check_proto {
- my $self = shift;
- return "&" if $self->{'noproto'};
- my($proto, @args) = @_;
- my($arg, $real);
- my $doneok = 0;
- my @reals;
- # An unbackslashed @ or % gobbles up the rest of the args
- 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
- while ($proto) {
- $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
- my $chr = $1;
- if ($chr eq "") {
- return "&" if @args;
- } elsif ($chr eq ";") {
- $doneok = 1;
- } elsif ($chr eq "@" or $chr eq "%") {
- push @reals, map($self->deparse($_, 6), @args);
- @args = ();
- } else {
- $arg = shift @args;
- last unless $arg;
- if ($chr eq "\$") {
- if (want_scalar $arg) {
- push @reals, $self->deparse($arg, 6);
- } else {
- return "&";
- }
- } elsif ($chr eq "&") {
- if ($arg->name =~ /^(s?refgen|undef)$/) {
- push @reals, $self->deparse($arg, 6);
- } else {
- return "&";
- }
- } elsif ($chr eq "*") {
- if ($arg->name =~ /^s?refgen$/
- and $arg->first->first->name eq "rv2gv")
- {
- $real = $arg->first->first; # skip refgen, null
- if ($real->first->name eq "gv") {
- push @reals, $self->deparse($real, 6);
- } else {
- push @reals, $self->deparse($real->first, 6);
- }
- } else {
- return "&";
- }
- } elsif (substr($chr, 0, 1) eq "\\") {
- $chr =~ tr/\\[]//d;
- if ($arg->name =~ /^s?refgen$/ and
- !null($real = $arg->first) and
- ($chr =~ /\$/ && is_scalar($real->first)
- or ($chr =~ /@/
- && class($real->first->sibling) ne 'NULL'
- && $real->first->sibling->name
- =~ /^(rv2|pad)av$/)
- or ($chr =~ /%/
- && class($real->first->sibling) ne 'NULL'
- && $real->first->sibling->name
- =~ /^(rv2|pad)hv$/)
- #or ($chr =~ /&/ # This doesn't work
- # && $real->first->name eq "rv2cv")
- or ($chr =~ /\*/
- && $real->first->name eq "rv2gv")))
- {
- push @reals, $self->deparse($real, 6);
- } else {
- return "&";
- }
- }
- }
- }
- return "&" if $proto and !$doneok; # too few args and no `;'
- return "&" if @args; # too many args
- return ("", join ", ", @reals);
-}
-
-sub pp_entersub {
- my $self = shift;
- my($op, $cx) = @_;
- return $self->method($op, $cx) unless null $op->first->sibling;
- my $prefix = "";
- my $amper = "";
- my($kid, @exprs);
- if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
- $prefix = "do ";
- } elsif ($op->private & OPpENTERSUB_AMPER) {
- $amper = "&";
- }
- $kid = $op->first;
- $kid = $kid->first->sibling; # skip ex-list, pushmark
- for (; not null $kid->sibling; $kid = $kid->sibling) {
- push @exprs, $kid;
- }
- my $simple = 0;
- my $proto = undef;
- if (is_scope($kid)) {
- $amper = "&";
- $kid = "{" . $self->deparse($kid, 0) . "}";
- } elsif ($kid->first->name eq "gv") {
- my $gv = $self->gv_or_padgv($kid->first);
- if (class($gv->CV) ne "SPECIAL") {
- $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
- }
- $simple = 1; # only calls of named functions can be prototyped
- $kid = $self->deparse($kid, 24);
- } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
- $amper = "&";
- $kid = $self->deparse($kid, 24);
- } else {
- $prefix = "";
- my $arrow = is_subscriptable($kid->first) ? "" : "->";
- $kid = $self->deparse($kid, 24) . $arrow;
- }
-
- # Doesn't matter how many prototypes there are, if
- # they haven't happened yet!
- my $declared;
- {
- no strict 'refs';
- no warnings 'uninitialized';
- $declared = exists $self->{'subs_declared'}{$kid}
- || (
- defined &{ ${$self->{'curstash'}."::"}{$kid} }
- && !exists
- $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
- && defined prototype $self->{'curstash'}."::".$kid
- );
- if (!$declared && defined($proto)) {
- # Avoid "too early to check prototype" warning
- ($amper, $proto) = ('&');
- }
- }
-
- my $args;
- if ($declared and defined $proto and not $amper) {
- ($amper, $args) = $self->check_proto($proto, @exprs);
- if ($amper eq "&") {
- $args = join(", ", map($self->deparse($_, 6), @exprs));
- }
- } else {
- $args = join(", ", map($self->deparse($_, 6), @exprs));
- }
- if ($prefix or $amper) {
- if ($op->flags & OPf_STACKED) {
- return $prefix . $amper . $kid . "(" . $args . ")";
- } else {
- return $prefix . $amper. $kid;
- }
- } else {
- # glob() invocations can be translated into calls of
- # CORE::GLOBAL::glob with a second parameter, a number.
- # Reverse this.
- if ($kid eq "CORE::GLOBAL::glob") {
- $kid = "glob";
- $args =~ s/\s*,[^,]+$//;
- }
-
- # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
- # so it must have been translated from a keyword call. Translate
- # it back.
- $kid =~ s/^CORE::GLOBAL:://;
-
- my $dproto = defined($proto) ? $proto : "undefined";
- if (!$declared) {
- return "$kid(" . $args . ")";
- } elsif ($dproto eq "") {
- return $kid;
- } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
- # is_scalar is an excessively conservative test here:
- # really, we should be comparing to the precedence of the
- # top operator of $exprs[0] (ala unop()), but that would
- # take some major code restructuring to do right.
- return $self->maybe_parens_func($kid, $args, $cx, 16);
- } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
- return $self->maybe_parens_func($kid, $args, $cx, 5);
- } else {
- return "$kid(" . $args . ")";
- }
- }
-}
-
-sub pp_enterwrite { unop(@_, "write") }
-
-# escape things that cause interpolation in double quotes,
-# but not character escapes
-sub uninterp {
- my($str) = @_;
- $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
- return $str;
-}
-
-{
-my $bal;
-BEGIN {
- use re "eval";
- # Matches any string which is balanced with respect to {braces}
- $bal = qr(
- (?:
- [^\\{}]
- | \\\\
- | \\[{}]
- | \{(??{$bal})\}
- )*
- )x;
-}
-
-# the same, but treat $|, $), $( and $ at the end of the string differently
-sub re_uninterp {
- my($str) = @_;
-
- $str =~ s/
- ( ^|\G # $1
- | [^\\]
- )
-
- ( # $2
- (?:\\\\)*
- )
-
- ( # $3
- (\(\?\??\{$bal\}\)) # $4
- | [\$\@]
- (?!\||\)|\(|$)
- | \\[uUlLQE]
- )
-
- /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
-
- return $str;
-}
-
-# This is for regular expressions with the /x modifier
-# We have to leave comments unmangled.
-sub re_uninterp_extended {
- my($str) = @_;
-
- $str =~ s/
- ( ^|\G # $1
- | [^\\]
- )
-
- ( # $2
- (?:\\\\)*
- )
-
- ( # $3
- ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
- | \#[^\n]* # (skip over comments)
- )
- | [\$\@]
- (?!\||\)|\(|$|\s)
- | \\[uUlLQE]
- )
-
- /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
-
- return $str;
-}
-}
-
-my %unctrl = # portable to to EBCDIC
- (
- "\c@" => '\c@', # unused
- "\cA" => '\cA',
- "\cB" => '\cB',
- "\cC" => '\cC',
- "\cD" => '\cD',
- "\cE" => '\cE',
- "\cF" => '\cF',
- "\cG" => '\cG',
- "\cH" => '\cH',
- "\cI" => '\cI',
- "\cJ" => '\cJ',
- "\cK" => '\cK',
- "\cL" => '\cL',
- "\cM" => '\cM',
- "\cN" => '\cN',
- "\cO" => '\cO',
- "\cP" => '\cP',
- "\cQ" => '\cQ',
- "\cR" => '\cR',
- "\cS" => '\cS',
- "\cT" => '\cT',
- "\cU" => '\cU',
- "\cV" => '\cV',
- "\cW" => '\cW',
- "\cX" => '\cX',
- "\cY" => '\cY',
- "\cZ" => '\cZ',
- "\c[" => '\c[', # unused
- "\c\\" => '\c\\', # unused
- "\c]" => '\c]', # unused
- "\c_" => '\c_', # unused
- );
-
-# character escapes, but not delimiters that might need to be escaped
-sub escape_str { # ASCII, UTF8
- my($str) = @_;
- $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
- $str =~ s/\a/\\a/g;
-# $str =~ s/\cH/\\b/g; # \b means something different in a regex
- $str =~ s/\t/\\t/g;
- $str =~ s/\n/\\n/g;
- $str =~ s/\e/\\e/g;
- $str =~ s/\f/\\f/g;
- $str =~ s/\r/\\r/g;
- $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
- $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
- return $str;
-}
-
-# For regexes with the /x modifier.
-# Leave whitespace unmangled.
-sub escape_extended_re {
- my($str) = @_;
- $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
- $str =~ s/([[:^print:]])/
- ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
- $str =~ s/\n/\n\f/g;
- return $str;
-}
-
-# Don't do this for regexen
-sub unback {
- my($str) = @_;
- $str =~ s/\\/\\\\/g;
- return $str;
-}
-
-# Remove backslashes which precede literal control characters,
-# to avoid creating ambiguity when we escape the latter.
-sub re_unback {
- my($str) = @_;
-
- # the insane complexity here is due to the behaviour of "\c\"
- $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
- return $str;
-}
-
-sub balanced_delim {
- my($str) = @_;
- my @str = split //, $str;
- my($ar, $open, $close, $fail, $c, $cnt);
- for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
- ($open, $close) = @$ar;
- $fail = 0; $cnt = 0;
- for $c (@str) {
- if ($c eq $open) {
- $cnt++;
- } elsif ($c eq $close) {
- $cnt--;
- if ($cnt < 0) {
- # qq()() isn't ")("
- $fail = 1;
- last;
- }
- }
- }
- $fail = 1 if $cnt != 0;
- return ($open, "$open$str$close") if not $fail;
- }
- return ("", $str);
-}
-
-sub single_delim {
- my($q, $default, $str) = @_;
- return "$default$str$default" if $default and index($str, $default) == -1;
- if ($q ne 'qr') {
- (my $succeed, $str) = balanced_delim($str);
- return "$q$str" if $succeed;
- }
- for my $delim ('/', '"', '#') {
- return "$q$delim" . $str . $delim if index($str, $delim) == -1;
- }
- if ($default) {
- $str =~ s/$default/\\$default/g;
- return "$default$str$default";
- } else {
- $str =~ s[/][\\/]g;
- return "$q/$str/";
- }
-}
-
-my $max_prec;
-BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
-
-# Split a floating point number into an integer mantissa and a binary
-# exponent. Assumes you've already made sure the number isn't zero or
-# some weird infinity or NaN.
-sub split_float {
- my($f) = @_;
- my $exponent = 0;
- if ($f == int($f)) {
- while ($f % 2 == 0) {
- $f /= 2;
- $exponent++;
- }
- } else {
- while ($f != int($f)) {
- $f *= 2;
- $exponent--;
- }
- }
- my $mantissa = sprintf("%.0f", $f);
- return ($mantissa, $exponent);
-}
-
-sub const {
- my $self = shift;
- my($sv, $cx) = @_;
- if ($self->{'use_dumper'}) {
- return $self->const_dumper($sv, $cx);
- }
- if (class($sv) eq "SPECIAL") {
- # sv_undef, sv_yes, sv_no
- return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
- } elsif (class($sv) eq "NULL") {
- return 'undef';
- }
- # convert a version object into the "v1.2.3" string in its V magic
- if ($sv->FLAGS & SVs_RMG) {
- for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
- return $mg->PTR if $mg->TYPE eq 'V';
- }
- }
-
- if ($sv->FLAGS & SVf_IOK) {
- my $str = $sv->int_value;
- $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
- return $str;
- } elsif ($sv->FLAGS & SVf_NOK) {
- my $nv = $sv->NV;
- if ($nv == 0) {
- if (pack("F", $nv) eq pack("F", 0)) {
- # positive zero
- return "0";
- } else {
- # negative zero
- return $self->maybe_parens("-.0", $cx, 21);
- }
- } elsif (1/$nv == 0) {
- if ($nv > 0) {
- # positive infinity
- return $self->maybe_parens("9**9**9", $cx, 22);
- } else {
- # negative infinity
- return $self->maybe_parens("-9**9**9", $cx, 21);
- }
- } elsif ($nv != $nv) {
- # NaN
- if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
- # the normal kind
- return "sin(9**9**9)";
- } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
- # the inverted kind
- return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
- } else {
- # some other kind
- my $hex = unpack("h*", pack("F", $nv));
- return qq'unpack("F", pack("h*", "$hex"))';
- }
- }
- # first, try the default stringification
- my $str = "$nv";
- if ($str != $nv) {
- # failing that, try using more precision
- $str = sprintf("%.${max_prec}g", $nv);
-# if (pack("F", $str) ne pack("F", $nv)) {
- if ($str != $nv) {
- # not representable in decimal with whatever sprintf()
- # and atof() Perl is using here.
- my($mant, $exp) = split_float($nv);
- return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
- }
- }
- $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
- return $str;
- } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
- my $ref = $sv->RV;
- if (class($ref) eq "AV") {
- return "[" . $self->list_const(2, $ref->ARRAY) . "]";
- } elsif (class($ref) eq "HV") {
- my %hash = $ref->ARRAY;
- my @elts;
- for my $k (sort keys %hash) {
- push @elts, "$k => " . $self->const($hash{$k}, 6);
- }
- return "{" . join(", ", @elts) . "}";
- } elsif (class($ref) eq "CV") {
- return "sub " . $self->deparse_sub($ref);
- }
- if ($ref->FLAGS & SVs_SMG) {
- for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
- if ($mg->TYPE eq 'r') {
- my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
- return single_delim("qr", "", $re);
- }
- }
- }
-
- return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
- } elsif ($sv->FLAGS & SVf_POK) {
- my $str = $sv->PV;
- if ($str =~ /[^ -~]/) { # ASCII for non-printing
- return single_delim("qq", '"', uninterp escape_str unback $str);
- } else {
- return single_delim("q", "'", unback $str);
- }
- } else {
- return "undef";
- }
-}
-
-sub const_dumper {
- my $self = shift;
- my($sv, $cx) = @_;
- my $ref = $sv->object_2svref();
- my $dumper = Data::Dumper->new([$$ref], ['$v']);
- $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
- my $str = $dumper->Dump();
- if ($str =~ /^\$v/) {
- return '${my ' . $str . ' \$v}';
- } else {
- return $str;
- }
-}
-
-sub const_sv {
- my $self = shift;
- my $op = shift;
- my $sv = $op->sv;
- # the constant could be in the pad (under useithreads)
- $sv = $self->padval($op->targ) unless $$sv;
- return $sv;
-}
-
-sub pp_const {
- my $self = shift;
- my($op, $cx) = @_;
- if ($op->private & OPpCONST_ARYBASE) {
- return '$[';
- }
-# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
-# return $self->const_sv($op)->PV;
-# }
- my $sv = $self->const_sv($op);
- return $self->const($sv, $cx);
-}
-
-sub dq {
- my $self = shift;
- my $op = shift;
- my $type = $op->name;
- if ($type eq "const") {
- return '$[' if $op->private & OPpCONST_ARYBASE;
- return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
- } elsif ($type eq "concat") {
- my $first = $self->dq($op->first);
- my $last = $self->dq($op->last);
-
- # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
- ($last =~ /^[A-Z\\\^\[\]_?]/ &&
- $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
- || ($last =~ /^[:'{\[\w_]/ && #'
- $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
-
- return $first . $last;
- } elsif ($type eq "uc") {
- return '\U' . $self->dq($op->first->sibling) . '\E';
- } elsif ($type eq "lc") {
- return '\L' . $self->dq($op->first->sibling) . '\E';
- } elsif ($type eq "ucfirst") {
- return '\u' . $self->dq($op->first->sibling);
- } elsif ($type eq "lcfirst") {
- return '\l' . $self->dq($op->first->sibling);
- } elsif ($type eq "quotemeta") {
- return '\Q' . $self->dq($op->first->sibling) . '\E';
- } elsif ($type eq "join") {
- return $self->deparse($op->last, 26); # was join($", @ary)
- } else {
- return $self->deparse($op, 26);
- }
-}
-
-sub pp_backtick {
- my $self = shift;
- my($op, $cx) = @_;
- # skip pushmark
- return single_delim("qx", '`', $self->dq($op->first->sibling));
-}
-
-sub dquote {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first->sibling; # skip ex-stringify, pushmark
- return $self->deparse($kid, $cx) if $self->{'unquote'};
- $self->maybe_targmy($kid, $cx,
- sub {single_delim("qq", '"', $self->dq($_[1]))});
-}
-
-# OP_STRINGIFY is a listop, but it only ever has one arg
-sub pp_stringify { maybe_targmy(@_, \&dquote) }
-
-# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
-# note that tr(from)/to/ is OK, but not tr/from/(to)
-sub double_delim {
- my($from, $to) = @_;
- my($succeed, $delim);
- if ($from !~ m[/] and $to !~ m[/]) {
- return "/$from/$to/";
- } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
- if (($succeed, $to) = balanced_delim($to) and $succeed) {
- return "$from$to";
- } else {
- for $delim ('/', '"', '#') { # note no `'' -- s''' is special
- return "$from$delim$to$delim" if index($to, $delim) == -1;
- }
- $to =~ s[/][\\/]g;
- return "$from/$to/";
- }
- } else {
- for $delim ('/', '"', '#') { # note no '
- return "$delim$from$delim$to$delim"
- if index($to . $from, $delim) == -1;
- }
- $from =~ s[/][\\/]g;
- $to =~ s[/][\\/]g;
- return "/$from/$to/";
- }
-}
-
-# Only used by tr///, so backslashes hyphens
-sub pchr { # ASCII
- my($n) = @_;
- if ($n == ord '\\') {
- return '\\\\';
- } elsif ($n == ord "-") {
- return "\\-";
- } elsif ($n >= ord(' ') and $n <= ord('~')) {
- return chr($n);
- } elsif ($n == ord "\a") {
- return '\\a';
- } elsif ($n == ord "\b") {
- return '\\b';
- } elsif ($n == ord "\t") {
- return '\\t';
- } elsif ($n == ord "\n") {
- return '\\n';
- } elsif ($n == ord "\e") {
- return '\\e';
- } elsif ($n == ord "\f") {
- return '\\f';
- } elsif ($n == ord "\r") {
- return '\\r';
- } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
- return '\\c' . chr(ord("@") + $n);
- } else {
-# return '\x' . sprintf("%02x", $n);
- return '\\' . sprintf("%03o", $n);
- }
-}
-
-sub collapse {
- my(@chars) = @_;
- my($str, $c, $tr) = ("");
- for ($c = 0; $c < @chars; $c++) {
- $tr = $chars[$c];
- $str .= pchr($tr);
- if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
- $chars[$c + 2] == $tr + 2)
- {
- for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
- {}
- $str .= "-";
- $str .= pchr($chars[$c]);
- }
- }
- return $str;
-}
-
-sub tr_decode_byte {
- my($table, $flags) = @_;
- my(@table) = unpack("s*", $table);
- splice @table, 0x100, 1; # Number of subsequent elements
- my($c, $tr, @from, @to, @delfrom, $delhyphen);
- if ($table[ord "-"] != -1 and
- $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
- {
- $tr = $table[ord "-"];
- $table[ord "-"] = -1;
- if ($tr >= 0) {
- @from = ord("-");
- @to = $tr;
- } else { # -2 ==> delete
- $delhyphen = 1;
- }
- }
- for ($c = 0; $c < @table; $c++) {
- $tr = $table[$c];
- if ($tr >= 0) {
- push @from, $c; push @to, $tr;
- } elsif ($tr == -2) {
- push @delfrom, $c;
- }
- }
- @from = (@from, @delfrom);
- if ($flags & OPpTRANS_COMPLEMENT) {
- my @newfrom = ();
- my %from;
- @from{@from} = (1) x @from;
- for ($c = 0; $c < 256; $c++) {
- push @newfrom, $c unless $from{$c};
- }
- @from = @newfrom;
- }
- unless ($flags & OPpTRANS_DELETE || !@to) {
- pop @to while $#to and $to[$#to] == $to[$#to -1];
- }
- my($from, $to);
- $from = collapse(@from);
- $to = collapse(@to);
- $from .= "-" if $delhyphen;
- return ($from, $to);
-}
-
-sub tr_chr {
- my $x = shift;
- if ($x == ord "-") {
- return "\\-";
- } elsif ($x == ord "\\") {
- return "\\\\";
- } else {
- return chr $x;
- }
-}
-
-# XXX This doesn't yet handle all cases correctly either
-
-sub tr_decode_utf8 {
- my($swash_hv, $flags) = @_;
- my %swash = $swash_hv->ARRAY;
- my $final = undef;
- $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
- my $none = $swash{"NONE"}->IV;
- my $extra = $none + 1;
- my(@from, @delfrom, @to);
- my $line;
- foreach $line (split /\n/, $swash{'LIST'}->PV) {
- my($min, $max, $result) = split(/\t/, $line);
- $min = hex $min;
- if (length $max) {
- $max = hex $max;
- } else {
- $max = $min;
- }
- $result = hex $result;
- if ($result == $extra) {
- push @delfrom, [$min, $max];
- } else {
- push @from, [$min, $max];
- push @to, [$result, $result + $max - $min];
- }
- }
- for my $i (0 .. $#from) {
- if ($from[$i][0] == ord '-') {
- unshift @from, splice(@from, $i, 1);
- unshift @to, splice(@to, $i, 1);
- last;
- } elsif ($from[$i][1] == ord '-') {
- $from[$i][1]--;
- $to[$i][1]--;
- unshift @from, ord '-';
- unshift @to, ord '-';
- last;
- }
- }
- for my $i (0 .. $#delfrom) {
- if ($delfrom[$i][0] == ord '-') {
- push @delfrom, splice(@delfrom, $i, 1);
- last;
- } elsif ($delfrom[$i][1] == ord '-') {
- $delfrom[$i][1]--;
- push @delfrom, ord '-';
- last;
- }
- }
- if (defined $final and $to[$#to][1] != $final) {
- push @to, [$final, $final];
- }
- push @from, @delfrom;
- if ($flags & OPpTRANS_COMPLEMENT) {
- my @newfrom;
- my $next = 0;
- for my $i (0 .. $#from) {
- push @newfrom, [$next, $from[$i][0] - 1];
- $next = $from[$i][1] + 1;
- }
- @from = ();
- for my $range (@newfrom) {
- if ($range->[0] <= $range->[1]) {
- push @from, $range;
- }
- }
- }
- my($from, $to, $diff);
- for my $chunk (@from) {
- $diff = $chunk->[1] - $chunk->[0];
- if ($diff > 1) {
- $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
- } elsif ($diff == 1) {
- $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
- } else {
- $from .= tr_chr($chunk->[0]);
- }
- }
- for my $chunk (@to) {
- $diff = $chunk->[1] - $chunk->[0];
- if ($diff > 1) {
- $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
- } elsif ($diff == 1) {
- $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
- } else {
- $to .= tr_chr($chunk->[0]);
- }
- }
- #$final = sprintf("%04x", $final) if defined $final;
- #$none = sprintf("%04x", $none) if defined $none;
- #$extra = sprintf("%04x", $extra) if defined $extra;
- #print STDERR "final: $final\n none: $none\nextra: $extra\n";
- #print STDERR $swash{'LIST'}->PV;
- return (escape_str($from), escape_str($to));
-}
-
-sub pp_trans {
- my $self = shift;
- my($op, $cx) = @_;
- my($from, $to);
- if (class($op) eq "PVOP") {
- ($from, $to) = tr_decode_byte($op->pv, $op->private);
- } else { # class($op) eq "SVOP"
- ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
- }
- my $flags = "";
- $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
- $flags .= "d" if $op->private & OPpTRANS_DELETE;
- $to = "" if $from eq $to and $flags eq "";
- $flags .= "s" if $op->private & OPpTRANS_SQUASH;
- return "tr" . double_delim($from, $to) . $flags;
-}
-
-# Like dq(), but different
-sub re_dq {
- my $self = shift;
- my ($op, $extended) = @_;
-
- my $type = $op->name;
- if ($type eq "const") {
- return '$[' if $op->private & OPpCONST_ARYBASE;
- my $unbacked = re_unback($self->const_sv($op)->as_string);
- return re_uninterp_extended(escape_extended_re($unbacked))
- if $extended;
- return re_uninterp(escape_str($unbacked));
- } elsif ($type eq "concat") {
- my $first = $self->re_dq($op->first, $extended);
- my $last = $self->re_dq($op->last, $extended);
-
- # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
- ($last =~ /^[A-Z\\\^\[\]_?]/ &&
- $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
- || ($last =~ /^[{\[\w_]/ &&
- $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
-
- return $first . $last;
- } elsif ($type eq "uc") {
- return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
- } elsif ($type eq "lc") {
- return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
- } elsif ($type eq "ucfirst") {
- return '\u' . $self->re_dq($op->first->sibling, $extended);
- } elsif ($type eq "lcfirst") {
- return '\l' . $self->re_dq($op->first->sibling, $extended);
- } elsif ($type eq "quotemeta") {
- return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
- } elsif ($type eq "join") {
- return $self->deparse($op->last, 26); # was join($", @ary)
- } else {
- return $self->deparse($op, 26);
- }
-}
-
-sub pure_string {
- my ($self, $op) = @_;
- return 0 if null $op;
- my $type = $op->name;
-
- if ($type eq 'const') {
- return 1;
- }
- elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
- return $self->pure_string($op->first->sibling);
- }
- elsif ($type eq 'join') {
- my $join_op = $op->first->sibling; # Skip pushmark
- return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
-
- my $gvop = $join_op->first;
- return 0 unless $gvop->name eq 'gvsv';
- return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
-
- return 0 unless ${$join_op->sibling} eq ${$op->last};
- return 0 unless $op->last->name =~ /^(rv2|pad)av$/;
- }
- elsif ($type eq 'concat') {
- return $self->pure_string($op->first)
- && $self->pure_string($op->last);
- }
- elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
- return 1;
- }
- elsif ($type eq "null" and $op->can('first') and not null $op->first and
- $op->first->name eq "null" and $op->first->can('first')
- and not null $op->first->first and
- $op->first->first->name eq "aelemfast") {
- return 1;
- }
- else {
- return 0;
- }
-
- return 1;
-}
-
-sub regcomp {
- my $self = shift;
- my($op, $cx, $extended) = @_;
- my $kid = $op->first;
- $kid = $kid->first if $kid->name eq "regcmaybe";
- $kid = $kid->first if $kid->name eq "regcreset";
- if ($kid->name eq "null" and !null($kid->first)
- and $kid->first->name eq 'pushmark')
- {
- my $str = '';
- $kid = $kid->first->sibling;
- while (!null($kid)) {
- $str .= $self->re_dq($kid, $extended);
- $kid = $kid->sibling;
- }
- return $str, 1;
- }
-
- return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
- return ($self->deparse($kid, $cx), 0);
-}
-
-sub pp_regcomp {
- my ($self, $op, $cx) = @_;
- return (($self->regcomp($op, $cx, 0))[0]);
-}
-
-# osmic acid -- see osmium tetroxide
-
-my %matchwords;
-map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
- 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
- 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
-
-sub matchop {
- my $self = shift;
- my($op, $cx, $name, $delim) = @_;
- my $kid = $op->first;
- my ($binop, $var, $re) = ("", "", "");
- if ($op->flags & OPf_STACKED) {
- $binop = 1;
- $var = $self->deparse($kid, 20);
- $kid = $kid->sibling;
- }
- my $quote = 1;
- my $extended = ($op->pmflags & PMf_EXTENDED);
- if (null $kid) {
- my $unbacked = re_unback($op->precomp);
- if ($extended) {
- $re = re_uninterp_extended(escape_extended_re($unbacked));
- } else {
- $re = re_uninterp(escape_str(re_unback($op->precomp)));
- }
- } elsif ($kid->name ne 'regcomp') {
- carp("found ".$kid->name." where regcomp expected");
- } else {
- ($re, $quote) = $self->regcomp($kid, 21, $extended);
- }
- my $flags = "";
- $flags .= "c" if $op->pmflags & PMf_CONTINUE;
- $flags .= "g" if $op->pmflags & PMf_GLOBAL;
- $flags .= "i" if $op->pmflags & PMf_FOLD;
- $flags .= "m" if $op->pmflags & PMf_MULTILINE;
- $flags .= "o" if $op->pmflags & PMf_KEEP;
- $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
- $flags .= "x" if $op->pmflags & PMf_EXTENDED;
- $flags = $matchwords{$flags} if $matchwords{$flags};
- if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
- $re =~ s/\?/\\?/g;
- $re = "?$re?";
- } elsif ($quote) {
- $re = single_delim($name, $delim, $re);
- }
- $re = $re . $flags if $quote;
- if ($binop) {
- return $self->maybe_parens("$var =~ $re", $cx, 20);
- } else {
- return $re;
- }
-}
-
-sub pp_match { matchop(@_, "m", "/") }
-sub pp_pushre { matchop(@_, "m", "/") }
-sub pp_qr { matchop(@_, "qr", "") }
-
-sub pp_split {
- my $self = shift;
- my($op, $cx) = @_;
- my($kid, @exprs, $ary, $expr);
- $kid = $op->first;
-
- # For our kid (an OP_PUSHRE), pmreplroot is never actually the
- # root of a replacement; it's either empty, or abused to point to
- # the GV for an array we split into (an optimization to save
- # assignment overhead). Depending on whether we're using ithreads,
- # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
- # figures out for us which it is.
- my $replroot = $kid->pmreplroot;
- my $gv = 0;
- if (ref($replroot) eq "B::GV") {
- $gv = $replroot;
- } elsif (!ref($replroot) and $replroot > 0) {
- $gv = $self->padval($replroot);
- }
- $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
-
- for (; !null($kid); $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
- }
-
- # handle special case of split(), and split(" ") that compiles to /\s+/
- $kid = $op->first;
- if ($kid->flags & OPf_SPECIAL
- && $exprs[0] eq '/\\s+/'
- && $kid->pmflags & PMf_SKIPWHITE ) {
- $exprs[0] = '" "';
- }
-
- $expr = "split(" . join(", ", @exprs) . ")";
- if ($ary) {
- return $self->maybe_parens("$ary = $expr", $cx, 7);
- } else {
- return $expr;
- }
-}
-
-# oxime -- any of various compounds obtained chiefly by the action of
-# hydroxylamine on aldehydes and ketones and characterized by the
-# bivalent grouping C=NOH [Webster's Tenth]
-
-my %substwords;
-map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
- 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
- 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
- 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
-
-sub pp_subst {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first;
- my($binop, $var, $re, $repl) = ("", "", "", "");
- if ($op->flags & OPf_STACKED) {
- $binop = 1;
- $var = $self->deparse($kid, 20);
- $kid = $kid->sibling;
- }
- my $flags = "";
- if (null($op->pmreplroot)) {
- $repl = $self->dq($kid);
- $kid = $kid->sibling;
- } else {
- $repl = $op->pmreplroot->first; # skip substcont
- while ($repl->name eq "entereval") {
- $repl = $repl->first;
- $flags .= "e";
- }
- if ($op->pmflags & PMf_EVAL) {
- $repl = $self->deparse($repl->first, 0);
- } else {
- $repl = $self->dq($repl);
- }
- }
- my $extended = ($op->pmflags & PMf_EXTENDED);
- if (null $kid) {
- my $unbacked = re_unback($op->precomp);
- if ($extended) {
- $re = re_uninterp_extended(escape_extended_re($unbacked));
- }
- else {
- $re = re_uninterp(escape_str($unbacked));
- }
- } else {
- ($re) = $self->regcomp($kid, 1, $extended);
- }
- $flags .= "e" if $op->pmflags & PMf_EVAL;
- $flags .= "g" if $op->pmflags & PMf_GLOBAL;
- $flags .= "i" if $op->pmflags & PMf_FOLD;
- $flags .= "m" if $op->pmflags & PMf_MULTILINE;
- $flags .= "o" if $op->pmflags & PMf_KEEP;
- $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
- $flags .= "x" if $extended;
- $flags = $substwords{$flags} if $substwords{$flags};
- if ($binop) {
- return $self->maybe_parens("$var =~ s"
- . double_delim($re, $repl) . $flags,
- $cx, 20);
- } else {
- return "s". double_delim($re, $repl) . $flags;
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-B::Deparse - Perl compiler backend to produce perl code
-
-=head1 SYNOPSIS
-
-B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
- [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
-
-=head1 DESCRIPTION
-
-B::Deparse is a backend module for the Perl compiler that generates
-perl source code, based on the internal compiled structure that perl
-itself creates after parsing a program. The output of B::Deparse won't
-be exactly the same as the original source, since perl doesn't keep
-track of comments or whitespace, and there isn't a one-to-one
-correspondence between perl's syntactical constructions and their
-compiled form, but it will often be close. When you use the B<-p>
-option, the output also includes parentheses even when they are not
-required by precedence, which can make it easy to see if perl is
-parsing your expressions the way you intended.
-
-While B::Deparse goes to some lengths to try to figure out what your
-original program was doing, some parts of the language can still trip
-it up; it still fails even on some parts of Perl's own test suite. If
-you encounter a failure other than the most common ones described in
-the BUGS section below, you can help contribute to B::Deparse's
-ongoing development by submitting a bug report with a small
-example.
-
-=head1 OPTIONS
-
-As with all compiler backend options, these must follow directly after
-the '-MO=Deparse', separated by a comma but not any white space.
-
-=over 4
-
-=item B<-d>
-
-Output data values (when they appear as constants) using Data::Dumper.
-Without this option, B::Deparse will use some simple routines of its
-own for the same purpose. Currently, Data::Dumper is better for some
-kinds of data (such as complex structures with sharing and
-self-reference) while the built-in routines are better for others
-(such as odd floating-point values).
-
-=item B<-f>I<FILE>
-
-Normally, B::Deparse deparses the main code of a program, and all the subs
-defined in the same file. To include subs defined in other files, pass the
-B<-f> option with the filename. You can pass the B<-f> option several times, to
-include more than one secondary file. (Most of the time you don't want to
-use it at all.) You can also use this option to include subs which are
-defined in the scope of a B<#line> directive with two parameters.
-
-=item B<-l>
-
-Add '#line' declarations to the output based on the line and file
-locations of the original code.
-
-=item B<-p>
-
-Print extra parentheses. Without this option, B::Deparse includes
-parentheses in its output only when they are needed, based on the
-structure of your program. With B<-p>, it uses parentheses (almost)
-whenever they would be legal. This can be useful if you are used to
-LISP, or if you want to see how perl parses your input. If you say
-
- if ($var & 0x7f == 65) {print "Gimme an A!"}
- print ($which ? $a : $b), "\n";
- $name = $ENV{USER} or "Bob";
-
-C<B::Deparse,-p> will print
-
- if (($var & 0)) {
- print('Gimme an A!')
- };
- (print(($which ? $a : $b)), '???');
- (($name = $ENV{'USER'}) or '???')
-
-which probably isn't what you intended (the C<'???'> is a sign that
-perl optimized away a constant value).
-
-=item B<-P>
-
-Disable prototype checking. With this option, all function calls are
-deparsed as if no prototype was defined for them. In other words,
-
- perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
-
-will print
-
- sub foo (\@) {
- 1;
- }
- &foo(\@x);
-
-making clear how the parameters are actually passed to C<foo>.
-
-=item B<-q>
-
-Expand double-quoted strings into the corresponding combinations of
-concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
-instance, print
-
- print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
-
-as
-
- print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
- . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
-
-Note that the expanded form represents the way perl handles such
-constructions internally -- this option actually turns off the reverse
-translation that B::Deparse usually does. On the other hand, note that
-C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
-of $y into a string before doing the assignment.
-
-=item B<-s>I<LETTERS>
-
-Tweak the style of B::Deparse's output. The letters should follow
-directly after the 's', with no space or punctuation. The following
-options are available:
-
-=over 4
-
-=item B<C>
-
-Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
-
- if (...) {
- ...
- } else {
- ...
- }
-
-instead of
-
- if (...) {
- ...
- }
- else {
- ...
- }
-
-The default is not to cuddle.
-
-=item B<i>I<NUMBER>
-
-Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
-
-=item B<T>
-
-Use tabs for each 8 columns of indent. The default is to use only spaces.
-For instance, if the style options are B<-si4T>, a line that's indented
-3 times will be preceded by one tab and four spaces; if the options were
-B<-si8T>, the same line would be preceded by three tabs.
-
-=item B<v>I<STRING>B<.>
-
-Print I<STRING> for the value of a constant that can't be determined
-because it was optimized away (mnemonic: this happens when a constant
-is used in B<v>oid context). The end of the string is marked by a period.
-The string should be a valid perl expression, generally a constant.
-Note that unless it's a number, it probably needs to be quoted, and on
-a command line quotes need to be protected from the shell. Some
-conventional values include 0, 1, 42, '', 'foo', and
-'Useless use of constant omitted' (which may need to be
-B<-sv"'Useless use of constant omitted'.">
-or something similar depending on your shell). The default is '???'.
-If you're using B::Deparse on a module or other file that's require'd,
-you shouldn't use a value that evaluates to false, since the customary
-true constant at the end of a module will be in void context when the
-file is compiled as a main program.
-
-=back
-
-=item B<-x>I<LEVEL>
-
-Expand conventional syntax constructions into equivalent ones that expose
-their internal operation. I<LEVEL> should be a digit, with higher values
-meaning more expansion. As with B<-q>, this actually involves turning off
-special cases in B::Deparse's normal operations.
-
-If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
-while loops with continue blocks; for instance
-
- for ($i = 0; $i < 10; ++$i) {
- print $i;
- }
-
-turns into
-
- $i = 0;
- while ($i < 10) {
- print $i;
- } continue {
- ++$i
- }
-
-Note that in a few cases this translation can't be perfectly carried back
-into the source code -- if the loop's initializer declares a my variable,
-for instance, it won't have the correct scope outside of the loop.
-
-If I<LEVEL> is at least 5, C<use> declarations will be translated into
-C<BEGIN> blocks containing calls to C<require> and C<import>; for
-instance,
-
- use strict 'refs';
-
-turns into
-
- sub BEGIN {
- require strict;
- do {
- 'strict'->import('refs')
- };
- }
-
-If I<LEVEL> is at least 7, C<if> statements will be translated into
-equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
-
- print 'hi' if $nice;
- if ($nice) {
- print 'hi';
- }
- if ($nice) {
- print 'hi';
- } else {
- print 'bye';
- }
-
-turns into
-
- $nice and print 'hi';
- $nice and do { print 'hi' };
- $nice ? do { print 'hi' } : do { print 'bye' };
-
-Long sequences of elsifs will turn into nested ternary operators, which
-B::Deparse doesn't know how to indent nicely.
-
-=back
-
-=head1 USING B::Deparse AS A MODULE
-
-=head2 Synopsis
-
- use B::Deparse;
- $deparse = B::Deparse->new("-p", "-sC");
- $body = $deparse->coderef2text(\&func);
- eval "sub func $body"; # the inverse operation
-
-=head2 Description
-
-B::Deparse can also be used on a sub-by-sub basis from other perl
-programs.
-
-=head2 new
-
- $deparse = B::Deparse->new(OPTIONS)
-
-Create an object to store the state of a deparsing operation and any
-options. The options are the same as those that can be given on the
-command line (see L</OPTIONS>); options that are separated by commas
-after B<-MO=Deparse> should be given as separate strings. Some
-options, like B<-u>, don't make sense for a single subroutine, so
-don't pass them.
-
-=head2 ambient_pragmas
-
- $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
-
-The compilation of a subroutine can be affected by a few compiler
-directives, B<pragmas>. These are:
-
-=over 4
-
-=item *
-
-use strict;
-
-=item *
-
-use warnings;
-
-=item *
-
-Assigning to the special variable $[
-
-=item *
-
-use integer;
-
-=item *
-
-use bytes;
-
-=item *
-
-use utf8;
-
-=item *
-
-use re;
-
-=back
-
-Ordinarily, if you use B::Deparse on a subroutine which has
-been compiled in the presence of one or more of these pragmas,
-the output will include statements to turn on the appropriate
-directives. So if you then compile the code returned by coderef2text,
-it will behave the same way as the subroutine which you deparsed.
-
-However, you may know that you intend to use the results in a
-particular context, where some pragmas are already in scope. In
-this case, you use the B<ambient_pragmas> method to describe the
-assumptions you wish to make.
-
-Not all of the options currently have any useful effect. See
-L</BUGS> for more details.
-
-The parameters it accepts are:
-
-=over 4
-
-=item strict
-
-Takes a string, possibly containing several values separated
-by whitespace. The special values "all" and "none" mean what you'd
-expect.
-
- $deparse->ambient_pragmas(strict => 'subs refs');
-
-=item $[
-
-Takes a number, the value of the array base $[.
-
-=item bytes
-
-=item utf8
-
-=item integer
-
-If the value is true, then the appropriate pragma is assumed to
-be in the ambient scope, otherwise not.
-
-=item re
-
-Takes a string, possibly containing a whitespace-separated list of
-values. The values "all" and "none" are special. It's also permissible
-to pass an array reference here.
-
- $deparser->ambient_pragmas(re => 'eval');
-
-
-=item warnings
-
-Takes a string, possibly containing a whitespace-separated list of
-values. The values "all" and "none" are special, again. It's also
-permissible to pass an array reference here.
-
- $deparser->ambient_pragmas(warnings => [qw[void io]]);
-
-If one of the values is the string "FATAL", then all the warnings
-in that list will be considered fatal, just as with the B<warnings>
-pragma itself. Should you need to specify that some warnings are
-fatal, and others are merely enabled, you can pass the B<warnings>
-parameter twice:
-
- $deparser->ambient_pragmas(
- warnings => 'all',
- warnings => [FATAL => qw/void io/],
- );
-
-See L<perllexwarn> for more information about lexical warnings.
-
-=item hint_bits
-
-=item warning_bits
-
-These two parameters are used to specify the ambient pragmas in
-the format used by the special variables $^H and ${^WARNING_BITS}.
-
-They exist principally so that you can write code like:
-
- { my ($hint_bits, $warning_bits);
- BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
- $deparser->ambient_pragmas (
- hint_bits => $hint_bits,
- warning_bits => $warning_bits,
- '$[' => 0 + $[
- ); }
-
-which specifies that the ambient pragmas are exactly those which
-are in scope at the point of calling.
-
-=back
-
-=head2 coderef2text
-
- $body = $deparse->coderef2text(\&func)
- $body = $deparse->coderef2text(sub ($$) { ... })
-
-Return source code for the body of a subroutine (a block, optionally
-preceded by a prototype in parens), given a reference to the
-sub. Because a subroutine can have no names, or more than one name,
-this method doesn't return a complete subroutine definition -- if you
-want to eval the result, you should prepend "sub subname ", or "sub "
-for an anonymous function constructor. Unless the sub was defined in
-the main:: package, the code will include a package declaration.
-
-=head1 BUGS
-
-=over 4
-
-=item *
-
-The only pragmas to be completely supported are: C<use warnings>,
-C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
-behaves like a pragma, is also supported.)
-
-Excepting those listed above, we're currently unable to guarantee that
-B::Deparse will produce a pragma at the correct point in the program.
-(Specifically, pragmas at the beginning of a block often appear right
-before the start of the block instead.)
-Since the effects of pragmas are often lexically scoped, this can mean
-that the pragma holds sway over a different portion of the program
-than in the input file.
-
-=item *
-
-In fact, the above is a specific instance of a more general problem:
-we can't guarantee to produce BEGIN blocks or C<use> declarations in
-exactly the right place. So if you use a module which affects compilation
-(such as by over-riding keywords, overloading constants or whatever)
-then the output code might not work as intended.
-
-This is the most serious outstanding problem, and will require some help
-from the Perl core to fix.
-
-=item *
-
-If a keyword is over-ridden, and your program explicitly calls
-the built-in version by using CORE::keyword, the output of B::Deparse
-will not reflect this. If you run the resulting code, it will call
-the over-ridden version rather than the built-in one. (Maybe there
-should be an option to B<always> print keyword calls as C<CORE::name>.)
-
-=item *
-
-Some constants don't print correctly either with or without B<-d>.
-For instance, neither B::Deparse nor Data::Dumper know how to print
-dual-valued scalars correctly, as in:
-
- use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
-
-=item *
-
-An input file that uses source filtering probably won't be deparsed into
-runnable code, because it will still include the B<use> declaration
-for the source filtering module, even though the code that is
-produced is already ordinary Perl which shouldn't be filtered again.
-
-=item *
-
-Optimised away statements are rendered as '???'. This includes statements that
-have a compile-time side-effect, such as the obscure
-
- my $x if 0;
-
-which is not, consequently, deparsed correctly.
-
-=item *
-
-There are probably many more bugs on non-ASCII platforms (EBCDIC).
-
-=back
-
-=head1 AUTHOR
-
-Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
-by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
-Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
-Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
-Garcia-Suarez.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Disassembler.pm b/Master/tlpkg/installer/perllib/B/Disassembler.pm
deleted file mode 100644
index e1993aa9537..00000000000
--- a/Master/tlpkg/installer/perllib/B/Disassembler.pm
+++ /dev/null
@@ -1,233 +0,0 @@
-# Disassembler.pm
-#
-# Copyright (c) 1996 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-
-$B::Disassembler::VERSION = '1.05';
-
-package B::Disassembler::BytecodeStream;
-
-use FileHandle;
-use Carp;
-use Config qw(%Config);
-use B qw(cstring cast_I32);
-@ISA = qw(FileHandle);
-sub readn {
- my ($fh, $len) = @_;
- my $data;
- read($fh, $data, $len);
- croak "reached EOF while reading $len bytes" unless length($data) == $len;
- return $data;
-}
-
-sub GET_U8 {
- my $fh = shift;
- my $c = $fh->getc;
- croak "reached EOF while reading U8" unless defined($c);
- return ord($c);
-}
-
-sub GET_U16 {
- my $fh = shift;
- my $str = $fh->readn(2);
- croak "reached EOF while reading U16" unless length($str) == 2;
- return unpack("S", $str);
-}
-
-sub GET_NV {
- my $fh = shift;
- my ($str, $c);
- while (defined($c = $fh->getc) && $c ne "\0") {
- $str .= $c;
- }
- croak "reached EOF while reading double" unless defined($c);
- return $str;
-}
-
-sub GET_U32 {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading U32" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_I32 {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading I32" unless length($str) == 4;
- return unpack("l", $str);
-}
-
-sub GET_objindex {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading objindex" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_opindex {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading opindex" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_svindex {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading svindex" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_pvindex {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading pvindex" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_strconst {
- my $fh = shift;
- my ($str, $c);
- $str = '';
- while (defined($c = $fh->getc) && $c ne "\0") {
- $str .= $c;
- }
- croak "reached EOF while reading strconst" unless defined($c);
- return cstring($str);
-}
-
-sub GET_pvcontents {}
-
-sub GET_PV {
- my $fh = shift;
- my $str;
- my $len = $fh->GET_U32;
- if ($len) {
- read($fh, $str, $len);
- croak "reached EOF while reading PV" unless length($str) == $len;
- return cstring($str);
- } else {
- return '""';
- }
-}
-
-sub GET_comment_t {
- my $fh = shift;
- my ($str, $c);
- while (defined($c = $fh->getc) && $c ne "\n") {
- $str .= $c;
- }
- croak "reached EOF while reading comment" unless defined($c);
- return cstring($str);
-}
-
-sub GET_double {
- my $fh = shift;
- my ($str, $c);
- while (defined($c = $fh->getc) && $c ne "\0") {
- $str .= $c;
- }
- croak "reached EOF while reading double" unless defined($c);
- return $str;
-}
-
-sub GET_none {}
-
-sub GET_op_tr_array {
- my $fh = shift;
- my $len = unpack "S", $fh->readn(2);
- my @ary = unpack "S*", $fh->readn($len*2);
- return join(",", $len, @ary);
-}
-
-sub GET_IV64 {
- my $fh = shift;
- my $str = $fh->readn(8);
- croak "reached EOF while reading I32" unless length($str) == 8;
- return sprintf "0x%09llx", unpack("q", $str);
-}
-
-sub GET_IV {
- $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
-}
-
-sub GET_PADOFFSET {
- $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32;
-}
-
-sub GET_long {
- $Config{longsize} == 8 ? &GET_IV64 : &GET_U32;
-}
-
-
-package B::Disassembler;
-use Exporter;
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(disassemble_fh get_header);
-use Carp;
-use strict;
-
-use B::Asmdata qw(%insn_data @insn_name);
-
-our( $magic, $archname, $blversion, $ivsize, $ptrsize );
-
-sub dis_header($){
- my( $fh ) = @_;
- $magic = $fh->GET_U32();
- warn( "bad magic" ) if $magic != 0x43424c50;
- $archname = $fh->GET_strconst();
- $blversion = $fh->GET_strconst();
- $ivsize = $fh->GET_U32();
- $ptrsize = $fh->GET_U32();
-}
-
-sub get_header(){
- return( $magic, $archname, $blversion, $ivsize, $ptrsize);
-}
-
-sub disassemble_fh {
- my ($fh, $out) = @_;
- my ($c, $getmeth, $insn, $arg);
- bless $fh, "B::Disassembler::BytecodeStream";
- dis_header( $fh );
- while (defined($c = $fh->getc)) {
- $c = ord($c);
- $insn = $insn_name[$c];
- if (!defined($insn) || $insn eq "unused") {
- my $pos = $fh->tell - 1;
- die "Illegal instruction code $c at stream offset $pos\n";
- }
- $getmeth = $insn_data{$insn}->[2];
- $arg = $fh->$getmeth();
- if (defined($arg)) {
- &$out($insn, $arg);
- } else {
- &$out($insn);
- }
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Disassembler - Disassemble Perl bytecode
-
-=head1 SYNOPSIS
-
- use Disassembler;
-
-=head1 DESCRIPTION
-
-See F<ext/B/B/Disassembler.pm>.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Lint.pm b/Master/tlpkg/installer/perllib/B/Lint.pm
deleted file mode 100644
index 3475bd2596e..00000000000
--- a/Master/tlpkg/installer/perllib/B/Lint.pm
+++ /dev/null
@@ -1,392 +0,0 @@
-package B::Lint;
-
-our $VERSION = '1.03';
-
-=head1 NAME
-
-B::Lint - Perl lint
-
-=head1 SYNOPSIS
-
-perl -MO=Lint[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-The B::Lint module is equivalent to an extended version of the B<-w>
-option of B<perl>. It is named after the program F<lint> which carries
-out a similar process for C programs.
-
-=head1 OPTIONS AND LINT CHECKS
-
-Option words are separated by commas (not whitespace) and follow the
-usual conventions of compiler backend options. Following any options
-(indicated by a leading B<->) come lint check arguments. Each such
-argument (apart from the special B<all> and B<none> options) is a
-word representing one possible lint check (turning on that check) or
-is B<no-foo> (turning off that check). Before processing the check
-arguments, a standard list of checks is turned on. Later options
-override earlier ones. Available options are:
-
-=over 8
-
-=item B<context>
-
-Produces a warning whenever an array is used in an implicit scalar
-context. For example, both of the lines
-
- $foo = length(@bar);
- $foo = @bar;
-
-will elicit a warning. Using an explicit B<scalar()> silences the
-warning. For example,
-
- $foo = scalar(@bar);
-
-=item B<implicit-read> and B<implicit-write>
-
-These options produce a warning whenever an operation implicitly
-reads or (respectively) writes to one of Perl's special variables.
-For example, B<implicit-read> will warn about these:
-
- /foo/;
-
-and B<implicit-write> will warn about these:
-
- s/foo/bar/;
-
-Both B<implicit-read> and B<implicit-write> warn about this:
-
- for (@a) { ... }
-
-=item B<bare-subs>
-
-This option warns whenever a bareword is implicitly quoted, but is also
-the name of a subroutine in the current package. Typical mistakes that it will
-trap are:
-
- use constant foo => 'bar';
- @a = ( foo => 1 );
- $b{foo} = 2;
-
-Neither of these will do what a naive user would expect.
-
-=item B<dollar-underscore>
-
-This option warns whenever C<$_> is used either explicitly anywhere or
-as the implicit argument of a B<print> statement.
-
-=item B<private-names>
-
-This option warns on each use of any variable, subroutine or
-method name that lives in a non-current package but begins with
-an underscore ("_"). Warnings aren't issued for the special case
-of the single character name "_" by itself (e.g. C<$_> and C<@_>).
-
-=item B<undefined-subs>
-
-This option warns whenever an undefined subroutine is invoked.
-This option will only catch explicitly invoked subroutines such
-as C<foo()> and not indirect invocations such as C<&$subref()>
-or C<$obj-E<gt>meth()>. Note that some programs or modules delay
-definition of subs until runtime by means of the AUTOLOAD
-mechanism.
-
-=item B<regexp-variables>
-
-This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
-is used. Any occurrence of any of these variables in your
-program can slow your whole program down. See L<perlre> for
-details.
-
-=item B<all>
-
-Turn all warnings on.
-
-=item B<none>
-
-Turn all warnings off.
-
-=back
-
-=head1 NON LINT-CHECK OPTIONS
-
-=over 8
-
-=item B<-u Package>
-
-Normally, Lint only checks the main code of the program together
-with all subs defined in package main. The B<-u> option lets you
-include other package names whose subs are then checked by Lint.
-
-=back
-
-=head1 BUGS
-
-This is only a very preliminary version.
-
-This module doesn't work correctly on thread-enabled perls.
-
-=head1 AUTHOR
-
-Malcolm Beattie, mbeattie@sable.ox.ac.uk.
-
-=cut
-
-use strict;
-use B qw(walkoptree_slow main_root walksymtable svref_2object parents
- OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
- );
-
-my $file = "unknown"; # shadows current filename
-my $line = 0; # shadows current line number
-my $curstash = "main"; # shadows current stash
-
-# Lint checks
-my %check;
-my %implies_ok_context;
-BEGIN {
- map($implies_ok_context{$_}++,
- qw(scalar av2arylen aelem aslice helem hslice
- keys values hslice defined undef delete));
-}
-
-# Lint checks turned on by default
-my @default_checks = qw(context);
-
-my %valid_check;
-# All valid checks
-BEGIN {
- map($valid_check{$_}++,
- qw(context implicit_read implicit_write dollar_underscore
- private_names bare_subs undefined_subs regexp_variables));
-}
-
-# Debugging options
-my ($debug_op);
-
-my %done_cv; # used to mark which subs have already been linted
-my @extra_packages; # Lint checks mainline code and all subs which are
- # in main:: or in one of these packages.
-
-sub warning {
- my $format = (@_ < 2) ? "%s" : shift;
- warn sprintf("$format at %s line %d\n", @_, $file, $line);
-}
-
-# This gimme can't cope with context that's only determined
-# at runtime via dowantarray().
-sub gimme {
- my $op = shift;
- my $flags = $op->flags;
- if ($flags & OPf_WANT) {
- return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
- }
- return undef;
-}
-
-sub B::OP::lint {}
-
-sub B::COP::lint {
- my $op = shift;
- if ($op->name eq "nextstate") {
- $file = $op->file;
- $line = $op->line;
- $curstash = $op->stash->NAME;
- }
-}
-
-sub B::UNOP::lint {
- my $op = shift;
- my $opname = $op->name;
- if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
- my $parent = parents->[0];
- my $pname = $parent->name;
- return if gimme($op) || $implies_ok_context{$pname};
- # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
- # null out the parent so we have to check for a parent of pp_null and
- # a grandparent of pp_enteriter or pp_delete
- if ($pname eq "null") {
- my $gpname = parents->[1]->name;
- return if $gpname eq "enteriter" || $gpname eq "delete";
- }
- warning("Implicit scalar context for %s in %s",
- $opname eq "rv2av" ? "array" : "hash", $parent->desc);
- }
- if ($check{private_names} && $opname eq "method") {
- my $methop = $op->first;
- if ($methop->name eq "const") {
- my $method = $methop->sv->PV;
- if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
- warning("Illegal reference to private method name $method");
- }
- }
- }
-}
-
-sub B::PMOP::lint {
- my $op = shift;
- if ($check{implicit_read}) {
- if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
- warning('Implicit match on $_');
- }
- }
- if ($check{implicit_write}) {
- if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
- warning('Implicit substitution on $_');
- }
- }
-}
-
-sub B::LOOP::lint {
- my $op = shift;
- if ($check{implicit_read} || $check{implicit_write}) {
- if ($op->name eq "enteriter") {
- my $last = $op->last;
- if ($last->name eq "gv" && $last->gv->NAME eq "_") {
- warning('Implicit use of $_ in foreach');
- }
- }
- }
-}
-
-sub B::SVOP::lint {
- my $op = shift;
- if ( $check{bare_subs} && $op->name eq 'const'
- && $op->private & 64 ) # OPpCONST_BARE = 64 in op.h
- {
- my $sv = $op->sv;
- if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) {
- warning "Bare sub name '" . $sv->PV . "' interpreted as string";
- }
- }
- if ($check{dollar_underscore} && $op->name eq "gvsv"
- && $op->gv->NAME eq "_")
- {
- warning('Use of $_');
- }
- if ($check{private_names}) {
- my $opname = $op->name;
- if ($opname eq "gv" || $opname eq "gvsv") {
- my $gv = $op->gv;
- if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
- warning('Illegal reference to private name %s', $gv->NAME);
- }
- } elsif ($opname eq "method_named") {
- my $method = $op->gv->PV;
- if ($method =~ /^_./) {
- warning("Illegal reference to private method name $method");
- }
- }
- }
- if ($check{undefined_subs}) {
- if ($op->name eq "gv"
- && $op->next->name eq "entersub")
- {
- my $gv = $op->gv;
- my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
- no strict 'refs';
- if (!defined(&$subname)) {
- $subname =~ s/^main:://;
- warning('Undefined subroutine %s called', $subname);
- }
- }
- }
- if ($check{regexp_variables} && $op->name eq "gvsv") {
- my $name = $op->gv->NAME;
- if ($name =~ /^[&'`]$/) {
- warning('Use of regexp variable $%s', $name);
- }
- }
-}
-
-sub B::GV::lintcv {
- my $gv = shift;
- my $cv = $gv->CV;
- #warn sprintf("lintcv: %s::%s (done=%d)\n",
- # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
- return if !$$cv || $done_cv{$$cv}++;
- my $root = $cv->ROOT;
- #warn " root = $root (0x$$root)\n";#debug
- walkoptree_slow($root, "lint") if $$root;
-}
-
-sub do_lint {
- my %search_pack;
- walkoptree_slow(main_root, "lint") if ${main_root()};
-
- # Now do subs in main
- no strict qw(vars refs);
- local(*glob);
- for my $sym (keys %main::) {
- next if $sym =~ /::$/;
- *glob = $main::{$sym};
- svref_2object(\*glob)->EGV->lintcv;
- }
-
- # Now do subs in non-main packages given by -u options
- map { $search_pack{$_} = 1 } @extra_packages;
- walksymtable(\%{"main::"}, "lintcv", sub {
- my $package = shift;
- $package =~ s/::$//;
- #warn "Considering $package\n";#debug
- return exists $search_pack{$package};
- });
-}
-
-sub compile {
- my @options = @_;
- my ($option, $opt, $arg);
- # Turn on default lint checks
- for $opt (@default_checks) {
- $check{$opt} = 1;
- }
- OPTION:
- while ($option = shift @options) {
- if ($option =~ /^-(.)(.*)/) {
- $opt = $1;
- $arg = $2;
- } else {
- unshift @options, $option;
- last OPTION;
- }
- if ($opt eq "-" && $arg eq "-") {
- shift @options;
- last OPTION;
- } elsif ($opt eq "D") {
- $arg ||= shift @options;
- foreach $arg (split(//, $arg)) {
- if ($arg eq "o") {
- B->debug(1);
- } elsif ($arg eq "O") {
- $debug_op = 1;
- }
- }
- } elsif ($opt eq "u") {
- $arg ||= shift @options;
- push(@extra_packages, $arg);
- }
- }
- foreach $opt (@default_checks, @options) {
- $opt =~ tr/-/_/;
- if ($opt eq "all") {
- %check = %valid_check;
- }
- elsif ($opt eq "none") {
- %check = ();
- }
- else {
- if ($opt =~ s/^no_//) {
- $check{$opt} = 0;
- }
- else {
- $check{$opt} = 1;
- }
- warn "No such check: $opt\n" unless defined $valid_check{$opt};
- }
- }
- # Remaining arguments are things to check
-
- return \&do_lint;
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/B/Showlex.pm b/Master/tlpkg/installer/perllib/B/Showlex.pm
deleted file mode 100644
index 3b261a337df..00000000000
--- a/Master/tlpkg/installer/perllib/B/Showlex.pm
+++ /dev/null
@@ -1,205 +0,0 @@
-package B::Showlex;
-
-our $VERSION = '1.02';
-
-use strict;
-use B qw(svref_2object comppadlist class);
-use B::Terse ();
-use B::Concise ();
-
-#
-# Invoke as
-# perl -MO=Showlex,foo bar.pl
-# to see the names of lexical variables used by &foo
-# or as
-# perl -MO=Showlex bar.pl
-# to see the names of file scope lexicals used by bar.pl
-#
-
-
-# borrowed from B::Concise
-our $walkHandle = \*STDOUT;
-
-sub walk_output { # updates $walkHandle
- $walkHandle = B::Concise::walk_output(@_);
- #print "got $walkHandle";
- #print $walkHandle "using it";
- $walkHandle;
-}
-
-sub shownamearray {
- my ($name, $av) = @_;
- my @els = $av->ARRAY;
- my $count = @els;
- my $i;
- print $walkHandle "$name has $count entries\n";
- for ($i = 0; $i < $count; $i++) {
- my $sv = $els[$i];
- if (class($sv) ne "SPECIAL") {
- printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX;
- } else {
- printf $walkHandle "$i: %s\n", $sv->terse;
- #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv);
- }
- }
-}
-
-sub showvaluearray {
- my ($name, $av) = @_;
- my @els = $av->ARRAY;
- my $count = @els;
- my $i;
- print $walkHandle "$name has $count entries\n";
- for ($i = 0; $i < $count; $i++) {
- printf $walkHandle "$i: %s\n", $els[$i]->terse;
- #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]);
- }
-}
-
-sub showlex {
- my ($objname, $namesav, $valsav) = @_;
- shownamearray("Pad of lexical names for $objname", $namesav);
- showvaluearray("Pad of lexical values for $objname", $valsav);
-}
-
-my ($newlex, $nosp1); # rendering state vars
-
-sub newlex { # drop-in for showlex
- my ($objname, $names, $vals) = @_;
- my @names = $names->ARRAY;
- my @vals = $vals->ARRAY;
- my $count = @names;
- print $walkHandle "$objname Pad has $count entries\n";
- printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1;
- for (my $i = 1; $i < $count; $i++) {
- printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse
- unless $nosp1 and $names[$i]->terse =~ /SPECIAL/;
- }
-}
-
-sub showlex_obj {
- my ($objname, $obj) = @_;
- $objname =~ s/^&main::/&/;
- showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex;
- newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex;
-}
-
-sub showlex_main {
- showlex("comppadlist", comppadlist->ARRAY) if !$newlex;
- newlex ("main", comppadlist->ARRAY) if $newlex;
-}
-
-sub compile {
- my @options = grep(/^-/, @_);
- my @args = grep(!/^-/, @_);
- for my $o (@options) {
- $newlex = 1 if $o eq "-newlex";
- $nosp1 = 1 if $o eq "-nosp";
- }
-
- return \&showlex_main unless @args;
- return sub {
- my $objref;
- foreach my $objname (@args) {
- next unless $objname; # skip nulls w/o carping
-
- if (ref $objname) {
- print $walkHandle "B::Showlex::compile($objname)\n";
- $objref = $objname;
- } else {
- $objname = "main::$objname" unless $objname =~ /::/;
- print $walkHandle "$objname:\n";
- no strict 'refs';
- die "err: unknown function ($objname)\n"
- unless *{$objname}{CODE};
- $objref = \&$objname;
- }
- showlex_obj($objname, $objref);
- }
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Showlex - Show lexical variables used in functions or files
-
-=head1 SYNOPSIS
-
- perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl
-
-=head1 DESCRIPTION
-
-When a comma-separated list of subroutine names is given as options, Showlex
-prints the lexical variables used in those subroutines. Otherwise, it prints
-the file-scope lexicals in the file.
-
-=head1 EXAMPLES
-
-Traditional form:
-
- $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")'
- Pad of lexical names for comppadlist has 4 entries
- 0: SPECIAL #1 &PL_sv_undef
- 1: PVNV (0x9db0fb0) $i
- 2: PVNV (0x9db0f38) $j
- 3: PVNV (0x9db0f50) $k
- Pad of lexical values for comppadlist has 5 entries
- 0: SPECIAL #1 &PL_sv_undef
- 1: NULL (0x9da4234)
- 2: NULL (0x9db0f2c)
- 3: NULL (0x9db0f44)
- 4: NULL (0x9da4264)
- -e syntax OK
-
-New-style form:
-
- $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")'
- main Pad has 4 entries
- 0: SPECIAL #1 &PL_sv_undef
- 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234)
- 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34)
- 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c)
- -e syntax OK
-
-New form, no specials, outside O framework:
-
- $ perl -MB::Showlex -e \
- 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()'
- main Pad has 4 entries
- 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1
- 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo"
- 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74)
-
-Note that this example shows the values of the lexicals, whereas the other
-examples did not (as they're compile-time only).
-
-=head2 OPTIONS
-
-The C<-newlex> option produces a more readable C<< name => value >> format,
-and is shown in the second example above.
-
-The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL
-#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm
-your declared lexicals.
-
-=head1 SEE ALSO
-
-C<B::Showlex> can also be used outside of the O framework, as in the third
-example. See C<B::Concise> for a fuller explanation of reasons.
-
-=head1 TODO
-
-Some of the reported info, such as hex addresses, is not particularly
-valuable. Other information would be more useful for the typical
-programmer, such as line-numbers, pad-slot reuses, etc.. Given this,
--newlex isnt a particularly good flag-name.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Stackobj.pm b/Master/tlpkg/installer/perllib/B/Stackobj.pm
deleted file mode 100644
index b17dfb8173a..00000000000
--- a/Master/tlpkg/installer/perllib/B/Stackobj.pm
+++ /dev/null
@@ -1,349 +0,0 @@
-# Stackobj.pm
-#
-# Copyright (c) 1996 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-package B::Stackobj;
-
-our $VERSION = '1.00';
-
-use Exporter ();
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
- VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
-%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
- flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
- VALID_UNSIGNED REGISTER TEMPORARY)]);
-
-use Carp qw(confess);
-use strict;
-use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
-
-# Types
-sub T_UNKNOWN () { 0 }
-sub T_DOUBLE () { 1 }
-sub T_INT () { 2 }
-sub T_SPECIAL () { 3 }
-
-# Flags
-sub VALID_INT () { 0x01 }
-sub VALID_UNSIGNED () { 0x02 }
-sub VALID_DOUBLE () { 0x04 }
-sub VALID_SV () { 0x08 }
-sub REGISTER () { 0x10 } # no implicit write-back when calling subs
-sub TEMPORARY () { 0x20 } # no implicit write-back needed at all
-sub SAVE_INT () { 0x40 } #if int part needs to be saved at all
-sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all
-
-
-#
-# Callback for runtime code generation
-#
-my $runtime_callback = sub { confess "set_callback not yet called" };
-sub set_callback (&) { $runtime_callback = shift }
-sub runtime { &$runtime_callback(@_) }
-
-#
-# Methods
-#
-
-sub write_back { confess "stack object does not implement write_back" }
-
-sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
-
-sub as_sv {
- my $obj = shift;
- if (!($obj->{flags} & VALID_SV)) {
- $obj->write_back;
- $obj->{flags} |= VALID_SV;
- }
- return $obj->{sv};
-}
-
-sub as_int {
- my $obj = shift;
- if (!($obj->{flags} & VALID_INT)) {
- $obj->load_int;
- $obj->{flags} |= VALID_INT|SAVE_INT;
- }
- return $obj->{iv};
-}
-
-sub as_double {
- my $obj = shift;
- if (!($obj->{flags} & VALID_DOUBLE)) {
- $obj->load_double;
- $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
- }
- return $obj->{nv};
-}
-
-sub as_numeric {
- my $obj = shift;
- return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
-}
-
-sub as_bool {
- my $obj=shift;
- if ($obj->{flags} & VALID_INT ){
- return $obj->{iv};
- }
- if ($obj->{flags} & VALID_DOUBLE ){
- return $obj->{nv};
- }
- return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
-}
-
-#
-# Debugging methods
-#
-sub peek {
- my $obj = shift;
- my $type = $obj->{type};
- my $flags = $obj->{flags};
- my @flags;
- if ($type == T_UNKNOWN) {
- $type = "T_UNKNOWN";
- } elsif ($type == T_INT) {
- $type = "T_INT";
- } elsif ($type == T_DOUBLE) {
- $type = "T_DOUBLE";
- } else {
- $type = "(illegal type $type)";
- }
- push(@flags, "VALID_INT") if $flags & VALID_INT;
- push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
- push(@flags, "VALID_SV") if $flags & VALID_SV;
- push(@flags, "REGISTER") if $flags & REGISTER;
- push(@flags, "TEMPORARY") if $flags & TEMPORARY;
- @flags = ("none") unless @flags;
- return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
- class($obj), join("|", @flags));
-}
-
-sub minipeek {
- my $obj = shift;
- my $type = $obj->{type};
- my $flags = $obj->{flags};
- if ($type == T_INT || $flags & VALID_INT) {
- return $obj->{iv};
- } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
- return $obj->{nv};
- } else {
- return $obj->{sv};
- }
-}
-
-#
-# Caller needs to ensure that set_int, set_double,
-# set_numeric and set_sv are only invoked on legal lvalues.
-#
-sub set_int {
- my ($obj, $expr,$unsigned) = @_;
- runtime("$obj->{iv} = $expr;");
- $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
- $obj->{flags} |= VALID_INT|SAVE_INT;
- $obj->{flags} |= VALID_UNSIGNED if $unsigned;
-}
-
-sub set_double {
- my ($obj, $expr) = @_;
- runtime("$obj->{nv} = $expr;");
- $obj->{flags} &= ~(VALID_SV | VALID_INT);
- $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
-}
-
-sub set_numeric {
- my ($obj, $expr) = @_;
- if ($obj->{type} == T_INT) {
- $obj->set_int($expr);
- } else {
- $obj->set_double($expr);
- }
-}
-
-sub set_sv {
- my ($obj, $expr) = @_;
- runtime("SvSetSV($obj->{sv}, $expr);");
- $obj->invalidate;
- $obj->{flags} |= VALID_SV;
-}
-
-#
-# Stackobj::Padsv
-#
-
-@B::Stackobj::Padsv::ISA = 'B::Stackobj';
-sub B::Stackobj::Padsv::new {
- my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
- $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
- $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
- bless {
- type => $type,
- flags => VALID_SV | $extra_flags,
- sv => "PL_curpad[$ix]",
- iv => "$iname",
- nv => "$dname"
- }, $class;
-}
-
-sub B::Stackobj::Padsv::load_int {
- my $obj = shift;
- if ($obj->{flags} & VALID_DOUBLE) {
- runtime("$obj->{iv} = $obj->{nv};");
- } else {
- runtime("$obj->{iv} = SvIV($obj->{sv});");
- }
- $obj->{flags} |= VALID_INT|SAVE_INT;
-}
-
-sub B::Stackobj::Padsv::load_double {
- my $obj = shift;
- $obj->write_back;
- runtime("$obj->{nv} = SvNV($obj->{sv});");
- $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
-}
-sub B::Stackobj::Padsv::save_int {
- my $obj = shift;
- return $obj->{flags} & SAVE_INT;
-}
-
-sub B::Stackobj::Padsv::save_double {
- my $obj = shift;
- return $obj->{flags} & SAVE_DOUBLE;
-}
-
-sub B::Stackobj::Padsv::write_back {
- my $obj = shift;
- my $flags = $obj->{flags};
- return if $flags & VALID_SV;
- if ($flags & VALID_INT) {
- if ($flags & VALID_UNSIGNED ){
- runtime("sv_setuv($obj->{sv}, $obj->{iv});");
- }else{
- runtime("sv_setiv($obj->{sv}, $obj->{iv});");
- }
- } elsif ($flags & VALID_DOUBLE) {
- runtime("sv_setnv($obj->{sv}, $obj->{nv});");
- } else {
- confess "write_back failed for lexical @{[$obj->peek]}\n";
- }
- $obj->{flags} |= VALID_SV;
-}
-
-#
-# Stackobj::Const
-#
-
-@B::Stackobj::Const::ISA = 'B::Stackobj';
-sub B::Stackobj::Const::new {
- my ($class, $sv) = @_;
- my $obj = bless {
- flags => 0,
- sv => $sv # holds the SV object until write_back happens
- }, $class;
- if ( ref($sv) eq "B::SPECIAL" ){
- $obj->{type}= T_SPECIAL;
- }else{
- my $svflags = $sv->FLAGS;
- if ($svflags & SVf_IOK) {
- $obj->{flags} = VALID_INT|VALID_DOUBLE;
- $obj->{type} = T_INT;
- if ($svflags & SVf_IVisUV){
- $obj->{flags} |= VALID_UNSIGNED;
- $obj->{nv} = $obj->{iv} = $sv->UVX;
- }else{
- $obj->{nv} = $obj->{iv} = $sv->IV;
- }
- } elsif ($svflags & SVf_NOK) {
- $obj->{flags} = VALID_INT|VALID_DOUBLE;
- $obj->{type} = T_DOUBLE;
- $obj->{iv} = $obj->{nv} = $sv->NV;
- } else {
- $obj->{type} = T_UNKNOWN;
- }
- }
- return $obj;
-}
-
-sub B::Stackobj::Const::write_back {
- my $obj = shift;
- return if $obj->{flags} & VALID_SV;
- # Save the SV object and replace $obj->{sv} by its C source code name
- $obj->{sv} = $obj->{sv}->save;
- $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
-}
-
-sub B::Stackobj::Const::load_int {
- my $obj = shift;
- if (ref($obj->{sv}) eq "B::RV"){
- $obj->{iv} = int($obj->{sv}->RV->PV);
- }else{
- $obj->{iv} = int($obj->{sv}->PV);
- }
- $obj->{flags} |= VALID_INT;
-}
-
-sub B::Stackobj::Const::load_double {
- my $obj = shift;
- if (ref($obj->{sv}) eq "B::RV"){
- $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
- }else{
- $obj->{nv} = $obj->{sv}->PV + 0.0;
- }
- $obj->{flags} |= VALID_DOUBLE;
-}
-
-sub B::Stackobj::Const::invalidate {}
-
-#
-# Stackobj::Bool
-#
-
-@B::Stackobj::Bool::ISA = 'B::Stackobj';
-sub B::Stackobj::Bool::new {
- my ($class, $preg) = @_;
- my $obj = bless {
- type => T_INT,
- flags => VALID_INT|VALID_DOUBLE,
- iv => $$preg,
- nv => $$preg,
- preg => $preg # this holds our ref to the pseudo-reg
- }, $class;
- return $obj;
-}
-
-sub B::Stackobj::Bool::write_back {
- my $obj = shift;
- return if $obj->{flags} & VALID_SV;
- $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
- $obj->{flags} |= VALID_SV;
-}
-
-# XXX Might want to handle as_double/set_double/load_double?
-
-sub B::Stackobj::Bool::invalidate {}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Stackobj - Helper module for CC backend
-
-=head1 SYNOPSIS
-
- use B::Stackobj;
-
-=head1 DESCRIPTION
-
-See F<ext/B/README>.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Stash.pm b/Master/tlpkg/installer/perllib/B/Stash.pm
deleted file mode 100644
index 5e60868a28e..00000000000
--- a/Master/tlpkg/installer/perllib/B/Stash.pm
+++ /dev/null
@@ -1,52 +0,0 @@
-# Stash.pm -- show what stashes are loaded
-# vishalb@hotmail.com
-package B::Stash;
-
-our $VERSION = '1.00';
-
-=pod
-
-=head1 NAME
-
-B::Stash - show what stashes are loaded
-
-=cut
-
-BEGIN { %Seen = %INC }
-
-CHECK {
- my @arr=scan($main::{"main::"});
- @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr;
- print "-umain,-u", join (",-u",@arr) ,"\n";
-}
-sub scan{
- my $start=shift;
- my $prefix=shift;
- $prefix = '' unless defined $prefix;
- my @return;
- foreach my $key ( keys %{$start}){
-# print $prefix,$key,"\n";
- if ($key =~ /::$/){
- unless ($start eq ${$start}{$key} or $key eq "B::" ){
- push @return, $key unless omit($prefix.$key);
- foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){
- push @return, "$key".$subscan;
- }
- }
- }
- }
- return @return;
-}
-sub omit{
- my $module = shift;
- my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 ,
- "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 );
- return 1 if $omit{$module};
- if ($module eq "IO::" or $module eq "IO::Handle::"){
- $module =~ s/::/\//g;
- return 1 unless $INC{$module};
- }
-
- return 0;
-}
-1;
diff --git a/Master/tlpkg/installer/perllib/B/Terse.pm b/Master/tlpkg/installer/perllib/B/Terse.pm
deleted file mode 100644
index 1d53950ad3b..00000000000
--- a/Master/tlpkg/installer/perllib/B/Terse.pm
+++ /dev/null
@@ -1,103 +0,0 @@
-package B::Terse;
-
-our $VERSION = '1.03_01';
-
-use strict;
-use B qw(class);
-use B::Asmdata qw(@specialsv_name);
-use B::Concise qw(concise_subref set_style_standard);
-use Carp;
-
-sub terse {
- my ($order, $subref) = @_;
- set_style_standard("terse");
- if ($order eq "exec") {
- concise_subref('exec', $subref);
- } else {
- concise_subref('basic', $subref);
- }
-}
-
-sub compile {
- my @args = @_;
- my $order = @args ? shift(@args) : "";
- $order = "-exec" if $order eq "exec";
- unshift @args, $order if $order ne "";
- B::Concise::compile("-terse", @args);
-}
-
-sub indent {
- my ($level) = @_ ? shift : 0;
- return " " x $level;
-}
-
-# Don't use this, at least on OPs in subroutines: it has no way of
-# getting to the pad, and will give wrong answers or crash.
-sub B::OP::terse {
- carp "B::OP::terse is deprecated; use B::Concise instead";
- B::Concise::b_terse(@_);
-}
-
-sub B::SV::terse {
- my($sv, $level) = (@_, 0);
- my %info;
- B::Concise::concise_sv($sv, \%info);
- my $s = indent($level)
- . B::Concise::fmt_line(\%info, $sv,
- "#svclass~(?((#svaddr))?)~#svval", 0);
- chomp $s;
- print "$s\n" unless defined wantarray;
- $s;
-}
-
-sub B::NULL::terse {
- my ($sv, $level) = (@_, 0);
- my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv;
- print "$s\n" unless defined wantarray;
- $s;
-}
-
-sub B::SPECIAL::terse {
- my ($sv, $level) = (@_, 0);
- my $s = indent($level)
- . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]);
- print "$s\n" unless defined wantarray;
- $s;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Terse - Walk Perl syntax tree, printing terse info about ops
-
-=head1 SYNOPSIS
-
- perl -MO=Terse[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-This version of B::Terse is really just a wrapper that calls B::Concise
-with the B<-terse> option. It is provided for compatibility with old scripts
-(and habits) but using B::Concise directly is now recommended instead.
-
-For compatibility with the old B::Terse, this module also adds a
-method named C<terse> to B::OP and B::SV objects. The B::SV method is
-largely compatible with the old one, though authors of new software
-might be advised to choose a more user-friendly output format. The
-B::OP C<terse> method, however, doesn't work well. Since B::Terse was
-first written, much more information in OPs has migrated to the
-scratchpad datastructure, but the C<terse> interface doesn't have any
-way of getting to the correct pad. As a kludge, the new version will
-always use the pad for the main program, but for OPs in subroutines
-this will give the wrong answer or crash.
-
-=head1 AUTHOR
-
-The original version of B::Terse was written by Malcolm Beattie,
-E<lt>mbeattie@sable.ox.ac.ukE<gt>. This wrapper was written by Stephen
-McCamant, E<lt>smcc@MIT.EDUE<gt>.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/B/Xref.pm b/Master/tlpkg/installer/perllib/B/Xref.pm
deleted file mode 100644
index f727dc766b5..00000000000
--- a/Master/tlpkg/installer/perllib/B/Xref.pm
+++ /dev/null
@@ -1,430 +0,0 @@
-package B::Xref;
-
-our $VERSION = '1.01';
-
-=head1 NAME
-
-B::Xref - Generates cross reference reports for Perl programs
-
-=head1 SYNOPSIS
-
-perl -MO=Xref[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-The B::Xref module is used to generate a cross reference listing of all
-definitions and uses of variables, subroutines and formats in a Perl program.
-It is implemented as a backend for the Perl compiler.
-
-The report generated is in the following format:
-
- File filename1
- Subroutine subname1
- Package package1
- object1 line numbers
- object2 line numbers
- ...
- Package package2
- ...
-
-Each B<File> section reports on a single file. Each B<Subroutine> section
-reports on a single subroutine apart from the special cases
-"(definitions)" and "(main)". These report, respectively, on subroutine
-definitions found by the initial symbol table walk and on the main part of
-the program or module external to all subroutines.
-
-The report is then grouped by the B<Package> of each variable,
-subroutine or format with the special case "(lexicals)" meaning
-lexical variables. Each B<object> name (implicitly qualified by its
-containing B<Package>) includes its type character(s) at the beginning
-where possible. Lexical variables are easier to track and even
-included dereferencing information where possible.
-
-The C<line numbers> are a comma separated list of line numbers (some
-preceded by code letters) where that object is used in some way.
-Simple uses aren't preceded by a code letter. Introductions (such as
-where a lexical is first defined with C<my>) are indicated with the
-letter "i". Subroutine and method calls are indicated by the character
-"&". Subroutine definitions are indicated by "s" and format
-definitions by "f".
-
-=head1 OPTIONS
-
-Option words are separated by commas (not whitespace) and follow the
-usual conventions of compiler backend options.
-
-=over 8
-
-=item C<-oFILENAME>
-
-Directs output to C<FILENAME> instead of standard output.
-
-=item C<-r>
-
-Raw output. Instead of producing a human-readable report, outputs a line
-in machine-readable form for each definition/use of a variable/sub/format.
-
-=item C<-d>
-
-Don't output the "(definitions)" sections.
-
-=item C<-D[tO]>
-
-(Internal) debug options, probably only useful if C<-r> included.
-The C<t> option prints the object on the top of the stack as it's
-being tracked. The C<O> option prints each operator as it's being
-processed in the execution order of the program.
-
-=back
-
-=head1 BUGS
-
-Non-lexical variables are quite difficult to track through a program.
-Sometimes the type of a non-lexical variable's use is impossible to
-determine. Introductions of non-lexical non-scalars don't seem to be
-reported properly.
-
-=head1 AUTHOR
-
-Malcolm Beattie, mbeattie@sable.ox.ac.uk.
-
-=cut
-
-use strict;
-use Config;
-use B qw(peekop class comppadlist main_start svref_2object walksymtable
- OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
- );
-
-sub UNKNOWN { ["?", "?", "?"] }
-
-my @pad; # lexicals in current pad
- # as ["(lexical)", type, name]
-my %done; # keyed by $$op: set when each $op is done
-my $top = UNKNOWN; # shadows top element of stack as
- # [pack, type, name] (pack can be "(lexical)")
-my $file; # shadows current filename
-my $line; # shadows current line number
-my $subname; # shadows current sub name
-my %table; # Multi-level hash to record all uses etc.
-my @todo = (); # List of CVs that need processing
-
-my %code = (intro => "i", used => "",
- subdef => "s", subused => "&",
- formdef => "f", meth => "->");
-
-
-# Options
-my ($debug_op, $debug_top, $nodefs, $raw);
-
-sub process {
- my ($var, $event) = @_;
- my ($pack, $type, $name) = @$var;
- if ($type eq "*") {
- if ($event eq "used") {
- return;
- } elsif ($event eq "subused") {
- $type = "&";
- }
- }
- $type =~ s/(.)\*$/$1/g;
- if ($raw) {
- printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
- $file, $subname, $line, $pack, $type, $name, $event;
- } else {
- # Wheee
- push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
- $line);
- }
-}
-
-sub load_pad {
- my $padlist = shift;
- my ($namelistav, $vallistav, @namelist, $ix);
- @pad = ();
- return if class($padlist) eq "SPECIAL";
- ($namelistav,$vallistav) = $padlist->ARRAY;
- @namelist = $namelistav->ARRAY;
- for ($ix = 1; $ix < @namelist; $ix++) {
- my $namesv = $namelist[$ix];
- next if class($namesv) eq "SPECIAL";
- my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
- $pad[$ix] = ["(lexical)", $type || '?', $name || '?'];
- }
- if ($Config{useithreads}) {
- my (@vallist);
- @vallist = $vallistav->ARRAY;
- for ($ix = 1; $ix < @vallist; $ix++) {
- my $valsv = $vallist[$ix];
- next unless class($valsv) eq "GV";
- # these pad GVs don't have corresponding names, so same @pad
- # array can be used without collisions
- $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
- }
- }
-}
-
-sub xref {
- my $start = shift;
- my $op;
- for ($op = $start; $$op; $op = $op->next) {
- last if $done{$$op}++;
- warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
- warn peekop($op), "\n" if $debug_op;
- my $opname = $op->name;
- if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
- xref($op->other);
- } elsif ($opname eq "match" || $opname eq "subst") {
- xref($op->pmreplstart);
- } elsif ($opname eq "substcont") {
- xref($op->other->pmreplstart);
- $op = $op->other;
- redo;
- } elsif ($opname eq "enterloop") {
- xref($op->redoop);
- xref($op->nextop);
- xref($op->lastop);
- } elsif ($opname eq "subst") {
- xref($op->pmreplstart);
- } else {
- no strict 'refs';
- my $ppname = "pp_$opname";
- &$ppname($op) if defined(&$ppname);
- }
- }
-}
-
-sub xref_cv {
- my $cv = shift;
- my $pack = $cv->GV->STASH->NAME;
- $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
- load_pad($cv->PADLIST);
- xref($cv->START);
- $subname = "(main)";
-}
-
-sub xref_object {
- my $cvref = shift;
- xref_cv(svref_2object($cvref));
-}
-
-sub xref_main {
- $subname = "(main)";
- load_pad(comppadlist);
- xref(main_start);
- while (@todo) {
- xref_cv(shift @todo);
- }
-}
-
-sub pp_nextstate {
- my $op = shift;
- $file = $op->file;
- $line = $op->line;
- $top = UNKNOWN;
-}
-
-sub pp_padsv {
- my $op = shift;
- $top = $pad[$op->targ];
- process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
-}
-
-sub pp_padav { pp_padsv(@_) }
-sub pp_padhv { pp_padsv(@_) }
-
-sub deref {
- my ($op, $var, $as) = @_;
- $var->[1] = $as . $var->[1];
- process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
-}
-
-sub pp_rv2cv { deref(shift, $top, "&"); }
-sub pp_rv2hv { deref(shift, $top, "%"); }
-sub pp_rv2sv { deref(shift, $top, "\$"); }
-sub pp_rv2av { deref(shift, $top, "\@"); }
-sub pp_rv2gv { deref(shift, $top, "*"); }
-
-sub pp_gvsv {
- my $op = shift;
- my $gv;
- if ($Config{useithreads}) {
- $top = $pad[$op->padix];
- $top = UNKNOWN unless $top;
- $top->[1] = '$';
- }
- else {
- $gv = $op->gv;
- $top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
- }
- process($top, $op->private & OPpLVAL_INTRO ||
- $op->private & OPpOUR_INTRO ? "intro" : "used");
-}
-
-sub pp_gv {
- my $op = shift;
- my $gv;
- if ($Config{useithreads}) {
- $top = $pad[$op->padix];
- $top = UNKNOWN unless $top;
- $top->[1] = '*';
- }
- else {
- $gv = $op->gv;
- $top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
- }
- process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
-}
-
-sub pp_const {
- my $op = shift;
- my $sv = $op->sv;
- # constant could be in the pad (under useithreads)
- if ($$sv) {
- $top = ["?", "",
- (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
- ? cstring($sv->PV) : "?"];
- }
- else {
- $top = $pad[$op->targ];
- $top = UNKNOWN unless $top;
- }
-}
-
-sub pp_method {
- my $op = shift;
- $top = ["(method)", "->".$top->[1], $top->[2]];
-}
-
-sub pp_entersub {
- my $op = shift;
- if ($top->[1] eq "m") {
- process($top, "meth");
- } else {
- process($top, "subused");
- }
- $top = UNKNOWN;
-}
-
-#
-# Stuff for cross referencing definitions of variables and subs
-#
-
-sub B::GV::xref {
- my $gv = shift;
- my $cv = $gv->CV;
- if ($$cv) {
- #return if $done{$$cv}++;
- $file = $gv->FILE;
- $line = $gv->LINE;
- process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
- push(@todo, $cv);
- }
- my $form = $gv->FORM;
- if ($$form) {
- return if $done{$$form}++;
- $file = $gv->FILE;
- $line = $gv->LINE;
- process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
- }
-}
-
-sub xref_definitions {
- my ($pack, %exclude);
- return if $nodefs;
- $subname = "(definitions)";
- foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
- strict vars FileHandle Exporter Carp PerlIO::Layer
- attributes utf8 warnings)) {
- $exclude{$pack."::"} = 1;
- }
- no strict qw(vars refs);
- walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
-}
-
-sub output {
- return if $raw;
- my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
- $perpack, $pername, $perev);
- foreach $file (sort(keys(%table))) {
- $perfile = $table{$file};
- print "File $file\n";
- foreach $subname (sort(keys(%$perfile))) {
- $persubname = $perfile->{$subname};
- print " Subroutine $subname\n";
- foreach $pack (sort(keys(%$persubname))) {
- $perpack = $persubname->{$pack};
- print " Package $pack\n";
- foreach $name (sort(keys(%$perpack))) {
- $pername = $perpack->{$name};
- my @lines;
- foreach $ev (qw(intro formdef subdef meth subused used)) {
- $perev = $pername->{$ev};
- if (defined($perev) && @$perev) {
- my $code = $code{$ev};
- push(@lines, map("$code$_", @$perev));
- }
- }
- printf " %-16s %s\n", $name, join(", ", @lines);
- }
- }
- }
- }
-}
-
-sub compile {
- my @options = @_;
- my ($option, $opt, $arg);
- OPTION:
- while ($option = shift @options) {
- if ($option =~ /^-(.)(.*)/) {
- $opt = $1;
- $arg = $2;
- } else {
- unshift @options, $option;
- last OPTION;
- }
- if ($opt eq "-" && $arg eq "-") {
- shift @options;
- last OPTION;
- } elsif ($opt eq "o") {
- $arg ||= shift @options;
- open(STDOUT, ">$arg") or return "$arg: $!\n";
- } elsif ($opt eq "d") {
- $nodefs = 1;
- } elsif ($opt eq "r") {
- $raw = 1;
- } elsif ($opt eq "D") {
- $arg ||= shift @options;
- foreach $arg (split(//, $arg)) {
- if ($arg eq "o") {
- B->debug(1);
- } elsif ($arg eq "O") {
- $debug_op = 1;
- } elsif ($arg eq "t") {
- $debug_top = 1;
- }
- }
- }
- }
- if (@options) {
- return sub {
- my $objname;
- xref_definitions();
- foreach $objname (@options) {
- $objname = "main::$objname" unless $objname =~ /::/;
- eval "xref_object(\\&$objname)";
- die "xref_object(\\&$objname) failed: $@" if $@;
- }
- output();
- }
- } else {
- return sub {
- xref_definitions();
- xref_main();
- output();
- }
- }
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/B/assemble b/Master/tlpkg/installer/perllib/B/assemble
deleted file mode 100644
index 43cc5bc4b33..00000000000
--- a/Master/tlpkg/installer/perllib/B/assemble
+++ /dev/null
@@ -1,30 +0,0 @@
-use B::Assembler qw(assemble_fh);
-use FileHandle;
-
-my ($filename, $fh, $out);
-
-if ($ARGV[0] eq "-d") {
- B::Assembler::debug(1);
- shift;
-}
-
-$out = \*STDOUT;
-
-if (@ARGV == 0) {
- $fh = \*STDIN;
- $filename = "-";
-} elsif (@ARGV == 1) {
- $filename = $ARGV[0];
- $fh = new FileHandle "<$filename";
-} elsif (@ARGV == 2) {
- $filename = $ARGV[0];
- $fh = new FileHandle "<$filename";
- $out = new FileHandle ">$ARGV[1]";
-} else {
- die "Usage: assemble [filename] [outfilename]\n";
-}
-
-binmode $out;
-$SIG{__WARN__} = sub { warn "$filename:@_" };
-$SIG{__DIE__} = sub { die "$filename: @_" };
-assemble_fh($fh, sub { print $out @_ });
diff --git a/Master/tlpkg/installer/perllib/B/cc_harness b/Master/tlpkg/installer/perllib/B/cc_harness
deleted file mode 100644
index 79f8727a8f0..00000000000
--- a/Master/tlpkg/installer/perllib/B/cc_harness
+++ /dev/null
@@ -1,12 +0,0 @@
-use Config;
-
-$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE";
-
-if (!grep(/^-[cS]$/, @ARGV)) {
- $linkargs = sprintf("%s $libdir/$Config{libperl} %s",
- @Config{qw(ldflags libs)});
-}
-
-$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs";
-print "$cccmd\n";
-exec $cccmd;
diff --git a/Master/tlpkg/installer/perllib/B/disassemble b/Master/tlpkg/installer/perllib/B/disassemble
deleted file mode 100644
index 6530b809502..00000000000
--- a/Master/tlpkg/installer/perllib/B/disassemble
+++ /dev/null
@@ -1,22 +0,0 @@
-use B::Disassembler qw(disassemble_fh);
-use FileHandle;
-
-my $fh;
-if (@ARGV == 0) {
- $fh = \*STDIN;
-} elsif (@ARGV == 1) {
- $fh = new FileHandle "<$ARGV[0]";
-} else {
- die "Usage: disassemble [filename]\n";
-}
-
-sub print_insn {
- my ($insn, $arg) = @_;
- if (defined($arg)) {
- printf "%s %s\n", $insn, $arg;
- } else {
- print $insn, "\n";
- }
-}
-
-disassemble_fh($fh, \&print_insn);
diff --git a/Master/tlpkg/installer/perllib/B/makeliblinks b/Master/tlpkg/installer/perllib/B/makeliblinks
deleted file mode 100644
index 82560783c01..00000000000
--- a/Master/tlpkg/installer/perllib/B/makeliblinks
+++ /dev/null
@@ -1,54 +0,0 @@
-use File::Find;
-use Config;
-
-if (@ARGV != 2) {
- warn <<"EOT";
-Usage: makeliblinks libautodir targetdir
-where libautodir is the architecture-dependent auto directory
-(e.g. $Config::Config{archlib}/auto).
-EOT
- exit 2;
-}
-
-my ($libautodir, $targetdir) = @ARGV;
-
-# Calculate relative path prefix from $targetdir to $libautodir
-sub relprefix {
- my ($to, $from) = @_;
- my $up;
- for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) {
- $from =~ s(
- [^/]+ (?# a group of non-slashes)
- /* (?# maybe with some trailing slashes)
- $ (?# at the end of the path)
- )()x;
- }
- return (("../" x $up) . substr($to, length($from)));
-}
-
-my $relprefix = relprefix($libautodir, $targetdir);
-
-my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)};
-
-sub link_if_library {
- if (/\.($dlext|$lib_ext)$/o) {
- my $ext = $1;
- my $name = $File::Find::name;
- if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") {
- die "directory of $name doesn't match $libautodir\n";
- }
- substr($name, 0, length($libautodir) + 1) = '';
- my @parts = split(m(/), $name);
- if ($parts[-1] ne "$parts[-2].$ext") {
- die "module name $_ doesn't match its directory $libautodir\n";
- }
- pop @parts;
- my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext";
- print "$libpath -> $relprefix/$name\n";
- symlink("$relprefix/$name", $libpath)
- or warn "above link failed with error: $!\n";
- }
-}
-
-find(\&link_if_library, $libautodir);
-exit 0;
diff --git a/Master/tlpkg/installer/perllib/Carp.pm b/Master/tlpkg/installer/perllib/Carp.pm
deleted file mode 100644
index 1a814ead34f..00000000000
--- a/Master/tlpkg/installer/perllib/Carp.pm
+++ /dev/null
@@ -1,274 +0,0 @@
-package Carp;
-
-our $VERSION = '1.04';
-
-=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
-
-shortmess - return the message that carp and croak produce
-
-longmess - return the message that cluck and confess produce
-
-=head1 SYNOPSIS
-
- use Carp;
- croak "We're outta here!";
-
- use Carp qw(cluck);
- cluck "This is how we got here!";
-
- print FH Carp::shortmess("This will have caller's details added");
- print FH Carp::longmess("This will have stack backtrace added");
-
-=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 carp,
-croak or shortmess 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 shortmess works. What
-it does is search the call-stack for a function call stack where
-it hasn't been told that there shouldn't be an error. If every
-call is marked safe, it then gives up and gives a full stack
-backtrace instead. In other words it presumes that the first likely
-looking potential suspect is guilty. Its 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 @CARP_NOT, or
-(if that array is empty) @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 @ISA
-with @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 Carp is safe. (This rule is what keeps it from
-reporting the error where you call carp/croak/shortmess.)
-
-=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.
-
-=cut
-
-# This package is heavily used. Be small. Be fast. Be good.
-
-# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
-# _almost_ complete understanding of the package. Corrections and
-# comments are welcome.
-
-# The members of %Internal are packages that are internal to perl.
-# Carp will not report errors from within these packages if it
-# can. The members of %CarpInternal are internal to Perl's warning
-# system. Carp will not report errors from within these packages
-# either, and will not report calls *to* these packages for carp and
-# croak. They replace $CarpLevel, which is deprecated. The
-# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
-# text and function arguments should be formatted when printed.
-
-# Comments added by Jos I. Boumans <kane@dwim.org> 11-Aug-2004
-# I can not get %CarpInternal or %Internal to work as advertised,
-# therefor leaving it out of the below documentation.
-# $CarpLevel may be decprecated according to the last comment, but
-# after 6 years, it's still around and in heavy use ;)
-
-=pod
-
-=head1 GLOBAL VARIABLES
-
-=head2 $Carp::CarpLevel
-
-This variable determines how many call frames are to be skipped when
-reporting where an error occurred on a call to one of C<Carp>'s
-functions. For example:
-
- $Carp::CarpLevel = 1;
- sub bar { .... or _error('Wrong input') }
- sub _error { Carp::carp(@_) }
-
-This would make Carp report the error as coming from C<bar>'s caller,
-rather than from C<_error>'s caller, as it normally would.
-
-Defaults to C<0>.
-
-=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> use the C<longmess> function at all times.
-This effectively means that all calls to C<carp> become C<cluck> and
-all calls to C<croak> become C<confess>.
-
-Note, this is analogous to using C<use Carp 'verbose'>.
-
-Defaults to C<0>.
-
-=cut
-
-
-$CarpInternal{Carp}++;
-$CarpInternal{warnings}++;
-$CarpLevel = 0; # How many extra package levels to skip on carp.
- # How many calls to skip on confess.
- # Reconciling these notions is hard, use
- # %Internal and %CarpInternal instead.
-$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
-$MaxArgLen = 64; # How much of each argument to print. 0 = all.
-$MaxArgNums = 8; # How many arguments to print. 0 = all.
-$Verbose = 0; # If true then make shortmess call longmess instead
-
-require Exporter;
-@ISA = ('Exporter');
-@EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(cluck verbose longmess shortmess);
-@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
-
-=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.
-
-=cut
-
-# 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';
- return @_;
-}
-
-
-# longmess() crawls all the way up the stack reporting on all the function
-# calls made. The error string, $error, is originally constructed from the
-# arguments passed into longmess() via confess(), cluck() or shortmess().
-# This gets appended with the stack trace messages which are generated for
-# each function call on the stack.
-
-sub longmess {
- {
- local($@, $!);
- # XXX fix require to not clear $@ or $!?
- # don't use require unless we need to (for Safe compartments)
- require Carp::Heavy unless $INC{"Carp/Heavy.pm"};
- }
- # Icky backwards compatibility wrapper. :-(
- my $call_pack = caller();
- if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
- return longmess_heavy(@_);
- }
- else {
- local $CarpLevel = $CarpLevel + 1;
- return longmess_heavy(@_);
- }
-}
-
-
-# shortmess() is called by carp() and croak() to skip all the way up to
-# the top-level caller's package and report the error from there. confess()
-# and cluck() generate a full stack trace so they call longmess() to
-# generate that. In verbose mode shortmess() calls longmess() so
-# you always get a stack trace
-
-sub shortmess { # Short-circuit &longmess if called via multiple packages
- {
- local($@, $!);
- # XXX fix require to not clear $@ or $!?
- # don't use require unless we need to (for Safe compartments)
- require Carp::Heavy unless $INC{"Carp/Heavy.pm"};
- }
- # Icky backwards compatibility wrapper. :-(
- my $call_pack = caller();
- local @CARP_NOT = caller();
- shortmess_heavy(@_);
-}
-
-
-# the following four functions call longmess() or shortmess() depending on
-# whether they should generate a full stack trace (confess() and cluck())
-# or simply report the caller's package (croak() and carp()), respectively.
-# confess() and croak() die, carp() and cluck() warn.
-
-sub croak { die shortmess @_ }
-sub confess { die longmess @_ }
-sub carp { warn shortmess @_ }
-sub cluck { warn longmess @_ }
-
-1;
diff --git a/Master/tlpkg/installer/perllib/Carp/Heavy.pm b/Master/tlpkg/installer/perllib/Carp/Heavy.pm
deleted file mode 100644
index 55bca2b421a..00000000000
--- a/Master/tlpkg/installer/perllib/Carp/Heavy.pm
+++ /dev/null
@@ -1,241 +0,0 @@
-# Carp::Heavy uses some variables in common with Carp.
-package Carp;
-
-=head1 NAME
-
-Carp::Heavy - heavy machinery, no user serviceable parts inside
-
-=cut
-
-# use strict; # not yet
-
-# On one line so MakeMaker will see it.
-use Carp; our $VERSION = $Carp::VERSION;
-
-our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
-
-sub caller_info {
- my $i = shift(@_) + 1;
- package DB;
- my %call_info;
- @call_info{
- qw(pack file line sub has_args wantarray evaltext is_require)
- } = caller($i);
-
- unless (defined $call_info{pack}) {
- return ();
- }
-
- my $sub_name = Carp::get_subname(\%call_info);
- if ($call_info{has_args}) {
- my @args = map {Carp::format_arg($_)} @DB::args;
- if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
- $#args = $MaxArgNums;
- push @args, '...';
- }
- # Push the args onto the subroutine
- $sub_name .= '(' . join (', ', @args) . ')';
- }
- $call_info{sub_name} = $sub_name;
- return wantarray() ? %call_info : \%call_info;
-}
-
-# Transform an argument to a function into a string.
-sub format_arg {
- my $arg = shift;
- if (ref($arg)) {
- $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
- }elsif (not defined($arg)) {
- $arg = 'undef';
- }
- $arg =~ s/'/\\'/g;
- $arg = str_len_trim($arg, $MaxArgLen);
-
- # Quote it?
- $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
-
- # The following handling of "control chars" is direct from
- # the original code - it is broken on Unicode though.
- # Suggestions?
- utf8::is_utf8($arg)
- or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
- return $arg;
-}
-
-# Takes an inheritance cache and a package and returns
-# an anon hash of known inheritances and anon array of
-# inheritances which consequences have not been figured
-# for.
-sub get_status {
- my $cache = shift;
- my $pkg = shift;
- $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
- return @{$cache->{$pkg}};
-}
-
-# Takes the info from caller() and figures out the name of
-# the sub/require/eval
-sub get_subname {
- my $info = shift;
- if (defined($info->{evaltext})) {
- my $eval = $info->{evaltext};
- if ($info->{is_require}) {
- return "require $eval";
- }
- else {
- $eval =~ s/([\\\'])/\\$1/g;
- return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
- }
- }
-
- return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
-}
-
-# Figures out what call (from the point of view of the caller)
-# the long error backtrace should start at.
-sub long_error_loc {
- my $i;
- my $lvl = $CarpLevel;
- {
- my $pkg = caller(++$i);
- unless(defined($pkg)) {
- # This *shouldn't* happen.
- if (%Internal) {
- local %Internal;
- $i = long_error_loc();
- last;
- }
- else {
- # OK, now I am irritated.
- return 2;
- }
- }
- redo if $CarpInternal{$pkg};
- redo unless 0 > --$lvl;
- redo if $Internal{$pkg};
- }
- return $i - 1;
-}
-
-
-sub longmess_heavy {
- return @_ if ref($_[0]); # don't break references as exceptions
- my $i = long_error_loc();
- return ret_backtrace($i, @_);
-}
-
-# Returns a full stack backtrace starting from where it is
-# told.
-sub ret_backtrace {
- my ($i, @error) = @_;
- my $mess;
- my $err = join '', @error;
- $i++;
-
- my $tid_msg = '';
- if (defined &Thread::tid) {
- my $tid = Thread->self->tid;
- $tid_msg = " thread $tid" if $tid;
- }
-
- my %i = caller_info($i);
- $mess = "$err at $i{file} line $i{line}$tid_msg\n";
-
- while (my %i = caller_info(++$i)) {
- $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
- }
-
- return $mess;
-}
-
-sub ret_summary {
- my ($i, @error) = @_;
- my $err = join '', @error;
- $i++;
-
- my $tid_msg = '';
- if (defined &Thread::tid) {
- my $tid = Thread->self->tid;
- $tid_msg = " thread $tid" if $tid;
- }
-
- my %i = caller_info($i);
- return "$err at $i{file} line $i{line}$tid_msg\n";
-}
-
-
-sub short_error_loc {
- my $cache;
- my $i = 1;
- my $lvl = $CarpLevel;
- {
- my $called = caller($i++);
- my $caller = caller($i);
- return 0 unless defined($caller); # What happened?
- redo if $Internal{$caller};
- redo if $CarpInternal{$called};
- redo if trusts($called, $caller, $cache);
- redo if trusts($caller, $called, $cache);
- redo unless 0 > --$lvl;
- }
- return $i - 1;
-}
-
-sub shortmess_heavy {
- return longmess_heavy(@_) if $Verbose;
- return @_ if ref($_[0]); # don't break references as exceptions
- my $i = short_error_loc();
- if ($i) {
- ret_summary($i, @_);
- }
- else {
- longmess_heavy(@_);
- }
-}
-
-# If a string is too long, trims it with ...
-sub str_len_trim {
- my $str = shift;
- my $max = shift || 0;
- if (2 < $max and $max < length($str)) {
- substr($str, $max - 3) = '...';
- }
- return $str;
-}
-
-# Takes two packages and an optional cache. Says whether the
-# first inherits from the second.
-#
-# Recursive versions of this have to work to avoid certain
-# possible endless loops, and when following long chains of
-# inheritance are less efficient.
-sub trusts {
- my $child = shift;
- my $parent = shift;
- my $cache = shift || {};
- my ($known, $partial) = get_status($cache, $child);
- # Figure out consequences until we have an answer
- while (@$partial and not exists $known->{$parent}) {
- my $anc = shift @$partial;
- next if exists $known->{$anc};
- $known->{$anc}++;
- my ($anc_knows, $anc_partial) = get_status($cache, $anc);
- my @found = keys %$anc_knows;
- @$known{@found} = ();
- push @$partial, @$anc_partial;
- }
- return exists $known->{$parent};
-}
-
-# Takes a package and gives a list of those trusted directly
-sub trusts_directly {
- my $class = shift;
- no strict 'refs';
- no warnings 'once';
- return @{"$class\::CARP_NOT"}
- ? @{"$class\::CARP_NOT"}
- : @{"$class\::ISA"};
-}
-
-1;
-
diff --git a/Master/tlpkg/installer/perllib/Class/ISA.pm b/Master/tlpkg/installer/perllib/Class/ISA.pm
deleted file mode 100644
index e1371912e2c..00000000000
--- a/Master/tlpkg/installer/perllib/Class/ISA.pm
+++ /dev/null
@@ -1,214 +0,0 @@
-#!/usr/local/bin/perl
-# Time-stamp: "2004-12-29 20:01:02 AST" -*-Perl-*-
-
-package Class::ISA;
-require 5;
-use strict;
-use vars qw($Debug $VERSION);
-$VERSION = '0.33';
-$Debug = 0 unless defined $Debug;
-
-=head1 NAME
-
-Class::ISA -- report the search path for a class's ISA tree
-
-=head1 SYNOPSIS
-
- # Suppose you go: use Food::Fishstick, and that uses and
- # inherits from other things, which in turn use and inherit
- # from other things. And suppose, for sake of brevity of
- # example, that their ISA tree is the same as:
-
- @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
- @Food::Fish::ISA = qw(Food);
- @Food::ISA = qw(Matter);
- @Life::Fungus::ISA = qw(Life);
- @Chemicals::ISA = qw(Matter);
- @Life::ISA = qw(Matter);
- @Matter::ISA = qw();
-
- use Class::ISA;
- print "Food::Fishstick path is:\n ",
- join(", ", Class::ISA::super_path('Food::Fishstick')),
- "\n";
-
-That prints:
-
- Food::Fishstick path is:
- Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals
-
-=head1 DESCRIPTION
-
-Suppose you have a class (like Food::Fish::Fishstick) that is derived,
-via its @ISA, from one or more superclasses (as Food::Fish::Fishstick
-is from Food::Fish, Life::Fungus, and Chemicals), and some of those
-superclasses may themselves each be derived, via its @ISA, from one or
-more superclasses (as above).
-
-When, then, you call a method in that class ($fishstick->calories),
-Perl first searches there for that method, but if it's not there, it
-goes searching in its superclasses, and so on, in a depth-first (or
-maybe "height-first" is the word) search. In the above example, it'd
-first look in Food::Fish, then Food, then Matter, then Life::Fungus,
-then Life, then Chemicals.
-
-This library, Class::ISA, provides functions that return that list --
-the list (in order) of names of classes Perl would search to find a
-method, with no duplicates.
-
-=head1 FUNCTIONS
-
-=over
-
-=item the function Class::ISA::super_path($CLASS)
-
-This returns the ordered list of names of classes that Perl would
-search thru in order to find a method, with no duplicates in the list.
-$CLASS is not included in the list. UNIVERSAL is not included -- if
-you need to consider it, add it to the end.
-
-
-=item the function Class::ISA::self_and_super_path($CLASS)
-
-Just like C<super_path>, except that $CLASS is included as the first
-element.
-
-=item the function Class::ISA::self_and_super_versions($CLASS)
-
-This returns a hash whose keys are $CLASS and its
-(super-)superclasses, and whose values are the contents of each
-class's $VERSION (or undef, for classes with no $VERSION).
-
-The code for self_and_super_versions is meant to serve as an example
-for precisely the kind of tasks I anticipate that self_and_super_path
-and super_path will be used for. You are strongly advised to read the
-source for self_and_super_versions, and the comments there.
-
-=back
-
-=head1 CAUTIONARY NOTES
-
-* Class::ISA doesn't export anything. You have to address the
-functions with a "Class::ISA::" on the front.
-
-* Contrary to its name, Class::ISA isn't a class; it's just a package.
-Strange, isn't it?
-
-* Say you have a loop in the ISA tree of the class you're calling one
-of the Class::ISA functions on: say that Food inherits from Matter,
-but Matter inherits from Food (for sake of argument). If Perl, while
-searching for a method, actually discovers this cyclicity, it will
-throw a fatal error. The functions in Class::ISA effectively ignore
-this cyclicity; the Class::ISA algorithm is "never go down the same
-path twice", and cyclicities are just a special case of that.
-
-* The Class::ISA functions just look at @ISAs. But theoretically, I
-suppose, AUTOLOADs could bypass Perl's ISA-based search mechanism and
-do whatever they please. That would be bad behavior, tho; and I try
-not to think about that.
-
-* If Perl can't find a method anywhere in the ISA tree, it then looks
-in the magical class UNIVERSAL. This is rarely relevant to the tasks
-that I expect Class::ISA functions to be put to, but if it matters to
-you, then instead of this:
-
- @supers = Class::Tree::super_path($class);
-
-do this:
-
- @supers = (Class::Tree::super_path($class), 'UNIVERSAL');
-
-And don't say no-one ever told ya!
-
-* When you call them, the Class::ISA functions look at @ISAs anew --
-that is, there is no memoization, and so if ISAs change during
-runtime, you get the current ISA tree's path, not anything memoized.
-However, changing ISAs at runtime is probably a sign that you're out
-of your mind!
-
-=head1 COPYRIGHT
-
-Copyright (c) 1999, 2000 Sean M. Burke. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 AUTHOR
-
-Sean M. Burke C<sburke@cpan.org>
-
-=cut
-
-###########################################################################
-
-sub self_and_super_versions {
- no strict 'refs';
- map {
- $_ => (defined(${"$_\::VERSION"}) ? ${"$_\::VERSION"} : undef)
- } self_and_super_path($_[0])
-}
-
-# Also consider magic like:
-# no strict 'refs';
-# my %class2SomeHashr =
-# map { defined(%{"$_\::SomeHash"}) ? ($_ => \%{"$_\::SomeHash"}) : () }
-# Class::ISA::self_and_super_path($class);
-# to get a hash of refs to all the defined (and non-empty) hashes in
-# $class and its superclasses.
-#
-# Or even consider this incantation for doing something like hash-data
-# inheritance:
-# no strict 'refs';
-# %union_hash =
-# map { defined(%{"$_\::SomeHash"}) ? %{"$_\::SomeHash"}) : () }
-# reverse(Class::ISA::self_and_super_path($class));
-# Consider that reverse() is necessary because with
-# %foo = ('a', 'wun', 'b', 'tiw', 'a', 'foist');
-# $foo{'a'} is 'foist', not 'wun'.
-
-###########################################################################
-sub super_path {
- my @ret = &self_and_super_path(@_);
- shift @ret if @ret;
- return @ret;
-}
-
-#--------------------------------------------------------------------------
-sub self_and_super_path {
- # Assumption: searching is depth-first.
- # Assumption: '' (empty string) can't be a class package name.
- # Note: 'UNIVERSAL' is not given any special treatment.
- return () unless @_;
-
- my @out = ();
-
- my @in_stack = ($_[0]);
- my %seen = ($_[0] => 1);
-
- my $current;
- while(@in_stack) {
- next unless defined($current = shift @in_stack) && length($current);
- print "At $current\n" if $Debug;
- push @out, $current;
- no strict 'refs';
- unshift @in_stack,
- map
- { my $c = $_; # copy, to avoid being destructive
- substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
- # Canonize the :: -> main::, ::foo -> main::foo thing.
- # Should I ever canonize the Foo'Bar = Foo::Bar thing?
- $seen{$c}++ ? () : $c;
- }
- @{"$current\::ISA"}
- ;
- # I.e., if this class has any parents (at least, ones I've never seen
- # before), push them, in order, onto the stack of classes I need to
- # explore.
- }
-
- return @out;
-}
-#--------------------------------------------------------------------------
-1;
-
-__END__
diff --git a/Master/tlpkg/installer/perllib/Class/Struct.pm b/Master/tlpkg/installer/perllib/Class/Struct.pm
deleted file mode 100644
index 7a9af54faf8..00000000000
--- a/Master/tlpkg/installer/perllib/Class/Struct.pm
+++ /dev/null
@@ -1,636 +0,0 @@
-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/installer/perllib/Config.pm b/Master/tlpkg/installer/perllib/Config.pm
deleted file mode 100644
index 7e5ad77b30a..00000000000
--- a/Master/tlpkg/installer/perllib/Config.pm
+++ /dev/null
@@ -1,95 +0,0 @@
-# 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
-@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 (v5.8.8) doesn't match executable version ($])"
- unless $^V;
-
-$^V eq v5.8.8
- or die "Perl lib version (v5.8.8) 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 => 'x:\\perl\\lib',
- archname => 'MSWin32-x86-multi-thread',
- cc => 'gcc',
- d_readlink => undef,
- d_symlink => undef,
- dlsrc => 'dl_win32.xs',
- dont_use_nlink => undef,
- exe_ext => '.exe',
- inc_version_list => '',
- intsize => '4',
- ldlibpthname => '',
- libpth => 'x:\\msys\\mingw\\lib',
- osname => 'MSWin32',
- osvers => '5.1',
- path_sep => ';',
- privlibexp => 'x:\\perl\\lib',
- scriptdir => 'x:\\perl\\bin',
- sitearchexp => 'x:\\perl\\site\\lib',
- sitelibexp => 'x:\\perl\\site\\lib',
- useithreads => 'define',
- usevendorprefix => undef,
- version => '5.8.8',
-};
diff --git a/Master/tlpkg/installer/perllib/Config_heavy.pl b/Master/tlpkg/installer/perllib/Config_heavy.pl
deleted file mode 100644
index 919d4637cf2..00000000000
--- a/Master/tlpkg/installer/perllib/Config_heavy.pl
+++ /dev/null
@@ -1,1185 +0,0 @@
-# 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: siepo@xpeco
-### Target system: WIN32
-
-our $summary = <<'!END!';
-Summary of my $package (revision $revision $version_patchlevel_string) configuration:
- Platform:
- osname=$osname, osvers=$osvers, archname=$archname
- uname='$myuname'
- config_args='$config_args'
- hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
- usethreads=$usethreads use5005threads=$use5005threads 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 = $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'
-Mcc='Mcc'
-PATCHLEVEL='8'
-PERL_API_REVISION='5'
-PERL_API_SUBVERSION='0'
-PERL_API_VERSION='8'
-PERL_CONFIG_SH='true'
-PERL_PATCHLEVEL='8'
-PERL_REVISION='5'
-PERL_SUBVERSION='8'
-PERL_VERSION='8'
-RCSfile='$RCSfile'
-Revision='$Revision'
-SUBVERSION='8'
-Source=''
-State=''
-_a='.a'
-_exe='.exe'
-_o='.o'
-afs='false'
-afsroot='/afs'
-alignbytes='8'
-ansi2knr=''
-aphostname=''
-api_revision='5'
-api_subversion='0'
-api_version='8'
-api_versionstring='5.8.0'
-ar='ar'
-archlib='x:\perl\lib'
-archlibexp='x:\perl\lib'
-archname64=''
-archname='MSWin32-x86-multi-thread'
-archobjs=''
-asctime_r_proto='0'
-awk='awk'
-baserev='5'
-bash=''
-bin='x:\perl\bin'
-binexp='x:\perl\bin'
-bison=''
-byacc='byacc'
-byteorder='1234'
-c=''
-castflags='0'
-cat='type'
-cc='gcc'
-cccdlflags=' '
-ccdlflags=' '
-ccflags=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DPERL_IMPLICIT_CONTEXT -fno-strict-aliasing -DPERL_MSVCRT_READFIX'
-ccflags_uselargefiles=''
-ccname='gcc'
-ccsymbols=''
-ccversion=''
-cf_by='siepo'
-cf_email='siepo@xpeco'
-cf_time='Sun May 27 17:53:00 2007'
-charsize='1'
-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_asctime_r='undef'
-d_atolf='undef'
-d_atoll='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_bzero='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_crypt='define'
-d_crypt_r='undef'
-d_csh='undef'
-d_ctermid_r='undef'
-d_ctime_r='undef'
-d_cuserid='undef'
-d_dbl_dig='define'
-d_dbminitproto='undef'
-d_difftime='define'
-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_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_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_gmtime_r='undef'
-d_gnulibc='undef'
-d_grpasswd='undef'
-d_hasmntopt='undef'
-d_htonl='define'
-d_ilogbl='undef'
-d_index='undef'
-d_inetaton='undef'
-d_int64_t='undef'
-d_isascii='define'
-d_isfinite='undef'
-d_isinf='undef'
-d_isnan='define'
-d_isnanl='undef'
-d_killpg='undef'
-d_lchown='undef'
-d_ldbl_dig='define'
-d_libm_lib_version='undef'
-d_link='define'
-d_localtime_r='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_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_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_procselfexe='undef'
-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='undef'
-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_sigprocmask='undef'
-d_sigsetjmp='undef'
-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_times='define'
-d_tm_tm_gmtoff='undef'
-d_tm_tm_zone='undef'
-d_tmpnam_r='undef'
-d_truncate='undef'
-d_ttyname_r='undef'
-d_tzname='define'
-d_u32align='define'
-d_ualarm='undef'
-d_umask='define'
-d_uname='define'
-d_union_semun='define'
-d_unordered='undef'
-d_unsetenv='undef'
-d_usleep='undef'
-d_usleepproto='undef'
-d_ustat='undef'
-d_vendorarch='undef'
-d_vendorbin='undef'
-d_vendorlib='undef'
-d_vendorscript='undef'
-d_vfork='undef'
-d_void_closedir='undef'
-d_voidsig='define'
-d_voidtty=''
-d_volatile='define'
-d_vprintf='define'
-d_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'
-dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call IO List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attrs 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='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Errno Fcntl File/Glob Filter/Util/Call IO List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attrs re threads threads/shared'
-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_bsdioctl=''
-i_crypt='undef'
-i_db='undef'
-i_dbm='undef'
-i_dirent='define'
-i_dld='undef'
-i_dlfcn='define'
-i_fcntl='define'
-i_float='define'
-i_fp='undef'
-i_fp_class='undef'
-i_gdbm='undef'
-i_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_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_sysresrc='undef'
-i_syssecrt='undef'
-i_sysselct='undef'
-i_syssockio='undef'
-i_sysstat='define'
-i_sysstatfs='undef'
-i_sysstatvfs='undef'
-i_systime='undef'
-i_systimek='undef'
-i_systimes='undef'
-i_systypes='define'
-i_sysuio='undef'
-i_sysun='undef'
-i_sysutsname='undef'
-i_sysvfs='undef'
-i_syswait='undef'
-i_termio='undef'
-i_termios='undef'
-i_time='define'
-i_unistd='undef'
-i_ustat='undef'
-i_utime='define'
-i_values='undef'
-i_varargs='undef'
-i_varhdr='varargs.h'
-i_vfork='undef'
-ignore_versioned_solibs=''
-inc_version_list=''
-inc_version_list_init='0'
-incpath='x:\msys\mingw\include'
-inews=''
-installarchlib='x:\perl\lib'
-installbin='x:\perl\bin'
-installhtml1dir=''
-installhtml3dir=''
-installhtmldir='x:\perl\html'
-installhtmlhelpdir='x:\perl\htmlhelp'
-installman1dir='x:\perl\man\man1'
-installman3dir='x:\perl\man\man3'
-installprefix='x:\perl'
-installprefixexp='x:\perl'
-installprivlib='x:\perl\lib'
-installscript='x:\perl\bin'
-installsitearch='x:\perl\site\lib'
-installsitebin='x:\perl\bin'
-installsitehtml1dir=''
-installsitehtml3dir=''
-installsitelib='x:\perl\site\lib'
-installsiteman1dir=''
-installsiteman3dir=''
-installsitescript=''
-installstyle='lib'
-installusrbinperl='undef'
-installvendorarch=''
-installvendorbin=''
-installvendorhtml1dir=''
-installvendorhtml3dir=''
-installvendorlib=''
-installvendorman1dir=''
-installvendorman3dir=''
-installvendorscript=''
-intsize='4'
-issymlink=''
-ivdformat='"ld"'
-ivsize='4'
-ivtype='long'
-known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attrs re threads threads/shared'
-ksh=''
-ld='g++'
-lddlflags='-mdll -s -L"x:\perl\lib\CORE" -L"x:\msys\mingw\lib"'
-ldflags='-s -L"x:\perl\lib\CORE" -L"x:\msys\mingw\lib"'
-ldflags_uselargefiles=''
-ldlibpthname=''
-less='less'
-lib_ext='.a'
-libc='-lmsvcrt'
-libperl='libperl58.a'
-libpth='x:\msys\mingw\lib'
-libs=' -lmsvcrt -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'
-mail=''
-mailx=''
-make='dmake'
-make_set_make='#'
-mallocobj='malloc.o'
-mallocsrc='malloc.c'
-malloctype='void *'
-man1dir='x:\perl\man\man1'
-man1direxp='x:\perl\man\man1'
-man1ext='1'
-man3dir='x:\perl\man\man3'
-man3direxp='x:\perl\man\man3'
-man3ext='3'
-mips_type=''
-mistrustnm=''
-mkdir='mkdir'
-mmaptype='void *'
-modetype='mode_t'
-more='more /e'
-multiarch='undef'
-mv=''
-myarchname='MSWin32'
-mydomain=''
-myhostname=''
-myuname=''
-n='-n'
-need_va_copy='undef'
-netdb_hlen_type='int'
-netdb_host_type='char *'
-netdb_name_type='char *'
-netdb_net_type='long'
-nm='nm'
-nm_opt=''
-nm_so_opt=''
-nonxs_ext='Errno'
-nroff=''
-nvEUformat='"E"'
-nvFUformat='"F"'
-nvGUformat='"G"'
-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=''
-path_sep=';'
-perl5=''
-perl='perl'
-perl_patchlevel=''
-perladmin=''
-perllibs=' -lmsvcrt -lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32'
-perlpath='x:\perl\bin\perl.exe'
-pg=''
-phostname='hostname'
-pidtype='int'
-plibpth=''
-pmake=''
-pr=''
-prefix='x:\perl'
-prefixexp='x:\perl'
-privlib='x:\perl\lib'
-privlibexp='x:\perl\lib'
-procselfexe=''
-prototype='define'
-ptrsize='4'
-quadkind='5'
-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'
-rmail=''
-run=''
-runnm='true'
-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='x:\perl\bin'
-scriptdirexp='x:\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='x:\perl\site\lib'
-sitearchexp='x:\perl\site\lib'
-sitebin='x:\perl\site\bin'
-sitebinexp='x:\perl\site\bin'
-sitehtml1dir=''
-sitehtml1direxp=''
-sitehtml3dir=''
-sitehtml3direxp=''
-sitelib='x:\perl\site\lib'
-sitelib_stem=''
-sitelibexp='x:\perl\site\lib'
-siteman1dir=''
-siteman1direxp=''
-siteman3dir=''
-siteman3direxp=''
-siteprefix='x:\perl\site'
-siteprefixexp='x:\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=' '
-stdchar='char'
-stdio_base='((fp)->_base)'
-stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
-stdio_cnt='((fp)->_cnt)'
-stdio_filbuf=''
-stdio_ptr='((fp)->_ptr)'
-stdio_stream_array=''
-strerror_r_proto='0'
-strings='/usr/include/string.h'
-submit=''
-subversion=''
-sysman='/usr/man/man1'
-tail=''
-tar=''
-targetarch=''
-tbl=''
-tee=''
-test=''
-timeincl='/usr/include/sys/time.h '
-timetype='time_t'
-tmpnam_r_proto='0'
-to=':'
-touch='touch'
-tr=''
-trnl='\012'
-troff=''
-ttyname_r_proto='0'
-u16size='2'
-u16type='unsigned short'
-u32size='4'
-u32type='unsigned long'
-u64size='8'
-u64type='unsigned long long'
-u8size='1'
-u8type='unsigned char'
-uidformat='"ld"'
-uidsign='-1'
-uidsize='4'
-uidtype='uid_t'
-uname='uname'
-uniq='uniq'
-uquadtype='unsigned long long'
-use5005threads='undef'
-use64bitall='undef'
-use64bitint='undef'
-usecrosscompile='undef'
-usedl='define'
-usefaststdio='define'
-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='yes'
-usesitecustomize='undef'
-usesocks='undef'
-usethreads='define'
-usevendorprefix='undef'
-usevfork='false'
-usrinc='/usr/include'
-uuname=''
-uvXUformat='"lX"'
-uvoformat='"lo"'
-uvsize='4'
-uvtype='unsigned long'
-uvuformat='"lu"'
-uvxformat='"lx"'
-vendorarch=''
-vendorarchexp=''
-vendorbin=''
-vendorbinexp=''
-vendorhtml1dir=' '
-vendorhtml1direxp=''
-vendorhtml3dir=' '
-vendorhtml3direxp=''
-vendorlib=''
-vendorlib_stem=''
-vendorlibexp=''
-vendorman1dir=' '
-vendorman1direxp=''
-vendorman3dir=' '
-vendorman3direxp=''
-vendorprefix=''
-vendorprefixexp=''
-vendorscript=''
-vendorscriptexp=''
-version='5.8.8'
-version_patchlevel_string='version 8 subversion 8'
-versiononly='undef'
-vi=''
-voidflags='15'
-xlibpth='/usr/lib/386 /lib/386'
-yacc='yacc'
-yaccflags=''
-zcat=''
-zip='zip'
-!END!
-
-my $i = 0;
-foreach my $c (4,3,2) { $i |= ord($c); $i <<= 8 }
-$i |= ord(1);
-our $byteorder = join('', unpack('aaaa', pack('L!', $i)));
-s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
-
-my $config_sh_len = length $_;
-
-our $Config_SH_expanded = "\n$_" . << 'EOVIRTUAL';
-ccflags_nolargefiles=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DPERL_IMPLICIT_CONTEXT -fno-strict-aliasing -DPERL_MSVCRT_READFIX'
-ldflags_nolargefiles='-s -L"x:\perl\lib\CORE" -L"x:\msys\mingw\lib"'
-libs_nolargefiles='-lmsvcrt -lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32'
-libswanted_nolargefiles=''
-EOVIRTUAL
-
-# Search for it in the big string
-sub fetch_string {
- my($self, $key) = @_;
-
- # We only have ' delimted.
- my $start = index($Config_SH_expanded, "\n$key=\'");
- # 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, "'\n", $start)
- - $start);
- # 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 {
- my $pos = index($Config_SH_expanded, qq('\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
- );
-}
-
-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/installer/perllib/Cwd.pm b/Master/tlpkg/installer/perllib/Cwd.pm
deleted file mode 100644
index 8d25af9f7cd..00000000000
--- a/Master/tlpkg/installer/perllib/Cwd.pm
+++ /dev/null
@@ -1,710 +0,0 @@
-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.
-
-Re-implements the getcwd(3) (or getwd(3)) functions in Perl.
-
-=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.12';
-
-@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;
-}
-
-# If loading the XS stuff doesn't work, we can fall back to pure perl
-eval {
- if ( $] >= 5.006 ) {
- require XSLoader;
- XSLoader::load( __PACKAGE__, $VERSION );
- } else {
- require DynaLoader;
- push @ISA, 'DynaLoader';
- __PACKAGE__->bootstrap( $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',
- },
-
- 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};
-$METHOD_MAP{nto} = $METHOD_MAP{qnx};
-
-
-# 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;
- }
-}
-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
- if( $os eq 'MacOS' || (defined $ENV{PATH} &&
- $os ne 'MSWin32' && # no pwd on Windows
- grep { -x "$_/pwd" } split($sep, $ENV{PATH})) )
- {
- *cwd = \&_backtick_pwd;
- }
- else {
- *cwd = \&getcwd;
- }
-}
-
-# set a reasonable (and very safe) default for fastgetcwd, in case it
-# isn't redefined later (20001212 rspier)
-*fastgetcwd = \&cwd;
-
-# By Brandon S. Allbery
-#
-# Usage: $cwd = getcwd();
-
-sub 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 ($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))
- {
- _carp("opendir($dotdots): $!");
- return '';
- }
- 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 @_;
-
- # may need to turn foo.dir into [.foo]
- my $path = VMS::Filespec::pathify($_[0]);
- $path = $_[0] unless defined $path;
-
- 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 {
- $ENV{'PWD'} = Win32::GetCwd();
- $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;
-
-# 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/installer/perllib/Data/Dumper.pm b/Master/tlpkg/installer/perllib/Data/Dumper.pm
deleted file mode 100644
index b7fe1d61e77..00000000000
--- a/Master/tlpkg/installer/perllib/Data/Dumper.pm
+++ /dev/null
@@ -1,1264 +0,0 @@
-#
-# 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.121_08';
-
-#$| = 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($v) 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);
-}
-
-sub init_refaddr_format {
- require Config;
- my $f = $Config::Config{uvxformat};
- $f =~ tr/"//d;
- our $refaddr_format = "0x%" . $f;
-}
-
-sub format_refaddr {
- 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')) {
- 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);
-}
-
-#
-# 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 ];
- }
- }
-
- if ($realpack and $realpack eq 'Regexp') {
- $out = "$val";
- $out =~ s,/,\\/,g;
- return "qr/$out/";
- }
-
- # 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) {
- $out = $s->{'bless'} . '( ';
- $blesspad = $s->{apad};
- $s->{apad} .= ' ' if ($s->{indent} >= 2);
- }
-
- $s->{level}++;
- $ipad = $s->{xpad} x $s->{level};
-
- if ($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($v, $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 $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 ];
- }
- }
- 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) { # we have a blessed ref
- $out .= ', \'' . $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 {
- $val =~ s/([\\\'])/\\$1/g;
- $out .= '\'' . $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 contents 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
-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.121 (Aug 24 2003)
-
-=head1 SEE ALSO
-
-perl(1)
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Digest/MD5.pm b/Master/tlpkg/installer/perllib/Digest/MD5.pm
deleted file mode 100644
index 17fb11d678a..00000000000
--- a/Master/tlpkg/installer/perllib/Digest/MD5.pm
+++ /dev/null
@@ -1,376 +0,0 @@
-package Digest::MD5;
-
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK);
-
-$VERSION = '2.36'; # $Date: 2005/11/30 13:46:47 $
-
-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::SHA1>,
-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/installer/perllib/Digest/base.pm b/Master/tlpkg/installer/perllib/Digest/base.pm
deleted file mode 100644
index cb336c2cf61..00000000000
--- a/Master/tlpkg/installer/perllib/Digest/base.pm
+++ /dev/null
@@ -1,100 +0,0 @@
-package Digest::base;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = "1.00";
-
-# 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/installer/perllib/Digest/file.pm b/Master/tlpkg/installer/perllib/Digest/file.pm
deleted file mode 100644
index 67985fd7599..00000000000
--- a/Master/tlpkg/installer/perllib/Digest/file.pm
+++ /dev/null
@@ -1,85 +0,0 @@
-package Digest::file;
-
-use strict;
-
-use Exporter ();
-use Carp qw(croak);
-use Digest ();
-
-use vars qw($VERSION @ISA @EXPORT_OK);
-
-$VERSION = "1.00";
-@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/installer/perllib/DynaLoader.pm b/Master/tlpkg/installer/perllib/DynaLoader.pm
deleted file mode 100644
index 178e9b2616c..00000000000
--- a/Master/tlpkg/installer/perllib/DynaLoader.pm
+++ /dev/null
@@ -1,833 +0,0 @@
-
-# Generated from DynaLoader.pm.PL
-
-package DynaLoader;
-
-# And Gandalf said: 'Many folk like to know beforehand what is to
-# be set on the table; but those who have laboured to prepare the
-# feast like to keep their secret; for wonder makes the words of
-# praise louder.'
-
-# (Quote from Tolkien suggested by Anno Siegel.)
-#
-# See pod text at end of file for documentation.
-# See also ext/DynaLoader/README in source tree for other information.
-#
-# Tim.Bunce@ig.co.uk, August 1994
-
-use vars qw($VERSION *AUTOLOAD);
-
-$VERSION = '1.05'; # avoid typo warning
-
-require AutoLoader;
-*AUTOLOAD = \&AutoLoader::AUTOLOAD;
-
-use Config;
-
-# The following require can't be removed during maintenance
-# releases, sadly, because of the risk of buggy code that does
-# require Carp; Carp::croak "..."; without brackets dying
-# if Carp hasn't been loaded in earlier compile time. :-(
-# We'll let those bugs get found on the development track.
-require Carp if $] < 5.00450;
-
-# enable debug/trace messages from DynaLoader perl code
-$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
-
-#
-# Flags to alter dl_load_file behaviour. Assigned bits:
-# 0x01 make symbols available for linking later dl_load_file's.
-# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
-# (ignored under VMS; effect is built-in to image linking)
-#
-# This is called as a class method $module->dl_load_flags. The
-# definition here will be inherited and result on "default" loading
-# behaviour unless a sub-class of DynaLoader defines its own version.
-#
-
-sub dl_load_flags { 0x00 }
-
-# ($dl_dlext, $dlsrc)
-# = @Config::Config{'dlext', 'dlsrc'};
- ($dl_dlext, $dlsrc) = ('dll','dl_win32.xs')
-;
-# Some systems need special handling to expand file specifications
-# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>)
-# See dl_expandspec() for more details. Should be harmless but
-# inefficient to define on systems that don't need it.
-$Is_VMS = $^O eq 'VMS';
-$do_expand = $Is_VMS;
-$Is_MacOS = $^O eq 'MacOS';
-
-my $Mac_FS;
-$Mac_FS = eval { require Mac::FileSpec::Unixish } if $Is_MacOS;
-
-@dl_require_symbols = (); # names of symbols we need
-@dl_resolve_using = (); # names of files to link with
-@dl_library_path = (); # path to look for files
-
-#XSLoader.pm may have added elements before we were required
-#@dl_shared_objects = (); # shared objects for symbols we have
-#@dl_librefs = (); # things we have loaded
-#@dl_modules = (); # Modules we have loaded
-
-# This is a fix to support DLD's unfortunate desire to relink -lc
-@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";
-
-# Initialise @dl_library_path with the 'standard' library path
-# for this platform as determined by Configure.
-
-push(@dl_library_path, split(' ', $Config::Config{libpth}));
-
-
-my $ldlibpthname = $Config::Config{ldlibpthname};
-my $ldlibpthname_defined = defined $Config::Config{ldlibpthname};
-my $pthsep = $Config::Config{path_sep};
-
-# Add to @dl_library_path any extra directories we can gather from environment
-# during runtime.
-
-if ($ldlibpthname_defined &&
- exists $ENV{$ldlibpthname}) {
- push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname}));
-}
-
-# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH.
-
-if ($ldlibpthname_defined &&
- $ldlibpthname ne 'LD_LIBRARY_PATH' &&
- exists $ENV{LD_LIBRARY_PATH}) {
- push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH}));
-}
-
-
-# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
-# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
-boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
- !defined(&dl_error);
-
-if ($dl_debug) {
- print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n";
- print STDERR "DynaLoader not linked into this perl\n"
- unless defined(&boot_DynaLoader);
-}
-
-1; # End of main code
-
-
-sub croak { require Carp; Carp::croak(@_) }
-
-sub bootstrap_inherit {
- my $module = $_[0];
- local *isa = *{"$module\::ISA"};
- local @isa = (@isa, 'DynaLoader');
- # Cannot goto due to delocalization. Will report errors on a wrong line?
- bootstrap(@_);
-}
-
-# The bootstrap function cannot be autoloaded (without complications)
-# so we define it here:
-
-sub bootstrap {
- # use local vars to enable $module.bs script to edit values
- local(@args) = @_;
- local($module) = $args[0];
- local(@dirs, $file);
-
- unless ($module) {
- require Carp;
- Carp::confess("Usage: DynaLoader::bootstrap(module)");
- }
-
- # A common error on platforms which don't support dynamic loading.
- # Since it's fatal and potentially confusing we give a detailed message.
- croak("Can't load module $module, dynamic loading not available in this perl.\n".
- " (You may need to build a new perl executable which either supports\n".
- " dynamic loading or has the $module module statically linked into it.)\n")
- unless defined(&dl_load_file);
-
- my @modparts = split(/::/,$module);
- my $modfname = $modparts[-1];
-
- # Some systems have restrictions on files names for DLL's etc.
- # mod2fname returns appropriate file base name (typically truncated)
- # It may also edit @modparts if required.
- $modfname = &mod2fname(\@modparts) if defined &mod2fname;
-
- # Truncate the module name to 8.3 format for NetWare
- if (($^O eq 'NetWare') && (length($modfname) > 8)) {
- $modfname = substr($modfname, 0, 8);
- }
-
- my $modpname = join(($Is_MacOS ? ':' : '/'),@modparts);
-
- print STDERR "DynaLoader::bootstrap for $module ",
- ($Is_MacOS
- ? "(:auto:$modpname:$modfname.$dl_dlext)\n" :
- "(auto/$modpname/$modfname.$dl_dlext)\n")
- if $dl_debug;
-
- foreach (@INC) {
- chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS;
- my $dir;
- if ($Is_MacOS) {
- my $path = $_;
- if ($Mac_FS && ! -d $path) {
- $path = Mac::FileSpec::Unixish::nativize($path);
- }
- $path .= ":" unless /:$/;
- $dir = "${path}auto:$modpname";
- } else {
- $dir = "$_/auto/$modpname";
- }
-
- next unless -d $dir; # skip over uninteresting directories
-
- # check for common cases to avoid autoload of dl_findfile
- my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext";
- last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try);
-
- # no luck here, save dir for possible later dl_findfile search
- push @dirs, $dir;
- }
- # last resort, let dl_findfile have a go in all known locations
- $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;
-
- croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
- unless $file; # wording similar to error from 'require'
-
- $file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols};
- my $bootname = "boot_$module";
- $bootname =~ s/\W/_/g;
- @dl_require_symbols = ($bootname);
-
- # Execute optional '.bootstrap' perl script for this module.
- # The .bs file can be used to configure @dl_resolve_using etc to
- # match the needs of the individual module on this architecture.
- my $bs = $file;
- $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
- if (-s $bs) { # only read file if it's not empty
- print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
- eval { do $bs; };
- warn "$bs: $@\n" if $@;
- }
-
- my $boot_symbol_ref;
-
- if ($^O eq 'darwin') {
- if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) {
- goto boot; #extension library has already been loaded, e.g. darwin
- }
- }
-
- # Many dynamic extension loading problems will appear to come from
- # this section of code: XYZ failed at line 123 of DynaLoader.pm.
- # Often these errors are actually occurring in the initialisation
- # C code of the extension XS file. Perl reports the error as being
- # in this perl code simply because this was the last perl code
- # it executed.
-
- my $libref = dl_load_file($file, $module->dl_load_flags) or
- croak("Can't load '$file' for module $module: ".dl_error());
-
- push(@dl_librefs,$libref); # record loaded object
-
- my @unresolved = dl_undef_symbols();
- if (@unresolved) {
- require Carp;
- Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
- }
-
- $boot_symbol_ref = dl_find_symbol($libref, $bootname) or
- croak("Can't find '$bootname' symbol in $file\n");
-
- push(@dl_modules, $module); # record loaded module
-
- boot:
- my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
-
- # See comment block above
-
- push(@dl_shared_objects, $file); # record files loaded
-
- &$xs(@args);
-}
-
-
-#sub _check_file { # private utility to handle dl_expandspec vs -f tests
-# my($file) = @_;
-# return $file if (!$do_expand && -f $file); # the common case
-# return $file if ( $do_expand && ($file=dl_expandspec($file)));
-# return undef;
-#}
-
-
-# Let autosplit and the autoloader deal with these functions:
-__END__
-
-
-sub dl_findfile {
- # Read ext/DynaLoader/DynaLoader.doc for detailed information.
- # This function does not automatically consider the architecture
- # or the perl library auto directories.
- my (@args) = @_;
- my (@dirs, $dir); # which directories to search
- my (@found); # full paths to real files we have found
- my $dl_ext= 'dll'; # $Config::Config{'dlext'} suffix for perl extensions
- my $dl_so = 'dll'; # $Config::Config{'so'} suffix for shared libraries
-
- print STDERR "dl_findfile(@args)\n" if $dl_debug;
-
- # accumulate directories but process files as they appear
- arg: foreach(@args) {
- # Special fast case: full filepath requires no search
- if ($Is_VMS && m%[:>/\]]% && -f $_) {
- push(@found,dl_expandspec(VMS::Filespec::vmsify($_)));
- last arg unless wantarray;
- next;
- }
- elsif ($Is_MacOS) {
- if (m/:/ && -f $_) {
- push(@found,$_);
- last arg unless wantarray;
- }
- }
- elsif (m:/: && -f $_ && !$do_expand) {
- 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; }
-
- if ($Is_MacOS) {
- # 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
- s/^-l//;
- push(@names, $_);
- foreach $dir (@dirs, @dl_library_path) {
- next unless -d $dir;
- $dir =~ s/^([^:]+)$/:$1/;
- $dir =~ s/:$//;
- foreach $name (@names) {
- my($file) = "$dir:$name";
- print STDERR " checking in $dir for $name\n" if $dl_debug;
- if (-f $file) {
- push(@found, $file);
- next arg; # no need to look any further
- }
- }
- }
- 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; }
-
- # VMS: we may be using native VMS directory syntax instead of
- # Unix emulation, so check this as well
- if ($Is_VMS && /[:>\]]/ && -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_ext") unless m/\.$dl_ext$/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, $_);
- }
- foreach $dir (@dirs, @dl_library_path) {
- next unless -d $dir;
- chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS;
- foreach $name (@names) {
- my($file) = "$dir/$name";
- print STDERR " checking in $dir for $name\n" if $dl_debug;
- $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file);
- #$file = _check_file($file);
- if ($file) {
- push(@found, $file);
- next arg; # no need to look any further
- }
- }
- }
- }
- if ($dl_debug) {
- foreach(@dirs) {
- print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_;
- }
- print STDERR "dl_findfile found: @found\n";
- }
- return $found[0] unless wantarray;
- @found;
-}
-
-
-sub dl_expandspec {
- my($spec) = @_;
- # Optional function invoked if DynaLoader.pm sets $do_expand.
- # Most systems do not require or use this function.
- # Some systems may implement it in the dl_*.xs file in which case
- # this autoload version will not be called but is harmless.
-
- # This function is designed to deal with systems which treat some
- # 'filenames' in a special way. For example VMS 'Logical Names'
- # (something like unix environment variables - but different).
- # This function should recognise such names and expand them into
- # full file paths.
- # Must return undef if $spec is invalid or file does not exist.
-
- my $file = $spec; # default output to input
-
- if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs
- require Carp;
- Carp::croak("dl_expandspec: should be defined in XS file!\n");
- } else {
- return undef unless -f $file;
- }
- print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug;
- $file;
-}
-
-sub dl_find_symbol_anywhere
-{
- my $sym = shift;
- my $libref;
- foreach $libref (@dl_librefs) {
- my $symref = dl_find_symbol($libref,$sym);
- return $symref if $symref;
- }
- return undef;
-}
-
-=head1 NAME
-
-DynaLoader - Dynamically load C libraries into Perl code
-
-=head1 SYNOPSIS
-
- package YourPackage;
- require DynaLoader;
- @ISA = qw(... DynaLoader ...);
- bootstrap YourPackage;
-
- # optional method for 'global' loading
- sub dl_load_flags { 0x01 }
-
-
-=head1 DESCRIPTION
-
-This document defines a standard generic interface to the dynamic
-linking mechanisms available on many platforms. Its primary purpose is
-to implement automatic dynamic loading of Perl modules.
-
-This document serves as both a specification for anyone wishing to
-implement the DynaLoader for a new platform and as a guide for
-anyone wishing to use the DynaLoader directly in an application.
-
-The DynaLoader is designed to be a very simple high-level
-interface that is sufficiently general to cover the requirements
-of SunOS, HP-UX, NeXT, Linux, VMS and other platforms.
-
-It is also hoped that the interface will cover the needs of OS/2, NT
-etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime).
-
-It must be stressed that the DynaLoader, by itself, is practically
-useless for accessing non-Perl libraries because it provides almost no
-Perl-to-C 'glue'. There is, for example, no mechanism for calling a C
-library function or supplying arguments. A C::DynaLib module
-is available from CPAN sites which performs that function for some
-common system types. And since the year 2000, there's also Inline::C,
-a module that allows you to write Perl subroutines in C. Also available
-from your local CPAN site.
-
-DynaLoader Interface Summary
-
- @dl_library_path
- @dl_resolve_using
- @dl_require_symbols
- $dl_debug
- @dl_librefs
- @dl_modules
- @dl_shared_objects
- Implemented in:
- bootstrap($modulename) Perl
- @filepaths = dl_findfile(@names) Perl
- $flags = $modulename->dl_load_flags Perl
- $symref = dl_find_symbol_anywhere($symbol) Perl
-
- $libref = dl_load_file($filename, $flags) C
- $status = dl_unload_file($libref) C
- $symref = dl_find_symbol($libref, $symbol) C
- @symbols = dl_undef_symbols() C
- dl_install_xsub($name, $symref [, $filename]) C
- $message = dl_error C
-
-=over 4
-
-=item @dl_library_path
-
-The standard/default list of directories in which dl_findfile() will
-search for libraries etc. Directories are searched in order:
-$dl_library_path[0], [1], ... etc
-
-@dl_library_path is initialised to hold the list of 'normal' directories
-(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should
-ensure portability across a wide range of platforms.
-
-@dl_library_path should also be initialised with any other directories
-that can be determined from the environment at runtime (such as
-LD_LIBRARY_PATH for SunOS).
-
-After initialisation @dl_library_path can be manipulated by an
-application using push and unshift before calling dl_findfile().
-Unshift can be used to add directories to the front of the search order
-either to save search time or to override libraries with the same name
-in the 'normal' directories.
-
-The load function that dl_load_file() calls may require an absolute
-pathname. The dl_findfile() function and @dl_library_path can be
-used to search for and return the absolute pathname for the
-library/object that you wish to load.
-
-=item @dl_resolve_using
-
-A list of additional libraries or other shared objects which can be
-used to resolve any undefined symbols that might be generated by a
-later call to load_file().
-
-This is only required on some platforms which do not handle dependent
-libraries automatically. For example the Socket Perl extension
-library (F<auto/Socket/Socket.so>) contains references to many socket
-functions which need to be resolved when it's loaded. Most platforms
-will automatically know where to find the 'dependent' library (e.g.,
-F</usr/lib/libsocket.so>). A few platforms need to be told the
-location of the dependent library explicitly. Use @dl_resolve_using
-for this.
-
-Example usage:
-
- @dl_resolve_using = dl_findfile('-lsocket');
-
-=item @dl_require_symbols
-
-A list of one or more symbol names that are in the library/object file
-to be dynamically loaded. This is only required on some platforms.
-
-=item @dl_librefs
-
-An array of the handles returned by successful calls to dl_load_file(),
-made by bootstrap, in the order in which they were loaded.
-Can be used with dl_find_symbol() to look for a symbol in any of
-the loaded files.
-
-=item @dl_modules
-
-An array of module (package) names that have been bootstrap'ed.
-
-=item @dl_shared_objects
-
-An array of file names for the shared objects that were loaded.
-
-=item dl_error()
-
-Syntax:
-
- $message = dl_error();
-
-Error message text from the last failed DynaLoader function. Note
-that, similar to errno in unix, a successful function call does not
-reset this message.
-
-Implementations should detect the error as soon as it occurs in any of
-the other functions and save the corresponding message for later
-retrieval. This will avoid problems on some platforms (such as SunOS)
-where the error message is very temporary (e.g., dlerror()).
-
-=item $dl_debug
-
-Internal debugging messages are enabled when $dl_debug is set true.
-Currently setting $dl_debug only affects the Perl side of the
-DynaLoader. These messages should help an application developer to
-resolve any DynaLoader usage problems.
-
-$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined.
-
-For the DynaLoader developer/porter there is a similar debugging
-variable added to the C code (see dlutils.c) and enabled if Perl was
-built with the B<-DDEBUGGING> flag. This can also be set via the
-PERL_DL_DEBUG environment variable. Set to 1 for minimal information or
-higher for more.
-
-=item dl_findfile()
-
-Syntax:
-
- @filepaths = dl_findfile(@names)
-
-Determine the full paths (including file suffix) of one or more
-loadable files given their generic names and optionally one or more
-directories. Searches directories in @dl_library_path by default and
-returns an empty list if no files were found.
-
-Names can be specified in a variety of platform independent forms. Any
-names in the form B<-lname> are converted into F<libname.*>, where F<.*> is
-an appropriate suffix for the platform.
-
-If a name does not already have a suitable prefix and/or suffix then
-the corresponding file will be searched for by trying combinations of
-prefix and suffix appropriate to the platform: "$name.o", "lib$name.*"
-and "$name".
-
-If any directories are included in @names they are searched before
-@dl_library_path. Directories may be specified as B<-Ldir>. Any other
-names are treated as filenames to be searched for.
-
-Using arguments of the form C<-Ldir> and C<-lname> is recommended.
-
-Example:
-
- @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix));
-
-
-=item dl_expandspec()
-
-Syntax:
-
- $filepath = dl_expandspec($spec)
-
-Some unusual systems, such as VMS, require special filename handling in
-order to deal with symbolic names for files (i.e., VMS's Logical Names).
-
-To support these systems a dl_expandspec() function can be implemented
-either in the F<dl_*.xs> file or code can be added to the autoloadable
-dl_expandspec() function in F<DynaLoader.pm>. See F<DynaLoader.pm> for
-more information.
-
-=item dl_load_file()
-
-Syntax:
-
- $libref = dl_load_file($filename, $flags)
-
-Dynamically load $filename, which must be the path to a shared object
-or library. An opaque 'library reference' is returned as a handle for
-the loaded object. Returns undef on error.
-
-The $flags argument to alters dl_load_file behaviour.
-Assigned bits:
-
- 0x01 make symbols available for linking later dl_load_file's.
- (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
- (ignored under VMS; this is a normal part of image linking)
-
-(On systems that provide a handle for the loaded object such as SunOS
-and HPUX, $libref will be that handle. On other systems $libref will
-typically be $filename or a pointer to a buffer containing $filename.
-The application should not examine or alter $libref in any way.)
-
-This is the function that does the real work. It should use the
-current values of @dl_require_symbols and @dl_resolve_using if required.
-
- SunOS: dlopen($filename)
- HP-UX: shl_load($filename)
- Linux: dld_create_reference(@dl_require_symbols); dld_link($filename)
- NeXT: rld_load($filename, @dl_resolve_using)
- VMS: lib$find_image_symbol($filename,$dl_require_symbols[0])
-
-(The dlopen() function is also used by Solaris and some versions of
-Linux, and is a common choice when providing a "wrapper" on other
-mechanisms as is done in the OS/2 port.)
-
-=item dl_unload_file()
-
-Syntax:
-
- $status = dl_unload_file($libref)
-
-Dynamically unload $libref, which must be an opaque 'library reference' as
-returned from dl_load_file. Returns one on success and zero on failure.
-
-This function is optional and may not necessarily be provided on all platforms.
-If it is defined, it is called automatically when the interpreter exits for
-every shared object or library loaded by DynaLoader::bootstrap. All such
-library references are stored in @dl_librefs by DynaLoader::Bootstrap as it
-loads the libraries. The files are unloaded in last-in, first-out order.
-
-This unloading is usually necessary when embedding a shared-object perl (e.g.
-one configured with -Duseshrplib) within a larger application, and the perl
-interpreter is created and destroyed several times within the lifetime of the
-application. In this case it is possible that the system dynamic linker will
-unload and then subsequently reload the shared libperl without relocating any
-references to it from any files DynaLoaded by the previous incarnation of the
-interpreter. As a result, any shared objects opened by DynaLoader may point to
-a now invalid 'ghost' of the libperl shared object, causing apparently random
-memory corruption and crashes. This behaviour is most commonly seen when using
-Apache and mod_perl built with the APXS mechanism.
-
- SunOS: dlclose($libref)
- HP-UX: ???
- Linux: ???
- NeXT: ???
- VMS: ???
-
-(The dlclose() function is also used by Solaris and some versions of
-Linux, and is a common choice when providing a "wrapper" on other
-mechanisms as is done in the OS/2 port.)
-
-=item dl_load_flags()
-
-Syntax:
-
- $flags = dl_load_flags $modulename;
-
-Designed to be a method call, and to be overridden by a derived class
-(i.e. a class which has DynaLoader in its @ISA). The definition in
-DynaLoader itself returns 0, which produces standard behavior from
-dl_load_file().
-
-=item dl_find_symbol()
-
-Syntax:
-
- $symref = dl_find_symbol($libref, $symbol)
-
-Return the address of the symbol $symbol or C<undef> if not found. If the
-target system has separate functions to search for symbols of different
-types then dl_find_symbol() should search for function symbols first and
-then other types.
-
-The exact manner in which the address is returned in $symref is not
-currently defined. The only initial requirement is that $symref can
-be passed to, and understood by, dl_install_xsub().
-
- SunOS: dlsym($libref, $symbol)
- HP-UX: shl_findsym($libref, $symbol)
- Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol)
- NeXT: rld_lookup("_$symbol")
- VMS: lib$find_image_symbol($libref,$symbol)
-
-
-=item dl_find_symbol_anywhere()
-
-Syntax:
-
- $symref = dl_find_symbol_anywhere($symbol)
-
-Applies dl_find_symbol() to the members of @dl_librefs and returns
-the first match found.
-
-=item dl_undef_symbols()
-
-Example
-
- @symbols = dl_undef_symbols()
-
-Return a list of symbol names which remain undefined after load_file().
-Returns C<()> if not known. Don't worry if your platform does not provide
-a mechanism for this. Most do not need it and hence do not provide it,
-they just return an empty list.
-
-
-=item dl_install_xsub()
-
-Syntax:
-
- dl_install_xsub($perl_name, $symref [, $filename])
-
-Create a new Perl external subroutine named $perl_name using $symref as
-a pointer to the function which implements the routine. This is simply
-a direct call to newXSUB(). Returns a reference to the installed
-function.
-
-The $filename parameter is used by Perl to identify the source file for
-the function if required by die(), caller() or the debugger. If
-$filename is not defined then "DynaLoader" will be used.
-
-
-=item bootstrap()
-
-Syntax:
-
-bootstrap($module)
-
-This is the normal entry point for automatic dynamic loading in Perl.
-
-It performs the following actions:
-
-=over 8
-
-=item *
-
-locates an auto/$module directory by searching @INC
-
-=item *
-
-uses dl_findfile() to determine the filename to load
-
-=item *
-
-sets @dl_require_symbols to C<("boot_$module")>
-
-=item *
-
-executes an F<auto/$module/$module.bs> file if it exists
-(typically used to add to @dl_resolve_using any files which
-are required to load the module on the current platform)
-
-=item *
-
-calls dl_load_flags() to determine how to load the file.
-
-=item *
-
-calls dl_load_file() to load the file
-
-=item *
-
-calls dl_undef_symbols() and warns if any symbols are undefined
-
-=item *
-
-calls dl_find_symbol() for "boot_$module"
-
-=item *
-
-calls dl_install_xsub() to install it as "${module}::bootstrap"
-
-=item *
-
-calls &{"${module}::bootstrap"} to bootstrap the module (actually
-it uses the function reference returned by dl_install_xsub for speed)
-
-=back
-
-=back
-
-
-=head1 AUTHOR
-
-Tim Bunce, 11 August 1994.
-
-This interface is based on the work and comments of (in no particular
-order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno
-Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others.
-
-Larry Wall designed the elegant inherited bootstrap mechanism and
-implemented the first Perl 5 dynamic loader using it.
-
-Solaris global loading added by Nick Ing-Simmons with design/coding
-assistance from Tim Bunce, January 1996.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode.pm b/Master/tlpkg/installer/perllib/Encode.pm
deleted file mode 100644
index ac0123c89ec..00000000000
--- a/Master/tlpkg/installer/perllib/Encode.pm
+++ /dev/null
@@ -1,851 +0,0 @@
-#
-# $Id: Encode.pm,v 2.12 2005/09/08 14:17:17 dankogai Exp dankogai $
-#
-package Encode;
-use strict;
-our $VERSION = sprintf "%d.%02d", q$Revision: 2.12 $ =~ /(\d+)/g;
-sub DEBUG () { 0 }
-use XSLoader ();
-XSLoader::load(__PACKAGE__, $VERSION);
-
-require Exporter;
-use base qw/Exporter/;
-
-# Public, encouraged API is exported by default
-
-our @EXPORT = qw(
- decode decode_utf8 encode encode_utf8
- encodings find_encoding clone_encoding
-);
-
-our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC
- PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL);
-our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN
- FB_PERLQQ FB_HTMLCREF FB_XMLCREF);
-
-our @EXPORT_OK =
- (
- qw(
- _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit
- is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade
- ),
- @FB_FLAGS, @FB_CONSTS,
- );
-
-our %EXPORT_TAGS =
- (
- all => [ @EXPORT, @EXPORT_OK ],
- fallbacks => [ @FB_CONSTS ],
- fallback_all => [ @FB_CONSTS, @FB_FLAGS ],
- );
-
-# Documentation moved after __END__ for speed - NI-S
-
-our $ON_EBCDIC = (ord("A") == 193);
-
-use Encode::Alias;
-
-# Make a %Encoding package variable to allow a certain amount of cheating
-our %Encoding;
-our %ExtModule;
-require Encode::Config;
-eval { require Encode::ConfigLocal };
-
-sub encodings
-{
- my $class = shift;
- my %enc;
- if (@_ and $_[0] eq ":all"){
- %enc = ( %Encoding, %ExtModule );
- }else{
- %enc = %Encoding;
- for my $mod (map {m/::/o ? $_ : "Encode::$_" } @_){
- DEBUG and warn $mod;
- for my $enc (keys %ExtModule){
- $ExtModule{$enc} eq $mod and $enc{$enc} = $mod;
- }
- }
- }
- return
- sort { lc $a cmp lc $b }
- grep {!/^(?:Internal|Unicode|Guess)$/o} keys %enc;
-}
-
-sub perlio_ok{
- my $obj = ref($_[0]) ? $_[0] : find_encoding($_[0]);
- $obj->can("perlio_ok") and return $obj->perlio_ok();
- return 0; # safety net
-}
-
-sub define_encoding
-{
- my $obj = shift;
- my $name = shift;
- $Encoding{$name} = $obj;
- my $lc = lc($name);
- define_alias($lc => $obj) unless $lc eq $name;
- while (@_){
- my $alias = shift;
- define_alias($alias, $obj);
- }
- return $obj;
-}
-
-sub getEncoding
-{
- my ($class, $name, $skip_external) = @_;
-
- ref($name) && $name->can('renew') and return $name;
- exists $Encoding{$name} and return $Encoding{$name};
- my $lc = lc $name;
- exists $Encoding{$lc} and return $Encoding{$lc};
-
- my $oc = $class->find_alias($name);
- defined($oc) and return $oc;
- $lc ne $name and $oc = $class->find_alias($lc);
- defined($oc) and return $oc;
-
- unless ($skip_external)
- {
- if (my $mod = $ExtModule{$name} || $ExtModule{$lc}){
- $mod =~ s,::,/,g ; $mod .= '.pm';
- eval{ require $mod; };
- exists $Encoding{$name} and return $Encoding{$name};
- }
- }
- return;
-}
-
-sub find_encoding($;$)
-{
- my ($name, $skip_external) = @_;
- return __PACKAGE__->getEncoding($name,$skip_external);
-}
-
-sub resolve_alias($){
- my $obj = find_encoding(shift);
- defined $obj and return $obj->name;
- return;
-}
-
-sub clone_encoding($){
- my $obj = find_encoding(shift);
- ref $obj or return;
- eval { require Storable };
- $@ and return;
- return Storable::dclone($obj);
-}
-
-sub encode($$;$)
-{
- my ($name, $string, $check) = @_;
- return undef unless defined $string;
- $string .= '' if ref $string; # stringify;
- $check ||=0;
- my $enc = find_encoding($name);
- unless(defined $enc){
- require Carp;
- Carp::croak("Unknown encoding '$name'");
- }
- my $octets = $enc->encode($string,$check);
- $_[1] = $string if $check and !($check & LEAVE_SRC());
- return $octets;
-}
-
-sub decode($$;$)
-{
- my ($name,$octets,$check) = @_;
- return undef unless defined $octets;
- $octets .= '' if ref $octets;
- $check ||=0;
- my $enc = find_encoding($name);
- unless(defined $enc){
- require Carp;
- Carp::croak("Unknown encoding '$name'");
- }
- my $string = $enc->decode($octets,$check);
- $_[1] = $octets if $check and !($check & LEAVE_SRC());
- return $string;
-}
-
-sub from_to($$$;$)
-{
- my ($string,$from,$to,$check) = @_;
- return undef unless defined $string;
- $check ||=0;
- my $f = find_encoding($from);
- unless (defined $f){
- require Carp;
- Carp::croak("Unknown encoding '$from'");
- }
- my $t = find_encoding($to);
- unless (defined $t){
- require Carp;
- Carp::croak("Unknown encoding '$to'");
- }
- my $uni = $f->decode($string,$check);
- return undef if ($check && length($string));
- $string = $t->encode($uni,$check);
- return undef if ($check && length($uni));
- return defined($_[0] = $string) ? length($string) : undef ;
-}
-
-sub encode_utf8($)
-{
- my ($str) = @_;
- utf8::encode($str);
- return $str;
-}
-
-sub decode_utf8($;$)
-{
- my ($str, $check) = @_;
- if ($check){
- return decode("utf8", $str, $check);
- }else{
- return decode("utf8", $str);
- return $str;
- }
-}
-
-predefine_encodings(1);
-
-#
-# This is to restore %Encoding if really needed;
-#
-
-sub predefine_encodings{
- use Encode::Encoding;
- no warnings 'redefine';
- my $use_xs = shift;
- if ($ON_EBCDIC) {
- # was in Encode::UTF_EBCDIC
- package Encode::UTF_EBCDIC;
- push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding';
- *decode = sub{
- my ($obj,$str,$chk) = @_;
- my $res = '';
- for (my $i = 0; $i < length($str); $i++) {
- $res .=
- chr(utf8::unicode_to_native(ord(substr($str,$i,1))));
- }
- $_[1] = '' if $chk;
- return $res;
- };
- *encode = sub{
- my ($obj,$str,$chk) = @_;
- my $res = '';
- for (my $i = 0; $i < length($str); $i++) {
- $res .=
- chr(utf8::native_to_unicode(ord(substr($str,$i,1))));
- }
- $_[1] = '' if $chk;
- return $res;
- };
- $Encode::Encoding{Unicode} =
- bless {Name => "UTF_EBCDIC"} => "Encode::UTF_EBCDIC";
- } else {
- package Encode::Internal;
- push @Encode::Internal::ISA, 'Encode::Encoding';
- *decode = sub{
- my ($obj,$str,$chk) = @_;
- utf8::upgrade($str);
- $_[1] = '' if $chk;
- return $str;
- };
- *encode = \&decode;
- $Encode::Encoding{Unicode} =
- bless {Name => "Internal"} => "Encode::Internal";
- }
-
- {
- # was in Encode::utf8
- package Encode::utf8;
- push @Encode::utf8::ISA, 'Encode::Encoding';
- #
- if ($use_xs){
- Encode::DEBUG and warn __PACKAGE__, " XS on";
- *decode = \&decode_xs;
- *encode = \&encode_xs;
- }else{
- Encode::DEBUG and warn __PACKAGE__, " XS off";
- *decode = sub{
- my ($obj,$octets,$chk) = @_;
- my $str = Encode::decode_utf8($octets);
- if (defined $str) {
- $_[1] = '' if $chk;
- return $str;
- }
- return undef;
- };
- *encode = sub {
- my ($obj,$string,$chk) = @_;
- my $octets = Encode::encode_utf8($string);
- $_[1] = '' if $chk;
- return $octets;
- };
- }
- *cat_decode = sub{ # ($obj, $dst, $src, $pos, $trm, $chk)
- my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk
- my ($rdst, $rsrc, $rpos) = \@_[1,2,3];
- use bytes;
- if ((my $npos = index($$rsrc, $trm, $pos)) >= 0) {
- $$rdst .= substr($$rsrc, $pos, $npos - $pos + length($trm));
- $$rpos = $npos + length($trm);
- return 1;
- }
- $$rdst .= substr($$rsrc, $pos);
- $$rpos = length($$rsrc);
- return '';
- };
- $Encode::Encoding{utf8} =
- bless {Name => "utf8"} => "Encode::utf8";
- $Encode::Encoding{"utf-8-strict"} =
- bless {Name => "utf-8-strict", strict_utf8 => 1 } => "Encode::utf8";
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Encode - character encodings
-
-=head1 SYNOPSIS
-
- use Encode;
-
-=head2 Table of Contents
-
-Encode consists of a collection of modules whose details are too big
-to fit in one document. This POD itself explains the top-level APIs
-and general topics at a glance. For other topics and more details,
-see the PODs below:
-
- Name Description
- --------------------------------------------------------
- Encode::Alias Alias definitions to encodings
- Encode::Encoding Encode Implementation Base Class
- Encode::Supported List of Supported Encodings
- Encode::CN Simplified Chinese Encodings
- Encode::JP Japanese Encodings
- Encode::KR Korean Encodings
- Encode::TW Traditional Chinese Encodings
- --------------------------------------------------------
-
-=head1 DESCRIPTION
-
-The C<Encode> module provides the interfaces between Perl's strings
-and the rest of the system. Perl strings are sequences of
-B<characters>.
-
-The repertoire of characters that Perl can represent is at least that
-defined by the Unicode Consortium. On most platforms the ordinal
-values of the characters (as returned by C<ord(ch)>) is the "Unicode
-codepoint" for the character (the exceptions are those platforms where
-the legacy encoding is some variant of EBCDIC rather than a super-set
-of ASCII - see L<perlebcdic>).
-
-Traditionally, computer data has been moved around in 8-bit chunks
-often called "bytes". These chunks are also known as "octets" in
-networking standards. Perl is widely used to manipulate data of many
-types - not only strings of characters representing human or computer
-languages but also "binary" data being the machine's representation of
-numbers, pixels in an image - or just about anything.
-
-When Perl is processing "binary data", the programmer wants Perl to
-process "sequences of bytes". This is not a problem for Perl - as a
-byte has 256 possible values, it easily fits in Perl's much larger
-"logical character".
-
-=head2 TERMINOLOGY
-
-=over 2
-
-=item *
-
-I<character>: a character in the range 0..(2**32-1) (or more).
-(What Perl's strings are made of.)
-
-=item *
-
-I<byte>: a character in the range 0..255
-(A special case of a Perl character.)
-
-=item *
-
-I<octet>: 8 bits of data, with ordinal values 0..255
-(Term for bytes passed to or from a non-Perl context, e.g. a disk file.)
-
-=back
-
-=head1 PERL ENCODING API
-
-=over 2
-
-=item $octets = encode(ENCODING, $string [, CHECK])
-
-Encodes a string from Perl's internal form into I<ENCODING> and returns
-a sequence of octets. ENCODING can be either a canonical name or
-an alias. For encoding names and aliases, see L</"Defining Aliases">.
-For CHECK, see L</"Handling Malformed Data">.
-
-For example, to convert a string from Perl's internal format to
-iso-8859-1 (also known as Latin1),
-
- $octets = encode("iso-8859-1", $string);
-
-B<CAVEAT>: When you run C<$octets = encode("utf8", $string)>, then $octets
-B<may not be equal to> $string. Though they both contain the same data, the utf8 flag
-for $octets is B<always> off. When you encode anything, utf8 flag of
-the result is always off, even when it contains completely valid utf8
-string. See L</"The UTF-8 flag"> below.
-
-If the $string is C<undef> then C<undef> is returned.
-
-=item $string = decode(ENCODING, $octets [, CHECK])
-
-Decodes a sequence of octets assumed to be in I<ENCODING> into Perl's
-internal form and returns the resulting string. As in encode(),
-ENCODING can be either a canonical name or an alias. For encoding names
-and aliases, see L</"Defining Aliases">. For CHECK, see
-L</"Handling Malformed Data">.
-
-For example, to convert ISO-8859-1 data to a string in Perl's internal format:
-
- $string = decode("iso-8859-1", $octets);
-
-B<CAVEAT>: When you run C<$string = decode("utf8", $octets)>, then $string
-B<may not be equal to> $octets. Though they both contain the same data,
-the utf8 flag for $string is on unless $octets entirely consists of
-ASCII data (or EBCDIC on EBCDIC machines). See L</"The UTF-8 flag">
-below.
-
-If the $string is C<undef> then C<undef> is returned.
-
-=item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK])
-
-Converts B<in-place> data between two encodings. The data in $octets
-must be encoded as octets and not as characters in Perl's internal
-format. For example, to convert ISO-8859-1 data to Microsoft's CP1250
-encoding:
-
- from_to($octets, "iso-8859-1", "cp1250");
-
-and to convert it back:
-
- from_to($octets, "cp1250", "iso-8859-1");
-
-Note that because the conversion happens in place, the data to be
-converted cannot be a string constant; it must be a scalar variable.
-
-from_to() returns the length of the converted string in octets on
-success, I<undef> on error.
-
-B<CAVEAT>: The following operations look the same but are not quite so;
-
- from_to($data, "iso-8859-1", "utf8"); #1
- $data = decode("iso-8859-1", $data); #2
-
-Both #1 and #2 make $data consist of a completely valid UTF-8 string
-but only #2 turns utf8 flag on. #1 is equivalent to
-
- $data = encode("utf8", decode("iso-8859-1", $data));
-
-See L</"The UTF-8 flag"> below.
-
-=item $octets = encode_utf8($string);
-
-Equivalent to C<$octets = encode("utf8", $string);> The characters
-that comprise $string are encoded in Perl's internal format and the
-result is returned as a sequence of octets. All possible
-characters have a UTF-8 representation so this function cannot fail.
-
-
-=item $string = decode_utf8($octets [, CHECK]);
-
-equivalent to C<$string = decode("utf8", $octets [, CHECK])>.
-The sequence of octets represented by
-$octets is decoded from UTF-8 into a sequence of logical
-characters. Not all sequences of octets form valid UTF-8 encodings, so
-it is possible for this call to fail. For CHECK, see
-L</"Handling Malformed Data">.
-
-=back
-
-=head2 Listing available encodings
-
- use Encode;
- @list = Encode->encodings();
-
-Returns a list of the canonical names of the available encodings that
-are loaded. To get a list of all available encodings including the
-ones that are not loaded yet, say
-
- @all_encodings = Encode->encodings(":all");
-
-Or you can give the name of a specific module.
-
- @with_jp = Encode->encodings("Encode::JP");
-
-When "::" is not in the name, "Encode::" is assumed.
-
- @ebcdic = Encode->encodings("EBCDIC");
-
-To find out in detail which encodings are supported by this package,
-see L<Encode::Supported>.
-
-=head2 Defining Aliases
-
-To add a new alias to a given encoding, use:
-
- use Encode;
- use Encode::Alias;
- define_alias(newName => ENCODING);
-
-After that, newName can be used as an alias for ENCODING.
-ENCODING may be either the name of an encoding or an
-I<encoding object>
-
-But before you do so, make sure the alias is nonexistent with
-C<resolve_alias()>, which returns the canonical name thereof.
-i.e.
-
- Encode::resolve_alias("latin1") eq "iso-8859-1" # true
- Encode::resolve_alias("iso-8859-12") # false; nonexistent
- Encode::resolve_alias($name) eq $name # true if $name is canonical
-
-resolve_alias() does not need C<use Encode::Alias>; it can be
-exported via C<use Encode qw(resolve_alias)>.
-
-See L<Encode::Alias> for details.
-
-=head1 Encoding via PerlIO
-
-If your perl supports I<PerlIO> (which is the default), you can use a PerlIO layer to decode
-and encode directly via a filehandle. The following two examples
-are totally identical in their functionality.
-
- # via PerlIO
- open my $in, "<:encoding(shiftjis)", $infile or die;
- open my $out, ">:encoding(euc-jp)", $outfile or die;
- while(<$in>){ print $out $_; }
-
- # via from_to
- open my $in, "<", $infile or die;
- open my $out, ">", $outfile or die;
- while(<$in>){
- from_to($_, "shiftjis", "euc-jp", 1);
- print $out $_;
- }
-
-Unfortunately, it may be that encodings are PerlIO-savvy. You can check
-if your encoding is supported by PerlIO by calling the C<perlio_ok>
-method.
-
- Encode::perlio_ok("hz"); # False
- find_encoding("euc-cn")->perlio_ok; # True where PerlIO is available
-
- use Encode qw(perlio_ok); # exported upon request
- perlio_ok("euc-jp")
-
-Fortunately, all encodings that come with Encode core are PerlIO-savvy
-except for hz and ISO-2022-kr. For gory details, see
-L<Encode::Encoding> and L<Encode::PerlIO>.
-
-=head1 Handling Malformed Data
-
-The optional I<CHECK> argument tells Encode what to do when it
-encounters malformed data. Without CHECK, Encode::FB_DEFAULT ( == 0 )
-is assumed.
-
-As of version 2.12 Encode supports coderef values for CHECK. See below.
-
-=over 2
-
-=item B<NOTE:> Not all encoding support this feature
-
-Some encodings ignore I<CHECK> argument. For example,
-L<Encode::Unicode> ignores I<CHECK> and it always croaks on error.
-
-=back
-
-Now here is the list of I<CHECK> values available
-
-=over 2
-
-=item I<CHECK> = Encode::FB_DEFAULT ( == 0)
-
-If I<CHECK> is 0, (en|de)code will put a I<substitution character> in
-place of a malformed character. When you encode, E<lt>subcharE<gt>
-will be used. When you decode the code point C<0xFFFD> is used. If
-the data is supposed to be UTF-8, an optional lexical warning
-(category utf8) is given.
-
-=item I<CHECK> = Encode::FB_CROAK ( == 1)
-
-If I<CHECK> is 1, methods will die on error immediately with an error
-message. Therefore, when I<CHECK> is set to 1, you should trap the
-error with eval{} unless you really want to let it die.
-
-=item I<CHECK> = Encode::FB_QUIET
-
-If I<CHECK> is set to Encode::FB_QUIET, (en|de)code will immediately
-return the portion of the data that has been processed so far when an
-error occurs. The data argument will be overwritten with everything
-after that point (that is, the unprocessed part of data). This is
-handy when you have to call decode repeatedly in the case where your
-source data may contain partial multi-byte character sequences,
-(i.e. you are reading with a fixed-width buffer). Here is a sample
-code that does exactly this:
-
- my $buffer = ''; my $string = '';
- while(read $fh, $buffer, 256, length($buffer)){
- $string .= decode($encoding, $buffer, Encode::FB_QUIET);
- # $buffer now contains the unprocessed partial character
- }
-
-=item I<CHECK> = Encode::FB_WARN
-
-This is the same as above, except that it warns on error. Handy when
-you are debugging the mode above.
-
-=item perlqq mode (I<CHECK> = Encode::FB_PERLQQ)
-
-=item HTML charref mode (I<CHECK> = Encode::FB_HTMLCREF)
-
-=item XML charref mode (I<CHECK> = Encode::FB_XMLCREF)
-
-For encodings that are implemented by Encode::XS, CHECK ==
-Encode::FB_PERLQQ turns (en|de)code into C<perlqq> fallback mode.
-
-When you decode, C<\xI<HH>> will be inserted for a malformed character,
-where I<HH> is the hex representation of the octet that could not be
-decoded to utf8. And when you encode, C<\x{I<HHHH>}> will be inserted,
-where I<HHHH> is the Unicode ID of the character that cannot be found
-in the character repertoire of the encoding.
-
-HTML/XML character reference modes are about the same, in place of
-C<\x{I<HHHH>}>, HTML uses C<&#I<NNN>;> where I<NNN> is a decimal number and
-XML uses C<&#xI<HHHH>;> where I<HHHH> is the hexadecimal number.
-
-In Encode 2.10 or later, C<LEAVE_SRC> is also implied.
-
-=item The bitmask
-
-These modes are actually set via a bitmask. Here is how the FB_XX
-constants are laid out. You can import the FB_XX constants via
-C<use Encode qw(:fallbacks)>; you can import the generic bitmask
-constants via C<use Encode qw(:fallback_all)>.
-
- FB_DEFAULT FB_CROAK FB_QUIET FB_WARN FB_PERLQQ
- DIE_ON_ERR 0x0001 X
- WARN_ON_ERR 0x0002 X
- RETURN_ON_ERR 0x0004 X X
- LEAVE_SRC 0x0008 X
- PERLQQ 0x0100 X
- HTMLCREF 0x0200
- XMLCREF 0x0400
-
-=back
-
-=head2 coderef for CHECK
-
-As of Encode 2.12 CHECK can also be a code reference which takes the
-ord value of unmapped caharacter as an argument and returns a string
-that represents the fallback character. For instance,
-
- $ascii = encode("ascii", $utf8, sub{ sprintf "<U+%04X>", shift });
-
-Acts like FB_PERLQQ but E<lt>U+I<XXXX>E<gt> is used instead of
-\x{I<XXXX>}.
-
-=head1 Defining Encodings
-
-To define a new encoding, use:
-
- use Encode qw(define_encoding);
- define_encoding($object, 'canonicalName' [, alias...]);
-
-I<canonicalName> will be associated with I<$object>. The object
-should provide the interface described in L<Encode::Encoding>.
-If more than two arguments are provided then additional
-arguments are taken as aliases for I<$object>.
-
-See L<Encode::Encoding> for more details.
-
-=head1 The UTF-8 flag
-
-Before the introduction of utf8 support in perl, The C<eq> operator
-just compared the strings represented by two scalars. Beginning with
-perl 5.8, C<eq> compares two strings with simultaneous consideration
-of I<the utf8 flag>. To explain why we made it so, I will quote page
-402 of C<Programming Perl, 3rd ed.>
-
-=over 2
-
-=item Goal #1:
-
-Old byte-oriented programs should not spontaneously break on the old
-byte-oriented data they used to work on.
-
-=item Goal #2:
-
-Old byte-oriented programs should magically start working on the new
-character-oriented data when appropriate.
-
-=item Goal #3:
-
-Programs should run just as fast in the new character-oriented mode
-as in the old byte-oriented mode.
-
-=item Goal #4:
-
-Perl should remain one language, rather than forking into a
-byte-oriented Perl and a character-oriented Perl.
-
-=back
-
-Back when C<Programming Perl, 3rd ed.> was written, not even Perl 5.6.0
-was born and many features documented in the book remained
-unimplemented for a long time. Perl 5.8 corrected this and the introduction
-of the UTF-8 flag is one of them. You can think of this perl notion as of a
-byte-oriented mode (utf8 flag off) and a character-oriented mode (utf8
-flag on).
-
-Here is how Encode takes care of the utf8 flag.
-
-=over 2
-
-=item *
-
-When you encode, the resulting utf8 flag is always off.
-
-=item *
-
-When you decode, the resulting utf8 flag is on unless you can
-unambiguously represent data. Here is the definition of
-dis-ambiguity.
-
-After C<$utf8 = decode('foo', $octet);>,
-
- When $octet is... The utf8 flag in $utf8 is
- ---------------------------------------------
- In ASCII only (or EBCDIC only) OFF
- In ISO-8859-1 ON
- In any other Encoding ON
- ---------------------------------------------
-
-As you see, there is one exception, In ASCII. That way you can assume
-Goal #1. And with Encode Goal #2 is assumed but you still have to be
-careful in such cases mentioned in B<CAVEAT> paragraphs.
-
-This utf8 flag is not visible in perl scripts, exactly for the same
-reason you cannot (or you I<don't have to>) see if a scalar contains a
-string, integer, or floating point number. But you can still peek
-and poke these if you will. See the section below.
-
-=back
-
-=head2 Messing with Perl's Internals
-
-The following API uses parts of Perl's internals in the current
-implementation. As such, they are efficient but may change.
-
-=over 2
-
-=item is_utf8(STRING [, CHECK])
-
-[INTERNAL] Tests whether the UTF-8 flag is turned on in the STRING.
-If CHECK is true, also checks the data in STRING for being well-formed
-UTF-8. Returns true if successful, false otherwise.
-
-As of perl 5.8.1, L<utf8> also has utf8::is_utf8().
-
-=item _utf8_on(STRING)
-
-[INTERNAL] Turns on the UTF-8 flag in STRING. The data in STRING is
-B<not> checked for being well-formed UTF-8. Do not use unless you
-B<know> that the STRING is well-formed UTF-8. Returns the previous
-state of the UTF-8 flag (so please don't treat the return value as
-indicating success or failure), or C<undef> if STRING is not a string.
-
-=item _utf8_off(STRING)
-
-[INTERNAL] Turns off the UTF-8 flag in STRING. Do not use frivolously.
-Returns the previous state of the UTF-8 flag (so please don't treat the
-return value as indicating success or failure), or C<undef> if STRING is
-not a string.
-
-=back
-
-=head1 UTF-8 vs. utf8
-
- ....We now view strings not as sequences of bytes, but as sequences
- of numbers in the range 0 .. 2**32-1 (or in the case of 64-bit
- computers, 0 .. 2**64-1) -- Programming Perl, 3rd ed.
-
-That has been the perl's notion of UTF-8 but official UTF-8 is more
-strict; Its ranges is much narrower (0 .. 10FFFF), some sequences are
-not allowed (i.e. Those used in the surrogate pair, 0xFFFE, et al).
-
-Now that is overruled by Larry Wall himself.
-
- From: Larry Wall <larry@wall.org>
- Date: December 04, 2004 11:51:58 JST
- To: perl-unicode@perl.org
- Subject: Re: Make Encode.pm support the real UTF-8
- Message-Id: <20041204025158.GA28754@wall.org>
-
- On Fri, Dec 03, 2004 at 10:12:12PM +0000, Tim Bunce wrote:
- : I've no problem with 'utf8' being perl's unrestricted uft8 encoding,
- : but "UTF-8" is the name of the standard and should give the
- : corresponding behaviour.
-
- For what it's worth, that's how I've always kept them straight in my
- head.
-
- Also for what it's worth, Perl 6 will mostly default to strict but
- make it easy to switch back to lax.
-
- Larry
-
-Do you copy? As of Perl 5.8.7, B<UTF-8> means strict, official UTF-8
-while B<utf8> means liberal, lax, version thereof. And Encode version
-2.10 or later thus groks the difference between C<UTF-8> and C"utf8".
-
- encode("utf8", "\x{FFFF_FFFF}", 1); # okay
- encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks
-
-C<UTF-8> in Encode is actually a canonical name for C<utf-8-strict>.
-Yes, the hyphen between "UTF" and "8" is important. Without it Encode
-goes "liberal"
-
- find_encoding("UTF-8")->name # is 'utf-8-strict'
- find_encoding("utf-8")->name # ditto. names are case insensitive
- find_encoding("utf8")->name # ditto. "_" are treated as "-"
- find_encoding("UTF8")->name # is 'utf8'.
-
-
-=head1 SEE ALSO
-
-L<Encode::Encoding>,
-L<Encode::Supported>,
-L<Encode::PerlIO>,
-L<encoding>,
-L<perlebcdic>,
-L<perlfunc/open>,
-L<perlunicode>,
-L<utf8>,
-the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt>
-
-=head1 MAINTAINER
-
-This project was originated by Nick Ing-Simmons and later maintained
-by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full
-list of people involved. For any questions, use
-E<lt>perl-unicode@perl.orgE<gt> so we can all share.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Alias.pm b/Master/tlpkg/installer/perllib/Encode/Alias.pm
deleted file mode 100644
index c0bbf69f469..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Alias.pm
+++ /dev/null
@@ -1,341 +0,0 @@
-package Encode::Alias;
-use strict;
-no warnings 'redefine';
-use Encode;
-our $VERSION = do { my @r = (q$Revision: 2.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-sub DEBUG () { 0 }
-
-use base qw(Exporter);
-
-# Public, encouraged API is exported by default
-
-our @EXPORT =
- qw (
- define_alias
- find_alias
- );
-
-our @Alias; # ordered matching list
-our %Alias; # cached known aliases
-
-sub find_alias{
- my $class = shift;
- my $find = shift;
- unless (exists $Alias{$find}) {
- $Alias{$find} = undef; # Recursion guard
- for (my $i=0; $i < @Alias; $i += 2){
- my $alias = $Alias[$i];
- my $val = $Alias[$i+1];
- my $new;
- if (ref($alias) eq 'Regexp' && $find =~ $alias){
- DEBUG and warn "eval $val";
- $new = eval $val;
- DEBUG and $@ and warn "$val, $@";
- }elsif (ref($alias) eq 'CODE'){
- DEBUG and warn "$alias", "->", "($find)";
- $new = $alias->($find);
- }elsif (lc($find) eq lc($alias)){
- $new = $val;
- }
- if (defined($new)){
- next if $new eq $find; # avoid (direct) recursion on bugs
- DEBUG and warn "$alias, $new";
- my $enc = (ref($new)) ? $new : Encode::find_encoding($new);
- if ($enc){
- $Alias{$find} = $enc;
- last;
- }
- }
- }
- # case insensitive search when canonical is not in all lowercase
- # RT ticket #7835
- unless ($Alias{$find}){
- my $lcfind = lc($find);
- for my $name (keys %Encode::Encoding, keys %Encode::ExtModule){
- $lcfind eq lc($name) or next;
- $Alias{$find} = Encode::find_encoding($name);
- DEBUG and warn "$find => $name";
- }
- }
- }
- if (DEBUG){
- my $name;
- if (my $e = $Alias{$find}){
- $name = $e->name;
- }else{
- $name = "";
- }
- warn "find_alias($class, $find)->name = $name";
- }
- return $Alias{$find};
-}
-
-sub define_alias{
- while (@_){
- my ($alias,$name) = splice(@_,0,2);
- unshift(@Alias, $alias => $name); # newer one has precedence
- if (ref($alias)){
- # clear %Alias cache to allow overrides
- my @a = keys %Alias;
- for my $k (@a){
- if (ref($alias) eq 'Regexp' && $k =~ $alias){
- DEBUG and warn "delete \$Alias\{$k\}";
- delete $Alias{$k};
- }
- elsif (ref($alias) eq 'CODE'){
- DEBUG and warn "delete \$Alias\{$k\}";
- delete $Alias{$alias->($name)};
- }
- }
- }else{
- DEBUG and warn "delete \$Alias\{$alias\}";
- delete $Alias{$alias};
- }
- }
-}
-
-# Allow latin-1 style names as well
-# 0 1 2 3 4 5 6 7 8 9 10
-our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 );
-# Allow winlatin1 style names as well
-our %Winlatin2cp = (
- 'latin1' => 1252,
- 'latin2' => 1250,
- 'cyrillic' => 1251,
- 'greek' => 1253,
- 'turkish' => 1254,
- 'hebrew' => 1255,
- 'arabic' => 1256,
- 'baltic' => 1257,
- 'vietnamese' => 1258,
- );
-
-init_aliases();
-
-sub undef_aliases{
- @Alias = ();
- %Alias = ();
-}
-
-sub init_aliases
-{
- undef_aliases();
- # Try all-lower-case version should all else fails
- define_alias( qr/^(.*)$/ => '"\L$1"' );
-
- # UTF/UCS stuff
- define_alias( qr/^UTF-?7$/i => '"UTF-7"');
- define_alias( qr/^UCS-?2-?LE$/i => '"UCS-2LE"' );
- define_alias( qr/^UCS-?2-?(BE)?$/i => '"UCS-2BE"',
- qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")',
- qr/^iso-10646-1$/i => '"UCS-2BE"' );
- define_alias( qr/^UTF-?(16|32)-?BE$/i => '"UTF-$1BE"',
- qr/^UTF-?(16|32)-?LE$/i => '"UTF-$1LE"',
- qr/^UTF-?(16|32)$/i => '"UTF-$1"',
- );
- # ASCII
- define_alias(qr/^(?:US-?)ascii$/i => '"ascii"');
- define_alias('C' => 'ascii');
- define_alias(qr/\bISO[-_]?646[-_]?US$/i => '"ascii"');
- # Allow variants of iso-8859-1 etc.
- define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' );
-
- # At least HP-UX has these.
- define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' );
-
- # More HP stuff.
- define_alias( qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i => '"${1}8"' );
-
- # The Official name of ASCII.
- define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' );
-
- # This is a font issue, not an encoding issue.
- # (The currency symbol of the Latin 1 upper half
- # has been redefined as the euro symbol.)
- define_alias( qr/^(.+)\@euro$/i => '"$1"' );
-
- define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i
- => 'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef' );
-
- define_alias( qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish|
- hebrew|arabic|baltic|vietnamese)$/ix =>
- '"cp" . $Encode::Alias::Winlatin2cp{lc($1)}' );
-
- # Common names for non-latin preferred MIME names
- define_alias( 'ascii' => 'US-ascii',
- 'cyrillic' => 'iso-8859-5',
- 'arabic' => 'iso-8859-6',
- 'greek' => 'iso-8859-7',
- 'hebrew' => 'iso-8859-8',
- 'thai' => 'iso-8859-11',
- 'tis620' => 'iso-8859-11',
- );
-
- # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN.
- # And Microsoft has their own naming (again, surprisingly).
- # And windows-* is registered in IANA!
- define_alias( qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"');
-
- # Sometimes seen with a leading zero.
- # define_alias( qr/\bcp037\b/i => '"cp37"');
-
- # Mac Mappings
- # predefined in *.ucm; unneeded
- # define_alias( qr/\bmacIcelandic$/i => '"macIceland"');
- define_alias( qr/^mac_(.*)$/i => '"mac$1"');
- # Ououououou. gone. They are differente!
- # define_alias( qr/\bmacRomanian$/i => '"macRumanian"');
-
- # Standardize on the dashed versions.
- define_alias( qr/\bkoi8[\s\-_]*([ru])$/i => '"koi8-$1"' );
-
- unless ($Encode::ON_EBCDIC){
- # for Encode::CN
- define_alias( qr/\beuc.*cn$/i => '"euc-cn"' );
- define_alias( qr/\bcn.*euc$/i => '"euc-cn"' );
- # define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' )
- # CP936 doesn't have vendor-addon for GBK, so they're identical.
- define_alias( qr/^gbk$/i => '"cp936"');
- # This fixes gb2312 vs. euc-cn confusion, practically
- define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' );
- # for Encode::JP
- define_alias( qr/\bjis$/i => '"7bit-jis"' );
- define_alias( qr/\beuc.*jp$/i => '"euc-jp"' );
- define_alias( qr/\bjp.*euc$/i => '"euc-jp"' );
- define_alias( qr/\bujis$/i => '"euc-jp"' );
- define_alias( qr/\bshift.*jis$/i => '"shiftjis"' );
- define_alias( qr/\bsjis$/i => '"shiftjis"' );
- define_alias( qr/\bwindows-31j$/i => '"cp932"' );
- # for Encode::KR
- define_alias( qr/\beuc.*kr$/i => '"euc-kr"' );
- define_alias( qr/\bkr.*euc$/i => '"euc-kr"' );
- # This fixes ksc5601 vs. euc-kr confusion, practically
- define_alias( qr/(?:x-)?uhc$/i => '"cp949"' );
- define_alias( qr/(?:x-)?windows-949$/i => '"cp949"' );
- define_alias( qr/\bks_c_5601-1987$/i => '"cp949"' );
- # for Encode::TW
- define_alias( qr/\bbig-?5$/i => '"big5-eten"' );
- define_alias( qr/\bbig5-?et(?:en)?$/i => '"big5-eten"' );
- define_alias( qr/\btca[-_]?big5$/i => '"big5-eten"' );
- define_alias( qr/\bbig5-?hk(?:scs)?$/i => '"big5-hkscs"' );
- define_alias( qr/\bhk(?:scs)?[-_]?big5$/i => '"big5-hkscs"' );
- }
- # utf8 is blessed :)
- define_alias( qr/^UTF-8$/i => '"utf-8-strict"');
- # At last, Map white space and _ to '-'
- define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' );
-}
-
-1;
-__END__
-
-# TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8
-# TODO: HP-UX '15' encodings japanese15 korean15 roi15
-# TODO: Cyrillic encoding ISO-IR-111 (useful?)
-# TODO: Armenian encoding ARMSCII-8
-# TODO: Hebrew encoding ISO-8859-8-1
-# TODO: Thai encoding TCVN
-# TODO: Vietnamese encodings VPS
-# TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese
-# ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic
-# Farsi Georgian Gujarati Gurmukhi Hebrew Japanese
-# Kannada Khmer Korean Laotian Malayalam Mongolian
-# Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese
-
-=head1 NAME
-
-Encode::Alias - alias definitions to encodings
-
-=head1 SYNOPSIS
-
- use Encode;
- use Encode::Alias;
- define_alias( newName => ENCODING);
-
-=head1 DESCRIPTION
-
-Allows newName to be used as an alias for ENCODING. ENCODING may be
-either the name of an encoding or an encoding object (as described
-in L<Encode>).
-
-Currently I<newName> can be specified in the following ways:
-
-=over 4
-
-=item As a simple string.
-
-=item As a qr// compiled regular expression, e.g.:
-
- define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' );
-
-In this case, if I<ENCODING> is not a reference, it is C<eval>-ed
-in order to allow C<$1> etc. to be substituted. The example is one
-way to alias names as used in X11 fonts to the MIME names for the
-iso-8859-* family. Note the double quotes inside the single quotes.
-
-(or, you don't have to do this yourself because this example is predefined)
-
-If you are using a regex here, you have to use the quotes as shown or
-it won't work. Also note that regex handling is tricky even for the
-experienced. Use this feature with caution.
-
-=item As a code reference, e.g.:
-
- define_alias( sub {shift =~ /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
-
-The same effect as the example above in a different way. The coderef
-takes the alias name as an argument and returns a canonical name on
-success or undef if not. Note the second argument is not required.
-Use this with even more caution than the regex version.
-
-=back
-
-=head3 Changes in code reference aliasing
-
-As of Encode 1.87, the older form
-
- define_alias( sub { return /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
-
-no longer works.
-
-Encode up to 1.86 internally used "local $_" to implement ths older
-form. But consider the code below;
-
- use Encode;
- $_ = "eeeee" ;
- while (/(e)/g) {
- my $utf = decode('aliased-encoding-name', $1);
- print "position:",pos,"\n";
- }
-
-Prior to Encode 1.86 this fails because of "local $_".
-
-=head2 Alias overloading
-
-You can override predefined aliases by simply applying define_alias().
-The new alias is always evaluated first, and when necessary,
-define_alias() flushes the internal cache to make the new definition
-available.
-
- # redirect SHIFT_JIS to MS/IBM Code Page 932, which is a
- # superset of SHIFT_JIS
-
- define_alias( qr/shift.*jis$/i => '"cp932"' );
- define_alias( qr/sjis$/i => '"cp932"' );
-
-If you want to zap all predefined aliases, you can use
-
- Encode::Alias->undef_aliases;
-
-to do so. And
-
- Encode::Alias->init_aliases;
-
-gets the factory settings back.
-
-=head1 SEE ALSO
-
-L<Encode>, L<Encode::Supported>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Encode/Byte.pm b/Master/tlpkg/installer/perllib/Encode/Byte.pm
deleted file mode 100644
index d40c1c3d9d1..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Byte.pm
+++ /dev/null
@@ -1,119 +0,0 @@
-package Encode::Byte;
-use Encode;
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use XSLoader;
-XSLoader::load(__PACKAGE__,$VERSION);
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::Byte - Single Byte Encodings
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $greek = encode("iso-8859-7", $utf8); # loads Encode::Byte implicitly
- $utf8 = decode("iso-8859-7", $greek); # ditto
-
-=head1 ABSTRACT
-
-This module implements various single byte encodings. For most cases it uses
-\x80-\xff (upper half) to map non-ASCII characters. Encodings
-supported are as follows.
-
- Canonical Alias Description
- --------------------------------------------------------------------
- # ISO 8859 series
- (iso-8859-1 is in built-in)
- iso-8859-2 latin2 [ISO]
- iso-8859-3 latin3 [ISO]
- iso-8859-4 latin4 [ISO]
- iso-8859-5 [ISO]
- iso-8859-6 [ISO]
- iso-8859-7 [ISO]
- iso-8859-8 [ISO]
- iso-8859-9 latin5 [ISO]
- iso-8859-10 latin6 [ISO]
- iso-8859-11
- (iso-8859-12 is nonexistent)
- iso-8859-13 latin7 [ISO]
- iso-8859-14 latin8 [ISO]
- iso-8859-15 latin9 [ISO]
- iso-8859-16 latin10 [ISO]
-
- # Cyrillic
- koi8-f
- koi8-r cp878 [RFC1489]
- koi8-u [RFC2319]
-
- # Vietnamese
- viscii
-
- # all cp* are also available as ibm-*, ms-*, and windows-*
- # also see L<http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp>
-
- cp424
- cp437
- cp737
- cp775
- cp850
- cp852
- cp855
- cp856
- cp857
- cp860
- cp861
- cp862
- cp863
- cp864
- cp865
- cp866
- cp869
- cp874
- cp1006
- cp1250 WinLatin2
- cp1251 WinCyrillic
- cp1252 WinLatin1
- cp1253 WinGreek
- cp1254 WinTurkish
- cp1255 WinHebrew
- cp1256 WinArabic
- cp1257 WinBaltic
- cp1258 WinVietnamese
-
- # Macintosh
- # Also see L<http://developer.apple.com/technotes/tn/tn1150.html>
- MacArabic
- MacCentralEurRoman
- MacCroatian
- MacCyrillic
- MacFarsi
- MacGreek
- MacHebrew
- MacIcelandic
- MacRoman
- MacRomanian
- MacRumanian
- MacSami
- MacThai
- MacTurkish
- MacUkrainian
-
- # More vendor encodings
- AdobeStandardEncoding
- nextstep
- gsm0338 # used in GSM handsets
- hp-roman8
-
-=head1 DESCRIPTION
-
-To find how to use this module in detail, see L<Encode>.
-
-=head1 SEE ALSO
-
-L<Encode>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/CJKConstants.pm b/Master/tlpkg/installer/perllib/Encode/CJKConstants.pm
deleted file mode 100644
index 4ab40e72ef2..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/CJKConstants.pm
+++ /dev/null
@@ -1,66 +0,0 @@
-#
-# $Id: CJKConstants.pm,v 2.0 2004/05/16 20:55:16 dankogai Exp $
-#
-
-package Encode::CJKConstants;
-
-use strict;
-
-our $RCSID = q$Id: CJKConstants.pm,v 2.0 2004/05/16 20:55:16 dankogai Exp $;
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use Carp;
-
-require Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT = qw();
-our @EXPORT_OK = qw(%CHARCODE %ESC %RE);
-our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK, @EXPORT ] );
-
-my %_0208 = (
- 1978 => '\e\$\@',
- 1983 => '\e\$B',
- 1990 => '\e&\@\e\$B',
- );
-
-our %CHARCODE = (
- UNDEF_EUC => "\xa2\xae", # ¢® in EUC
- UNDEF_SJIS => "\x81\xac", # ¢® in SJIS
- UNDEF_JIS => "\xa2\xf7", # ¢÷ -- used in unicode
- UNDEF_UNICODE => "\x20\x20", # ¢÷ -- used in unicode
- );
-
-our %ESC = (
- GB_2312 => "\e\$A",
- JIS_0208 => "\e\$B",
- JIS_0212 => "\e\$(D",
- KSC_5601 => "\e\$(C",
- ASC => "\e\(B",
- KANA => "\e\(I",
- '2022_KR' => "\e\$)C",
- );
-
-our %RE =
- (
- ASCII => '[\x00-\x7f]',
- BIN => '[\x00-\x06\x7f\xff]',
- EUC_0212 => '\x8f[\xa1-\xfe][\xa1-\xfe]',
- EUC_C => '[\xa1-\xfe][\xa1-\xfe]',
- EUC_KANA => '\x8e[\xa1-\xdf]',
- JIS_0208 => "$_0208{1978}|$_0208{1983}|$_0208{1990}",
- JIS_0212 => "\e" . '\$\(D',
- ISO_ASC => "\e" . '\([BJ]',
- JIS_KANA => "\e" . '\(I',
- '2022_KR' => "\e" . '\$\)C',
- SJIS_C => '[\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc]',
- SJIS_KANA => '[\xa1-\xdf]',
- UTF8 => '[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf][\x80-\xbf]'
- );
-
-1;
-
-=head1 NAME
-
-Encode::CJKConstants.pm -- Internally used by Encode::??::ISO_2022_*
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/CN.pm b/Master/tlpkg/installer/perllib/Encode/CN.pm
deleted file mode 100644
index be5a830fc51..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/CN.pm
+++ /dev/null
@@ -1,76 +0,0 @@
-package Encode::CN;
-BEGIN {
- if (ord("A") == 193) {
- die "Encode::CN not supported on EBCDIC\n";
- }
-}
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use Encode;
-use XSLoader;
-XSLoader::load(__PACKAGE__,$VERSION);
-
-# Relocated from Encode.pm
-
-use Encode::CN::HZ;
-# use Encode::CN::2022_CN;
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::CN - China-based Chinese Encodings
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $euc_cn = encode("euc-cn", $utf8); # loads Encode::CN implicitly
- $utf8 = decode("euc-cn", $euc_cn); # ditto
-
-=head1 DESCRIPTION
-
-This module implements China-based Chinese charset encodings.
-Encodings supported are as follows.
-
- Canonical Alias Description
- --------------------------------------------------------------------
- euc-cn /\beuc.*cn$/i EUC (Extended Unix Character)
- /\bcn.*euc$/i
- /\bGB[-_ ]?2312(?:\D.*$|$)/i (see below)
- gb2312-raw The raw (low-bit) GB2312 character map
- gb12345-raw Traditional chinese counterpart to
- GB2312 (raw)
- iso-ir-165 GB2312 + GB6345 + GB8565 + additions
- MacChineseSimp GB2312 + Apple Additions
- cp936 Code Page 936, also known as GBK
- (Extended GuoBiao)
- hz 7-bit escaped GB2312 encoding
- --------------------------------------------------------------------
-
-To find how to use this module in detail, see L<Encode>.
-
-=head1 NOTES
-
-Due to size concerns, C<GB 18030> (an extension to C<GBK>) is distributed
-separately on CPAN, under the name L<Encode::HanExtra>. That module
-also contains extra Taiwan-based encodings.
-
-=head1 BUGS
-
-When you see C<charset=gb2312> on mails and web pages, they really
-mean C<euc-cn> encodings. To fix that, C<gb2312> is aliased to C<euc-cn>.
-Use C<gb2312-raw> when you really mean it.
-
-The ASCII region (0x00-0x7f) is preserved for all encodings, even though
-this conflicts with mappings by the Unicode Consortium. See
-
-L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en>
-
-to find out why it is implemented that way.
-
-=head1 SEE ALSO
-
-L<Encode>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/CN/HZ.pm b/Master/tlpkg/installer/perllib/Encode/CN/HZ.pm
deleted file mode 100644
index fbc6ba60ced..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/CN/HZ.pm
+++ /dev/null
@@ -1,196 +0,0 @@
-package Encode::CN::HZ;
-
-use strict;
-
-use vars qw($VERSION);
-$VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use Encode qw(:fallbacks);
-
-use base qw(Encode::Encoding);
-__PACKAGE__->Define('hz');
-
-# HZ is a combination of ASCII and escaped GB, so we implement it
-# with the GB2312(raw) encoding here. Cf. RFCs 1842 & 1843.
-
-# not ported for EBCDIC. Which should be used, "~" or "\x7E"?
-
-sub needs_lines { 1 }
-
-sub decode ($$;$)
-{
- my ($obj,$str,$chk) = @_;
-
- my $GB = Encode::find_encoding('gb2312-raw');
- my $ret = '';
- my $in_ascii = 1; # default mode is ASCII.
-
- while (length $str) {
- if ($in_ascii) { # ASCII mode
- if ($str =~ s/^([\x00-\x7D\x7F]+)//) { # no '~' => ASCII
- $ret .= $1;
- # EBCDIC should need ascii2native, but not ported.
- }
- elsif ($str =~ s/^\x7E\x7E//) { # escaped tilde
- $ret .= '~';
- }
- elsif ($str =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII
- 1; # no-op
- }
- elsif ($str =~ s/^\x7E\x7B//) { # '~{'
- $in_ascii = 0; # to GB
- }
- else { # encounters an invalid escape, \x80 or greater
- last;
- }
- }
- else { # GB mode; the byte ranges are as in RFC 1843.
- if ($str =~ s/^((?:[\x21-\x77][\x21-\x7E])+)//) {
- $ret .= $GB->decode($1, $chk);
- }
- elsif ($str =~ s/^\x7E\x7D//) { # '~}'
- $in_ascii = 1;
- }
- else { # invalid
- last;
- }
- }
- }
- $_[1] = '' if $chk; # needs_lines guarantees no partial character
- return $ret;
-}
-
-sub cat_decode {
- my ($obj, undef, $src, $pos, $trm, $chk) = @_;
- my ($rdst, $rsrc, $rpos) = \@_[1..3];
-
- my $GB = Encode::find_encoding('gb2312-raw');
- my $ret = '';
- my $in_ascii = 1; # default mode is ASCII.
-
- my $ini_pos = pos($$rsrc);
-
- substr($src, 0, $pos) = '';
-
- my $ini_len = bytes::length($src);
-
- # $trm is the first of the pair '~~', then 2nd tilde is to be removed.
- # XXX: Is better C<$src =~ s/^\x7E// or die if ...>?
- $src =~ s/^\x7E// if $trm eq "\x7E";
-
- while (length $src) {
- my $now;
- if ($in_ascii) { # ASCII mode
- if ($src =~ s/^([\x00-\x7D\x7F])//) { # no '~' => ASCII
- $now = $1;
- }
- elsif ($src =~ s/^\x7E\x7E//) { # escaped tilde
- $now = '~';
- }
- elsif ($src =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII
- next;
- }
- elsif ($src =~ s/^\x7E\x7B//) { # '~{'
- $in_ascii = 0; # to GB
- next;
- }
- else { # encounters an invalid escape, \x80 or greater
- last;
- }
- }
- else { # GB mode; the byte ranges are as in RFC 1843.
- if ($src =~ s/^((?:[\x21-\x77][\x21-\x7F])+)//) {
- $now = $GB->decode($1, $chk);
- }
- elsif ($src =~ s/^\x7E\x7D//) { # '~}'
- $in_ascii = 1;
- next;
- }
- else { # invalid
- last;
- }
- }
-
- next if ! defined $now;
-
- $ret .= $now;
-
- if ($now eq $trm) {
- $$rdst .= $ret;
- $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src);
- pos($$rsrc) = $ini_pos;
- return 1;
- }
- }
-
- $$rdst .= $ret;
- $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src);
- pos($$rsrc) = $ini_pos;
- return ''; # terminator not found
-}
-
-
-sub encode($$;$)
-{
- my ($obj,$str,$chk) = @_;
-
- my $GB = Encode::find_encoding('gb2312-raw');
- my $ret = '';
- my $in_ascii = 1; # default mode is ASCII.
-
- no warnings 'utf8'; # $str may be malformed UTF8 at the end of a chunk.
-
- while (length $str) {
- if ($str =~ s/^([[:ascii:]]+)//) {
- my $tmp = $1;
- $tmp =~ s/~/~~/g; # escapes tildes
- if (! $in_ascii) {
- $ret .= "\x7E\x7D"; # '~}'
- $in_ascii = 1;
- }
- $ret .= pack 'a*', $tmp; # remove UTF8 flag.
- }
- elsif ($str =~ s/(.)//) {
- my $s = $1;
- my $tmp = $GB->encode($s, $chk);
- last if !defined $tmp;
- if (length $tmp == 2) { # maybe a valid GB char (XXX)
- if ($in_ascii) {
- $ret .= "\x7E\x7B"; # '~{'
- $in_ascii = 0;
- }
- $ret .= $tmp;
- }
- elsif (length $tmp) { # maybe FALLBACK in ASCII (XXX)
- if (!$in_ascii) {
- $ret .= "\x7E\x7D"; # '~}'
- $in_ascii = 1;
- }
- $ret .= $tmp;
- }
- }
- else { # if $str is malformed UTF8 *and* if length $str != 0.
- last;
- }
- }
- $_[1] = $str if $chk;
-
- # The state at the end of the chunk is discarded, even if in GB mode.
- # That results in the combination of GB-OUT and GB-IN, i.e. "~}~{".
- # Parhaps it is harmless, but further investigations may be required...
-
- if (! $in_ascii) {
- $ret .= "\x7E\x7D"; # '~}'
- $in_ascii = 1;
- }
- return $ret;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::CN::HZ -- internally used by Encode::CN
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Changes.e2x b/Master/tlpkg/installer/perllib/Encode/Changes.e2x
deleted file mode 100644
index 5c67c55cb93..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Changes.e2x
+++ /dev/null
@@ -1,7 +0,0 @@
-#
-# $Id: Changes.e2x,v 2.0 2004/05/16 20:55:15 dankogai Exp $
-# Revision history for Perl extension Encode::$_Name_.
-#
-
-0.01 $_Now_
- Autogenerated by enc2xs version $_Version_.
diff --git a/Master/tlpkg/installer/perllib/Encode/Config.pm b/Master/tlpkg/installer/perllib/Encode/Config.pm
deleted file mode 100644
index d69b92d8248..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Config.pm
+++ /dev/null
@@ -1,166 +0,0 @@
-#
-# Demand-load module list
-#
-package Encode::Config;
-our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use strict;
-
-our %ExtModule =
- (
- # Encode::Byte
- #iso-8859-1 is in Encode.pm itself
- 'iso-8859-2' => 'Encode::Byte',
- 'iso-8859-3' => 'Encode::Byte',
- 'iso-8859-4' => 'Encode::Byte',
- 'iso-8859-5' => 'Encode::Byte',
- 'iso-8859-6' => 'Encode::Byte',
- 'iso-8859-7' => 'Encode::Byte',
- 'iso-8859-8' => 'Encode::Byte',
- 'iso-8859-9' => 'Encode::Byte',
- 'iso-8859-10' => 'Encode::Byte',
- 'iso-8859-11' => 'Encode::Byte',
- 'iso-8859-13' => 'Encode::Byte',
- 'iso-8859-14' => 'Encode::Byte',
- 'iso-8859-15' => 'Encode::Byte',
- 'iso-8859-16' => 'Encode::Byte',
- 'koi8-f' => 'Encode::Byte',
- 'koi8-r' => 'Encode::Byte',
- 'koi8-u' => 'Encode::Byte',
- 'viscii' => 'Encode::Byte',
- 'cp424' => 'Encode::Byte',
- 'cp437' => 'Encode::Byte',
- 'cp737' => 'Encode::Byte',
- 'cp775' => 'Encode::Byte',
- 'cp850' => 'Encode::Byte',
- 'cp852' => 'Encode::Byte',
- 'cp855' => 'Encode::Byte',
- 'cp856' => 'Encode::Byte',
- 'cp857' => 'Encode::Byte',
- 'cp860' => 'Encode::Byte',
- 'cp861' => 'Encode::Byte',
- 'cp862' => 'Encode::Byte',
- 'cp863' => 'Encode::Byte',
- 'cp864' => 'Encode::Byte',
- 'cp865' => 'Encode::Byte',
- 'cp866' => 'Encode::Byte',
- 'cp869' => 'Encode::Byte',
- 'cp874' => 'Encode::Byte',
- 'cp1006' => 'Encode::Byte',
- 'cp1250' => 'Encode::Byte',
- 'cp1251' => 'Encode::Byte',
- 'cp1252' => 'Encode::Byte',
- 'cp1253' => 'Encode::Byte',
- 'cp1254' => 'Encode::Byte',
- 'cp1255' => 'Encode::Byte',
- 'cp1256' => 'Encode::Byte',
- 'cp1257' => 'Encode::Byte',
- 'cp1258' => 'Encode::Byte',
- 'AdobeStandardEncoding' => 'Encode::Byte',
- 'MacArabic' => 'Encode::Byte',
- 'MacCentralEurRoman' => 'Encode::Byte',
- 'MacCroatian' => 'Encode::Byte',
- 'MacCyrillic' => 'Encode::Byte',
- 'MacFarsi' => 'Encode::Byte',
- 'MacGreek' => 'Encode::Byte',
- 'MacHebrew' => 'Encode::Byte',
- 'MacIcelandic' => 'Encode::Byte',
- 'MacRoman' => 'Encode::Byte',
- 'MacRomanian' => 'Encode::Byte',
- 'MacRumanian' => 'Encode::Byte',
- 'MacSami' => 'Encode::Byte',
- 'MacThai' => 'Encode::Byte',
- 'MacTurkish' => 'Encode::Byte',
- 'MacUkrainian' => 'Encode::Byte',
- 'nextstep' => 'Encode::Byte',
- 'hp-roman8' => 'Encode::Byte',
- 'gsm0338' => 'Encode::Byte',
- # Encode::EBCDIC
- 'cp37' => 'Encode::EBCDIC',
- 'cp500' => 'Encode::EBCDIC',
- 'cp875' => 'Encode::EBCDIC',
- 'cp1026' => 'Encode::EBCDIC',
- 'cp1047' => 'Encode::EBCDIC',
- 'posix-bc' => 'Encode::EBCDIC',
- # Encode::Symbol
- 'dingbats' => 'Encode::Symbol',
- 'symbol' => 'Encode::Symbol',
- 'AdobeSymbol' => 'Encode::Symbol',
- 'AdobeZdingbat' => 'Encode::Symbol',
- 'MacDingbats' => 'Encode::Symbol',
- 'MacSymbol' => 'Encode::Symbol',
- # Encode::Unicode
- 'UCS-2BE' => 'Encode::Unicode',
- 'UCS-2LE' => 'Encode::Unicode',
- 'UTF-16' => 'Encode::Unicode',
- 'UTF-16BE' => 'Encode::Unicode',
- 'UTF-16LE' => 'Encode::Unicode',
- 'UTF-32' => 'Encode::Unicode',
- 'UTF-32BE' => 'Encode::Unicode',
- 'UTF-32LE' => 'Encode::Unicode',
- 'UTF-7' => 'Encode::Unicode::UTF7',
- );
-
-unless (ord("A") == 193){
- %ExtModule =
- (
- %ExtModule,
- 'euc-cn' => 'Encode::CN',
- 'gb12345-raw' => 'Encode::CN',
- 'gb2312-raw' => 'Encode::CN',
- 'hz' => 'Encode::CN',
- 'iso-ir-165' => 'Encode::CN',
- 'cp936' => 'Encode::CN',
- 'MacChineseSimp' => 'Encode::CN',
-
- '7bit-jis' => 'Encode::JP',
- 'euc-jp' => 'Encode::JP',
- 'iso-2022-jp' => 'Encode::JP',
- 'iso-2022-jp-1' => 'Encode::JP',
- 'jis0201-raw' => 'Encode::JP',
- 'jis0208-raw' => 'Encode::JP',
- 'jis0212-raw' => 'Encode::JP',
- 'cp932' => 'Encode::JP',
- 'MacJapanese' => 'Encode::JP',
- 'shiftjis' => 'Encode::JP',
-
-
- 'euc-kr' => 'Encode::KR',
- 'iso-2022-kr' => 'Encode::KR',
- 'johab' => 'Encode::KR',
- 'ksc5601-raw' => 'Encode::KR',
- 'cp949' => 'Encode::KR',
- 'MacKorean' => 'Encode::KR',
-
- 'big5-eten' => 'Encode::TW',
- 'big5-hkscs' => 'Encode::TW',
- 'cp950' => 'Encode::TW',
- 'MacChineseTrad' => 'Encode::TW',
-
- #'big5plus' => 'Encode::HanExtra',
- #'euc-tw' => 'Encode::HanExtra',
- #'gb18030' => 'Encode::HanExtra',
-
- 'MIME-Header' => 'Encode::MIME::Header',
- 'MIME-B' => 'Encode::MIME::Header',
- 'MIME-Q' => 'Encode::MIME::Header',
-
- 'MIME-Header-ISO_2022_JP' => 'Encode::MIME::Header::ISO_2022_JP',
- );
-}
-
-#
-# Why not export ? to keep ConfigLocal Happy!
-#
-while (my ($enc,$mod) = each %ExtModule){
- $Encode::ExtModule{$enc} = $mod;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::Config -- internally used by Encode
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x b/Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x
deleted file mode 100644
index e203dfded50..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x
+++ /dev/null
@@ -1,13 +0,0 @@
-#
-# Local demand-load module list
-#
-# You should not edit this file by hand! use "enc2xs -C"
-#
-package Encode::ConfigLocal;
-our $VERSION = $_LocalVer_;
-
-use strict;
-
-$_ModLines_
-
-1;
diff --git a/Master/tlpkg/installer/perllib/Encode/EBCDIC.pm b/Master/tlpkg/installer/perllib/Encode/EBCDIC.pm
deleted file mode 100644
index 200a82fea46..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/EBCDIC.pm
+++ /dev/null
@@ -1,43 +0,0 @@
-package Encode::EBCDIC;
-use Encode;
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use XSLoader;
-XSLoader::load(__PACKAGE__,$VERSION);
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::EBCDIC - EBCDIC Encodings
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $posix_bc = encode("posix-bc", $utf8); # loads Encode::EBCDIC implicitly
- $utf8 = decode("", $posix_bc); # ditto
-
-=head1 ABSTRACT
-
-This module implements various EBCDIC-Based encodings. Encodings
-supported are as follows.
-
- Canonical Alias Description
- --------------------------------------------------------------------
- cp37
- cp500
- cp875
- cp1026
- cp1047
- posix-bc
-
-=head1 DESCRIPTION
-
-To find how to use this module in detail, see L<Encode>.
-
-=head1 SEE ALSO
-
-L<Encode>, L<perlebcdic>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Encoder.pm b/Master/tlpkg/installer/perllib/Encode/Encoder.pm
deleted file mode 100644
index fe2a2b90ff6..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Encoder.pm
+++ /dev/null
@@ -1,249 +0,0 @@
-#
-# $Id: Encoder.pm,v 2.0 2004/05/16 20:55:17 dankogai Exp $
-#
-package Encode::Encoder;
-use strict;
-use warnings;
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-require Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT_OK = qw ( encoder );
-
-our $AUTOLOAD;
-sub DEBUG () { 0 }
-use Encode qw(encode decode find_encoding from_to);
-use Carp;
-
-sub new{
- my ($class, $data, $encname) = @_;
- unless($encname){
- $encname = Encode::is_utf8($data) ? 'utf8' : '';
- }else{
- my $obj = find_encoding($encname)
- or croak __PACKAGE__, ": unknown encoding: $encname";
- $encname = $obj->name;
- }
- my $self = {
- data => $data,
- encoding => $encname,
- };
- bless $self => $class;
-}
-
-sub encoder{ __PACKAGE__->new(@_) }
-
-sub data{
- my ($self, $data) = @_;
- if (defined $data){
- $self->{data} = $data;
- return $data;
- }else{
- return $self->{data};
- }
-}
-
-sub encoding{
- my ($self, $encname) = @_;
- if ($encname){
- my $obj = find_encoding($encname)
- or confess __PACKAGE__, ": unknown encoding: $encname";
- $self->{encoding} = $obj->name;
- return $self;
- }else{
- return $self->{encoding}
- }
-}
-
-sub bytes {
- my ($self, $encname) = @_;
- $encname ||= $self->{encoding};
- my $obj = find_encoding($encname)
- or confess __PACKAGE__, ": unknown encoding: $encname";
- $self->{data} = $obj->decode($self->{data}, 1);
- $self->{encoding} = '' ;
- return $self;
-}
-
-sub DESTROY{ # defined so it won't autoload.
- DEBUG and warn shift;
-}
-
-sub AUTOLOAD {
- my $self = shift;
- my $type = ref($self)
- or confess "$self is not an object";
- my $myname = $AUTOLOAD;
- $myname =~ s/.*://; # strip fully-qualified portion
- my $obj = find_encoding($myname)
- or confess __PACKAGE__, ": unknown encoding: $myname";
- DEBUG and warn $self->{encoding}, " => ", $obj->name;
- if ($self->{encoding}){
- from_to($self->{data}, $self->{encoding}, $obj->name, 1);
- }else{
- $self->{data} = $obj->encode($self->{data}, 1);
- }
- $self->{encoding} = $obj->name;
- return $self;
-}
-
-use overload
- q("") => sub { $_[0]->{data} },
- q(0+) => sub { use bytes (); bytes::length($_[0]->{data}) },
- fallback => 1,
- ;
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::Encoder -- Object Oriented Encoder
-
-=head1 SYNOPSIS
-
- use Encode::Encoder;
- # Encode::encode("ISO-8859-1", $data);
- Encode::Encoder->new($data)->iso_8859_1; # OOP way
- # shortcut
- use Encode::Encoder qw(encoder);
- encoder($data)->iso_8859_1;
- # you can stack them!
- encoder($data)->iso_8859_1->base64; # provided base64() is defined
- # you can use it as a decoder as well
- encoder($base64)->bytes('base64')->latin1;
- # stringified
- print encoder($data)->utf8->latin1; # prints the string in latin1
- # numified
- encoder("\x{abcd}\x{ef}g")->utf8 == 6; # true. bytes::length($data)
-
-=head1 ABSTRACT
-
-B<Encode::Encoder> allows you to use Encode in an object-oriented
-style. This is not only more intuitive than a functional approach,
-but also handier when you want to stack encodings. Suppose you want
-your UTF-8 string converted to Latin1 then Base64: you can simply say
-
- my $base64 = encoder($utf8)->latin1->base64;
-
-instead of
-
- my $latin1 = encode("latin1", $utf8);
- my $base64 = encode_base64($utf8);
-
-or the lazier and more convoluted
-
- my $base64 = encode_base64(encode("latin1", $utf8));
-
-=head1 Description
-
-Here is how to use this module.
-
-=over 4
-
-=item *
-
-There are at least two instance variables stored in a hash reference,
-{data} and {encoding}.
-
-=item *
-
-When there is no method, it takes the method name as the name of the
-encoding and encodes the instance I<data> with I<encoding>. If successful,
-the instance I<encoding> is set accordingly.
-
-=item *
-
-You can retrieve the result via -E<gt>data but usually you don't have to
-because the stringify operator ("") is overridden to do exactly that.
-
-=back
-
-=head2 Predefined Methods
-
-This module predefines the methods below:
-
-=over 4
-
-=item $e = Encode::Encoder-E<gt>new([$data, $encoding]);
-
-returns an encoder object. Its data is initialized with $data if
-present, and its encoding is set to $encoding if present.
-
-When $encoding is omitted, it defaults to utf8 if $data is already in
-utf8 or "" (empty string) otherwise.
-
-=item encoder()
-
-is an alias of Encode::Encoder-E<gt>new(). This one is exported on demand.
-
-=item $e-E<gt>data([$data])
-
-When $data is present, sets the instance data to $data and returns the
-object itself. Otherwise, the current instance data is returned.
-
-=item $e-E<gt>encoding([$encoding])
-
-When $encoding is present, sets the instance encoding to $encoding and
-returns the object itself. Otherwise, the current instance encoding is
-returned.
-
-=item $e-E<gt>bytes([$encoding])
-
-decodes instance data from $encoding, or the instance encoding if
-omitted. If the conversion is successful, the instance encoding
-will be set to "".
-
-The name I<bytes> was deliberately picked to avoid namespace tainting
--- this module may be used as a base class so method names that appear
-in Encode::Encoding are avoided.
-
-=back
-
-=head2 Example: base64 transcoder
-
-This module is designed to work with L<Encode::Encoding>.
-To make the Base64 transcoder example above really work, you could
-write a module like this:
-
- package Encode::Base64;
- use base 'Encode::Encoding';
- __PACKAGE__->Define('base64');
- use MIME::Base64;
- sub encode{
- my ($obj, $data) = @_;
- return encode_base64($data);
- }
- sub decode{
- my ($obj, $data) = @_;
- return decode_base64($data);
- }
- 1;
- __END__
-
-And your caller module would be something like this:
-
- use Encode::Encoder;
- use Encode::Base64;
-
- # now you can really do the following
-
- encoder($data)->iso_8859_1->base64;
- encoder($base64)->bytes('base64')->latin1;
-
-=head2 Operator Overloading
-
-This module overloads two operators, stringify ("") and numify (0+).
-
-Stringify dumps the data inside the object.
-
-Numify returns the number of bytes in the instance data.
-
-They come in handy when you want to print or find the size of data.
-
-=head1 SEE ALSO
-
-L<Encode>,
-L<Encode::Encoding>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Encoding.pm b/Master/tlpkg/installer/perllib/Encode/Encoding.pm
deleted file mode 100644
index 06af9fb6994..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Encoding.pm
+++ /dev/null
@@ -1,341 +0,0 @@
-package Encode::Encoding;
-# Base class for classes which implement encodings
-use strict;
-our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-require Encode;
-
-sub DEBUG { 0 }
-sub Define
-{
- my $obj = shift;
- my $canonical = shift;
- $obj = bless { Name => $canonical },$obj unless ref $obj;
- # warn "$canonical => $obj\n";
- Encode::define_encoding($obj, $canonical, @_);
-}
-
-sub name { return shift->{'Name'} }
-
-# sub renew { return $_[0] }
-
-sub renew {
- my $self = shift;
- my $clone = bless { %$self } => ref($self);
- $clone->{renewed}++; # so the caller can see it
- DEBUG and warn $clone->{renewed};
- return $clone;
-}
-
-sub renewed{ return $_[0]->{renewed} || 0 }
-
-*new_sequence = \&renew;
-
-sub needs_lines { 0 };
-
-sub perlio_ok {
- eval{ require PerlIO::encoding };
- return $@ ? 0 : 1;
-}
-
-# (Temporary|legacy) methods
-
-sub toUnicode { shift->decode(@_) }
-sub fromUnicode { shift->encode(@_) }
-
-#
-# Needs to be overloaded or just croak
-#
-
-sub encode {
- require Carp;
- my $obj = shift;
- my $class = ref($obj) ? ref($obj) : $obj;
- Carp::croak($class . "->encode() not defined!");
-}
-
-sub decode{
- require Carp;
- my $obj = shift;
- my $class = ref($obj) ? ref($obj) : $obj;
- Carp::croak($class . "->encode() not defined!");
-}
-
-sub DESTROY {}
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::Encoding - Encode Implementation Base Class
-
-=head1 SYNOPSIS
-
- package Encode::MyEncoding;
- use base qw(Encode::Encoding);
-
- __PACKAGE__->Define(qw(myCanonical myAlias));
-
-=head1 DESCRIPTION
-
-As mentioned in L<Encode>, encodings are (in the current
-implementation at least) defined as objects. The mapping of encoding
-name to object is via the C<%Encode::Encoding> hash. Though you can
-directly manipulate this hash, it is strongly encouraged to use this
-base class module and add encode() and decode() methods.
-
-=head2 Methods you should implement
-
-You are strongly encouraged to implement methods below, at least
-either encode() or decode().
-
-=over 4
-
-=item -E<gt>encode($string [,$check])
-
-MUST return the octet sequence representing I<$string>.
-
-=over 2
-
-=item *
-
-If I<$check> is true, it SHOULD modify I<$string> in place to remove
-the converted part (i.e. the whole string unless there is an error).
-If perlio_ok() is true, SHOULD becomes MUST.
-
-=item *
-
-If an error occurs, it SHOULD return the octet sequence for the
-fragment of string that has been converted and modify $string in-place
-to remove the converted part leaving it starting with the problem
-fragment. If perlio_ok() is true, SHOULD becomes MUST.
-
-=item *
-
-If I<$check> is is false then C<encode> MUST make a "best effort" to
-convert the string - for example, by using a replacement character.
-
-=back
-
-=item -E<gt>decode($octets [,$check])
-
-MUST return the string that I<$octets> represents.
-
-=over 2
-
-=item *
-
-If I<$check> is true, it SHOULD modify I<$octets> in place to remove
-the converted part (i.e. the whole sequence unless there is an
-error). If perlio_ok() is true, SHOULD becomes MUST.
-
-=item *
-
-If an error occurs, it SHOULD return the fragment of string that has
-been converted and modify $octets in-place to remove the converted
-part leaving it starting with the problem fragment. If perlio_ok() is
-true, SHOULD becomes MUST.
-
-=item *
-
-If I<$check> is false then C<decode> should make a "best effort" to
-convert the string - for example by using Unicode's "\x{FFFD}" as a
-replacement character.
-
-=back
-
-=back
-
-If you want your encoding to work with L<encoding> pragma, you should
-also implement the method below.
-
-=over 4
-
-=item -E<gt>cat_decode($destination, $octets, $offset, $terminator [,$check])
-
-MUST decode I<$octets> with I<$offset> and concatenate it to I<$destination>.
-Decoding will terminate when $terminator (a string) appears in output.
-I<$offset> will be modified to the last $octets position at end of decode.
-Returns true if $terminator appears output, else returns false.
-
-=back
-
-=head2 Other methods defined in Encode::Encodings
-
-You do not have to override methods shown below unless you have to.
-
-=over 4
-
-=item -E<gt>name
-
-Predefined As:
-
- sub name { return shift->{'Name'} }
-
-MUST return the string representing the canonical name of the encoding.
-
-=item -E<gt>renew
-
-Predefined As:
-
- sub renew {
- my $self = shift;
- my $clone = bless { %$self } => ref($self);
- $clone->{renewed}++;
- return $clone;
- }
-
-This method reconstructs the encoding object if necessary. If you need
-to store the state during encoding, this is where you clone your object.
-
-PerlIO ALWAYS calls this method to make sure it has its own private
-encoding object.
-
-=item -E<gt>renewed
-
-Predefined As:
-
- sub renewed { $_[0]->{renewed} || 0 }
-
-Tells whether the object is renewed (and how many times). Some
-modules emit C<Use of uninitialized value in null operation> warning
-unless the value is numeric so return 0 for false.
-
-=item -E<gt>perlio_ok()
-
-Predefined As:
-
- sub perlio_ok {
- eval{ require PerlIO::encoding };
- return $@ ? 0 : 1;
- }
-
-If your encoding does not support PerlIO for some reasons, just;
-
- sub perlio_ok { 0 }
-
-=item -E<gt>needs_lines()
-
-Predefined As:
-
- sub needs_lines { 0 };
-
-If your encoding can work with PerlIO but needs line buffering, you
-MUST define this method so it returns true. 7bit ISO-2022 encodings
-are one example that needs this. When this method is missing, false
-is assumed.
-
-=back
-
-=head2 Example: Encode::ROT13
-
- package Encode::ROT13;
- use strict;
- use base qw(Encode::Encoding);
-
- __PACKAGE__->Define('rot13');
-
- sub encode($$;$){
- my ($obj, $str, $chk) = @_;
- $str =~ tr/A-Za-z/N-ZA-Mn-za-m/;
- $_[1] = '' if $chk; # this is what in-place edit means
- return $str;
- }
-
- # Jr pna or ynml yvxr guvf;
- *decode = \&encode;
-
- 1;
-
-=head1 Why the heck Encode API is different?
-
-It should be noted that the I<$check> behaviour is different from the
-outer public API. The logic is that the "unchecked" case is useful
-when the encoding is part of a stream which may be reporting errors
-(e.g. STDERR). In such cases, it is desirable to get everything
-through somehow without causing additional errors which obscure the
-original one. Also, the encoding is best placed to know what the
-correct replacement character is, so if that is the desired behaviour
-then letting low level code do it is the most efficient.
-
-By contrast, if I<$check> is true, the scheme above allows the
-encoding to do as much as it can and tell the layer above how much
-that was. What is lacking at present is a mechanism to report what
-went wrong. The most likely interface will be an additional method
-call to the object, or perhaps (to avoid forcing per-stream objects
-on otherwise stateless encodings) an additional parameter.
-
-It is also highly desirable that encoding classes inherit from
-C<Encode::Encoding> as a base class. This allows that class to define
-additional behaviour for all encoding objects.
-
- package Encode::MyEncoding;
- use base qw(Encode::Encoding);
-
- __PACKAGE__->Define(qw(myCanonical myAlias));
-
-to create an object with C<< bless {Name => ...}, $class >>, and call
-define_encoding. They inherit their C<name> method from
-C<Encode::Encoding>.
-
-=head2 Compiled Encodings
-
-For the sake of speed and efficiency, most of the encodings are now
-supported via a I<compiled form>: XS modules generated from UCM
-files. Encode provides the enc2xs tool to achieve that. Please see
-L<enc2xs> for more details.
-
-=head1 SEE ALSO
-
-L<perlmod>, L<enc2xs>
-
-=begin future
-
-=over 4
-
-=item Scheme 1
-
-The fixup routine gets passed the remaining fragment of string being
-processed. It modifies it in place to remove bytes/characters it can
-understand and returns a string used to represent them. For example:
-
- sub fixup {
- my $ch = substr($_[0],0,1,'');
- return sprintf("\x{%02X}",ord($ch);
- }
-
-This scheme is close to how the underlying C code for Encode works,
-but gives the fixup routine very little context.
-
-=item Scheme 2
-
-The fixup routine gets passed the original string, an index into
-it of the problem area, and the output string so far. It appends
-what it wants to the output string and returns a new index into the
-original string. For example:
-
- sub fixup {
- # my ($s,$i,$d) = @_;
- my $ch = substr($_[0],$_[1],1);
- $_[2] .= sprintf("\x{%02X}",ord($ch);
- return $_[1]+1;
- }
-
-This scheme gives maximal control to the fixup routine but is more
-complicated to code, and may require that the internals of Encode be tweaked to
-keep the original string intact.
-
-=item Other Schemes
-
-Hybrids of the above.
-
-Multiple return values rather than in-place modifications.
-
-Index into the string could be C<pos($str)> allowing C<s/\G...//>.
-
-=back
-
-=end future
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Guess.pm b/Master/tlpkg/installer/perllib/Encode/Guess.pm
deleted file mode 100644
index 5692cee9a4a..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Guess.pm
+++ /dev/null
@@ -1,351 +0,0 @@
-package Encode::Guess;
-use strict;
-
-use Encode qw(:fallbacks find_encoding);
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-my $Canon = 'Guess';
-sub DEBUG () { 0 }
-our %DEF_SUSPECTS = map { $_ => find_encoding($_) } qw(ascii utf8);
-$Encode::Encoding{$Canon} =
- bless {
- Name => $Canon,
- Suspects => { %DEF_SUSPECTS },
- } => __PACKAGE__;
-
-use base qw(Encode::Encoding);
-sub needs_lines { 1 }
-sub perlio_ok { 0 }
-
-our @EXPORT = qw(guess_encoding);
-our $NoUTFAutoGuess = 0;
-our $UTF8_BOM = pack("C3", 0xef, 0xbb, 0xbf);
-
-sub import { # Exporter not used so we do it on our own
- my $callpkg = caller;
- for my $item (@EXPORT){
- no strict 'refs';
- *{"$callpkg\::$item"} = \&{"$item"};
- }
- set_suspects(@_);
-}
-
-sub set_suspects{
- my $class = shift;
- my $self = ref($class) ? $class : $Encode::Encoding{$Canon};
- $self->{Suspects} = { %DEF_SUSPECTS };
- $self->add_suspects(@_);
-}
-
-sub add_suspects{
- my $class = shift;
- my $self = ref($class) ? $class : $Encode::Encoding{$Canon};
- for my $c (@_){
- my $e = find_encoding($c) or die "Unknown encoding: $c";
- $self->{Suspects}{$e->name} = $e;
- DEBUG and warn "Added: ", $e->name;
- }
-}
-
-sub decode($$;$){
- my ($obj, $octet, $chk) = @_;
- my $guessed = guess($obj, $octet);
- unless (ref($guessed)){
- require Carp;
- Carp::croak($guessed);
- }
- my $utf8 = $guessed->decode($octet, $chk);
- $_[1] = $octet if $chk;
- return $utf8;
-}
-
-sub guess_encoding{
- guess($Encode::Encoding{$Canon}, @_);
-}
-
-sub guess {
- my $class = shift;
- my $obj = ref($class) ? $class : $Encode::Encoding{$Canon};
- my $octet = shift;
-
- # sanity check
- return unless defined $octet and length $octet;
-
- # cheat 0: utf8 flag;
- if ( Encode::is_utf8($octet) ) {
- return find_encoding('utf8') unless $NoUTFAutoGuess;
- Encode::_utf8_off($octet);
- }
- # cheat 1: BOM
- use Encode::Unicode;
- unless ($NoUTFAutoGuess) {
- my $BOM = pack('C3', unpack("C3", $octet));
- return find_encoding('utf8')
- if (defined $BOM and $BOM eq $UTF8_BOM);
- $BOM = unpack('N', $octet);
- return find_encoding('UTF-32')
- if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe0000));
- $BOM = unpack('n', $octet);
- return find_encoding('UTF-16')
- if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe));
- if ($octet =~ /\x00/o){ # if \x00 found, we assume UTF-(16|32)(BE|LE)
- my $utf;
- my ($be, $le) = (0, 0);
- if ($octet =~ /\x00\x00/o){ # UTF-32(BE|LE) assumed
- $utf = "UTF-32";
- for my $char (unpack('N*', $octet)){
- $char & 0x0000ffff and $be++;
- $char & 0xffff0000 and $le++;
- }
- }else{ # UTF-16(BE|LE) assumed
- $utf = "UTF-16";
- for my $char (unpack('n*', $octet)){
- $char & 0x00ff and $be++;
- $char & 0xff00 and $le++;
- }
- }
- DEBUG and warn "$utf, be == $be, le == $le";
- $be == $le
- and return
- "Encodings ambiguous between $utf BE and LE ($be, $le)";
- $utf .= ($be > $le) ? 'BE' : 'LE';
- return find_encoding($utf);
- }
- }
- my %try = %{$obj->{Suspects}};
- for my $c (@_){
- my $e = find_encoding($c) or die "Unknown encoding: $c";
- $try{$e->name} = $e;
- DEBUG and warn "Added: ", $e->name;
- }
- my $nline = 1;
- for my $line (split /\r\n?|\n/, $octet){
- # cheat 2 -- \e in the string
- if ($line =~ /\e/o){
- my @keys = keys %try;
- delete @try{qw/utf8 ascii/};
- for my $k (@keys){
- ref($try{$k}) eq 'Encode::XS' and delete $try{$k};
- }
- }
- my %ok = %try;
- # warn join(",", keys %try);
- for my $k (keys %try){
- my $scratch = $line;
- $try{$k}->decode($scratch, FB_QUIET);
- if ($scratch eq ''){
- DEBUG and warn sprintf("%4d:%-24s ok\n", $nline, $k);
- }else{
- use bytes ();
- DEBUG and
- warn sprintf("%4d:%-24s not ok; %d bytes left\n",
- $nline, $k, bytes::length($scratch));
- delete $ok{$k};
- }
- }
- %ok or return "No appropriate encodings found!";
- if (scalar(keys(%ok)) == 1){
- my ($retval) = values(%ok);
- return $retval;
- }
- %try = %ok; $nline++;
- }
- $try{ascii} or
- return "Encodings too ambiguous: ", join(" or ", keys %try);
- return $try{ascii};
-}
-
-
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::Guess -- Guesses encoding from data
-
-=head1 SYNOPSIS
-
- # if you are sure $data won't contain anything bogus
-
- use Encode;
- use Encode::Guess qw/euc-jp shiftjis 7bit-jis/;
- my $utf8 = decode("Guess", $data);
- my $data = encode("Guess", $utf8); # this doesn't work!
-
- # more elaborate way
- use Encode::Guess;
- my $enc = guess_encoding($data, qw/euc-jp shiftjis 7bit-jis/);
- ref($enc) or die "Can't guess: $enc"; # trap error this way
- $utf8 = $enc->decode($data);
- # or
- $utf8 = decode($enc->name, $data)
-
-=head1 ABSTRACT
-
-Encode::Guess enables you to guess in what encoding a given data is
-encoded, or at least tries to.
-
-=head1 DESCRIPTION
-
-By default, it checks only ascii, utf8 and UTF-16/32 with BOM.
-
- use Encode::Guess; # ascii/utf8/BOMed UTF
-
-To use it more practically, you have to give the names of encodings to
-check (I<suspects> as follows). The name of suspects can either be
-canonical names or aliases.
-
-CAVEAT: Unlike UTF-(16|32), BOM in utf8 is NOT AUTOMATICALLY STRIPPED.
-
- # tries all major Japanese Encodings as well
- use Encode::Guess qw/euc-jp shiftjis 7bit-jis/;
-
-If the C<$Encode::Guess::NoUTFAutoGuess> variable is set to a true
-value, no heuristics will be applied to UTF8/16/32, and the result
-will be limited to the suspects and C<ascii>.
-
-=over 4
-
-=item Encode::Guess->set_suspects
-
-You can also change the internal suspects list via C<set_suspects>
-method.
-
- use Encode::Guess;
- Encode::Guess->set_suspects(qw/euc-jp shiftjis 7bit-jis/);
-
-=item Encode::Guess->add_suspects
-
-Or you can use C<add_suspects> method. The difference is that
-C<set_suspects> flushes the current suspects list while
-C<add_suspects> adds.
-
- use Encode::Guess;
- Encode::Guess->add_suspects(qw/euc-jp shiftjis 7bit-jis/);
- # now the suspects are euc-jp,shiftjis,7bit-jis, AND
- # euc-kr,euc-cn, and big5-eten
- Encode::Guess->add_suspects(qw/euc-kr euc-cn big5-eten/);
-
-=item Encode::decode("Guess" ...)
-
-When you are content with suspects list, you can now
-
- my $utf8 = Encode::decode("Guess", $data);
-
-=item Encode::Guess->guess($data)
-
-But it will croak if:
-
-=over
-
-=item *
-
-Two or more suspects remain
-
-=item *
-
-No suspects left
-
-=back
-
-So you should instead try this;
-
- my $decoder = Encode::Guess->guess($data);
-
-On success, $decoder is an object that is documented in
-L<Encode::Encoding>. So you can now do this;
-
- my $utf8 = $decoder->decode($data);
-
-On failure, $decoder now contains an error message so the whole thing
-would be as follows;
-
- my $decoder = Encode::Guess->guess($data);
- die $decoder unless ref($decoder);
- my $utf8 = $decoder->decode($data);
-
-=item guess_encoding($data, [, I<list of suspects>])
-
-You can also try C<guess_encoding> function which is exported by
-default. It takes $data to check and it also takes the list of
-suspects by option. The optional suspect list is I<not reflected> to
-the internal suspects list.
-
- my $decoder = guess_encoding($data, qw/euc-jp euc-kr euc-cn/);
- die $decoder unless ref($decoder);
- my $utf8 = $decoder->decode($data);
- # check only ascii and utf8
- my $decoder = guess_encoding($data);
-
-=back
-
-=head1 CAVEATS
-
-=over 4
-
-=item *
-
-Because of the algorithm used, ISO-8859 series and other single-byte
-encodings do not work well unless either one of ISO-8859 is the only
-one suspect (besides ascii and utf8).
-
- use Encode::Guess;
- # perhaps ok
- my $decoder = guess_encoding($data, 'latin1');
- # definitely NOT ok
- my $decoder = guess_encoding($data, qw/latin1 greek/);
-
-The reason is that Encode::Guess guesses encoding by trial and error.
-It first splits $data into lines and tries to decode the line for each
-suspect. It keeps it going until all but one encoding is eliminated
-out of suspects list. ISO-8859 series is just too successful for most
-cases (because it fills almost all code points in \x00-\xff).
-
-=item *
-
-Do not mix national standard encodings and the corresponding vendor
-encodings.
-
- # a very bad idea
- my $decoder
- = guess_encoding($data, qw/shiftjis MacJapanese cp932/);
-
-The reason is that vendor encoding is usually a superset of national
-standard so it becomes too ambiguous for most cases.
-
-=item *
-
-On the other hand, mixing various national standard encodings
-automagically works unless $data is too short to allow for guessing.
-
- # This is ok if $data is long enough
- my $decoder =
- guess_encoding($data, qw/euc-cn
- euc-jp shiftjis 7bit-jis
- euc-kr
- big5-eten/);
-
-=item *
-
-DO NOT PUT TOO MANY SUSPECTS! Don't you try something like this!
-
- my $decoder = guess_encoding($data,
- Encode->encodings(":all"));
-
-=back
-
-It is, after all, just a guess. You should alway be explicit when it
-comes to encodings. But there are some, especially Japanese,
-environment that guess-coding is a must. Use this module with care.
-
-=head1 TO DO
-
-Encode::Guess does not work on EBCDIC platforms.
-
-=head1 SEE ALSO
-
-L<Encode>, L<Encode::Encoding>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Encode/JP.pm b/Master/tlpkg/installer/perllib/Encode/JP.pm
deleted file mode 100644
index 01ad37f30db..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/JP.pm
+++ /dev/null
@@ -1,97 +0,0 @@
-package Encode::JP;
-BEGIN {
- if (ord("A") == 193) {
- die "Encode::JP not supported on EBCDIC\n";
- }
-}
-use Encode;
-our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use XSLoader;
-XSLoader::load(__PACKAGE__,$VERSION);
-
-use Encode::JP::JIS7;
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::JP - Japanese Encodings
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $euc_jp = encode("euc-jp", $utf8); # loads Encode::JP implicitly
- $utf8 = decode("euc-jp", $euc_jp); # ditto
-
-=head1 ABSTRACT
-
-This module implements Japanese charset encodings. Encodings
-supported are as follows.
-
- Canonical Alias Description
- --------------------------------------------------------------------
- euc-jp /\beuc.*jp$/i EUC (Extended Unix Character)
- /\bjp.*euc/i
- /\bujis$/i
- shiftjis /\bshift.*jis$/i Shift JIS (aka MS Kanji)
- /\bsjis$/i
- 7bit-jis /\bjis$/i 7bit JIS
- iso-2022-jp ISO-2022-JP [RFC1468]
- = 7bit JIS with all Halfwidth Kana
- converted to Fullwidth
- iso-2022-jp-1 ISO-2022-JP-1 [RFC2237]
- = ISO-2022-JP with JIS X 0212-1990
- support. See below
- MacJapanese Shift JIS + Apple vendor mappings
- cp932 /\bwindows-31j$/i Code Page 932
- = Shift JIS + MS/IBM vendor mappings
- jis0201-raw JIS0201, raw format
- jis0208-raw JIS0201, raw format
- jis0212-raw JIS0201, raw format
- --------------------------------------------------------------------
-
-=head1 DESCRIPTION
-
-To find out how to use this module in detail, see L<Encode>.
-
-=head1 Note on ISO-2022-JP(-1)?
-
-ISO-2022-JP-1 (RFC2237) is a superset of ISO-2022-JP (RFC1468) which
-adds support for JIS X 0212-1990. That means you can use the same
-code to decode to utf8 but not vice versa.
-
- $utf8 = decode('iso-2022-jp-1', $stream);
-
-and
-
- $utf8 = decode('iso-2022-jp', $stream);
-
-yield the same result but
-
- $with_0212 = encode('iso-2022-jp-1', $utf8);
-
-is now different from
-
- $without_0212 = encode('iso-2022-jp', $utf8 );
-
-In the latter case, characters that map to 0212 are first converted
-to U+3013 (0xA2AE in EUC-JP; a white square also known as 'Tofu' or
-'geta mark') then fed to the decoding engine. U+FFFD is not used,
-in order to preserve text layout as much as possible.
-
-=head1 BUGS
-
-The ASCII region (0x00-0x7f) is preserved for all encodings, even
-though this conflicts with mappings by the Unicode Consortium. See
-
-L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en>
-
-to find out why it is implemented that way.
-
-=head1 SEE ALSO
-
-L<Encode>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm b/Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm
deleted file mode 100644
index 0c84c62fda6..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm
+++ /dev/null
@@ -1,174 +0,0 @@
-#
-# $Id: H2Z.pm,v 2.0 2004/05/16 20:55:17 dankogai Exp $
-#
-
-package Encode::JP::H2Z;
-
-use strict;
-
-our $RCSID = q$Id: H2Z.pm,v 2.0 2004/05/16 20:55:17 dankogai Exp $;
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use Encode::CJKConstants qw(:all);
-
-use vars qw(%_D2Z $_PAT_D2Z
- %_Z2D $_PAT_Z2D
- %_H2Z $_PAT_H2Z
- %_Z2H $_PAT_Z2H);
-
-%_H2Z = (
- "\x8e\xa1" => "\xa1\xa3", #¡£
- "\x8e\xa2" => "\xa1\xd6", #¡Ö
- "\x8e\xa3" => "\xa1\xd7", #¡×
- "\x8e\xa4" => "\xa1\xa2", #¡¢
- "\x8e\xa5" => "\xa1\xa6", #¡¦
- "\x8e\xa6" => "\xa5\xf2", #¥ò
- "\x8e\xa7" => "\xa5\xa1", #¥¡
- "\x8e\xa8" => "\xa5\xa3", #¥£
- "\x8e\xa9" => "\xa5\xa5", #¥¥
- "\x8e\xaa" => "\xa5\xa7", #¥§
- "\x8e\xab" => "\xa5\xa9", #¥©
- "\x8e\xac" => "\xa5\xe3", #¥ã
- "\x8e\xad" => "\xa5\xe5", #¥å
- "\x8e\xae" => "\xa5\xe7", #¥ç
- "\x8e\xaf" => "\xa5\xc3", #¥Ã
- "\x8e\xb0" => "\xa1\xbc", #¡¼
- "\x8e\xb1" => "\xa5\xa2", #¥¢
- "\x8e\xb2" => "\xa5\xa4", #¥¤
- "\x8e\xb3" => "\xa5\xa6", #¥¦
- "\x8e\xb4" => "\xa5\xa8", #¥¨
- "\x8e\xb5" => "\xa5\xaa", #¥ª
- "\x8e\xb6" => "\xa5\xab", #¥«
- "\x8e\xb7" => "\xa5\xad", #¥­
- "\x8e\xb8" => "\xa5\xaf", #¥¯
- "\x8e\xb9" => "\xa5\xb1", #¥±
- "\x8e\xba" => "\xa5\xb3", #¥³
- "\x8e\xbb" => "\xa5\xb5", #¥µ
- "\x8e\xbc" => "\xa5\xb7", #¥·
- "\x8e\xbd" => "\xa5\xb9", #¥¹
- "\x8e\xbe" => "\xa5\xbb", #¥»
- "\x8e\xbf" => "\xa5\xbd", #¥½
- "\x8e\xc0" => "\xa5\xbf", #¥¿
- "\x8e\xc1" => "\xa5\xc1", #¥Á
- "\x8e\xc2" => "\xa5\xc4", #¥Ä
- "\x8e\xc3" => "\xa5\xc6", #¥Æ
- "\x8e\xc4" => "\xa5\xc8", #¥È
- "\x8e\xc5" => "\xa5\xca", #¥Ê
- "\x8e\xc6" => "\xa5\xcb", #¥Ë
- "\x8e\xc7" => "\xa5\xcc", #¥Ì
- "\x8e\xc8" => "\xa5\xcd", #¥Í
- "\x8e\xc9" => "\xa5\xce", #¥Î
- "\x8e\xca" => "\xa5\xcf", #¥Ï
- "\x8e\xcb" => "\xa5\xd2", #¥Ò
- "\x8e\xcc" => "\xa5\xd5", #¥Õ
- "\x8e\xcd" => "\xa5\xd8", #¥Ø
- "\x8e\xce" => "\xa5\xdb", #¥Û
- "\x8e\xcf" => "\xa5\xde", #¥Þ
- "\x8e\xd0" => "\xa5\xdf", #¥ß
- "\x8e\xd1" => "\xa5\xe0", #¥à
- "\x8e\xd2" => "\xa5\xe1", #¥á
- "\x8e\xd3" => "\xa5\xe2", #¥â
- "\x8e\xd4" => "\xa5\xe4", #¥ä
- "\x8e\xd5" => "\xa5\xe6", #¥æ
- "\x8e\xd6" => "\xa5\xe8", #¥è
- "\x8e\xd7" => "\xa5\xe9", #¥é
- "\x8e\xd8" => "\xa5\xea", #¥ê
- "\x8e\xd9" => "\xa5\xeb", #¥ë
- "\x8e\xda" => "\xa5\xec", #¥ì
- "\x8e\xdb" => "\xa5\xed", #¥í
- "\x8e\xdc" => "\xa5\xef", #¥ï
- "\x8e\xdd" => "\xa5\xf3", #¥ó
- "\x8e\xde" => "\xa1\xab", #¡«
- "\x8e\xdf" => "\xa1\xac", #¡¬
-);
-
-%_D2Z = (
- "\x8e\xb6\x8e\xde" => "\xa5\xac", #¥¬
- "\x8e\xb7\x8e\xde" => "\xa5\xae", #¥®
- "\x8e\xb8\x8e\xde" => "\xa5\xb0", #¥°
- "\x8e\xb9\x8e\xde" => "\xa5\xb2", #¥²
- "\x8e\xba\x8e\xde" => "\xa5\xb4", #¥´
- "\x8e\xbb\x8e\xde" => "\xa5\xb6", #¥¶
- "\x8e\xbc\x8e\xde" => "\xa5\xb8", #¥¸
- "\x8e\xbd\x8e\xde" => "\xa5\xba", #¥º
- "\x8e\xbe\x8e\xde" => "\xa5\xbc", #¥¼
- "\x8e\xbf\x8e\xde" => "\xa5\xbe", #¥¾
- "\x8e\xc0\x8e\xde" => "\xa5\xc0", #¥À
- "\x8e\xc1\x8e\xde" => "\xa5\xc2", #¥Â
- "\x8e\xc2\x8e\xde" => "\xa5\xc5", #¥Å
- "\x8e\xc3\x8e\xde" => "\xa5\xc7", #¥Ç
- "\x8e\xc4\x8e\xde" => "\xa5\xc9", #¥É
- "\x8e\xca\x8e\xde" => "\xa5\xd0", #¥Ð
- "\x8e\xcb\x8e\xde" => "\xa5\xd3", #¥Ó
- "\x8e\xcc\x8e\xde" => "\xa5\xd6", #¥Ö
- "\x8e\xcd\x8e\xde" => "\xa5\xd9", #¥Ù
- "\x8e\xce\x8e\xde" => "\xa5\xdc", #¥Ü
- "\x8e\xca\x8e\xdf" => "\xa5\xd1", #¥Ñ
- "\x8e\xcb\x8e\xdf" => "\xa5\xd4", #¥Ô
- "\x8e\xcc\x8e\xdf" => "\xa5\xd7", #¥×
- "\x8e\xcd\x8e\xdf" => "\xa5\xda", #¥Ú
- "\x8e\xce\x8e\xdf" => "\xa5\xdd", #¥Ý
- "\x8e\xb3\x8e\xde" => "\xa5\xf4", #¥ô
-);
-
-# init only once;
-
-#$_PAT_D2Z = join("|", keys %_D2Z);
-#$_PAT_H2Z = join("|", keys %_H2Z);
-
-%_Z2H = reverse %_H2Z;
-%_Z2D = reverse %_D2Z;
-
-#$_PAT_Z2H = join("|", keys %_Z2H);
-#$_PAT_Z2D = join("|", keys %_Z2D);
-
-sub h2z {
- no warnings qw(uninitialized);
- my $r_str = shift;
- my ($keep_dakuten) = @_;
- my $n = 0;
- unless ($keep_dakuten){
- $n = (
- $$r_str =~ s(
- ($RE{EUC_KANA}
- (?:\x8e[\xde\xdf])?)
- ){
- my $str = $1;
- $_D2Z{$str} || $_H2Z{$str} ||
- # in case dakuten and handakuten are side-by-side!
- $_H2Z{substr($str,0,2)} . $_H2Z{substr($str,2,2)};
- }eogx
- );
- }else{
- $n = (
- $$r_str =~ s(
- ($RE{EUC_KANA})
- ){
- $_H2Z{$1};
- }eogx
- );
- }
- $n;
-}
-
-sub z2h {
- my $r_str = shift;
- my $n = (
- $$r_str =~ s(
- ($RE{EUC_C}|$RE{EUC_0212}|$RE{EUC_KANA})
- ){
- $_Z2D{$1} || $_Z2H{$1} || $1;
- }eogx
- );
- $n;
-}
-
-1;
-__END__
-
-
-=head1 NAME
-
-Encode::JP::H2Z -- internally used by Encode::JP::2022_JP*
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm b/Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm
deleted file mode 100644
index 28503ec760c..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm
+++ /dev/null
@@ -1,165 +0,0 @@
-package Encode::JP::JIS7;
-use strict;
-
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use Encode qw(:fallbacks);
-
-for my $name ('7bit-jis', 'iso-2022-jp', 'iso-2022-jp-1'){
- my $h2z = ($name eq '7bit-jis') ? 0 : 1;
- my $jis0212 = ($name eq 'iso-2022-jp') ? 0 : 1;
-
- $Encode::Encoding{$name} =
- bless {
- Name => $name,
- h2z => $h2z,
- jis0212 => $jis0212,
- } => __PACKAGE__;
-}
-
-use base qw(Encode::Encoding);
-
-# we override this to 1 so PerlIO works
-sub needs_lines { 1 }
-
-use Encode::CJKConstants qw(:all);
-
-#
-# decode is identical for all 2022 variants
-#
-
-sub decode($$;$)
-{
- my ($obj, $str, $chk) = @_;
- my $residue = '';
- if ($chk){
- $str =~ s/([^\x00-\x7f].*)$//so and $residue = $1;
- }
- $residue .= jis_euc(\$str);
- $_[1] = $residue if $chk;
- return Encode::decode('euc-jp', $str, FB_PERLQQ);
-}
-
-#
-# encode is different
-#
-
-sub encode($$;$)
-{
- require Encode::JP::H2Z;
- my ($obj, $utf8, $chk) = @_;
- # empty the input string in the stack so perlio is ok
- $_[1] = '' if $chk;
- my ($h2z, $jis0212) = @$obj{qw(h2z jis0212)};
- my $octet = Encode::encode('euc-jp', $utf8, FB_PERLQQ) ;
- $h2z and &Encode::JP::H2Z::h2z(\$octet);
- euc_jis(\$octet, $jis0212);
- return $octet;
-}
-
-#
-# cat_decode
-#
-my $re_scan_jis_g = qr{
- \G ( ($RE{JIS_0212}) | $RE{JIS_0208} |
- ($RE{ISO_ASC}) | ($RE{JIS_KANA}) | )
- ([^\e]*)
-}x;
-sub cat_decode { # ($obj, $dst, $src, $pos, $trm, $chk)
- my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk
- my ($rdst, $rsrc, $rpos) = \@_[1,2,3];
- local ${^ENCODING};
- use bytes;
- my $opos = pos($$rsrc);
- pos($$rsrc) = $pos;
- while ($$rsrc =~ /$re_scan_jis_g/gc) {
- my ($esc, $esc_0212, $esc_asc, $esc_kana, $chunk) =
- ($1, $2, $3, $4, $5);
-
- unless ($chunk) { $esc or last; next; }
-
- if ($esc && !$esc_asc) {
- $chunk =~ tr/\x21-\x7e/\xa1-\xfe/;
- if ($esc_kana) {
- $chunk =~ s/([\xa1-\xdf])/\x8e$1/og;
- } elsif ($esc_0212) {
- $chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
- }
- $chunk = Encode::decode('euc-jp', $chunk, 0);
- }
- elsif ((my $npos = index($chunk, $trm)) >= 0) {
- $$rdst .= substr($chunk, 0, $npos + length($trm));
- $$rpos += length($esc) + $npos + length($trm);
- pos($$rsrc) = $opos;
- return 1;
- }
- $$rdst .= $chunk;
- $$rpos = pos($$rsrc);
- }
- $$rpos = pos($$rsrc);
- pos($$rsrc) = $opos;
- return '';
-}
-
-# JIS<->EUC
-my $re_scan_jis = qr{
- (?:($RE{JIS_0212})|$RE{JIS_0208}|($RE{ISO_ASC})|($RE{JIS_KANA}))([^\e]*)
-}x;
-
-sub jis_euc {
- local ${^ENCODING};
- my $r_str = shift;
- $$r_str =~ s($re_scan_jis)
- {
- my ($esc_0212, $esc_asc, $esc_kana, $chunk) =
- ($1, $2, $3, $4);
- if (!$esc_asc) {
- $chunk =~ tr/\x21-\x7e/\xa1-\xfe/;
- if ($esc_kana) {
- $chunk =~ s/([\xa1-\xdf])/\x8e$1/og;
- }
- elsif ($esc_0212) {
- $chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
- }
- }
- $chunk;
- }geox;
- my ($residue) = ($$r_str =~ s/(\e.*)$//so);
- return $residue;
-}
-
-sub euc_jis{
- no warnings qw(uninitialized);
- my $r_str = shift;
- my $jis0212 = shift;
- $$r_str =~ s{
- ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+)
- }{
- my $chunk = $1;
- my $esc =
- ( $chunk =~ tr/\x8E//d ) ? $ESC{KANA} :
- ( $chunk =~ tr/\x8F//d ) ? $ESC{JIS_0212} :
- $ESC{JIS_0208};
- if ($esc eq $ESC{JIS_0212} && !$jis0212){
- # fallback to '?'
- $chunk =~ tr/\xA1-\xFE/\x3F/;
- }else{
- $chunk =~ tr/\xA1-\xFE/\x21-\x7E/;
- }
- $esc . $chunk . $ESC{ASC};
- }geox;
- $$r_str =~
- s/\Q$ESC{ASC}\E
- (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox;
- $$r_str;
-}
-
-1;
-__END__
-
-
-=head1 NAME
-
-Encode::JP::JIS7 -- internally used by Encode::JP
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/KR.pm b/Master/tlpkg/installer/perllib/Encode/KR.pm
deleted file mode 100644
index e9d4073b7b4..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/KR.pm
+++ /dev/null
@@ -1,72 +0,0 @@
-package Encode::KR;
-BEGIN {
- if (ord("A") == 193) {
- die "Encode::KR not supported on EBCDIC\n";
- }
-}
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use Encode;
-use XSLoader;
-XSLoader::load(__PACKAGE__,$VERSION);
-
-use Encode::KR::2022_KR;
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::KR - Korean Encodings
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $euc_kr = encode("euc-kr", $utf8); # loads Encode::KR implicitly
- $utf8 = decode("euc-kr", $euc_kr); # ditto
-
-=head1 DESCRIPTION
-
-This module implements Korean charset encodings. Encodings supported
-are as follows.
-
-
- Canonical Alias Description
- --------------------------------------------------------------------
- euc-kr /\beuc.*kr$/i EUC (Extended Unix Character)
- /\bkr.*euc$/i
- ksc5601-raw Korean standard code set (as is)
- cp949 /(?:x-)?uhc$/i
- /(?:x-)?windows-949$/i
- /\bks_c_5601-1987$/i
- Code Page 949 (EUC-KR + 8,822
- (additional Hangul syllables)
- MacKorean EUC-KR + Apple Vendor Mappings
- johab JOHAB A supplementary encoding defined in
- Annex 3 of KS X 1001:1998
- iso-2022-kr iso-2022-kr [RFC1557]
- --------------------------------------------------------------------
-
-To find how to use this module in detail, see L<Encode>.
-
-=head1 BUGS
-
-When you see C<charset=ks_c_5601-1987> on mails and web pages, they really
-mean "cp949" encodings. To fix that, the following aliases are set;
-
- qr/(?:x-)?uhc$/i => '"cp949"'
- qr/(?:x-)?windows-949$/i => '"cp949"'
- qr/ks_c_5601-1987$/i => '"cp949"'
-
-The ASCII region (0x00-0x7f) is preserved for all encodings, even
-though this conflicts with mappings by the Unicode Consortium. See
-
-L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en>
-
-to find out why it is implemented that way.
-
-=head1 SEE ALSO
-
-L<Encode>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm b/Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm
deleted file mode 100644
index 8b4052be570..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm
+++ /dev/null
@@ -1,79 +0,0 @@
-package Encode::KR::2022_KR;
-use strict;
-
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use Encode qw(:fallbacks);
-
-use base qw(Encode::Encoding);
-__PACKAGE__->Define('iso-2022-kr');
-
-sub needs_lines { 1 }
-
-sub perlio_ok {
- return 0; # for the time being
-}
-
-sub decode
-{
- my ($obj, $str, $chk) = @_;
- my $res = $str;
- my $residue = iso_euc(\$res);
- # This is for PerlIO
- $_[1] = $residue if $chk;
- return Encode::decode('euc-kr', $res, FB_PERLQQ);
-}
-
-sub encode
-{
- my ($obj, $utf8, $chk) = @_;
- # empty the input string in the stack so perlio is ok
- $_[1] = '' if $chk;
- my $octet = Encode::encode('euc-kr', $utf8, FB_PERLQQ) ;
- euc_iso(\$octet);
- return $octet;
-}
-
-use Encode::CJKConstants qw(:all);
-
-# ISO<->EUC
-
-sub iso_euc{
- my $r_str = shift;
- $$r_str =~ s/$RE{'2022_KR'}//gox; # remove the designator
- $$r_str =~ s{ # replace characters in GL
- \x0e # between SO(\x0e) and SI(\x0f)
- ([^\x0f]*) # with characters in GR
- \x0f
- }
- {
- my $out= $1;
- $out =~ tr/\x21-\x7e/\xa1-\xfe/;
- $out;
- }geox;
- my ($residue) = ($$r_str =~ s/(\e.*)$//so);
- return $residue;
-}
-
-sub euc_iso{
- no warnings qw(uninitialized);
- my $r_str = shift;
- substr($$r_str,0,0)=$ESC{'2022_KR'}; # put the designator at the beg.
- $$r_str =~ s{ # move KS X 1001 characters in GR to GL
- ($RE{EUC_C}+) # and enclose them with SO and SI
- }{
- my $str = $1;
- $str =~ tr/\xA1-\xFE/\x21-\x7E/;
- "\x0e" . $str . "\x0f";
- }geox;
- $$r_str;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::KR::2022_KR -- internally used by Encode::KR
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/MIME/Header.pm b/Master/tlpkg/installer/perllib/Encode/MIME/Header.pm
deleted file mode 100644
index f4e2ad6e2b5..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/MIME/Header.pm
+++ /dev/null
@@ -1,230 +0,0 @@
-package Encode::MIME::Header;
-use strict;
-# use warnings;
-our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-use Encode qw(find_encoding encode_utf8 decode_utf8);
-use MIME::Base64;
-use Carp;
-
-my %seed =
- (
- decode_b => '1', # decodes 'B' encoding ?
- decode_q => '1', # decodes 'Q' encoding ?
- encode => 'B', # encode with 'B' or 'Q' ?
- bpl => 75, # bytes per line
- );
-
-$Encode::Encoding{'MIME-Header'} =
- bless {
- %seed,
- Name => 'MIME-Header',
- } => __PACKAGE__;
-
-$Encode::Encoding{'MIME-B'} =
- bless {
- %seed,
- decode_q => 0,
- Name => 'MIME-B',
- } => __PACKAGE__;
-
-$Encode::Encoding{'MIME-Q'} =
- bless {
- %seed,
- decode_q => 1,
- encode => 'Q',
- Name => 'MIME-Q',
- } => __PACKAGE__;
-
-use base qw(Encode::Encoding);
-
-sub needs_lines { 1 }
-sub perlio_ok{ 0 };
-
-sub decode($$;$){
- use utf8;
- my ($obj, $str, $chk) = @_;
- # zap spaces between encoded words
- $str =~ s/\?=\s+=\?/\?==\?/gos;
- # multi-line header to single line
- $str =~ s/(:?\r|\n|\r\n)[ \t]//gos;
- $str =~
- s{
- =\? # begin encoded word
- ([0-9A-Za-z\-_]+) # charset (encoding)
- \?([QqBb])\? # delimiter
- (.*?) # Base64-encodede contents
- \?= # end encoded word
- }{
- if (uc($2) eq 'B'){
- $obj->{decode_b} or croak qq(MIME "B" unsupported);
- decode_b($1, $3);
- }elsif(uc($2) eq 'Q'){
- $obj->{decode_q} or croak qq(MIME "Q" unsupported);
- decode_q($1, $3);
- }else{
- croak qq(MIME "$2" encoding is nonexistent!);
- }
- }egox;
- $_[1] = '' if $chk;
- return $str;
-}
-
-sub decode_b{
- my $enc = shift;
- my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc");
- my $db64 = decode_base64(shift);
- return $d->name eq 'utf8' ?
- Encode::decode_utf8($db64) : $d->decode($db64, Encode::FB_PERLQQ);
-}
-
-sub decode_q{
- my ($enc, $q) = @_;
- my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc");
- $q =~ s/_/ /go;
- $q =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ego;
- return $d->name eq 'utf8' ?
- Encode::decode_utf8($q) : $d->decode($q, Encode::FB_PERLQQ);
-}
-
-my $especials =
- join('|' =>
- map {quotemeta(chr($_))}
- unpack("C*", qq{()<>@,;:\"\'/[]?.=}));
-
-my $re_encoded_word =
- qr{
- (?:
- =\? # begin encoded word
- (?:[0-9A-Za-z\-_]+) # charset (encoding)
- \?(?:[QqBb])\? # delimiter
- (?:.*?) # Base64-encodede contents
- \?= # end encoded word
- )
- }xo;
-
-my $re_especials = qr{$re_encoded_word|$especials}xo;
-
-sub encode($$;$){
- my ($obj, $str, $chk) = @_;
- my @line = ();
- for my $line (split /\r|\n|\r\n/o, $str){
- my (@word, @subline);
- for my $word (split /($re_especials)/o, $line){
- if ($word =~ /[^\x00-\x7f]/o or $word =~ /^$re_encoded_word$/o){
- push @word, $obj->_encode($word);
- }else{
- push @word, $word;
- }
- }
- my $subline = '';
- for my $word (@word){
- use bytes ();
- if (bytes::length($subline) + bytes::length($word) > $obj->{bpl}){
- push @subline, $subline;
- $subline = '';
- }
- $subline .= $word;
- }
- $subline and push @subline, $subline;
- push @line, join("\n " => @subline);
- }
- $_[1] = '' if $chk;
- return join("\n", @line);
-}
-
-use constant HEAD => '=?UTF-8?';
-use constant TAIL => '?=';
-use constant SINGLE => { B => \&_encode_b, Q => \&_encode_q, };
-
-sub _encode{
- my ($o, $str) = @_;
- my $enc = $o->{encode};
- my $llen = ($o->{bpl} - length(HEAD) - 2 - length(TAIL));
- # to coerce a floating-point arithmetics, the following contains
- # .0 in numbers -- dankogai
- $llen *= $enc eq 'B' ? 3.0/4.0 : 1.0/3.0;
- my @result = ();
- my $chunk = '';
- while(length(my $chr = substr($str, 0, 1, ''))){
- use bytes ();
- if (bytes::length($chunk) + bytes::length($chr) > $llen){
- push @result, SINGLE->{$enc}($chunk);
- $chunk = '';
- }
- $chunk .= $chr;
- }
- $chunk and push @result, SINGLE->{$enc}($chunk);
- return @result;
-}
-
-sub _encode_b{
- HEAD . 'B?' . encode_base64(encode_utf8(shift), '') . TAIL;
-}
-
-sub _encode_q{
- my $chunk = shift;
- $chunk =~ s{
- ([^0-9A-Za-z])
- }{
- join("" => map {sprintf "=%02X", $_} unpack("C*", $1))
- }egox;
- return decode_utf8(HEAD . 'Q?' . $chunk . TAIL);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::MIME::Header -- MIME 'B' and 'Q' header encoding
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $utf8 = decode('MIME-Header', $header);
- $header = encode('MIME-Header', $utf8);
-
-=head1 ABSTRACT
-
-This module implements RFC 2047 Mime Header Encoding. There are 3
-variant encoding names; C<MIME-Header>, C<MIME-B> and C<MIME-Q>. The
-difference is described below
-
- decode() encode()
- ----------------------------------------------
- MIME-Header Both B and Q =?UTF-8?B?....?=
- MIME-B B only; Q croaks =?UTF-8?B?....?=
- MIME-Q Q only; B croaks =?UTF-8?Q?....?=
-
-=head1 DESCRIPTION
-
-When you decode(=?I<encoding>?I<X>?I<ENCODED WORD>?=), I<ENCODED WORD>
-is extracted and decoded for I<X> encoding (B for Base64, Q for
-Quoted-Printable). Then the decoded chunk is fed to
-decode(I<encoding>). So long as I<encoding> is supported by Encode,
-any source encoding is fine.
-
-When you encode, it just encodes UTF-8 string with I<X> encoding then
-quoted with =?UTF-8?I<X>?....?= . The parts that RFC 2047 forbids to
-encode are left as is and long lines are folded within 76 bytes per
-line.
-
-=head1 BUGS
-
-It would be nice to support encoding to non-UTF8, such as =?ISO-2022-JP?
-and =?ISO-8859-1?= but that makes the implementation too complicated.
-These days major mail agents all support =?UTF-8? so I think it is
-just good enough.
-
-Due to popular demand, 'MIME-Header-ISO_2022_JP' was introduced by
-Makamaka. Thre are still too many MUAs especially cellular phone
-handsets which does not grok UTF-8.
-
-=head1 SEE ALSO
-
-L<Encode>
-
-RFC 2047, L<http://www.faqs.org/rfcs/rfc2047.html> and many other
-locations.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm b/Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm
deleted file mode 100644
index 5f637a32472..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm
+++ /dev/null
@@ -1,127 +0,0 @@
-package Encode::MIME::Header::ISO_2022_JP;
-
-use strict;
-use base qw(Encode::MIME::Header);
-
-$Encode::Encoding{'MIME-Header-ISO_2022_JP'}
- = bless {encode => 'B', bpl => 76, Name => 'MIME-Header-ISO_2022_JP'}
- => __PACKAGE__;
-
-use constant HEAD => '=?ISO-2022-JP?B?';
-use constant TAIL => '?=';
-
-use Encode::CJKConstants qw(%RE);
-
-our $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-
-# I owe the below codes totally to
-# Jcode by Dan Kogai & http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64
-
-sub encode {
- my $self = shift;
- my $str = shift;
-
- utf8::encode($str) if( Encode::is_utf8($str) );
- Encode::from_to($str, 'utf8', 'euc-jp');
-
- my($trailing_crlf) = ($str =~ /(\n|\r|\x0d\x0a)$/o);
-
- $str = _mime_unstructured_header($str, $self->{bpl});
-
- not $trailing_crlf and $str =~ s/(\n|\r|\x0d\x0a)$//o;
-
- return $str;
-}
-
-
-sub _mime_unstructured_header {
- my ($oldheader, $bpl) = @_;
- my $crlf = $oldheader =~ /\n$/;
- my($header, @words, @wordstmp, $i) = ('');
-
- $oldheader =~ s/\s+$//;
-
- @wordstmp = split /\s+/, $oldheader;
-
- for ($i = 0; $i < $#wordstmp; $i++){
- if( $wordstmp[$i] !~ /^[\x21-\x7E]+$/ and $wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/){
- $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]";
- }
- else{
- push(@words, $wordstmp[$i]);
- }
- }
-
- push(@words, $wordstmp[-1]);
-
- for my $word (@words){
- if ($word =~ /^[\x21-\x7E]+$/) {
- $header =~ /(?:.*\n)*(.*)/;
- if (length($1) + length($word) > $bpl) {
- $header .= "\n $word";
- }
- else{
- $header .= $word;
- }
- }
- else{
- $header = _add_encoded_word($word, $header, $bpl);
- }
-
- $header =~ /(?:.*\n)*(.*)/;
-
- if(length($1) == $bpl){
- $header .= "\n ";
- }
- else {
- $header .= ' ';
- }
- }
-
- $header =~ s/\n? $//mg;
-
- $crlf ? "$header\n" : $header;
-}
-
-
-sub _add_encoded_word {
- my($str, $line, $bpl) = @_;
- my $result = '';
-
- while( length($str) ){
- my $target = $str;
- $str = '';
-
- if(length($line) + 22 + ($target =~ /^(?:$RE{EUC_0212}|$RE{EUC_C})/o) * 8 > $bpl){
- $line =~ s/[ \t\n\r]*$/\n/;
- $result .= $line;
- $line = ' ';
- }
-
- while(1){
- my $iso_2022_jp = $target;
- Encode::from_to($iso_2022_jp, 'euc-jp', 'iso-2022-jp');
-
- my $encoded
- = HEAD . MIME::Base64::encode_base64($iso_2022_jp, '') . TAIL;
-
- if(length($encoded) + length($line) > $bpl){
- $target =~ s/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|$RE{ASCII})$//o;
- $str = $1 . $str;
- }
- else{
- $line .= $encoded;
- last;
- }
- }
-
- }
-
- $result . $line;
-}
-
-
-1;
-__END__
-
diff --git a/Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x b/Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x
deleted file mode 100644
index 3bca0bff52b..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x
+++ /dev/null
@@ -1,180 +0,0 @@
-#
-# This file is auto-generated by:
-# enc2xs version $_Version_
-# $_Now_
-#
-use 5.7.2;
-use strict;
-use ExtUtils::MakeMaker;
-use Config;
-
-# Please edit the following to the taste!
-my $name = '$_Name_';
-my %tables = (
- $_Name__t => [ $_TableFiles_ ],
- );
-
-#### DO NOT EDIT BEYOND THIS POINT!
-require File::Spec;
-my ($enc2xs, $encode_h) = ();
-PATHLOOP:
-for my $d (@Config{qw/bin sitebin vendorbin/},
- (split /$Config{path_sep}/o, $ENV{PATH})){
- for my $f (qw/enc2xs enc2xs5.7.3/){
- my $path = File::Spec->catfile($d, $f);
- -r $path and $enc2xs = $path and last PATHLOOP;
- }
-}
-$enc2xs or die "enc2xs not found!";
-print "enc2xs is $enc2xs\n";
-my %encode_h = ();
-for my $d (@INC){
- my $dir = File::Spec->catfile($d, "Encode");
- my $file = File::Spec->catfile($dir, "encode.h");
- -f $file and $encode_h{$dir} = -M $file;
-}
-%encode_h or die "encode.h not found!";
-# find the latest one
-($encode_h) = sort {$encode_h{$b} <=> $encode_h{$a}} keys %encode_h;
-print "encode.h is at $encode_h\n";
-
-WriteMakefile(
- INC => "-I$encode_h",
-#### END_OF_HEADER -- DO NOT EDIT THIS LINE BY HAND! ####
- NAME => 'Encode::'.$name,
- VERSION_FROM => "$name.pm",
- OBJECT => '$(O_FILES)',
- 'dist' => {
- COMPRESS => 'gzip -9f',
- SUFFIX => 'gz',
- DIST_DEFAULT => 'all tardist',
- },
- MAN3PODS => {},
- PREREQ_PM => {
- 'Encode' => "1.41",
- },
- # OS 390 winges about line numbers > 64K ???
- XSOPT => '-nolinenumbers',
- );
-
-package MY;
-
-sub post_initialize
-{
- my ($self) = @_;
- my %o;
- my $x = $self->{'OBJ_EXT'};
- # Add the table O_FILES
- foreach my $e (keys %tables)
- {
- $o{$e.$x} = 1;
- }
- $o{"$name$x"} = 1;
- $self->{'O_FILES'} = [sort keys %o];
- my @files = ("$name.xs");
- $self->{'C'} = ["$name.c"];
- # The next two lines to make MacPerl Happy -- dankogai via pudge
- $self->{SOURCE} .= " $name.c"
- if $^O eq 'MacOS' && $self->{SOURCE} !~ /\b$name\.c\b/;
- # $self->{'H'} = [$self->catfile($self->updir,'encode.h')];
- my %xs;
- foreach my $table (keys %tables) {
- push (@{$self->{'C'}},"$table.c");
- # Do NOT add $table.h etc. to H_FILES unless we own up as to how they
- # get built.
- foreach my $ext (qw($(OBJ_EXT) .c .h .exh .fnm)) {
- push (@files,$table.$ext);
- }
- }
- $self->{'XS'} = { "$name.xs" => "$name.c" };
- $self->{'clean'}{'FILES'} .= join(' ',@files);
- open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
- print XS <<'END';
-#include <EXTERN.h>
-#include <perl.h>
-#include <XSUB.h>
-#define U8 U8
-#include "encode.h"
-END
- foreach my $table (keys %tables) {
- print XS qq[#include "${table}.h"\n];
- }
- print XS <<"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);
-}
-
-MODULE = Encode::$name PACKAGE = Encode::$name
-PROTOTYPES: DISABLE
-BOOT:
-{
-END
- foreach my $table (keys %tables) {
- print XS qq[#include "${table}.exh"\n];
- }
- print XS "}\n";
- close(XS);
- return "# Built $name.xs\n\n";
-}
-
-sub postamble
-{
- my $self = shift;
- my $dir = "."; # $self->catdir('Encode');
- my $str = "# $name\$(OBJ_EXT) depends on .h and .exh files not .c files - but all written by enc2xs\n";
- $str .= "$name.c : $name.xs ";
- foreach my $table (keys %tables)
- {
- $str .= " $table.c";
- }
- $str .= "\n\n";
- $str .= "$name\$(OBJ_EXT) : $name.c\n\n";
-
- foreach my $table (keys %tables)
- {
- my $numlines = 1;
- my $lengthsofar = length($str);
- my $continuator = '';
- $str .= "$table.c : Makefile.PL";
- foreach my $file (@{$tables{$table}})
- {
- $str .= $continuator.' '.$self->catfile($dir,$file);
- if ( length($str)-$lengthsofar > 128*$numlines )
- {
- $continuator .= " \\\n\t";
- $numlines++;
- } else {
- $continuator = '';
- }
- }
- my $plib = $self->{PERL_CORE} ? '"-I$(PERL_LIB)"' : '';
- my $ucopts = '-"Q"';
- $str .=
- qq{\n\t\$(PERL) $plib $enc2xs $ucopts -o \$\@ -f $table.fnm\n\n};
- open (FILELIST, ">$table.fnm")
- || die "Could not open $table.fnm: $!";
- foreach my $file (@{$tables{$table}})
- {
- print FILELIST $self->catfile($dir,$file) . "\n";
- }
- close(FILELIST);
- }
- return $str;
-}
-
diff --git a/Master/tlpkg/installer/perllib/Encode/PerlIO.pod b/Master/tlpkg/installer/perllib/Encode/PerlIO.pod
deleted file mode 100644
index abd1f2d10a1..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/PerlIO.pod
+++ /dev/null
@@ -1,167 +0,0 @@
-=head1 NAME
-
-Encode::PerlIO -- a detailed document on Encode and PerlIO
-
-=head1 Overview
-
-It is very common to want to do encoding transformations when
-reading or writing files, network connections, pipes etc.
-If Perl is configured to use the new 'perlio' IO system then
-C<Encode> provides a "layer" (see L<PerlIO>) which can transform
-data as it is read or written.
-
-Here is how the blind poet would modernise the encoding:
-
- use Encode;
- open(my $iliad,'<:encoding(iso-8859-7)','iliad.greek');
- open(my $utf8,'>:utf8','iliad.utf8');
- my @epic = <$iliad>;
- print $utf8 @epic;
- close($utf8);
- close($illiad);
-
-In addition, the new IO system can also be configured to read/write
-UTF-8 encoded characters (as noted above, this is efficient):
-
- open(my $fh,'>:utf8','anything');
- print $fh "Any \x{0021} string \N{SMILEY FACE}\n";
-
-Either of the above forms of "layer" specifications can be made the default
-for a lexical scope with the C<use open ...> pragma. See L<open>.
-
-Once a handle is open, its layers can be altered using C<binmode>.
-
-Without any such configuration, or if Perl itself is built using the
-system's own IO, then write operations assume that the file handle
-accepts only I<bytes> and will C<die> if a character larger than 255 is
-written to the handle. When reading, each octet from the handle becomes
-a byte-in-a-character. Note that this default is the same behaviour
-as bytes-only languages (including Perl before v5.6) would have,
-and is sufficient to handle native 8-bit encodings e.g. iso-8859-1,
-EBCDIC etc. and any legacy mechanisms for handling other encodings
-and binary data.
-
-In other cases, it is the program's responsibility to transform
-characters into bytes using the API above before doing writes, and to
-transform the bytes read from a handle into characters before doing
-"character operations" (e.g. C<lc>, C</\W+/>, ...).
-
-You can also use PerlIO to convert larger amounts of data you don't
-want to bring into memory. For example, to convert between ISO-8859-1
-(Latin 1) and UTF-8 (or UTF-EBCDIC in EBCDIC machines):
-
- open(F, "<:encoding(iso-8859-1)", "data.txt") or die $!;
- open(G, ">:utf8", "data.utf") or die $!;
- while (<F>) { print G }
-
- # Could also do "print G <F>" but that would pull
- # the whole file into memory just to write it out again.
-
-More examples:
-
- open(my $f, "<:encoding(cp1252)")
- open(my $g, ">:encoding(iso-8859-2)")
- open(my $h, ">:encoding(latin9)") # iso-8859-15
-
-See also L<encoding> for how to change the default encoding of the
-data in your script.
-
-=head1 How does it work?
-
-Here is a crude diagram of how filehandle, PerlIO, and Encode
-interact.
-
- filehandle <-> PerlIO PerlIO <-> scalar (read/printed)
- \ /
- Encode
-
-When PerlIO receives data from either direction, it fills a buffer
-(currently with 1024 bytes) and passes the buffer to Encode.
-Encode tries to convert the valid part and passes it back to PerlIO,
-leaving invalid parts (usually a partial character) in the buffer.
-PerlIO then appends more data to the buffer, calls Encode again,
-and so on until the data stream ends.
-
-To do so, PerlIO always calls (de|en)code methods with CHECK set to 1.
-This ensures that the method stops at the right place when it
-encounters partial character. The following is what happens when
-PerlIO and Encode tries to encode (from utf8) more than 1024 bytes
-and the buffer boundary happens to be in the middle of a character.
-
- A B C .... ~ \x{3000} ....
- 41 42 43 .... 7E e3 80 80 ....
- <- buffer --------------->
- << encoded >>>>>>>>>>
- <- next buffer ------
-
-Encode converts from the beginning to \x7E, leaving \xe3 in the buffer
-because it is invalid (partial character).
-
-Unfortunately, this scheme does not work well with escape-based
-encodings such as ISO-2022-JP.
-
-=head1 Line Buffering
-
-Now let's see what happens when you try to decode from ISO-2022-JP and
-the buffer ends in the middle of a character.
-
- JIS208-ESC \x{5f3e}
- A B C .... ~ \e $ B |DAN | ....
- 41 42 43 .... 7E 1b 24 41 43 46 ....
- <- buffer --------------------------->
- << encoded >>>>>>>>>>>>>>>>>>>>>>>
-
-As you see, the next buffer begins with \x43. But \x43 is 'C' in
-ASCII, which is wrong in this case because we are now in JISX 0208
-area so it has to convert \x43\x46, not \x43. Unlike utf8 and EUC,
-in escape-based encodings you can't tell if a given octet is a whole
-character or just part of it.
-
-Fortunately PerlIO also supports line buffer if you tell PerlIO to use
-one instead of fixed buffer. Since ISO-2022-JP is guaranteed to revert to ASCII at the end of the line, partial
-character will never happen when line buffer is used.
-
-To tell PerlIO to use line buffer, implement -E<gt>needs_lines method
-for your encoding object. See L<Encode::Encoding> for details.
-
-Thanks to these efforts most encodings that come with Encode support
-PerlIO but that still leaves following encodings.
-
- iso-2022-kr
- MIME-B
- MIME-Header
- MIME-Q
-
-Fortunately iso-2022-kr is hardly used (according to Jungshik) and
-MIME-* are very unlikely to be fed to PerlIO because they are for mail
-headers. See L<Encode::MIME::Header> for details.
-
-=head2 How can I tell whether my encoding fully supports PerlIO ?
-
-As of this writing, any encoding whose class belongs to Encode::XS and
-Encode::Unicode works. The Encode module has a C<perlio_ok> method
-which you can use before applying PerlIO encoding to the filehandle.
-Here is an example:
-
- my $use_perlio = perlio_ok($enc);
- my $layer = $use_perlio ? "<:raw" : "<:encoding($enc)";
- open my $fh, $layer, $file or die "$file : $!";
- while(<$fh>){
- $_ = decode($enc, $_) unless $use_perlio;
- # ....
- }
-
-=head1 SEE ALSO
-
-L<Encode::Encoding>,
-L<Encode::Supported>,
-L<Encode::PerlIO>,
-L<encoding>,
-L<perlebcdic>,
-L<perlfunc/open>,
-L<perlunicode>,
-L<utf8>,
-the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Encode/README.e2x b/Master/tlpkg/installer/perllib/Encode/README.e2x
deleted file mode 100644
index 28a31a655c2..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/README.e2x
+++ /dev/null
@@ -1,31 +0,0 @@
-Encode::$_Name_ version 0.1
-========
-
-NAME
- Encode::$_Name_ - <describe encoding>
-
-SYNOPSIS
- use Encode::$_Name_;
- #<put more words here>
-ABSTRACT
- <fill this in>
-INSTALLATION
-
-To install this module type the following:
-
- perl Makefile.PL
- make
- make test
- make install
-
-DEPENDENCIES
-
-This module requires perl version 5.7.3 or later.
-
-COPYRIGHT AND LICENCE
-
-Copyright (C) 2002 Your Name <your@address.domain>
-
-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/installer/perllib/Encode/Supported.pod b/Master/tlpkg/installer/perllib/Encode/Supported.pod
deleted file mode 100644
index 651f7e6ed4f..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Supported.pod
+++ /dev/null
@@ -1,890 +0,0 @@
-=head1 NAME
-
-Encode::Supported -- Encodings supported by Encode
-
-=head1 DESCRIPTION
-
-=head2 Encoding Names
-
-Encoding names are case insensitive. White space in names
-is ignored. In addition, an encoding may have aliases.
-Each encoding has one "canonical" name. The "canonical"
-name is chosen from the names of the encoding by picking
-the first in the following sequence (with a few exceptions).
-
-=over 4
-
-=item *
-
-The name used by the Perl community. That includes 'utf8' and 'ascii'.
-Unlike aliases, canonical names directly reach the method so such
-frequently used words like 'utf8' don't need to do alias lookups.
-
-=item *
-
-The MIME name as defined in IETF RFCs. This includes all "iso-"s.
-
-=item *
-
-The name in the IANA registry.
-
-=item *
-
-The name used by the organization that defined it.
-
-=back
-
-In case I<de jure> canonical names differ from that of the Encode
-module, they are always aliased if it ever be implemented. So you can
-safely tell if a given encoding is implemented or not just by passing
-the canonical name.
-
-Because of all the alias issues, and because in the general case
-encodings have state, "Encode" uses an encoding object internally
-once an operation is in progress.
-
-=head1 Supported Encodings
-
-As of Perl 5.8.0, at least the following encodings are recognized.
-Note that unless otherwise specified, they are all case insensitive
-(via alias) and all occurrence of spaces are replaced with '-'.
-In other words, "ISO 8859 1" and "iso-8859-1" are identical.
-
-Encodings are categorized and implemented in several different modules
-but you don't have to C<use Encode::XX> to make them available for
-most cases. Encode.pm will automatically load those modules on demand.
-
-=head2 Built-in Encodings
-
-The following encodings are always available.
-
- Canonical Aliases Comments & References
- ----------------------------------------------------------------
- ascii US-ascii ISO-646-US [ECMA]
- ascii-ctrl Special Encoding
- iso-8859-1 latin1 [ISO]
- null Special Encoding
- utf8 UTF-8 [RFC2279]
- ----------------------------------------------------------------
-
-I<null> and I<ascii-ctrl> are special. "null" fails for all character
-so when you set fallback mode to PERLQQ, HTMLCREF or XMLCREF, ALL
-CHARACTERS will fall back to character references. Ditto for
-"ascii-ctrl" except for control characters. For fallback modes, see
-L<Encode>.
-
-=head2 Encode::Unicode -- other Unicode encodings
-
-Unicode coding schemes other than native utf8 are supported by
-Encode::Unicode, which will be autoloaded on demand.
-
- ----------------------------------------------------------------
- UCS-2BE UCS-2, iso-10646-1 [IANA, UC]
- UCS-2LE [UC]
- UTF-16 [UC]
- UTF-16BE [UC]
- UTF-16LE [UC]
- UTF-32 [UC]
- UTF-32BE UCS-4 [UC]
- UTF-32LE [UC]
- UTF-7 [RFC2152]
- ----------------------------------------------------------------
-
-To find how (UCS-2|UTF-(16|32))(LE|BE)? differ from one another,
-see L<Encode::Unicode>.
-
-UTF-7 is a special encoding which "re-encodes" UTF-16BE into a 7-bit
-encoding. It is implemented seperately by Encode::Unicode::UTF7.
-
-=head2 Encode::Byte -- Extended ASCII
-
-Encode::Byte implements most single-byte encodings except for
-Symbols and EBCDIC. The following encodings are based on single-byte
-encodings implemented as extended ASCII. Most of them map
-\x80-\xff (upper half) to non-ASCII characters.
-
-=over 4
-
-=item ISO-8859 and corresponding vendor mappings
-
-Since there are so many, they are presented in table format with
-languages and corresponding encoding names by vendors. Note that
-the table is sorted in order of ISO-8859 and the corresponding vendor
-mappings are slightly different from that of ISO. See
-L<http://czyborra.com/charsets/iso8859.html> for details.
-
- Lang/Regions ISO/Other Std. DOS Windows Macintosh Others
- ----------------------------------------------------------------
- N. America (ASCII) cp437 AdobeStandardEncoding
- cp863 (DOSCanadaF)
- W. Europe iso-8859-1 cp850 cp1252 MacRoman nextstep
- hp-roman8
- cp860 (DOSPortuguese)
- Cntrl. Europe iso-8859-2 cp852 cp1250 MacCentralEurRoman
- MacCroatian
- MacRomanian
- MacRumanian
- Latin3[1] iso-8859-3
- Latin4[2] iso-8859-4
- Cyrillics iso-8859-5 cp855 cp1251 MacCyrillic
- (See also next section) cp866 MacUkrainian
- Arabic iso-8859-6 cp864 cp1256 MacArabic
- cp1006 MacFarsi
- Greek iso-8859-7 cp737 cp1253 MacGreek
- cp869 (DOSGreek2)
- Hebrew iso-8859-8 cp862 cp1255 MacHebrew
- Turkish iso-8859-9 cp857 cp1254 MacTurkish
- Nordics iso-8859-10 cp865
- cp861 MacIcelandic
- MacSami
- Thai iso-8859-11[3] cp874 MacThai
- (iso-8859-12 is nonexistent. Reserved for Indics?)
- Baltics iso-8859-13 cp775 cp1257
- Celtics iso-8859-14
- Latin9 [4] iso-8859-15
- Latin10 iso-8859-16
- Vietnamese viscii cp1258 MacVietnamese
- ----------------------------------------------------------------
-
- [1] Esperanto, Maltese, and Turkish. Turkish is now on 8859-9.
- [2] Baltics. Now on 8859-10, except for Latvian.
- [3] TIS 620 + Non-Breaking Space (0xA0 / U+00A0)
- [4] Nicknamed Latin0; the Euro sign as well as French and Finnish
- letters that are missing from 8859-1 were added.
-
-All cp* are also available as ibm-*, ms-*, and windows-* . See also
-L<http://czyborra.com/charsets/codepages.html>.
-
-Macintosh encodings don't seem to be registered in such entities as
-IANA. "Canonical" names in Encode are based upon Apple's Tech Note
-1150. See L<http://developer.apple.com/technotes/tn/tn1150.html>
-for details.
-
-=item KOI8 - De Facto Standard for the Cyrillic world
-
-Though ISO-8859 does have ISO-8859-5, the KOI8 series is far more
-popular in the Net. L<Encode> comes with the following KOI charsets.
-For gory details, see L<http://czyborra.com/charsets/cyrillic.html>
-
- ----------------------------------------------------------------
- koi8-f
- koi8-r cp878 [RFC1489]
- koi8-u [RFC2319]
- ----------------------------------------------------------------
-
-=item gsm0338 - Hentai Latin 1
-
-GSM0338 is for GSM handsets. Though it shares alphanumerals with
-ASCII, control character ranges and other parts are mapped very
-differently, mainly to store Greek characters. There are also escape
-sequences (starting with 0x1B) to cover e.g. the Euro sign. Some
-special cases like a trailing 0x00 byte or a lone 0x1B byte are not
-well-defined and decode() will return an empty string for them.
-One possible workaround is
-
- $gsm =~ s/\x00\z/\x00\x00/;
- $uni = decode("gsm0338", $gsm);
- $uni .= "\xA0" if $gsm =~ /\x1B\z/;
-
-Note that the Encode implementation of GSM0338 does not implement the
-reuse of Latin capital letters as Greek capital letters (for example,
-the 0x5A is U+005A (LATIN CAPITAL LETTER Z), not U+0396 (GREEK CAPITAL
-LETTER ZETA).
-
-The GSM0338 is also covered in Encode::Byte even though it is not
-an "extended ASCII" encoding.
-
-=back
-
-=head2 CJK: Chinese, Japanese, Korean (Multibyte)
-
-Note that Vietnamese is listed above. Also read "Encoding vs Charset"
-below. Also note that these are implemented in distinct modules by
-countries, due to the size concerns (simplified Chinese is mapped
-to 'CN', continental China, while traditional Chinese is mapped to
-'TW', Taiwan). Please refer to their respective documentation pages.
-
-=over 4
-
-=item Encode::CN -- Continental China
-
- Standard DOS/Win Macintosh Comment/Reference
- ----------------------------------------------------------------
- euc-cn [1] MacChineseSimp
- (gbk) cp936 [2]
- gb12345-raw { GB12345 without CES }
- gb2312-raw { GB2312 without CES }
- hz
- iso-ir-165
- ----------------------------------------------------------------
-
- [1] GB2312 is aliased to this. See L<Microsoft-related naming mess>
- [2] gbk is aliased to this. See L<Microsoft-related naming mess>
-
-=item Encode::JP -- Japan
-
- Standard DOS/Win Macintosh Comment/Reference
- ----------------------------------------------------------------
- euc-jp
- shiftjis cp932 macJapanese
- 7bit-jis
- iso-2022-jp [RFC1468]
- iso-2022-jp-1 [RFC2237]
- jis0201-raw { JIS X 0201 (roman + halfwidth kana) without CES }
- jis0208-raw { JIS X 0208 (Kanji + fullwidth kana) without CES }
- jis0212-raw { JIS X 0212 (Extended Kanji) without CES }
- ----------------------------------------------------------------
-
-=item Encode::KR -- Korea
-
- Standard DOS/Win Macintosh Comment/Reference
- ----------------------------------------------------------------
- euc-kr MacKorean [RFC1557]
- cp949 [1]
- iso-2022-kr [RFC1557]
- johab [KS X 1001:1998, Annex 3]
- ksc5601-raw { KSC5601 without CES }
- ----------------------------------------------------------------
-
- [1] ks_c_5601-1987, (x-)?windows-949, and uhc are aliased to this.
- See below.
-
-=item Encode::TW -- Taiwan
-
- Standard DOS/Win Macintosh Comment/Reference
- ----------------------------------------------------------------
- big5-eten cp950 MacChineseTrad {big5 aliased to big5-eten}
- big5-hkscs
- ----------------------------------------------------------------
-
-=item Encode::HanExtra -- More Chinese via CPAN
-
-Due to the size concerns, additional Chinese encodings below are
-distributed separately on CPAN, under the name Encode::HanExtra.
-
- Standard DOS/Win Macintosh Comment/Reference
- ----------------------------------------------------------------
- big5ext CMEX's Big5e Extension
- big5plus CMEX's Big5+ Extension
- cccii Chinese Character Code for Information Interchange
- euc-tw EUC (Extended Unix Character)
- gb18030 GBK with Traditional Characters
- ----------------------------------------------------------------
-
-=item Encode::JIS2K -- JIS X 0213 encodings via CPAN
-
-Due to size concerns, additional Japanese encodings below are
-distributed separately on CPAN, under the name Encode::JIS2K.
-
- Standard DOS/Win Macintosh Comment/Reference
- ----------------------------------------------------------------
- euc-jisx0213
- shiftjisx0123
- iso-2022-jp-3
- jis0213-1-raw
- jis0213-2-raw
- ----------------------------------------------------------------
-
-=back
-
-=head2 Miscellaneous encodings
-
-=over 4
-
-=item Encode::EBCDIC
-
-See L<perlebcdic> for details.
-
- ----------------------------------------------------------------
- cp37
- cp500
- cp875
- cp1026
- cp1047
- posix-bc
- ----------------------------------------------------------------
-
-=item Encode::Symbols
-
-For symbols and dingbats.
-
- ----------------------------------------------------------------
- symbol
- dingbats
- MacDingbats
- AdobeZdingbat
- AdobeSymbol
- ----------------------------------------------------------------
-
-=item Encode::MIME::Header
-
-Strictly speaking, MIME header encoding documented in RFC 2047 is more
-of encapsulation than encoding. However, their support in modern
-world is imperative so they are supported.
-
- ----------------------------------------------------------------
- MIME-Header [RFC2047]
- MIME-B [RFC2047]
- MIME-Q [RFC2047]
- ----------------------------------------------------------------
-
-=item Encode::Guess
-
-This one is not a name of encoding but a utility that lets you pick up
-the most appropriate encoding for a data out of given I<suspects>. See
-L<Encode::Guess> for details.
-
-=back
-
-=head1 Unsupported encodings
-
-The following encodings are not supported as yet; some because they
-are rarely used, some because of technical difficulties. They may
-be supported by external modules via CPAN in the future, however.
-
-=over 4
-
-=item ISO-2022-JP-2 [RFC1554]
-
-Not very popular yet. Needs Unicode Database or equivalent to
-implement encode() (because it includes JIS X 0208/0212, KSC5601, and
-GB2312 simultaneously, whose code points in Unicode overlap. So you
-need to lookup the database to determine to what character set a given
-Unicode character should belong).
-
-=item ISO-2022-CN [RFC1922]
-
-Not very popular. Needs CNS 11643-1 and -2 which are not available in
-this module. CNS 11643 is supported (via euc-tw) in Encode::HanExtra.
-Autrijus Tang may add support for this encoding in his module in future.
-
-=item Various HP-UX encodings
-
-The following are unsupported due to the lack of mapping data.
-
- '8' - arabic8, greek8, hebrew8, kana8, thai8, and turkish8
- '15' - japanese15, korean15, and roi15
-
-=item Cyrillic encoding ISO-IR-111
-
-Anton Tagunov doubts its usefulness.
-
-=item ISO-8859-8-1 [Hebrew]
-
-None of the Encode team knows Hebrew enough (ISO-8859-8, cp1255 and
-MacHebrew are supported because and just because there were mappings
-available at L<http://www.unicode.org/>). Contributions welcome.
-
-=item ISIRI 3342, Iran System, ISIRI 2900 [Farsi]
-
-Ditto.
-
-=item Thai encoding TCVN
-
-Ditto.
-
-=item Vietnamese encodings VPS
-
-Though Jungshik Shin has reported that Mozilla supports this encoding,
-it was too late before 5.8.0 for us to add it. In the future, it
-may be available via a separate module. See
-L<http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.uf>
-and
-L<http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.ut>
-if you are interested in helping us.
-
-=item Various Mac encodings
-
-The following are unsupported due to the lack of mapping data.
-
- MacArmenian, MacBengali, MacBurmese, MacEthiopic
- MacExtArabic, MacGeorgian, MacKannada, MacKhmer
- MacLaotian, MacMalayalam, MacMongolian, MacOriya
- MacSinhalese, MacTamil, MacTelugu, MacTibetan
- MacVietnamese
-
-The rest which are already available are based upon the vendor mappings
-at L<http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> .
-
-=item (Mac) Indic encodings
-
-The maps for the following are available at L<http://www.unicode.org/>
-but remain unsupport because those encodings need algorithmical
-approach, currently unsupported by F<enc2xs>:
-
- MacDevanagari
- MacGurmukhi
- MacGujarati
-
-For details, please see C<Unicode mapping issues and notes:> at
-L<http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/DEVANAGA.TXT> .
-
-I believe this issue is prevalent not only for Mac Indics but also in
-other Indic encodings, but the above were the only Indic encodings
-maps that I could find at L<http://www.unicode.org/> .
-
-=back
-
-=head1 Encoding vs. Charset -- terminology
-
-We are used to using the term (character) I<encoding> and I<character
-set> interchangeably. But just as confusing the terms byte and
-character is dangerous and the terms should be differentiated when
-needed, we need to differentiate I<encoding> and I<character set>.
-
-To understand that, here is a description of how we make computers
-grok our characters.
-
-=over 4
-
-=item *
-
-First we start with which characters to include. We call this
-collection of characters I<character repertoire>.
-
-=item *
-
-Then we have to give each character a unique ID so your computer can
-tell the difference between 'a' and 'A'. This itemized character
-repertoire is now a I<character set>.
-
-=item *
-
-If your computer can grow the character set without further
-processing, you can go ahead and use it. This is called a I<coded
-character set> (CCS) or I<raw character encoding>. ASCII is used this
-way for most cases.
-
-=item *
-
-But in many cases, especially multi-byte CJK encodings, you have to
-tweak a little more. Your network connection may not accept any data
-with the Most Significant Bit set, and your computer may not be able to
-tell if a given byte is a whole character or just half of it. So you
-have to I<encode> the character set to use it.
-
-A I<character encoding scheme> (CES) determines how to encode a given
-character set, or a set of multiple character sets. 7bit ISO-2022 is
-an example of a CES. You switch between character sets via I<escape
-sequences>.
-
-=back
-
-Technically, or mathematically, speaking, a character set encoded in
-such a CES that maps character by character may form a CCS. EUC is such
-an example. The CES of EUC is as follows:
-
-=over 4
-
-=item *
-
-Map ASCII unchanged.
-
-=item *
-
-Map such a character set that consists of 94 or 96 powered by N
-members by adding 0x80 to each byte.
-
-=item *
-
-You can also use 0x8e and 0x8f to indicate that the following sequence of
-characters belongs to yet another character set. To each following byte
-is added the value 0x80.
-
-=back
-
-By carefully looking at the encoded byte sequence, you can find that the
-byte sequence conforms a unique number. In that sense, EUC is a CCS
-generated by a CES above from up to four CCS (complicated?). UTF-8
-falls into this category. See L<perlUnicode/"UTF-8"> to find out how
-UTF-8 maps Unicode to a byte sequence.
-
-You may also have found out by now why 7bit ISO-2022 cannot comprise
-a CCS. If you look at a byte sequence \x21\x21, you can't tell if
-it is two !'s or IDEOGRAPHIC SPACE. EUC maps the latter to \xA1\xA1
-so you have no trouble differentiating between "!!". and S<" ">.
-
-=head1 Encoding Classification (by Anton Tagunov and Dan Kogai)
-
-This section tries to classify the supported encodings by their
-applicability for information exchange over the Internet and to
-choose the most suitable aliases to name them in the context of
-such communication.
-
-=over 4
-
-=item *
-
-To (en|de)code encodings marked by C<(**)>, you need
-C<Encode::HanExtra>, available from CPAN.
-
-=back
-
-Encoding names
-
- US-ASCII UTF-8 ISO-8859-* KOI8-R
- Shift_JIS EUC-JP ISO-2022-JP ISO-2022-JP-1
- EUC-KR Big5 GB2312
-
-are registered with IANA as preferred MIME names and may
-be used over the Internet.
-
-C<Shift_JIS> has been officialized by JIS X 0208:1997.
-L<Microsoft-related naming mess> gives details.
-
-C<GB2312> is the IANA name for C<EUC-CN>.
-See L<Microsoft-related naming mess> for details.
-
-C<GB_2312-80> I<raw> encoding is available as C<gb2312-raw>
-with Encode. See L<Encode::CN> for details.
-
- EUC-CN
- KOI8-U [RFC2319]
-
-have not been registered with IANA (as of March 2002) but
-seem to be supported by major web browsers.
-The IANA name for C<EUC-CN> is C<GB2312>.
-
- KS_C_5601-1987
-
-is heavily misused.
-See L<Microsoft-related naming mess> for details.
-
-C<KS_C_5601-1987> I<raw> encoding is available as C<kcs5601-raw>
-with Encode. See L<Encode::KR> for details.
-
- UTF-16 UTF-16BE UTF-16LE
-
-are IANA-registered C<charset>s. See [RFC 2781] for details.
-Jungshik Shin reports that UTF-16 with a BOM is well accepted
-by MS IE 5/6 and NS 4/6. Beware however that
-
-=over 4
-
-=item *
-
-C<UTF-16> support in any software you're going to be
-using/interoperating with has probably been less tested
-then C<UTF-8> support
-
-=item *
-
-C<UTF-8> coded data seamlessly passes traditional
-command piping (C<cat>, C<more>, etc.) while C<UTF-16> coded
-data is likely to cause confusion (with its zero bytes,
-for example)
-
-=item *
-
-it is beyond the power of words to describe the way HTML browsers
-encode non-C<ASCII> form data. To get a general impression, visit
-L<http://ppewww.ph.gla.ac.uk/~flavell/charset/form-i18n.html>.
-While encoding of form data has stabilized for C<UTF-8> encoded pages
-(at least IE 5/6, NS 6, and Opera 6 behave consistently), be sure to
-expect fun (and cross-browser discrepancies) with C<UTF-16> encoded
-pages!
-
-=back
-
-The rule of thumb is to use C<UTF-8> unless you know what
-you're doing and unless you really benefit from using C<UTF-16>.
-
- ISO-IR-165 [RFC1345]
- VISCII
- GB 12345
- GB 18030 (**) (see links bellow)
- EUC-TW (**)
-
-are totally valid encodings but not registered at IANA.
-The names under which they are listed here are probably the
-most widely-known names for these encodings and are recommended
-names.
-
- BIG5PLUS (**)
-
-is a proprietary name.
-
-=head2 Microsoft-related naming mess
-
-Microsoft products misuse the following names:
-
-=over 4
-
-=item KS_C_5601-1987
-
-Microsoft extension to C<EUC-KR>.
-
-Proper names: C<CP949>, C<UHC>, C<x-windows-949> (as used by Mozilla).
-
-See L<http://lists.w3.org/Archives/Public/ietf-charsets/2001AprJun/0033.html>
-for details.
-
-Encode aliases C<KS_C_5601-1987> to C<cp949> to reflect this common
-misusage. I<Raw> C<KS_C_5601-1987> encoding is available as
-C<kcs5601-raw>.
-
-See L<Encode::KR> for details.
-
-=item GB2312
-
-Microsoft extension to C<EUC-CN>.
-
-Proper names: C<CP936>, C<GBK>.
-
-C<GB2312> has been registered in the C<EUC-CN> meaning at
-IANA. This has partially repaired the situation: Microsoft's
-C<GB2312> has become a superset of the official C<GB2312>.
-
-Encode aliases C<GB2312> to C<euc-cn> in full agreement with
-IANA registration. C<cp936> is supported separately.
-I<Raw> C<GB_2312-80> encoding is available as C<gb2312-raw>.
-
-See L<Encode::CN> for details.
-
-=item Big5
-
-Microsoft extension to C<Big5>.
-
-Proper name: C<CP950>.
-
-Encode separately supports C<Big5> and C<cp950>.
-
-=item Shift_JIS
-
-Microsoft's understanding of C<Shift_JIS>.
-
-JIS has not endorsed the full Microsoft standard however.
-The official C<Shift_JIS> includes only JIS X 0201 and JIS X 0208
-character sets, while Microsoft has always used C<Shift_JIS>
-to encode a wider character repertoire. See C<IANA> registration for
-C<Windows-31J>.
-
-As a historical predecessor, Microsoft's variant
-probably has more rights for the name, though it may be objected
-that Microsoft shouldn't have used JIS as part of the name
-in the first place.
-
-Unambiguous name: C<CP932>. C<IANA> name (also used by Mozilla, and
-provided as an alias by Encode): C<Windows-31J>.
-
-Encode separately supports C<Shift_JIS> and C<cp932>.
-
-=back
-
-=head1 Glossary
-
-=over 4
-
-=item character repertoire
-
-A collection of unique characters. A I<character> set in the strictest
-sense. At this stage, characters are not numbered.
-
-=item coded character set (CCS)
-
-A character set that is mapped in a way computers can use directly.
-Many character encodings, including EUC, fall in this category.
-
-=item character encoding scheme (CES)
-
-An algorithm to map a character set to a byte sequence. You don't
-have to be able to tell which character set a given byte sequence
-belongs. 7-bit ISO-2022 is a CES but it cannot be a CCS. EUC is an
-example of being both a CCS and CES.
-
-=item charset (in MIME context)
-
-has long been used in the meaning of C<encoding>, CES.
-
-While the word combination C<character set> has lost this meaning
-in MIME context since [RFC 2130], the C<charset> abbreviation has
-retained it. This is how [RFC 2277] and [RFC 2278] bless C<charset>:
-
- This document uses the term "charset" to mean a set of rules for
- mapping from a sequence of octets to a sequence of characters, such
- as the combination of a coded character set and a character encoding
- scheme; this is also what is used as an identifier in MIME "charset="
- parameters, and registered in the IANA charset registry ... (Note
- that this is NOT a term used by other standards bodies, such as ISO).
- [RFC 2277]
-
-=item EUC
-
-Extended Unix Character. See ISO-2022.
-
-=item ISO-2022
-
-A CES that was carefully designed to coexist with ASCII. There are a 7
-bit version and an 8 bit version.
-
-The 7 bit version switches character set via escape sequence so it
-cannot form a CCS. Since this is more difficult to handle in programs
-than the 8 bit version, the 7 bit version is not very popular except for
-iso-2022-jp, the I<de facto> standard CES for e-mails.
-
-The 8 bit version can form a CCS. EUC and ISO-8859 are two examples
-thereof. Pre-5.6 perl could use them as string literals.
-
-=item UCS
-
-Short for I<Universal Character Set>. When you say just UCS, it means
-I<Unicode>.
-
-=item UCS-2
-
-ISO/IEC 10646 encoding form: Universal Character Set coded in two
-octets.
-
-=item Unicode
-
-A character set that aims to include all character repertoires of the
-world. Many character sets in various national as well as industrial
-standards have become, in a way, just subsets of Unicode.
-
-=item UTF
-
-Short for I<Unicode Transformation Format>. Determines how to map a
-Unicode character into a byte sequence.
-
-=item UTF-16
-
-A UTF in 16-bit encoding. Can either be in big endian or little
-endian. The big endian version is called UTF-16BE (equal to UCS-2 +
-surrogate support) and the little endian version is called UTF-16LE.
-
-=back
-
-=head1 See Also
-
-L<Encode>,
-L<Encode::Byte>,
-L<Encode::CN>, L<Encode::JP>, L<Encode::KR>, L<Encode::TW>,
-L<Encode::EBCDIC>, L<Encode::Symbol>
-L<Encode::MIME::Header>, L<Encode::Guess>
-
-=head1 References
-
-=over 4
-
-=item ECMA
-
-European Computer Manufacturers Association
-L<http://www.ecma.ch>
-
-=over 4
-
-=item ECMA-035 (eq C<ISO-2022>)
-
-L<http://www.ecma.ch/ecma1/STAND/ECMA-035.HTM>
-
-The specification of ISO-2022 is available from the link above.
-
-=back
-
-=item IANA
-
-Internet Assigned Numbers Authority
-L<http://www.iana.org/>
-
-=over 4
-
-=item Assigned Charset Names by IANA
-
-L<http://www.iana.org/assignments/character-sets>
-
-Most of the C<canonical names> in Encode derive from this list
-so you can directly apply the string you have extracted from MIME
-header of mails and web pages.
-
-=back
-
-=item ISO
-
-International Organization for Standardization
-L<http://www.iso.ch/>
-
-=item RFC
-
-Request For Comments -- need I say more?
-L<http://www.rfc-editor.org/>, L<http://www.rfc.net/>,
-L<http://www.faqs.org/rfcs/>
-
-=item UC
-
-Unicode Consortium
-L<http://www.unicode.org/>
-
-=over 4
-
-=item Unicode Glossary
-
-L<http://www.unicode.org/glossary/>
-
-The glossary of this document is based upon this site.
-
-=back
-
-=back
-
-=head2 Other Notable Sites
-
-=over 4
-
-=item czyborra.com
-
-L<http://czyborra.com/>
-
-Contains a lot of useful information, especially gory details of ISO
-vs. vendor mappings.
-
-=item CJK.inf
-
-L<http://www.oreilly.com/people/authors/lunde/cjk_inf.html>
-
-Somewhat obsolete (last update in 1996), but still useful. Also try
-
-L<ftp://ftp.oreilly.com/pub/examples/nutshell/cjkv/pdf/GB18030_Summary.pdf>
-
-You will find brief info on C<EUC-CN>, C<GBK> and mostly on C<GB 18030>.
-
-=item Jungshik Shin's Hangul FAQ
-
-L<http://jshin.net/faq>
-
-And especially its subject 8.
-
-L<http://jshin.net/faq/qa8.html>
-
-A comprehensive overview of the Korean (C<KS *>) standards.
-
-=item debian.org: "Introduction to i18n"
-
-A brief description for most of the mentioned CJK encodings is
-contained in
-L<http://www.debian.org/doc/manuals/intro-i18n/ch-codes.en.html>
-
-=back
-
-=head2 Offline sources
-
-=over 4
-
-=item C<CJKV Information Processing> by Ken Lunde
-
-CJKV Information Processing
-1999 O'Reilly & Associates, ISBN : 1-56592-224-7
-
-The modern successor of C<CJK.inf>.
-
-Features a comprehensive coverage of CJKV character sets and
-encodings along with many other issues faced by anyone trying
-to better support CJKV languages/scripts in all the areas of
-information processing.
-
-To purchase this book, visit
-L<http://www.oreilly.com/catalog/cjkvinfo/>
-or your favourite bookstore.
-
-=back
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Symbol.pm b/Master/tlpkg/installer/perllib/Encode/Symbol.pm
deleted file mode 100644
index 7ad8ca92c7d..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Symbol.pm
+++ /dev/null
@@ -1,42 +0,0 @@
-package Encode::Symbol;
-use Encode;
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use XSLoader;
-XSLoader::load(__PACKAGE__,$VERSION);
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::Symbol - Symbol Encodings
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $symbol = encode("symbol", $utf8); # loads Encode::Symbol implicitly
- $utf8 = decode("", $symbol); # ditto
-
-=head1 ABSTRACT
-
-This module implements symbol and dingbats encodings. Encodings
-supported are as follows.
-
- Canonical Alias Description
- --------------------------------------------------------------------
- symbol
- dingbats
- AdobeZDingbat
- AdobeSymbol
- MacDingbats
-
-=head1 DESCRIPTION
-
-To find out how to use this module in detail, see L<Encode>.
-
-=head1 SEE ALSO
-
-L<Encode>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/TW.pm b/Master/tlpkg/installer/perllib/Encode/TW.pm
deleted file mode 100644
index 2e1abc0c7f9..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/TW.pm
+++ /dev/null
@@ -1,78 +0,0 @@
-package Encode::TW;
-BEGIN {
- if (ord("A") == 193) {
- die "Encode::TW not supported on EBCDIC\n";
- }
-}
-our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use Encode;
-use XSLoader;
-XSLoader::load(__PACKAGE__,$VERSION);
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::TW - Taiwan-based Chinese Encodings
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $big5 = encode("big5", $utf8); # loads Encode::TW implicitly
- $utf8 = decode("big5", $big5); # ditto
-
-=head1 DESCRIPTION
-
-This module implements tradition Chinese charset encodings as used
-in Taiwan and Hong Kong.
-Encodings supported are as follows.
-
- Canonical Alias Description
- --------------------------------------------------------------------
- big5-eten /\bbig-?5$/i Big5 encoding (with ETen extensions)
- /\bbig5-?et(en)?$/i
- /\btca-?big5$/i
- big5-hkscs /\bbig5-?hk(scs)?$/i
- /\bhk(scs)?-?big5$/i
- Big5 + Cantonese characters in Hong Kong
- MacChineseTrad Big5 + Apple Vendor Mappings
- cp950 Code Page 950
- = Big5 + Microsoft vendor mappings
- --------------------------------------------------------------------
-
-To find out how to use this module in detail, see L<Encode>.
-
-=head1 NOTES
-
-Due to size concerns, C<EUC-TW> (Extended Unix Character), C<CCCII>
-(Chinese Character Code for Information Interchange), C<BIG5PLUS>
-(CMEX's Big5+) and C<BIG5EXT> (CMEX's Big5e) are distributed separately
-on CPAN, under the name L<Encode::HanExtra>. That module also contains
-extra China-based encodings.
-
-=head1 BUGS
-
-Since the original C<big5> encoding (1984) is not supported anywhere
-(glibc and DOS-based systems uses C<big5> to mean C<big5-eten>; Microsoft
-uses C<big5> to mean C<cp950>), a conscious decision was made to alias
-C<big5> to C<big5-eten>, which is the de facto superset of the original
-big5.
-
-The C<CNS11643> encoding files are not complete. For common C<CNS11643>
-manipulation, please use C<EUC-TW> in L<Encode::HanExtra>, which contains
-planes 1-7.
-
-The ASCII region (0x00-0x7f) is preserved for all encodings, even
-though this conflicts with mappings by the Unicode Consortium. See
-
-L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en>
-
-to find out why it is implemented that way.
-
-=head1 SEE ALSO
-
-L<Encode>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Unicode.pm b/Master/tlpkg/installer/perllib/Encode/Unicode.pm
deleted file mode 100644
index 4d0c31d82d3..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Unicode.pm
+++ /dev/null
@@ -1,268 +0,0 @@
-package Encode::Unicode;
-
-use strict;
-use warnings;
-no warnings 'redefine';
-
-our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-use XSLoader;
-XSLoader::load(__PACKAGE__,$VERSION);
-
-#
-# Object Generator 8 transcoders all at once!
-#
-
-require Encode;
-
-our %BOM_Unknown = map {$_ => 1} qw(UTF-16 UTF-32);
-
-for my $name (qw(UTF-16 UTF-16BE UTF-16LE
- UTF-32 UTF-32BE UTF-32LE
- UCS-2BE UCS-2LE))
-{
- my ($size, $endian, $ucs2, $mask);
- $name =~ /^(\w+)-(\d+)(\w*)$/o;
- if ($ucs2 = ($1 eq 'UCS')){
- $size = 2;
- }else{
- $size = $2/8;
- }
- $endian = ($3 eq 'BE') ? 'n' : ($3 eq 'LE') ? 'v' : '' ;
- $size == 4 and $endian = uc($endian);
-
- $Encode::Encoding{$name} =
- bless {
- Name => $name,
- size => $size,
- endian => $endian,
- ucs2 => $ucs2,
- } => __PACKAGE__;
-}
-
-use base qw(Encode::Encoding);
-
-sub renew {
- my $self = shift;
- $BOM_Unknown{$self->name} or return $self;
- my $clone = bless { %$self } => ref($self);
- $clone->{renewed}++; # so the caller knows it is renewed.
- return $clone;
-}
-
-# There used to be a perl implemntation of (en|de)code but with
-# XS version is ripe, perl version is zapped for optimal speed
-
-*decode = \&decode_xs;
-*encode = \&encode_xs;
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::Unicode -- Various Unicode Transformation Formats
-
-=cut
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $ucs2 = encode("UCS-2BE", $utf8);
- $utf8 = decode("UCS-2BE", $ucs2);
-
-=head1 ABSTRACT
-
-This module implements all Character Encoding Schemes of Unicode that
-are officially documented by Unicode Consortium (except, of course,
-for UTF-8, which is a native format in perl).
-
-=over 4
-
-=item L<http://www.unicode.org/glossary/> says:
-
-I<Character Encoding Scheme> A character encoding form plus byte
-serialization. There are Seven character encoding schemes in Unicode:
-UTF-8, UTF-16, UTF-16BE, UTF-16LE, UTF-32 (UCS-4), UTF-32BE (UCS-4BE) and
-UTF-32LE (UCS-4LE), and UTF-7.
-
-Since UTF-7 is a 7-bit (re)encoded version of UTF-16BE, It is not part of
-Unicode's Character Encoding Scheme. It is separately implemented in
-Encode::Unicode::UTF7. For details see L<Encode::Unicode::UTF7>.
-
-=item Quick Reference
-
- Decodes from ord(N) Encodes chr(N) to...
- octet/char BOM S.P d800-dfff ord > 0xffff \x{1abcd} ==
- ---------------+-----------------+------------------------------
- UCS-2BE 2 N N is bogus Not Available
- UCS-2LE 2 N N bogus Not Available
- UTF-16 2/4 Y Y is S.P S.P BE/LE
- UTF-16BE 2/4 N Y S.P S.P 0xd82a,0xdfcd
- UTF-16LE 2 N Y S.P S.P 0x2ad8,0xcddf
- UTF-32 4 Y - is bogus As is BE/LE
- UTF-32BE 4 N - bogus As is 0x0001abcd
- UTF-32LE 4 N - bogus As is 0xcdab0100
- UTF-8 1-4 - - bogus >= 4 octets \xf0\x9a\af\8d
- ---------------+-----------------+------------------------------
-
-=back
-
-=head1 Size, Endianness, and BOM
-
-You can categorize these CES by 3 criteria: size of each character,
-endianness, and Byte Order Mark.
-
-=head2 by size
-
-UCS-2 is a fixed-length encoding with each character taking 16 bits.
-It B<does not> support I<surrogate pairs>. When a surrogate pair
-is encountered during decode(), its place is filled with \x{FFFD}
-if I<CHECK> is 0, or the routine croaks if I<CHECK> is 1. When a
-character whose ord value is larger than 0xFFFF is encountered,
-its place is filled with \x{FFFD} if I<CHECK> is 0, or the routine
-croaks if I<CHECK> is 1.
-
-UTF-16 is almost the same as UCS-2 but it supports I<surrogate pairs>.
-When it encounters a high surrogate (0xD800-0xDBFF), it fetches the
-following low surrogate (0xDC00-0xDFFF) and C<desurrogate>s them to
-form a character. Bogus surrogates result in death. When \x{10000}
-or above is encountered during encode(), it C<ensurrogate>s them and
-pushes the surrogate pair to the output stream.
-
-UTF-32 (UCS-4) is a fixed-length encoding with each character taking 32 bits.
-Since it is 32-bit, there is no need for I<surrogate pairs>.
-
-=head2 by endianness
-
-The first (and now failed) goal of Unicode was to map all character
-repertoires into a fixed-length integer so that programmers are happy.
-Since each character is either a I<short> or I<long> in C, you have to
-pay attention to the endianness of each platform when you pass data
-to one another.
-
-Anything marked as BE is Big Endian (or network byte order) and LE is
-Little Endian (aka VAX byte order). For anything not marked either
-BE or LE, a character called Byte Order Mark (BOM) indicating the
-endianness is prepended to the string.
-
-CAVEAT: Though BOM in utf8 (\xEF\xBB\xBF) is valid, it is meaningless
-and as of this writing Encode suite just leave it as is (\x{FeFF}).
-
-=over 4
-
-=item BOM as integer when fetched in network byte order
-
- 16 32 bits/char
- -------------------------
- BE 0xFeFF 0x0000FeFF
- LE 0xFFeF 0xFFFe0000
- -------------------------
-
-=back
-
-This modules handles the BOM as follows.
-
-=over 4
-
-=item *
-
-When BE or LE is explicitly stated as the name of encoding, BOM is
-simply treated as a normal character (ZERO WIDTH NO-BREAK SPACE).
-
-=item *
-
-When BE or LE is omitted during decode(), it checks if BOM is at the
-beginning of the string; if one is found, the endianness is set to
-what the BOM says. If no BOM is found, the routine dies.
-
-=item *
-
-When BE or LE is omitted during encode(), it returns a BE-encoded
-string with BOM prepended. So when you want to encode a whole text
-file, make sure you encode() the whole text at once, not line by line
-or each line, not file, will have a BOM prepended.
-
-=item *
-
-C<UCS-2> is an exception. Unlike others, this is an alias of UCS-2BE.
-UCS-2 is already registered by IANA and others that way.
-
-=back
-
-=head1 Surrogate Pairs
-
-To say the least, surrogate pairs were the biggest mistake of the
-Unicode Consortium. But according to the late Douglas Adams in I<The
-Hitchhiker's Guide to the Galaxy> Trilogy, C<In the beginning the
-Universe was created. This has made a lot of people very angry and
-been widely regarded as a bad move>. Their mistake was not of this
-magnitude so let's forgive them.
-
-(I don't dare make any comparison with Unicode Consortium and the
-Vogons here ;) Or, comparing Encode to Babel Fish is completely
-appropriate -- if you can only stick this into your ear :)
-
-Surrogate pairs were born when the Unicode Consortium finally
-admitted that 16 bits were not big enough to hold all the world's
-character repertoires. But they already made UCS-2 16-bit. What
-do we do?
-
-Back then, the range 0xD800-0xDFFF was not allocated. Let's split
-that range in half and use the first half to represent the C<upper
-half of a character> and the second half to represent the C<lower
-half of a character>. That way, you can represent 1024 * 1024 =
-1048576 more characters. Now we can store character ranges up to
-\x{10ffff} even with 16-bit encodings. This pair of half-character is
-now called a I<surrogate pair> and UTF-16 is the name of the encoding
-that embraces them.
-
-Here is a formula to ensurrogate a Unicode character \x{10000} and
-above;
-
- $hi = ($uni - 0x10000) / 0x400 + 0xD800;
- $lo = ($uni - 0x10000) % 0x400 + 0xDC00;
-
-And to desurrogate;
-
- $uni = 0x10000 + ($hi - 0xD800) * 0x400 + ($lo - 0xDC00);
-
-Note this move has made \x{D800}-\x{DFFF} into a forbidden zone but
-perl does not prohibit the use of characters within this range. To perl,
-every one of \x{0000_0000} up to \x{ffff_ffff} (*) is I<a character>.
-
- (*) or \x{ffff_ffff_ffff_ffff} if your perl is compiled with 64-bit
- integer support!
-
-=head1 Error Checking
-
-Unlike most encodings which accept various ways to handle errors,
-Unicode encodings simply croaks.
-
- % perl -MEncode -e '$_ = "\xfe\xff\xd8\xd9\xda\xdb\0\n"' \
- -e 'Encode::from_to($_, "utf16","shift_jis", 0); print'
- UTF-16:Malformed LO surrogate d8d9 at /path/to/Encode.pm line 184.
- % perl -MEncode -e '$a = "BOM missing"' \
- -e ' Encode::from_to($a, "utf16", "shift_jis", 0); print'
- UTF-16:Unrecognised BOM 424f at /path/to/Encode.pm line 184.
-
-Unlike other encodings where mappings are not one-to-one against
-Unicode, UTFs are supposed to map 100% against one another. So Encode
-is more strict on UTFs.
-
-Consider that "division by zero" of Encode :)
-
-=head1 SEE ALSO
-
-L<Encode>, L<Encode::Unicode::UTF7>, L<http://www.unicode.org/glossary/>,
-L<http://www.unicode.org/unicode/faq/utf_bom.html>,
-
-RFC 2781 L<http://rfc.net/rfc2781.html>,
-
-The whole Unicode standard L<http://www.unicode.org/unicode/uni2book/u2.html>
-
-Ch. 15, pp. 403 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/installer/perllib/Encode/Unicode/UTF7.pm b/Master/tlpkg/installer/perllib/Encode/Unicode/UTF7.pm
deleted file mode 100644
index dc75ce37816..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/Unicode/UTF7.pm
+++ /dev/null
@@ -1,118 +0,0 @@
-#
-# $Id: UTF7.pm,v 2.1 2004/05/25 16:27:14 dankogai Exp $
-#
-package Encode::Unicode::UTF7;
-use strict;
-no warnings 'redefine';
-use base qw(Encode::Encoding);
-__PACKAGE__->Define('UTF-7');
-our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-use MIME::Base64;
-use Encode;
-
-#
-# Algorithms taken from Unicode::String by Gisle Aas
-#
-
-our $OPTIONAL_DIRECT_CHARS = 1;
-my $specials = quotemeta "\'(),-./:?";
-$OPTIONAL_DIRECT_CHARS and
- $specials .= quotemeta "!\"#$%&*;<=>@[]^_`{|}";
-# \s will not work because it matches U+3000 DEOGRAPHIC SPACE
-# We use qr/[\n\r\t\ ] instead
-my $re_asis = qr/(?:[\n\r\t\ A-Za-z0-9$specials])/;
-my $re_encoded = qr/(?:[^\n\r\t\ A-Za-z0-9$specials])/;
-my $e_utf16 = find_encoding("UTF-16BE");
-
-sub needs_lines { 1 };
-
-sub encode($$;$){
- my ($obj, $str, $chk) = @_;
- my $len = length($str);
- pos($str) = 0;
- my $bytes = '';
- while (pos($str) < $len){
- if ($str =~ /\G($re_asis+)/ogc){
- $bytes .= $1;
- }elsif($str =~ /\G($re_encoded+)/ogsc){
- if ($1 eq "+"){
- $bytes .= "+-";
- }else{
- my $s = $1;
- my $base64 = encode_base64($e_utf16->encode($s), '');
- $base64 =~ s/=+$//;
- $bytes .= "+$base64-";
- }
- }else{
- die "This should not happen! (pos=" . pos($str) . ")";
- }
- }
- $_[1] = '' if $chk;
- return $bytes;
-}
-
-sub decode{
- my ($obj, $bytes, $chk) = @_;
- my $len = length($bytes);
- my $str = "";
- while (pos($bytes) < $len) {
- if ($bytes =~ /\G([^+]+)/ogc) {
- $str .= $1;
- }elsif($bytes =~ /\G\+-/ogc) {
- $str .= "+";
- }elsif($bytes =~ /\G\+([A-Za-z0-9+\/]+)-?/ogsc) {
- my $base64 = $1;
- my $pad = length($base64) % 4;
- $base64 .= "=" x (4 - $pad) if $pad;
- $str .= $e_utf16->decode(decode_base64($base64));
- }elsif($bytes =~ /\G\+/ogc) {
- $^W and warn "Bad UTF7 data escape";
- $str .= "+";
- }else{
- die "This should not happen " . pos($bytes);
- }
- }
- $_[1] = '' if $chk;
- return $str;
-}
-1;
-__END__
-
-=head1 NAME
-
-Encode::Unicode::UTF7 -- UTF-7 encoding
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $utf7 = encode("UTF-7", $utf8);
- $utf8 = decode("UTF-7", $ucs2);
-
-=head1 ABSTRACT
-
-This module implements UTF-7 encoding documented in RFC 2152. UTF-7,
-as its name suggests, is a 7-bit re-encoded version of UTF-16BE. It
-is designed to be MTA-safe and expected to be a standard way to
-exchange Unicoded mails via mails. But with the advent of UTF-8 and
-8-bit compliant MTAs, UTF-7 is hardly ever used.
-
-UTF-7 was not supported by Encode until version 1.95 because of that.
-But Unicode::String, a module by Gisle Aas which adds Unicode supports
-to non-utf8-savvy perl did support UTF-7, the UTF-7 support was added
-so Encode can supersede Unicode::String 100%.
-
-=head1 In Practice
-
-When you want to encode Unicode for mails and web pages, however, do
-not use UTF-7 unless you are sure your recipients and readers can
-handle it. Very few MUAs and WWW Browsers support these days (only
-Mozilla seems to support one). For general cases, use UTF-8 for
-message body and MIME-Header for header instead.
-
-=head1 SEE ALSO
-
-L<Encode>, L<Encode::Unicode>, L<Unicode::String>
-
-RFC 2781 L<http://www.ietf.org/rfc/rfc2152.txt>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/_PM.e2x b/Master/tlpkg/installer/perllib/Encode/_PM.e2x
deleted file mode 100644
index eb59cd1b520..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/_PM.e2x
+++ /dev/null
@@ -1,23 +0,0 @@
-package Encode::$_Name_;
-our $VERSION = "0.01";
-
-use Encode;
-use XSLoader;
-XSLoader::load(__PACKAGE__,$VERSION);
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::$_Name_ - New Encoding
-
-=head1 SYNOPSIS
-
-You got to fill this in!
-
-=head1 SEE ALSO
-
-L<Encode>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/_T.e2x b/Master/tlpkg/installer/perllib/Encode/_T.e2x
deleted file mode 100644
index 6cf5f293d54..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/_T.e2x
+++ /dev/null
@@ -1,7 +0,0 @@
-use strict;
-# Adjust the number here!
-use Test::More tests => 2;
-
-use_ok('Encode');
-use_ok('Encode::$_Name_');
-# Add more test here!
diff --git a/Master/tlpkg/installer/perllib/Encode/encode.h b/Master/tlpkg/installer/perllib/Encode/encode.h
deleted file mode 100644
index 94764a6a14c..00000000000
--- a/Master/tlpkg/installer/perllib/Encode/encode.h
+++ /dev/null
@@ -1,111 +0,0 @@
-#ifndef ENCODE_H
-#define ENCODE_H
-
-#ifndef U8
-/*
- A tad devious this:
- perl normally has a #define for U8 - if that isn't present then we
- typedef it - leaving it #ifndef so we can do data parts without
- getting extern references to the code parts
-*/
-typedef unsigned char U8;
-#endif
-
-typedef struct encpage_s encpage_t;
-
-struct encpage_s
-{
- /* fields ordered to pack nicely on 32-bit machines */
- const U8 *seq; /* Packed output sequences we generate
- if we match */
- encpage_t *next; /* Page to go to if we match */
- U8 min; /* Min value of octet to match this entry */
- U8 max; /* Max value of octet to match this entry */
- U8 dlen; /* destination length -
- size of entries in seq */
- U8 slen; /* source length -
- number of source octets needed */
-};
-
-/*
- At any point in a translation there is a page pointer which points
- at an array of the above structures.
-
- Basic operation :
- get octet from source stream.
- if (octet >= min && octet < max) {
- if slen is 0 then we cannot represent this character.
- if we have less than slen octets (including this one) then
- we have a partial character.
- otherwise
- copy dlen octets from seq + dlen*(octet-min) to output
- (dlen may be zero if we don't know yet.)
- load page pointer with next to continue.
- (is slen is one this is end of a character)
- get next octet.
- }
- else {
- increment the page pointer to look at next slot in the array
- }
-
- arrays SHALL be constructed so there is an entry which matches
- ..0xFF at the end, and either maps it or indicates no
- representation.
-
- if MSB of slen is set then mapping is an approximate "FALLBACK" entry.
-
-*/
-
-
-typedef struct encode_s encode_t;
-struct encode_s
-{
- encpage_t *t_utf8; /* Starting table for translation from
- the encoding to UTF-8 form */
- encpage_t *f_utf8; /* Starting table for translation
- from UTF-8 to the encoding */
- const U8 *rep; /* Replacement character in this encoding
- e.g. "?" */
- int replen; /* Number of octets in rep */
- U8 min_el; /* Minimum octets to represent a character */
- U8 max_el; /* Maximum octets to represent a character */
- const char *name[2]; /* name(s) of this encoding */
-};
-
-#ifdef U8
-/* See comment at top of file for deviousness */
-
-extern int do_encode(encpage_t *enc, const U8 *src, STRLEN *slen,
- U8 *dst, STRLEN dlen, STRLEN *dout, int approx,
- const U8 *term, STRLEN tlen);
-
-extern void Encode_DefineEncoding(encode_t *enc);
-
-#endif /* U8 */
-
-#define ENCODE_NOSPACE 1
-#define ENCODE_PARTIAL 2
-#define ENCODE_NOREP 3
-#define ENCODE_FALLBACK 4
-#define ENCODE_FOUND_TERM 5
-
-#define FBCHAR_UTF8 "\xEF\xBF\xBD"
-
-#define ENCODE_DIE_ON_ERR 0x0001 /* croaks immediately */
-#define ENCODE_WARN_ON_ERR 0x0002 /* warn on error; may proceed */
-#define ENCODE_RETURN_ON_ERR 0x0004 /* immediately returns on NOREP */
-#define ENCODE_LEAVE_SRC 0x0008 /* $src updated unless set */
-#define ENCODE_PERLQQ 0x0100 /* perlqq fallback string */
-#define ENCODE_HTMLCREF 0x0200 /* HTML character ref. fb mode */
-#define ENCODE_XMLCREF 0x0400 /* XML character ref. fb mode */
-#define ENCODE_STOP_AT_PARTIAL 0x0800 /* stop at partial explicitly */
-
-#define ENCODE_FB_DEFAULT 0x0000
-#define ENCODE_FB_CROAK 0x0001
-#define ENCODE_FB_QUIET ENCODE_RETURN_ON_ERR
-#define ENCODE_FB_WARN (ENCODE_RETURN_ON_ERR|ENCODE_WARN_ON_ERR)
-#define ENCODE_FB_PERLQQ (ENCODE_PERLQQ|ENCODE_LEAVE_SRC)
-#define ENCODE_FB_HTMLCREF (ENCODE_HTMLCREF|ENCODE_LEAVE_SRC)
-#define ENCODE_FB_XMLCREF (ENCODE_XMLCREF|ENCODE_LEAVE_SRC)
-
-#endif /* ENCODE_H */
diff --git a/Master/tlpkg/installer/perllib/Errno.pm b/Master/tlpkg/installer/perllib/Errno.pm
deleted file mode 100644
index 23c07ea0482..00000000000
--- a/Master/tlpkg/installer/perllib/Errno.pm
+++ /dev/null
@@ -1,227 +0,0 @@
-#
-# 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 strict;
-
-$VERSION = "1.09_01";
-$VERSION = eval $VERSION;
-@ISA = qw(Exporter);
-
-@EXPORT_OK = qw(EBADR ENOMSG ENOTSUP ESTRPIPE EADDRINUSE EL3HLT EBADF
- ENOTBLK ENAVAIL ECHRNG ENOTNAM ELNRNG ENOKEY EXDEV EBADE EBADSLT
- ECONNREFUSED ENOSTR ENONET EOVERFLOW EISCONN EFBIG EKEYREVOKED
- ECONNRESET EWOULDBLOCK ELIBMAX EREMOTEIO ENOPKG ELIBSCN EDESTADDRREQ
- ENOTSOCK EIO EMEDIUMTYPE EINPROGRESS ERANGE EAFNOSUPPORT EADDRNOTAVAIL
- EINTR EREMOTE EILSEQ ENOMEM EPIPE ENETUNREACH ENODATA EUSERS
- EOPNOTSUPP EPROTO EISNAM ESPIPE EALREADY ENAMETOOLONG ENOEXEC EISDIR
- EBADRQC EEXIST EDOTDOT ELIBBAD EOWNERDEAD ESRCH EFAULT EXFULL
- EDEADLOCK EAGAIN ENOPROTOOPT ENETDOWN EPROTOTYPE EL2NSYNC ENETRESET
- EUCLEAN EADV EROFS ESHUTDOWN EMULTIHOP EPROTONOSUPPORT ENFILE ENOLCK
- ECONNABORTED ECANCELED EDEADLK ESRMNT ENOLINK ETIME ENOTDIR EINVAL
- ENOTTY ENOANO ELOOP ENOENT EPFNOSUPPORT EBADMSG ENOMEDIUM EL2HLT EDOM
- EBFONT EKEYEXPIRED EMSGSIZE ENOCSI EL3RST ENOSPC EIDRM ENOBUFS ENOSYS
- EHOSTDOWN EBADFD ENOSR ENOTCONN ESTALE EDQUOT EKEYREJECTED EMFILE
- ENOTRECOVERABLE EACCES EBUSY E2BIG EPERM ELIBEXEC ETOOMANYREFS ELIBACC
- ENOTUNIQ ECOMM ERESTART ESOCKTNOSUPPORT EUNATCH ETIMEDOUT ENXIO ENODEV
- ETXTBSY EMLINK ECHILD EHOSTUNREACH EREMCHG ENOTEMPTY);
-
-%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 ENOTBLK
- ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
- EPFNOSUPPORT EPIPE EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART
- EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT
- ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV
- )]
-);
-
-sub EPERM () { 1 }
-sub ENOENT () { 2 }
-sub ESRCH () { 3 }
-sub EINTR () { 4 }
-sub EIO () { 5 }
-sub ENXIO () { 6 }
-sub E2BIG () { 7 }
-sub ENOEXEC () { 8 }
-sub EBADF () { 9 }
-sub ECHILD () { 10 }
-sub EWOULDBLOCK () { 11 }
-sub EAGAIN () { 11 }
-sub ENOMEM () { 12 }
-sub EACCES () { 13 }
-sub EFAULT () { 14 }
-sub ENOTBLK () { 15 }
-sub EBUSY () { 16 }
-sub EEXIST () { 17 }
-sub EXDEV () { 18 }
-sub ENODEV () { 19 }
-sub ENOTDIR () { 20 }
-sub EISDIR () { 21 }
-sub EINVAL () { 22 }
-sub ENFILE () { 23 }
-sub EMFILE () { 24 }
-sub ENOTTY () { 25 }
-sub ETXTBSY () { 26 }
-sub EFBIG () { 27 }
-sub ENOSPC () { 28 }
-sub ESPIPE () { 29 }
-sub EROFS () { 30 }
-sub EMLINK () { 31 }
-sub EPIPE () { 32 }
-sub EDOM () { 33 }
-sub ERANGE () { 34 }
-sub EDEADLOCK () { 35 }
-sub EDEADLK () { 35 }
-sub ENAMETOOLONG () { 36 }
-sub ENOLCK () { 37 }
-sub ENOSYS () { 38 }
-sub ENOTEMPTY () { 39 }
-sub ELOOP () { 40 }
-sub ENOMSG () { 42 }
-sub EIDRM () { 43 }
-sub ECHRNG () { 44 }
-sub EL2NSYNC () { 45 }
-sub EL3HLT () { 46 }
-sub EL3RST () { 47 }
-sub ELNRNG () { 48 }
-sub EUNATCH () { 49 }
-sub ENOCSI () { 50 }
-sub EL2HLT () { 51 }
-sub EBADE () { 52 }
-sub EBADR () { 53 }
-sub EXFULL () { 54 }
-sub ENOANO () { 55 }
-sub EBADRQC () { 56 }
-sub EBADSLT () { 57 }
-sub EBFONT () { 59 }
-sub ENOSTR () { 60 }
-sub ENODATA () { 61 }
-sub ETIME () { 62 }
-sub ENOSR () { 63 }
-sub ENONET () { 64 }
-sub ENOPKG () { 65 }
-sub EREMOTE () { 66 }
-sub ENOLINK () { 67 }
-sub EADV () { 68 }
-sub ESRMNT () { 69 }
-sub ECOMM () { 70 }
-sub EPROTO () { 71 }
-sub EMULTIHOP () { 72 }
-sub EDOTDOT () { 73 }
-sub EBADMSG () { 74 }
-sub EOVERFLOW () { 75 }
-sub ENOTUNIQ () { 76 }
-sub EBADFD () { 77 }
-sub EREMCHG () { 78 }
-sub ELIBACC () { 79 }
-sub ELIBBAD () { 80 }
-sub ELIBSCN () { 81 }
-sub ELIBMAX () { 82 }
-sub ELIBEXEC () { 83 }
-sub EILSEQ () { 84 }
-sub ERESTART () { 85 }
-sub ESTRPIPE () { 86 }
-sub EUSERS () { 87 }
-sub ENOTSOCK () { 88 }
-sub EDESTADDRREQ () { 89 }
-sub EMSGSIZE () { 90 }
-sub EPROTOTYPE () { 91 }
-sub ENOPROTOOPT () { 92 }
-sub EPROTONOSUPPORT () { 93 }
-sub ESOCKTNOSUPPORT () { 94 }
-sub ENOTSUP () { 95 }
-sub EOPNOTSUPP () { 95 }
-sub EPFNOSUPPORT () { 96 }
-sub EAFNOSUPPORT () { 97 }
-sub EADDRINUSE () { 98 }
-sub EADDRNOTAVAIL () { 99 }
-sub ENETDOWN () { 100 }
-sub ENETUNREACH () { 101 }
-sub ENETRESET () { 102 }
-sub ECONNABORTED () { 103 }
-sub ECONNRESET () { 104 }
-sub ENOBUFS () { 105 }
-sub EISCONN () { 106 }
-sub ENOTCONN () { 107 }
-sub ESHUTDOWN () { 108 }
-sub ETOOMANYREFS () { 109 }
-sub ETIMEDOUT () { 110 }
-sub ECONNREFUSED () { 111 }
-sub EHOSTDOWN () { 112 }
-sub EHOSTUNREACH () { 113 }
-sub EALREADY () { 114 }
-sub EINPROGRESS () { 115 }
-sub ESTALE () { 116 }
-sub EUCLEAN () { 117 }
-sub ENOTNAM () { 118 }
-sub ENAVAIL () { 119 }
-sub EISNAM () { 120 }
-sub EREMOTEIO () { 121 }
-sub EDQUOT () { 122 }
-sub ENOMEDIUM () { 123 }
-sub EMEDIUMTYPE () { 124 }
-sub ECANCELED () { 125 }
-sub ENOKEY () { 126 }
-sub EKEYEXPIRED () { 127 }
-sub EKEYREVOKED () { 128 }
-sub EKEYREJECTED () { 129 }
-sub EOWNERDEAD () { 130 }
-sub ENOTRECOVERABLE () { 131 }
-
-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__
-
diff --git a/Master/tlpkg/installer/perllib/Exporter.pm b/Master/tlpkg/installer/perllib/Exporter.pm
deleted file mode 100644
index d9c22049776..00000000000
--- a/Master/tlpkg/installer/perllib/Exporter.pm
+++ /dev/null
@@ -1,440 +0,0 @@
-package Exporter;
-
-require 5.006;
-
-# Be lean.
-#use strict;
-#no strict 'refs';
-
-our $Debug = 0;
-our $ExportLevel = 0;
-our $Verbose ||= 0;
-our $VERSION = '5.58';
-our (%Cache);
-$Carp::Internal{Exporter} = 1;
-
-sub as_heavy {
- require Exporter::Heavy;
- # Unfortunately, this does not work if the caller is aliased as *name = \&foo
- # Thus the need to create a lot of identical subroutines
- my $c = (caller(1))[3];
- $c =~ s/.*:://;
- \&{"Exporter::Heavy::heavy_$c"};
-}
-
-sub export {
- goto &{as_heavy()};
-}
-
-sub import {
- my $pkg = shift;
- my $callpkg = caller($ExportLevel);
-
- if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
- *{$callpkg."::import"} = \&import;
- return;
- }
-
- # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
- my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
- return export $pkg, $callpkg, @_
- if $Verbose or $Debug or @$fail > 1;
- my $export_cache = ($Cache{$pkg} ||= {});
- my $args = @_ or @_ = @$exports;
-
- local $_;
- if ($args and not %$export_cache) {
- s/^&//, $export_cache->{$_} = 1
- foreach (@$exports, @{"$pkg\::EXPORT_OK"});
- }
- my $heavy;
- # Try very hard not to use {} and hence have to enter scope on the foreach
- # We bomb out of the loop with last as soon as heavy is set.
- if ($args or $fail) {
- ($heavy = (/\W/ or $args and not exists $export_cache->{$_}
- or @$fail and $_ eq $fail->[0])) and last
- foreach (@_);
- } else {
- ($heavy = /\W/) and last
- foreach (@_);
- }
- return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
- local $SIG{__WARN__} =
- sub {require Carp; &Carp::carp};
- # shortcut for the common case of no type character
- *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
-}
-
-# Default methods
-
-sub export_fail {
- my $self = shift;
- @_;
-}
-
-# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
-# *name = \&foo. Thus the need to create a lot of identical subroutines
-# Otherwise we could have aliased them to export().
-
-sub export_to_level {
- goto &{as_heavy()};
-}
-
-sub export_tags {
- goto &{as_heavy()};
-}
-
-sub export_ok_tags {
- goto &{as_heavy()};
-}
-
-sub require_version {
- goto &{as_heavy()};
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Exporter - Implements default import method for modules
-
-=head1 SYNOPSIS
-
-In module YourModule.pm:
-
- package YourModule;
- require Exporter;
- @ISA = qw(Exporter);
- @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
-
-or
-
- package YourModule;
- use Exporter 'import'; # gives you Exporter's import() method directly
- @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
-
-In other files which wish to use YourModule:
-
- use ModuleName qw(frobnicate); # import listed symbols
- frobnicate ($left, $right) # calls YourModule::frobnicate
-
-=head1 DESCRIPTION
-
-The Exporter module implements an C<import> method which allows a module
-to export functions and variables to its users' namespaces. Many modules
-use Exporter rather than implementing their own C<import> method because
-Exporter provides a highly flexible interface, with an implementation optimised
-for the common case.
-
-Perl automatically calls the C<import> method when processing a
-C<use> statement for a module. Modules and C<use> are documented
-in L<perlfunc> and L<perlmod>. Understanding the concept of
-modules and how the C<use> statement operates is important to
-understanding the Exporter.
-
-=head2 How to Export
-
-The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
-symbols that are going to be exported into the users name space by
-default, or which they can request to be exported, respectively. The
-symbols can represent functions, scalars, arrays, hashes, or typeglobs.
-The symbols must be given by full name with the exception that the
-ampersand in front of a function is optional, e.g.
-
- @EXPORT = qw(afunc $scalar @array); # afunc is a function
- @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
-
-If you are only exporting function names it is recommended to omit the
-ampersand, as the implementation is faster this way.
-
-=head2 Selecting What To Export
-
-Do B<not> export method names!
-
-Do B<not> export anything else by default without a good reason!
-
-Exports pollute the namespace of the module user. If you must export
-try to use @EXPORT_OK in preference to @EXPORT and avoid short or
-common symbol names to reduce the risk of name clashes.
-
-Generally anything not exported is still accessible from outside the
-module using the ModuleName::item_name (or $blessed_ref-E<gt>method)
-syntax. By convention you can use a leading underscore on names to
-informally indicate that they are 'internal' and not for public use.
-
-(It is actually possible to get private functions by saying:
-
- my $subref = sub { ... };
- $subref->(@args); # Call it as a function
- $obj->$subref(@args); # Use it as a method
-
-However if you use them for methods it is up to you to figure out
-how to make inheritance work.)
-
-As a general rule, if the module is trying to be object oriented
-then export nothing. If it's just a collection of functions then
-@EXPORT_OK anything but use @EXPORT with caution. For function and
-method names use barewords in preference to names prefixed with
-ampersands for the export lists.
-
-Other module design guidelines can be found in L<perlmod>.
-
-=head2 How to Import
-
-In other files which wish to use your module there are three basic ways for
-them to load your module and import its symbols:
-
-=over 4
-
-=item C<use ModuleName;>
-
-This imports all the symbols from ModuleName's @EXPORT into the namespace
-of the C<use> statement.
-
-=item C<use ModuleName ();>
-
-This causes perl to load your module but does not import any symbols.
-
-=item C<use ModuleName qw(...);>
-
-This imports only the symbols listed by the caller into their namespace.
-All listed symbols must be in your @EXPORT or @EXPORT_OK, else an error
-occurs. The advanced export features of Exporter are accessed like this,
-but with list entries that are syntactically distinct from symbol names.
-
-=back
-
-Unless you want to use its advanced features, this is probably all you
-need to know to use Exporter.
-
-=head1 Advanced features
-
-=head2 Specialised Import Lists
-
-If any of the entries in an import list begins with !, : or / then
-the list is treated as a series of specifications which either add to
-or delete from the list of names to import. They are processed left to
-right. Specifications are in the form:
-
- [!]name This name only
- [!]:DEFAULT All names in @EXPORT
- [!]:tag All names in $EXPORT_TAGS{tag} anonymous list
- [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
-
-A leading ! indicates that matching names should be deleted from the
-list of names to import. If the first specification is a deletion it
-is treated as though preceded by :DEFAULT. If you just want to import
-extra names in addition to the default set you will still need to
-include :DEFAULT explicitly.
-
-e.g., Module.pm defines:
-
- @EXPORT = qw(A1 A2 A3 A4 A5);
- @EXPORT_OK = qw(B1 B2 B3 B4 B5);
- %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
-
- Note that you cannot use tags in @EXPORT or @EXPORT_OK.
- Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
-
-An application using Module can say something like:
-
- use Module qw(:DEFAULT :T2 !B3 A3);
-
-Other examples include:
-
- use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
- use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
-
-Remember that most patterns (using //) will need to be anchored
-with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
-
-You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
-specifications are being processed and what is actually being imported
-into modules.
-
-=head2 Exporting without using Exporter's import method
-
-Exporter has a special method, 'export_to_level' which is used in situations
-where you can't directly call Exporter's import method. The export_to_level
-method looks like:
-
- MyPackage->export_to_level($where_to_export, $package, @what_to_export);
-
-where $where_to_export is an integer telling how far up the calling stack
-to export your symbols, and @what_to_export is an array telling what
-symbols *to* export (usually this is @_). The $package argument is
-currently unused.
-
-For example, suppose that you have a module, A, which already has an
-import function:
-
- package A;
-
- @ISA = qw(Exporter);
- @EXPORT_OK = qw ($b);
-
- sub import
- {
- $A::b = 1; # not a very useful import method
- }
-
-and you want to Export symbol $A::b back to the module that called
-package A. Since Exporter relies on the import method to work, via
-inheritance, as it stands Exporter::import() will never get called.
-Instead, say the following:
-
- package A;
- @ISA = qw(Exporter);
- @EXPORT_OK = qw ($b);
-
- sub import
- {
- $A::b = 1;
- A->export_to_level(1, @_);
- }
-
-This will export the symbols one level 'above' the current package - ie: to
-the program or module that used package A.
-
-Note: Be careful not to modify C<@_> at all before you call export_to_level
-- or people using your package will get very unexplained results!
-
-=head2 Exporting without inheriting from Exporter
-
-By including Exporter in your @ISA you inherit an Exporter's import() method
-but you also inherit several other helper methods which you probably don't
-want. To avoid this you can do
-
- package YourModule;
- use Exporter qw( import );
-
-which will export Exporter's own import() method into YourModule.
-Everything will work as before but you won't need to include Exporter in
-@YourModule::ISA.
-
-=head2 Module Version Checking
-
-The Exporter module will convert an attempt to import a number from a
-module into a call to $module_name-E<gt>require_version($value). This can
-be used to validate that the version of the module being used is
-greater than or equal to the required version.
-
-The Exporter module supplies a default require_version method which
-checks the value of $VERSION in the exporting module.
-
-Since the default require_version method treats the $VERSION number as
-a simple numeric value it will regard version 1.10 as lower than
-1.9. For this reason it is strongly recommended that you use numbers
-with at least two decimal places, e.g., 1.09.
-
-=head2 Managing Unknown Symbols
-
-In some situations you may want to prevent certain symbols from being
-exported. Typically this applies to extensions which have functions
-or constants that may not exist on some systems.
-
-The names of any symbols that cannot be exported should be listed
-in the C<@EXPORT_FAIL> array.
-
-If a module attempts to import any of these symbols the Exporter
-will give the module an opportunity to handle the situation before
-generating an error. The Exporter will call an export_fail method
-with a list of the failed symbols:
-
- @failed_symbols = $module_name->export_fail(@failed_symbols);
-
-If the export_fail method returns an empty list then no error is
-recorded and all the requested symbols are exported. If the returned
-list is not empty then an error is generated for each symbol and the
-export fails. The Exporter provides a default export_fail method which
-simply returns the list unchanged.
-
-Uses for the export_fail method include giving better error messages
-for some symbols and performing lazy architectural checks (put more
-symbols into @EXPORT_FAIL by default and then take them out if someone
-actually tries to use them and an expensive check shows that they are
-usable on that platform).
-
-=head2 Tag Handling Utility Functions
-
-Since the symbols listed within %EXPORT_TAGS must also appear in either
-@EXPORT or @EXPORT_OK, two utility functions are provided which allow
-you to easily add tagged sets of symbols to @EXPORT or @EXPORT_OK:
-
- %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
-
- Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
- Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
-
-Any names which are not tags are added to @EXPORT or @EXPORT_OK
-unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
-names being silently added to @EXPORT or @EXPORT_OK. Future versions
-may make this a fatal error.
-
-=head2 Generating combined tags
-
-If several symbol categories exist in %EXPORT_TAGS, it's usually
-useful to create the utility ":all" to simplify "use" statements.
-
-The simplest way to do this is:
-
- %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
-
- # add all the other ":class" tags to the ":all" class,
- # deleting duplicates
- {
- my %seen;
-
- push @{$EXPORT_TAGS{all}},
- grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
- }
-
-CGI.pm creates an ":all" tag which contains some (but not really
-all) of its categories. That could be done with one small
-change:
-
- # add some of the other ":class" tags to the ":all" class,
- # deleting duplicates
- {
- my %seen;
-
- push @{$EXPORT_TAGS{all}},
- grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
- foreach qw/html2 html3 netscape form cgi internal/;
- }
-
-Note that the tag names in %EXPORT_TAGS don't have the leading ':'.
-
-=head2 C<AUTOLOAD>ed Constants
-
-Many modules make use of C<AUTOLOAD>ing for constant subroutines to
-avoid having to compile and waste memory on rarely used values (see
-L<perlsub> for details on constant subroutines). Calls to such
-constant subroutines are not optimized away at compile time because
-they can't be checked at compile time for constancy.
-
-Even if a prototype is available at compile time, the body of the
-subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
-examine both the C<()> prototype and the body of a subroutine at
-compile time to detect that it can safely replace calls to that
-subroutine with the constant value.
-
-A workaround for this is to call the constants once in a C<BEGIN> block:
-
- package My ;
-
- use Socket ;
-
- foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
- BEGIN { SO_LINGER }
- foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
-
-This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
-SO_LINGER is encountered later in C<My> package.
-
-If you are writing a package that C<AUTOLOAD>s, consider forcing
-an C<AUTOLOAD> for any constants explicitly imported by other packages
-or which are usually used when your package is C<use>d.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Exporter/Heavy.pm b/Master/tlpkg/installer/perllib/Exporter/Heavy.pm
deleted file mode 100644
index 2cc792288f0..00000000000
--- a/Master/tlpkg/installer/perllib/Exporter/Heavy.pm
+++ /dev/null
@@ -1,248 +0,0 @@
-package Exporter::Heavy;
-
-use strict;
-no strict 'refs';
-
-# On one line so MakeMaker will see it.
-require Exporter; our $VERSION = $Exporter::VERSION;
-$Carp::Internal{"Exporter::Heavy"} = 1;
-
-=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;
- *{"${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/installer/perllib/Fcntl.pm b/Master/tlpkg/installer/perllib/Fcntl.pm
deleted file mode 100644
index 7ef0038bd18..00000000000
--- a/Master/tlpkg/installer/perllib/Fcntl.pm
+++ /dev/null
@@ -1,236 +0,0 @@
-package Fcntl;
-
-=head1 NAME
-
-Fcntl - load the C Fcntl.h defines
-
-=head1 SYNOPSIS
-
- use Fcntl;
- use Fcntl qw(:DEFAULT :flock);
-
-=head1 DESCRIPTION
-
-This module is just a translation of the C F<fcntl.h> file.
-Unlike the old mechanism of requiring a translated F<fcntl.ph>
-file, this uses the B<h2xs> program (see the Perl source distribution)
-and your native C compiler. This means that it has a
-far more likely chance of getting the numbers right.
-
-=head1 NOTE
-
-Only C<#define> symbols get translated; you must still correctly
-pack up your own arguments to pass as args for locking functions, etc.
-
-=head1 EXPORTED SYMBOLS
-
-By default your system's F_* and O_* constants (eg, F_DUPFD and
-O_CREAT) and the FD_CLOEXEC constant are exported into your namespace.
-
-You can request that the flock() constants (LOCK_SH, LOCK_EX, LOCK_NB
-and LOCK_UN) be provided by using the tag C<:flock>. See L<Exporter>.
-
-You can request that the old constants (FAPPEND, FASYNC, FCREAT,
-FDEFER, FEXCL, FNDELAY, FNONBLOCK, FSYNC, FTRUNC) be provided for
-compatibility reasons by using the tag C<:Fcompat>. For new
-applications the newer versions of these constants are suggested
-(O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK,
-O_SYNC, O_TRUNC).
-
-For ease of use also the SEEK_* constants (for seek() and sysseek(),
-e.g. SEEK_END) and the S_I* constants (for chmod() and stat()) are
-available for import. They can be imported either separately or using
-the tags C<:seek> and C<:mode>.
-
-Please refer to your native fcntl(2), open(2), fseek(3), lseek(2)
-(equal to Perl's seek() and sysseek(), respectively), and chmod(2)
-documentation to see what constants are implemented in your system.
-
-See L<perlopentut> to learn about the uses of the O_* constants
-with sysopen().
-
-See L<perlfunc/seek> and L<perlfunc/sysseek> about the SEEK_* constants.
-
-See L<perlfunc/stat> about the S_I* constants.
-
-=cut
-
-our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD);
-
-require Exporter;
-use XSLoader ();
-@ISA = qw(Exporter);
-$VERSION = "1.05";
-# Items to export into callers namespace by default
-# (move infrequently used names to @EXPORT_OK below)
-@EXPORT =
- qw(
- FD_CLOEXEC
- F_ALLOCSP
- F_ALLOCSP64
- F_COMPAT
- F_DUP2FD
- F_DUPFD
- F_EXLCK
- F_FREESP
- F_FREESP64
- F_FSYNC
- F_FSYNC64
- F_GETFD
- F_GETFL
- F_GETLK
- F_GETLK64
- F_GETOWN
- F_NODNY
- F_POSIX
- F_RDACC
- F_RDDNY
- F_RDLCK
- F_RWACC
- F_RWDNY
- F_SETFD
- F_SETFL
- F_SETLK
- F_SETLK64
- F_SETLKW
- F_SETLKW64
- F_SETOWN
- F_SHARE
- F_SHLCK
- F_UNLCK
- F_UNSHARE
- F_WRACC
- F_WRDNY
- F_WRLCK
- O_ACCMODE
- O_ALIAS
- O_APPEND
- O_ASYNC
- O_BINARY
- O_CREAT
- O_DEFER
- O_DIRECT
- O_DIRECTORY
- O_DSYNC
- O_EXCL
- O_EXLOCK
- O_LARGEFILE
- O_NDELAY
- O_NOCTTY
- O_NOFOLLOW
- O_NOINHERIT
- O_NONBLOCK
- O_RANDOM
- O_RAW
- O_RDONLY
- O_RDWR
- O_RSRC
- O_RSYNC
- O_SEQUENTIAL
- O_SHLOCK
- O_SYNC
- O_TEMPORARY
- O_TEXT
- O_TRUNC
- O_WRONLY
- );
-
-# Other items we are prepared to export if requested
-@EXPORT_OK = qw(
- DN_ACCESS
- DN_ATTRIB
- DN_CREATE
- DN_DELETE
- DN_MODIFY
- DN_MULTISHOT
- DN_RENAME
- FAPPEND
- FASYNC
- FCREAT
- FDEFER
- FDSYNC
- FEXCL
- FLARGEFILE
- FNDELAY
- FNONBLOCK
- FRSYNC
- FSYNC
- FTRUNC
- F_GETLEASE
- F_GETSIG
- F_NOTIFY
- F_SETLEASE
- F_SETSIG
- LOCK_EX
- LOCK_MAND
- LOCK_NB
- LOCK_READ
- LOCK_RW
- LOCK_SH
- LOCK_UN
- LOCK_WRITE
- O_IGNORE_CTTY
- O_NOATIME
- O_NOLINK
- O_NOTRANS
- SEEK_CUR
- SEEK_END
- SEEK_SET
- S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT
- S_IREAD S_IWRITE S_IEXEC
- S_IRGRP S_IWGRP S_IXGRP S_IRWXG
- S_IROTH S_IWOTH S_IXOTH S_IRWXO
- S_IRUSR S_IWUSR S_IXUSR S_IRWXU
- S_ISUID S_ISGID S_ISVTX S_ISTXT
- _S_IFMT S_IFREG S_IFDIR S_IFLNK
- &S_ISREG &S_ISDIR &S_ISLNK &S_ISSOCK &S_ISBLK &S_ISCHR &S_ISFIFO
- &S_ISWHT &S_ISENFMT &S_IFMT &S_IMODE
-);
-# Named groups of exports
-%EXPORT_TAGS = (
- 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)],
- 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FEXCL FLARGEFILE
- FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC)],
- 'seek' => [qw(SEEK_SET SEEK_CUR SEEK_END)],
- 'mode' => [qw(S_ISUID S_ISGID S_ISVTX S_ISTXT
- _S_IFMT S_IFREG S_IFDIR S_IFLNK
- S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT
- S_IRUSR S_IWUSR S_IXUSR S_IRWXU
- S_IRGRP S_IWGRP S_IXGRP S_IRWXG
- S_IROTH S_IWOTH S_IXOTH S_IRWXO
- S_IREAD S_IWRITE S_IEXEC
- S_ISREG S_ISDIR S_ISLNK S_ISSOCK
- S_ISBLK S_ISCHR S_ISFIFO
- S_ISWHT S_ISENFMT
- S_IFMT S_IMODE
- )],
-);
-
-sub S_IFMT { @_ ? ( $_[0] & _S_IFMT() ) : _S_IFMT() }
-sub S_IMODE { $_[0] & 07777 }
-
-sub S_ISREG { ( $_[0] & _S_IFMT() ) == S_IFREG() }
-sub S_ISDIR { ( $_[0] & _S_IFMT() ) == S_IFDIR() }
-sub S_ISLNK { ( $_[0] & _S_IFMT() ) == S_IFLNK() }
-sub S_ISSOCK { ( $_[0] & _S_IFMT() ) == S_IFSOCK() }
-sub S_ISBLK { ( $_[0] & _S_IFMT() ) == S_IFBLK() }
-sub S_ISCHR { ( $_[0] & _S_IFMT() ) == S_IFCHR() }
-sub S_ISFIFO { ( $_[0] & _S_IFMT() ) == S_IFIFO() }
-sub S_ISWHT { ( $_[0] & _S_IFMT() ) == S_IFWHT() }
-sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() }
-
-sub AUTOLOAD {
- (my $constname = $AUTOLOAD) =~ s/.*:://;
- die "&Fcntl::constant not defined" if $constname eq 'constant';
- my ($error, $val) = constant($constname);
- if ($error) {
- my (undef,$file,$line) = caller;
- die "$error at $file line $line.\n";
- }
- *$AUTOLOAD = sub { $val };
- goto &$AUTOLOAD;
-}
-
-XSLoader::load 'Fcntl', $VERSION;
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Basename.pm b/Master/tlpkg/installer/perllib/File/Basename.pm
deleted file mode 100644
index 837b753972a..00000000000
--- a/Master/tlpkg/installer/perllib/File/Basename.pm
+++ /dev/null
@@ -1,398 +0,0 @@
-=head1 NAME
-
-File::Basename - Parse file paths into directory, filename and suffix.
-
-=head1 SYNOPSIS
-
- use File::Basename;
-
- ($name,$path,$suffix) = fileparse($fullname,@suffixlist);
- $name = fileparse($fullname,@suffixlist);
-
- $basename = basename($fullname,@suffixlist);
- $dirname = dirname($fullname);
-
-
-=head1 DESCRIPTION
-
-These routines allow you to parse file paths into their directory, filename
-and suffix.
-
-B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and
-quirks, of the shell and C functions of the same name. See each
-function's documentation for details. If your concern is just parsing
-paths it is safer to use L<File::Spec>'s C<splitpath()> and
-C<splitdir()> methods.
-
-It is guaranteed that
-
- # Where $path_separator is / for Unix, \ for Windows, etc...
- dirname($path) . $path_separator . basename($path);
-
-is equivalent to the original path for all systems but VMS.
-
-
-=cut
-
-
-package File::Basename;
-
-# A bit of juggling to insure that C<use re 'taint';> always works, since
-# File::Basename is used during the Perl build, when the re extension may
-# not be available.
-BEGIN {
- unless (eval { require re; })
- { eval ' sub re::import { $^H |= 0x00100000; } ' } # HINT_RE_TAINT
- import re 'taint';
-}
-
-
-use strict;
-use 5.006;
-use warnings;
-our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
-$VERSION = "2.74";
-
-fileparse_set_fstype($^O);
-
-
-=over 4
-
-=item C<fileparse>
-
- my($filename, $directories, $suffix) = fileparse($path);
- my($filename, $directories, $suffix) = fileparse($path, @suffixes);
- my $filename = fileparse($path, @suffixes);
-
-The C<fileparse()> routine divides a file path into its $directories, $filename
-and (optionally) the filename $suffix.
-
-$directories contains everything up to and including the last
-directory separator in the $path including the volume (if applicable).
-The remainder of the $path is the $filename.
-
- # On Unix returns ("baz", "/foo/bar/", "")
- fileparse("/foo/bar/baz");
-
- # On Windows returns ("baz", "C:\foo\bar\", "")
- fileparse("C:\foo\bar\baz");
-
- # On Unix returns ("", "/foo/bar/baz/", "")
- fileparse("/foo/bar/baz/");
-
-If @suffixes are given each element is a pattern (either a string or a
-C<qr//>) matched against the end of the $filename. The matching
-portion is removed and becomes the $suffix.
-
- # On Unix returns ("baz", "/foo/bar", ".txt")
- fileparse("/foo/bar/baz", qr/\.[^.]*/);
-
-If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern
-matching for suffix removal is performed case-insensitively, since
-those systems are not case-sensitive when opening existing files.
-
-You are guaranteed that C<$directories . $filename . $suffix> will
-denote the same location as the original $path.
-
-=cut
-
-
-sub fileparse {
- my($fullname,@suffices) = @_;
-
- unless (defined $fullname) {
- require Carp;
- Carp::croak("fileparse(): need a valid pathname");
- }
-
- my $orig_type = '';
- my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
-
- my($taint) = substr($fullname,0,0); # Is $fullname tainted?
-
- if ($type eq "VMS" and $fullname =~ m{/} ) {
- # We're doing Unix emulation
- $orig_type = $type;
- $type = 'Unix';
- }
-
- my($dirpath, $basename);
-
- if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
- ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
- $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
- }
- elsif ($type eq "OS2") {
- ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
- $dirpath = './' unless $dirpath; # Can't be 0
- $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
- }
- elsif ($type eq "MacOS") {
- ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
- $dirpath = ':' unless $dirpath;
- }
- elsif ($type eq "AmigaOS") {
- ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
- $dirpath = './' unless $dirpath;
- }
- elsif ($type eq 'VMS' ) {
- ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
- $dirpath ||= ''; # should always be defined
- }
- else { # Default to Unix semantics.
- ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s);
- if ($orig_type eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) {
- # dev:[000000] is top of VMS tree, similar to Unix '/'
- # so strip it off and treat the rest as "normal"
- my $devspec = $1;
- my $remainder = $3;
- ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s);
- $dirpath ||= ''; # should always be defined
- $dirpath = $devspec.$dirpath;
- }
- $dirpath = './' unless $dirpath;
- }
-
-
- my $tail = '';
- my $suffix = '';
- if (@suffices) {
- foreach $suffix (@suffices) {
- my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
- if ($basename =~ s/$pat//s) {
- $taint .= substr($suffix,0,0);
- $tail = $1 . $tail;
- }
- }
- }
-
- # Ensure taint is propgated from the path to its pieces.
- $tail .= $taint;
- wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
- : ($basename .= $taint);
-}
-
-
-
-=item C<basename>
-
- my $filename = basename($path);
- my $filename = basename($path, @suffixes);
-
-This function is provided for compatibility with the Unix shell command
-C<basename(1)>. It does B<NOT> always return the file name portion of a
-path as you might expect. To be safe, if you want the file name portion of
-a path use C<fileparse()>.
-
-C<basename()> returns the last level of a filepath even if the last
-level is clearly directory. In effect, it is acting like C<pop()> for
-paths. This differs from C<fileparse()>'s behaviour.
-
- # Both return "bar"
- basename("/foo/bar");
- basename("/foo/bar/");
-
-@suffixes work as in C<fileparse()> except all regex metacharacters are
-quoted.
-
- # These two function calls are equivalent.
- my $filename = basename("/foo/bar/baz.txt", ".txt");
- my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/);
-
-Also note that in order to be compatible with the shell command,
-C<basename()> does not strip off a suffix if it is identical to the
-remaining characters in the filename.
-
-=cut
-
-
-sub basename {
- my($path) = shift;
-
- # From BSD basename(1)
- # The basename utility deletes any prefix ending with the last slash `/'
- # character present in string (after first stripping trailing slashes)
- _strip_trailing_sep($path);
-
- my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
-
- # From BSD basename(1)
- # The suffix is not stripped if it is identical to the remaining
- # characters in string.
- if( length $suffix and !length $basename ) {
- $basename = $suffix;
- }
-
- # Ensure that basename '/' == '/'
- if( !length $basename ) {
- $basename = $dirname;
- }
-
- return $basename;
-}
-
-
-
-=item C<dirname>
-
-This function is provided for compatibility with the Unix shell
-command C<dirname(1)> and has inherited some of its quirks. In spite of
-its name it does B<NOT> always return the directory name as you might
-expect. To be safe, if you want the directory name of a path use
-C<fileparse()>.
-
-Only on VMS (where there is no ambiguity between the file and directory
-portions of a path) and AmigaOS (possibly due to an implementation quirk in
-this module) does C<dirname()> work like C<fileparse($path)>, returning just the
-$directories.
-
- # On VMS and AmigaOS
- my $directories = dirname($path);
-
-When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function
-which is subtly different from how C<fileparse()> works. It returns all but
-the last level of a file path even if the last level is clearly a directory.
-In effect, it is not returning the directory portion but simply the path one
-level up acting like C<chop()> for file paths.
-
-Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on
-its returned path.
-
- # returns /foo/bar. fileparse() would return /foo/bar/
- dirname("/foo/bar/baz");
-
- # also returns /foo/bar despite the fact that baz is clearly a
- # directory. fileparse() would return /foo/bar/baz/
- dirname("/foo/bar/baz/");
-
- # returns '.'. fileparse() would return 'foo/'
- dirname("foo/");
-
-Under VMS, if there is no directory information in the $path, then the
-current default device and directory is used.
-
-=cut
-
-
-sub dirname {
- my $path = shift;
-
- my($type) = $Fileparse_fstype;
-
- if( $type eq 'VMS' and $path =~ m{/} ) {
- # Parse as Unix
- local($File::Basename::Fileparse_fstype) = '';
- return dirname($path);
- }
-
- my($basename, $dirname) = fileparse($path);
-
- if ($type eq 'VMS') {
- $dirname ||= $ENV{DEFAULT};
- }
- elsif ($type eq 'MacOS') {
- if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
- _strip_trailing_sep($dirname);
- ($basename,$dirname) = fileparse $dirname;
- }
- $dirname .= ":" unless $dirname =~ /:\z/;
- }
- elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
- _strip_trailing_sep($dirname);
- unless( length($basename) ) {
- ($basename,$dirname) = fileparse $dirname;
- _strip_trailing_sep($dirname);
- }
- }
- elsif ($type eq 'AmigaOS') {
- if ( $dirname =~ /:\z/) { return $dirname }
- chop $dirname;
- $dirname =~ s#[^:/]+\z## unless length($basename);
- }
- else {
- _strip_trailing_sep($dirname);
- unless( length($basename) ) {
- ($basename,$dirname) = fileparse $dirname;
- _strip_trailing_sep($dirname);
- }
- }
-
- $dirname;
-}
-
-
-# Strip the trailing path separator.
-sub _strip_trailing_sep {
- my $type = $Fileparse_fstype;
-
- if ($type eq 'MacOS') {
- $_[0] =~ s/([^:]):\z/$1/s;
- }
- elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
- $_[0] =~ s/([^:])[\\\/]*\z/$1/;
- }
- else {
- $_[0] =~ s{(.)/*\z}{$1}s;
- }
-}
-
-
-=item C<fileparse_set_fstype>
-
- my $type = fileparse_set_fstype();
- my $previous_type = fileparse_set_fstype($type);
-
-Normally File::Basename will assume a file path type native to your current
-operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...).
-With this function you can override that assumption.
-
-Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS",
-"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility),
-"Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is
-given "Unix" will be assumed.
-
-If you've selected VMS syntax, and the file specification you pass to
-one of these routines contains a "/", they assume you are using Unix
-emulation and apply the Unix syntax rules instead, for that function
-call only.
-
-=back
-
-=cut
-
-
-BEGIN {
-
-my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
-my @Types = (@Ignore_Case, qw(Unix));
-
-sub fileparse_set_fstype {
- my $old = $Fileparse_fstype;
-
- if (@_) {
- my $new_type = shift;
-
- $Fileparse_fstype = 'Unix'; # default
- foreach my $type (@Types) {
- $Fileparse_fstype = $type if $new_type =~ /^$type/i;
- }
-
- $Fileparse_igncase =
- (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
- }
-
- return $old;
-}
-
-}
-
-
-1;
-
-
-=head1 SEE ALSO
-
-L<dirname(1)>, L<basename(1)>, L<File::Spec>
diff --git a/Master/tlpkg/installer/perllib/File/CheckTree.pm b/Master/tlpkg/installer/perllib/File/CheckTree.pm
deleted file mode 100644
index 20ffd68124d..00000000000
--- a/Master/tlpkg/installer/perllib/File/CheckTree.pm
+++ /dev/null
@@ -1,229 +0,0 @@
-package File::CheckTree;
-
-use 5.006;
-use Cwd;
-use Exporter;
-use File::Spec;
-use warnings;
-use strict;
-
-our $VERSION = '4.3';
-our @ISA = qw(Exporter);
-our @EXPORT = qw(validate);
-
-=head1 NAME
-
-validate - run many filetest checks on a tree
-
-=head1 SYNOPSIS
-
- use File::CheckTree;
-
- $num_warnings = validate( q{
- /vmunix -e || die
- /boot -e || die
- /bin cd
- csh -ex
- csh !-ug
- sh -ex
- sh !-ug
- /usr -d || warn "What happened to $file?\n"
- });
-
-=head1 DESCRIPTION
-
-The validate() routine takes a single multiline string consisting of
-directives, each containing a filename plus a file test to try on it.
-(The file test may also be a "cd", causing subsequent relative filenames
-to be interpreted relative to that directory.) After the file test
-you may put C<|| die> to make it a fatal error if the file test fails.
-The default is C<|| warn>. The file test may optionally have a "!' prepended
-to test for the opposite condition. If you do a cd and then list some
-relative filenames, you may want to indent them slightly for readability.
-If you supply your own die() or warn() message, you can use $file to
-interpolate the filename.
-
-Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
-Only the first failed test of the bunch will produce a warning.
-
-The routine returns the number of warnings issued.
-
-=head1 AUTHOR
-
-File::CheckTree was derived from lib/validate.pl which was
-written by Larry Wall.
-Revised by Paul Grassie <F<grassie@perl.com>> in 2002.
-
-=head1 HISTORY
-
-File::CheckTree used to not display fatal error messages.
-It used to count only those warnings produced by a generic C<|| warn>
-(and not those in which the user supplied the message). In addition,
-the validate() routine would leave the user program in whatever
-directory was last entered through the use of "cd" directives.
-These bugs were fixed during the development of perl 5.8.
-The first fixed version of File::CheckTree was 4.2.
-
-=cut
-
-my $Warnings;
-
-sub validate {
- my ($starting_dir, $file, $test, $cwd, $oldwarnings);
-
- $starting_dir = cwd;
-
- $cwd = "";
- $Warnings = 0;
-
- foreach my $check (split /\n/, $_[0]) {
- my ($testlist, @testlist);
-
- # skip blanks/comments
- next if $check =~ /^\s*#/ || $check =~ /^\s*$/;
-
- # Todo:
- # should probably check for invalid directives and die
- # but earlier versions of File::CheckTree did not do this either
-
- # split a line like "/foo -r || die"
- # so that $file is "/foo", $test is "-rwx || die"
- ($file, $test) = split(' ', $check, 2); # special whitespace split
-
- # change a $test like "!-ug || die" to "!-Z || die",
- # capturing the bundled tests (e.g. "ug") in $2
- if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
- $testlist = $2;
- # split bundled tests, e.g. "ug" to 'u', 'g'
- @testlist = split(//, $testlist);
- }
- else {
- # put in placeholder Z for stand-alone test
- @testlist = ('Z');
- }
-
- # will compare these two later to stop on 1st warning w/in a bundle
- $oldwarnings = $Warnings;
-
- foreach my $one (@testlist) {
- # examples of $test: "!-Z || die" or "-w || warn"
- my $this = $test;
-
- # expand relative $file to full pathname if preceded by cd directive
- $file = File::Spec->catfile($cwd, $file)
- if $cwd && !File::Spec->file_name_is_absolute($file);
-
- # put filename in after the test operator
- $this =~ s/(-\w\b)/$1 "\$file"/g;
-
- # change the "-Z" representing a bundle with the $one test
- $this =~ s/-Z/-$one/;
-
- # if it's a "cd" directive...
- if ($this =~ /^cd\b/) {
- # add "|| die ..."
- $this .= ' || die "cannot cd to $file\n"';
- # expand "cd" directive with directory name
- $this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
- }
- else {
- # add "|| warn" as a default disposition
- $this .= ' || warn' unless $this =~ /\|\|/;
-
- # change a generic ".. || die" or ".. || warn"
- # to call valmess instead of die/warn directly
- # valmess will look up the error message from %Val_Message
- $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
- /$1 || valmess('$3', '$2', \$file)/x;
- }
-
- {
- # count warnings, either from valmess or '-r || warn "my msg"'
- # also, call any pre-existing signal handler for __WARN__
- my $orig_sigwarn = $SIG{__WARN__};
- local $SIG{__WARN__} = sub {
- ++$Warnings;
- if ( $orig_sigwarn ) {
- $orig_sigwarn->(@_);
- }
- else {
- warn "@_";
- }
- };
-
- # do the test
- eval $this;
-
- # re-raise an exception caused by a "... || die" test
- if ($@) {
- # in case of any cd directives, return from whence we came
- if ($starting_dir ne cwd) {
- chdir($starting_dir) || die "$starting_dir: $!";
- }
- die $@ if $@;
- }
- }
-
- # stop on 1st warning within a bundle of tests
- last if $Warnings > $oldwarnings;
- }
- }
-
- # in case of any cd directives, return from whence we came
- if ($starting_dir ne cwd) {
- chdir($starting_dir) || die "chdir $starting_dir: $!";
- }
-
- return $Warnings;
-}
-
-my %Val_Message = (
- 'r' => "is not readable by uid $>.",
- 'w' => "is not writable by uid $>.",
- 'x' => "is not executable by uid $>.",
- 'o' => "is not owned by uid $>.",
- 'R' => "is not readable by you.",
- 'W' => "is not writable by you.",
- 'X' => "is not executable by you.",
- 'O' => "is not owned by you.",
- 'e' => "does not exist.",
- 'z' => "does not have zero size.",
- 's' => "does not have non-zero size.",
- 'f' => "is not a plain file.",
- 'd' => "is not a directory.",
- 'l' => "is not a symbolic link.",
- 'p' => "is not a named pipe (FIFO).",
- 'S' => "is not a socket.",
- 'b' => "is not a block special file.",
- 'c' => "is not a character special file.",
- 'u' => "does not have the setuid bit set.",
- 'g' => "does not have the setgid bit set.",
- 'k' => "does not have the sticky bit set.",
- 'T' => "is not a text file.",
- 'B' => "is not a binary file."
-);
-
-sub valmess {
- my ($disposition, $test, $file) = @_;
- my $ferror;
-
- if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
- my ($neg, $ftype) = ($1, $2);
-
- $ferror = "$file $Val_Message{$ftype}";
-
- if ($neg eq '!') {
- $ferror =~ s/ is not / should not be / ||
- $ferror =~ s/ does not / should not / ||
- $ferror =~ s/ not / /;
- }
- }
- else {
- $ferror = "Can't do $test $file.\n";
- }
-
- die "$ferror\n" if $disposition eq 'die';
- warn "$ferror\n";
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Compare.pm b/Master/tlpkg/installer/perllib/File/Compare.pm
deleted file mode 100644
index 0b73d7c7657..00000000000
--- a/Master/tlpkg/installer/perllib/File/Compare.pm
+++ /dev/null
@@ -1,178 +0,0 @@
-package File::Compare;
-
-use 5.006;
-use strict;
-use warnings;
-our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big);
-
-require Exporter;
-use Carp;
-
-$VERSION = '1.1003';
-@ISA = qw(Exporter);
-@EXPORT = qw(compare);
-@EXPORT_OK = qw(cmp compare_text);
-
-$Too_Big = 1024 * 1024 * 2;
-
-sub compare {
- croak("Usage: compare( file1, file2 [, buffersize]) ")
- unless(@_ == 2 || @_ == 3);
-
- my ($from,$to,$size) = @_;
- my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0);
-
- my ($fromsize,$closefrom,$closeto);
- local (*FROM, *TO);
-
- croak("from undefined") unless (defined $from);
- croak("to undefined") unless (defined $to);
-
- if (ref($from) &&
- (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
- *FROM = *$from;
- } elsif (ref(\$from) eq 'GLOB') {
- *FROM = $from;
- } else {
- open(FROM,"<$from") or goto fail_open1;
- unless ($text_mode) {
- binmode FROM;
- $fromsize = -s FROM;
- }
- $closefrom = 1;
- }
-
- if (ref($to) &&
- (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) {
- *TO = *$to;
- } elsif (ref(\$to) eq 'GLOB') {
- *TO = $to;
- } else {
- open(TO,"<$to") or goto fail_open2;
- binmode TO unless $text_mode;
- $closeto = 1;
- }
-
- if (!$text_mode && $closefrom && $closeto) {
- # If both are opened files we know they differ if their size differ
- goto fail_inner if $fromsize != -s TO;
- }
-
- if ($text_mode) {
- local $/ = "\n";
- my ($fline,$tline);
- while (defined($fline = <FROM>)) {
- goto fail_inner unless defined($tline = <TO>);
- if (ref $size) {
- # $size contains ref to comparison function
- goto fail_inner if &$size($fline, $tline);
- } else {
- goto fail_inner if $fline ne $tline;
- }
- }
- goto fail_inner if defined($tline = <TO>);
- }
- else {
- unless (defined($size) && $size > 0) {
- $size = $fromsize || -s TO || 0;
- $size = 1024 if $size < 512;
- $size = $Too_Big if $size > $Too_Big;
- }
-
- my ($fr,$tr,$fbuf,$tbuf);
- $fbuf = $tbuf = '';
- while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
- unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) {
- goto fail_inner;
- }
- }
- goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0;
- }
-
- close(TO) || goto fail_open2 if $closeto;
- close(FROM) || goto fail_open1 if $closefrom;
-
- return 0;
-
- # All of these contortions try to preserve error messages...
- fail_inner:
- close(TO) || goto fail_open2 if $closeto;
- close(FROM) || goto fail_open1 if $closefrom;
-
- return 1;
-
- fail_open2:
- if ($closefrom) {
- my $status = $!;
- $! = 0;
- close FROM;
- $! = $status unless $!;
- }
- fail_open1:
- return -1;
-}
-
-sub cmp;
-*cmp = \&compare;
-
-sub compare_text {
- my ($from,$to,$cmp) = @_;
- croak("Usage: compare_text( file1, file2 [, cmp-function])")
- unless @_ == 2 || @_ == 3;
- croak("Third arg to compare_text() function must be a code reference")
- if @_ == 3 && ref($cmp) ne 'CODE';
-
- # Using a negative buffer size puts compare into text_mode too
- $cmp = -1 unless defined $cmp;
- compare($from, $to, $cmp);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-File::Compare - Compare files or filehandles
-
-=head1 SYNOPSIS
-
- use File::Compare;
-
- if (compare("file1","file2") == 0) {
- print "They're equal\n";
- }
-
-=head1 DESCRIPTION
-
-The File::Compare::compare function compares the contents of two
-sources, each of which can be a file or a file handle. It is exported
-from File::Compare by default.
-
-File::Compare::cmp is a synonym for File::Compare::compare. It is
-exported from File::Compare only by request.
-
-File::Compare::compare_text does a line by line comparison of the two
-files. It stops as soon as a difference is detected. compare_text()
-accepts an optional third argument: This must be a CODE reference to
-a line comparison function, which returns 0 when both lines are considered
-equal. For example:
-
- compare_text($file1, $file2)
-
-is basically equivalent to
-
- compare_text($file1, $file2, sub {$_[0] ne $_[1]} )
-
-=head1 RETURN
-
-File::Compare::compare and its sibling functions return 0 if the files
-are equal, 1 if the files are unequal, or -1 if an error was encountered.
-
-=head1 AUTHOR
-
-File::Compare was written by Nick Ing-Simmons.
-Its original documentation was written by Chip Salzenberg.
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/File/Copy.pm b/Master/tlpkg/installer/perllib/File/Copy.pm
deleted file mode 100644
index 52ba7c6d81a..00000000000
--- a/Master/tlpkg/installer/perllib/File/Copy.pm
+++ /dev/null
@@ -1,459 +0,0 @@
-# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
-# source code has been placed in the public domain by the author.
-# Please be kind and preserve the documentation.
-#
-# Additions copyright 1996 by Charles Bailey. Permission is granted
-# to distribute the revised code under the same terms as Perl itself.
-
-package File::Copy;
-
-use 5.006;
-use strict;
-use warnings;
-use Carp;
-use File::Spec;
-use Config;
-our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
-sub copy;
-sub syscopy;
-sub cp;
-sub mv;
-
-# Note that this module implements only *part* of the API defined by
-# the File/Copy.pm module of the File-Tools-2.0 package. However, that
-# package has not yet been updated to work with Perl 5.004, and so it
-# would be a Bad Thing for the CPAN module to grab it and replace this
-# module. Therefore, we set this module's version higher than 2.0.
-$VERSION = '2.09';
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(copy move);
-@EXPORT_OK = qw(cp mv);
-
-$Too_Big = 1024 * 1024 * 2;
-
-my $macfiles;
-if ($^O eq 'MacOS') {
- $macfiles = eval { require Mac::MoreFiles };
- warn 'Mac::MoreFiles could not be loaded; using non-native syscopy'
- if $@ && $^W;
-}
-
-sub _catname {
- my($from, $to) = @_;
- if (not defined &basename) {
- require File::Basename;
- import File::Basename 'basename';
- }
-
- if ($^O eq 'MacOS') {
- # a partial dir name that's valid only in the cwd (e.g. 'tmp')
- $to = ':' . $to if $to !~ /:/;
- }
-
- return File::Spec->catfile($to, basename($from));
-}
-
-sub copy {
- croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
- unless(@_ == 2 || @_ == 3);
-
- my $from = shift;
- my $to = shift;
-
- my $from_a_handle = (ref($from)
- ? (ref($from) eq 'GLOB'
- || UNIVERSAL::isa($from, 'GLOB')
- || UNIVERSAL::isa($from, 'IO::Handle'))
- : (ref(\$from) eq 'GLOB'));
- my $to_a_handle = (ref($to)
- ? (ref($to) eq 'GLOB'
- || UNIVERSAL::isa($to, 'GLOB')
- || UNIVERSAL::isa($to, 'IO::Handle'))
- : (ref(\$to) eq 'GLOB'));
-
- if ($from eq $to) { # works for references, too
- carp("'$from' and '$to' are identical (not copied)");
- # The "copy" was a success as the source and destination contain
- # the same data.
- return 1;
- }
-
- if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
- !($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'vms')) {
- my @fs = stat($from);
- if (@fs) {
- my @ts = stat($to);
- if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) {
- carp("'$from' and '$to' are identical (not copied)");
- return 0;
- }
- }
- }
-
- if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
- $to = _catname($from, $to);
- }
-
- if (defined &syscopy && !$Syscopy_is_copy
- && !$to_a_handle
- && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles
- && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX.
- && !($from_a_handle && $^O eq 'MSWin32')
- && !($from_a_handle && $^O eq 'MacOS')
- && !($from_a_handle && $^O eq 'NetWare')
- )
- {
- return syscopy($from, $to);
- }
-
- my $closefrom = 0;
- my $closeto = 0;
- my ($size, $status, $r, $buf);
- local($\) = '';
-
- my $from_h;
- if ($from_a_handle) {
- $from_h = $from;
- } else {
- $from = _protect($from) if $from =~ /^\s/s;
- $from_h = \do { local *FH };
- open($from_h, "< $from\0") or goto fail_open1;
- binmode $from_h or die "($!,$^E)";
- $closefrom = 1;
- }
-
- my $to_h;
- if ($to_a_handle) {
- $to_h = $to;
- } else {
- $to = _protect($to) if $to =~ /^\s/s;
- $to_h = \do { local *FH };
- open($to_h,"> $to\0") or goto fail_open2;
- binmode $to_h or die "($!,$^E)";
- $closeto = 1;
- }
-
- if (@_) {
- $size = shift(@_) + 0;
- croak("Bad buffer size for copy: $size\n") unless ($size > 0);
- } else {
- $size = tied(*$from_h) ? 0 : -s $from_h || 0;
- $size = 1024 if ($size < 512);
- $size = $Too_Big if ($size > $Too_Big);
- }
-
- $! = 0;
- for (;;) {
- my ($r, $w, $t);
- defined($r = sysread($from_h, $buf, $size))
- or goto fail_inner;
- last unless $r;
- for ($w = 0; $w < $r; $w += $t) {
- $t = syswrite($to_h, $buf, $r - $w, $w)
- or goto fail_inner;
- }
- }
-
- close($to_h) || goto fail_open2 if $closeto;
- close($from_h) || goto fail_open1 if $closefrom;
-
- # Use this idiom to avoid uninitialized value warning.
- return 1;
-
- # All of these contortions try to preserve error messages...
- fail_inner:
- if ($closeto) {
- $status = $!;
- $! = 0;
- close $to_h;
- $! = $status unless $!;
- }
- fail_open2:
- if ($closefrom) {
- $status = $!;
- $! = 0;
- close $from_h;
- $! = $status unless $!;
- }
- fail_open1:
- return 0;
-}
-
-sub move {
- croak("Usage: move(FROM, TO) ") unless @_ == 2;
-
- my($from,$to) = @_;
-
- my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
-
- if (-d $to && ! -d $from) {
- $to = _catname($from, $to);
- }
-
- ($tosz1,$tomt1) = (stat($to))[7,9];
- $fromsz = -s $from;
- if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
- # will not rename with overwrite
- unlink $to;
- }
- return 1 if rename $from, $to;
-
- # Did rename return an error even though it succeeded, because $to
- # is on a remote NFS file system, and NFS lost the server's ack?
- return 1 if defined($fromsz) && !-e $from && # $from disappeared
- (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
- ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed
- $tosz2 == $fromsz; # it's all there
-
- ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
-
- {
- local $@;
- eval {
- local $SIG{__DIE__};
- copy($from,$to) or die;
- my($atime, $mtime) = (stat($from))[8,9];
- utime($atime, $mtime, $to);
- unlink($from) or die;
- };
- return 1 unless $@;
- }
- ($sts,$ossts) = ($! + 0, $^E + 0);
-
- ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
- unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
- ($!,$^E) = ($sts,$ossts);
- return 0;
-}
-
-*cp = \&copy;
-*mv = \&move;
-
-
-if ($^O eq 'MacOS') {
- *_protect = sub { MacPerl::MakeFSSpec($_[0]) };
-} else {
- *_protect = sub { "./$_[0]" };
-}
-
-# &syscopy is an XSUB under OS/2
-unless (defined &syscopy) {
- if ($^O eq 'VMS') {
- *syscopy = \&rmscopy;
- } elsif ($^O eq 'mpeix') {
- *syscopy = sub {
- return 0 unless @_ == 2;
- # Use the MPE cp program in order to
- # preserve MPE file attributes.
- return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
- };
- } elsif ($^O eq 'MSWin32') {
- *syscopy = sub {
- return 0 unless @_ == 2;
- return Win32::CopyFile(@_, 1);
- };
- } elsif ($macfiles) {
- *syscopy = sub {
- my($from, $to) = @_;
- my($dir, $toname);
-
- return 0 unless -e $from;
-
- if ($to =~ /(.*:)([^:]+):?$/) {
- ($dir, $toname) = ($1, $2);
- } else {
- ($dir, $toname) = (":", $to);
- }
-
- unlink($to);
- Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1);
- };
- } else {
- $Syscopy_is_copy = 1;
- *syscopy = \&copy;
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-File::Copy - Copy files or filehandles
-
-=head1 SYNOPSIS
-
- use File::Copy;
-
- copy("file1","file2") or die "Copy failed: $!";
- copy("Copy.pm",\*STDOUT);
- move("/dev1/fileA","/dev2/fileB");
-
- use File::Copy "cp";
-
- $n = FileHandle->new("/a/file","r");
- cp($n,"x");
-
-=head1 DESCRIPTION
-
-The File::Copy module provides two basic functions, C<copy> and
-C<move>, which are useful for getting the contents of a file from
-one place to another.
-
-=over 4
-
-=item *
-
-The C<copy> function takes two
-parameters: a file to copy from and a file to copy to. Either
-argument may be a string, a FileHandle reference or a FileHandle
-glob. Obviously, if the first argument is a filehandle of some
-sort, it will be read from, and if it is a file I<name> it will
-be opened for reading. Likewise, the second argument will be
-written to (and created if need be). Trying to copy a file on top
-of itself is a fatal error.
-
-B<Note that passing in
-files as handles instead of names may lead to loss of information
-on some operating systems; it is recommended that you use file
-names whenever possible.> Files are opened in binary mode where
-applicable. To get a consistent behaviour when copying from a
-filehandle to a file, use C<binmode> on the filehandle.
-
-An optional third parameter can be used to specify the buffer
-size used for copying. This is the number of bytes from the
-first file, that wil be held in memory at any given time, before
-being written to the second file. The default buffer size depends
-upon the file, but will generally be the whole file (up to 2Mb), or
-1k for filehandles that do not reference files (eg. sockets).
-
-You may use the syntax C<use File::Copy "cp"> to get at the
-"cp" alias for this function. The syntax is I<exactly> the same.
-
-=item *
-
-The C<move> function also takes two parameters: the current name
-and the intended name of the file to be moved. If the destination
-already exists and is a directory, and the source is not a
-directory, then the source file will be renamed into the directory
-specified by the destination.
-
-If possible, move() will simply rename the file. Otherwise, it copies
-the file to the new location and deletes the original. If an error occurs
-during this copy-and-delete process, you may be left with a (possibly partial)
-copy of the file under the destination name.
-
-You may use the "mv" alias for this function in the same way that
-you may use the "cp" alias for C<copy>.
-
-=back
-
-File::Copy also provides the C<syscopy> routine, which copies the
-file specified in the first parameter to the file specified in the
-second parameter, preserving OS-specific attributes and file
-structure. For Unix systems, this is equivalent to the simple
-C<copy> routine, which doesn't preserve OS-specific attributes. For
-VMS systems, this calls the C<rmscopy> routine (see below). For OS/2
-systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
-this calls C<Win32::CopyFile>.
-
-On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
-if available.
-
-=head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)
-
-If both arguments to C<copy> are not file handles,
-then C<copy> will perform a "system copy" of
-the input file to a new output file, in order to preserve file
-attributes, indexed file structure, I<etc.> The buffer size
-parameter is ignored. If either argument to C<copy> is a
-handle to an opened file, then data is copied using Perl
-operators, and no effort is made to preserve file attributes
-or record structure.
-
-The system copy routine may also be called directly under VMS and OS/2
-as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
-is the routine that does the actual work for syscopy).
-
-=over 4
-
-=item rmscopy($from,$to[,$date_flag])
-
-The first and second arguments may be strings, typeglobs, typeglob
-references, or objects inheriting from IO::Handle;
-they are used in all cases to obtain the
-I<filespec> of the input and output files, respectively. The
-name and type of the input file are used as defaults for the
-output file, if necessary.
-
-A new version of the output file is always created, which
-inherits the structure and RMS attributes of the input file,
-except for owner and protections (and possibly timestamps;
-see below). All data from the input file is copied to the
-output file; if either of the first two parameters to C<rmscopy>
-is a file handle, its position is unchanged. (Note that this
-means a file handle pointing to the output file will be
-associated with an old version of that file after C<rmscopy>
-returns, not the newly created version.)
-
-The third parameter is an integer flag, which tells C<rmscopy>
-how to handle timestamps. If it is E<lt> 0, none of the input file's
-timestamps are propagated to the output file. If it is E<gt> 0, then
-it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
-timestamps other than the revision date are propagated; if bit 1
-is set, the revision date is propagated. If the third parameter
-to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
-if the name or type of the output file was explicitly specified,
-then no timestamps are propagated, but if they were taken implicitly
-from the input filespec, then all timestamps other than the
-revision date are propagated. If this parameter is not supplied,
-it defaults to 0.
-
-Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
-it sets C<$!>, deletes the output file, and returns 0.
-
-=back
-
-=head1 RETURN
-
-All functions return 1 on success, 0 on failure.
-$! will be set if an error was encountered.
-
-=head1 NOTES
-
-=over 4
-
-=item *
-
-On Mac OS (Classic), the path separator is ':', not '/', and the
-current directory is denoted as ':', not '.'. You should be careful
-about specifying relative pathnames. While a full path always begins
-with a volume name, a relative pathname should always begin with a
-':'. If specifying a volume name only, a trailing ':' is required.
-
-E.g.
-
- copy("file1", "tmp"); # creates the file 'tmp' in the current directory
- copy("file1", ":tmp:"); # creates :tmp:file1
- copy("file1", ":tmp"); # same as above
- copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do
- # that, since it may cause confusion, see example #1)
- copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume
- copy("file1", ":tmp:file1"); # ok, partial path
- copy("file1", "DataHD:"); # creates DataHD:file1
-
- move("MacintoshHD:fileA", "DataHD:fileB"); # moves (don't copies) files from one
- # volume to another
-
-=back
-
-=head1 AUTHOR
-
-File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
-and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/File/DosGlob.pm b/Master/tlpkg/installer/perllib/File/DosGlob.pm
deleted file mode 100644
index a1c27d5c32a..00000000000
--- a/Master/tlpkg/installer/perllib/File/DosGlob.pm
+++ /dev/null
@@ -1,571 +0,0 @@
-#!perl -w
-
-# use strict fails
-#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191.
-
-#
-# Documentation at the __END__
-#
-
-package File::DosGlob;
-
-our $VERSION = '1.00';
-use strict;
-use warnings;
-
-sub doglob {
- my $cond = shift;
- my @retval = ();
- #print "doglob: ", join('|', @_), "\n";
- OUTER:
- for my $pat (@_) {
- my @matched = ();
- my @globdirs = ();
- my $head = '.';
- my $sepchr = '/';
- my $tail;
- next OUTER unless defined $pat and $pat ne '';
- # if arg is within quotes strip em and do no globbing
- if ($pat =~ /^"(.*)"\z/s) {
- $pat = $1;
- if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
- else { push(@retval, $pat) if -e $pat }
- next OUTER;
- }
- # wildcards with a drive prefix such as h:*.pm must be changed
- # to h:./*.pm to expand correctly
- if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
- substr($_,0,2) = $1 . "./";
- }
- if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
- ($head, $sepchr, $tail) = ($1,$2,$3);
- #print "div: |$head|$sepchr|$tail|\n";
- push (@retval, $pat), next OUTER if $tail eq '';
- if ($head =~ /[*?]/) {
- @globdirs = doglob('d', $head);
- push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
- next OUTER if @globdirs;
- }
- $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
- $pat = $tail;
- }
- #
- # If file component has no wildcards, we can avoid opendir
- unless ($pat =~ /[*?]/) {
- $head = '' if $head eq '.';
- $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
- $head .= $pat;
- if ($cond eq 'd') { push(@retval,$head) if -d $head }
- else { push(@retval,$head) if -e $head }
- next OUTER;
- }
- opendir(D, $head) or next OUTER;
- my @leaves = readdir D;
- closedir D;
- $head = '' if $head eq '.';
- $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
-
- # escape regex metachars but not glob chars
- $pat =~ s:([].+^\-\${}[|]):\\$1:g;
- # and convert DOS-style wildcards to regex
- $pat =~ s/\*/.*/g;
- $pat =~ s/\?/.?/g;
-
- #print "regex: '$pat', head: '$head'\n";
- my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
- INNER:
- for my $e (@leaves) {
- next INNER if $e eq '.' or $e eq '..';
- next INNER if $cond eq 'd' and ! -d "$head$e";
- push(@matched, "$head$e"), next INNER if &$matchsub($e);
- #
- # [DOS compatibility special case]
- # Failed, add a trailing dot and try again, but only
- # if name does not have a dot in it *and* pattern
- # has a dot *and* name is shorter than 9 chars.
- #
- if (index($e,'.') == -1 and length($e) < 9
- and index($pat,'\\.') != -1) {
- push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
- }
- }
- push @retval, @matched if @matched;
- }
- return @retval;
-}
-
-
-#
-# Do DOS-like globbing on Mac OS
-#
-sub doglob_Mac {
- my $cond = shift;
- my @retval = ();
-
- #print "doglob_Mac: ", join('|', @_), "\n";
- OUTER:
- for my $arg (@_) {
- local $_ = $arg;
- my @matched = ();
- my @globdirs = ();
- my $head = ':';
- my $not_esc_head = $head;
- my $sepchr = ':';
- next OUTER unless defined $_ and $_ ne '';
- # if arg is within quotes strip em and do no globbing
- if (/^"(.*)"\z/s) {
- $_ = $1;
- # $_ may contain escaped metachars '\*', '\?' and '\'
- my $not_esc_arg = $_;
- $not_esc_arg =~ s/\\([*?\\])/$1/g;
- if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg }
- else { push(@retval, $not_esc_arg) if -e $not_esc_arg }
- next OUTER;
- }
-
- if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy
- my $tail;
- ($head, $sepchr, $tail) = ($1,$2,$3);
- #print "div: |$head|$sepchr|$tail|\n";
- push (@retval, $_), next OUTER if $tail eq '';
- #
- # $head may contain escaped metachars '\*' and '\?'
-
- my $tmp_head = $head;
- # if a '*' or '?' is preceded by an odd count of '\', temporary delete
- # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as
- # wildcards
- $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
-
- if ($tmp_head =~ /[*?]/) { # if there are wildcards ...
- @globdirs = doglob_Mac('d', $head);
- push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)),
- next OUTER if @globdirs;
- }
-
- $head .= $sepchr;
- $not_esc_head = $head;
- # unescape $head for file operations
- $not_esc_head =~ s/\\([*?\\])/$1/g;
- $_ = $tail;
- }
- #
- # If file component has no wildcards, we can avoid opendir
-
- my $tmp_tail = $_;
- # if a '*' or '?' is preceded by an odd count of '\', temporary delete
- # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as
- # wildcards
- $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
-
- unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ...
- $not_esc_head = $head = '' if $head eq ':';
- my $not_esc_tail = $_;
- # unescape $head and $tail for file operations
- $not_esc_tail =~ s/\\([*?\\])/$1/g;
- $head .= $_;
- $not_esc_head .= $not_esc_tail;
- if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head }
- else { push(@retval,$head) if -e $not_esc_head }
- next OUTER;
- }
- #print "opendir($not_esc_head)\n";
- opendir(D, $not_esc_head) or next OUTER;
- my @leaves = readdir D;
- closedir D;
-
- # escape regex metachars but not '\' and glob chars '*', '?'
- $_ =~ s:([].+^\-\${}[|]):\\$1:g;
- # and convert DOS-style wildcards to regex,
- # but only if they are not escaped
- $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
-
- #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n";
- my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }';
- warn($@), next OUTER if $@;
- INNER:
- for my $e (@leaves) {
- next INNER if $e eq '.' or $e eq '..';
- next INNER if $cond eq 'd' and ! -d "$not_esc_head$e";
-
- if (&$matchsub($e)) {
- my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ?
- "$e" : "$not_esc_head$e";
- #
- # On Mac OS, the two glob metachars '*' and '?' and the escape
- # char '\' are valid characters for file and directory names.
- # We have to escape and treat them specially.
- $leave =~ s|([*?\\])|\\$1|g;
- push(@matched, $leave);
- next INNER;
- }
- }
- push @retval, @matched if @matched;
- }
- return @retval;
-}
-
-#
-# _expand_volume() will only be used on Mac OS (Classic):
-# Takes an array of original patterns as argument and returns an array of
-# possibly modified patterns. Each original pattern is processed like
-# that:
-# + If there's a volume name in the pattern, we push a separate pattern
-# for each mounted volume that matches (with '*', '?' and '\' escaped).
-# + If there's no volume name in the original pattern, it is pushed
-# unchanged.
-# Note that the returned array of patterns may be empty.
-#
-sub _expand_volume {
-
- require MacPerl; # to be verbose
-
- my @pat = @_;
- my @new_pat = ();
- my @FSSpec_Vols = MacPerl::Volumes();
- my @mounted_volumes = ();
-
- foreach my $spec_vol (@FSSpec_Vols) {
- # push all mounted volumes into array
- push @mounted_volumes, MacPerl::MakePath($spec_vol);
- }
- #print "mounted volumes: |@mounted_volumes|\n";
-
- while (@pat) {
- my $pat = shift @pat;
- if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name?
- my $vol_pat = $1;
- my $tail = $2;
- #
- # escape regex metachars but not '\' and glob chars '*', '?'
- $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g;
- # and convert DOS-style wildcards to regex,
- # but only if they are not escaped
- $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
- #print "volume regex: '$vol_pat' \n";
-
- foreach my $volume (@mounted_volumes) {
- if ($volume =~ m|^$vol_pat\z|ios) {
- #
- # On Mac OS, the two glob metachars '*' and '?' and the
- # escape char '\' are valid characters for volume names.
- # We have to escape and treat them specially.
- $volume =~ s|([*?\\])|\\$1|g;
- push @new_pat, $volume . $tail;
- }
- }
- } else { # no volume name in pattern, push original pattern
- push @new_pat, $pat;
- }
- }
- return @new_pat;
-}
-
-
-#
-# _preprocess_pattern() will only be used on Mac OS (Classic):
-# Resolves any updirs in the pattern. Removes a single trailing colon
-# from the pattern, unless it's a volume name pattern like "*HD:"
-#
-sub _preprocess_pattern {
- my @pat = @_;
-
- foreach my $p (@pat) {
- my $proceed;
- # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*"
- do {
- $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
- } while ($proceed);
- # remove a single trailing colon, e.g. ":*:" -> ":*"
- $p =~ s/:([^:]+):\z/:$1/;
- }
- return @pat;
-}
-
-
-#
-# _un_escape() will only be used on Mac OS (Classic):
-# Unescapes a list of arguments which may contain escaped
-# metachars '*', '?' and '\'.
-#
-sub _un_escape {
- foreach (@_) {
- s/\\([*?\\])/$1/g;
- }
- return @_;
-}
-
-#
-# this can be used to override CORE::glob in a specific
-# package by saying C<use File::DosGlob 'glob';> in that
-# namespace.
-#
-
-# context (keyed by second cxix arg provided by core)
-my %iter;
-my %entries;
-
-sub glob {
- my($pat,$cxix) = @_;
- my @pat;
-
- # glob without args defaults to $_
- $pat = $_ unless defined $pat;
-
- # extract patterns
- if ($pat =~ /\s/) {
- require Text::ParseWords;
- @pat = Text::ParseWords::parse_line('\s+',0,$pat);
- }
- else {
- push @pat, $pat;
- }
-
- # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
- # abc3 will be the original {3} (and drop the {}).
- # abc1 abc2 will be put in @appendpat.
- # This was just the esiest way, not nearly the best.
- REHASH: {
- my @appendpat = ();
- for (@pat) {
- # There must be a "," I.E. abc{efg} is not what we want.
- while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
- my ($start, $match, $end) = ($1, $2, $3);
- #print "Got: \n\t$start\n\t$match\n\t$end\n";
- my $tmp = "$start$match$end";
- while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
- #print "Striped: $tmp\n";
- # these expanshions will be preformed by the original,
- # when we call REHASH.
- }
- push @appendpat, ("$tmp");
- s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
- if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
- $match = $1;
- #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
- $_ = "$start$match$end";
- }
- }
- #print "Sould have "GOT" vs "Got"!\n";
- #FIXME: There should be checking for this.
- # How or what should be done about failure is beond me.
- }
- if ( $#appendpat != -1
- ) {
- #print "LOOP\n";
- #FIXME: Max loop, no way! :")
- for ( @appendpat ) {
- push @pat, $_;
- }
- goto REHASH;
- }
- }
- for ( @pat ) {
- s/\\{/{/g;
- s/\\}/}/g;
- s/\\,/,/g;
- }
- #print join ("\n", @pat). "\n";
-
- # assume global context if not provided one
- $cxix = '_G_' unless defined $cxix;
- $iter{$cxix} = 0 unless exists $iter{$cxix};
-
- # if we're just beginning, do it all first
- if ($iter{$cxix} == 0) {
- if ($^O eq 'MacOS') {
- # first, take care of updirs and trailing colons
- @pat = _preprocess_pattern(@pat);
- # expand volume names
- @pat = _expand_volume(@pat);
- $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@pat) )] : [()];
- } else {
- $entries{$cxix} = [doglob(1,@pat)];
- }
- }
-
- # chuck it all out, quick or slow
- if (wantarray) {
- delete $iter{$cxix};
- return @{delete $entries{$cxix}};
- }
- else {
- if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
- return shift @{$entries{$cxix}};
- }
- else {
- # return undef for EOL
- delete $iter{$cxix};
- delete $entries{$cxix};
- return undef;
- }
- }
-}
-
-{
- no strict 'refs';
-
- sub import {
- my $pkg = shift;
- return unless @_;
- my $sym = shift;
- my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
- *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
- }
-}
-1;
-
-__END__
-
-=head1 NAME
-
-File::DosGlob - DOS like globbing and then some
-
-=head1 SYNOPSIS
-
- require 5.004;
-
- # override CORE::glob in current package
- use File::DosGlob 'glob';
-
- # override CORE::glob in ALL packages (use with extreme caution!)
- use File::DosGlob 'GLOBAL_glob';
-
- @perlfiles = glob "..\\pe?l/*.p?";
- print <..\\pe?l/*.p?>;
-
- # from the command line (overrides only in main::)
- > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
-
-=head1 DESCRIPTION
-
-A module that implements DOS-like globbing with a few enhancements.
-It is largely compatible with perlglob.exe (the M$ setargv.obj
-version) in all but one respect--it understands wildcards in
-directory components.
-
-For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
-that it will find something like '..\lib\File/DosGlob.pm' alright).
-Note that all path components are case-insensitive, and that
-backslashes and forward slashes are both accepted, and preserved.
-You may have to double the backslashes if you are putting them in
-literally, due to double-quotish parsing of the pattern by perl.
-
-Spaces in the argument delimit distinct patterns, so
-C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
-or C<.dll>. If you want to put in literal spaces in the glob
-pattern, you can escape them with either double quotes, or backslashes.
-e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
-C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using
-C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
-of the quoting rules used.
-
-Extending it to csh patterns is left as an exercise to the reader.
-
-=head1 NOTES
-
-=over 4
-
-=item *
-
-Mac OS (Classic) users should note a few differences. The specification
-of pathnames in glob patterns adheres to the usual Mac OS conventions:
-The path separator is a colon ':', not a slash '/' or backslash '\'. A
-full path always begins with a volume name. A relative pathname on Mac
-OS must always begin with a ':', except when specifying a file or
-directory name in the current working directory, where the leading colon
-is optional. If specifying a volume name only, a trailing ':' is
-required. Due to these rules, a glob like E<lt>*:E<gt> will find all
-mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find
-all files and directories in the current directory.
-
-Note that updirs in the glob pattern are resolved before the matching begins,
-i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also,
-that a single trailing ':' in the pattern is ignored (unless it's a volume
-name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories
-I<and> files (and not, as one might expect, only directories).
-
-The metachars '*', '?' and the escape char '\' are valid characters in
-volume, directory and file names on Mac OS. Hence, if you want to match
-a '*', '?' or '\' literally, you have to escape these characters. Due to
-perl's quoting rules, things may get a bit complicated, when you want to
-match a string like '\*' literally, or when you want to match '\' literally,
-but treat the immediately following character '*' as metachar. So, here's a
-rule of thumb (applies to both single- and double-quoted strings): escape
-each '*' or '?' or '\' with a backslash, if you want to treat them literally,
-and then double each backslash and your are done. E.g.
-
-- Match '\*' literally
-
- escape both '\' and '*' : '\\\*'
- double the backslashes : '\\\\\\*'
-
-(Internally, the glob routine sees a '\\\*', which means that both '\' and
-'*' are escaped.)
-
-
-- Match '\' literally, treat '*' as metachar
-
- escape '\' but not '*' : '\\*'
- double the backslashes : '\\\\*'
-
-(Internally, the glob routine sees a '\\*', which means that '\' is escaped and
-'*' is not.)
-
-Note that you also have to quote literal spaces in the glob pattern, as described
-above.
-
-=back
-
-=head1 EXPORTS (by request only)
-
-glob()
-
-=head1 BUGS
-
-Should probably be built into the core, and needs to stop
-pandering to DOS habits. Needs a dose of optimizium too.
-
-=head1 AUTHOR
-
-Gurusamy Sarathy <gsar@activestate.com>
-
-=head1 HISTORY
-
-=over 4
-
-=item *
-
-Support for globally overriding glob() (GSAR 3-JUN-98)
-
-=item *
-
-Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
-
-=item *
-
-A few dir-vs-file optimizations result in glob importation being
-10 times faster than using perlglob.exe, and using perlglob.bat is
-only twice as slow as perlglob.exe (GSAR 28-MAY-97)
-
-=item *
-
-Several cleanups prompted by lack of compatible perlglob.exe
-under Borland (GSAR 27-MAY-97)
-
-=item *
-
-Initial version (GSAR 20-FEB-97)
-
-=back
-
-=head1 SEE ALSO
-
-perl
-
-perlglob.bat
-
-Text::ParseWords
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/File/Find.pm b/Master/tlpkg/installer/perllib/File/Find.pm
deleted file mode 100644
index 497051e0635..00000000000
--- a/Master/tlpkg/installer/perllib/File/Find.pm
+++ /dev/null
@@ -1,1275 +0,0 @@
-package File::Find;
-use 5.006;
-use strict;
-use warnings;
-use warnings::register;
-our $VERSION = '1.10';
-require Exporter;
-require Cwd;
-
-#
-# Modified to ensure sub-directory traversal order is not inverded by stack
-# push and pops. That is remains in the same order as in the directory file,
-# or user pre-processing (EG:sorted).
-#
-
-=head1 NAME
-
-File::Find - Traverse a directory tree.
-
-=head1 SYNOPSIS
-
- use File::Find;
- find(\&wanted, @directories_to_search);
- sub wanted { ... }
-
- use File::Find;
- finddepth(\&wanted, @directories_to_search);
- sub wanted { ... }
-
- use File::Find;
- find({ wanted => \&process, follow => 1 }, '.');
-
-=head1 DESCRIPTION
-
-These are functions for searching through directory trees doing work
-on each file found similar to the Unix I<find> command. File::Find
-exports two functions, C<find> and C<finddepth>. They work similarly
-but have subtle differences.
-
-=over 4
-
-=item B<find>
-
- find(\&wanted, @directories);
- find(\%options, @directories);
-
-C<find()> does a depth-first search over the given C<@directories> in
-the order they are given. For each file or directory found, it calls
-the C<&wanted> subroutine. (See below for details on how to use the
-C<&wanted> function). Additionally, for each directory found, it will
-C<chdir()> into that directory and continue the search, invoking the
-C<&wanted> function on each file or subdirectory in the directory.
-
-=item B<finddepth>
-
- finddepth(\&wanted, @directories);
- finddepth(\%options, @directories);
-
-C<finddepth()> works just like C<find()> except that is invokes the
-C<&wanted> function for a directory I<after> invoking it for the
-directory's contents. It does a postorder traversal instead of a
-preorder traversal, working from the bottom of the directory tree up
-where C<find()> works from the top of the tree down.
-
-=back
-
-=head2 %options
-
-The first argument to C<find()> is either a code reference to your
-C<&wanted> function, or a hash reference describing the operations
-to be performed for each file. The
-code reference is described in L<The wanted function> below.
-
-Here are the possible keys for the hash:
-
-=over 3
-
-=item C<wanted>
-
-The value should be a code reference. This code reference is
-described in L<The wanted function> below.
-
-=item C<bydepth>
-
-Reports the name of a directory only AFTER all its entries
-have been reported. Entry point C<finddepth()> is a shortcut for
-specifying C<<{ bydepth => 1 }>> in the first argument of C<find()>.
-
-=item C<preprocess>
-
-The value should be a code reference. This code reference is used to
-preprocess the current directory. The name of the currently processed
-directory is in C<$File::Find::dir>. Your preprocessing function is
-called after C<readdir()>, but before the loop that calls the C<wanted()>
-function. It is called with a list of strings (actually file/directory
-names) and is expected to return a list of strings. The code can be
-used to sort the file/directory names alphabetically, numerically,
-or to filter out directory entries based on their name alone. When
-I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op.
-
-=item C<postprocess>
-
-The value should be a code reference. It is invoked just before leaving
-the currently processed directory. It is called in void context with no
-arguments. The name of the current directory is in C<$File::Find::dir>. This
-hook is handy for summarizing a directory, such as calculating its disk
-usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a
-no-op.
-
-=item C<follow>
-
-Causes symbolic links to be followed. Since directory trees with symbolic
-links (followed) may contain files more than once and may even have
-cycles, a hash has to be built up with an entry for each file.
-This might be expensive both in space and time for a large
-directory tree. See I<follow_fast> and I<follow_skip> below.
-If either I<follow> or I<follow_fast> is in effect:
-
-=over 6
-
-=item *
-
-It is guaranteed that an I<lstat> has been called before the user's
-C<wanted()> function is called. This enables fast file checks involving S<_>.
-Note that this guarantee no longer holds if I<follow> or I<follow_fast>
-are not set.
-
-=item *
-
-There is a variable C<$File::Find::fullname> which holds the absolute
-pathname of the file with all symbolic links resolved. If the link is
-a dangling symbolic link, then fullname will be set to C<undef>.
-
-=back
-
-This is a no-op on Win32.
-
-=item C<follow_fast>
-
-This is similar to I<follow> except that it may report some files more
-than once. It does detect cycles, however. Since only symbolic links
-have to be hashed, this is much cheaper both in space and time. If
-processing a file more than once (by the user's C<wanted()> function)
-is worse than just taking time, the option I<follow> should be used.
-
-This is also a no-op on Win32.
-
-=item C<follow_skip>
-
-C<follow_skip==1>, which is the default, causes all files which are
-neither directories nor symbolic links to be ignored if they are about
-to be processed a second time. If a directory or a symbolic link
-are about to be processed a second time, File::Find dies.
-
-C<follow_skip==0> causes File::Find to die if any file is about to be
-processed a second time.
-
-C<follow_skip==2> causes File::Find to ignore any duplicate files and
-directories but to proceed normally otherwise.
-
-=item C<dangling_symlinks>
-
-If true and a code reference, will be called with the symbolic link
-name and the directory it lives in as arguments. Otherwise, if true
-and warnings are on, warning "symbolic_link_name is a dangling
-symbolic link\n" will be issued. If false, the dangling symbolic link
-will be silently ignored.
-
-=item C<no_chdir>
-
-Does not C<chdir()> to each directory as it recurses. The C<wanted()>
-function will need to be aware of this, of course. In this case,
-C<$_> will be the same as C<$File::Find::name>.
-
-=item C<untaint>
-
-If find is used in taint-mode (-T command line switch or if EUID != UID
-or if EGID != GID) then internally directory names have to be untainted
-before they can be chdir'ed to. Therefore they are checked against a regular
-expression I<untaint_pattern>. Note that all names passed to the user's
-I<wanted()> function are still tainted. If this option is used while
-not in taint-mode, C<untaint> is a no-op.
-
-=item C<untaint_pattern>
-
-See above. This should be set using the C<qr> quoting operator.
-The default is set to C<qr|^([-+@\w./]+)$|>.
-Note that the parentheses are vital.
-
-=item C<untaint_skip>
-
-If set, a directory which fails the I<untaint_pattern> is skipped,
-including all its sub-directories. The default is to 'die' in such a case.
-
-=back
-
-=head2 The wanted function
-
-The C<wanted()> function does whatever verifications you want on
-each file and directory. Note that despite its name, the C<wanted()>
-function is a generic callback function, and does B<not> tell
-File::Find if a file is "wanted" or not. In fact, its return value
-is ignored.
-
-The wanted function takes no arguments but rather does its work
-through a collection of variables.
-
-=over 4
-
-=item C<$File::Find::dir> is the current directory name,
-
-=item C<$_> is the current filename within that directory
-
-=item C<$File::Find::name> is the complete pathname to the file.
-
-=back
-
-Don't modify these variables.
-
-For example, when examining the file F</some/path/foo.ext> you will have:
-
- $File::Find::dir = /some/path/
- $_ = foo.ext
- $File::Find::name = /some/path/foo.ext
-
-You are chdir()'d to C<$File::Find::dir> when the function is called,
-unless C<no_chdir> was specified. Note that when changing to
-directories is in effect the root directory (F</>) is a somewhat
-special case inasmuch as the concatenation of C<$File::Find::dir>,
-C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The
-table below summarizes all variants:
-
- $File::Find::name $File::Find::dir $_
- default / / .
- no_chdir=>0 /etc / etc
- /etc/x /etc x
-
- no_chdir=>1 / / /
- /etc / /etc
- /etc/x /etc /etc/x
-
-
-When <follow> or <follow_fast> are in effect, there is
-also a C<$File::Find::fullname>. The function may set
-C<$File::Find::prune> to prune the tree unless C<bydepth> was
-specified. Unless C<follow> or C<follow_fast> is specified, for
-compatibility reasons (find.pl, find2perl) there are in addition the
-following globals available: C<$File::Find::topdir>,
-C<$File::Find::topdev>, C<$File::Find::topino>,
-C<$File::Find::topmode> and C<$File::Find::topnlink>.
-
-This library is useful for the C<find2perl> tool, which when fed,
-
- find2perl / -name .nfs\* -mtime +7 \
- -exec rm -f {} \; -o -fstype nfs -prune
-
-produces something like:
-
- sub wanted {
- /^\.nfs.*\z/s &&
- (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) &&
- int(-M _) > 7 &&
- unlink($_)
- ||
- ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) &&
- $dev < 0 &&
- ($File::Find::prune = 1);
- }
-
-Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical
-filehandle that caches the information from the preceding
-C<stat()>, C<lstat()>, or filetest.
-
-Here's another interesting wanted function. It will find all symbolic
-links that don't resolve:
-
- sub wanted {
- -l && !-e && print "bogus link: $File::Find::name\n";
- }
-
-See also the script C<pfind> on CPAN for a nice application of this
-module.
-
-=head1 WARNINGS
-
-If you run your program with the C<-w> switch, or if you use the
-C<warnings> pragma, File::Find will report warnings for several weird
-situations. You can disable these warnings by putting the statement
-
- no warnings 'File::Find';
-
-in the appropriate scope. See L<perllexwarn> for more info about lexical
-warnings.
-
-=head1 CAVEAT
-
-=over 2
-
-=item $dont_use_nlink
-
-You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to
-force File::Find to always stat directories. This was used for file systems
-that do not have an C<nlink> count matching the number of sub-directories.
-Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file
-system) and a couple of others.
-
-You shouldn't need to set this variable, since File::Find should now detect
-such file systems on-the-fly and switch itself to using stat. This works even
-for parts of your file system, like a mounted CD-ROM.
-
-If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs.
-
-=item symlinks
-
-Be aware that the option to follow symbolic links can be dangerous.
-Depending on the structure of the directory tree (including symbolic
-links to directories) you might traverse a given (physical) directory
-more than once (only if C<follow_fast> is in effect).
-Furthermore, deleting or changing files in a symbolically linked directory
-might cause very unpleasant surprises, since you delete or change files
-in an unknown directory.
-
-=back
-
-=head1 NOTES
-
-=over 4
-
-=item *
-
-Mac OS (Classic) users should note a few differences:
-
-=over 4
-
-=item *
-
-The path separator is ':', not '/', and the current directory is denoted
-as ':', not '.'. You should be careful about specifying relative pathnames.
-While a full path always begins with a volume name, a relative pathname
-should always begin with a ':'. If specifying a volume name only, a
-trailing ':' is required.
-
-=item *
-
-C<$File::Find::dir> is guaranteed to end with a ':'. If C<$_>
-contains the name of a directory, that name may or may not end with a
-':'. Likewise, C<$File::Find::name>, which contains the complete
-pathname to that directory, and C<$File::Find::fullname>, which holds
-the absolute pathname of that directory with all symbolic links resolved,
-may or may not end with a ':'.
-
-=item *
-
-The default C<untaint_pattern> (see above) on Mac OS is set to
-C<qr|^(.+)$|>. Note that the parentheses are vital.
-
-=item *
-
-The invisible system file "Icon\015" is ignored. While this file may
-appear in every directory, there are some more invisible system files
-on every volume, which are all located at the volume root level (i.e.
-"MacintoshHD:"). These system files are B<not> excluded automatically.
-Your filter may use the following code to recognize invisible files or
-directories (requires Mac::Files):
-
- use Mac::Files;
-
- # invisible() -- returns 1 if file/directory is invisible,
- # 0 if it's visible or undef if an error occurred
-
- sub invisible($) {
- my $file = shift;
- my ($fileCat, $fileInfo);
- my $invisible_flag = 1 << 14;
-
- if ( $fileCat = FSpGetCatInfo($file) ) {
- if ($fileInfo = $fileCat->ioFlFndrInfo() ) {
- return (($fileInfo->fdFlags & $invisible_flag) && 1);
- }
- }
- return undef;
- }
-
-Generally, invisible files are system files, unless an odd application
-decides to use invisible files for its own purposes. To distinguish
-such files from system files, you have to look at the B<type> and B<creator>
-file attributes. The MacPerl built-in functions C<GetFileInfo(FILE)> and
-C<SetFileInfo(CREATOR, TYPE, FILES)> offer access to these attributes
-(see MacPerl.pm for details).
-
-Files that appear on the desktop actually reside in an (hidden) directory
-named "Desktop Folder" on the particular disk volume. Note that, although
-all desktop files appear to be on the same "virtual" desktop, each disk
-volume actually maintains its own "Desktop Folder" directory.
-
-=back
-
-=back
-
-=head1 BUGS AND CAVEATS
-
-Despite the name of the C<finddepth()> function, both C<find()> and
-C<finddepth()> perform a depth-first search of the directory
-hierarchy.
-
-=head1 HISTORY
-
-File::Find used to produce incorrect results if called recursively.
-During the development of perl 5.8 this bug was fixed.
-The first fixed version of File::Find was 1.01.
-
-=cut
-
-our @ISA = qw(Exporter);
-our @EXPORT = qw(find finddepth);
-
-
-use strict;
-my $Is_VMS;
-my $Is_MacOS;
-
-require File::Basename;
-require File::Spec;
-
-# Should ideally be my() not our() but local() currently
-# refuses to operate on lexicals
-
-our %SLnkSeen;
-our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
- $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
- $pre_process, $post_process, $dangling_symlinks);
-
-sub contract_name {
- my ($cdir,$fn) = @_;
-
- return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir;
-
- $cdir = substr($cdir,0,rindex($cdir,'/')+1);
-
- $fn =~ s|^\./||;
-
- my $abs_name= $cdir . $fn;
-
- if (substr($fn,0,3) eq '../') {
- 1 while $abs_name =~ s!/[^/]*/\.\./!/!;
- }
-
- return $abs_name;
-}
-
-# return the absolute name of a directory or file
-sub contract_name_Mac {
- my ($cdir,$fn) = @_;
- my $abs_name;
-
- if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':'
-
- my $colon_count = length ($1);
- if ($colon_count == 1) {
- $abs_name = $cdir . $2;
- return $abs_name;
- }
- else {
- # need to move up the tree, but
- # only if it's not a volume name
- for (my $i=1; $i<$colon_count; $i++) {
- unless ($cdir =~ /^[^:]+:$/) { # volume name
- $cdir =~ s/[^:]+:$//;
- }
- else {
- return undef;
- }
- }
- $abs_name = $cdir . $2;
- return $abs_name;
- }
-
- }
- else {
-
- # $fn may be a valid path to a directory or file or (dangling)
- # symlink, without a leading ':'
- if ( (-e $fn) || (-l $fn) ) {
- if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:*
- return $fn; # $fn is already an absolute path
- }
- else {
- $abs_name = $cdir . $fn;
- return $abs_name;
- }
- }
- else { # argh!, $fn is not a valid directory/file
- return undef;
- }
- }
-}
-
-sub PathCombine($$) {
- my ($Base,$Name) = @_;
- my $AbsName;
-
- if ($Is_MacOS) {
- # $Name is the resolved symlink (always a full path on MacOS),
- # i.e. there's no need to call contract_name_Mac()
- $AbsName = $Name;
-
- # (simple) check for recursion
- if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion
- return undef;
- }
- }
- else {
- if (substr($Name,0,1) eq '/') {
- $AbsName= $Name;
- }
- else {
- $AbsName= contract_name($Base,$Name);
- }
-
- # (simple) check for recursion
- my $newlen= length($AbsName);
- if ($newlen <= length($Base)) {
- if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/')
- && $AbsName eq substr($Base,0,$newlen))
- {
- return undef;
- }
- }
- }
- return $AbsName;
-}
-
-sub Follow_SymLink($) {
- my ($AbsName) = @_;
-
- my ($NewName,$DEV, $INO);
- ($DEV, $INO)= lstat $AbsName;
-
- while (-l _) {
- if ($SLnkSeen{$DEV, $INO}++) {
- if ($follow_skip < 2) {
- die "$AbsName is encountered a second time";
- }
- else {
- return undef;
- }
- }
- $NewName= PathCombine($AbsName, readlink($AbsName));
- unless(defined $NewName) {
- if ($follow_skip < 2) {
- die "$AbsName is a recursive symbolic link";
- }
- else {
- return undef;
- }
- }
- else {
- $AbsName= $NewName;
- }
- ($DEV, $INO) = lstat($AbsName);
- return undef unless defined $DEV; # dangling symbolic link
- }
-
- if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) {
- if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) {
- die "$AbsName encountered a second time";
- }
- else {
- return undef;
- }
- }
-
- return $AbsName;
-}
-
-our($dir, $name, $fullname, $prune);
-sub _find_dir_symlnk($$$);
-sub _find_dir($$$);
-
-# check whether or not a scalar variable is tainted
-# (code straight from the Camel, 3rd ed., page 561)
-sub is_tainted_pp {
- my $arg = shift;
- my $nada = substr($arg, 0, 0); # zero-length
- local $@;
- eval { eval "# $nada" };
- return length($@) != 0;
-}
-
-sub _find_opt {
- my $wanted = shift;
- die "invalid top directory" unless defined $_[0];
-
- # This function must local()ize everything because callbacks may
- # call find() or finddepth()
-
- local %SLnkSeen;
- local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
- $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
- $pre_process, $post_process, $dangling_symlinks);
- local($dir, $name, $fullname, $prune);
- local *_ = \my $a;
-
- my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd();
- my $cwd_untainted = $cwd;
- my $check_t_cwd = 1;
- $wanted_callback = $wanted->{wanted};
- $bydepth = $wanted->{bydepth};
- $pre_process = $wanted->{preprocess};
- $post_process = $wanted->{postprocess};
- $no_chdir = $wanted->{no_chdir};
- $full_check = $^O eq 'MSWin32' ? 0 : $wanted->{follow};
- $follow = $^O eq 'MSWin32' ? 0 :
- $full_check || $wanted->{follow_fast};
- $follow_skip = $wanted->{follow_skip};
- $untaint = $wanted->{untaint};
- $untaint_pat = $wanted->{untaint_pattern};
- $untaint_skip = $wanted->{untaint_skip};
- $dangling_symlinks = $wanted->{dangling_symlinks};
-
- # for compatibility reasons (find.pl, find2perl)
- local our ($topdir, $topdev, $topino, $topmode, $topnlink);
-
- # a symbolic link to a directory doesn't increase the link count
- $avoid_nlink = $follow || $File::Find::dont_use_nlink;
-
- my ($abs_dir, $Is_Dir);
-
- Proc_Top_Item:
- foreach my $TOP (@_) {
- my $top_item = $TOP;
-
- ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
-
- if ($Is_MacOS) {
- $top_item = ":$top_item"
- if ( (-d _) && ( $top_item !~ /:/ ) );
- } elsif ($^O eq 'MSWin32') {
- $top_item =~ s|/\z|| unless $top_item =~ m|\w:/$|;
- }
- else {
- $top_item =~ s|/\z|| unless $top_item eq '/';
- }
-
- $Is_Dir= 0;
-
- if ($follow) {
-
- if ($Is_MacOS) {
- $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety
-
- if ($top_item eq $File::Find::current_dir) {
- $abs_dir = $cwd;
- }
- else {
- $abs_dir = contract_name_Mac($cwd, $top_item);
- unless (defined $abs_dir) {
- warnings::warnif "Can't determine absolute path for $top_item (No such file or directory)\n";
- next Proc_Top_Item;
- }
- }
-
- }
- else {
- if (substr($top_item,0,1) eq '/') {
- $abs_dir = $top_item;
- }
- elsif ($top_item eq $File::Find::current_dir) {
- $abs_dir = $cwd;
- }
- else { # care about any ../
- $abs_dir = contract_name("$cwd/",$top_item);
- }
- }
- $abs_dir= Follow_SymLink($abs_dir);
- unless (defined $abs_dir) {
- if ($dangling_symlinks) {
- if (ref $dangling_symlinks eq 'CODE') {
- $dangling_symlinks->($top_item, $cwd);
- } else {
- warnings::warnif "$top_item is a dangling symbolic link\n";
- }
- }
- next Proc_Top_Item;
- }
-
- if (-d _) {
- _find_dir_symlnk($wanted, $abs_dir, $top_item);
- $Is_Dir= 1;
- }
- }
- else { # no follow
- $topdir = $top_item;
- unless (defined $topnlink) {
- warnings::warnif "Can't stat $top_item: $!\n";
- next Proc_Top_Item;
- }
- if (-d _) {
- $top_item =~ s/\.dir\z//i if $Is_VMS;
- _find_dir($wanted, $top_item, $topnlink);
- $Is_Dir= 1;
- }
- else {
- $abs_dir= $top_item;
- }
- }
-
- unless ($Is_Dir) {
- unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
- if ($Is_MacOS) {
- ($dir,$_) = (':', $top_item); # $File::Find::dir, $_
- }
- else {
- ($dir,$_) = ('./', $top_item);
- }
- }
-
- $abs_dir = $dir;
- if (( $untaint ) && (is_tainted($dir) )) {
- ( $abs_dir ) = $dir =~ m|$untaint_pat|;
- unless (defined $abs_dir) {
- if ($untaint_skip == 0) {
- die "directory $dir is still tainted";
- }
- else {
- next Proc_Top_Item;
- }
- }
- }
-
- unless ($no_chdir || chdir $abs_dir) {
- warnings::warnif "Couldn't chdir $abs_dir: $!\n";
- next Proc_Top_Item;
- }
-
- $name = $abs_dir . $_; # $File::Find::name
- $_ = $name if $no_chdir;
-
- { $wanted_callback->() }; # protect against wild "next"
-
- }
-
- unless ( $no_chdir ) {
- if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) {
- ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|;
- unless (defined $cwd_untainted) {
- die "insecure cwd in find(depth)";
- }
- $check_t_cwd = 0;
- }
- unless (chdir $cwd_untainted) {
- die "Can't cd to $cwd: $!\n";
- }
- }
- }
-}
-
-# API:
-# $wanted
-# $p_dir : "parent directory"
-# $nlink : what came back from the stat
-# preconditions:
-# chdir (if not no_chdir) to dir
-
-sub _find_dir($$$) {
- my ($wanted, $p_dir, $nlink) = @_;
- my ($CdLvl,$Level) = (0,0);
- my @Stack;
- my @filenames;
- my ($subcount,$sub_nlink);
- my $SE= [];
- my $dir_name= $p_dir;
- my $dir_pref;
- my $dir_rel = $File::Find::current_dir;
- my $tainted = 0;
- my $no_nlink;
-
- if ($Is_MacOS) {
- $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface
- } elsif ($^O eq 'MSWin32') {
- $dir_pref = ($p_dir =~ m|\w:/$| ? $p_dir : "$p_dir/" );
- }
- else {
- $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
- }
-
- local ($dir, $name, $prune, *DIR);
-
- unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) {
- my $udir = $p_dir;
- if (( $untaint ) && (is_tainted($p_dir) )) {
- ( $udir ) = $p_dir =~ m|$untaint_pat|;
- unless (defined $udir) {
- if ($untaint_skip == 0) {
- die "directory $p_dir is still tainted";
- }
- else {
- return;
- }
- }
- }
- unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
- warnings::warnif "Can't cd to $udir: $!\n";
- return;
- }
- }
-
- # push the starting directory
- push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
-
- if ($Is_MacOS) {
- $p_dir = $dir_pref; # ensure trailing ':'
- }
-
- while (defined $SE) {
- unless ($bydepth) {
- $dir= $p_dir; # $File::Find::dir
- $name= $dir_name; # $File::Find::name
- $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
- # prune may happen here
- $prune= 0;
- { $wanted_callback->() }; # protect against wild "next"
- next if $prune;
- }
-
- # change to that directory
- unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
- my $udir= $dir_rel;
- if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) {
- ( $udir ) = $dir_rel =~ m|$untaint_pat|;
- unless (defined $udir) {
- if ($untaint_skip == 0) {
- if ($Is_MacOS) {
- die "directory ($p_dir) $dir_rel is still tainted";
- }
- else {
- die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted";
- }
- } else { # $untaint_skip == 1
- next;
- }
- }
- }
- unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
- if ($Is_MacOS) {
- warnings::warnif "Can't cd to ($p_dir) $udir: $!\n";
- }
- else {
- warnings::warnif "Can't cd to (" .
- ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n";
- }
- next;
- }
- $CdLvl++;
- }
-
- if ($Is_MacOS) {
- $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
- }
-
- $dir= $dir_name; # $File::Find::dir
-
- # Get the list of files in the current directory.
- unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) {
- warnings::warnif "Can't opendir($dir_name): $!\n";
- next;
- }
- @filenames = readdir DIR;
- closedir(DIR);
- @filenames = $pre_process->(@filenames) if $pre_process;
- push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process;
-
- # default: use whatever was specifid
- # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back)
- $no_nlink = $avoid_nlink;
- # if dir has wrong nlink count, force switch to slower stat method
- $no_nlink = 1 if ($nlink < 2);
-
- if ($nlink == 2 && !$no_nlink) {
- # This dir has no subdirectories.
- for my $FN (@filenames) {
- next if $FN =~ $File::Find::skip_pattern;
-
- $name = $dir_pref . $FN; # $File::Find::name
- $_ = ($no_chdir ? $name : $FN); # $_
- { $wanted_callback->() }; # protect against wild "next"
- }
-
- }
- else {
- # This dir has subdirectories.
- $subcount = $nlink - 2;
-
- # HACK: insert directories at this position. so as to preserve
- # the user pre-processed ordering of files.
- # EG: directory traversal is in user sorted order, not at random.
- my $stack_top = @Stack;
-
- for my $FN (@filenames) {
- next if $FN =~ $File::Find::skip_pattern;
- if ($subcount > 0 || $no_nlink) {
- # Seen all the subdirs?
- # check for directoriness.
- # stat is faster for a file in the current directory
- $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3];
-
- if (-d _) {
- --$subcount;
- $FN =~ s/\.dir\z//i if $Is_VMS;
- # HACK: replace push to preserve dir traversal order
- #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
- splice @Stack, $stack_top, 0,
- [$CdLvl,$dir_name,$FN,$sub_nlink];
- }
- else {
- $name = $dir_pref . $FN; # $File::Find::name
- $_= ($no_chdir ? $name : $FN); # $_
- { $wanted_callback->() }; # protect against wild "next"
- }
- }
- else {
- $name = $dir_pref . $FN; # $File::Find::name
- $_= ($no_chdir ? $name : $FN); # $_
- { $wanted_callback->() }; # protect against wild "next"
- }
- }
- }
- }
- continue {
- while ( defined ($SE = pop @Stack) ) {
- ($Level, $p_dir, $dir_rel, $nlink) = @$SE;
- if ($CdLvl > $Level && !$no_chdir) {
- my $tmp;
- if ($Is_MacOS) {
- $tmp = (':' x ($CdLvl-$Level)) . ':';
- }
- else {
- $tmp = join('/',('..') x ($CdLvl-$Level));
- }
- die "Can't cd to $dir_name" . $tmp
- unless chdir ($tmp);
- $CdLvl = $Level;
- }
-
- if ($Is_MacOS) {
- # $pdir always has a trailing ':', except for the starting dir,
- # where $dir_rel eq ':'
- $dir_name = "$p_dir$dir_rel";
- $dir_pref = "$dir_name:";
- }
- elsif ($^O eq 'MSWin32') {
- $dir_name = ($p_dir =~ m|\w:/$| ? "$p_dir$dir_rel" : "$p_dir/$dir_rel");
- $dir_pref = "$dir_name/";
- }
- else {
- $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
- $dir_pref = "$dir_name/";
- }
-
- if ( $nlink == -2 ) {
- $name = $dir = $p_dir; # $File::Find::name / dir
- $_ = $File::Find::current_dir;
- $post_process->(); # End-of-directory processing
- }
- elsif ( $nlink < 0 ) { # must be finddepth, report dirname now
- $name = $dir_name;
- if ($Is_MacOS) {
- if ($dir_rel eq ':') { # must be the top dir, where we started
- $name =~ s|:$||; # $File::Find::name
- $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
- }
- $dir = $p_dir; # $File::Find::dir
- $_ = ($no_chdir ? $name : $dir_rel); # $_
- }
- else {
- if ( substr($name,-2) eq '/.' ) {
- substr($name, length($name) == 2 ? -1 : -2) = '';
- }
- $dir = $p_dir;
- $_ = ($no_chdir ? $dir_name : $dir_rel );
- if ( substr($_,-2) eq '/.' ) {
- substr($_, length($_) == 2 ? -1 : -2) = '';
- }
- }
- { $wanted_callback->() }; # protect against wild "next"
- }
- else {
- push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
- last;
- }
- }
- }
-}
-
-
-# API:
-# $wanted
-# $dir_loc : absolute location of a dir
-# $p_dir : "parent directory"
-# preconditions:
-# chdir (if not no_chdir) to dir
-
-sub _find_dir_symlnk($$$) {
- my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory
- my @Stack;
- my @filenames;
- my $new_loc;
- my $updir_loc = $dir_loc; # untainted parent directory
- my $SE = [];
- my $dir_name = $p_dir;
- my $dir_pref;
- my $loc_pref;
- my $dir_rel = $File::Find::current_dir;
- my $byd_flag; # flag for pending stack entry if $bydepth
- my $tainted = 0;
- my $ok = 1;
-
- if ($Is_MacOS) {
- $dir_pref = ($p_dir =~ /:$/) ? "$p_dir" : "$p_dir:";
- $loc_pref = ($dir_loc =~ /:$/) ? "$dir_loc" : "$dir_loc:";
- } else {
- $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
- $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
- }
-
- local ($dir, $name, $fullname, $prune, *DIR);
-
- unless ($no_chdir) {
- # untaint the topdir
- if (( $untaint ) && (is_tainted($dir_loc) )) {
- ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted
- # once untainted, $updir_loc is pushed on the stack (as parent directory);
- # hence, we don't need to untaint the parent directory every time we chdir
- # to it later
- unless (defined $updir_loc) {
- if ($untaint_skip == 0) {
- die "directory $dir_loc is still tainted";
- }
- else {
- return;
- }
- }
- }
- $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir);
- unless ($ok) {
- warnings::warnif "Can't cd to $updir_loc: $!\n";
- return;
- }
- }
-
- push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth;
-
- if ($Is_MacOS) {
- $p_dir = $dir_pref; # ensure trailing ':'
- }
-
- while (defined $SE) {
-
- unless ($bydepth) {
- # change (back) to parent directory (always untainted)
- unless ($no_chdir) {
- unless (chdir $updir_loc) {
- warnings::warnif "Can't cd to $updir_loc: $!\n";
- next;
- }
- }
- $dir= $p_dir; # $File::Find::dir
- $name= $dir_name; # $File::Find::name
- $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
- $fullname= $dir_loc; # $File::Find::fullname
- # prune may happen here
- $prune= 0;
- lstat($_); # make sure file tests with '_' work
- { $wanted_callback->() }; # protect against wild "next"
- next if $prune;
- }
-
- # change to that directory
- unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
- $updir_loc = $dir_loc;
- if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) {
- # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir
- ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|;
- unless (defined $updir_loc) {
- if ($untaint_skip == 0) {
- die "directory $dir_loc is still tainted";
- }
- else {
- next;
- }
- }
- }
- unless (chdir $updir_loc) {
- warnings::warnif "Can't cd to $updir_loc: $!\n";
- next;
- }
- }
-
- if ($Is_MacOS) {
- $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
- }
-
- $dir = $dir_name; # $File::Find::dir
-
- # Get the list of files in the current directory.
- unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) {
- warnings::warnif "Can't opendir($dir_loc): $!\n";
- next;
- }
- @filenames = readdir DIR;
- closedir(DIR);
-
- for my $FN (@filenames) {
- next if $FN =~ $File::Find::skip_pattern;
-
- # follow symbolic links / do an lstat
- $new_loc = Follow_SymLink($loc_pref.$FN);
-
- # ignore if invalid symlink
- unless (defined $new_loc) {
- if ($dangling_symlinks) {
- if (ref $dangling_symlinks eq 'CODE') {
- $dangling_symlinks->($FN, $dir_pref);
- } else {
- warnings::warnif "$dir_pref$FN is a dangling symbolic link\n";
- }
- }
-
- $fullname = undef;
- $name = $dir_pref . $FN;
- $_ = ($no_chdir ? $name : $FN);
- { $wanted_callback->() };
- next;
- }
-
- if (-d _) {
- push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1];
- }
- else {
- $fullname = $new_loc; # $File::Find::fullname
- $name = $dir_pref . $FN; # $File::Find::name
- $_ = ($no_chdir ? $name : $FN); # $_
- { $wanted_callback->() }; # protect against wild "next"
- }
- }
-
- }
- continue {
- while (defined($SE = pop @Stack)) {
- ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE;
- if ($Is_MacOS) {
- # $p_dir always has a trailing ':', except for the starting dir,
- # where $dir_rel eq ':'
- $dir_name = "$p_dir$dir_rel";
- $dir_pref = "$dir_name:";
- $loc_pref = ($dir_loc =~ /:$/) ? $dir_loc : "$dir_loc:";
- }
- else {
- $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
- $dir_pref = "$dir_name/";
- $loc_pref = "$dir_loc/";
- }
- if ( $byd_flag < 0 ) { # must be finddepth, report dirname now
- unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
- unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted
- warnings::warnif "Can't cd to $updir_loc: $!\n";
- next;
- }
- }
- $fullname = $dir_loc; # $File::Find::fullname
- $name = $dir_name; # $File::Find::name
- if ($Is_MacOS) {
- if ($dir_rel eq ':') { # must be the top dir, where we started
- $name =~ s|:$||; # $File::Find::name
- $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
- }
- $dir = $p_dir; # $File::Find::dir
- $_ = ($no_chdir ? $name : $dir_rel); # $_
- }
- else {
- if ( substr($name,-2) eq '/.' ) {
- substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name
- }
- $dir = $p_dir; # $File::Find::dir
- $_ = ($no_chdir ? $dir_name : $dir_rel); # $_
- if ( substr($_,-2) eq '/.' ) {
- substr($_, length($_) == 2 ? -1 : -2) = '';
- }
- }
-
- lstat($_); # make sure file tests with '_' work
- { $wanted_callback->() }; # protect against wild "next"
- }
- else {
- push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if $bydepth;
- last;
- }
- }
- }
-}
-
-
-sub wrap_wanted {
- my $wanted = shift;
- if ( ref($wanted) eq 'HASH' ) {
- if ( $wanted->{follow} || $wanted->{follow_fast}) {
- $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
- }
- if ( $wanted->{untaint} ) {
- $wanted->{untaint_pattern} = $File::Find::untaint_pattern
- unless defined $wanted->{untaint_pattern};
- $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
- }
- return $wanted;
- }
- else {
- return { wanted => $wanted };
- }
-}
-
-sub find {
- my $wanted = shift;
- _find_opt(wrap_wanted($wanted), @_);
-}
-
-sub finddepth {
- my $wanted = wrap_wanted(shift);
- $wanted->{bydepth} = 1;
- _find_opt($wanted, @_);
-}
-
-# default
-$File::Find::skip_pattern = qr/^\.{1,2}\z/;
-$File::Find::untaint_pattern = qr|^([-+@\w./]+)$|;
-
-# These are hard-coded for now, but may move to hint files.
-if ($^O eq 'VMS') {
- $Is_VMS = 1;
- $File::Find::dont_use_nlink = 1;
-}
-elsif ($^O eq 'MacOS') {
- $Is_MacOS = 1;
- $File::Find::dont_use_nlink = 1;
- $File::Find::skip_pattern = qr/^Icon\015\z/;
- $File::Find::untaint_pattern = qr|^(.+)$|;
-}
-
-# this _should_ work properly on all platforms
-# where File::Find can be expected to work
-$File::Find::current_dir = File::Spec->curdir || '.';
-
-$File::Find::dont_use_nlink = 1
- if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' ||
- $^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'epoc' || $^O eq 'qnx' ||
- $^O eq 'nto';
-
-# Set dont_use_nlink in your hint file if your system's stat doesn't
-# report the number of links in a directory as an indication
-# of the number of files.
-# See, e.g. hints/machten.sh for MachTen 2.2.
-unless ($File::Find::dont_use_nlink) {
- require Config;
- $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
-}
-
-# We need a function that checks if a scalar is tainted. Either use the
-# Scalar::Util module's tainted() function or our (slower) pure Perl
-# fallback is_tainted_pp()
-{
- local $@;
- eval { require Scalar::Util };
- *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted;
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Glob.pm b/Master/tlpkg/installer/perllib/File/Glob.pm
deleted file mode 100644
index 133c650529b..00000000000
--- a/Master/tlpkg/installer/perllib/File/Glob.pm
+++ /dev/null
@@ -1,496 +0,0 @@
-package File::Glob;
-
-use strict;
-our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS,
- $AUTOLOAD, $DEFAULT_FLAGS);
-
-use XSLoader ();
-
-@ISA = qw(Exporter);
-
-# NOTE: The glob() export is only here for compatibility with 5.6.0.
-# csh_glob() should not be used directly, unless you know what you're doing.
-
-@EXPORT_OK = qw(
- csh_glob
- bsd_glob
- glob
- GLOB_ABEND
- GLOB_ALPHASORT
- GLOB_ALTDIRFUNC
- GLOB_BRACE
- GLOB_CSH
- GLOB_ERR
- GLOB_ERROR
- GLOB_LIMIT
- GLOB_MARK
- GLOB_NOCASE
- GLOB_NOCHECK
- GLOB_NOMAGIC
- GLOB_NOSORT
- GLOB_NOSPACE
- GLOB_QUOTE
- GLOB_TILDE
-);
-
-%EXPORT_TAGS = (
- 'glob' => [ qw(
- GLOB_ABEND
- GLOB_ALPHASORT
- GLOB_ALTDIRFUNC
- GLOB_BRACE
- GLOB_CSH
- GLOB_ERR
- GLOB_ERROR
- GLOB_LIMIT
- GLOB_MARK
- GLOB_NOCASE
- GLOB_NOCHECK
- GLOB_NOMAGIC
- GLOB_NOSORT
- GLOB_NOSPACE
- GLOB_QUOTE
- GLOB_TILDE
- glob
- bsd_glob
- ) ],
-);
-
-$VERSION = '1.05';
-
-sub import {
- require Exporter;
- my $i = 1;
- while ($i < @_) {
- if ($_[$i] =~ /^:(case|nocase|globally)$/) {
- splice(@_, $i, 1);
- $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case';
- $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase';
- if ($1 eq 'globally') {
- local $^W;
- *CORE::GLOBAL::glob = \&File::Glob::csh_glob;
- }
- next;
- }
- ++$i;
- }
- goto &Exporter::import;
-}
-
-sub AUTOLOAD {
- # This AUTOLOAD is used to 'autoload' constants from the constant()
- # XS function. If a constant is not found then control is passed
- # to the AUTOLOAD in AutoLoader.
-
- my $constname;
- ($constname = $AUTOLOAD) =~ s/.*:://;
- my ($error, $val) = constant($constname);
- if ($error) {
- require Carp;
- Carp::croak($error);
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-XSLoader::load 'File::Glob', $VERSION;
-
-# Preloaded methods go here.
-
-sub GLOB_ERROR {
- return (constant('GLOB_ERROR'))[1];
-}
-
-sub GLOB_CSH () {
- GLOB_BRACE()
- | GLOB_NOMAGIC()
- | GLOB_QUOTE()
- | GLOB_TILDE()
- | GLOB_ALPHASORT()
-}
-
-$DEFAULT_FLAGS = GLOB_CSH();
-if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) {
- $DEFAULT_FLAGS |= GLOB_NOCASE();
-}
-
-# Autoload methods go after =cut, and are processed by the autosplit program.
-
-sub bsd_glob {
- my ($pat,$flags) = @_;
- $flags = $DEFAULT_FLAGS if @_ < 2;
- return doglob($pat,$flags);
-}
-
-# File::Glob::glob() is deprecated because its prototype is different from
-# CORE::glob() (use bsd_glob() instead)
-sub glob {
- splice @_, 1; # don't pass PL_glob_index as flags!
- goto &bsd_glob;
-}
-
-## borrowed heavily from gsar's File::DosGlob
-my %iter;
-my %entries;
-
-sub csh_glob {
- my $pat = shift;
- my $cxix = shift;
- my @pat;
-
- # glob without args defaults to $_
- $pat = $_ unless defined $pat;
-
- # extract patterns
- $pat =~ s/^\s+//; # Protect against empty elements in
- $pat =~ s/\s+$//; # things like < *.c> and <*.c >.
- # These alone shouldn't trigger ParseWords.
- if ($pat =~ /\s/) {
- # XXX this is needed for compatibility with the csh
- # implementation in Perl. Need to support a flag
- # to disable this behavior.
- require Text::ParseWords;
- @pat = Text::ParseWords::parse_line('\s+',0,$pat);
- }
-
- # assume global context if not provided one
- $cxix = '_G_' unless defined $cxix;
- $iter{$cxix} = 0 unless exists $iter{$cxix};
-
- # if we're just beginning, do it all first
- if ($iter{$cxix} == 0) {
- if (@pat) {
- $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ];
- }
- else {
- $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ];
- }
- }
-
- # chuck it all out, quick or slow
- if (wantarray) {
- delete $iter{$cxix};
- return @{delete $entries{$cxix}};
- }
- else {
- if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
- return shift @{$entries{$cxix}};
- }
- else {
- # return undef for EOL
- delete $iter{$cxix};
- delete $entries{$cxix};
- return undef;
- }
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-File::Glob - Perl extension for BSD glob routine
-
-=head1 SYNOPSIS
-
- use File::Glob ':glob';
-
- @list = bsd_glob('*.[ch]');
- $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR);
-
- if (GLOB_ERROR) {
- # an error occurred reading $homedir
- }
-
- ## override the core glob (CORE::glob() does this automatically
- ## by default anyway, since v5.6.0)
- use File::Glob ':globally';
- my @sources = <*.{c,h,y}>;
-
- ## override the core glob, forcing case sensitivity
- use File::Glob qw(:globally :case);
- my @sources = <*.{c,h,y}>;
-
- ## override the core glob forcing case insensitivity
- use File::Glob qw(:globally :nocase);
- my @sources = <*.{c,h,y}>;
-
- ## glob on all files in home directory
- use File::Glob ':globally';
- my @sources = <~gnat/*>;
-
-=head1 DESCRIPTION
-
-The glob angle-bracket operator C<< <> >> is a pathname generator that
-implements the rules for file name pattern matching used by Unix-like shells
-such as the Bourne shell or C shell.
-
-File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is
-a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2").
-bsd_glob() takes a mandatory C<pattern> argument, and an optional
-C<flags> argument, and returns a list of filenames matching the
-pattern, with interpretation of the pattern modified by the C<flags>
-variable.
-
-Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob().
-Note that they don't share the same prototype--CORE::glob() only accepts
-a single argument. Due to historical reasons, CORE::glob() will also
-split its argument on whitespace, treating it as multiple patterns,
-whereas bsd_glob() considers them as one pattern.
-
-=head2 META CHARACTERS
-
- \ Quote the next metacharacter
- [] Character class
- {} Multiple pattern
- * Match any string of characters
- ? Match any single character
- ~ User name home directory
-
-The metanotation C<a{b,c,d}e> is a shorthand for C<abe ace ade>. Left to
-right order is preserved, with results of matches being sorted separately
-at a low level to preserve this order. As a special case C<{>, C<}>, and
-C<{}> are passed undisturbed.
-
-=head2 POSIX FLAGS
-
-The POSIX defined flags for bsd_glob() are:
-
-=over 4
-
-=item C<GLOB_ERR>
-
-Force bsd_glob() to return an error when it encounters a directory it
-cannot open or read. Ordinarily bsd_glob() continues to find matches.
-
-=item C<GLOB_LIMIT>
-
-Make bsd_glob() return an error (GLOB_NOSPACE) when the pattern expands
-to a size bigger than the system constant C<ARG_MAX> (usually found in
-limits.h). If your system does not define this constant, bsd_glob() uses
-C<sysconf(_SC_ARG_MAX)> or C<_POSIX_ARG_MAX> where available (in that
-order). You can inspect these values using the standard C<POSIX>
-extension.
-
-=item C<GLOB_MARK>
-
-Each pathname that is a directory that matches the pattern has a slash
-appended.
-
-=item C<GLOB_NOCASE>
-
-By default, file names are assumed to be case sensitive; this flag
-makes bsd_glob() treat case differences as not significant.
-
-=item C<GLOB_NOCHECK>
-
-If the pattern does not match any pathname, then bsd_glob() returns a list
-consisting of only the pattern. If C<GLOB_QUOTE> is set, its effect
-is present in the pattern returned.
-
-=item C<GLOB_NOSORT>
-
-By default, the pathnames are sorted in ascending ASCII order; this
-flag prevents that sorting (speeding up bsd_glob()).
-
-=back
-
-The FreeBSD extensions to the POSIX standard are the following flags:
-
-=over 4
-
-=item C<GLOB_BRACE>
-
-Pre-process the string to expand C<{pat,pat,...}> strings like csh(1).
-The pattern '{}' is left unexpanded for historical reasons (and csh(1)
-does the same thing to ease typing of find(1) patterns).
-
-=item C<GLOB_NOMAGIC>
-
-Same as C<GLOB_NOCHECK> but it only returns the pattern if it does not
-contain any of the special characters "*", "?" or "[". C<NOMAGIC> is
-provided to simplify implementing the historic csh(1) globbing
-behaviour and should probably not be used anywhere else.
-
-=item C<GLOB_QUOTE>
-
-Use the backslash ('\') character for quoting: every occurrence of a
-backslash followed by a character in the pattern is replaced by that
-character, avoiding any special interpretation of the character.
-(But see below for exceptions on DOSISH systems).
-
-=item C<GLOB_TILDE>
-
-Expand patterns that start with '~' to user name home directories.
-
-=item C<GLOB_CSH>
-
-For convenience, C<GLOB_CSH> is a synonym for
-C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE | GLOB_ALPHASORT>.
-
-=back
-
-The POSIX provided C<GLOB_APPEND>, C<GLOB_DOOFFS>, and the FreeBSD
-extensions C<GLOB_ALTDIRFUNC>, and C<GLOB_MAGCHAR> flags have not been
-implemented in the Perl version because they involve more complex
-interaction with the underlying C structures.
-
-The following flag has been added in the Perl implementation for
-csh compatibility:
-
-=over 4
-
-=item C<GLOB_ALPHASORT>
-
-If C<GLOB_NOSORT> is not in effect, sort filenames is alphabetical
-order (case does not matter) rather than in ASCII order.
-
-=back
-
-=head1 DIAGNOSTICS
-
-bsd_glob() returns a list of matching paths, possibly zero length. If an
-error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be
-set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred,
-or one of the following values otherwise:
-
-=over 4
-
-=item C<GLOB_NOSPACE>
-
-An attempt to allocate memory failed.
-
-=item C<GLOB_ABEND>
-
-The glob was stopped because an error was encountered.
-
-=back
-
-In the case where bsd_glob() has found some matching paths, but is
-interrupted by an error, it will return a list of filenames B<and>
-set &File::Glob::ERROR.
-
-Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour
-by not considering C<ENOENT> and C<ENOTDIR> as errors - bsd_glob() will
-continue processing despite those errors, unless the C<GLOB_ERR> flag is
-set.
-
-Be aware that all filenames returned from File::Glob are tainted.
-
-=head1 NOTES
-
-=over 4
-
-=item *
-
-If you want to use multiple patterns, e.g. C<bsd_glob("a* b*")>, you should
-probably throw them in a set as in C<bsd_glob("{a*,b*}")>. This is because
-the argument to bsd_glob() isn't subjected to parsing by the C shell.
-Remember that you can use a backslash to escape things.
-
-=item *
-
-On DOSISH systems, backslash is a valid directory separator character.
-In this case, use of backslash as a quoting character (via GLOB_QUOTE)
-interferes with the use of backslash as a directory separator. The
-best (simplest, most portable) solution is to use forward slashes for
-directory separators, and backslashes for quoting. However, this does
-not match "normal practice" on these systems. As a concession to user
-expectation, therefore, backslashes (under GLOB_QUOTE) only quote the
-glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself.
-All other backslashes are passed through unchanged.
-
-=item *
-
-Win32 users should use the real slash. If you really want to use
-backslashes, consider using Sarathy's File::DosGlob, which comes with
-the standard Perl distribution.
-
-=item *
-
-Mac OS (Classic) users should note a few differences. Since
-Mac OS is not Unix, when the glob code encounters a tilde glob (e.g.
-~user) and the C<GLOB_TILDE> flag is used, it simply returns that
-pattern without doing any expansion.
-
-Glob on Mac OS is case-insensitive by default (if you don't use any
-flags). If you specify any flags at all and still want glob
-to be case-insensitive, you must include C<GLOB_NOCASE> in the flags.
-
-The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users
-should be careful about specifying relative pathnames. While a full path
-always begins with a volume name, a relative pathname should always
-begin with a ':'. If specifying a volume name only, a trailing ':' is
-required.
-
-The specification of pathnames in glob patterns adheres to the usual Mac
-OS conventions: The path separator is a colon ':', not a slash '/'. A
-full path always begins with a volume name. A relative pathname on Mac
-OS must always begin with a ':', except when specifying a file or
-directory name in the current working directory, where the leading colon
-is optional. If specifying a volume name only, a trailing ':' is
-required. Due to these rules, a glob like E<lt>*:E<gt> will find all
-mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find
-all files and directories in the current directory.
-
-Note that updirs in the glob pattern are resolved before the matching begins,
-i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also,
-that a single trailing ':' in the pattern is ignored (unless it's a volume
-name pattern like "*HD:"), i.e. a glob like E<lt>:*:E<gt> will find both
-directories I<and> files (and not, as one might expect, only directories).
-You can, however, use the C<GLOB_MARK> flag to distinguish (without a file
-test) directory names from file names.
-
-If the C<GLOB_MARK> flag is set, all directory paths will have a ':' appended.
-Since a directory like 'lib:' is I<not> a valid I<relative> path on Mac OS,
-both a leading and a trailing colon will be added, when the directory name in
-question doesn't contain any colons (e.g. 'lib' becomes ':lib:').
-
-=back
-
-=head1 SEE ALSO
-
-L<perlfunc/glob>, glob(3)
-
-=head1 AUTHOR
-
-The Perl interface was written by Nathan Torkington E<lt>gnat@frii.comE<gt>,
-and is released under the artistic license. Further modifications were
-made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt>, Gurusamy Sarathy
-E<lt>gsar@activestate.comE<gt>, and Thomas Wegner
-E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the
-following copyright:
-
- Copyright (c) 1989, 1993 The Regents of the University of California.
- All rights reserved.
-
- This code is derived from software contributed to Berkeley by
- Guido van Rossum.
-
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions
- are met:
-
- 1. Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
- 2. Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer in the
- documentation and/or other materials provided with the distribution.
- 3. Neither the name of the University nor the names of its contributors
- may be used to endorse or promote products derived from this software
- without specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- SUCH DAMAGE.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/File/Path.pm b/Master/tlpkg/installer/perllib/File/Path.pm
deleted file mode 100644
index 2e41ff3f77f..00000000000
--- a/Master/tlpkg/installer/perllib/File/Path.pm
+++ /dev/null
@@ -1,285 +0,0 @@
-package File::Path;
-
-=head1 NAME
-
-File::Path - create or remove directory trees
-
-=head1 SYNOPSIS
-
- use File::Path;
-
- mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
- rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
-
-=head1 DESCRIPTION
-
-The C<mkpath> function provides a convenient way to create directories, even
-if your C<mkdir> kernel call won't create more than one level of directory at
-a time. C<mkpath> takes three arguments:
-
-=over 4
-
-=item *
-
-the name of the path to create, or a reference
-to a list of paths to create,
-
-=item *
-
-a boolean value, which if TRUE will cause C<mkpath>
-to print the name of each directory as it is created
-(defaults to FALSE), and
-
-=item *
-
-the numeric mode to use when creating the directories
-(defaults to 0777), to be modified by the current umask.
-
-=back
-
-It returns a list of all directories (including intermediates, determined
-using the Unix '/' separator) created.
-
-If a system error prevents a directory from being created, then the
-C<mkpath> function throws a fatal error with C<Carp::croak>. This error
-can be trapped with an C<eval> block:
-
- eval { mkpath($dir) };
- if ($@) {
- print "Couldn't create $dir: $@";
- }
-
-Similarly, the C<rmtree> function provides a convenient way to delete a
-subtree from the directory structure, much like the Unix command C<rm -r>.
-C<rmtree> takes three arguments:
-
-=over 4
-
-=item *
-
-the root of the subtree to delete, or a reference to
-a list of roots. All of the files and directories
-below each root, as well as the roots themselves,
-will be deleted.
-
-=item *
-
-a boolean value, which if TRUE will cause C<rmtree> to
-print a message each time it examines a file, giving the
-name of the file, and indicating whether it's using C<rmdir>
-or C<unlink> to remove it, or that it's skipping it.
-(defaults to FALSE)
-
-=item *
-
-a boolean value, which if TRUE will cause C<rmtree> to
-skip any files to which you do not have delete access
-(if running under VMS) or write access (if running
-under another OS). This will change in the future when
-a criterion for 'delete permission' under OSs other
-than VMS is settled. (defaults to FALSE)
-
-=back
-
-It returns the number of files successfully deleted. Symlinks are
-simply deleted and not followed.
-
-B<NOTE:> There are race conditions internal to the implementation of
-C<rmtree> making it unsafe to use on directory trees which may be
-altered or moved while C<rmtree> is running, and in particular on any
-directory trees with any path components or subdirectories potentially
-writable by untrusted users.
-
-Additionally, if the third parameter is not TRUE and C<rmtree> is
-interrupted, it may leave files and directories with permissions altered
-to allow deletion (and older versions of this module would even set
-files and directories to world-read/writable!)
-
-Note also that the occurrence of errors in C<rmtree> can be determined I<only>
-by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent
-from the return value.
-
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item *
-
-On Windows, if C<mkpath> gives you the warning: B<No such file or
-directory>, this may mean that you've exceeded your filesystem's
-maximum path length.
-
-=back
-
-=head1 AUTHORS
-
-Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
-Charles Bailey <F<bailey@newman.upenn.edu>>
-
-=cut
-
-use 5.006;
-use Carp;
-use File::Basename ();
-use Exporter ();
-use strict;
-use warnings;
-
-our $VERSION = "1.08";
-our @ISA = qw( Exporter );
-our @EXPORT = qw( mkpath rmtree );
-
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-# These OSes complain if you want to remove a file that you have no
-# write permission to:
-my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
- $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
-
-sub mkpath {
- my($paths, $verbose, $mode) = @_;
- # $paths -- either a path string or ref to list of paths
- # $verbose -- optional print "mkdir $path" for each directory created
- # $mode -- optional permissions, defaults to 0777
- local($")=$Is_MacOS ? ":" : "/";
- $mode = 0777 unless defined($mode);
- $paths = [$paths] unless ref $paths;
- my(@created,$path);
- foreach $path (@$paths) {
- $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT
- # Logic wants Unix paths, so go with the flow.
- if ($Is_VMS) {
- next if $path eq '/';
- $path = VMS::Filespec::unixify($path);
- if ($path =~ m:^(/[^/]+)/?\z:) {
- $path = $1.'/000000';
- }
- }
- next if -d $path;
- my $parent = File::Basename::dirname($path);
- unless (-d $parent or $path eq $parent) {
- push(@created,mkpath($parent, $verbose, $mode));
- }
- print "mkdir $path\n" if $verbose;
- unless (mkdir($path,$mode)) {
- my $e = $!;
- # allow for another process to have created it meanwhile
- $! = $e, croak ("mkdir $path: $e") unless -d $path;
- }
- push(@created, $path);
- }
- @created;
-}
-
-sub rmtree {
- my($roots, $verbose, $safe) = @_;
- my(@files);
- my($count) = 0;
- $verbose ||= 0;
- $safe ||= 0;
-
- if ( defined($roots) && length($roots) ) {
- $roots = [$roots] unless ref $roots;
- }
- else {
- carp "No root path(s) specified\n";
- return 0;
- }
-
- my($root);
- foreach $root (@{$roots}) {
- if ($Is_MacOS) {
- $root = ":$root" if $root !~ /:/;
- $root =~ s#([^:])\z#$1:#;
- } else {
- $root =~ s#/\z##;
- }
- (undef, undef, my $rp) = lstat $root or next;
- $rp &= 07777; # don't forget setuid, setgid, sticky bits
- if ( -d _ ) {
- # notabene: 0700 is for making readable in the first place,
- # it's also intended to change it to writable in case we have
- # to recurse in which case we are better than rm -rf for
- # subtrees with strange permissions
- chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- or carp "Can't make directory $root read+writeable: $!"
- unless $safe;
-
- if (opendir my $d, $root) {
- no strict 'refs';
- if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
- # Blindly untaint dir names
- @files = map { /^(.*)$/s ; $1 } readdir $d;
- } else {
- @files = readdir $d;
- }
- closedir $d;
- }
- else {
- carp "Can't read $root: $!";
- @files = ();
- }
-
- # Deleting large numbers of files from VMS Files-11 filesystems
- # is faster if done in reverse ASCIIbetical order
- @files = reverse @files if $Is_VMS;
- ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
- if ($Is_MacOS) {
- @files = map("$root$_", @files);
- } else {
- @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
- }
- $count += rmtree(\@files,$verbose,$safe);
- if ($safe &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
- print "skipped $root\n" if $verbose;
- next;
- }
- chmod $rp | 0700, $root
- or carp "Can't make directory $root writeable: $!"
- if $force_writeable;
- print "rmdir $root\n" if $verbose;
- if (rmdir $root) {
- ++$count;
- }
- else {
- carp "Can't remove directory $root: $!";
- chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- or carp("and can't restore permissions to "
- . sprintf("0%o",$rp) . "\n");
- }
- }
- else {
- if ($safe &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root)
- : !(-l $root || -w $root)))
- {
- print "skipped $root\n" if $verbose;
- next;
- }
- chmod $rp | 0600, $root
- or carp "Can't make file $root writeable: $!"
- if $force_writeable;
- print "unlink $root\n" if $verbose;
- # delete all versions under VMS
- for (;;) {
- unless (unlink $root) {
- carp "Can't unlink file $root: $!";
- if ($force_writeable) {
- chmod $rp, $root
- or carp("and can't restore permissions to "
- . sprintf("0%o",$rp) . "\n");
- }
- last;
- }
- ++$count;
- last unless $Is_VMS && lstat $root;
- }
- }
- }
-
- $count;
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Spec.pm b/Master/tlpkg/installer/perllib/File/Spec.pm
deleted file mode 100644
index 0c8cd21e057..00000000000
--- a/Master/tlpkg/installer/perllib/File/Spec.pm
+++ /dev/null
@@ -1,322 +0,0 @@
-package File::Spec;
-
-use strict;
-use vars qw(@ISA $VERSION);
-
-$VERSION = '3.12';
-$VERSION = eval $VERSION;
-
-my %module = (MacOS => 'Mac',
- MSWin32 => 'Win32',
- os2 => 'OS2',
- VMS => 'VMS',
- epoc => 'Epoc',
- NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
- symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
- dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP.
- cygwin => 'Cygwin');
-
-
-my $module = $module{$^O} || 'Unix';
-
-require "File/Spec/$module.pm";
-@ISA = ("File::Spec::$module");
-
-1;
-
-__END__
-
-=head1 NAME
-
-File::Spec - portably perform operations on file names
-
-=head1 SYNOPSIS
-
- use File::Spec;
-
- $x=File::Spec->catfile('a', 'b', 'c');
-
-which returns 'a/b/c' under Unix. Or:
-
- use File::Spec::Functions;
-
- $x = catfile('a', 'b', 'c');
-
-=head1 DESCRIPTION
-
-This module is designed to support operations commonly performed on file
-specifications (usually called "file names", but not to be confused with the
-contents of a file, or Perl's file handles), such as concatenating several
-directory and file names into a single path, or determining whether a path
-is rooted. It is based on code directly taken from MakeMaker 5.17, code
-written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
-Zakharevich, Paul Schinder, and others.
-
-Since these functions are different for most operating systems, each set of
-OS specific routines is available in a separate module, including:
-
- File::Spec::Unix
- File::Spec::Mac
- File::Spec::OS2
- File::Spec::Win32
- File::Spec::VMS
-
-The module appropriate for the current OS is automatically loaded by
-File::Spec. Since some modules (like VMS) make use of facilities available
-only under that OS, it may not be possible to load all modules under all
-operating systems.
-
-Since File::Spec is object oriented, subroutines should not be called directly,
-as in:
-
- File::Spec::catfile('a','b');
-
-but rather as class methods:
-
- File::Spec->catfile('a','b');
-
-For simple uses, L<File::Spec::Functions> provides convenient functional
-forms of these methods.
-
-=head1 METHODS
-
-=over 2
-
-=item canonpath
-
-No physical check on the filesystem, but a logical cleanup of a
-path.
-
- $cpath = File::Spec->canonpath( $path ) ;
-
-Note that this does *not* collapse F<x/../y> sections into F<y>. This
-is by design. If F</foo> on your system is a symlink to F</bar/baz>,
-then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
-F<../>-removal would give you. If you want to do this kind of
-processing, you probably want C<Cwd>'s C<realpath()> function to
-actually traverse the filesystem cleaning up paths like this.
-
-=item catdir
-
-Concatenate two or more directory names to form a complete path ending
-with a directory. But remove the trailing slash from the resulting
-string, because it doesn't look good, isn't necessary and confuses
-OS/2. Of course, if this is the root directory, don't cut off the
-trailing slash :-)
-
- $path = File::Spec->catdir( @directories );
-
-=item catfile
-
-Concatenate one or more directory names and a filename to form a
-complete path ending with a filename
-
- $path = File::Spec->catfile( @directories, $filename );
-
-=item curdir
-
-Returns a string representation of the current directory.
-
- $curdir = File::Spec->curdir();
-
-=item devnull
-
-Returns a string representation of the null device.
-
- $devnull = File::Spec->devnull();
-
-=item rootdir
-
-Returns a string representation of the root directory.
-
- $rootdir = File::Spec->rootdir();
-
-=item tmpdir
-
-Returns a string representation of the first writable directory from a
-list of possible temporary directories. Returns the current directory
-if no writable temporary directories are found. The list of directories
-checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}>
-(unless taint is on) and F</tmp>.
-
- $tmpdir = File::Spec->tmpdir();
-
-=item updir
-
-Returns a string representation of the parent directory.
-
- $updir = File::Spec->updir();
-
-=item no_upwards
-
-Given a list of file names, strip out those that refer to a parent
-directory. (Does not strip symlinks, only '.', '..', and equivalents.)
-
- @paths = File::Spec->no_upwards( @paths );
-
-=item case_tolerant
-
-Returns a true or false value indicating, respectively, that alphabetic
-case is not or is significant when comparing file specifications.
-
- $is_case_tolerant = File::Spec->case_tolerant();
-
-=item file_name_is_absolute
-
-Takes as its argument a path, and returns true if it is an absolute path.
-
- $is_absolute = File::Spec->file_name_is_absolute( $path );
-
-This does not consult the local filesystem on Unix, Win32, OS/2, or
-Mac OS (Classic). It does consult the working environment for VMS
-(see L<File::Spec::VMS/file_name_is_absolute>).
-
-=item path
-
-Takes no argument. Returns the environment variable C<PATH> (or the local
-platform's equivalent) as a list.
-
- @PATH = File::Spec->path();
-
-=item join
-
-join is the same as catfile.
-
-=item splitpath
-
-Splits a path in to volume, directory, and filename portions. On systems
-with no concept of volume, returns '' for volume.
-
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
-
-For systems with no syntax differentiating filenames from directories,
-assumes that the last file is a path unless C<$no_file> is true or a
-trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
-true makes this return ( '', $path, '' ).
-
-The directory portion may or may not be returned with a trailing '/'.
-
-The results can be passed to L</catpath()> to get back a path equivalent to
-(usually identical to) the original path.
-
-=item splitdir
-
-The opposite of L</catdir()>.
-
- @dirs = File::Spec->splitdir( $directories );
-
-C<$directories> must be only the directory portion of the path on systems
-that have the concept of a volume or that have path syntax that differentiates
-files from directories.
-
-Unlike just splitting the directories on the separator, empty
-directory names (C<''>) can be returned, because these are significant
-on some OSes.
-
-=item catpath()
-
-Takes volume, directory and file portions and returns an entire path. Under
-Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is
-inserted if need be. On other OSes, C<$volume> is significant.
-
- $full_path = File::Spec->catpath( $volume, $directory, $file );
-
-=item abs2rel
-
-Takes a destination path and an optional base path returns a relative path
-from the base path to the destination path:
-
- $rel_path = File::Spec->abs2rel( $path ) ;
- $rel_path = File::Spec->abs2rel( $path, $base ) ;
-
-If C<$base> is not present or '', then L<cwd()|Cwd> is used. If C<$base> is
-relative, then it is converted to absolute form using
-L</rel2abs()>. This means that it is taken to be relative to
-L<cwd()|Cwd>.
-
-On systems with the concept of volume, if C<$path> and C<$base> appear to be
-on two different volumes, we will not attempt to resolve the two
-paths, and we will instead simply return C<$path>. Note that previous
-versions of this module ignored the volume of C<$base>, which resulted in
-garbage results part of the time.
-
-On systems that have a grammar that indicates filenames, this ignores the
-C<$base> filename as well. Otherwise all path components are assumed to be
-directories.
-
-If C<$path> is relative, it is converted to absolute form using L</rel2abs()>.
-This means that it is taken to be relative to L<cwd()|Cwd>.
-
-No checks against the filesystem are made. On VMS, there is
-interaction with the working environment, as logicals and
-macros are expanded.
-
-Based on code written by Shigio Yamaguchi.
-
-=item rel2abs()
-
-Converts a relative path to an absolute path.
-
- $abs_path = File::Spec->rel2abs( $path ) ;
- $abs_path = File::Spec->rel2abs( $path, $base ) ;
-
-If C<$base> is not present or '', then L<cwd()|Cwd> is used. If C<$base> is relative,
-then it is converted to absolute form using L</rel2abs()>. This means that it
-is taken to be relative to L<cwd()|Cwd>.
-
-On systems with the concept of volume, if C<$path> and C<$base> appear to be
-on two different volumes, we will not attempt to resolve the two
-paths, and we will instead simply return C<$path>. Note that previous
-versions of this module ignored the volume of C<$base>, which resulted in
-garbage results part of the time.
-
-On systems that have a grammar that indicates filenames, this ignores the
-C<$base> filename as well. Otherwise all path components are assumed to be
-directories.
-
-If C<$path> is absolute, it is cleaned up and returned using L</canonpath()>.
-
-No checks against the filesystem are made. On VMS, there is
-interaction with the working environment, as logicals and
-macros are expanded.
-
-Based on code written by Shigio Yamaguchi.
-
-=back
-
-For further information, please see L<File::Spec::Unix>,
-L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or
-L<File::Spec::VMS>.
-
-=head1 SEE ALSO
-
-L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>,
-L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>,
-L<ExtUtils::MakeMaker>
-
-=head1 AUTHOR
-
-Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>.
-
-The vast majority of the code was written by
-Kenneth Albanowski C<< <kjahds@kjahds.com> >>,
-Andy Dougherty C<< <doughera@lafayette.edu> >>,
-Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>,
-Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>.
-VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>.
-OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>.
-Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and
-Thomas Wegner C<< <wegner_thomas@yahoo.com> >>.
-abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>,
-modified by Barrie Slaymaker C<< <barries@slaysys.com> >>.
-splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm b/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm
deleted file mode 100644
index 19a2937c6b9..00000000000
--- a/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm
+++ /dev/null
@@ -1,93 +0,0 @@
-package File::Spec::Cygwin;
-
-use strict;
-use vars qw(@ISA $VERSION);
-require File::Spec::Unix;
-
-$VERSION = '1.1';
-
-@ISA = qw(File::Spec::Unix);
-
-=head1 NAME
-
-File::Spec::Cygwin - methods for Cygwin file specs
-
-=head1 SYNOPSIS
-
- require File::Spec::Cygwin; # Done internally by File::Spec if needed
-
-=head1 DESCRIPTION
-
-See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
-implementation of these methods, not the semantics.
-
-This module is still in beta. Cygwin-knowledgeable folks are invited
-to offer patches and suggestions.
-
-=cut
-
-=pod
-
-=over 4
-
-=item canonpath
-
-Any C<\> (backslashes) are converted to C</> (forward slashes),
-and then File::Spec::Unix canonpath() is called on the result.
-
-=cut
-
-sub canonpath {
- my($self,$path) = @_;
- $path =~ s|\\|/|g;
- return $self->SUPER::canonpath($path);
-}
-
-=pod
-
-=item file_name_is_absolute
-
-True is returned if the file name begins with C<drive_letter:>,
-and if not, File::Spec::Unix file_name_is_absolute() is called.
-
-=cut
-
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test
- return $self->SUPER::file_name_is_absolute($file);
-}
-
-=item tmpdir (override)
-
-Returns a string representation of the first existing directory
-from the following list:
-
- $ENV{TMPDIR}
- /tmp
- C:/temp
-
-Since Perl 5.8.0, if running under taint mode, and if the environment
-variables are tainted, they are not used.
-
-=cut
-
-my $tmpdir;
-sub tmpdir {
- return $tmpdir if defined $tmpdir;
- $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", 'C:/temp' );
-}
-
-=back
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm b/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm
deleted file mode 100644
index a7168f9e494..00000000000
--- a/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm
+++ /dev/null
@@ -1,77 +0,0 @@
-package File::Spec::Epoc;
-
-use strict;
-use vars qw($VERSION @ISA);
-
-$VERSION = '1.1';
-
-require File::Spec::Unix;
-@ISA = qw(File::Spec::Unix);
-
-=head1 NAME
-
-File::Spec::Epoc - methods for Epoc file specs
-
-=head1 SYNOPSIS
-
- require File::Spec::Epoc; # Done internally by File::Spec if needed
-
-=head1 DESCRIPTION
-
-See File::Spec::Unix for a documentation of the methods provided
-there. This package overrides the implementation of these methods, not
-the semantics.
-
-This package is still work in progress ;-)
-
-=cut
-
-sub case_tolerant {
- return 1;
-}
-
-=pod
-
-=over 4
-
-=item canonpath()
-
-No physical check on the filesystem, but a logical cleanup of a
-path. On UNIX eliminated successive slashes and successive "/.".
-
-=back
-
-=cut
-
-sub canonpath {
- my ($self,$path) = @_;
-
- $path =~ s|/+|/|g; # xx////xx -> xx/xx
- $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
- $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
- $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx
- $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
- return $path;
-}
-
-=pod
-
-=head1 AUTHOR
-
-o.flebbe@gmx.de
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
-implementation of these methods, not the semantics.
-
-=cut
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Spec/Functions.pm b/Master/tlpkg/installer/perllib/File/Spec/Functions.pm
deleted file mode 100644
index 38c898c5d8f..00000000000
--- a/Master/tlpkg/installer/perllib/File/Spec/Functions.pm
+++ /dev/null
@@ -1,109 +0,0 @@
-package File::Spec::Functions;
-
-use File::Spec;
-use strict;
-
-use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-
-$VERSION = '1.3';
-
-require Exporter;
-
-@ISA = qw(Exporter);
-
-@EXPORT = qw(
- canonpath
- catdir
- catfile
- curdir
- rootdir
- updir
- no_upwards
- file_name_is_absolute
- path
-);
-
-@EXPORT_OK = qw(
- devnull
- tmpdir
- splitpath
- splitdir
- catpath
- abs2rel
- rel2abs
- case_tolerant
-);
-
-%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
-
-foreach my $meth (@EXPORT, @EXPORT_OK) {
- my $sub = File::Spec->can($meth);
- no strict 'refs';
- *{$meth} = sub {&$sub('File::Spec', @_)};
-}
-
-
-1;
-__END__
-
-=head1 NAME
-
-File::Spec::Functions - portably perform operations on file names
-
-=head1 SYNOPSIS
-
- use File::Spec::Functions;
- $x = catfile('a','b');
-
-=head1 DESCRIPTION
-
-This module exports convenience functions for all of the class methods
-provided by File::Spec.
-
-For a reference of available functions, please consult L<File::Spec::Unix>,
-which contains the entire set, and which is inherited by the modules for
-other platforms. For further information, please see L<File::Spec::Mac>,
-L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>.
-
-=head2 Exports
-
-The following functions are exported by default.
-
- canonpath
- catdir
- catfile
- curdir
- rootdir
- updir
- no_upwards
- file_name_is_absolute
- path
-
-
-The following functions are exported only by request.
-
- devnull
- tmpdir
- splitpath
- splitdir
- catpath
- abs2rel
- rel2abs
- case_tolerant
-
-All the functions may be imported using the C<:ALL> tag.
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2,
-File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/File/Spec/Mac.pm b/Master/tlpkg/installer/perllib/File/Spec/Mac.pm
deleted file mode 100644
index 8b51bd6c249..00000000000
--- a/Master/tlpkg/installer/perllib/File/Spec/Mac.pm
+++ /dev/null
@@ -1,780 +0,0 @@
-package File::Spec::Mac;
-
-use strict;
-use vars qw(@ISA $VERSION);
-require File::Spec::Unix;
-
-$VERSION = '1.4';
-
-@ISA = qw(File::Spec::Unix);
-
-my $macfiles;
-if ($^O eq 'MacOS') {
- $macfiles = eval { require Mac::Files };
-}
-
-sub case_tolerant { 1 }
-
-
-=head1 NAME
-
-File::Spec::Mac - File::Spec for Mac OS (Classic)
-
-=head1 SYNOPSIS
-
- require File::Spec::Mac; # Done internally by File::Spec if needed
-
-=head1 DESCRIPTION
-
-Methods for manipulating file specifications.
-
-=head1 METHODS
-
-=over 2
-
-=item canonpath
-
-On Mac OS, there's nothing to be done. Returns what it's given.
-
-=cut
-
-sub canonpath {
- my ($self,$path) = @_;
- return $path;
-}
-
-=item catdir()
-
-Concatenate two or more directory names to form a path separated by colons
-(":") ending with a directory. Resulting paths are B<relative> by default,
-but can be forced to be absolute (but avoid this, see below). Automatically
-puts a trailing ":" on the end of the complete path, because that's what's
-done in MacPerl's environment and helps to distinguish a file path from a
-directory path.
-
-B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting
-path is relative by default and I<not> absolute. This decision was made due
-to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths
-on all other operating systems, it will now also follow this convention on Mac
-OS. Note that this may break some existing scripts.
-
-The intended purpose of this routine is to concatenate I<directory names>.
-But because of the nature of Macintosh paths, some additional possibilities
-are allowed to make using this routine give reasonable results for some
-common situations. In other words, you are also allowed to concatenate
-I<paths> instead of directory names (strictly speaking, a string like ":a"
-is a path, but not a name, since it contains a punctuation character ":").
-
-So, beside calls like
-
- catdir("a") = ":a:"
- catdir("a","b") = ":a:b:"
- catdir() = "" (special case)
-
-calls like the following
-
- catdir(":a:") = ":a:"
- catdir(":a","b") = ":a:b:"
- catdir(":a:","b") = ":a:b:"
- catdir(":a:",":b:") = ":a:b:"
- catdir(":") = ":"
-
-are allowed.
-
-Here are the rules that are used in C<catdir()>; note that we try to be as
-compatible as possible to Unix:
-
-=over 2
-
-=item 1.
-
-The resulting path is relative by default, i.e. the resulting path will have a
-leading colon.
-
-=item 2.
-
-A trailing colon is added automatically to the resulting path, to denote a
-directory.
-
-=item 3.
-
-Generally, each argument has one leading ":" and one trailing ":"
-removed (if any). They are then joined together by a ":". Special
-treatment applies for arguments denoting updir paths like "::lib:",
-see (4), or arguments consisting solely of colons ("colon paths"),
-see (5).
-
-=item 4.
-
-When an updir path like ":::lib::" is passed as argument, the number
-of directories to climb up is handled correctly, not removing leading
-or trailing colons when necessary. E.g.
-
- catdir(":::a","::b","c") = ":::a::b:c:"
- catdir(":::a::","::b","c") = ":::a:::b:c:"
-
-=item 5.
-
-Adding a colon ":" or empty string "" to a path at I<any> position
-doesn't alter the path, i.e. these arguments are ignored. (When a ""
-is passed as the first argument, it has a special meaning, see
-(6)). This way, a colon ":" is handled like a "." (curdir) on Unix,
-while an empty string "" is generally ignored (see
-C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".."
-(updir), and a ":::" is handled like a "../.." etc. E.g.
-
- catdir("a",":",":","b") = ":a:b:"
- catdir("a",":","::",":b") = ":a::b:"
-
-=item 6.
-
-If the first argument is an empty string "" or is a volume name, i.e. matches
-the pattern /^[^:]+:/, the resulting path is B<absolute>.
-
-=item 7.
-
-Passing an empty string "" as the first argument to C<catdir()> is
-like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e.
-
- catdir("","a","b") is the same as
-
- catdir(rootdir(),"a","b").
-
-This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and
-C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup
-volume, which is the closest in concept to Unix' "/". This should help
-to run existing scripts originally written for Unix.
-
-=item 8.
-
-For absolute paths, some cleanup is done, to ensure that the volume
-name isn't immediately followed by updirs. This is invalid, because
-this would go beyond "root". Generally, these cases are handled like
-their Unix counterparts:
-
- Unix:
- Unix->catdir("","") = "/"
- Unix->catdir("",".") = "/"
- Unix->catdir("","..") = "/" # can't go beyond root
- Unix->catdir("",".","..","..","a") = "/a"
- Mac:
- Mac->catdir("","") = rootdir() # (e.g. "HD:")
- Mac->catdir("",":") = rootdir()
- Mac->catdir("","::") = rootdir() # can't go beyond root
- Mac->catdir("",":","::","::","a") = rootdir() . "a:" # (e.g. "HD:a:")
-
-However, this approach is limited to the first arguments following
-"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more
-arguments that move up the directory tree, an invalid path going
-beyond root can be created.
-
-=back
-
-As you've seen, you can force C<catdir()> to create an absolute path
-by passing either an empty string or a path that begins with a volume
-name as the first argument. However, you are strongly encouraged not
-to do so, since this is done only for backward compatibility. Newer
-versions of File::Spec come with a method called C<catpath()> (see
-below), that is designed to offer a portable solution for the creation
-of absolute paths. It takes volume, directory and file portions and
-returns an entire path. While C<catdir()> is still suitable for the
-concatenation of I<directory names>, you are encouraged to use
-C<catpath()> to concatenate I<volume names> and I<directory
-paths>. E.g.
-
- $dir = File::Spec->catdir("tmp","sources");
- $abs_path = File::Spec->catpath("MacintoshHD:", $dir,"");
-
-yields
-
- "MacintoshHD:tmp:sources:" .
-
-=cut
-
-sub catdir {
- my $self = shift;
- return '' unless @_;
- my @args = @_;
- my $first_arg;
- my $relative;
-
- # take care of the first argument
-
- if ($args[0] eq '') { # absolute path, rootdir
- shift @args;
- $relative = 0;
- $first_arg = $self->rootdir;
-
- } elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name
- $relative = 0;
- $first_arg = shift @args;
- # add a trailing ':' if need be (may be it's a path like HD:dir)
- $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
-
- } else { # relative path
- $relative = 1;
- if ( $args[0] =~ /^::+\Z(?!\n)/ ) {
- # updir colon path ('::', ':::' etc.), don't shift
- $first_arg = ':';
- } elsif ($args[0] eq ':') {
- $first_arg = shift @args;
- } else {
- # add a trailing ':' if need be
- $first_arg = shift @args;
- $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
- }
- }
-
- # For all other arguments,
- # (a) ignore arguments that equal ':' or '',
- # (b) handle updir paths specially:
- # '::' -> concatenate '::'
- # '::' . '::' -> concatenate ':::' etc.
- # (c) add a trailing ':' if need be
-
- my $result = $first_arg;
- while (@args) {
- my $arg = shift @args;
- unless (($arg eq '') || ($arg eq ':')) {
- if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::'
- my $updir_count = length($arg) - 1;
- while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path
- $arg = shift @args;
- $updir_count += (length($arg) - 1);
- }
- $arg = (':' x $updir_count);
- } else {
- $arg =~ s/^://s; # remove a leading ':' if any
- $arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':'
- }
- $result .= $arg;
- }#unless
- }
-
- if ( ($relative) && ($result !~ /^:/) ) {
- # add a leading colon if need be
- $result = ":$result";
- }
-
- unless ($relative) {
- # remove updirs immediately following the volume name
- $result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/;
- }
-
- return $result;
-}
-
-=item catfile
-
-Concatenate one or more directory names and a filename to form a
-complete path ending with a filename. Resulting paths are B<relative>
-by default, but can be forced to be absolute (but avoid this).
-
-B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the
-resulting path is relative by default and I<not> absolute. This
-decision was made due to portability reasons. Since
-C<File::Spec-E<gt>catfile()> returns relative paths on all other
-operating systems, it will now also follow this convention on Mac OS.
-Note that this may break some existing scripts.
-
-The last argument is always considered to be the file portion. Since
-C<catfile()> uses C<catdir()> (see above) for the concatenation of the
-directory portions (if any), the following with regard to relative and
-absolute paths is true:
-
- catfile("") = ""
- catfile("file") = "file"
-
-but
-
- catfile("","") = rootdir() # (e.g. "HD:")
- catfile("","file") = rootdir() . file # (e.g. "HD:file")
- catfile("HD:","file") = "HD:file"
-
-This means that C<catdir()> is called only when there are two or more
-arguments, as one might expect.
-
-Note that the leading ":" is removed from the filename, so that
-
- catfile("a","b","file") = ":a:b:file" and
-
- catfile("a","b",":file") = ":a:b:file"
-
-give the same answer.
-
-To concatenate I<volume names>, I<directory paths> and I<filenames>,
-you are encouraged to use C<catpath()> (see below).
-
-=cut
-
-sub catfile {
- my $self = shift;
- return '' unless @_;
- my $file = pop @_;
- return $file unless @_;
- my $dir = $self->catdir(@_);
- $file =~ s/^://s;
- return $dir.$file;
-}
-
-=item curdir
-
-Returns a string representing the current directory. On Mac OS, this is ":".
-
-=cut
-
-sub curdir {
- return ":";
-}
-
-=item devnull
-
-Returns a string representing the null device. On Mac OS, this is "Dev:Null".
-
-=cut
-
-sub devnull {
- return "Dev:Null";
-}
-
-=item rootdir
-
-Returns a string representing the root directory. Under MacPerl,
-returns the name of the startup volume, since that's the closest in
-concept, although other volumes aren't rooted there. The name has a
-trailing ":", because that's the correct specification for a volume
-name on Mac OS.
-
-If Mac::Files could not be loaded, the empty string is returned.
-
-=cut
-
-sub rootdir {
-#
-# There's no real root directory on Mac OS. The name of the startup
-# volume is returned, since that's the closest in concept.
-#
- return '' unless $macfiles;
- my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
- &Mac::Files::kSystemFolderType);
- $system =~ s/:.*\Z(?!\n)/:/s;
- return $system;
-}
-
-=item tmpdir
-
-Returns the contents of $ENV{TMPDIR}, if that directory exits or the
-current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will
-contain a path like "MacintoshHD:Temporary Items:", which is a hidden
-directory on your startup volume.
-
-=cut
-
-my $tmpdir;
-sub tmpdir {
- return $tmpdir if defined $tmpdir;
- $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR} );
-}
-
-=item updir
-
-Returns a string representing the parent directory. On Mac OS, this is "::".
-
-=cut
-
-sub updir {
- return "::";
-}
-
-=item file_name_is_absolute
-
-Takes as argument a path and returns true, if it is an absolute path.
-If the path has a leading ":", it's a relative path. Otherwise, it's an
-absolute path, unless the path doesn't contain any colons, i.e. it's a name
-like "a". In this particular case, the path is considered to be relative
-(i.e. it is considered to be a filename). Use ":" in the appropriate place
-in the path if you want to distinguish unambiguously. As a special case,
-the filename '' is always considered to be absolute. Note that with version
-1.2 of File::Spec::Mac, this does no longer consult the local filesystem.
-
-E.g.
-
- File::Spec->file_name_is_absolute("a"); # false (relative)
- File::Spec->file_name_is_absolute(":a:b:"); # false (relative)
- File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute)
- File::Spec->file_name_is_absolute(""); # true (absolute)
-
-
-=cut
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- if ($file =~ /:/) {
- return (! ($file =~ m/^:/s) );
- } elsif ( $file eq '' ) {
- return 1 ;
- } else {
- return 0; # i.e. a file like "a"
- }
-}
-
-=item path
-
-Returns the null list for the MacPerl application, since the concept is
-usually meaningless under Mac OS. But if you're using the MacPerl tool under
-MPW, it gives back $ENV{Commands} suitably split, as is done in
-:lib:ExtUtils:MM_Mac.pm.
-
-=cut
-
-sub path {
-#
-# The concept is meaningless under the MacPerl application.
-# Under MPW, it has a meaning.
-#
- return unless exists $ENV{Commands};
- return split(/,/, $ENV{Commands});
-}
-
-=item splitpath
-
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
-
-Splits a path into volume, directory, and filename portions.
-
-On Mac OS, assumes that the last part of the path is a filename unless
-$no_file is true or a trailing separator ":" is present.
-
-The volume portion is always returned with a trailing ":". The directory portion
-is always returned with a leading (to denote a relative path) and a trailing ":"
-(to denote a directory). The file portion is always returned I<without> a leading ":".
-Empty portions are returned as empty string ''.
-
-The results can be passed to C<catpath()> to get back a path equivalent to
-(usually identical to) the original path.
-
-
-=cut
-
-sub splitpath {
- my ($self,$path, $nofile) = @_;
- my ($volume,$directory,$file);
-
- if ( $nofile ) {
- ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s;
- }
- else {
- $path =~
- m|^( (?: [^:]+: )? )
- ( (?: .*: )? )
- ( .* )
- |xs;
- $volume = $1;
- $directory = $2;
- $file = $3;
- }
-
- $volume = '' unless defined($volume);
- $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir"
- if ($directory) {
- # Make sure non-empty directories begin and end in ':'
- $directory .= ':' unless (substr($directory,-1) eq ':');
- $directory = ":$directory" unless (substr($directory,0,1) eq ':');
- } else {
- $directory = '';
- }
- $file = '' unless defined($file);
-
- return ($volume,$directory,$file);
-}
-
-
-=item splitdir
-
-The opposite of C<catdir()>.
-
- @dirs = File::Spec->splitdir( $directories );
-
-$directories should be only the directory portion of the path on systems
-that have the concept of a volume or that have path syntax that differentiates
-files from directories. Consider using C<splitpath()> otherwise.
-
-Unlike just splitting the directories on the separator, empty directory names
-(C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing
-colon to distinguish a directory path from a file path, a single trailing colon
-will be ignored, i.e. there's no empty directory name after it.
-
-Hence, on Mac OS, both
-
- File::Spec->splitdir( ":a:b::c:" ); and
- File::Spec->splitdir( ":a:b::c" );
-
-yield:
-
- ( "a", "b", "::", "c")
-
-while
-
- File::Spec->splitdir( ":a:b::c::" );
-
-yields:
-
- ( "a", "b", "::", "c", "::")
-
-
-=cut
-
-sub splitdir {
- my ($self, $path) = @_;
- my @result = ();
- my ($head, $sep, $tail, $volume, $directories);
-
- return ('') if ( (!defined($path)) || ($path eq '') );
- return (':') if ($path eq ':');
-
- ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s;
-
- # deprecated, but handle it correctly
- if ($volume) {
- push (@result, $volume);
- $sep .= ':';
- }
-
- while ($sep || $directories) {
- if (length($sep) > 1) {
- my $updir_count = length($sep) - 1;
- for (my $i=0; $i<$updir_count; $i++) {
- # push '::' updir_count times;
- # simulate Unix '..' updirs
- push (@result, '::');
- }
- }
- $sep = '';
- if ($directories) {
- ( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s;
- push (@result, $head);
- $directories = $tail;
- }
- }
- return @result;
-}
-
-
-=item catpath
-
- $path = File::Spec->catpath($volume,$directory,$file);
-
-Takes volume, directory and file portions and returns an entire path. On Mac OS,
-$volume, $directory and $file are concatenated. A ':' is inserted if need be. You
-may pass an empty string for each portion. If all portions are empty, the empty
-string is returned. If $volume is empty, the result will be a relative path,
-beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any)
-is removed form $file and the remainder is returned. If $file is empty, the
-resulting path will have a trailing ':'.
-
-
-=cut
-
-sub catpath {
- my ($self,$volume,$directory,$file) = @_;
-
- if ( (! $volume) && (! $directory) ) {
- $file =~ s/^:// if $file;
- return $file ;
- }
-
- # We look for a volume in $volume, then in $directory, but not both
-
- my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1);
-
- $volume = $dir_volume unless length $volume;
- my $path = $volume; # may be ''
- $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
-
- if ($directory) {
- $directory = $dir_dirs if $volume;
- $directory =~ s/^://; # remove leading ':' if any
- $path .= $directory;
- $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
- }
-
- if ($file) {
- $file =~ s/^://; # remove leading ':' if any
- $path .= $file;
- }
-
- return $path;
-}
-
-=item abs2rel
-
-Takes a destination path and an optional base path and returns a relative path
-from the base path to the destination path:
-
- $rel_path = File::Spec->abs2rel( $path ) ;
- $rel_path = File::Spec->abs2rel( $path, $base ) ;
-
-Note that both paths are assumed to have a notation that distinguishes a
-directory path (with trailing ':') from a file path (without trailing ':').
-
-If $base is not present or '', then the current working directory is used.
-If $base is relative, then it is converted to absolute form using C<rel2abs()>.
-This means that it is taken to be relative to the current working directory.
-
-If $path and $base appear to be on two different volumes, we will not
-attempt to resolve the two paths, and we will instead simply return
-$path. Note that previous versions of this module ignored the volume
-of $base, which resulted in garbage results part of the time.
-
-If $base doesn't have a trailing colon, the last element of $base is
-assumed to be a filename. This filename is ignored. Otherwise all path
-components are assumed to be directories.
-
-If $path is relative, it is converted to absolute form using C<rel2abs()>.
-This means that it is taken to be relative to the current working directory.
-
-Based on code written by Shigio Yamaguchi.
-
-
-=cut
-
-# maybe this should be done in canonpath() ?
-sub _resolve_updirs {
- my $path = shift @_;
- my $proceed;
-
- # resolve any updirs, e.g. "HD:tmp::file" -> "HD:file"
- do {
- $proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
- } while ($proceed);
-
- return $path;
-}
-
-
-sub abs2rel {
- my($self,$path,$base) = @_;
-
- # Clean up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- $path = $self->rel2abs( $path ) ;
- }
-
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- $base = _resolve_updirs( $base ); # resolve updirs in $base
- }
- else {
- $base = _resolve_updirs( $base );
- }
-
- # Split up paths - ignore $base's file
- my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path );
- my ( $base_vol, $base_dirs ) = $self->splitpath( $base );
-
- return $path unless lc( $path_vol ) eq lc( $base_vol );
-
- # Now, remove all leading components that are the same
- my @pathchunks = $self->splitdir( $path_dirs );
- my @basechunks = $self->splitdir( $base_dirs );
-
- while ( @pathchunks &&
- @basechunks &&
- lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) {
- shift @pathchunks ;
- shift @basechunks ;
- }
-
- # @pathchunks now has the directories to descend in to.
- # ensure relative path, even if @pathchunks is empty
- $path_dirs = $self->catdir( ':', @pathchunks );
-
- # @basechunks now contains the number of directories to climb out of.
- $base_dirs = (':' x @basechunks) . ':' ;
-
- return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ;
-}
-
-=item rel2abs
-
-Converts a relative path to an absolute path:
-
- $abs_path = File::Spec->rel2abs( $path ) ;
- $abs_path = File::Spec->rel2abs( $path, $base ) ;
-
-Note that both paths are assumed to have a notation that distinguishes a
-directory path (with trailing ':') from a file path (without trailing ':').
-
-If $base is not present or '', then $base is set to the current working
-directory. If $base is relative, then it is converted to absolute form
-using C<rel2abs()>. This means that it is taken to be relative to the
-current working directory.
-
-If $base doesn't have a trailing colon, the last element of $base is
-assumed to be a filename. This filename is ignored. Otherwise all path
-components are assumed to be directories.
-
-If $path is already absolute, it is returned and $base is ignored.
-
-Based on code written by Shigio Yamaguchi.
-
-=cut
-
-sub rel2abs {
- my ($self,$path,$base) = @_;
-
- if ( ! $self->file_name_is_absolute($path) ) {
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- }
- elsif ( ! $self->file_name_is_absolute($base) ) {
- $base = $self->rel2abs($base) ;
- }
-
- # Split up paths
-
- # igonore $path's volume
- my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
-
- # ignore $base's file part
- my ( $base_vol, $base_dirs ) = $self->splitpath($base) ;
-
- # Glom them together
- $path_dirs = ':' if ($path_dirs eq '');
- $base_dirs =~ s/:$//; # remove trailing ':', if any
- $base_dirs = $base_dirs . $path_dirs;
-
- $path = $self->catpath( $base_vol, $base_dirs, $path_file );
- }
- return $path;
-}
-
-
-=back
-
-=head1 AUTHORS
-
-See the authors list in I<File::Spec>. Mac OS support by Paul Schinder
-<schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
-implementation of these methods, not the semantics.
-
-=cut
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Spec/OS2.pm b/Master/tlpkg/installer/perllib/File/Spec/OS2.pm
deleted file mode 100644
index ec308f3b6f3..00000000000
--- a/Master/tlpkg/installer/perllib/File/Spec/OS2.pm
+++ /dev/null
@@ -1,272 +0,0 @@
-package File::Spec::OS2;
-
-use strict;
-use vars qw(@ISA $VERSION);
-require File::Spec::Unix;
-
-$VERSION = '1.2';
-
-@ISA = qw(File::Spec::Unix);
-
-sub devnull {
- return "/dev/nul";
-}
-
-sub case_tolerant {
- return 1;
-}
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- return scalar($file =~ m{^([a-z]:)?[\\/]}is);
-}
-
-sub path {
- my $path = $ENV{PATH};
- $path =~ s:\\:/:g;
- my @path = split(';',$path);
- foreach (@path) { $_ = '.' if $_ eq '' }
- return @path;
-}
-
-sub _cwd {
- # In OS/2 the "require Cwd" is unnecessary bloat.
- return Cwd::sys_cwd();
-}
-
-my $tmpdir;
-sub tmpdir {
- return $tmpdir if defined $tmpdir;
- $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
- '/tmp',
- '/' );
-}
-
-sub catdir {
- my $self = shift;
- my @args = @_;
- foreach (@args) {
- tr[\\][/];
- # append a backslash to each argument unless it has one there
- $_ .= "/" unless m{/$};
- }
- return $self->canonpath(join('', @args));
-}
-
-sub canonpath {
- my ($self,$path) = @_;
- $path =~ s/^([a-z]:)/\l$1/s;
- $path =~ s|\\|/|g;
- $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx
- $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
- $path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx
- $path =~ s|/\Z(?!\n)||
- unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx
- $path =~ s{^/\.\.$}{/}; # /.. -> /
- 1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx
- return $path;
-}
-
-
-sub splitpath {
- my ($self,$path, $nofile) = @_;
- my ($volume,$directory,$file) = ('','','');
- if ( $nofile ) {
- $path =~
- m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
- (.*)
- }xs;
- $volume = $1;
- $directory = $2;
- }
- else {
- $path =~
- m{^ ( (?: [a-zA-Z]: |
- (?:\\\\|//)[^\\/]+[\\/][^\\/]+
- )?
- )
- ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
- (.*)
- }xs;
- $volume = $1;
- $directory = $2;
- $file = $3;
- }
-
- return ($volume,$directory,$file);
-}
-
-
-sub splitdir {
- my ($self,$directories) = @_ ;
- split m|[\\/]|, $directories, -1;
-}
-
-
-sub catpath {
- my ($self,$volume,$directory,$file) = @_;
-
- # If it's UNC, make sure the glue separator is there, reusing
- # whatever separator is first in the $volume
- $volume .= $1
- if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
- $directory =~ m@^[^\\/]@s
- ) ;
-
- $volume .= $directory ;
-
- # If the volume is not just A:, make sure the glue separator is
- # there, reusing whatever separator is first in the $volume if possible.
- if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
- $volume =~ m@[^\\/]\Z(?!\n)@ &&
- $file =~ m@[^\\/]@
- ) {
- $volume =~ m@([\\/])@ ;
- my $sep = $1 ? $1 : '/' ;
- $volume .= $sep ;
- }
-
- $volume .= $file ;
-
- return $volume ;
-}
-
-
-sub abs2rel {
- my($self,$path,$base) = @_;
-
- # Clean up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- $path = $self->rel2abs( $path ) ;
- } else {
- $path = $self->canonpath( $path ) ;
- }
-
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- } elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- } else {
- $base = $self->canonpath( $base ) ;
- }
-
- # Split up paths
- my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
- my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
- return $path unless $path_volume eq $base_volume;
-
- # Now, remove all leading components that are the same
- my @pathchunks = $self->splitdir( $path_directories );
- my @basechunks = $self->splitdir( $base_directories );
-
- while ( @pathchunks &&
- @basechunks &&
- lc( $pathchunks[0] ) eq lc( $basechunks[0] )
- ) {
- shift @pathchunks ;
- shift @basechunks ;
- }
-
- # No need to catdir, we know these are well formed.
- $path_directories = CORE::join( '/', @pathchunks );
- $base_directories = CORE::join( '/', @basechunks );
-
- # $base_directories now contains the directories the resulting relative
- # path must ascend out of before it can descend to $path_directory. So,
- # replace all names with $parentDir
-
- #FA Need to replace between backslashes...
- $base_directories =~ s|[^\\/]+|..|g ;
-
- # Glue the two together, using a separator if necessary, and preventing an
- # empty result.
-
- #FA Must check that new directories are not empty.
- if ( $path_directories ne '' && $base_directories ne '' ) {
- $path_directories = "$base_directories/$path_directories" ;
- } else {
- $path_directories = "$base_directories$path_directories" ;
- }
-
- return $self->canonpath(
- $self->catpath( "", $path_directories, $path_file )
- ) ;
-}
-
-
-sub rel2abs {
- my ($self,$path,$base ) = @_;
-
- if ( ! $self->file_name_is_absolute( $path ) ) {
-
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
-
- my ( $path_directories, $path_file ) =
- ($self->splitpath( $path, 1 ))[1,2] ;
-
- my ( $base_volume, $base_directories ) =
- $self->splitpath( $base, 1 ) ;
-
- $path = $self->catpath(
- $base_volume,
- $self->catdir( $base_directories, $path_directories ),
- $path_file
- ) ;
- }
-
- return $self->canonpath( $path ) ;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-File::Spec::OS2 - methods for OS/2 file specs
-
-=head1 SYNOPSIS
-
- require File::Spec::OS2; # Done internally by File::Spec if needed
-
-=head1 DESCRIPTION
-
-See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
-implementation of these methods, not the semantics.
-
-Amongst the changes made for OS/2 are...
-
-=over 4
-
-=item tmpdir
-
-Modifies the list of places temp directory information is looked for.
-
- $ENV{TMPDIR}
- $ENV{TEMP}
- $ENV{TMP}
- /tmp
- /
-
-=item splitpath
-
-Volumes can be drive letters or UNC sharenames (\\server\share).
-
-=back
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/File/Spec/Unix.pm b/Master/tlpkg/installer/perllib/File/Spec/Unix.pm
deleted file mode 100644
index 4a25fe632f2..00000000000
--- a/Master/tlpkg/installer/perllib/File/Spec/Unix.pm
+++ /dev/null
@@ -1,510 +0,0 @@
-package File::Spec::Unix;
-
-use strict;
-use vars qw($VERSION);
-
-$VERSION = '1.5';
-
-=head1 NAME
-
-File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
-
-=head1 SYNOPSIS
-
- require File::Spec::Unix; # Done automatically by File::Spec
-
-=head1 DESCRIPTION
-
-Methods for manipulating file specifications. Other File::Spec
-modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
-override specific methods.
-
-=head1 METHODS
-
-=over 2
-
-=item canonpath()
-
-No physical check on the filesystem, but a logical cleanup of a
-path. On UNIX eliminates successive slashes and successive "/.".
-
- $cpath = File::Spec->canonpath( $path ) ;
-
-Note that this does *not* collapse F<x/../y> sections into F<y>. This
-is by design. If F</foo> on your system is a symlink to F</bar/baz>,
-then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
-F<../>-removal would give you. If you want to do this kind of
-processing, you probably want C<Cwd>'s C<realpath()> function to
-actually traverse the filesystem cleaning up paths like this.
-
-=cut
-
-sub canonpath {
- my ($self,$path) = @_;
-
- # Handle POSIX-style node names beginning with double slash (qnx, nto)
- # Handle network path names beginning with double slash (cygwin)
- # (POSIX says: "a pathname that begins with two successive slashes
- # may be interpreted in an implementation-defined manner, although
- # more than two leading slashes shall be treated as a single slash.")
- my $node = '';
- if ( $^O =~ m/^(?:qnx|nto|cygwin)$/ && $path =~ s:^(//[^/]+)(/|\z):/:s ) {
- $node = $1;
- }
- # This used to be
- # $path =~ s|/+|/|g unless($^O eq 'cygwin');
- # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
- # (Mainly because trailing "" directories didn't get stripped).
- # Why would cygwin avoid collapsing multiple slashes into one? --jhi
- $path =~ s|/+|/|g; # xx////xx -> xx/xx
- $path =~ s@(/\.)+(/|\Z(?!\n))@/@g; # xx/././xx -> xx/xx
- $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
- $path =~ s|^/(\.\./)+|/|; # /../../xx -> xx
- $path =~ s|^/\.\.$|/|; # /.. -> /
- $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
- return "$node$path";
-}
-
-=item catdir()
-
-Concatenate two or more directory names to form a complete path ending
-with a directory. But remove the trailing slash from the resulting
-string, because it doesn't look good, isn't necessary and confuses
-OS2. Of course, if this is the root directory, don't cut off the
-trailing slash :-)
-
-=cut
-
-sub catdir {
- my $self = shift;
-
- $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
-}
-
-=item catfile
-
-Concatenate one or more directory names and a filename to form a
-complete path ending with a filename
-
-=cut
-
-sub catfile {
- my $self = shift;
- my $file = $self->canonpath(pop @_);
- return $file unless @_;
- my $dir = $self->catdir(@_);
- $dir .= "/" unless substr($dir,-1) eq "/";
- return $dir.$file;
-}
-
-=item curdir
-
-Returns a string representation of the current directory. "." on UNIX.
-
-=cut
-
-sub curdir () { '.' }
-
-=item devnull
-
-Returns a string representation of the null device. "/dev/null" on UNIX.
-
-=cut
-
-sub devnull () { '/dev/null' }
-
-=item rootdir
-
-Returns a string representation of the root directory. "/" on UNIX.
-
-=cut
-
-sub rootdir () { '/' }
-
-=item tmpdir
-
-Returns a string representation of the first writable directory from
-the following list or the current directory if none from the list are
-writable:
-
- $ENV{TMPDIR}
- /tmp
-
-Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
-is tainted, it is not used.
-
-=cut
-
-my $tmpdir;
-sub _tmpdir {
- return $tmpdir if defined $tmpdir;
- my $self = shift;
- my @dirlist = @_;
- {
- no strict 'refs';
- if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
- require Scalar::Util;
- @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
- }
- }
- foreach (@dirlist) {
- next unless defined && -d && -w _;
- $tmpdir = $_;
- last;
- }
- $tmpdir = $self->curdir unless defined $tmpdir;
- $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
- return $tmpdir;
-}
-
-sub tmpdir {
- return $tmpdir if defined $tmpdir;
- $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" );
-}
-
-=item updir
-
-Returns a string representation of the parent directory. ".." on UNIX.
-
-=cut
-
-sub updir () { '..' }
-
-=item no_upwards
-
-Given a list of file names, strip out those that refer to a parent
-directory. (Does not strip symlinks, only '.', '..', and equivalents.)
-
-=cut
-
-sub no_upwards {
- my $self = shift;
- return grep(!/^\.{1,2}\Z(?!\n)/s, @_);
-}
-
-=item case_tolerant
-
-Returns a true or false value indicating, respectively, that alphabetic
-is not or is significant when comparing file specifications.
-
-=cut
-
-sub case_tolerant () { 0 }
-
-=item file_name_is_absolute
-
-Takes as argument a path and returns true if it is an absolute path.
-
-This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
-OS (Classic). It does consult the working environment for VMS (see
-L<File::Spec::VMS/file_name_is_absolute>).
-
-=cut
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- return scalar($file =~ m:^/:s);
-}
-
-=item path
-
-Takes no argument, returns the environment variable PATH as an array.
-
-=cut
-
-sub path {
- return () unless exists $ENV{PATH};
- my @path = split(':', $ENV{PATH});
- foreach (@path) { $_ = '.' if $_ eq '' }
- return @path;
-}
-
-=item join
-
-join is the same as catfile.
-
-=cut
-
-sub join {
- my $self = shift;
- return $self->catfile(@_);
-}
-
-=item splitpath
-
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
-
-Splits a path into volume, directory, and filename portions. On systems
-with no concept of volume, returns '' for volume.
-
-For systems with no syntax differentiating filenames from directories,
-assumes that the last file is a path unless $no_file is true or a
-trailing separator or /. or /.. is present. On Unix this means that $no_file
-true makes this return ( '', $path, '' ).
-
-The directory portion may or may not be returned with a trailing '/'.
-
-The results can be passed to L</catpath()> to get back a path equivalent to
-(usually identical to) the original path.
-
-=cut
-
-sub splitpath {
- my ($self,$path, $nofile) = @_;
-
- my ($volume,$directory,$file) = ('','','');
-
- if ( $nofile ) {
- $directory = $path;
- }
- else {
- $path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs;
- $directory = $1;
- $file = $2;
- }
-
- return ($volume,$directory,$file);
-}
-
-
-=item splitdir
-
-The opposite of L</catdir()>.
-
- @dirs = File::Spec->splitdir( $directories );
-
-$directories must be only the directory portion of the path on systems
-that have the concept of a volume or that have path syntax that differentiates
-files from directories.
-
-Unlike just splitting the directories on the separator, empty
-directory names (C<''>) can be returned, because these are significant
-on some OSs.
-
-On Unix,
-
- File::Spec->splitdir( "/a/b//c/" );
-
-Yields:
-
- ( '', 'a', 'b', '', 'c', '' )
-
-=cut
-
-sub splitdir {
- return split m|/|, $_[1], -1; # Preserve trailing fields
-}
-
-
-=item catpath()
-
-Takes volume, directory and file portions and returns an entire path. Under
-Unix, $volume is ignored, and directory and file are concatenated. A '/' is
-inserted if needed (though if the directory portion doesn't start with
-'/' it is not added). On other OSs, $volume is significant.
-
-=cut
-
-sub catpath {
- my ($self,$volume,$directory,$file) = @_;
-
- if ( $directory ne '' &&
- $file ne '' &&
- substr( $directory, -1 ) ne '/' &&
- substr( $file, 0, 1 ) ne '/'
- ) {
- $directory .= "/$file" ;
- }
- else {
- $directory .= $file ;
- }
-
- return $directory ;
-}
-
-=item abs2rel
-
-Takes a destination path and an optional base path returns a relative path
-from the base path to the destination path:
-
- $rel_path = File::Spec->abs2rel( $path ) ;
- $rel_path = File::Spec->abs2rel( $path, $base ) ;
-
-If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
-relative, then it is converted to absolute form using
-L</rel2abs()>. This means that it is taken to be relative to
-L<cwd()|Cwd>.
-
-On systems that have a grammar that indicates filenames, this ignores the
-$base filename. Otherwise all path components are assumed to be
-directories.
-
-If $path is relative, it is converted to absolute form using L</rel2abs()>.
-This means that it is taken to be relative to L<cwd()|Cwd>.
-
-No checks against the filesystem are made. On VMS, there is
-interaction with the working environment, as logicals and
-macros are expanded.
-
-Based on code written by Shigio Yamaguchi.
-
-=cut
-
-sub abs2rel {
- my($self,$path,$base) = @_;
-
- # Clean up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- $path = $self->rel2abs( $path ) ;
- }
- else {
- $path = $self->canonpath( $path ) ;
- }
-
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
-
- # Now, remove all leading components that are the same
- my @pathchunks = $self->splitdir( $path);
- my @basechunks = $self->splitdir( $base);
-
- while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) {
- shift @pathchunks ;
- shift @basechunks ;
- }
-
- $path = CORE::join( '/', @pathchunks );
- $base = CORE::join( '/', @basechunks );
-
- # $base now contains the directories the resulting relative path
- # must ascend out of before it can descend to $path_directory. So,
- # replace all names with $parentDir
- $base =~ s|[^/]+|..|g ;
-
- # Glue the two together, using a separator if necessary, and preventing an
- # empty result.
- if ( $path ne '' && $base ne '' ) {
- $path = "$base/$path" ;
- } else {
- $path = "$base$path" ;
- }
-
- return $self->canonpath( $path ) ;
-}
-
-=item rel2abs()
-
-Converts a relative path to an absolute path.
-
- $abs_path = File::Spec->rel2abs( $path ) ;
- $abs_path = File::Spec->rel2abs( $path, $base ) ;
-
-If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
-relative, then it is converted to absolute form using
-L</rel2abs()>. This means that it is taken to be relative to
-L<cwd()|Cwd>.
-
-On systems that have a grammar that indicates filenames, this ignores
-the $base filename. Otherwise all path components are assumed to be
-directories.
-
-If $path is absolute, it is cleaned up and returned using L</canonpath()>.
-
-No checks against the filesystem are made. On VMS, there is
-interaction with the working environment, as logicals and
-macros are expanded.
-
-Based on code written by Shigio Yamaguchi.
-
-=cut
-
-sub rel2abs {
- my ($self,$path,$base ) = @_;
-
- # Clean up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
-
- # Glom them together
- $path = $self->catdir( $base, $path ) ;
- }
-
- return $self->canonpath( $path ) ;
-}
-
-=back
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-L<File::Spec>
-
-=cut
-
-# Internal routine to File::Spec, no point in making this public since
-# it is the standard Cwd interface. Most of the platform-specific
-# File::Spec subclasses use this.
-sub _cwd {
- require Cwd;
- Cwd::cwd();
-}
-
-
-# Internal method to reduce xx\..\yy -> yy
-sub _collapse {
- my($fs, $path) = @_;
-
- my $updir = $fs->updir;
- my $curdir = $fs->curdir;
-
- my($vol, $dirs, $file) = $fs->splitpath($path);
- my @dirs = $fs->splitdir($dirs);
-
- my @collapsed;
- foreach my $dir (@dirs) {
- if( $dir eq $updir and # if we have an updir
- @collapsed and # and something to collapse
- length $collapsed[-1] and # and its not the rootdir
- $collapsed[-1] ne $updir and # nor another updir
- $collapsed[-1] ne $curdir # nor the curdir
- )
- { # then
- pop @collapsed; # collapse
- }
- else { # else
- push @collapsed, $dir; # just hang onto it
- }
- }
-
- return $fs->catpath($vol,
- $fs->catdir(@collapsed),
- $file
- );
-}
-
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Spec/VMS.pm b/Master/tlpkg/installer/perllib/File/Spec/VMS.pm
deleted file mode 100644
index f8923f25fb2..00000000000
--- a/Master/tlpkg/installer/perllib/File/Spec/VMS.pm
+++ /dev/null
@@ -1,521 +0,0 @@
-package File::Spec::VMS;
-
-use strict;
-use vars qw(@ISA $VERSION);
-require File::Spec::Unix;
-
-$VERSION = '1.4';
-
-@ISA = qw(File::Spec::Unix);
-
-use File::Basename;
-use VMS::Filespec;
-
-=head1 NAME
-
-File::Spec::VMS - methods for VMS file specs
-
-=head1 SYNOPSIS
-
- require File::Spec::VMS; # Done internally by File::Spec if needed
-
-=head1 DESCRIPTION
-
-See File::Spec::Unix for a documentation of the methods provided
-there. This package overrides the implementation of these methods, not
-the semantics.
-
-=over 4
-
-=item canonpath (override)
-
-Removes redundant portions of file specifications according to VMS syntax.
-
-=cut
-
-sub canonpath {
- my($self,$path) = @_;
-
- if ($path =~ m|/|) { # Fake Unix
- my $pathify = $path =~ m|/\Z(?!\n)|;
- $path = $self->SUPER::canonpath($path);
- if ($pathify) { return vmspath($path); }
- else { return vmsify($path); }
- }
- else {
- $path =~ tr/<>/[]/; # < and > ==> [ and ]
- $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
- $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
- $path =~ s/\[000000\./\[/g; # [000000. ==> [
- $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
- $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
- 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
- # That loop does the following
- # with any amount of dashes:
- # .-.-. ==> .--.
- # [-.-. ==> [--.
- # .-.-] ==> .--]
- # [-.-] ==> [--]
- 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
- # That loop does the following
- # with any amount (minimum 2)
- # of dashes:
- # .foo.--. ==> .-.
- # .foo.--] ==> .-]
- # [foo.--. ==> [-.
- # [foo.--] ==> [-]
- #
- # And then, the remaining cases
- $path =~ s/\[\.-/[-/; # [.- ==> [-
- $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
- $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
- $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
- $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
- $path =~ s/\[\]//; # [] ==>
- return $path;
- }
-}
-
-=item catdir (override)
-
-Concatenates a list of file specifications, and returns the result as a
-VMS-syntax directory specification. No check is made for "impossible"
-cases (e.g. elements other than the first being absolute filespecs).
-
-=cut
-
-sub catdir {
- my ($self,@dirs) = @_;
- my $dir = pop @dirs;
- @dirs = grep($_,@dirs);
- my $rslt;
- if (@dirs) {
- my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
- my ($spath,$sdir) = ($path,$dir);
- $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//;
- $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
- $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
-
- # Special case for VMS absolute directory specs: these will have had device
- # prepended during trip through Unix syntax in eliminate_macros(), since
- # Unix syntax has no way to express "absolute from the top of this device's
- # directory tree".
- if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
- }
- else {
- if (not defined $dir or not length $dir) { $rslt = ''; }
- elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; }
- else { $rslt = vmspath($dir); }
- }
- return $self->canonpath($rslt);
-}
-
-=item catfile (override)
-
-Concatenates a list of file specifications, and returns the result as a
-VMS-syntax file specification.
-
-=cut
-
-sub catfile {
- my ($self,@files) = @_;
- my $file = $self->canonpath(pop @files);
- @files = grep($_,@files);
- my $rslt;
- if (@files) {
- my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
- my $spath = $path;
- $spath =~ s/\.dir\Z(?!\n)//;
- if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
- $rslt = "$spath$file";
- }
- else {
- $rslt = $self->eliminate_macros($spath);
- $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
- }
- }
- else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
- return $self->canonpath($rslt);
-}
-
-
-=item curdir (override)
-
-Returns a string representation of the current directory: '[]'
-
-=cut
-
-sub curdir {
- return '[]';
-}
-
-=item devnull (override)
-
-Returns a string representation of the null device: '_NLA0:'
-
-=cut
-
-sub devnull {
- return "_NLA0:";
-}
-
-=item rootdir (override)
-
-Returns a string representation of the root directory: 'SYS$DISK:[000000]'
-
-=cut
-
-sub rootdir {
- return 'SYS$DISK:[000000]';
-}
-
-=item tmpdir (override)
-
-Returns a string representation of the first writable directory
-from the following list or '' if none are writable:
-
- sys$scratch:
- $ENV{TMPDIR}
-
-Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
-is tainted, it is not used.
-
-=cut
-
-my $tmpdir;
-sub tmpdir {
- return $tmpdir if defined $tmpdir;
- $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
-}
-
-=item updir (override)
-
-Returns a string representation of the parent directory: '[-]'
-
-=cut
-
-sub updir {
- return '[-]';
-}
-
-=item case_tolerant (override)
-
-VMS file specification syntax is case-tolerant.
-
-=cut
-
-sub case_tolerant {
- return 1;
-}
-
-=item path (override)
-
-Translate logical name DCL$PATH as a searchlist, rather than trying
-to C<split> string value of C<$ENV{'PATH'}>.
-
-=cut
-
-sub path {
- my (@dirs,$dir,$i);
- while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
- return @dirs;
-}
-
-=item file_name_is_absolute (override)
-
-Checks for VMS directory spec as well as Unix separators.
-
-=cut
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- # If it's a logical name, expand it.
- $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
- return scalar($file =~ m!^/!s ||
- $file =~ m![<\[][^.\-\]>]! ||
- $file =~ /:[^<\[]/);
-}
-
-=item splitpath (override)
-
-Splits using VMS syntax.
-
-=cut
-
-sub splitpath {
- my($self,$path) = @_;
- my($dev,$dir,$file) = ('','','');
-
- vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
- return ($1 || '',$2 || '',$3);
-}
-
-=item splitdir (override)
-
-Split dirspec using VMS syntax.
-
-=cut
-
-sub splitdir {
- my($self,$dirspec) = @_;
- $dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
- $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
- $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
- $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [
- $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
- $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
- while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
- # That loop does the following
- # with any amount of dashes:
- # .--. ==> .-.-.
- # [--. ==> [-.-.
- # .--] ==> .-.-]
- # [--] ==> [-.-]
- $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
- my(@dirs) = split('\.', vmspath($dirspec));
- $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
- @dirs;
-}
-
-
-=item catpath (override)
-
-Construct a complete filespec using VMS syntax
-
-=cut
-
-sub catpath {
- my($self,$dev,$dir,$file) = @_;
-
- # We look for a volume in $dev, then in $dir, but not both
- my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
- $dev = $dir_volume unless length $dev;
- $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
-
- if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
- else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
- if (length($dev) or length($dir)) {
- $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
- $dir = vmspath($dir);
- }
- "$dev$dir$file";
-}
-
-=item abs2rel (override)
-
-Use VMS syntax when converting filespecs.
-
-=cut
-
-sub abs2rel {
- my $self = shift;
- return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
- if grep m{/}, @_;
-
- my($path,$base) = @_;
- $base = $self->_cwd() unless defined $base and length $base;
-
- for ($path, $base) { $_ = $self->canonpath($_) }
-
- # Are we even starting $path on the same (node::)device as $base? Note that
- # logical paths or nodename differences may be on the "same device"
- # but the comparison that ignores device differences so as to concatenate
- # [---] up directory specs is not even a good idea in cases where there is
- # a logical path difference between $path and $base nodename and/or device.
- # Hence we fall back to returning the absolute $path spec
- # if there is a case blind device (or node) difference of any sort
- # and we do not even try to call $parse() or consult %ENV for $trnlnm()
- # (this module needs to run on non VMS platforms after all).
-
- my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
- my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
- return $path unless lc($path_volume) eq lc($base_volume);
-
- for ($path, $base) { $_ = $self->rel2abs($_) }
-
- # Now, remove all leading components that are the same
- my @pathchunks = $self->splitdir( $path_directories );
- unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
- my @basechunks = $self->splitdir( $base_directories );
- unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
-
- while ( @pathchunks &&
- @basechunks &&
- lc( $pathchunks[0] ) eq lc( $basechunks[0] )
- ) {
- shift @pathchunks ;
- shift @basechunks ;
- }
-
- # @basechunks now contains the directories to climb out of,
- # @pathchunks now has the directories to descend in to.
- $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
- return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
-}
-
-
-=item rel2abs (override)
-
-Use VMS syntax when converting filespecs.
-
-=cut
-
-sub rel2abs {
- my $self = shift ;
- my ($path,$base ) = @_;
- return undef unless defined $path;
- if ($path =~ m/\//) {
- $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
- ? vmspath($path) # whether it's a directory
- : vmsify($path) );
- }
- $base = vmspath($base) if defined $base && $base =~ m/\//;
- # Clean up and split up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd;
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
-
- # Split up paths
- my ( $path_directories, $path_file ) =
- ($self->splitpath( $path ))[1,2] ;
-
- my ( $base_volume, $base_directories ) =
- $self->splitpath( $base ) ;
-
- $path_directories = '' if $path_directories eq '[]' ||
- $path_directories eq '<>';
- my $sep = '' ;
- $sep = '.'
- if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
- $path_directories =~ m{^[^.\[<]}s
- ) ;
- $base_directories = "$base_directories$sep$path_directories";
- $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
-
- $path = $self->catpath( $base_volume, $base_directories, $path_file );
- }
-
- return $self->canonpath( $path ) ;
-}
-
-
-# eliminate_macros() and fixpath() are MakeMaker-specific methods
-# which are used inside catfile() and catdir(). MakeMaker has its own
-# copies as of 6.06_03 which are the canonical ones. We leave these
-# here, in peace, so that File::Spec continues to work with MakeMakers
-# prior to 6.06_03.
-#
-# Please consider these two methods deprecated. Do not patch them,
-# patch the ones in ExtUtils::MM_VMS instead.
-sub eliminate_macros {
- my($self,$path) = @_;
- return '' unless $path;
- $self = {} unless ref $self;
-
- if ($path =~ /\s/) {
- return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
- }
-
- my($npath) = unixify($path);
- my($complex) = 0;
- my($head,$macro,$tail);
-
- # perform m##g in scalar context so it acts as an iterator
- while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
- if ($self->{$2}) {
- ($head,$macro,$tail) = ($1,$2,$3);
- if (ref $self->{$macro}) {
- if (ref $self->{$macro} eq 'ARRAY') {
- $macro = join ' ', @{$self->{$macro}};
- }
- else {
- print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
- "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
- $macro = "\cB$macro\cB";
- $complex = 1;
- }
- }
- else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
- $npath = "$head$macro$tail";
- }
- }
- if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
- $npath;
-}
-
-# Deprecated. See the note above for eliminate_macros().
-sub fixpath {
- my($self,$path,$force_path) = @_;
- return '' unless $path;
- $self = bless {} unless ref $self;
- my($fixedpath,$prefix,$name);
-
- if ($path =~ /\s/) {
- return join ' ',
- map { $self->fixpath($_,$force_path) }
- split /\s+/, $path;
- }
-
- if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
- if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
- $fixedpath = vmspath($self->eliminate_macros($path));
- }
- else {
- $fixedpath = vmsify($self->eliminate_macros($path));
- }
- }
- elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
- my($vmspre) = $self->eliminate_macros("\$($prefix)");
- # is it a dir or just a name?
- $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
- $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
- $fixedpath = vmspath($fixedpath) if $force_path;
- }
- else {
- $fixedpath = $path;
- $fixedpath = vmspath($fixedpath) if $force_path;
- }
- # No hints, so we try to guess
- if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
- $fixedpath = vmspath($fixedpath) if -d $fixedpath;
- }
-
- # Trim off root dirname if it's had other dirs inserted in front of it.
- $fixedpath =~ s/\.000000([\]>])/$1/;
- # Special case for VMS absolute directory specs: these will have had device
- # prepended during trip through Unix syntax in eliminate_macros(), since
- # Unix syntax has no way to express "absolute from the top of this device's
- # directory tree".
- if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
- $fixedpath;
-}
-
-
-=back
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
-implementation of these methods, not the semantics.
-
-An explanation of VMS file specs can be found at
-L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
-
-=cut
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Spec/Win32.pm b/Master/tlpkg/installer/perllib/File/Spec/Win32.pm
deleted file mode 100644
index a324306a74b..00000000000
--- a/Master/tlpkg/installer/perllib/File/Spec/Win32.pm
+++ /dev/null
@@ -1,369 +0,0 @@
-package File::Spec::Win32;
-
-use strict;
-
-use vars qw(@ISA $VERSION);
-require File::Spec::Unix;
-
-$VERSION = '1.6';
-
-@ISA = qw(File::Spec::Unix);
-
-=head1 NAME
-
-File::Spec::Win32 - methods for Win32 file specs
-
-=head1 SYNOPSIS
-
- require File::Spec::Win32; # Done internally by File::Spec if needed
-
-=head1 DESCRIPTION
-
-See File::Spec::Unix for a documentation of the methods provided
-there. This package overrides the implementation of these methods, not
-the semantics.
-
-=over 4
-
-=item devnull
-
-Returns a string representation of the null device.
-
-=cut
-
-sub devnull {
- return "nul";
-}
-
-sub rootdir () { '\\' }
-
-
-=item tmpdir
-
-Returns a string representation of the first existing directory
-from the following list:
-
- $ENV{TMPDIR}
- $ENV{TEMP}
- $ENV{TMP}
- SYS:/temp
- C:\system\temp
- C:/temp
- /tmp
- /
-
-The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
-for Symbian (the File::Spec::Win32 is used also for those platforms).
-
-Since Perl 5.8.0, if running under taint mode, and if the environment
-variables are tainted, they are not used.
-
-=cut
-
-my $tmpdir;
-sub tmpdir {
- return $tmpdir if defined $tmpdir;
- $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
- 'SYS:/temp',
- 'C:\system\temp',
- 'C:/temp',
- '/tmp',
- '/' );
-}
-
-sub case_tolerant {
- return 1;
-}
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- return scalar($file =~ m{^([a-z]:)?[\\/]}is);
-}
-
-=item catfile
-
-Concatenate one or more directory names and a filename to form a
-complete path ending with a filename
-
-=cut
-
-sub catfile {
- my $self = shift;
- my $file = $self->canonpath(pop @_);
- return $file unless @_;
- my $dir = $self->catdir(@_);
- $dir .= "\\" unless substr($dir,-1) eq "\\";
- return $dir.$file;
-}
-
-sub catdir {
- my $self = shift;
- my @args = @_;
- foreach (@args) {
- tr[/][\\];
- # append a backslash to each argument unless it has one there
- $_ .= "\\" unless m{\\$};
- }
- return $self->canonpath(join('', @args));
-}
-
-sub path {
- my @path = split(';', $ENV{PATH});
- s/"//g for @path;
- @path = grep length, @path;
- unshift(@path, ".");
- return @path;
-}
-
-=item canonpath
-
-No physical check on the filesystem, but a logical cleanup of a
-path. On UNIX eliminated successive slashes and successive "/.".
-On Win32 makes
-
- dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
- dir1\dir2\dir3\...\dir4 -> \dir\dir4
-
-=cut
-
-sub canonpath {
- my ($self,$path) = @_;
-
- $path =~ s/^([a-z]:)/\u$1/s;
- $path =~ s|/|\\|g;
- $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
- $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
- $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
- $path =~ s|\\\Z(?!\n)||
- unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
- # xx1/xx2/xx3/../../xx -> xx1/xx
- $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
- $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
- return $path if $path =~ m|^\.\.|; # skip relative paths
- return $path unless $path =~ /\.\./; # too few .'s to cleanup
- return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
- $path =~ s{^\\\.\.$}{\\}; # \.. -> \
- 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
-
- return $self->_collapse($path);
-}
-
-=item splitpath
-
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
-
-Splits a path into volume, directory, and filename portions. Assumes that
-the last file is a path unless the path ends in '\\', '\\.', '\\..'
-or $no_file is true. On Win32 this means that $no_file true makes this return
-( $volume, $path, '' ).
-
-Separators accepted are \ and /.
-
-Volumes can be drive letters or UNC sharenames (\\server\share).
-
-The results can be passed to L</catpath> to get back a path equivalent to
-(usually identical to) the original path.
-
-=cut
-
-sub splitpath {
- my ($self,$path, $nofile) = @_;
- my ($volume,$directory,$file) = ('','','');
- if ( $nofile ) {
- $path =~
- m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
- (.*)
- }xs;
- $volume = $1;
- $directory = $2;
- }
- else {
- $path =~
- m{^ ( (?: [a-zA-Z]: |
- (?:\\\\|//)[^\\/]+[\\/][^\\/]+
- )?
- )
- ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
- (.*)
- }xs;
- $volume = $1;
- $directory = $2;
- $file = $3;
- }
-
- return ($volume,$directory,$file);
-}
-
-
-=item splitdir
-
-The opposite of L<catdir()|File::Spec/catdir()>.
-
- @dirs = File::Spec->splitdir( $directories );
-
-$directories must be only the directory portion of the path on systems
-that have the concept of a volume or that have path syntax that differentiates
-files from directories.
-
-Unlike just splitting the directories on the separator, leading empty and
-trailing directory entries can be returned, because these are significant
-on some OSs. So,
-
- File::Spec->splitdir( "/a/b/c" );
-
-Yields:
-
- ( '', 'a', 'b', '', 'c', '' )
-
-=cut
-
-sub splitdir {
- my ($self,$directories) = @_ ;
- #
- # split() likes to forget about trailing null fields, so here we
- # check to be sure that there will not be any before handling the
- # simple case.
- #
- if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
- return split( m|[\\/]|, $directories );
- }
- else {
- #
- # since there was a trailing separator, add a file name to the end,
- # then do the split, then replace it with ''.
- #
- my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
- $directories[ $#directories ]= '' ;
- return @directories ;
- }
-}
-
-
-=item catpath
-
-Takes volume, directory and file portions and returns an entire path. Under
-Unix, $volume is ignored, and this is just like catfile(). On other OSs,
-the $volume become significant.
-
-=cut
-
-sub catpath {
- my ($self,$volume,$directory,$file) = @_;
-
- # If it's UNC, make sure the glue separator is there, reusing
- # whatever separator is first in the $volume
- my $v;
- $volume .= $v
- if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
- $directory =~ m@^[^\\/]@s
- ) ;
-
- $volume .= $directory ;
-
- # If the volume is not just A:, make sure the glue separator is
- # there, reusing whatever separator is first in the $volume if possible.
- if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
- $volume =~ m@[^\\/]\Z(?!\n)@ &&
- $file =~ m@[^\\/]@
- ) {
- $volume =~ m@([\\/])@ ;
- my $sep = $1 ? $1 : '\\' ;
- $volume .= $sep ;
- }
-
- $volume .= $file ;
-
- return $volume ;
-}
-
-
-sub abs2rel {
- my($self,$path,$base) = @_;
- $base = $self->_cwd() unless defined $base and length $base;
-
- for ($path, $base) { $_ = $self->canonpath($_) }
-
- my ($path_volume) = $self->splitpath($path, 1);
- my ($base_volume) = $self->splitpath($base, 1);
-
- # Can't relativize across volumes
- return $path unless $path_volume eq $base_volume;
-
- for ($path, $base) { $_ = $self->rel2abs($_) }
-
- my $path_directories = ($self->splitpath($path, 1))[1];
- my $base_directories = ($self->splitpath($base, 1))[1];
-
- # Now, remove all leading components that are the same
- my @pathchunks = $self->splitdir( $path_directories );
- my @basechunks = $self->splitdir( $base_directories );
-
- while ( @pathchunks &&
- @basechunks &&
- lc( $pathchunks[0] ) eq lc( $basechunks[0] )
- ) {
- shift @pathchunks ;
- shift @basechunks ;
- }
-
- my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
-
- return $self->canonpath( $self->catpath('', $result_dirs, '') );
-}
-
-
-sub rel2abs {
- my ($self,$path,$base ) = @_;
-
- if ( ! $self->file_name_is_absolute( $path ) ) {
-
- if ( !defined( $base ) || $base eq '' ) {
- require Cwd ;
- $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
- $base = $self->_cwd() unless defined $base ;
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
-
- my ( $path_directories, $path_file ) =
- ($self->splitpath( $path, 1 ))[1,2] ;
-
- my ( $base_volume, $base_directories ) =
- $self->splitpath( $base, 1 ) ;
-
- $path = $self->catpath(
- $base_volume,
- $self->catdir( $base_directories, $path_directories ),
- $path_file
- ) ;
- }
-
- return $self->canonpath( $path ) ;
-}
-
-=back
-
-=head2 Note For File::Spec::Win32 Maintainers
-
-Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
-implementation of these methods, not the semantics.
-
-=cut
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/Temp.pm b/Master/tlpkg/installer/perllib/File/Temp.pm
deleted file mode 100644
index 6ddcb3619a7..00000000000
--- a/Master/tlpkg/installer/perllib/File/Temp.pm
+++ /dev/null
@@ -1,2244 +0,0 @@
-package File::Temp;
-
-=head1 NAME
-
-File::Temp - return name and handle of a temporary file safely
-
-=begin __INTERNALS
-
-=head1 PORTABILITY
-
-This section is at the top in order to provide easier access to
-porters. It is not expected to be rendered by a standard pod
-formatting tool. Please skip straight to the SYNOPSIS section if you
-are not trying to port this module to a new platform.
-
-This module is designed to be portable across operating systems and it
-currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS
-(Classic). When porting to a new OS there are generally three main
-issues that have to be solved:
-
-=over 4
-
-=item *
-
-Can the OS unlink an open file? If it can not then the
-C<_can_unlink_opened_file> method should be modified.
-
-=item *
-
-Are the return values from C<stat> reliable? By default all the
-return values from C<stat> are compared when unlinking a temporary
-file using the filename and the handle. Operating systems other than
-unix do not always have valid entries in all fields. If C<unlink0> fails
-then the C<stat> comparison should be modified accordingly.
-
-=item *
-
-Security. Systems that can not support a test for the sticky bit
-on a directory can not use the MEDIUM and HIGH security tests.
-The C<_can_do_level> method should be modified accordingly.
-
-=back
-
-=end __INTERNALS
-
-=head1 SYNOPSIS
-
- use File::Temp qw/ tempfile tempdir /;
-
- $fh = tempfile();
- ($fh, $filename) = tempfile();
-
- ($fh, $filename) = tempfile( $template, DIR => $dir);
- ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
-
-
- $dir = tempdir( CLEANUP => 1 );
- ($fh, $filename) = tempfile( DIR => $dir );
-
-Object interface:
-
- require File::Temp;
- use File::Temp ();
-
- $fh = new File::Temp($template);
- $fname = $fh->filename;
-
- $tmp = new File::Temp( UNLINK => 0, SUFFIX => '.dat' );
- print $tmp "Some data\n";
- print "Filename is $tmp\n";
-
-The following interfaces are provided for compatibility with
-existing APIs. They should not be used in new code.
-
-MkTemp family:
-
- use File::Temp qw/ :mktemp /;
-
- ($fh, $file) = mkstemp( "tmpfileXXXXX" );
- ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
-
- $tmpdir = mkdtemp( $template );
-
- $unopened_file = mktemp( $template );
-
-POSIX functions:
-
- use File::Temp qw/ :POSIX /;
-
- $file = tmpnam();
- $fh = tmpfile();
-
- ($fh, $file) = tmpnam();
-
-Compatibility functions:
-
- $unopened_file = File::Temp::tempnam( $dir, $pfx );
-
-=head1 DESCRIPTION
-
-C<File::Temp> can be used to create and open temporary files in a safe
-way. There is both a function interface and an object-oriented
-interface. The File::Temp constructor or the tempfile() function can
-be used to return the name and the open filehandle of a temporary
-file. The tempdir() function can be used to create a temporary
-directory.
-
-The security aspect of temporary file creation is emphasized such that
-a filehandle and filename are returned together. This helps guarantee
-that a race condition can not occur where the temporary file is
-created by another process between checking for the existence of the
-file and its opening. Additional security levels are provided to
-check, for example, that the sticky bit is set on world writable
-directories. See L<"safe_level"> for more information.
-
-For compatibility with popular C library functions, Perl implementations of
-the mkstemp() family of functions are provided. These are, mkstemp(),
-mkstemps(), mkdtemp() and mktemp().
-
-Additionally, implementations of the standard L<POSIX|POSIX>
-tmpnam() and tmpfile() functions are provided if required.
-
-Implementations of mktemp(), tmpnam(), and tempnam() are provided,
-but should be used with caution since they return only a filename
-that was valid when function was called, so cannot guarantee
-that the file will not exist by the time the caller opens the filename.
-
-=cut
-
-# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
-# People would like a version on 5.005 so give them what they want :-)
-use 5.005;
-use strict;
-use Carp;
-use File::Spec 0.8;
-use File::Path qw/ rmtree /;
-use Fcntl 1.03;
-use Errno;
-require VMS::Stdio if $^O eq 'VMS';
-
-# Need the Symbol package if we are running older perl
-require Symbol if $] < 5.006;
-
-### For the OO interface
-use base qw/ IO::Handle /;
-use overload '""' => "STRINGIFY";
-
-
-# use 'our' on v5.6.0
-use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
-
-$DEBUG = 0;
-$KEEP_ALL = 0;
-
-# We are exporting functions
-
-use base qw/Exporter/;
-
-# Export list - to allow fine tuning of export table
-
-@EXPORT_OK = qw{
- tempfile
- tempdir
- tmpnam
- tmpfile
- mktemp
- mkstemp
- mkstemps
- mkdtemp
- unlink0
- cleanup
- };
-
-# Groups of functions for export
-
-%EXPORT_TAGS = (
- 'POSIX' => [qw/ tmpnam tmpfile /],
- 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
- );
-
-# add contents of these tags to @EXPORT
-Exporter::export_tags('POSIX','mktemp');
-
-# Version number
-
-$VERSION = '0.16';
-
-# This is a list of characters that can be used in random filenames
-
-my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
- a b c d e f g h i j k l m n o p q r s t u v w x y z
- 0 1 2 3 4 5 6 7 8 9 _
- /);
-
-# Maximum number of tries to make a temp file before failing
-
-use constant MAX_TRIES => 1000;
-
-# Minimum number of X characters that should be in a template
-use constant MINX => 4;
-
-# Default template when no template supplied
-
-use constant TEMPXXX => 'X' x 10;
-
-# Constants for the security level
-
-use constant STANDARD => 0;
-use constant MEDIUM => 1;
-use constant HIGH => 2;
-
-# OPENFLAGS. If we defined the flag to use with Sysopen here this gives
-# us an optimisation when many temporary files are requested
-
-my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
-
-unless ($^O eq 'MacOS') {
- for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) {
- my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
- no strict 'refs';
- $OPENFLAGS |= $bit if eval {
- # Make sure that redefined die handlers do not cause problems
- # eg CGI::Carp
- local $SIG{__DIE__} = sub {};
- local $SIG{__WARN__} = sub {};
- $bit = &$func();
- 1;
- };
- }
-}
-
-# On some systems the O_TEMPORARY flag can be used to tell the OS
-# to automatically remove the file when it is closed. This is fine
-# in most cases but not if tempfile is called with UNLINK=>0 and
-# the filename is requested -- in the case where the filename is to
-# be passed to another routine. This happens on windows. We overcome
-# this by using a second open flags variable
-
-my $OPENTEMPFLAGS = $OPENFLAGS;
-unless ($^O eq 'MacOS') {
- for my $oflag (qw/ TEMPORARY /) {
- my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
- no strict 'refs';
- $OPENTEMPFLAGS |= $bit if eval {
- # Make sure that redefined die handlers do not cause problems
- # eg CGI::Carp
- local $SIG{__DIE__} = sub {};
- local $SIG{__WARN__} = sub {};
- $bit = &$func();
- 1;
- };
- }
-}
-
-# INTERNAL ROUTINES - not to be used outside of package
-
-# Generic routine for getting a temporary filename
-# modelled on OpenBSD _gettemp() in mktemp.c
-
-# The template must contain X's that are to be replaced
-# with the random values
-
-# Arguments:
-
-# TEMPLATE - string containing the XXXXX's that is converted
-# to a random filename and opened if required
-
-# Optionally, a hash can also be supplied containing specific options
-# "open" => if true open the temp file, else just return the name
-# default is 0
-# "mkdir"=> if true, we are creating a temp directory rather than tempfile
-# default is 0
-# "suffixlen" => number of characters at end of PATH to be ignored.
-# default is 0.
-# "unlink_on_close" => indicates that, if possible, the OS should remove
-# the file as soon as it is closed. Usually indicates
-# use of the O_TEMPORARY flag to sysopen.
-# Usually irrelevant on unix
-
-# Optionally a reference to a scalar can be passed into the function
-# On error this will be used to store the reason for the error
-# "ErrStr" => \$errstr
-
-# "open" and "mkdir" can not both be true
-# "unlink_on_close" is not used when "mkdir" is true.
-
-# The default options are equivalent to mktemp().
-
-# Returns:
-# filehandle - open file handle (if called with doopen=1, else undef)
-# temp name - name of the temp file or directory
-
-# For example:
-# ($fh, $name) = _gettemp($template, "open" => 1);
-
-# for the current version, failures are associated with
-# stored in an error string and returned to give the reason whilst debugging
-# This routine is not called by any external function
-sub _gettemp {
-
- croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
- unless scalar(@_) >= 1;
-
- # the internal error string - expect it to be overridden
- # Need this in case the caller decides not to supply us a value
- # need an anonymous scalar
- my $tempErrStr;
-
- # Default options
- my %options = (
- "open" => 0,
- "mkdir" => 0,
- "suffixlen" => 0,
- "unlink_on_close" => 0,
- "ErrStr" => \$tempErrStr,
- );
-
- # Read the template
- my $template = shift;
- if (ref($template)) {
- # Use a warning here since we have not yet merged ErrStr
- carp "File::Temp::_gettemp: template must not be a reference";
- return ();
- }
-
- # Check that the number of entries on stack are even
- if (scalar(@_) % 2 != 0) {
- # Use a warning here since we have not yet merged ErrStr
- carp "File::Temp::_gettemp: Must have even number of options";
- return ();
- }
-
- # Read the options and merge with defaults
- %options = (%options, @_) if @_;
-
- # Make sure the error string is set to undef
- ${$options{ErrStr}} = undef;
-
- # Can not open the file and make a directory in a single call
- if ($options{"open"} && $options{"mkdir"}) {
- ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
- return ();
- }
-
- # Find the start of the end of the Xs (position of last X)
- # Substr starts from 0
- my $start = length($template) - 1 - $options{"suffixlen"};
-
- # Check that we have at least MINX x X (eg 'XXXX") at the end of the string
- # (taking suffixlen into account). Any fewer is insecure.
-
- # Do it using substr - no reason to use a pattern match since
- # we know where we are looking and what we are looking for
-
- if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
- ${$options{ErrStr}} = "The template must end with at least ".
- MINX . " 'X' characters\n";
- return ();
- }
-
- # Replace all the X at the end of the substring with a
- # random character or just all the XX at the end of a full string.
- # Do it as an if, since the suffix adjusts which section to replace
- # and suffixlen=0 returns nothing if used in the substr directly
- # and generate a full path from the template
-
- my $path = _replace_XX($template, $options{"suffixlen"});
-
-
- # Split the path into constituent parts - eventually we need to check
- # whether the directory exists
- # We need to know whether we are making a temp directory
- # or a tempfile
-
- my ($volume, $directories, $file);
- my $parent; # parent directory
- if ($options{"mkdir"}) {
- # There is no filename at the end
- ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
-
- # The parent is then $directories without the last directory
- # Split the directory and put it back together again
- my @dirs = File::Spec->splitdir($directories);
-
- # If @dirs only has one entry (i.e. the directory template) that means
- # we are in the current directory
- if ($#dirs == 0) {
- $parent = File::Spec->curdir;
- } else {
-
- if ($^O eq 'VMS') { # need volume to avoid relative dir spec
- $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
- $parent = 'sys$disk:[]' if $parent eq '';
- } else {
-
- # Put it back together without the last one
- $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
-
- # ...and attach the volume (no filename)
- $parent = File::Spec->catpath($volume, $parent, '');
- }
-
- }
-
- } else {
-
- # Get rid of the last filename (use File::Basename for this?)
- ($volume, $directories, $file) = File::Spec->splitpath( $path );
-
- # Join up without the file part
- $parent = File::Spec->catpath($volume,$directories,'');
-
- # If $parent is empty replace with curdir
- $parent = File::Spec->curdir
- unless $directories ne '';
-
- }
-
- # Check that the parent directories exist
- # Do this even for the case where we are simply returning a name
- # not a file -- no point returning a name that includes a directory
- # that does not exist or is not writable
-
- unless (-d $parent) {
- ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
- return ();
- }
- unless (-w $parent) {
- ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n";
- return ();
- }
-
-
- # Check the stickiness of the directory and chown giveaway if required
- # If the directory is world writable the sticky bit
- # must be set
-
- if (File::Temp->safe_level == MEDIUM) {
- my $safeerr;
- unless (_is_safe($parent,\$safeerr)) {
- ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
- return ();
- }
- } elsif (File::Temp->safe_level == HIGH) {
- my $safeerr;
- unless (_is_verysafe($parent, \$safeerr)) {
- ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
- return ();
- }
- }
-
-
- # Now try MAX_TRIES time to open the file
- for (my $i = 0; $i < MAX_TRIES; $i++) {
-
- # Try to open the file if requested
- if ($options{"open"}) {
- my $fh;
-
- # If we are running before perl5.6.0 we can not auto-vivify
- if ($] < 5.006) {
- $fh = &Symbol::gensym;
- }
-
- # Try to make sure this will be marked close-on-exec
- # XXX: Win32 doesn't respect this, nor the proper fcntl,
- # but may have O_NOINHERIT. This may or may not be in Fcntl.
- local $^F = 2;
-
- # Store callers umask
- my $umask = umask();
-
- # Set a known umask
- umask(066);
-
- # Attempt to open the file
- my $open_success = undef;
- if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) {
- # make it auto delete on close by setting FAB$V_DLT bit
- $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
- $open_success = $fh;
- } else {
- my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
- $OPENTEMPFLAGS :
- $OPENFLAGS );
- $open_success = sysopen($fh, $path, $flags, 0600);
- }
- if ( $open_success ) {
-
- # Reset umask
- umask($umask) if defined $umask;
-
- # Opened successfully - return file handle and name
- return ($fh, $path);
-
- } else {
- # Reset umask
- umask($umask) if defined $umask;
-
- # Error opening file - abort with error
- # if the reason was anything but EEXIST
- unless ($!{EEXIST}) {
- ${$options{ErrStr}} = "Could not create temp file $path: $!";
- return ();
- }
-
- # Loop round for another try
-
- }
- } elsif ($options{"mkdir"}) {
-
- # Store callers umask
- my $umask = umask();
-
- # Set a known umask
- umask(066);
-
- # Open the temp directory
- if (mkdir( $path, 0700)) {
- # created okay
- # Reset umask
- umask($umask) if defined $umask;
-
- return undef, $path;
- } else {
-
- # Reset umask
- umask($umask) if defined $umask;
-
- # Abort with error if the reason for failure was anything
- # except EEXIST
- unless ($!{EEXIST}) {
- ${$options{ErrStr}} = "Could not create directory $path: $!";
- return ();
- }
-
- # Loop round for another try
-
- }
-
- } else {
-
- # Return true if the file can not be found
- # Directory has been checked previously
-
- return (undef, $path) unless -e $path;
-
- # Try again until MAX_TRIES
-
- }
-
- # Did not successfully open the tempfile/dir
- # so try again with a different set of random letters
- # No point in trying to increment unless we have only
- # 1 X say and the randomness could come up with the same
- # file MAX_TRIES in a row.
-
- # Store current attempt - in principal this implies that the
- # 3rd time around the open attempt that the first temp file
- # name could be generated again. Probably should store each
- # attempt and make sure that none are repeated
-
- my $original = $path;
- my $counter = 0; # Stop infinite loop
- my $MAX_GUESS = 50;
-
- do {
-
- # Generate new name from original template
- $path = _replace_XX($template, $options{"suffixlen"});
-
- $counter++;
-
- } until ($path ne $original || $counter > $MAX_GUESS);
-
- # Check for out of control looping
- if ($counter > $MAX_GUESS) {
- ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
- return ();
- }
-
- }
-
- # If we get here, we have run out of tries
- ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
- . MAX_TRIES . ") to open temp file/dir";
-
- return ();
-
-}
-
-# Internal routine to return a random character from the
-# character list. Does not do an srand() since rand()
-# will do one automatically
-
-# No arguments. Return value is the random character
-
-# No longer called since _replace_XX runs a few percent faster if
-# I inline the code. This is important if we are creating thousands of
-# temporary files.
-
-sub _randchar {
-
- $CHARS[ int( rand( $#CHARS ) ) ];
-
-}
-
-# Internal routine to replace the XXXX... with random characters
-# This has to be done by _gettemp() every time it fails to
-# open a temp file/dir
-
-# Arguments: $template (the template with XXX),
-# $ignore (number of characters at end to ignore)
-
-# Returns: modified template
-
-sub _replace_XX {
-
- croak 'Usage: _replace_XX($template, $ignore)'
- unless scalar(@_) == 2;
-
- my ($path, $ignore) = @_;
-
- # Do it as an if, since the suffix adjusts which section to replace
- # and suffixlen=0 returns nothing if used in the substr directly
- # Alternatively, could simply set $ignore to length($path)-1
- # Don't want to always use substr when not required though.
-
- if ($ignore) {
- substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
- } else {
- $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
- }
- return $path;
-}
-
-# Internal routine to force a temp file to be writable after
-# it is created so that we can unlink it. Windows seems to occassionally
-# force a file to be readonly when written to certain temp locations
-sub _force_writable {
- my $file = shift;
- my $umask = umask();
- umask(066);
- chmod 0600, $file;
- umask($umask) if defined $umask;
-}
-
-
-# internal routine to check to see if the directory is safe
-# First checks to see if the directory is not owned by the
-# current user or root. Then checks to see if anyone else
-# can write to the directory and if so, checks to see if
-# it has the sticky bit set
-
-# Will not work on systems that do not support sticky bit
-
-#Args: directory path to check
-# Optionally: reference to scalar to contain error message
-# Returns true if the path is safe and false otherwise.
-# Returns undef if can not even run stat() on the path
-
-# This routine based on version written by Tom Christiansen
-
-# Presumably, by the time we actually attempt to create the
-# file or directory in this directory, it may not be safe
-# anymore... Have to run _is_safe directly after the open.
-
-sub _is_safe {
-
- my $path = shift;
- my $err_ref = shift;
-
- # Stat path
- my @info = stat($path);
- unless (scalar(@info)) {
- $$err_ref = "stat(path) returned no values";
- return 0;
- };
- return 1 if $^O eq 'VMS'; # owner delete control at file level
-
- # Check to see whether owner is neither superuser (or a system uid) nor me
- # Use the real uid from the $< variable
- # UID is in [4]
- if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) {
-
- Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'",
- File::Temp->top_system_uid());
-
- $$err_ref = "Directory owned neither by root nor the current user"
- if ref($err_ref);
- return 0;
- }
-
- # check whether group or other can write file
- # use 066 to detect either reading or writing
- # use 022 to check writability
- # Do it with S_IWOTH and S_IWGRP for portability (maybe)
- # mode is in info[2]
- if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
- ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
- # Must be a directory
- unless (-d $path) {
- $$err_ref = "Path ($path) is not a directory"
- if ref($err_ref);
- return 0;
- }
- # Must have sticky bit set
- unless (-k $path) {
- $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
- if ref($err_ref);
- return 0;
- }
- }
-
- return 1;
-}
-
-# Internal routine to check whether a directory is safe
-# for temp files. Safer than _is_safe since it checks for
-# the possibility of chown giveaway and if that is a possibility
-# checks each directory in the path to see if it is safe (with _is_safe)
-
-# If _PC_CHOWN_RESTRICTED is not set, does the full test of each
-# directory anyway.
-
-# Takes optional second arg as scalar ref to error reason
-
-sub _is_verysafe {
-
- # Need POSIX - but only want to bother if really necessary due to overhead
- require POSIX;
-
- my $path = shift;
- print "_is_verysafe testing $path\n" if $DEBUG;
- return 1 if $^O eq 'VMS'; # owner delete control at file level
-
- my $err_ref = shift;
-
- # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
- # and If it is not there do the extensive test
- my $chown_restricted;
- $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
- if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
-
- # If chown_resticted is set to some value we should test it
- if (defined $chown_restricted) {
-
- # Return if the current directory is safe
- return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
-
- }
-
- # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
- # was not avialable or the symbol was there but chown giveaway
- # is allowed. Either way, we now have to test the entire tree for
- # safety.
-
- # Convert path to an absolute directory if required
- unless (File::Spec->file_name_is_absolute($path)) {
- $path = File::Spec->rel2abs($path);
- }
-
- # Split directory into components - assume no file
- my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
-
- # Slightly less efficient than having a function in File::Spec
- # to chop off the end of a directory or even a function that
- # can handle ../ in a directory tree
- # Sometimes splitdir() returns a blank at the end
- # so we will probably check the bottom directory twice in some cases
- my @dirs = File::Spec->splitdir($directories);
-
- # Concatenate one less directory each time around
- foreach my $pos (0.. $#dirs) {
- # Get a directory name
- my $dir = File::Spec->catpath($volume,
- File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
- ''
- );
-
- print "TESTING DIR $dir\n" if $DEBUG;
-
- # Check the directory
- return 0 unless _is_safe($dir,$err_ref);
-
- }
-
- return 1;
-}
-
-
-
-# internal routine to determine whether unlink works on this
-# platform for files that are currently open.
-# Returns true if we can, false otherwise.
-
-# Currently WinNT, OS/2 and VMS can not unlink an opened file
-# On VMS this is because the O_EXCL flag is used to open the
-# temporary file. Currently I do not know enough about the issues
-# on VMS to decide whether O_EXCL is a requirement.
-
-sub _can_unlink_opened_file {
-
- if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') {
- return 0;
- } else {
- return 1;
- }
-
-}
-
-# internal routine to decide which security levels are allowed
-# see safe_level() for more information on this
-
-# Controls whether the supplied security level is allowed
-
-# $cando = _can_do_level( $level )
-
-sub _can_do_level {
-
- # Get security level
- my $level = shift;
-
- # Always have to be able to do STANDARD
- return 1 if $level == STANDARD;
-
- # Currently, the systems that can do HIGH or MEDIUM are identical
- if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') {
- return 0;
- } else {
- return 1;
- }
-
-}
-
-# This routine sets up a deferred unlinking of a specified
-# filename and filehandle. It is used in the following cases:
-# - Called by unlink0 if an opened file can not be unlinked
-# - Called by tempfile() if files are to be removed on shutdown
-# - Called by tempdir() if directories are to be removed on shutdown
-
-# Arguments:
-# _deferred_unlink( $fh, $fname, $isdir );
-#
-# - filehandle (so that it can be expclicitly closed if open
-# - filename (the thing we want to remove)
-# - isdir (flag to indicate that we are being given a directory)
-# [and hence no filehandle]
-
-# Status is not referred to since all the magic is done with an END block
-
-{
- # Will set up two lexical variables to contain all the files to be
- # removed. One array for files, another for directories They will
- # only exist in this block.
-
- # This means we only have to set up a single END block to remove
- # all files.
-
- # in order to prevent child processes inadvertently deleting the parent
- # temp files we use a hash to store the temp files and directories
- # created by a particular process id.
-
- # %files_to_unlink contains values that are references to an array of
- # array references containing the filehandle and filename associated with
- # the temp file.
- my (%files_to_unlink, %dirs_to_unlink);
-
- # Set up an end block to use these arrays
- END {
- cleanup();
- }
-
- # Cleanup function. Always triggered on END but can be invoked
- # manually.
- sub cleanup {
- if (!$KEEP_ALL) {
- # Files
- my @files = (exists $files_to_unlink{$$} ?
- @{ $files_to_unlink{$$} } : () );
- foreach my $file (@files) {
- # close the filehandle without checking its state
- # in order to make real sure that this is closed
- # if its already closed then I dont care about the answer
- # probably a better way to do this
- close($file->[0]); # file handle is [0]
-
- if (-f $file->[1]) { # file name is [1]
- _force_writable( $file->[1] ); # for windows
- unlink $file->[1] or warn "Error removing ".$file->[1];
- }
- }
- # Dirs
- my @dirs = (exists $dirs_to_unlink{$$} ?
- @{ $dirs_to_unlink{$$} } : () );
- foreach my $dir (@dirs) {
- if (-d $dir) {
- rmtree($dir, $DEBUG, 0);
- }
- }
-
- # clear the arrays
- @{ $files_to_unlink{$$} } = ()
- if exists $files_to_unlink{$$};
- @{ $dirs_to_unlink{$$} } = ()
- if exists $dirs_to_unlink{$$};
- }
- }
-
-
- # This is the sub called to register a file for deferred unlinking
- # This could simply store the input parameters and defer everything
- # until the END block. For now we do a bit of checking at this
- # point in order to make sure that (1) we have a file/dir to delete
- # and (2) we have been called with the correct arguments.
- sub _deferred_unlink {
-
- croak 'Usage: _deferred_unlink($fh, $fname, $isdir)'
- unless scalar(@_) == 3;
-
- my ($fh, $fname, $isdir) = @_;
-
- warn "Setting up deferred removal of $fname\n"
- if $DEBUG;
-
- # If we have a directory, check that it is a directory
- if ($isdir) {
-
- if (-d $fname) {
-
- # Directory exists so store it
- # first on VMS turn []foo into [.foo] for rmtree
- $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
- $dirs_to_unlink{$$} = []
- unless exists $dirs_to_unlink{$$};
- push (@{ $dirs_to_unlink{$$} }, $fname);
-
- } else {
- carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
- }
-
- } else {
-
- if (-f $fname) {
-
- # file exists so store handle and name for later removal
- $files_to_unlink{$$} = []
- unless exists $files_to_unlink{$$};
- push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
-
- } else {
- carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
- }
-
- }
-
- }
-
-
-}
-
-=head1 OBJECT-ORIENTED INTERFACE
-
-This is the primary interface for interacting with
-C<File::Temp>. Using the OO interface a temporary file can be created
-when the object is constructed and the file can be removed when the
-object is no longer required.
-
-Note that there is no method to obtain the filehandle from the
-C<File::Temp> object. The object itself acts as a filehandle. Also,
-the object is configured such that it stringifies to the name of the
-temporary file.
-
-=over 4
-
-=item B<new>
-
-Create a temporary file object.
-
- my $tmp = new File::Temp();
-
-by default the object is constructed as if C<tempfile>
-was called without options, but with the additional behaviour
-that the temporary file is removed by the object destructor
-if UNLINK is set to true (the default).
-
-Supported arguments are the same as for C<tempfile>: UNLINK
-(defaulting to true), DIR and SUFFIX. Additionally, the filename
-template is specified using the TEMPLATE option. The OPEN option
-is not supported (the file is always opened).
-
- $tmp = new File::Temp( TEMPLATE => 'tempXXXXX',
- DIR => 'mydir',
- SUFFIX => '.dat');
-
-Arguments are case insensitive.
-
-=cut
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
-
- # read arguments and convert keys to upper case
- my %args = @_;
- %args = map { uc($_), $args{$_} } keys %args;
-
- # see if they are unlinking (defaulting to yes)
- my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 );
- delete $args{UNLINK};
-
- # template (store it in an error so that it will
- # disappear from the arg list of tempfile
- my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () );
- delete $args{TEMPLATE};
-
- # Protect OPEN
- delete $args{OPEN};
-
- # Open the file and retain file handle and file name
- my ($fh, $path) = tempfile( @template, %args );
-
- print "Tmp: $fh - $path\n" if $DEBUG;
-
- # Store the filename in the scalar slot
- ${*$fh} = $path;
-
- # Store unlink information in hash slot (plus other constructor info)
- %{*$fh} = %args;
-
- # create the object
- bless $fh, $class;
-
- # final method-based configuration
- $fh->unlink_on_destroy( $unlink );
-
- return $fh;
-}
-
-=item B<filename>
-
-Return the name of the temporary file associated with this object.
-
- $filename = $tmp->filename;
-
-This method is called automatically when the object is used as
-a string.
-
-=cut
-
-sub filename {
- my $self = shift;
- return ${*$self};
-}
-
-sub STRINGIFY {
- my $self = shift;
- return $self->filename;
-}
-
-=item B<unlink_on_destroy>
-
-Control whether the file is unlinked when the object goes out of scope.
-The file is removed if this value is true and $KEEP_ALL is not.
-
- $fh->unlink_on_destroy( 1 );
-
-Default is for the file to be removed.
-
-=cut
-
-sub unlink_on_destroy {
- my $self = shift;
- if (@_) {
- ${*$self}{UNLINK} = shift;
- }
- return ${*$self}{UNLINK};
-}
-
-=item B<DESTROY>
-
-When the object goes out of scope, the destructor is called. This
-destructor will attempt to unlink the file (using C<unlink1>)
-if the constructor was called with UNLINK set to 1 (the default state
-if UNLINK is not specified).
-
-No error is given if the unlink fails.
-
-If the global variable $KEEP_ALL is true, the file will not be removed.
-
-=cut
-
-sub DESTROY {
- my $self = shift;
- if (${*$self}{UNLINK} && !$KEEP_ALL) {
- print "# ---------> Unlinking $self\n" if $DEBUG;
-
- # The unlink1 may fail if the file has been closed
- # by the caller. This leaves us with the decision
- # of whether to refuse to remove the file or simply
- # do an unlink without test. Seems to be silly
- # to do this when we are trying to be careful
- # about security
- _force_writable( $self->filename ); # for windows
- unlink1( $self, $self->filename )
- or unlink($self->filename);
- }
-}
-
-=back
-
-=head1 FUNCTIONS
-
-This section describes the recommended interface for generating
-temporary files and directories.
-
-=over 4
-
-=item B<tempfile>
-
-This is the basic function to generate temporary files.
-The behaviour of the file can be changed using various options:
-
- $fh = tempfile();
- ($fh, $filename) = tempfile();
-
-Create a temporary file in the directory specified for temporary
-files, as specified by the tmpdir() function in L<File::Spec>.
-
- ($fh, $filename) = tempfile($template);
-
-Create a temporary file in the current directory using the supplied
-template. Trailing `X' characters are replaced with random letters to
-generate the filename. At least four `X' characters must be present
-at the end of the template.
-
- ($fh, $filename) = tempfile($template, SUFFIX => $suffix)
-
-Same as previously, except that a suffix is added to the template
-after the `X' translation. Useful for ensuring that a temporary
-filename has a particular extension when needed by other applications.
-But see the WARNING at the end.
-
- ($fh, $filename) = tempfile($template, DIR => $dir);
-
-Translates the template as before except that a directory name
-is specified.
-
- ($fh, $filename) = tempfile($template, UNLINK => 1);
-
-Return the filename and filehandle as before except that the file is
-automatically removed when the program exits (dependent on
-$KEEP_ALL). Default is for the file to be removed if a file handle is
-requested and to be kept if the filename is requested. In a scalar
-context (where no filename is returned) the file is always deleted
-either (depending on the operating system) on exit or when it is
-closed (unless $KEEP_ALL is true when the temp file is created).
-
-Use the object-oriented interface if fine-grained control of when
-a file is removed is required.
-
-If the template is not specified, a template is always
-automatically generated. This temporary file is placed in tmpdir()
-(L<File::Spec>) unless a directory is specified explicitly with the
-DIR option.
-
- $fh = tempfile( $template, DIR => $dir );
-
-If called in scalar context, only the filehandle is returned and the
-file will automatically be deleted when closed on operating systems
-that support this (see the description of tmpfile() elsewhere in this
-document). This is the preferred mode of operation, as if you only
-have a filehandle, you can never create a race condition by fumbling
-with the filename. On systems that can not unlink an open file or can
-not mark a file as temporary when it is opened (for example, Windows
-NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when
-the program ends (equivalent to setting UNLINK to 1). The C<UNLINK>
-flag is ignored if present.
-
- (undef, $filename) = tempfile($template, OPEN => 0);
-
-This will return the filename based on the template but
-will not open this file. Cannot be used in conjunction with
-UNLINK set to true. Default is to always open the file
-to protect from possible race conditions. A warning is issued
-if warnings are turned on. Consider using the tmpnam()
-and mktemp() functions described elsewhere in this document
-if opening the file is not required.
-
-Options can be combined as required.
-
-=cut
-
-sub tempfile {
-
- # Can not check for argument count since we can have any
- # number of args
-
- # Default options
- my %options = (
- "DIR" => undef, # Directory prefix
- "SUFFIX" => '', # Template suffix
- "UNLINK" => 0, # Do not unlink file on exit
- "OPEN" => 1, # Open file
- );
-
- # Check to see whether we have an odd or even number of arguments
- my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef);
-
- # Read the options and merge with defaults
- %options = (%options, @_) if @_;
-
- # First decision is whether or not to open the file
- if (! $options{"OPEN"}) {
-
- warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
- if $^W;
-
- }
-
- if ($options{"DIR"} and $^O eq 'VMS') {
-
- # on VMS turn []foo into [.foo] for concatenation
- $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
- }
-
- # Construct the template
-
- # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
- # functions or simply constructing a template and using _gettemp()
- # explicitly. Go for the latter
-
- # First generate a template if not defined and prefix the directory
- # If no template must prefix the temp directory
- if (defined $template) {
- if ($options{"DIR"}) {
-
- $template = File::Spec->catfile($options{"DIR"}, $template);
-
- }
-
- } else {
-
- if ($options{"DIR"}) {
-
- $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
-
- } else {
-
- $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
-
- }
-
- }
-
- # Now add a suffix
- $template .= $options{"SUFFIX"};
-
- # Determine whether we should tell _gettemp to unlink the file
- # On unix this is irrelevant and can be worked out after the file is
- # opened (simply by unlinking the open filehandle). On Windows or VMS
- # we have to indicate temporary-ness when we open the file. In general
- # we only want a true temporary file if we are returning just the
- # filehandle - if the user wants the filename they probably do not
- # want the file to disappear as soon as they close it (which may be
- # important if they want a child process to use the file)
- # For this reason, tie unlink_on_close to the return context regardless
- # of OS.
- my $unlink_on_close = ( wantarray ? 0 : 1);
-
- # Create the file
- my ($fh, $path, $errstr);
- croak "Error in tempfile() using $template: $errstr"
- unless (($fh, $path) = _gettemp($template,
- "open" => $options{'OPEN'},
- "mkdir"=> 0 ,
- "unlink_on_close" => $unlink_on_close,
- "suffixlen" => length($options{'SUFFIX'}),
- "ErrStr" => \$errstr,
- ) );
-
- # Set up an exit handler that can do whatever is right for the
- # system. This removes files at exit when requested explicitly or when
- # system is asked to unlink_on_close but is unable to do so because
- # of OS limitations.
- # The latter should be achieved by using a tied filehandle.
- # Do not check return status since this is all done with END blocks.
- _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
-
- # Return
- if (wantarray()) {
-
- if ($options{'OPEN'}) {
- return ($fh, $path);
- } else {
- return (undef, $path);
- }
-
- } else {
-
- # Unlink the file. It is up to unlink0 to decide what to do with
- # this (whether to unlink now or to defer until later)
- unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
-
- # Return just the filehandle.
- return $fh;
- }
-
-
-}
-
-=item B<tempdir>
-
-This is the recommended interface for creation of temporary directories.
-The behaviour of the function depends on the arguments:
-
- $tempdir = tempdir();
-
-Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
-
- $tempdir = tempdir( $template );
-
-Create a directory from the supplied template. This template is
-similar to that described for tempfile(). `X' characters at the end
-of the template are replaced with random letters to construct the
-directory name. At least four `X' characters must be in the template.
-
- $tempdir = tempdir ( DIR => $dir );
-
-Specifies the directory to use for the temporary directory.
-The temporary directory name is derived from an internal template.
-
- $tempdir = tempdir ( $template, DIR => $dir );
-
-Prepend the supplied directory name to the template. The template
-should not include parent directory specifications itself. Any parent
-directory specifications are removed from the template before
-prepending the supplied directory.
-
- $tempdir = tempdir ( $template, TMPDIR => 1 );
-
-Using the supplied template, create the temporary directory in
-a standard location for temporary files. Equivalent to doing
-
- $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
-
-but shorter. Parent directory specifications are stripped from the
-template itself. The C<TMPDIR> option is ignored if C<DIR> is set
-explicitly. Additionally, C<TMPDIR> is implied if neither a template
-nor a directory are supplied.
-
- $tempdir = tempdir( $template, CLEANUP => 1);
-
-Create a temporary directory using the supplied template, but
-attempt to remove it (and all files inside it) when the program
-exits. Note that an attempt will be made to remove all files from
-the directory even if they were not created by this module (otherwise
-why ask to clean it up?). The directory removal is made with
-the rmtree() function from the L<File::Path|File::Path> module.
-Of course, if the template is not specified, the temporary directory
-will be created in tmpdir() and will also be removed at program exit.
-
-=cut
-
-# '
-
-sub tempdir {
-
- # Can not check for argument count since we can have any
- # number of args
-
- # Default options
- my %options = (
- "CLEANUP" => 0, # Remove directory on exit
- "DIR" => '', # Root directory
- "TMPDIR" => 0, # Use tempdir with template
- );
-
- # Check to see whether we have an odd or even number of arguments
- my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
-
- # Read the options and merge with defaults
- %options = (%options, @_) if @_;
-
- # Modify or generate the template
-
- # Deal with the DIR and TMPDIR options
- if (defined $template) {
-
- # Need to strip directory path if using DIR or TMPDIR
- if ($options{'TMPDIR'} || $options{'DIR'}) {
-
- # Strip parent directory from the filename
- #
- # There is no filename at the end
- $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
- my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
-
- # Last directory is then our template
- $template = (File::Spec->splitdir($directories))[-1];
-
- # Prepend the supplied directory or temp dir
- if ($options{"DIR"}) {
-
- $template = File::Spec->catdir($options{"DIR"}, $template);
-
- } elsif ($options{TMPDIR}) {
-
- # Prepend tmpdir
- $template = File::Spec->catdir(File::Spec->tmpdir, $template);
-
- }
-
- }
-
- } else {
-
- if ($options{"DIR"}) {
-
- $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
-
- } else {
-
- $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
-
- }
-
- }
-
- # Create the directory
- my $tempdir;
- my $suffixlen = 0;
- if ($^O eq 'VMS') { # dir names can end in delimiters
- $template =~ m/([\.\]:>]+)$/;
- $suffixlen = length($1);
- }
- if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
- # dir name has a trailing ':'
- ++$suffixlen;
- }
-
- my $errstr;
- croak "Error in tempdir() using $template: $errstr"
- unless ((undef, $tempdir) = _gettemp($template,
- "open" => 0,
- "mkdir"=> 1 ,
- "suffixlen" => $suffixlen,
- "ErrStr" => \$errstr,
- ) );
-
- # Install exit handler; must be dynamic to get lexical
- if ( $options{'CLEANUP'} && -d $tempdir) {
- _deferred_unlink(undef, $tempdir, 1);
- }
-
- # Return the dir name
- return $tempdir;
-
-}
-
-=back
-
-=head1 MKTEMP FUNCTIONS
-
-The following functions are Perl implementations of the
-mktemp() family of temp file generation system calls.
-
-=over 4
-
-=item B<mkstemp>
-
-Given a template, returns a filehandle to the temporary file and the name
-of the file.
-
- ($fh, $name) = mkstemp( $template );
-
-In scalar context, just the filehandle is returned.
-
-The template may be any filename with some number of X's appended
-to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
-with unique alphanumeric combinations.
-
-=cut
-
-
-
-sub mkstemp {
-
- croak "Usage: mkstemp(template)"
- if scalar(@_) != 1;
-
- my $template = shift;
-
- my ($fh, $path, $errstr);
- croak "Error in mkstemp using $template: $errstr"
- unless (($fh, $path) = _gettemp($template,
- "open" => 1,
- "mkdir"=> 0 ,
- "suffixlen" => 0,
- "ErrStr" => \$errstr,
- ) );
-
- if (wantarray()) {
- return ($fh, $path);
- } else {
- return $fh;
- }
-
-}
-
-
-=item B<mkstemps>
-
-Similar to mkstemp(), except that an extra argument can be supplied
-with a suffix to be appended to the template.
-
- ($fh, $name) = mkstemps( $template, $suffix );
-
-For example a template of C<testXXXXXX> and suffix of C<.dat>
-would generate a file similar to F<testhGji_w.dat>.
-
-Returns just the filehandle alone when called in scalar context.
-
-=cut
-
-sub mkstemps {
-
- croak "Usage: mkstemps(template, suffix)"
- if scalar(@_) != 2;
-
-
- my $template = shift;
- my $suffix = shift;
-
- $template .= $suffix;
-
- my ($fh, $path, $errstr);
- croak "Error in mkstemps using $template: $errstr"
- unless (($fh, $path) = _gettemp($template,
- "open" => 1,
- "mkdir"=> 0 ,
- "suffixlen" => length($suffix),
- "ErrStr" => \$errstr,
- ) );
-
- if (wantarray()) {
- return ($fh, $path);
- } else {
- return $fh;
- }
-
-}
-
-=item B<mkdtemp>
-
-Create a directory from a template. The template must end in
-X's that are replaced by the routine.
-
- $tmpdir_name = mkdtemp($template);
-
-Returns the name of the temporary directory created.
-Returns undef on failure.
-
-Directory must be removed by the caller.
-
-=cut
-
-#' # for emacs
-
-sub mkdtemp {
-
- croak "Usage: mkdtemp(template)"
- if scalar(@_) != 1;
-
- my $template = shift;
- my $suffixlen = 0;
- if ($^O eq 'VMS') { # dir names can end in delimiters
- $template =~ m/([\.\]:>]+)$/;
- $suffixlen = length($1);
- }
- if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
- # dir name has a trailing ':'
- ++$suffixlen;
- }
- my ($junk, $tmpdir, $errstr);
- croak "Error creating temp directory from template $template\: $errstr"
- unless (($junk, $tmpdir) = _gettemp($template,
- "open" => 0,
- "mkdir"=> 1 ,
- "suffixlen" => $suffixlen,
- "ErrStr" => \$errstr,
- ) );
-
- return $tmpdir;
-
-}
-
-=item B<mktemp>
-
-Returns a valid temporary filename but does not guarantee
-that the file will not be opened by someone else.
-
- $unopened_file = mktemp($template);
-
-Template is the same as that required by mkstemp().
-
-=cut
-
-sub mktemp {
-
- croak "Usage: mktemp(template)"
- if scalar(@_) != 1;
-
- my $template = shift;
-
- my ($tmpname, $junk, $errstr);
- croak "Error getting name to temp file from template $template: $errstr"
- unless (($junk, $tmpname) = _gettemp($template,
- "open" => 0,
- "mkdir"=> 0 ,
- "suffixlen" => 0,
- "ErrStr" => \$errstr,
- ) );
-
- return $tmpname;
-}
-
-=back
-
-=head1 POSIX FUNCTIONS
-
-This section describes the re-implementation of the tmpnam()
-and tmpfile() functions described in L<POSIX>
-using the mkstemp() from this module.
-
-Unlike the L<POSIX|POSIX> implementations, the directory used
-for the temporary file is not specified in a system include
-file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
-returned by L<File::Spec|File::Spec>. On some implementations this
-location can be set using the C<TMPDIR> environment variable, which
-may not be secure.
-If this is a problem, simply use mkstemp() and specify a template.
-
-=over 4
-
-=item B<tmpnam>
-
-When called in scalar context, returns the full name (including path)
-of a temporary file (uses mktemp()). The only check is that the file does
-not already exist, but there is no guarantee that that condition will
-continue to apply.
-
- $file = tmpnam();
-
-When called in list context, a filehandle to the open file and
-a filename are returned. This is achieved by calling mkstemp()
-after constructing a suitable template.
-
- ($fh, $file) = tmpnam();
-
-If possible, this form should be used to prevent possible
-race conditions.
-
-See L<File::Spec/tmpdir> for information on the choice of temporary
-directory for a particular operating system.
-
-=cut
-
-sub tmpnam {
-
- # Retrieve the temporary directory name
- my $tmpdir = File::Spec->tmpdir;
-
- croak "Error temporary directory is not writable"
- if $tmpdir eq '';
-
- # Use a ten character template and append to tmpdir
- my $template = File::Spec->catfile($tmpdir, TEMPXXX);
-
- if (wantarray() ) {
- return mkstemp($template);
- } else {
- return mktemp($template);
- }
-
-}
-
-=item B<tmpfile>
-
-Returns the filehandle of a temporary file.
-
- $fh = tmpfile();
-
-The file is removed when the filehandle is closed or when the program
-exits. No access to the filename is provided.
-
-If the temporary file can not be created undef is returned.
-Currently this command will probably not work when the temporary
-directory is on an NFS file system.
-
-=cut
-
-sub tmpfile {
-
- # Simply call tmpnam() in a list context
- my ($fh, $file) = tmpnam();
-
- # Make sure file is removed when filehandle is closed
- # This will fail on NFS
- unlink0($fh, $file)
- or return undef;
-
- return $fh;
-
-}
-
-=back
-
-=head1 ADDITIONAL FUNCTIONS
-
-These functions are provided for backwards compatibility
-with common tempfile generation C library functions.
-
-They are not exported and must be addressed using the full package
-name.
-
-=over 4
-
-=item B<tempnam>
-
-Return the name of a temporary file in the specified directory
-using a prefix. The file is guaranteed not to exist at the time
-the function was called, but such guarantees are good for one
-clock tick only. Always use the proper form of C<sysopen>
-with C<O_CREAT | O_EXCL> if you must open such a filename.
-
- $filename = File::Temp::tempnam( $dir, $prefix );
-
-Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
-(using unix file convention as an example)
-
-Because this function uses mktemp(), it can suffer from race conditions.
-
-=cut
-
-sub tempnam {
-
- croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
-
- my ($dir, $prefix) = @_;
-
- # Add a string to the prefix
- $prefix .= 'XXXXXXXX';
-
- # Concatenate the directory to the file
- my $template = File::Spec->catfile($dir, $prefix);
-
- return mktemp($template);
-
-}
-
-=back
-
-=head1 UTILITY FUNCTIONS
-
-Useful functions for dealing with the filehandle and filename.
-
-=over 4
-
-=item B<unlink0>
-
-Given an open filehandle and the associated filename, make a safe
-unlink. This is achieved by first checking that the filename and
-filehandle initially point to the same file and that the number of
-links to the file is 1 (all fields returned by stat() are compared).
-Then the filename is unlinked and the filehandle checked once again to
-verify that the number of links on that file is now 0. This is the
-closest you can come to making sure that the filename unlinked was the
-same as the file whose descriptor you hold.
-
- unlink0($fh, $path)
- or die "Error unlinking file $path safely";
-
-Returns false on error. The filehandle is not closed since on some
-occasions this is not required.
-
-On some platforms, for example Windows NT, it is not possible to
-unlink an open file (the file must be closed first). On those
-platforms, the actual unlinking is deferred until the program ends and
-good status is returned. A check is still performed to make sure that
-the filehandle and filename are pointing to the same thing (but not at
-the time the end block is executed since the deferred removal may not
-have access to the filehandle).
-
-Additionally, on Windows NT not all the fields returned by stat() can
-be compared. For example, the C<dev> and C<rdev> fields seem to be
-different. Also, it seems that the size of the file returned by stat()
-does not always agree, with C<stat(FH)> being more accurate than
-C<stat(filename)>, presumably because of caching issues even when
-using autoflush (this is usually overcome by waiting a while after
-writing to the tempfile before attempting to C<unlink0> it).
-
-Finally, on NFS file systems the link count of the file handle does
-not always go to zero immediately after unlinking. Currently, this
-command is expected to fail on NFS disks.
-
-This function is disabled if the global variable $KEEP_ALL is true
-and an unlink on open file is supported. If the unlink is to be deferred
-to the END block, the file is still registered for removal.
-
-=cut
-
-sub unlink0 {
-
- croak 'Usage: unlink0(filehandle, filename)'
- unless scalar(@_) == 2;
-
- # Read args
- my ($fh, $path) = @_;
-
- cmpstat($fh, $path) or return 0;
-
- # attempt remove the file (does not work on some platforms)
- if (_can_unlink_opened_file()) {
-
- # return early (Without unlink) if we have been instructed to retain files.
- return 1 if $KEEP_ALL;
-
- # XXX: do *not* call this on a directory; possible race
- # resulting in recursive removal
- croak "unlink0: $path has become a directory!" if -d $path;
- unlink($path) or return 0;
-
- # Stat the filehandle
- my @fh = stat $fh;
-
- print "Link count = $fh[3] \n" if $DEBUG;
-
- # Make sure that the link count is zero
- # - Cygwin provides deferred unlinking, however,
- # on Win9x the link count remains 1
- # On NFS the link count may still be 1 but we cant know that
- # we are on NFS
- return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0);
-
- } else {
- _deferred_unlink($fh, $path, 0);
- return 1;
- }
-
-}
-
-=item B<cmpstat>
-
-Compare C<stat> of filehandle with C<stat> of provided filename. This
-can be used to check that the filename and filehandle initially point
-to the same file and that the number of links to the file is 1 (all
-fields returned by stat() are compared).
-
- cmpstat($fh, $path)
- or die "Error comparing handle with file";
-
-Returns false if the stat information differs or if the link count is
-greater than 1.
-
-On certain platofms, eg Windows, not all the fields returned by stat()
-can be compared. For example, the C<dev> and C<rdev> fields seem to be
-different in Windows. Also, it seems that the size of the file
-returned by stat() does not always agree, with C<stat(FH)> being more
-accurate than C<stat(filename)>, presumably because of caching issues
-even when using autoflush (this is usually overcome by waiting a while
-after writing to the tempfile before attempting to C<unlink0> it).
-
-Not exported by default.
-
-=cut
-
-sub cmpstat {
-
- croak 'Usage: cmpstat(filehandle, filename)'
- unless scalar(@_) == 2;
-
- # Read args
- my ($fh, $path) = @_;
-
- warn "Comparing stat\n"
- if $DEBUG;
-
- # Stat the filehandle - which may be closed if someone has manually
- # closed the file. Can not turn off warnings without using $^W
- # unless we upgrade to 5.006 minimum requirement
- my @fh;
- {
- local ($^W) = 0;
- @fh = stat $fh;
- }
- return unless @fh;
-
- if ($fh[3] > 1 && $^W) {
- carp "unlink0: fstat found too many links; SB=@fh" if $^W;
- }
-
- # Stat the path
- my @path = stat $path;
-
- unless (@path) {
- carp "unlink0: $path is gone already" if $^W;
- return;
- }
-
- # this is no longer a file, but may be a directory, or worse
- unless (-f $path) {
- confess "panic: $path is no longer a file: SB=@fh";
- }
-
- # Do comparison of each member of the array
- # On WinNT dev and rdev seem to be different
- # depending on whether it is a file or a handle.
- # Cannot simply compare all members of the stat return
- # Select the ones we can use
- my @okstat = (0..$#fh); # Use all by default
- if ($^O eq 'MSWin32') {
- @okstat = (1,2,3,4,5,7,8,9,10);
- } elsif ($^O eq 'os2') {
- @okstat = (0, 2..$#fh);
- } elsif ($^O eq 'VMS') { # device and file ID are sufficient
- @okstat = (0, 1);
- } elsif ($^O eq 'dos') {
- @okstat = (0,2..7,11..$#fh);
- } elsif ($^O eq 'mpeix') {
- @okstat = (0..4,8..10);
- }
-
- # Now compare each entry explicitly by number
- for (@okstat) {
- print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
- # Use eq rather than == since rdev, blksize, and blocks (6, 11,
- # and 12) will be '' on platforms that do not support them. This
- # is fine since we are only comparing integers.
- unless ($fh[$_] eq $path[$_]) {
- warn "Did not match $_ element of stat\n" if $DEBUG;
- return 0;
- }
- }
-
- return 1;
-}
-
-=item B<unlink1>
-
-Similar to C<unlink0> except after file comparison using cmpstat, the
-filehandle is closed prior to attempting to unlink the file. This
-allows the file to be removed without using an END block, but does
-mean that the post-unlink comparison of the filehandle state provided
-by C<unlink0> is not available.
-
- unlink1($fh, $path)
- or die "Error closing and unlinking file";
-
-Usually called from the object destructor when using the OO interface.
-
-Not exported by default.
-
-This function is disabled if the global variable $KEEP_ALL is true.
-
-=cut
-
-sub unlink1 {
- croak 'Usage: unlink1(filehandle, filename)'
- unless scalar(@_) == 2;
-
- # Read args
- my ($fh, $path) = @_;
-
- cmpstat($fh, $path) or return 0;
-
- # Close the file
- close( $fh ) or return 0;
-
- # Make sure the file is writable (for windows)
- _force_writable( $path );
-
- # return early (without unlink) if we have been instructed to retain files.
- return 1 if $KEEP_ALL;
-
- # remove the file
- return unlink($path);
-}
-
-=item B<cleanup>
-
-Calling this function will cause any temp files or temp directories
-that are registered for removal to be removed. This happens automatically
-when the process exits but can be triggered manually if the caller is sure
-that none of the temp files are required. This method can be registered as
-an Apache callback.
-
-On OSes where temp files are automatically removed when the temp file
-is closed, calling this function will have no effect other than to remove
-temporary directories (which may include temporary files).
-
- File::Temp::cleanup();
-
-Not exported by default.
-
-=back
-
-=head1 PACKAGE VARIABLES
-
-These functions control the global state of the package.
-
-=over 4
-
-=item B<safe_level>
-
-Controls the lengths to which the module will go to check the safety of the
-temporary file or directory before proceeding.
-Options are:
-
-=over 8
-
-=item STANDARD
-
-Do the basic security measures to ensure the directory exists and
-is writable, that the umask() is fixed before opening of the file,
-that temporary files are opened only if they do not already exist, and
-that possible race conditions are avoided. Finally the L<unlink0|"unlink0">
-function is used to remove files safely.
-
-=item MEDIUM
-
-In addition to the STANDARD security, the output directory is checked
-to make sure that it is owned either by root or the user running the
-program. If the directory is writable by group or by other, it is then
-checked to make sure that the sticky bit is set.
-
-Will not work on platforms that do not support the C<-k> test
-for sticky bit.
-
-=item HIGH
-
-In addition to the MEDIUM security checks, also check for the
-possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
-sysconf() function. If this is a possibility, each directory in the
-path is checked in turn for safeness, recursively walking back to the
-root directory.
-
-For platforms that do not support the L<POSIX|POSIX>
-C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
-assumed that ``chown() giveaway'' is possible and the recursive test
-is performed.
-
-=back
-
-The level can be changed as follows:
-
- File::Temp->safe_level( File::Temp::HIGH );
-
-The level constants are not exported by the module.
-
-Currently, you must be running at least perl v5.6.0 in order to
-run with MEDIUM or HIGH security. This is simply because the
-safety tests use functions from L<Fcntl|Fcntl> that are not
-available in older versions of perl. The problem is that the version
-number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
-they are different versions.
-
-On systems that do not support the HIGH or MEDIUM safety levels
-(for example Win NT or OS/2) any attempt to change the level will
-be ignored. The decision to ignore rather than raise an exception
-allows portable programs to be written with high security in mind
-for the systems that can support this without those programs failing
-on systems where the extra tests are irrelevant.
-
-If you really need to see whether the change has been accepted
-simply examine the return value of C<safe_level>.
-
- $newlevel = File::Temp->safe_level( File::Temp::HIGH );
- die "Could not change to high security"
- if $newlevel != File::Temp::HIGH;
-
-=cut
-
-{
- # protect from using the variable itself
- my $LEVEL = STANDARD;
- sub safe_level {
- my $self = shift;
- if (@_) {
- my $level = shift;
- if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
- carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
- } else {
- # Dont allow this on perl 5.005 or earlier
- if ($] < 5.006 && $level != STANDARD) {
- # Cant do MEDIUM or HIGH checks
- croak "Currently requires perl 5.006 or newer to do the safe checks";
- }
- # Check that we are allowed to change level
- # Silently ignore if we can not.
- $LEVEL = $level if _can_do_level($level);
- }
- }
- return $LEVEL;
- }
-}
-
-=item TopSystemUID
-
-This is the highest UID on the current system that refers to a root
-UID. This is used to make sure that the temporary directory is
-owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than
-simply by root.
-
-This is required since on many unix systems C</tmp> is not owned
-by root.
-
-Default is to assume that any UID less than or equal to 10 is a root
-UID.
-
- File::Temp->top_system_uid(10);
- my $topid = File::Temp->top_system_uid;
-
-This value can be adjusted to reduce security checking if required.
-The value is only relevant when C<safe_level> is set to MEDIUM or higher.
-
-=cut
-
-{
- my $TopSystemUID = 10;
- sub top_system_uid {
- my $self = shift;
- if (@_) {
- my $newuid = shift;
- croak "top_system_uid: UIDs should be numeric"
- unless $newuid =~ /^\d+$/s;
- $TopSystemUID = $newuid;
- }
- return $TopSystemUID;
- }
-}
-
-=item B<$KEEP_ALL>
-
-Controls whether temporary files and directories should be retained
-regardless of any instructions in the program to remove them
-automatically. This is useful for debugging but should not be used in
-production code.
-
- $File::Temp::KEEP_ALL = 1;
-
-Default is for files to be removed as requested by the caller.
-
-In some cases, files will only be retained if this variable is true
-when the file is created. This means that you can not create a temporary
-file, set this variable and expect the temp file to still be around
-when the program exits.
-
-=item B<$DEBUG>
-
-Controls whether debugging messages should be enabled.
-
- $File::Temp::DEBUG = 1;
-
-Default is for debugging mode to be disabled.
-
-=back
-
-=head1 WARNING
-
-For maximum security, endeavour always to avoid ever looking at,
-touching, or even imputing the existence of the filename. You do not
-know that that filename is connected to the same file as the handle
-you have, and attempts to check this can only trigger more race
-conditions. It's far more secure to use the filehandle alone and
-dispense with the filename altogether.
-
-If you need to pass the handle to something that expects a filename
-then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary
-programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl
-programs. You will have to clear the close-on-exec bit on that file
-descriptor before passing it to another process.
-
- use Fcntl qw/F_SETFD F_GETFD/;
- fcntl($tmpfh, F_SETFD, 0)
- or die "Can't clear close-on-exec flag on temp fh: $!\n";
-
-=head2 Temporary files and NFS
-
-Some problems are associated with using temporary files that reside
-on NFS file systems and it is recommended that a local filesystem
-is used whenever possible. Some of the security tests will most probably
-fail when the temp file is not local. Additionally, be aware that
-the performance of I/O operations over NFS will not be as good as for
-a local disk.
-
-=head2 Forking
-
-In some cases files created by File::Temp are removed from within an
-END block. Since END blocks are triggered when a child process exits
-(unless C<POSIX::_exit()> is used by the child) File::Temp takes care
-to only remove those temp files created by a particular process ID. This
-means that a child will not attempt to remove temp files created by the
-parent process.
-
-=head2 BINMODE
-
-The file returned by File::Temp will have been opened in binary mode
-if such a mode is available. If that is not correct, use the binmode()
-function to change the mode of the filehandle.
-
-=head1 HISTORY
-
-Originally began life in May 1999 as an XS interface to the system
-mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
-translated to Perl for total control of the code's
-security checking, to ensure the presence of the function regardless of
-operating system and to help with portability. The module was shipped
-as a standard part of perl from v5.6.1.
-
-=head1 SEE ALSO
-
-L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
-
-See L<IO::File> and L<File::MkTemp>, L<Apachae::TempFile> for
-different implementations of temporary file handling.
-
-=head1 AUTHOR
-
-Tim Jenness E<lt>tjenness@cpan.orgE<gt>
-
-Copyright (C) 1999-2005 Tim Jenness and the UK Particle Physics and
-Astronomy Research Council. All Rights Reserved. This program is free
-software; you can redistribute it and/or modify it under the same
-terms as Perl itself.
-
-Original Perl implementation loosely based on the OpenBSD C code for
-mkstemp(). Thanks to Tom Christiansen for suggesting that this module
-should be written and providing ideas for code improvements and
-security enhancements.
-
-=cut
-
-1;
diff --git a/Master/tlpkg/installer/perllib/File/stat.pm b/Master/tlpkg/installer/perllib/File/stat.pm
deleted file mode 100644
index 132cbee27ad..00000000000
--- a/Master/tlpkg/installer/perllib/File/stat.pm
+++ /dev/null
@@ -1,139 +0,0 @@
-package File::stat;
-use 5.006;
-
-use strict;
-use warnings;
-
-our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
-our $VERSION = '1.00';
-
-BEGIN {
- use Exporter ();
- @EXPORT = qw(stat lstat);
- @EXPORT_OK = qw( $st_dev $st_ino $st_mode
- $st_nlink $st_uid $st_gid
- $st_rdev $st_size
- $st_atime $st_mtime $st_ctime
- $st_blksize $st_blocks
- );
- %EXPORT_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 'File::stat' => [
- map { $_ => '$' } qw{
- dev ino mode nlink uid gid rdev size
- atime mtime ctime blksize blocks
- }
-];
-
-sub populate (@) {
- return unless @_;
- my $stob = new();
- @$stob = (
- $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
- $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks )
- = @_;
- return $stob;
-}
-
-sub lstat ($) { populate(CORE::lstat(shift)) }
-
-sub stat ($) {
- my $arg = shift;
- my $st = populate(CORE::stat $arg);
- return $st if $st;
- my $fh;
- {
- local $!;
- no strict 'refs';
- require Symbol;
- $fh = \*{ Symbol::qualify( $arg, caller() )};
- return unless defined fileno $fh;
- }
- return populate(CORE::stat $fh);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-File::stat - by-name interface to Perl's built-in stat() functions
-
-=head1 SYNOPSIS
-
- use File::stat;
- $st = stat($file) or die "No $file: $!";
- if ( ($st->mode & 0111) && $st->nlink > 1) ) {
- print "$file is executable with lotsa links\n";
- }
-
- use File::stat qw(:FIELDS);
- stat($file) or die "No $file: $!";
- if ( ($st_mode & 0111) && $st_nlink > 1) ) {
- print "$file is executable with lotsa links\n";
- }
-
-=head1 DESCRIPTION
-
-This module's default exports override the core stat()
-and lstat() functions, replacing them with versions that return
-"File::stat" objects. This object has methods that
-return the similarly named structure field name from the
-stat(2) function; namely,
-dev,
-ino,
-mode,
-nlink,
-uid,
-gid,
-rdev,
-size,
-atime,
-mtime,
-ctime,
-blksize,
-and
-blocks.
-
-You may also import all the structure fields directly into your namespace
-as regular variables using the :FIELDS import tag. (Note that this still
-overrides your stat() and lstat() functions.) Access these fields as
-variables named with a preceding C<st_> in front their method names.
-Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
-the fields.
-
-To access this functionality without the core overrides,
-pass the C<use> an empty import list, and then access
-function functions with their full qualified names.
-On the other hand, the built-ins are still available
-via the C<CORE::> pseudo-package.
-
-=head1 BUGS
-
-As of Perl 5.8.0 after using this module you cannot use the implicit
-C<$_> or the special filehandle C<_> with stat() or lstat(), trying
-to do so leads into strange errors. The workaround is for C<$_> to
-be explicit
-
- my $stat_obj = stat $_;
-
-and for C<_> to explicitly populate the object using the unexported
-and undocumented populate() function with CORE::stat():
-
- my $stat_obj = File::stat::populate(CORE::stat(_));
-
-=head1 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/installer/perllib/FileHandle.pm b/Master/tlpkg/installer/perllib/FileHandle.pm
deleted file mode 100644
index 6be22429440..00000000000
--- a/Master/tlpkg/installer/perllib/FileHandle.pm
+++ /dev/null
@@ -1,262 +0,0 @@
-package FileHandle;
-
-use 5.006;
-use strict;
-our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
-
-$VERSION = "2.01";
-
-require IO::File;
-@ISA = qw(IO::File);
-
-@EXPORT = qw(_IOFBF _IOLBF _IONBF);
-
-@EXPORT_OK = qw(
- pipe
-
- autoflush
- output_field_separator
- output_record_separator
- input_record_separator
- input_line_number
- format_page_number
- format_lines_per_page
- format_lines_left
- format_name
- format_top_name
- format_line_break_characters
- format_formfeed
-
- print
- printf
- getline
- getlines
-);
-
-#
-# Everything we're willing to export, we must first import.
-#
-import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK;
-
-#
-# Some people call "FileHandle::function", so all the functions
-# that were in the old FileHandle class must be imported, too.
-#
-{
- no strict 'refs';
-
- my %import = (
- 'IO::Handle' =>
- [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets
- eof flush error clearerr setbuf setvbuf _open_mode_string)],
- 'IO::Seekable' =>
- [qw(seek tell getpos setpos)],
- 'IO::File' =>
- [qw(new new_tmpfile open)]
- );
- for my $pkg (keys %import) {
- for my $func (@{$import{$pkg}}) {
- my $c = *{"${pkg}::$func"}{CODE}
- or die "${pkg}::$func missing";
- *$func = $c;
- }
- }
-}
-
-#
-# Specialized importer for Fcntl magic.
-#
-sub import {
- my $pkg = shift;
- my $callpkg = caller;
- require Exporter;
- Exporter::export($pkg, $callpkg, @_);
-
- #
- # If the Fcntl extension is available,
- # export its constants.
- #
- eval {
- require Fcntl;
- Exporter::export('Fcntl', $callpkg);
- };
-}
-
-################################################
-# This is the only exported function we define;
-# the rest come from other classes.
-#
-
-sub pipe {
- my $r = new IO::Handle;
- my $w = new IO::Handle;
- CORE::pipe($r, $w) or return undef;
- ($r, $w);
-}
-
-# Rebless standard file handles
-bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle";
-bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle";
-bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle";
-
-1;
-
-__END__
-
-=head1 NAME
-
-FileHandle - supply object methods for filehandles
-
-=head1 SYNOPSIS
-
- use FileHandle;
-
- $fh = new FileHandle;
- if ($fh->open("< file")) {
- print <$fh>;
- $fh->close;
- }
-
- $fh = new FileHandle "> FOO";
- if (defined $fh) {
- print $fh "bar\n";
- $fh->close;
- }
-
- $fh = new FileHandle "file", "r";
- if (defined $fh) {
- print <$fh>;
- undef $fh; # automatically closes the file
- }
-
- $fh = new FileHandle "file", O_WRONLY|O_APPEND;
- if (defined $fh) {
- print $fh "corge\n";
- undef $fh; # automatically closes the file
- }
-
- $pos = $fh->getpos;
- $fh->setpos($pos);
-
- $fh->setvbuf($buffer_var, _IOLBF, 1024);
-
- ($readfh, $writefh) = FileHandle::pipe;
-
- autoflush STDOUT 1;
-
-=head1 DESCRIPTION
-
-NOTE: This class is now a front-end to the IO::* classes.
-
-C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
-newly created symbol (see the C<Symbol> package). If it receives any
-parameters, they are passed to C<FileHandle::open>; if the open fails,
-the C<FileHandle> object is destroyed. Otherwise, it is returned to
-the caller.
-
-C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
-It requires two parameters, which are passed to C<FileHandle::fdopen>;
-if the fdopen fails, the C<FileHandle> object is destroyed.
-Otherwise, it is returned to the caller.
-
-C<FileHandle::open> accepts one parameter or two. With one parameter,
-it is just a front end for the built-in C<open> function. With two
-parameters, the first parameter is a filename that may include
-whitespace or other special characters, and the second parameter is
-the open mode, optionally followed by a file permission value.
-
-If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
-or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
-Perl C<open> operator.
-
-If C<FileHandle::open> is given a numeric mode, it passes that mode
-and the optional permissions value to the Perl C<sysopen> operator.
-For convenience, C<FileHandle::import> tries to import the O_XXX
-constants from the Fcntl module. If dynamic loading is not available,
-this may fail, but the rest of FileHandle will still work.
-
-C<FileHandle::fdopen> is like C<open> except that its first parameter
-is not a filename but rather a file handle name, a FileHandle object,
-or a file descriptor number.
-
-If the C functions fgetpos() and fsetpos() are available, then
-C<FileHandle::getpos> returns an opaque value that represents the
-current position of the FileHandle, and C<FileHandle::setpos> uses
-that value to return to a previously visited position.
-
-If the C function setvbuf() is available, then C<FileHandle::setvbuf>
-sets the buffering policy for the FileHandle. The calling sequence
-for the Perl function is the same as its C counterpart, including the
-macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
-parameter specifies a scalar variable to use as a buffer. WARNING: A
-variable used as a buffer by C<FileHandle::setvbuf> must not be
-modified in any way until the FileHandle is closed or until
-C<FileHandle::setvbuf> is called again, or memory corruption may
-result!
-
-See L<perlfunc> for complete descriptions of each of the following
-supported C<FileHandle> methods, which are just front ends for the
-corresponding built-in functions:
-
- close
- fileno
- getc
- gets
- eof
- clearerr
- seek
- tell
-
-See L<perlvar> for complete descriptions of each of the following
-supported C<FileHandle> methods:
-
- autoflush
- output_field_separator
- output_record_separator
- input_record_separator
- input_line_number
- format_page_number
- format_lines_per_page
- format_lines_left
- format_name
- format_top_name
- format_line_break_characters
- format_formfeed
-
-Furthermore, for doing normal I/O you might need these:
-
-=over 4
-
-=item $fh->print
-
-See L<perlfunc/print>.
-
-=item $fh->printf
-
-See L<perlfunc/printf>.
-
-=item $fh->getline
-
-This works like <$fh> described in L<perlop/"I/O Operators">
-except that it's more readable and can be safely called in a
-list context but still returns just one line.
-
-=item $fh->getlines
-
-This works like <$fh> when called in a list context to
-read all the remaining lines in a file, except that it's more readable.
-It will also croak() if accidentally called in a scalar context.
-
-=back
-
-There are many other functions available since FileHandle is descended
-from IO::File, IO::Seekable, and IO::Handle. Please see those
-respective pages for documentation on more functions.
-
-=head1 SEE ALSO
-
-The B<IO> extension,
-L<perlfunc>,
-L<perlop/"I/O Operators">.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Getopt/Long.pm b/Master/tlpkg/installer/perllib/Getopt/Long.pm
deleted file mode 100644
index 04038db58e3..00000000000
--- a/Master/tlpkg/installer/perllib/Getopt/Long.pm
+++ /dev/null
@@ -1,2504 +0,0 @@
-# Getopt::Long.pm -- Universal options parsing
-
-package Getopt::Long;
-
-# RCS Status : $Id: GetoptLong.pm,v 2.72 2005-04-28 21:18:33+02 jv Exp $
-# Author : Johan Vromans
-# Created On : Tue Sep 11 15:00:12 1990
-# Last Modified By: Johan Vromans
-# Last Modified On: Wed Dec 14 21:17:21 2005
-# Update Count : 1458
-# Status : Released
-
-################ Copyright ################
-
-# This program is Copyright 1990,2005 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.
-
-################ Module Preamble ################
-
-use 5.004;
-
-use strict;
-
-use vars qw($VERSION);
-$VERSION = 2.35;
-# For testing versions only.
-#use vars qw($VERSION_STRING);
-#$VERSION_STRING = "2.35";
-
-use Exporter;
-use vars qw(@ISA @EXPORT @EXPORT_OK);
-@ISA = qw(Exporter);
-
-# Exported subroutines.
-sub GetOptions(@); # always
-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);
-}
-
-# 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 => ;
-
-sub GetOptions(@) {
-
- my @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.72 $', ") ",
- "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" ) {
-# 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;");
- }
- }
- }
-
- # 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 ($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' ) {
- 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}}($opt,
- $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);
- ($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);
- ($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 ($tryopt) };
- $@;
- };
- 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 ($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 ) {
- # 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;
- }
- 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 ) {
- 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;
-
- # 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' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
- : "[-+]?[0-9]+";
-
- 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 = ($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]
- if ( $bundling && defined $rest &&
- $rest =~ /^($key_valid)([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) {
- ($key, $arg, $rest) = ($1, $2, $+);
- chop($key) if $key;
- unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
- }
- elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) {
- 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' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
- : "[-+]?[0-9]+";
-
- 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]
- return $arg =~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/;
- }
- 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;
- }
- elsif ( $try eq 'gnu_getopt' ) {
- if ( $action ) {
- $gnu_compat = 1;
- $bundling = 1;
- $getopt_compat = 0;
- $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 '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(@_);
-}
-
-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. 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<-->.
-
-=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 Storing option 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 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.
-
-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<"arg2"> 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 Trouble Shooting
-
-=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,2005 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/installer/perllib/Getopt/Std.pm b/Master/tlpkg/installer/perllib/Getopt/Std.pm
deleted file mode 100644
index 99f93590622..00000000000
--- a/Master/tlpkg/installer/perllib/Getopt/Std.pm
+++ /dev/null
@@ -1,294 +0,0 @@
-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.
-
-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.05';
-# 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/installer/perllib/IO.pm b/Master/tlpkg/installer/perllib/IO.pm
deleted file mode 100644
index 9fccc3a7356..00000000000
--- a/Master/tlpkg/installer/perllib/IO.pm
+++ /dev/null
@@ -1,68 +0,0 @@
-#
-
-package IO;
-
-use XSLoader ();
-use Carp;
-use strict;
-use warnings;
-
-our $VERSION = "1.22";
-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/installer/perllib/IO/Dir.pm b/Master/tlpkg/installer/perllib/IO/Dir.pm
deleted file mode 100644
index fccd02c088a..00000000000
--- a/Master/tlpkg/installer/perllib/IO/Dir.pm
+++ /dev/null
@@ -1,246 +0,0 @@
-# IO::Dir.pm
-#
-# Copyright (c) 1997-8 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 IO::Dir;
-
-use 5.006;
-
-use strict;
-use Carp;
-use Symbol;
-use Exporter;
-use IO::File;
-our(@ISA, $VERSION, @EXPORT_OK);
-use Tie::Hash;
-use File::stat;
-use File::Spec;
-
-@ISA = qw(Tie::Hash Exporter);
-$VERSION = "1.05";
-$VERSION = eval $VERSION;
-@EXPORT_OK = qw(DIR_UNLINK);
-
-sub DIR_UNLINK () { 1 }
-
-sub new {
- @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]';
- my $class = shift;
- my $dh = gensym;
- if (@_) {
- IO::Dir::open($dh, $_[0])
- or return undef;
- }
- bless $dh, $class;
-}
-
-sub DESTROY {
- my ($dh) = @_;
- closedir($dh);
-}
-
-sub open {
- @_ == 2 or croak 'usage: $dh->open(DIRNAME)';
- my ($dh, $dirname) = @_;
- return undef
- unless opendir($dh, $dirname);
- # a dir name should always have a ":" in it; assume dirname is
- # in current directory
- $dirname = ':' . $dirname if ( ($^O eq 'MacOS') && ($dirname !~ /:/) );
- ${*$dh}{io_dir_path} = $dirname;
- 1;
-}
-
-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 seek {
- @_ == 2 or croak 'usage: $dh->seek(POS)';
- my ($dh,$pos) = @_;
- seekdir($dh,$pos);
-}
-
-sub tell {
- @_ == 1 or croak 'usage: $dh->tell()';
- my ($dh) = @_;
- telldir($dh);
-}
-
-sub rewind {
- @_ == 1 or croak 'usage: $dh->rewind()';
- my ($dh) = @_;
- rewinddir($dh);
-}
-
-sub TIEHASH {
- my($class,$dir,$options) = @_;
-
- my $dh = $class->new($dir)
- or return undef;
-
- $options ||= 0;
-
- ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK;
- $dh;
-}
-
-sub FIRSTKEY {
- my($dh) = @_;
- $dh->rewind;
- scalar $dh->read;
-}
-
-sub NEXTKEY {
- my($dh) = @_;
- scalar $dh->read;
-}
-
-sub EXISTS {
- my($dh,$key) = @_;
- -e File::Spec->catfile(${*$dh}{io_dir_path}, $key);
-}
-
-sub FETCH {
- my($dh,$key) = @_;
- &lstat(File::Spec->catfile(${*$dh}{io_dir_path}, $key));
-}
-
-sub STORE {
- my($dh,$key,$data) = @_;
- my($atime,$mtime) = ref($data) ? @$data : ($data,$data);
- my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
- unless(-e $file) {
- my $io = IO::File->new($file,O_CREAT | O_RDWR);
- $io->close if $io;
- }
- utime($atime,$mtime, $file);
-}
-
-sub DELETE {
- my($dh,$key) = @_;
-
- # Only unlink if unlink-ing is enabled
- return 0
- unless ${*$dh}{io_dir_unlink};
-
- my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
-
- -d $file
- ? rmdir($file)
- : unlink($file);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO::Dir - supply object methods for directory handles
-
-=head1 SYNOPSIS
-
- use IO::Dir;
- $d = IO::Dir->new(".");
- if (defined $d) {
- while (defined($_ = $d->read)) { something($_); }
- $d->rewind;
- while (defined($_ = $d->read)) { something_else($_); }
- undef $d;
- }
-
- tie %dir, 'IO::Dir', ".";
- foreach (keys %dir) {
- print $_, " " , $dir{$_}->size,"\n";
- }
-
-=head1 DESCRIPTION
-
-The C<IO::Dir> package provides two interfaces to perl's directory reading
-routines.
-
-The first interface is an object approach. C<IO::Dir> provides an object
-constructor and methods, which are just wrappers around perl's built in
-directory reading routines.
-
-=over 4
-
-=item new ( [ DIRNAME ] )
-
-C<new> is the constructor for C<IO::Dir> objects. It accepts one optional
-argument which, if given, C<new> will pass to C<open>
-
-=back
-
-The following methods are wrappers for the directory related functions built
-into perl (the trailing `dir' has been removed from the names). See L<perlfunc>
-for details of these functions.
-
-=over 4
-
-=item open ( DIRNAME )
-
-=item read ()
-
-=item seek ( POS )
-
-=item tell ()
-
-=item rewind ()
-
-=item close ()
-
-=back
-
-C<IO::Dir> also provides an interface to reading directories via a tied
-hash. The tied hash extends the interface beyond just the directory
-reading routines by the use of C<lstat>, from the C<File::stat> package,
-C<unlink>, C<rmdir> and C<utime>.
-
-=over 4
-
-=item tie %hash, 'IO::Dir', DIRNAME [, OPTIONS ]
-
-=back
-
-The keys of the hash will be the names of the entries in the directory.
-Reading a value from the hash will be the result of calling
-C<File::stat::lstat>. Deleting an element from the hash will
-delete the corresponding file or subdirectory,
-provided that C<DIR_UNLINK> is included in the C<OPTIONS>.
-
-Assigning to an entry in the hash will cause the time stamps of the file
-to be modified. If the file does not exist then it will be created. Assigning
-a single integer to a hash element will cause both the access and
-modification times to be changed to that value. Alternatively a reference to
-an array of two values can be passed. The first array element will be used to
-set the access time and the second element will be used to set the modification
-time.
-
-=head1 SEE ALSO
-
-L<File::stat>
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1997-2003 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/installer/perllib/IO/File.pm b/Master/tlpkg/installer/perllib/IO/File.pm
deleted file mode 100644
index e7cdbbed6d7..00000000000
--- a/Master/tlpkg/installer/perllib/IO/File.pm
+++ /dev/null
@@ -1,208 +0,0 @@
-#
-
-package IO::File;
-
-=head1 NAME
-
-IO::File - supply object methods for filehandles
-
-=head1 SYNOPSIS
-
- use IO::File;
-
- $fh = new IO::File;
- if ($fh->open("< file")) {
- print <$fh>;
- $fh->close;
- }
-
- $fh = new IO::File "> file";
- if (defined $fh) {
- print $fh "bar\n";
- $fh->close;
- }
-
- $fh = new IO::File "file", "r";
- if (defined $fh) {
- print <$fh>;
- undef $fh; # automatically closes the file
- }
-
- $fh = new IO::File "file", O_WRONLY|O_APPEND;
- if (defined $fh) {
- print $fh "corge\n";
-
- $pos = $fh->getpos;
- $fh->setpos($pos);
-
- undef $fh; # automatically closes the file
- }
-
- autoflush STDOUT 1;
-
-=head1 DESCRIPTION
-
-C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends
-these classes with methods that are specific to file handles.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( FILENAME [,MODE [,PERMS]] )
-
-Creates an C<IO::File>. If it receives any parameters, they are passed to
-the method C<open>; if the open fails, the object is destroyed. Otherwise,
-it is returned to the caller.
-
-=item new_tmpfile
-
-Creates an C<IO::File> opened for read/write on a newly created temporary
-file. On systems where this is possible, the temporary file is anonymous
-(i.e. it is unlinked after creation, but held open). If the temporary
-file cannot be created or opened, the C<IO::File> object is destroyed.
-Otherwise, it is returned to the caller.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item open( FILENAME [,MODE [,PERMS]] )
-
-=item open( FILENAME, IOLAYERS )
-
-C<open> accepts one, two or three parameters. With one parameter,
-it is just a front end for the built-in C<open> function. With two or three
-parameters, the first parameter is a filename that may include
-whitespace or other special characters, and the second parameter is
-the open mode, optionally followed by a file permission value.
-
-If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.)
-or an ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic
-Perl C<open> operator (but protects any special characters).
-
-If C<IO::File::open> is given a numeric mode, it passes that mode
-and the optional permissions value to the Perl C<sysopen> operator.
-The permissions default to 0666.
-
-If C<IO::File::open> is given a mode that includes the C<:> character,
-it passes all the three arguments to the three-argument C<open> operator.
-
-For convenience, C<IO::File> exports the O_XXX constants from the
-Fcntl module, if this module is available.
-
-=item binmode( [LAYER] )
-
-C<binmode> sets C<binmode> on the underlying C<IO> object, as documented
-in C<perldoc -f binmode>.
-
-C<binmode> accepts one optional parameter, which is the layer to be
-passed on to the C<binmode> call.
-
-=back
-
-=head1 NOTE
-
-Some operating systems may perform C<IO::File::new()> or C<IO::File::open()>
-on a directory without errors. This behavior is not portable and not
-suggested for use. Using C<opendir()> and C<readdir()> or C<IO::Dir> are
-suggested instead.
-
-=head1 SEE ALSO
-
-L<perlfunc>,
-L<perlop/"I/O Operators">,
-L<IO::Handle>,
-L<IO::Seekable>,
-L<IO::Dir>
-
-=head1 HISTORY
-
-Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
-
-=cut
-
-use 5.006_001;
-use strict;
-our($VERSION, @EXPORT, @EXPORT_OK, @ISA);
-use Carp;
-use Symbol;
-use SelectSaver;
-use IO::Seekable;
-use File::Spec;
-
-require Exporter;
-
-@ISA = qw(IO::Handle IO::Seekable Exporter);
-
-$VERSION = "1.13";
-
-@EXPORT = @IO::Seekable::EXPORT;
-
-eval {
- # Make all Fcntl O_XXX constants available for importing
- require Fcntl;
- my @O = grep /^O_/, @Fcntl::EXPORT;
- Fcntl->import(@O); # first we import what we want to export
- push(@EXPORT, @O);
-};
-
-################################################
-## Constructor
-##
-
-sub new {
- my $type = shift;
- my $class = ref($type) || $type || "IO::File";
- @_ >= 0 && @_ <= 3
- or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]";
- my $fh = $class->SUPER::new();
- if (@_) {
- $fh->open(@_)
- or return undef;
- }
- $fh;
-}
-
-################################################
-## Open
-##
-
-sub open {
- @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
- my ($fh, $file) = @_;
- if (@_ > 2) {
- my ($mode, $perms) = @_[2, 3];
- if ($mode =~ /^\d+$/) {
- defined $perms or $perms = 0666;
- return sysopen($fh, $file, $mode, $perms);
- } elsif ($mode =~ /:/) {
- return open($fh, $mode, $file) if @_ == 3;
- croak 'usage: $fh->open(FILENAME, IOLAYERS)';
- }
- if (defined($file) && length($file)
- && ! File::Spec->file_name_is_absolute($file))
- {
- $file = File::Spec->rel2abs($file);
- }
- $file = IO::Handle::_open_mode_string($mode) . " $file\0";
- }
- open($fh, $file);
-}
-
-################################################
-## Binmode
-##
-
-sub binmode {
- ( @_ == 1 or @_ == 2 ) or croak 'usage $fh->binmode([LAYER])';
-
- my($fh, $layer) = @_;
-
- return binmode $$fh unless $layer;
- return binmode $$fh, $layer;
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/IO/Handle.pm b/Master/tlpkg/installer/perllib/IO/Handle.pm
deleted file mode 100644
index 329d26ad198..00000000000
--- a/Master/tlpkg/installer/perllib/IO/Handle.pm
+++ /dev/null
@@ -1,625 +0,0 @@
-package IO::Handle;
-
-=head1 NAME
-
-IO::Handle - supply object methods for I/O handles
-
-=head1 SYNOPSIS
-
- use IO::Handle;
-
- $io = new IO::Handle;
- if ($io->fdopen(fileno(STDIN),"r")) {
- print $io->getline;
- $io->close;
- }
-
- $io = new IO::Handle;
- if ($io->fdopen(fileno(STDOUT),"w")) {
- $io->print("Some text\n");
- }
-
- # setvbuf is not available by default on Perls 5.8.0 and later.
- use IO::Handle '_IOLBF';
- $io->setvbuf($buffer_var, _IOLBF, 1024);
-
- undef $io; # automatically closes the file if it's open
-
- autoflush STDOUT 1;
-
-=head1 DESCRIPTION
-
-C<IO::Handle> is the base class for all other IO handle classes. It is
-not intended that objects of C<IO::Handle> would be created directly,
-but instead C<IO::Handle> is inherited from by several other classes
-in the IO hierarchy.
-
-If you are reading this documentation, looking for a replacement for
-the C<FileHandle> package, then I suggest you read the documentation
-for C<IO::File> too.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ()
-
-Creates a new C<IO::Handle> object.
-
-=item new_from_fd ( FD, MODE )
-
-Creates an C<IO::Handle> like C<new> does.
-It requires two parameters, which are passed to the method C<fdopen>;
-if the fdopen fails, the object is destroyed. Otherwise, it is returned
-to the caller.
-
-=back
-
-=head1 METHODS
-
-See L<perlfunc> for complete descriptions of each of the following
-supported C<IO::Handle> methods, which are just front ends for the
-corresponding built-in functions:
-
- $io->close
- $io->eof
- $io->fileno
- $io->format_write( [FORMAT_NAME] )
- $io->getc
- $io->read ( BUF, LEN, [OFFSET] )
- $io->print ( ARGS )
- $io->printf ( FMT, [ARGS] )
- $io->stat
- $io->sysread ( BUF, LEN, [OFFSET] )
- $io->syswrite ( BUF, [LEN, [OFFSET]] )
- $io->truncate ( LEN )
-
-See L<perlvar> for complete descriptions of each of the following
-supported C<IO::Handle> methods. All of them return the previous
-value of the attribute and takes an optional single argument that when
-given will set the value. If no argument is given the previous value
-is unchanged (except for $io->autoflush will actually turn ON
-autoflush by default).
-
- $io->autoflush ( [BOOL] ) $|
- $io->format_page_number( [NUM] ) $%
- $io->format_lines_per_page( [NUM] ) $=
- $io->format_lines_left( [NUM] ) $-
- $io->format_name( [STR] ) $~
- $io->format_top_name( [STR] ) $^
- $io->input_line_number( [NUM]) $.
-
-The following methods are not supported on a per-filehandle basis.
-
- IO::Handle->format_line_break_characters( [STR] ) $:
- IO::Handle->format_formfeed( [STR]) $^L
- IO::Handle->output_field_separator( [STR] ) $,
- IO::Handle->output_record_separator( [STR] ) $\
-
- IO::Handle->input_record_separator( [STR] ) $/
-
-Furthermore, for doing normal I/O you might need these:
-
-=over 4
-
-=item $io->fdopen ( FD, MODE )
-
-C<fdopen> is like an ordinary C<open> except that its first parameter
-is not a filename but rather a file handle name, an IO::Handle object,
-or a file descriptor number.
-
-=item $io->opened
-
-Returns true if the object is currently a valid file descriptor, false
-otherwise.
-
-=item $io->getline
-
-This works like <$io> described in L<perlop/"I/O Operators">
-except that it's more readable and can be safely called in a
-list context but still returns just one line. If used as the conditional
-+within a C<while> or C-style C<for> loop, however, you will need to
-+emulate the functionality of <$io> with C<< defined($_ = $io->getline) >>.
-
-=item $io->getlines
-
-This works like <$io> when called in a list context to read all
-the remaining lines in a file, except that it's more readable.
-It will also croak() if accidentally called in a scalar context.
-
-=item $io->ungetc ( ORD )
-
-Pushes a character with the given ordinal value back onto the given
-handle's input stream. Only one character of pushback per handle is
-guaranteed.
-
-=item $io->write ( BUF, LEN [, OFFSET ] )
-
-This C<write> is like C<write> found in C, that is it is the
-opposite of read. The wrapper for the perl C<write> function is
-called C<format_write>.
-
-=item $io->error
-
-Returns a true value if the given handle has experienced any errors
-since it was opened or since the last call to C<clearerr>, or if the
-handle is invalid. It only returns false for a valid handle with no
-outstanding errors.
-
-=item $io->clearerr
-
-Clear the given handle's error indicator. Returns -1 if the handle is
-invalid, 0 otherwise.
-
-=item $io->sync
-
-C<sync> synchronizes a file's in-memory state with that on the
-physical medium. C<sync> does not operate at the perlio api level, but
-operates on the file descriptor (similar to sysread, sysseek and
-systell). This means that any data held at the perlio api level will not
-be synchronized. To synchronize data that is buffered at the perlio api
-level you must use the flush method. C<sync> is not implemented on all
-platforms. Returns "0 but true" on success, C<undef> on error, C<undef>
-for an invalid handle. See L<fsync(3c)>.
-
-=item $io->flush
-
-C<flush> causes perl to flush any buffered data at the perlio api level.
-Any unread data in the buffer will be discarded, and any unwritten data
-will be written to the underlying file descriptor. Returns "0 but true"
-on success, C<undef> on error.
-
-=item $io->printflush ( ARGS )
-
-Turns on autoflush, print ARGS and then restores the autoflush status of the
-C<IO::Handle> object. Returns the return value from print.
-
-=item $io->blocking ( [ BOOL ] )
-
-If called with an argument C<blocking> will turn on non-blocking IO if
-C<BOOL> is false, and turn it off if C<BOOL> is true.
-
-C<blocking> will return the value of the previous setting, or the
-current setting if C<BOOL> is not given.
-
-If an error occurs C<blocking> will return undef and C<$!> will be set.
-
-=back
-
-
-If the C functions setbuf() and/or setvbuf() are available, then
-C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
-policy for an IO::Handle. The calling sequences for the Perl functions
-are the same as their C counterparts--including the constants C<_IOFBF>,
-C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
-specifies a scalar variable to use as a buffer. You should only
-change the buffer before any I/O, or immediately after calling flush.
-
-WARNING: The IO::Handle::setvbuf() is not available by default on
-Perls 5.8.0 and later because setvbuf() is rather specific to using
-the stdio library, while Perl prefers the new perlio subsystem instead.
-
-WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not
-be modified> in any way until the IO::Handle is closed or C<setbuf> or
-C<setvbuf> is called again, or memory corruption may result! Remember that
-the order of global destruction is undefined, so even if your buffer
-variable remains in scope until program termination, it may be undefined
-before the file IO::Handle is closed. Note that you need to import the
-constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf
-returns nothing. setvbuf returns "0 but true", on success, C<undef> on
-failure.
-
-Lastly, there is a special method for working under B<-T> and setuid/gid
-scripts:
-
-=over 4
-
-=item $io->untaint
-
-Marks the object as taint-clean, and as such data read from it will also
-be considered taint-clean. Note that this is a very trusting action to
-take, and appropriate consideration for the data source and potential
-vulnerability should be kept in mind. Returns 0 on success, -1 if setting
-the taint-clean flag failed. (eg invalid handle)
-
-=back
-
-=head1 NOTE
-
-An C<IO::Handle> object is a reference to a symbol/GLOB reference (see
-the C<Symbol> package). Some modules that
-inherit from C<IO::Handle> may want to keep object related variables
-in the hash table part of the GLOB. In an attempt to prevent modules
-trampling on each other I propose the that any such module should prefix
-its variables with its own name separated by _'s. For example the IO::Socket
-module keeps a C<timeout> variable in 'io_socket_timeout'.
-
-=head1 SEE ALSO
-
-L<perlfunc>,
-L<perlop/"I/O Operators">,
-L<IO::File>
-
-=head1 BUGS
-
-Due to backwards compatibility, all filehandles resemble objects
-of class C<IO::Handle>, or actually classes derived from that class.
-They actually aren't. Which means you can't derive your own
-class from C<IO::Handle> and inherit those methods.
-
-=head1 HISTORY
-
-Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
-
-=cut
-
-use 5.006_001;
-use strict;
-our($VERSION, @EXPORT_OK, @ISA);
-use Carp;
-use Symbol;
-use SelectSaver;
-use IO (); # Load the XS module
-
-require Exporter;
-@ISA = qw(Exporter);
-
-$VERSION = "1.25";
-$VERSION = eval $VERSION;
-
-@EXPORT_OK = qw(
- autoflush
- output_field_separator
- output_record_separator
- input_record_separator
- input_line_number
- format_page_number
- format_lines_per_page
- format_lines_left
- format_name
- format_top_name
- format_line_break_characters
- format_formfeed
- format_write
-
- print
- printf
- getline
- getlines
-
- printflush
- flush
-
- SEEK_SET
- SEEK_CUR
- SEEK_END
- _IOFBF
- _IOLBF
- _IONBF
-);
-
-################################################
-## Constructors, destructors.
-##
-
-sub new {
- my $class = ref($_[0]) || $_[0] || "IO::Handle";
- @_ == 1 or croak "usage: new $class";
- my $io = gensym;
- bless $io, $class;
-}
-
-sub new_from_fd {
- my $class = ref($_[0]) || $_[0] || "IO::Handle";
- @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
- my $io = gensym;
- shift;
- IO::Handle::fdopen($io, @_)
- or return undef;
- bless $io, $class;
-}
-
-#
-# There is no need for DESTROY to do anything, because when the
-# last reference to an IO object is gone, Perl automatically
-# closes its associated files (if any). However, to avoid any
-# attempts to autoload DESTROY, we here define it to do nothing.
-#
-sub DESTROY {}
-
-
-################################################
-## Open and close.
-##
-
-sub _open_mode_string {
- my ($mode) = @_;
- $mode =~ /^\+?(<|>>?)$/
- or $mode =~ s/^r(\+?)$/$1</
- or $mode =~ s/^w(\+?)$/$1>/
- or $mode =~ s/^a(\+?)$/$1>>/
- or croak "IO::Handle: bad open mode: $mode";
- $mode;
-}
-
-sub fdopen {
- @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
- my ($io, $fd, $mode) = @_;
- local(*GLOB);
-
- if (ref($fd) && "".$fd =~ /GLOB\(/o) {
- # It's a glob reference; Alias it as we cannot get name of anon GLOBs
- my $n = qualify(*GLOB);
- *GLOB = *{*$fd};
- $fd = $n;
- } elsif ($fd =~ m#^\d+$#) {
- # It's an FD number; prefix with "=".
- $fd = "=$fd";
- }
-
- open($io, _open_mode_string($mode) . '&' . $fd)
- ? $io : undef;
-}
-
-sub close {
- @_ == 1 or croak 'usage: $io->close()';
- my($io) = @_;
-
- close($io);
-}
-
-################################################
-## Normal I/O functions.
-##
-
-# flock
-# select
-
-sub opened {
- @_ == 1 or croak 'usage: $io->opened()';
- defined fileno($_[0]);
-}
-
-sub fileno {
- @_ == 1 or croak 'usage: $io->fileno()';
- fileno($_[0]);
-}
-
-sub getc {
- @_ == 1 or croak 'usage: $io->getc()';
- getc($_[0]);
-}
-
-sub eof {
- @_ == 1 or croak 'usage: $io->eof()';
- eof($_[0]);
-}
-
-sub print {
- @_ or croak 'usage: $io->print(ARGS)';
- my $this = shift;
- print $this @_;
-}
-
-sub printf {
- @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
- my $this = shift;
- printf $this @_;
-}
-
-sub getline {
- @_ == 1 or croak 'usage: $io->getline()';
- my $this = shift;
- return scalar <$this>;
-}
-
-*gets = \&getline; # deprecated
-
-sub getlines {
- @_ == 1 or croak 'usage: $io->getlines()';
- wantarray or
- croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
- my $this = shift;
- return <$this>;
-}
-
-sub truncate {
- @_ == 2 or croak 'usage: $io->truncate(LEN)';
- truncate($_[0], $_[1]);
-}
-
-sub read {
- @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
- read($_[0], $_[1], $_[2], $_[3] || 0);
-}
-
-sub sysread {
- @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
- sysread($_[0], $_[1], $_[2], $_[3] || 0);
-}
-
-sub write {
- @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
- local($\) = "";
- $_[2] = length($_[1]) unless defined $_[2];
- print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
-}
-
-sub syswrite {
- @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
- if (defined($_[2])) {
- syswrite($_[0], $_[1], $_[2], $_[3] || 0);
- } else {
- syswrite($_[0], $_[1]);
- }
-}
-
-sub stat {
- @_ == 1 or croak 'usage: $io->stat()';
- stat($_[0]);
-}
-
-################################################
-## State modification functions.
-##
-
-sub autoflush {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $|;
- $| = @_ > 1 ? $_[1] : 1;
- $prev;
-}
-
-sub output_field_separator {
- carp "output_field_separator is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $,;
- $, = $_[1] if @_ > 1;
- $prev;
-}
-
-sub output_record_separator {
- carp "output_record_separator is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $\;
- $\ = $_[1] if @_ > 1;
- $prev;
-}
-
-sub input_record_separator {
- carp "input_record_separator is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $/;
- $/ = $_[1] if @_ > 1;
- $prev;
-}
-
-sub input_line_number {
- local $.;
- () = tell qualify($_[0], caller) if ref($_[0]);
- my $prev = $.;
- $. = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_page_number {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $%;
- $% = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_lines_per_page {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $=;
- $= = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_lines_left {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $-;
- $- = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_name {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $~;
- $~ = qualify($_[1], caller) if @_ > 1;
- $prev;
-}
-
-sub format_top_name {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $^;
- $^ = qualify($_[1], caller) if @_ > 1;
- $prev;
-}
-
-sub format_line_break_characters {
- carp "format_line_break_characters is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $:;
- $: = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_formfeed {
- carp "format_formfeed is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $^L;
- $^L = $_[1] if @_ > 1;
- $prev;
-}
-
-sub formline {
- my $io = shift;
- my $picture = shift;
- local($^A) = $^A;
- local($\) = "";
- formline($picture, @_);
- print $io $^A;
-}
-
-sub format_write {
- @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
- if (@_ == 2) {
- my ($io, $fmt) = @_;
- my $oldfmt = $io->format_name($fmt);
- CORE::write($io);
- $io->format_name($oldfmt);
- } else {
- CORE::write($_[0]);
- }
-}
-
-# XXX undocumented
-sub fcntl {
- @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
- my ($io, $op) = @_;
- return fcntl($io, $op, $_[2]);
-}
-
-# XXX undocumented
-sub ioctl {
- @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
- my ($io, $op) = @_;
- return ioctl($io, $op, $_[2]);
-}
-
-# this sub is for compatability with older releases of IO that used
-# a sub called constant to detemine if a constant existed -- GMB
-#
-# The SEEK_* and _IO?BF constants were the only constants at that time
-# any new code should just chech defined(&CONSTANT_NAME)
-
-sub constant {
- no strict 'refs';
- my $name = shift;
- (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
- ? &{$name}() : undef;
-}
-
-
-# so that flush.pl can be deprecated
-
-sub printflush {
- my $io = shift;
- my $old;
- $old = new SelectSaver qualify($io, caller) if ref($io);
- local $| = 1;
- if(ref($io)) {
- print $io @_;
- }
- else {
- print @_;
- }
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/IO/Pipe.pm b/Master/tlpkg/installer/perllib/IO/Pipe.pm
deleted file mode 100644
index 827cc48bfcd..00000000000
--- a/Master/tlpkg/installer/perllib/IO/Pipe.pm
+++ /dev/null
@@ -1,257 +0,0 @@
-# IO::Pipe.pm
-#
-# Copyright (c) 1996-8 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 IO::Pipe;
-
-use 5.006_001;
-
-use IO::Handle;
-use strict;
-our($VERSION);
-use Carp;
-use Symbol;
-
-$VERSION = "1.13";
-
-sub new {
- my $type = shift;
- my $class = ref($type) || $type || "IO::Pipe";
- @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
-
- my $me = bless gensym(), $class;
-
- my($readfh,$writefh) = @_ ? @_ : $me->handles;
-
- pipe($readfh, $writefh)
- or return undef;
-
- @{*$me} = ($readfh, $writefh);
-
- $me;
-}
-
-sub handles {
- @_ == 1 or croak 'usage: $pipe->handles()';
- (IO::Pipe::End->new(), IO::Pipe::End->new());
-}
-
-my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
-
-sub _doit {
- my $me = shift;
- my $rw = shift;
-
- my $pid = $do_spawn ? 0 : fork();
-
- if($pid) { # Parent
- return $pid;
- }
- elsif(defined $pid) { # Child or spawn
- my $fh;
- my $io = $rw ? \*STDIN : \*STDOUT;
- my ($mode, $save) = $rw ? "r" : "w";
- if ($do_spawn) {
- require Fcntl;
- $save = IO::Handle->new_from_fd($io, $mode);
- my $handle = shift;
- # Close in child:
- unless ($^O eq 'MSWin32') {
- fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
- }
- $fh = $rw ? ${*$me}[0] : ${*$me}[1];
- } else {
- shift;
- $fh = $rw ? $me->reader() : $me->writer(); # close the other end
- }
- bless $io, "IO::Handle";
- $io->fdopen($fh, $mode);
- $fh->close;
-
- if ($do_spawn) {
- $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
- my $err = $!;
-
- $io->fdopen($save, $mode);
- $save->close or croak "Cannot close $!";
- croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
- return $pid;
- } else {
- exec @_ or
- croak "IO::Pipe: Cannot exec: $!";
- }
- }
- else {
- croak "IO::Pipe: Cannot fork: $!";
- }
-
- # NOT Reached
-}
-
-sub reader {
- @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
- my $me = shift;
-
- return undef
- unless(ref($me) || ref($me = $me->new));
-
- my $fh = ${*$me}[0];
- my $pid;
- $pid = $me->_doit(0, $fh, @_)
- if(@_);
-
- close ${*$me}[1];
- bless $me, ref($fh);
- *$me = *$fh; # Alias self to handle
- $me->fdopen($fh->fileno,"r")
- unless defined($me->fileno);
- bless $fh; # Really wan't un-bless here
- ${*$me}{'io_pipe_pid'} = $pid
- if defined $pid;
-
- $me;
-}
-
-sub writer {
- @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
- my $me = shift;
-
- return undef
- unless(ref($me) || ref($me = $me->new));
-
- my $fh = ${*$me}[1];
- my $pid;
- $pid = $me->_doit(1, $fh, @_)
- if(@_);
-
- close ${*$me}[0];
- bless $me, ref($fh);
- *$me = *$fh; # Alias self to handle
- $me->fdopen($fh->fileno,"w")
- unless defined($me->fileno);
- bless $fh; # Really wan't un-bless here
- ${*$me}{'io_pipe_pid'} = $pid
- if defined $pid;
-
- $me;
-}
-
-package IO::Pipe::End;
-
-our(@ISA);
-
-@ISA = qw(IO::Handle);
-
-sub close {
- my $fh = shift;
- my $r = $fh->SUPER::close(@_);
-
- waitpid(${*$fh}{'io_pipe_pid'},0)
- if(defined ${*$fh}{'io_pipe_pid'});
-
- $r;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO::Pipe - supply object methods for pipes
-
-=head1 SYNOPSIS
-
- use IO::Pipe;
-
- $pipe = new IO::Pipe;
-
- if($pid = fork()) { # Parent
- $pipe->reader();
-
- while(<$pipe>) {
- ...
- }
-
- }
- elsif(defined $pid) { # Child
- $pipe->writer();
-
- print $pipe ...
- }
-
- or
-
- $pipe = new IO::Pipe;
-
- $pipe->reader(qw(ls -l));
-
- while(<$pipe>) {
- ...
- }
-
-=head1 DESCRIPTION
-
-C<IO::Pipe> provides an interface to creating pipes between
-processes.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [READER, WRITER] )
-
-Creates an C<IO::Pipe>, which is a reference to a newly created symbol
-(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two
-arguments, which should be objects blessed into C<IO::Handle>, or a
-subclass thereof. These two objects will be used for the system call
-to C<pipe>. If no arguments are given then method C<handles> is called
-on the new C<IO::Pipe> object.
-
-These two handles are held in the array part of the GLOB until either
-C<reader> or C<writer> is called.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item reader ([ARGS])
-
-The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
-handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
-is called and C<ARGS> are passed to exec.
-
-=item writer ([ARGS])
-
-The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
-handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
-is called and C<ARGS> are passed to exec.
-
-=item handles ()
-
-This method is called during construction by C<IO::Pipe::new>
-on the newly created C<IO::Pipe> object. It returns an array of two objects
-blessed into C<IO::Pipe::End>, or a subclass thereof.
-
-=back
-
-=head1 SEE ALSO
-
-L<IO::Handle>
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1996-8 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/installer/perllib/IO/Poll.pm b/Master/tlpkg/installer/perllib/IO/Poll.pm
deleted file mode 100644
index e7fb0135069..00000000000
--- a/Master/tlpkg/installer/perllib/IO/Poll.pm
+++ /dev/null
@@ -1,209 +0,0 @@
-
-# IO::Poll.pm
-#
-# Copyright (c) 1997-8 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 IO::Poll;
-
-use strict;
-use IO::Handle;
-use Exporter ();
-our(@ISA, @EXPORT_OK, @EXPORT, $VERSION);
-
-@ISA = qw(Exporter);
-$VERSION = "0.07";
-
-@EXPORT = qw( POLLIN
- POLLOUT
- POLLERR
- POLLHUP
- POLLNVAL
- );
-
-@EXPORT_OK = qw(
- POLLPRI
- POLLRDNORM
- POLLWRNORM
- POLLRDBAND
- POLLWRBAND
- POLLNORM
- );
-
-# [0] maps fd's to requested masks
-# [1] maps fd's to returned masks
-# [2] maps fd's to handles
-sub new {
- my $class = shift;
-
- my $self = bless [{},{},{}], $class;
-
- $self;
-}
-
-sub mask {
- my $self = shift;
- my $io = shift;
- my $fd = fileno($io);
- return unless defined $fd;
- if (@_) {
- my $mask = shift;
- if($mask) {
- $self->[0]{$fd}{$io} = $mask; # the error events are always returned
- $self->[1]{$fd} = 0; # output mask
- $self->[2]{$io} = $io; # remember handle
- } else {
- delete $self->[0]{$fd}{$io};
- unless(%{$self->[0]{$fd}}) {
- # We no longer have any handles for this FD
- delete $self->[1]{$fd};
- delete $self->[0]{$fd};
- }
- delete $self->[2]{$io};
- }
- }
-
- return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io};
- return $self->[0]{$fd}{$io};
-}
-
-
-sub poll {
- my($self,$timeout) = @_;
-
- $self->[1] = {};
-
- my($fd,$mask,$iom);
- my @poll = ();
-
- while(($fd,$iom) = each %{$self->[0]}) {
- $mask = 0;
- $mask |= $_ for values(%$iom);
- push(@poll,$fd => $mask);
- }
-
- my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0;
-
- return $ret
- unless $ret > 0;
-
- while(@poll) {
- my($fd,$got) = splice(@poll,0,2);
- $self->[1]{$fd} = $got if $got;
- }
-
- return $ret;
-}
-
-sub events {
- my $self = shift;
- my $io = shift;
- my $fd = fileno($io);
- exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io}
- ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL)
- : 0;
-}
-
-sub remove {
- my $self = shift;
- my $io = shift;
- $self->mask($io,0);
-}
-
-sub handles {
- my $self = shift;
- return values %{$self->[2]} unless @_;
-
- my $events = shift || 0;
- my($fd,$ev,$io,$mask);
- my @handles = ();
-
- while(($fd,$ev) = each %{$self->[1]}) {
- while (($io,$mask) = each %{$self->[0]{$fd}}) {
- $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these
- push @handles,$self->[2]{$io} if ($ev & $mask) & $events;
- }
- }
- return @handles;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO::Poll - Object interface to system poll call
-
-=head1 SYNOPSIS
-
- use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP);
-
- $poll = new IO::Poll;
-
- $poll->mask($input_handle => POLLIN);
- $poll->mask($output_handle => POLLOUT);
-
- $poll->poll($timeout);
-
- $ev = $poll->events($input);
-
-=head1 DESCRIPTION
-
-C<IO::Poll> is a simple interface to the system level poll routine.
-
-=head1 METHODS
-
-=over 4
-
-=item mask ( IO [, EVENT_MASK ] )
-
-If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the
-list of file descriptors and the next call to poll will check for
-any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be
-removed from the list of file descriptors.
-
-If EVENT_MASK is not given then the return value will be the current
-event mask value for IO.
-
-=item poll ( [ TIMEOUT ] )
-
-Call the system level poll routine. If TIMEOUT is not specified then the
-call will block. Returns the number of handles which had events
-happen, or -1 on error.
-
-=item events ( IO )
-
-Returns the event mask which represents the events that happened on IO
-during the last call to C<poll>.
-
-=item remove ( IO )
-
-Remove IO from the list of file descriptors for the next poll.
-
-=item handles( [ EVENT_MASK ] )
-
-Returns a list of handles. If EVENT_MASK is not given then a list of all
-handles known will be returned. If EVENT_MASK is given then a list
-of handles will be returned which had one of the events specified by
-EVENT_MASK happen during the last call ti C<poll>
-
-=back
-
-=head1 SEE ALSO
-
-L<poll(2)>, L<IO::Handle>, L<IO::Select>
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1997-8 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/installer/perllib/IO/Seekable.pm b/Master/tlpkg/installer/perllib/IO/Seekable.pm
deleted file mode 100644
index db1effda287..00000000000
--- a/Master/tlpkg/installer/perllib/IO/Seekable.pm
+++ /dev/null
@@ -1,128 +0,0 @@
-#
-
-package IO::Seekable;
-
-=head1 NAME
-
-IO::Seekable - supply seek based methods for I/O objects
-
-=head1 SYNOPSIS
-
- use IO::Seekable;
- package IO::Something;
- @ISA = qw(IO::Seekable);
-
-=head1 DESCRIPTION
-
-C<IO::Seekable> does not have a constructor of its own as it is intended to
-be inherited by other C<IO::Handle> based objects. It provides methods
-which allow seeking of the file descriptors.
-
-=over 4
-
-=item $io->getpos
-
-Returns an opaque value that represents the current position of the
-IO::File, or C<undef> if this is not possible (eg an unseekable stream such
-as a terminal, pipe or socket). If the fgetpos() function is available in
-your C library it is used to implements getpos, else perl emulates getpos
-using C's ftell() function.
-
-=item $io->setpos
-
-Uses the value of a previous getpos call to return to a previously visited
-position. Returns "0 but true" on success, C<undef> on failure.
-
-=back
-
-See L<perlfunc> for complete descriptions of each of the following
-supported C<IO::Seekable> methods, which are just front ends for the
-corresponding built-in functions:
-
-=over 4
-
-=item $io->seek ( POS, WHENCE )
-
-Seek the IO::File to position POS, relative to WHENCE:
-
-=over 8
-
-=item WHENCE=0 (SEEK_SET)
-
-POS is absolute position. (Seek relative to the start of the file)
-
-=item WHENCE=1 (SEEK_CUR)
-
-POS is an offset from the current position. (Seek relative to current)
-
-=item WHENCE=2 (SEEK_END)
-
-POS is an offset from the end of the file. (Seek relative to end)
-
-=back
-
-The SEEK_* constants can be imported from the C<Fcntl> module if you
-don't wish to use the numbers C<0> C<1> or C<2> in your code.
-
-Returns C<1> upon success, C<0> otherwise.
-
-=item $io->sysseek( POS, WHENCE )
-
-Similar to $io->seek, but sets the IO::File's position using the system
-call lseek(2) directly, so will confuse most perl IO operators except
-sysread and syswrite (see L<perlfunc> for full details)
-
-Returns the new position, or C<undef> on failure. A position
-of zero is returned as the string C<"0 but true">
-
-=item $io->tell
-
-Returns the IO::File's current position, or -1 on error.
-
-=back
-
-=head1 SEE ALSO
-
-L<perlfunc>,
-L<perlop/"I/O Operators">,
-L<IO::Handle>
-L<IO::File>
-
-=head1 HISTORY
-
-Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt>
-
-=cut
-
-use 5.006_001;
-use Carp;
-use strict;
-our($VERSION, @EXPORT, @ISA);
-use IO::Handle ();
-# XXX we can't get these from IO::Handle or we'll get prototype
-# mismatch warnings on C<use POSIX; use IO::File;> :-(
-use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END);
-require Exporter;
-
-@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
-@ISA = qw(Exporter);
-
-$VERSION = "1.10";
-$VERSION = eval $VERSION;
-
-sub seek {
- @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)';
- seek($_[0], $_[1], $_[2]);
-}
-
-sub sysseek {
- @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)';
- sysseek($_[0], $_[1], $_[2]);
-}
-
-sub tell {
- @_ == 1 or croak 'usage: $io->tell()';
- tell($_[0]);
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/IO/Select.pm b/Master/tlpkg/installer/perllib/IO/Select.pm
deleted file mode 100644
index fc05fe70e9c..00000000000
--- a/Master/tlpkg/installer/perllib/IO/Select.pm
+++ /dev/null
@@ -1,381 +0,0 @@
-# IO::Select.pm
-#
-# Copyright (c) 1997-8 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 IO::Select;
-
-use strict;
-use warnings::register;
-use vars qw($VERSION @ISA);
-require Exporter;
-
-$VERSION = "1.17";
-
-@ISA = qw(Exporter); # This is only so we can do version checking
-
-sub VEC_BITS () {0}
-sub FD_COUNT () {1}
-sub FIRST_FD () {2}
-
-sub new
-{
- my $self = shift;
- my $type = ref($self) || $self;
-
- my $vec = bless [undef,0], $type;
-
- $vec->add(@_)
- if @_;
-
- $vec;
-}
-
-sub add
-{
- shift->_update('add', @_);
-}
-
-
-sub remove
-{
- shift->_update('remove', @_);
-}
-
-
-sub exists
-{
- my $vec = shift;
- my $fno = $vec->_fileno(shift);
- return undef unless defined $fno;
- $vec->[$fno + FIRST_FD];
-}
-
-
-sub _fileno
-{
- my($self, $f) = @_;
- return unless defined $f;
- $f = $f->[0] if ref($f) eq 'ARRAY';
- ($f =~ /^\d+$/) ? $f : fileno($f);
-}
-
-sub _update
-{
- my $vec = shift;
- my $add = shift eq 'add';
-
- my $bits = $vec->[VEC_BITS];
- $bits = '' unless defined $bits;
-
- my $count = 0;
- my $f;
- foreach $f (@_)
- {
- my $fn = $vec->_fileno($f);
- next unless defined $fn;
- my $i = $fn + FIRST_FD;
- if ($add) {
- if (defined $vec->[$i]) {
- $vec->[$i] = $f; # if array rest might be different, so we update
- next;
- }
- $vec->[FD_COUNT]++;
- vec($bits, $fn, 1) = 1;
- $vec->[$i] = $f;
- } else { # remove
- next unless defined $vec->[$i];
- $vec->[FD_COUNT]--;
- vec($bits, $fn, 1) = 0;
- $vec->[$i] = undef;
- }
- $count++;
- }
- $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
- $count;
-}
-
-sub can_read
-{
- my $vec = shift;
- my $timeout = shift;
- my $r = $vec->[VEC_BITS];
-
- defined($r) && (select($r,undef,undef,$timeout) > 0)
- ? handles($vec, $r)
- : ();
-}
-
-sub can_write
-{
- my $vec = shift;
- my $timeout = shift;
- my $w = $vec->[VEC_BITS];
-
- defined($w) && (select(undef,$w,undef,$timeout) > 0)
- ? handles($vec, $w)
- : ();
-}
-
-sub has_exception
-{
- my $vec = shift;
- my $timeout = shift;
- my $e = $vec->[VEC_BITS];
-
- defined($e) && (select(undef,undef,$e,$timeout) > 0)
- ? handles($vec, $e)
- : ();
-}
-
-sub has_error
-{
- warnings::warn("Call to deprecated method 'has_error', use 'has_exception'")
- if warnings::enabled();
- goto &has_exception;
-}
-
-sub count
-{
- my $vec = shift;
- $vec->[FD_COUNT];
-}
-
-sub bits
-{
- my $vec = shift;
- $vec->[VEC_BITS];
-}
-
-sub as_string # for debugging
-{
- my $vec = shift;
- my $str = ref($vec) . ": ";
- my $bits = $vec->bits;
- my $count = $vec->count;
- $str .= defined($bits) ? unpack("b*", $bits) : "undef";
- $str .= " $count";
- my @handles = @$vec;
- splice(@handles, 0, FIRST_FD);
- for (@handles) {
- $str .= " " . (defined($_) ? "$_" : "-");
- }
- $str;
-}
-
-sub _max
-{
- my($a,$b,$c) = @_;
- $a > $b
- ? $a > $c
- ? $a
- : $c
- : $b > $c
- ? $b
- : $c;
-}
-
-sub select
-{
- shift
- if defined $_[0] && !ref($_[0]);
-
- my($r,$w,$e,$t) = @_;
- my @result = ();
-
- my $rb = defined $r ? $r->[VEC_BITS] : undef;
- my $wb = defined $w ? $w->[VEC_BITS] : undef;
- my $eb = defined $e ? $e->[VEC_BITS] : undef;
-
- if(select($rb,$wb,$eb,$t) > 0)
- {
- my @r = ();
- my @w = ();
- my @e = ();
- my $i = _max(defined $r ? scalar(@$r)-1 : 0,
- defined $w ? scalar(@$w)-1 : 0,
- defined $e ? scalar(@$e)-1 : 0);
-
- for( ; $i >= FIRST_FD ; $i--)
- {
- my $j = $i - FIRST_FD;
- push(@r, $r->[$i])
- if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
- push(@w, $w->[$i])
- if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
- push(@e, $e->[$i])
- if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
- }
-
- @result = (\@r, \@w, \@e);
- }
- @result;
-}
-
-
-sub handles
-{
- my $vec = shift;
- my $bits = shift;
- my @h = ();
- my $i;
- my $max = scalar(@$vec) - 1;
-
- for ($i = FIRST_FD; $i <= $max; $i++)
- {
- next unless defined $vec->[$i];
- push(@h, $vec->[$i])
- if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
- }
-
- @h;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-IO::Select - OO interface to the select system call
-
-=head1 SYNOPSIS
-
- use IO::Select;
-
- $s = IO::Select->new();
-
- $s->add(\*STDIN);
- $s->add($some_handle);
-
- @ready = $s->can_read($timeout);
-
- @ready = IO::Select->new(@handles)->can_read(0);
-
-=head1 DESCRIPTION
-
-The C<IO::Select> package implements an object approach to the system C<select>
-function call. It allows the user to see what IO handles, see L<IO::Handle>,
-are ready for reading, writing or have an exception pending.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HANDLES ] )
-
-The constructor creates a new object and optionally initialises it with a set
-of handles.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item add ( HANDLES )
-
-Add the list of handles to the C<IO::Select> object. It is these values that
-will be returned when an event occurs. C<IO::Select> keeps these values in a
-cache which is indexed by the C<fileno> of the handle, so if more than one
-handle with the same C<fileno> is specified then only the last one is cached.
-
-Each handle can be an C<IO::Handle> object, an integer or an array
-reference where the first element is an C<IO::Handle> or an integer.
-
-=item remove ( HANDLES )
-
-Remove all the given handles from the object. This method also works
-by the C<fileno> of the handles. So the exact handles that were added
-need not be passed, just handles that have an equivalent C<fileno>
-
-=item exists ( HANDLE )
-
-Returns a true value (actually the handle itself) if it is present.
-Returns undef otherwise.
-
-=item handles
-
-Return an array of all registered handles.
-
-=item can_read ( [ TIMEOUT ] )
-
-Return an array of handles that are ready for reading. C<TIMEOUT> is
-the maximum amount of time to wait before returning an empty list, in
-seconds, possibly fractional. If C<TIMEOUT> is not given and any
-handles are registered then the call will block.
-
-=item can_write ( [ TIMEOUT ] )
-
-Same as C<can_read> except check for handles that can be written to.
-
-=item has_exception ( [ TIMEOUT ] )
-
-Same as C<can_read> except check for handles that have an exception
-condition, for example pending out-of-band data.
-
-=item count ()
-
-Returns the number of handles that the object will check for when
-one of the C<can_> methods is called or the object is passed to
-the C<select> static method.
-
-=item bits()
-
-Return the bit string suitable as argument to the core select() call.
-
-=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] )
-
-C<select> is a static method, that is you call it with the package name
-like C<new>. C<READ>, C<WRITE> and C<EXCEPTION> are either C<undef> or
-C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as
-for the core select call.
-
-The result will be an array of 3 elements, each a reference to an array
-which will hold the handles that are ready for reading, writing and have
-exceptions respectively. Upon error an empty list is returned.
-
-=back
-
-=head1 EXAMPLE
-
-Here is a short example which shows how C<IO::Select> could be used
-to write a server which communicates with several sockets while also
-listening for more connections on a listen socket
-
- use IO::Select;
- use IO::Socket;
-
- $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
- $sel = new IO::Select( $lsn );
-
- while(@ready = $sel->can_read) {
- foreach $fh (@ready) {
- if($fh == $lsn) {
- # Create a new socket
- $new = $lsn->accept;
- $sel->add($new);
- }
- else {
- # Process socket
-
- # Maybe we have finished with the socket
- $sel->remove($fh);
- $fh->close;
- }
- }
- }
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1997-8 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/installer/perllib/IO/Socket.pm b/Master/tlpkg/installer/perllib/IO/Socket.pm
deleted file mode 100644
index 4429f2bb3e6..00000000000
--- a/Master/tlpkg/installer/perllib/IO/Socket.pm
+++ /dev/null
@@ -1,476 +0,0 @@
-# IO::Socket.pm
-#
-# Copyright (c) 1997-8 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 IO::Socket;
-
-require 5.006;
-
-use IO::Handle;
-use Socket 1.3;
-use Carp;
-use strict;
-our(@ISA, $VERSION, @EXPORT_OK);
-use Exporter;
-use Errno;
-
-# legacy
-
-require IO::Socket::INET;
-require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
-
-@ISA = qw(IO::Handle);
-
-$VERSION = "1.29";
-
-@EXPORT_OK = qw(sockatmark);
-
-sub import {
- my $pkg = shift;
- if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast
- Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark');
- } else {
- my $callpkg = caller;
- Exporter::export 'Socket', $callpkg, @_;
- }
-}
-
-sub new {
- my($class,%arg) = @_;
- my $sock = $class->SUPER::new();
-
- $sock->autoflush(1);
-
- ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
-
- return scalar(%arg) ? $sock->configure(\%arg)
- : $sock;
-}
-
-my @domain2pkg;
-
-sub register_domain {
- my($p,$d) = @_;
- $domain2pkg[$d] = $p;
-}
-
-sub configure {
- my($sock,$arg) = @_;
- my $domain = delete $arg->{Domain};
-
- croak 'IO::Socket: Cannot configure a generic socket'
- unless defined $domain;
-
- croak "IO::Socket: Unsupported socket domain"
- unless defined $domain2pkg[$domain];
-
- croak "IO::Socket: Cannot configure socket in domain '$domain'"
- unless ref($sock) eq "IO::Socket";
-
- bless($sock, $domain2pkg[$domain]);
- $sock->configure($arg);
-}
-
-sub socket {
- @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
- my($sock,$domain,$type,$protocol) = @_;
-
- socket($sock,$domain,$type,$protocol) or
- return undef;
-
- ${*$sock}{'io_socket_domain'} = $domain;
- ${*$sock}{'io_socket_type'} = $type;
- ${*$sock}{'io_socket_proto'} = $protocol;
-
- $sock;
-}
-
-sub socketpair {
- @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
- my($class,$domain,$type,$protocol) = @_;
- my $sock1 = $class->new();
- my $sock2 = $class->new();
-
- socketpair($sock1,$sock2,$domain,$type,$protocol) or
- return ();
-
- ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type;
- ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
-
- ($sock1,$sock2);
-}
-
-sub connect {
- @_ == 2 or croak 'usage: $sock->connect(NAME)';
- my $sock = shift;
- my $addr = shift;
- my $timeout = ${*$sock}{'io_socket_timeout'};
- my $err;
- my $blocking;
-
- $blocking = $sock->blocking(0) if $timeout;
- if (!connect($sock, $addr)) {
- if (defined $timeout && $!{EINPROGRESS}) {
- require IO::Select;
-
- my $sel = new IO::Select $sock;
-
- if (!$sel->can_write($timeout)) {
- $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
- $@ = "connect: timeout";
- }
- elsif (!connect($sock,$addr) && not $!{EISCONN}) {
- # Some systems refuse to re-connect() to
- # an already open socket and set errno to EISCONN.
- $err = $!;
- $@ = "connect: $!";
- }
- }
- elsif ($blocking || !$!{EINPROGRESS}) {
- $err = $!;
- $@ = "connect: $!";
- }
- }
-
- $sock->blocking(1) if $blocking;
-
- $! = $err if $err;
-
- $err ? undef : $sock;
-}
-
-sub bind {
- @_ == 2 or croak 'usage: $sock->bind(NAME)';
- my $sock = shift;
- my $addr = shift;
-
- return bind($sock, $addr) ? $sock
- : undef;
-}
-
-sub listen {
- @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
- my($sock,$queue) = @_;
- $queue = 5
- unless $queue && $queue > 0;
-
- return listen($sock, $queue) ? $sock
- : undef;
-}
-
-sub accept {
- @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
- my $sock = shift;
- my $pkg = shift || $sock;
- my $timeout = ${*$sock}{'io_socket_timeout'};
- my $new = $pkg->new(Timeout => $timeout);
- my $peer = undef;
-
- if(defined $timeout) {
- require IO::Select;
-
- my $sel = new IO::Select $sock;
-
- unless ($sel->can_read($timeout)) {
- $@ = 'accept: timeout';
- $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
- return;
- }
- }
-
- $peer = accept($new,$sock)
- or return;
-
- return wantarray ? ($new, $peer)
- : $new;
-}
-
-sub sockname {
- @_ == 1 or croak 'usage: $sock->sockname()';
- getsockname($_[0]);
-}
-
-sub peername {
- @_ == 1 or croak 'usage: $sock->peername()';
- my($sock) = @_;
- getpeername($sock)
- || ${*$sock}{'io_socket_peername'}
- || undef;
-}
-
-sub connected {
- @_ == 1 or croak 'usage: $sock->connected()';
- my($sock) = @_;
- getpeername($sock);
-}
-
-sub send {
- @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
- my $sock = $_[0];
- my $flags = $_[2] || 0;
- my $peer = $_[3] || $sock->peername;
-
- croak 'send: Cannot determine peer address'
- unless($peer);
-
- my $r = defined(getpeername($sock))
- ? send($sock, $_[1], $flags)
- : send($sock, $_[1], $flags, $peer);
-
- # remember who we send to, if it was successful
- ${*$sock}{'io_socket_peername'} = $peer
- if(@_ == 4 && defined $r);
-
- $r;
-}
-
-sub recv {
- @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
- my $sock = $_[0];
- my $len = $_[2];
- my $flags = $_[3] || 0;
-
- # remember who we recv'd from
- ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
-}
-
-sub shutdown {
- @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
- my($sock, $how) = @_;
- shutdown($sock, $how);
-}
-
-sub setsockopt {
- @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)';
- setsockopt($_[0],$_[1],$_[2],$_[3]);
-}
-
-my $intsize = length(pack("i",0));
-
-sub getsockopt {
- @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
- my $r = getsockopt($_[0],$_[1],$_[2]);
- # Just a guess
- $r = unpack("i", $r)
- if(defined $r && length($r) == $intsize);
- $r;
-}
-
-sub sockopt {
- my $sock = shift;
- @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
- : $sock->setsockopt(SOL_SOCKET,@_);
-}
-
-sub atmark {
- @_ == 1 or croak 'usage: $sock->atmark()';
- my($sock) = @_;
- sockatmark($sock);
-}
-
-sub timeout {
- @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
- my($sock,$val) = @_;
- my $r = ${*$sock}{'io_socket_timeout'};
-
- ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
- if(@_ == 2);
-
- $r;
-}
-
-sub sockdomain {
- @_ == 1 or croak 'usage: $sock->sockdomain()';
- my $sock = shift;
- ${*$sock}{'io_socket_domain'};
-}
-
-sub socktype {
- @_ == 1 or croak 'usage: $sock->socktype()';
- my $sock = shift;
- ${*$sock}{'io_socket_type'}
-}
-
-sub protocol {
- @_ == 1 or croak 'usage: $sock->protocol()';
- my($sock) = @_;
- ${*$sock}{'io_socket_proto'};
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO::Socket - Object interface to socket communications
-
-=head1 SYNOPSIS
-
- use IO::Socket;
-
-=head1 DESCRIPTION
-
-C<IO::Socket> provides an object interface to creating and using sockets. It
-is built upon the L<IO::Handle> interface and inherits all the methods defined
-by L<IO::Handle>.
-
-C<IO::Socket> only defines methods for those operations which are common to all
-types of socket. Operations which are specified to a socket in a particular
-domain have methods defined in sub classes of C<IO::Socket>
-
-C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ARGS] )
-
-Creates an C<IO::Socket>, which is a reference to a
-newly created symbol (see the C<Symbol> package). C<new>
-optionally takes arguments, these arguments are in key-value pairs.
-C<new> only looks for one key C<Domain> which tells new which domain
-the socket will be in. All other arguments will be passed to the
-configuration method of the package for that domain, See below.
-
- NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
-
-As of VERSION 1.18 all IO::Socket objects have autoflush turned on
-by default. This was not the case with earlier releases.
-
- NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
-
-=back
-
-=head1 METHODS
-
-See L<perlfunc> for complete descriptions of each of the following
-supported C<IO::Socket> methods, which are just front ends for the
-corresponding built-in functions:
-
- socket
- socketpair
- bind
- listen
- accept
- send
- recv
- peername (getpeername)
- sockname (getsockname)
- shutdown
-
-Some methods take slightly different arguments to those defined in L<perlfunc>
-in attempt to make the interface more flexible. These are
-
-=over 4
-
-=item accept([PKG])
-
-perform the system call C<accept> on the socket and return a new
-object. The new object will be created in the same class as the listen
-socket, unless C<PKG> is specified. This object can be used to
-communicate with the client that was trying to connect.
-
-In a scalar context the new socket is returned, or undef upon
-failure. In a list context a two-element array is returned containing
-the new socket and the peer address; the list will be empty upon
-failure.
-
-The timeout in the [PKG] can be specified as zero to effect a "poll",
-but you shouldn't do that because a new IO::Select object will be
-created behind the scenes just to do the single poll. This is
-horrendously inefficient. Use rather true select() with a zero
-timeout on the handle, or non-blocking IO.
-
-=item socketpair(DOMAIN, TYPE, PROTOCOL)
-
-Call C<socketpair> and return a list of two sockets created, or an
-empty list on failure.
-
-=back
-
-Additional methods that are provided are:
-
-=over 4
-
-=item atmark
-
-True if the socket is currently positioned at the urgent data mark,
-false otherwise.
-
- use IO::Socket;
-
- my $sock = IO::Socket::INET->new('some_server');
- $sock->read($data, 1024) until $sock->atmark;
-
-Note: this is a reasonably new addition to the family of socket
-functions, so all systems may not support this yet. If it is
-unsupported by the system, an attempt to use this method will
-abort the program.
-
-The atmark() functionality is also exportable as sockatmark() function:
-
- use IO::Socket 'sockatmark';
-
-This allows for a more traditional use of sockatmark() as a procedural
-socket function. If your system does not support sockatmark(), the
-C<use> declaration will fail at compile time.
-
-=item connected
-
-If the socket is in a connected state the peer address is returned.
-If the socket is not in a connected state then undef will be returned.
-
-=item protocol
-
-Returns the numerical number for the protocol being used on the socket, if
-known. If the protocol is unknown, as with an AF_UNIX socket, zero
-is returned.
-
-=item sockdomain
-
-Returns the numerical number for the socket domain type. For example, for
-an AF_INET socket the value of &AF_INET will be returned.
-
-=item sockopt(OPT [, VAL])
-
-Unified method to both set and get options in the SOL_SOCKET level. If called
-with one argument then getsockopt is called, otherwise setsockopt is called.
-
-=item socktype
-
-Returns the numerical number for the socket type. For example, for
-a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
-
-=item timeout([VAL])
-
-Set or get the timeout value associated with this socket. If called without
-any arguments then the current setting is returned. If called with an argument
-the current setting is changed and the previous value returned.
-
-=back
-
-=head1 SEE ALSO
-
-L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
-
-=head1 AUTHOR
-
-Graham Barr. atmark() by Lincoln Stein. Currently maintained by the
-Perl Porters. Please report all bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1997-8 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.
-
-The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
-This module is distributed under the same terms as Perl itself.
-Feel free to use, modify and redistribute it as long as you retain
-the correct attribution.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/IO/Socket/INET.pm b/Master/tlpkg/installer/perllib/IO/Socket/INET.pm
deleted file mode 100644
index 96b49911d81..00000000000
--- a/Master/tlpkg/installer/perllib/IO/Socket/INET.pm
+++ /dev/null
@@ -1,431 +0,0 @@
-# IO::Socket::INET.pm
-#
-# Copyright (c) 1997-8 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 IO::Socket::INET;
-
-use strict;
-our(@ISA, $VERSION);
-use IO::Socket;
-use Socket;
-use Carp;
-use Exporter;
-use Errno;
-
-@ISA = qw(IO::Socket);
-$VERSION = "1.29";
-
-my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
-
-IO::Socket::INET->register_domain( AF_INET );
-
-my %socket_type = ( tcp => SOCK_STREAM,
- udp => SOCK_DGRAM,
- icmp => SOCK_RAW
- );
-
-sub new {
- my $class = shift;
- unshift(@_, "PeerAddr") if @_ == 1;
- return $class->SUPER::new(@_);
-}
-
-sub _sock_info {
- my($addr,$port,$proto) = @_;
- my $origport = $port;
- my @proto = ();
- my @serv = ();
-
- $port = $1
- if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
-
- if(defined $proto && $proto =~ /\D/) {
- if(@proto = getprotobyname($proto)) {
- $proto = $proto[2] || undef;
- }
- else {
- $@ = "Bad protocol '$proto'";
- return;
- }
- }
-
- if(defined $port) {
- my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
- my $pnum = ($port =~ m,^(\d+)$,)[0];
-
- @serv = getservbyname($port, $proto[0] || "")
- if ($port =~ m,\D,);
-
- $port = $serv[2] || $defport || $pnum;
- unless (defined $port) {
- $@ = "Bad service '$origport'";
- return;
- }
-
- $proto = (getprotobyname($serv[3]))[2] || undef
- if @serv && !$proto;
- }
-
- return ($addr || undef,
- $port || undef,
- $proto || undef
- );
-}
-
-sub _error {
- my $sock = shift;
- my $err = shift;
- {
- local($!);
- my $title = ref($sock).": ";
- $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
- close($sock)
- if(defined fileno($sock));
- }
- $! = $err;
- return undef;
-}
-
-sub _get_addr {
- my($sock,$addr_str, $multi) = @_;
- my @addr;
- if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) {
- (undef, undef, undef, undef, @addr) = gethostbyname($addr_str);
- } else {
- my $h = inet_aton($addr_str);
- push(@addr, $h) if defined $h;
- }
- @addr;
-}
-
-sub configure {
- my($sock,$arg) = @_;
- my($lport,$rport,$laddr,$raddr,$proto,$type);
-
-
- $arg->{LocalAddr} = $arg->{LocalHost}
- if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
-
- ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
- $arg->{LocalPort},
- $arg->{Proto})
- or return _error($sock, $!, $@);
-
- $laddr = defined $laddr ? inet_aton($laddr)
- : INADDR_ANY;
-
- return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
- unless(defined $laddr);
-
- $arg->{PeerAddr} = $arg->{PeerHost}
- if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
-
- unless(exists $arg->{Listen}) {
- ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
- $arg->{PeerPort},
- $proto)
- or return _error($sock, $!, $@);
- }
-
- $proto ||= (getprotobyname('tcp'))[2];
-
- my $pname = (getprotobynumber($proto))[0];
- $type = $arg->{Type} || $socket_type{lc $pname};
-
- my @raddr = ();
-
- if(defined $raddr) {
- @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
- return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
- unless @raddr;
- }
-
- while(1) {
-
- $sock->socket(AF_INET, $type, $proto) or
- return _error($sock, $!, "$!");
-
- if (defined $arg->{Blocking}) {
- defined $sock->blocking($arg->{Blocking})
- or return _error($sock, $!, "$!");
- }
-
- if ($arg->{Reuse} || $arg->{ReuseAddr}) {
- $sock->sockopt(SO_REUSEADDR,1) or
- return _error($sock, $!, "$!");
- }
-
- if ($arg->{ReusePort}) {
- $sock->sockopt(SO_REUSEPORT,1) or
- return _error($sock, $!, "$!");
- }
-
- if ($arg->{Broadcast}) {
- $sock->sockopt(SO_BROADCAST,1) or
- return _error($sock, $!, "$!");
- }
-
- if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
- $sock->bind($lport || 0, $laddr) or
- return _error($sock, $!, "$!");
- }
-
- if(exists $arg->{Listen}) {
- $sock->listen($arg->{Listen} || 5) or
- return _error($sock, $!, "$!");
- last;
- }
-
- # don't try to connect unless we're given a PeerAddr
- last unless exists($arg->{PeerAddr});
-
- $raddr = shift @raddr;
-
- return _error($sock, $EINVAL, 'Cannot determine remote port')
- unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
-
- last
- unless($type == SOCK_STREAM || defined $raddr);
-
- return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
- unless defined $raddr;
-
-# my $timeout = ${*$sock}{'io_socket_timeout'};
-# my $before = time() if $timeout;
-
- undef $@;
- if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
-# ${*$sock}{'io_socket_timeout'} = $timeout;
- return $sock;
- }
-
- return _error($sock, $!, $@ || "Timeout")
- unless @raddr;
-
-# if ($timeout) {
-# my $new_timeout = $timeout - (time() - $before);
-# return _error($sock,
-# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
-# "Timeout") if $new_timeout <= 0;
-# ${*$sock}{'io_socket_timeout'} = $new_timeout;
-# }
-
- }
-
- $sock;
-}
-
-sub connect {
- @_ == 2 || @_ == 3 or
- croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
- my $sock = shift;
- return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
-}
-
-sub bind {
- @_ == 2 || @_ == 3 or
- croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
- my $sock = shift;
- return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
-}
-
-sub sockaddr {
- @_ == 1 or croak 'usage: $sock->sockaddr()';
- my($sock) = @_;
- my $name = $sock->sockname;
- $name ? (sockaddr_in($name))[1] : undef;
-}
-
-sub sockport {
- @_ == 1 or croak 'usage: $sock->sockport()';
- my($sock) = @_;
- my $name = $sock->sockname;
- $name ? (sockaddr_in($name))[0] : undef;
-}
-
-sub sockhost {
- @_ == 1 or croak 'usage: $sock->sockhost()';
- my($sock) = @_;
- my $addr = $sock->sockaddr;
- $addr ? inet_ntoa($addr) : undef;
-}
-
-sub peeraddr {
- @_ == 1 or croak 'usage: $sock->peeraddr()';
- my($sock) = @_;
- my $name = $sock->peername;
- $name ? (sockaddr_in($name))[1] : undef;
-}
-
-sub peerport {
- @_ == 1 or croak 'usage: $sock->peerport()';
- my($sock) = @_;
- my $name = $sock->peername;
- $name ? (sockaddr_in($name))[0] : undef;
-}
-
-sub peerhost {
- @_ == 1 or croak 'usage: $sock->peerhost()';
- my($sock) = @_;
- my $addr = $sock->peeraddr;
- $addr ? inet_ntoa($addr) : undef;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO::Socket::INET - Object interface for AF_INET domain sockets
-
-=head1 SYNOPSIS
-
- use IO::Socket::INET;
-
-=head1 DESCRIPTION
-
-C<IO::Socket::INET> provides an object interface to creating and using sockets
-in the AF_INET domain. It is built upon the L<IO::Socket> interface and
-inherits all the methods defined by L<IO::Socket>.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ARGS] )
-
-Creates an C<IO::Socket::INET> object, which is a reference to a
-newly created symbol (see the C<Symbol> package). C<new>
-optionally takes arguments, these arguments are in key-value pairs.
-
-In addition to the key-value pairs accepted by L<IO::Socket>,
-C<IO::Socket::INET> provides.
-
-
- PeerAddr Remote host address <hostname>[:<port>]
- PeerHost Synonym for PeerAddr
- PeerPort Remote port or service <service>[(<no>)] | <no>
- LocalAddr Local host bind address hostname[:port]
- LocalHost Synonym for LocalAddr
- LocalPort Local host bind port <service>[(<no>)] | <no>
- Proto Protocol name (or number) "tcp" | "udp" | ...
- Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
- Listen Queue size for listen
- ReuseAddr Set SO_REUSEADDR before binding
- Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr)
- ReusePort Set SO_REUSEPORT before binding
- Broadcast Set SO_BROADCAST before binding
- Timeout Timeout value for various operations
- MultiHomed Try all addresses for multi-homed hosts
- Blocking Determine if connection will be blocking mode
-
-If C<Listen> is defined then a listen socket is created, else if the
-socket type, which is derived from the protocol, is SOCK_STREAM then
-connect() is called.
-
-Although it is not illegal, the use of C<MultiHomed> on a socket
-which is in non-blocking mode is of little use. This is because the
-first connect will never fail with a timeout as the connect call
-will not block.
-
-The C<PeerAddr> can be a hostname or the IP-address on the
-"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic
-service name. The service name might be followed by a number in
-parenthesis which is used if the service is not known by the system.
-The C<PeerPort> specification can also be embedded in the C<PeerAddr>
-by preceding it with a ":".
-
-If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
-then the constructor will try to derive C<Proto> from the service
-name. As a last resort C<Proto> "tcp" is assumed. The C<Type>
-parameter will be deduced from C<Proto> if not specified.
-
-If the constructor is only passed a single argument, it is assumed to
-be a C<PeerAddr> specification.
-
-If C<Blocking> is set to 0, the connection will be in nonblocking mode.
-If not specified it defaults to 1 (blocking mode).
-
-Examples:
-
- $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
- PeerPort => 'http(80)',
- Proto => 'tcp');
-
- $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
-
- $sock = IO::Socket::INET->new(Listen => 5,
- LocalAddr => 'localhost',
- LocalPort => 9000,
- Proto => 'tcp');
-
- $sock = IO::Socket::INET->new('127.0.0.1:25');
-
- $sock = IO::Socket::INET->new(PeerPort => 9999,
- PeerAddr => inet_ntoa(INADDR_BROADCAST),
- Proto => udp,
- LocalAddr => 'localhost',
- Broadcast => 1 )
- or die "Can't bind : $@\n";
-
- NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
-
-As of VERSION 1.18 all IO::Socket objects have autoflush turned on
-by default. This was not the case with earlier releases.
-
- NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
-
-=back
-
-=head2 METHODS
-
-=over 4
-
-=item sockaddr ()
-
-Return the address part of the sockaddr structure for the socket
-
-=item sockport ()
-
-Return the port number that the socket is using on the local host
-
-=item sockhost ()
-
-Return the address part of the sockaddr structure for the socket in a
-text form xx.xx.xx.xx
-
-=item peeraddr ()
-
-Return the address part of the sockaddr structure for the socket on
-the peer host
-
-=item peerport ()
-
-Return the port number for the socket on the peer host.
-
-=item peerhost ()
-
-Return the address part of the sockaddr structure for the socket on the
-peer host in a text form xx.xx.xx.xx
-
-=back
-
-=head1 SEE ALSO
-
-L<Socket>, L<IO::Socket>
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1996-8 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/installer/perllib/IO/Socket/UNIX.pm b/Master/tlpkg/installer/perllib/IO/Socket/UNIX.pm
deleted file mode 100644
index 952a0f41f0c..00000000000
--- a/Master/tlpkg/installer/perllib/IO/Socket/UNIX.pm
+++ /dev/null
@@ -1,144 +0,0 @@
-# IO::Socket::UNIX.pm
-#
-# Copyright (c) 1997-8 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 IO::Socket::UNIX;
-
-use strict;
-our(@ISA, $VERSION);
-use IO::Socket;
-use Socket;
-use Carp;
-
-@ISA = qw(IO::Socket);
-$VERSION = "1.22";
-$VERSION = eval $VERSION;
-
-IO::Socket::UNIX->register_domain( AF_UNIX );
-
-sub new {
- my $class = shift;
- unshift(@_, "Peer") if @_ == 1;
- return $class->SUPER::new(@_);
-}
-
-sub configure {
- my($sock,$arg) = @_;
- my($bport,$cport);
-
- my $type = $arg->{Type} || SOCK_STREAM;
-
- $sock->socket(AF_UNIX, $type, 0) or
- return undef;
-
- if(exists $arg->{Local}) {
- my $addr = sockaddr_un($arg->{Local});
- $sock->bind($addr) or
- return undef;
- }
- if(exists $arg->{Listen} && $type != SOCK_DGRAM) {
- $sock->listen($arg->{Listen} || 5) or
- return undef;
- }
- elsif(exists $arg->{Peer}) {
- my $addr = sockaddr_un($arg->{Peer});
- $sock->connect($addr) or
- return undef;
- }
-
- $sock;
-}
-
-sub hostpath {
- @_ == 1 or croak 'usage: $sock->hostpath()';
- my $n = $_[0]->sockname || return undef;
- (sockaddr_un($n))[0];
-}
-
-sub peerpath {
- @_ == 1 or croak 'usage: $sock->peerpath()';
- my $n = $_[0]->peername || return undef;
- (sockaddr_un($n))[0];
-}
-
-1; # Keep require happy
-
-__END__
-
-=head1 NAME
-
-IO::Socket::UNIX - Object interface for AF_UNIX domain sockets
-
-=head1 SYNOPSIS
-
- use IO::Socket::UNIX;
-
-=head1 DESCRIPTION
-
-C<IO::Socket::UNIX> provides an object interface to creating and using sockets
-in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and
-inherits all the methods defined by L<IO::Socket>.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ARGS] )
-
-Creates an C<IO::Socket::UNIX> object, which is a reference to a
-newly created symbol (see the C<Symbol> package). C<new>
-optionally takes arguments, these arguments are in key-value pairs.
-
-In addition to the key-value pairs accepted by L<IO::Socket>,
-C<IO::Socket::UNIX> provides.
-
- Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
- Local Path to local fifo
- Peer Path to peer fifo
- Listen Create a listen socket
-
-If the constructor is only passed a single argument, it is assumed to
-be a C<Peer> specification.
-
-
- NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
-
-As of VERSION 1.18 all IO::Socket objects have autoflush turned on
-by default. This was not the case with earlier releases.
-
- NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item hostpath()
-
-Returns the pathname to the fifo at the local end
-
-=item peerpath()
-
-Returns the pathanme to the fifo at the peer end
-
-=back
-
-=head1 SEE ALSO
-
-L<Socket>, L<IO::Socket>
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1996-8 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/installer/perllib/List/Util.pm b/Master/tlpkg/installer/perllib/List/Util.pm
deleted file mode 100644
index cfe31f70123..00000000000
--- a/Master/tlpkg/installer/perllib/List/Util.pm
+++ /dev/null
@@ -1,277 +0,0 @@
-# List::Util.pm
-#
-# Copyright (c) 1997-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 List::Util;
-
-use strict;
-use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY);
-require Exporter;
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle);
-$VERSION = "1.18";
-$XS_VERSION = $VERSION;
-$VERSION = eval $VERSION;
-
-eval {
- # PERL_DL_NONLAZY must be false, or any errors in loading will just
- # cause the perl code to be tested
- local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
- eval {
- require XSLoader;
- XSLoader::load('List::Util', $XS_VERSION);
- 1;
- } or do {
- require DynaLoader;
- local @ISA = qw(DynaLoader);
- bootstrap List::Util $XS_VERSION;
- };
-} unless $TESTING_PERL_ONLY;
-
-
-# This code is only compiled if the XS did not load
-# of for perl < 5.6.0
-
-if (!defined &reduce) {
-eval <<'ESQ'
-
-sub reduce (&@) {
- my $code = shift;
- no strict 'refs';
-
- return shift unless @_ > 1;
-
- use vars qw($a $b);
-
- my $caller = caller;
- local(*{$caller."::a"}) = \my $a;
- local(*{$caller."::b"}) = \my $b;
-
- $a = shift;
- foreach (@_) {
- $b = $_;
- $a = &{$code}();
- }
-
- $a;
-}
-
-sub first (&@) {
- my $code = shift;
-
- foreach (@_) {
- return $_ if &{$code}();
- }
-
- undef;
-}
-
-ESQ
-}
-
-# This code is only compiled if the XS did not load
-eval <<'ESQ' if !defined &sum;
-
-use vars qw($a $b);
-
-sub sum (@) { reduce { $a + $b } @_ }
-
-sub min (@) { reduce { $a < $b ? $a : $b } @_ }
-
-sub max (@) { reduce { $a > $b ? $a : $b } @_ }
-
-sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
-
-sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }
-
-sub shuffle (@) {
- my @a=\(@_);
- my $n;
- my $i=@_;
- map {
- $n = rand($i--);
- (${$a[$n]}, $a[$n] = $a[$i])[0];
- } @_;
-}
-
-ESQ
-
-1;
-
-__END__
-
-=head1 NAME
-
-List::Util - A selection of general-utility list subroutines
-
-=head1 SYNOPSIS
-
- use List::Util qw(first max maxstr min minstr reduce shuffle sum);
-
-=head1 DESCRIPTION
-
-C<List::Util> contains a selection of subroutines that people have
-expressed would be nice to have in the perl core, but the usage would
-not really be high enough to warrant the use of a keyword, and the size
-so small such that being individual extensions would be wasteful.
-
-By default C<List::Util> does not export any subroutines. The
-subroutines defined are
-
-=over 4
-
-=item first BLOCK LIST
-
-Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
-of LIST in turn. C<first> returns the first element where the result from
-BLOCK is a true value. If BLOCK never returns true or LIST was empty then
-C<undef> is returned.
-
- $foo = first { defined($_) } @list # first defined value in @list
- $foo = first { $_ > $value } @list # first value in @list which
- # is greater than $value
-
-This function could be implemented using C<reduce> like this
-
- $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list
-
-for example wanted() could be defined() which would return the first
-defined value in @list
-
-=item max LIST
-
-Returns the entry in the list with the highest numerical value. If the
-list is empty then C<undef> is returned.
-
- $foo = max 1..10 # 10
- $foo = max 3,9,12 # 12
- $foo = max @bar, @baz # whatever
-
-This function could be implemented using C<reduce> like this
-
- $foo = reduce { $a > $b ? $a : $b } 1..10
-
-=item maxstr LIST
-
-Similar to C<max>, but treats all the entries in the list as strings
-and returns the highest string as defined by the C<gt> operator.
-If the list is empty then C<undef> is returned.
-
- $foo = maxstr 'A'..'Z' # 'Z'
- $foo = maxstr "hello","world" # "world"
- $foo = maxstr @bar, @baz # whatever
-
-This function could be implemented using C<reduce> like this
-
- $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z'
-
-=item min LIST
-
-Similar to C<max> but returns the entry in the list with the lowest
-numerical value. If the list is empty then C<undef> is returned.
-
- $foo = min 1..10 # 1
- $foo = min 3,9,12 # 3
- $foo = min @bar, @baz # whatever
-
-This function could be implemented using C<reduce> like this
-
- $foo = reduce { $a < $b ? $a : $b } 1..10
-
-=item minstr LIST
-
-Similar to C<min>, but treats all the entries in the list as strings
-and returns the lowest string as defined by the C<lt> operator.
-If the list is empty then C<undef> is returned.
-
- $foo = minstr 'A'..'Z' # 'A'
- $foo = minstr "hello","world" # "hello"
- $foo = minstr @bar, @baz # whatever
-
-This function could be implemented using C<reduce> like this
-
- $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z'
-
-=item reduce BLOCK LIST
-
-Reduces LIST by calling BLOCK multiple times, setting C<$a> and C<$b>
-each time. The first call will be with C<$a> and C<$b> set to the first
-two elements of the list, subsequent calls will be done by
-setting C<$a> to the result of the previous call and C<$b> to the next
-element in the list.
-
-Returns the result of the last call to BLOCK. If LIST is empty then
-C<undef> is returned. If LIST only contains one element then that
-element is returned and BLOCK is not executed.
-
- $foo = reduce { $a < $b ? $a : $b } 1..10 # min
- $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
- $foo = reduce { $a + $b } 1 .. 10 # sum
- $foo = reduce { $a . $b } @bar # concat
-
-=item shuffle LIST
-
-Returns the elements of LIST in a random order
-
- @cards = shuffle 0..51 # 0..51 in a random order
-
-=item sum LIST
-
-Returns the sum of all the elements in LIST. If LIST is empty then
-C<undef> is returned.
-
- $foo = sum 1..10 # 55
- $foo = sum 3,9,12 # 24
- $foo = sum @bar, @baz # whatever
-
-This function could be implemented using C<reduce> like this
-
- $foo = reduce { $a + $b } 1..10
-
-=back
-
-=head1 KNOWN BUGS
-
-With perl versions prior to 5.005 there are some cases where reduce
-will return an incorrect result. This will show up as test 7 of
-reduce.t failing.
-
-=head1 SUGGESTED ADDITIONS
-
-The following are additions that have been requested, but I have been reluctant
-to add due to them being very simple to implement in perl
-
- # One argument is true
-
- sub any { $_ && return 1 for @_; 0 }
-
- # All arguments are true
-
- sub all { $_ || return 0 for @_; 1 }
-
- # All arguments are false
-
- sub none { $_ && return 0 for @_; 1 }
-
- # One argument is false
-
- sub notall { $_ || return 1 for @_; 0 }
-
- # How many elements are true
-
- sub true { scalar grep { $_ } @_ }
-
- # How many elements are false
-
- sub false { scalar grep { !$_ } @_ }
-
-=head1 COPYRIGHT
-
-Copyright (c) 1997-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/installer/perllib/Opcode.pm b/Master/tlpkg/installer/perllib/Opcode.pm
deleted file mode 100644
index 2987b9952e0..00000000000
--- a/Master/tlpkg/installer/perllib/Opcode.pm
+++ /dev/null
@@ -1,578 +0,0 @@
-package Opcode;
-
-use 5.006_001;
-
-use strict;
-
-our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK);
-
-$VERSION = "1.06";
-$XS_VERSION = "1.03";
-
-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', $XS_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 and or 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. To create new filehandles other ops
-such as open would need to be enabled.
-
- readline rcatline getc read
-
- formline enterwrite leavewrite
-
- print 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
-
- 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
-
- 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 threadsv
-
-=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_io :base_orig :base_thread
-
-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 :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
- require dofile
-
- caller -- get info about calling environment and args
-
- 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
-
-ops(3) -- perl pragma interface to Opcode module.
-
-Safe(3) -- 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/installer/perllib/POSIX.pm b/Master/tlpkg/installer/perllib/POSIX.pm
deleted file mode 100644
index 87676215e73..00000000000
--- a/Master/tlpkg/installer/perllib/POSIX.pm
+++ /dev/null
@@ -1,965 +0,0 @@
-package POSIX;
-
-our(@ISA, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD) = ();
-
-our $VERSION = "1.09";
-
-use AutoLoader;
-
-use XSLoader ();
-
-# 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;
-
-my %NON_CONSTS = (map {($_,1)}
- qw(S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG WEXITSTATUS
- WIFEXITED WIFSIGNALED WIFSTOPPED WSTOPSIG WTERMSIG));
-
-sub AUTOLOAD {
- if ($AUTOLOAD =~ /::(_?[a-z])/) {
- # require AutoLoader;
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD
- }
- local $! = 0;
- my $constname = $AUTOLOAD;
- $constname =~ s/.*:://;
- if ($NON_CONSTS{$constname}) {
- my ($val, $error) = &int_macro_int($constname, $_[0]);
- croak $error if $error;
- *$AUTOLOAD = sub { &int_macro_int($constname, $_[0]) };
- } else {
- my ($error, $val) = constant($constname);
- croak $error if $error;
- *$AUTOLOAD = sub { $val };
- }
-
- goto &$AUTOLOAD;
-}
-
-package POSIX::SigAction;
-
-use AutoLoader 'AUTOLOAD';
-sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] }
-
-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;
- 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 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();
-for (values %EXPORT_TAGS) {
- push @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 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} };
diff --git a/Master/tlpkg/installer/perllib/Pod/Checker.pm b/Master/tlpkg/installer/perllib/Pod/Checker.pm
deleted file mode 100644
index 49162da4a27..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Checker.pm
+++ /dev/null
@@ -1,1270 +0,0 @@
-#############################################################################
-# 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 vars qw($VERSION);
-$VERSION = 1.43; ## 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 nonexisting 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 happend 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 bulletted 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 wrt. 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 behaviour. Users of B<podchecker> (the script)
-get the well-known behaviour.
-
-=cut
-
-#############################################################################
-
-use strict;
-#use diagnostics;
-use Carp;
-use Exporter;
-use Pod::Parser;
-
-use vars qw(@ISA @EXPORT);
-@ISA = qw(Pod::Parser);
-@EXPORT = qw(&podchecker);
-
-use vars qw(%VALID_COMMANDS %VALID_SEQUENCES);
-
-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,
-);
-
-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 => "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
- die "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/installer/perllib/Pod/Find.pm b/Master/tlpkg/installer/perllib/Pod/Find.pm
deleted file mode 100644
index 0b085b8c9e3..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Find.pm
+++ /dev/null
@@ -1,523 +0,0 @@
-#############################################################################
-# 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 vars qw($VERSION);
-$VERSION = 1.34; ## Current version of this package
-require 5.005; ## requires this Perl version or later
-use Carp;
-
-#############################################################################
-
-=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 strict;
-#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 prepended to 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;
- %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;
- }
- $$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 undef;
- }
-
- return undef 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!!os 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; # / -> ::
- }
- $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);
- $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 undef;
-}
-
-=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
- unless(open(POD,"<$file")) {
- warn "Error: $file is unreadable: $!\n";
- return undef;
- }
-
- local $/ = undef;
- my $pod = <POD>;
- close(POD) || die "Error closing $file: $!\n";
- unless($pod =~ /^=(head\d|pod|over|item)\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/installer/perllib/Pod/Functions.pm b/Master/tlpkg/installer/perllib/Pod/Functions.pm
deleted file mode 100644
index 0e250cf0b50..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Functions.pm
+++ /dev/null
@@ -1,376 +0,0 @@
-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/installer/perllib/Pod/Html.pm b/Master/tlpkg/installer/perllib/Pod/Html.pm
deleted file mode 100644
index 4b9752bc6fc..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Html.pm
+++ /dev/null
@@ -1,2123 +0,0 @@
-package Pod::Html;
-use strict;
-require Exporter;
-
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = 1.0504;
-@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 ARGUMENTS
-
-Pod::Html 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
-
-=head1 EXAMPLE
-
- 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");
-
-=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 $PTQuote;
-
-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)
- $PTQuote = 0; # status of double-quote conversion
- %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;
- print HTML "<p><a name=\"__index__\"></a></p>\n";
- print HTML "<!-- INDEX BEGIN -->\n";
- print HTML "<!--\n" unless $Doindex;
- print HTML $index;
- print HTML "-->\n" unless $Doindex;
- print HTML "<!-- INDEX END -->\n\n";
- print HTML "<hr />\n" if $Doindex and $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){
- $PTQuote = 0; # status of quote conversion
-
- $_ = $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( $text );
-
- $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_' . $item;
- $name = anchorify($name);
- print HTML qq{<a name="$name">}, 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+(.+)\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*(.+)\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 );
- } else {
- warn "$0: $Podfile: no term text provided for definition list in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- }
- # 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 ($Begin_Stack[-1] ne $whom ) {
- die "Unmatched begin/end at chunk $Paragraph\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, \$PTQuote, 1 );
-}
-
-sub inIS_text($){
- my $text = shift();
- process_puretext( $text, \$PTQuote, 0 );
-}
-
-#
-# process_puretext - process pure text (without pod-escapes) converting
-# double-quotes and handling implicit C<> links.
-#
-sub process_puretext {
- my($text, $quote, $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);
-
- # convert double-quotes to single-quotes
- if( $$quote && $text =~ s/"/''/s ){
- $$quote = 0;
- }
- while ($text =~ s/"([^"]*)"/``$1''/sg) {};
- $$quote = 1 if $text =~ s/"/``/s;
-
- # 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
- if( $notinIS && $word =~ /^(\w+)\((.*)\)$/ ) {
- # has parenthesis so should have been a C<> ref
- ## try for a pagename (perlXXX(1))?
- my( $func, $args ) = ( $1, $2 );
- if( $args =~ /^\d+$/ ){
- my $url = page_sect( $word, '' );
- if( defined $url ){
- $word = "<a href=\"$url\">the $word manpage</a>";
- next;
- }
- }
- ## try function name for a link, append tt'ed argument list
- $word = emit_C( $func, '', "($args)");
-
-#### 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\n]+'.('>' x ($_[0] + 1)) : '>' }
-sub closing ($) { local($_) = shift; (defined && s/\s+$//) ? length : 0 }
-
-sub process_text {
- return if $Ignore;
- my( $tref ) = @_;
- my $res = process_text1( 0, $tref );
- $$tref = $res;
-}
-
-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> - italizice
- $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
-
- } elsif( $func eq 'I' ){
- # I<text> - italizice
- $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)
- ( $page, $ident ) = ( $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
- $$rstr =~ s/^[^>]*>//;
-
- } elsif( $func eq 'Z' ){
- # Z<> - empty
- warn "$0: $Podfile: invalid X<> 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 );
- } else {
- warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph.\n" unless $Quiet;
- }
- }
- 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\n]+)?|@{[pattern $closing[0]]})//s ){
- $res .= $1;
- unless( $3 ){
- shift @closing;
- return $res unless @closing;
- } else {
- unshift @closing, closing $4;
- }
- $res .= $2;
- }
- warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph.\n" unless $Quiet;
- 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
- if ($Pages{$page} =~ /([^:]*)\.pod:/) {
- $link = "$Htmlroot/$1.html$section";
- } elsif ($Pages{$page} =~ /([^:]*)\.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;
-
- # 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#item_" . 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 = "#item_" . 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 = 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]+)?// ){
- # 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)// ){
- $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;
-}
-
-#
-# fragment_id - construct a fragment identifier from:
-# a) =item text
-# b) contents of C<...>
-#
-my @HC;
-sub fragment_id {
- my $text = shift();
- $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\d,/& ]+)?$};
- return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$};
-
- # text? normalize!
- $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 );
- } else {
- return undef();
- }
-}
-
-#
-# 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/installer/perllib/Pod/InputObjects.pm b/Master/tlpkg/installer/perllib/Pod/InputObjects.pm
deleted file mode 100644
index fa5f61f9a70..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/InputObjects.pm
+++ /dev/null
@@ -1,941 +0,0 @@
-#############################################################################
-# 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 vars qw($VERSION);
-$VERSION = 1.30; ## 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
-
-#############################################################################
-
-use strict;
-#use diagnostics;
-#use Carp;
-
-#############################################################################
-
-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 and !(ref $ptree[0]) and !(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/installer/perllib/Pod/LaTeX.pm b/Master/tlpkg/installer/perllib/Pod/LaTeX.pm
deleted file mode 100644
index 9d3a905258f..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/LaTeX.pm
+++ /dev/null
@@ -1,1876 +0,0 @@
-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/installer/perllib/Pod/Man.pm b/Master/tlpkg/installer/perllib/Pod/Man.pm
deleted file mode 100644
index 693e4c46896..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Man.pm
+++ /dev/null
@@ -1,1413 +0,0 @@
-# Pod::Man -- Convert POD data to formatted *roff input.
-# $Id: Man.pm,v 1.37 2003/03/30 22:34:11 eagle Exp $
-#
-# Copyright 1999, 2000, 2001, 2002, 2003 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 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 Carp qw(carp croak);
-use Pod::ParseLink qw(parselink);
-use Pod::Parser ();
-
-use strict;
-use subs qw(makespace);
-use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION);
-
-@ISA = qw(Pod::Parser);
-
-# Don't use the CVS revision as the version, since this module is also in Perl
-# core and too many things could munge CVS magic revision strings. This
-# number should ideally be the same as the CVS revision in podlators, however.
-$VERSION = 1.37;
-
-
-##############################################################################
-# Preamble and *roff output tables
-##############################################################################
-
-# The following is the static preamble which starts all *roff output we
-# generate. It's completely 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@. $PREAMBLE
-# should therefore be run through s/\@CFONT\@/<font>/g before output.
-$PREAMBLE = <<'----END OF PREAMBLE----';
-.de Sh \" Subsection heading
-.br
-.if t .Sp
-.ne 5
-.PP
-\fB\\$1\fR
-.PP
-..
-.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\}
-.\"
-.\" If the F register is turned on, we'll generate index entries on stderr for
-.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index
-.\" entries marked with X<> in POD. Of course, you'll have to process the
-.\" output yourself in some meaningful fashion.
-.if \nF \{\
-. de IX
-. tm Index:\\$1\t\\n%\t"\\$2"
-..
-. nr % 0
-. rr F
-.\}
-.\"
-.\" For nroff, turn off justification. Always turn off hyphenation; it makes
-.\" way too many mistakes in technical documents.
-.hy 0
-.if n .na
-.\"
-.\" 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
-
-# This table is taken nearly verbatim 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. Note that some of these are quoted
-# with double quotes since they contain embedded single quotes, so use \\
-# uniformly for backslash for readability.
-%ESCAPES = (
- 'amp' => '&', # ampersand
- 'apos' => "'", # apostrophe
- 'lt' => '<', # left chevron, less-than
- 'gt' => '>', # right chevron, greater-than
- 'quot' => '"', # double quote
- 'sol' => '/', # solidus (forward slash)
- 'verbar' => '|', # vertical bar
-
- 'Aacute' => "A\\*'", # capital A, acute accent
- 'aacute' => "a\\*'", # small a, acute accent
- 'Acirc' => 'A\\*^', # capital A, circumflex accent
- 'acirc' => 'a\\*^', # small a, circumflex accent
- 'AElig' => '\*(AE', # capital AE diphthong (ligature)
- 'aelig' => '\*(ae', # small ae diphthong (ligature)
- 'Agrave' => "A\\*`", # capital A, grave accent
- 'agrave' => "A\\*`", # small a, grave accent
- 'Aring' => 'A\\*o', # capital A, ring
- 'aring' => 'a\\*o', # small a, ring
- 'Atilde' => 'A\\*~', # capital A, tilde
- 'atilde' => 'a\\*~', # small a, tilde
- 'Auml' => 'A\\*:', # capital A, dieresis or umlaut mark
- 'auml' => 'a\\*:', # small a, dieresis or umlaut mark
- 'Ccedil' => 'C\\*,', # capital C, cedilla
- 'ccedil' => 'c\\*,', # small c, cedilla
- 'Eacute' => "E\\*'", # capital E, acute accent
- 'eacute' => "e\\*'", # small e, acute accent
- 'Ecirc' => 'E\\*^', # capital E, circumflex accent
- 'ecirc' => 'e\\*^', # small e, circumflex accent
- 'Egrave' => 'E\\*`', # capital E, grave accent
- 'egrave' => 'e\\*`', # small e, grave accent
- 'ETH' => '\\*(D-', # capital Eth, Icelandic
- 'eth' => '\\*(d-', # small eth, Icelandic
- 'Euml' => 'E\\*:', # capital E, dieresis or umlaut mark
- 'euml' => 'e\\*:', # small e, dieresis or umlaut mark
- 'Iacute' => "I\\*'", # capital I, acute accent
- 'iacute' => "i\\*'", # small i, acute accent
- 'Icirc' => 'I\\*^', # capital I, circumflex accent
- 'icirc' => 'i\\*^', # small i, circumflex accent
- 'Igrave' => 'I\\*`', # capital I, grave accent
- 'igrave' => 'i\\*`', # small i, grave accent
- 'Iuml' => 'I\\*:', # capital I, dieresis or umlaut mark
- 'iuml' => 'i\\*:', # small i, dieresis or umlaut mark
- 'Ntilde' => 'N\*~', # capital N, tilde
- 'ntilde' => 'n\*~', # small n, tilde
- 'Oacute' => "O\\*'", # capital O, acute accent
- 'oacute' => "o\\*'", # small o, acute accent
- 'Ocirc' => 'O\\*^', # capital O, circumflex accent
- 'ocirc' => 'o\\*^', # small o, circumflex accent
- 'Ograve' => 'O\\*`', # capital O, grave accent
- 'ograve' => 'o\\*`', # small o, grave accent
- 'Oslash' => 'O\\*/', # capital O, slash
- 'oslash' => 'o\\*/', # small o, slash
- 'Otilde' => 'O\\*~', # capital O, tilde
- 'otilde' => 'o\\*~', # small o, tilde
- 'Ouml' => 'O\\*:', # capital O, dieresis or umlaut mark
- 'ouml' => 'o\\*:', # small o, dieresis or umlaut mark
- 'szlig' => '\*8', # small sharp s, German (sz ligature)
- 'THORN' => '\\*(Th', # capital THORN, Icelandic
- 'thorn' => '\\*(th', # small thorn, Icelandic
- 'Uacute' => "U\\*'", # capital U, acute accent
- 'uacute' => "u\\*'", # small u, acute accent
- 'Ucirc' => 'U\\*^', # capital U, circumflex accent
- 'ucirc' => 'u\\*^', # small u, circumflex accent
- 'Ugrave' => 'U\\*`', # capital U, grave accent
- 'ugrave' => 'u\\*`', # small u, grave accent
- 'Uuml' => 'U\\*:', # capital U, dieresis or umlaut mark
- 'uuml' => 'u\\*:', # small u, dieresis or umlaut mark
- 'Yacute' => "Y\\*'", # capital Y, acute accent
- 'yacute' => "y\\*'", # small y, acute accent
- 'yuml' => 'y\\*:', # small y, dieresis or umlaut mark
-
- 'nbsp' => '\\ ', # non-breaking space
- 'shy' => '', # soft (discretionary) hyphen
-);
-
-
-##############################################################################
-# Static helper functions
-##############################################################################
-
-# 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 {
- local $_ = shift;
- s/^([.\'\\])/\\&$1/mg;
- $_;
-}
-
-# Translate a font string into an escape.
-sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] }
-
-
-##############################################################################
-# Initialization
-##############################################################################
-
-# Initialize the object. Here, we also process any additional options passed
-# to the constructor or set up defaults if none were given. center is the
-# centered title, release is the version number, and date is the date for the
-# documentation. Note that we can't know what file name we're processing due
-# to the architecture of Pod::Parser, so that *has* to either be passed to the
-# constructor or set separately with Pod::Man::name().
-sub initialize {
- my $self = shift;
-
- # Figure out the fixed-width font. If user-supplied, make sure that they
- # are the right length.
- for (qw/fixed fixedbold fixeditalic fixedbolditalic/) {
- if (defined $$self{$_}) {
- if (length ($$self{$_}) < 1 || length ($$self{$_}) > 2) {
- croak qq(roff font should be 1 or 2 chars,)
- . qq( not "$$self{$_}");
- }
- } else {
- $$self{$_} = '';
- }
- }
-
- # Set the default fonts. We can't be sure what fixed bold-italic is going
- # to be called, 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})};
-
- # Extra stuff for page titles.
- $$self{center} = 'User Contributed Perl Documentation'
- unless defined $$self{center};
- $$self{indent} = 4 unless defined $$self{indent};
-
- # 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.
- if (!defined $$self{release}) {
- my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
- $version[2] ||= 0;
- $version[2] *= 10 ** (3 - length $version[2]);
- for (@version) { $_ += 0 }
- $$self{release} = 'perl v' . join ('.', @version);
- }
-
- # Double quotes in things that will be quoted.
- for (qw/center date release/) {
- $$self{$_} =~ s/\"/\"\"/g if $$self{$_};
- }
-
- # Figure out what quotes we'll be using for C<> text.
- $$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/\"/\"\"/;
-
- $self->SUPER::initialize;
-}
-
-# For each document we process, output the preamble first.
-sub begin_pod {
- my $self = shift;
-
- # Try to figure out the name and section from the file name.
- my $section = $$self{section} || 1;
- my $name = $$self{name};
- if (!defined $name) {
- $name = $self->input_file;
- $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i);
- $name =~ s/\.p(od|[lm])\z//i;
- if ($section !~ /^3/) {
- require File::Basename;
- $name = uc File::Basename::basename ($name);
- } else {
- # Assume that 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
- # everything up to the first of:
- #
- # */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 or site_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.
- 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 < scalar @dirs; $i++) {
- if ($dirs[$i] eq 'lib' && $dirs[$i + 1] =~ /perl/) {
- $cut = $i + 2;
- last;
- } elsif ($dirs[$i] =~ /perl/) {
- $cut = $i + 1;
- $cut++ if $dirs[$i + 1] eq 'lib';
- last;
- }
- }
- if ($cut > 0) {
- splice (@dirs, 0, $cut);
- shift @dirs if ($dirs[0] =~ /^site(_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);
- }
- }
-
- # If $name contains spaces, quote it; this mostly comes up in the case of
- # input from stdin.
- $name = '"' . $name . '"' if ($name =~ /\s/);
-
- # Modification date header. Try to use the modification time of our
- # input.
- if (!defined $$self{date}) {
- my $time = (stat $self->input_file)[9] || time;
- my ($day, $month, $year) = (localtime $time)[3,4,5];
- $month++;
- $year += 1900;
- $$self{date} = sprintf ('%4d-%02d-%02d', $year, $month, $day);
- }
-
- # Now, 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.
- local $_ = $PREAMBLE;
- s/\@CFONT\@/$$self{fixed}/;
- s/\@LQUOTE\@/$$self{LQUOTE}/;
- s/\@RQUOTE\@/$$self{RQUOTE}/;
- chomp $_;
- my $pversion = $Pod::Parser::VERSION;
- print { $self->output_handle } <<"----END OF HEADER----";
-.\\" Automatically generated by Pod::Man v$VERSION, Pod::Parser v$pversion
-.\\"
-.\\" Standard preamble:
-.\\" ========================================================================
-$_
-.\\" ========================================================================
-.\\"
-.IX Title "$name $section"
-.TH $name $section "$$self{date}" "$$self{release}" "$$self{center}"
-----END OF HEADER----
-
- # Initialize a few per-file 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.
-}
-
-
-##############################################################################
-# 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 ($self->can ('cmd_' . $command)) {
- $command = 'cmd_' . $command;
- $self->$command (@_);
- } else {
- my ($text, $line, $paragraph) = @_;
- my $file;
- ($file, $line) = $paragraph->file_line;
- $text =~ s/\n+\z//;
- $text = " $text" if ($text =~ /^\S/);
- warn qq($file:$line: Unknown command paragraph "=$command$text"\n);
- return;
- }
-}
-
-# Called for a verbatim paragraph. Gets the paragraph, the line number, and a
-# Pod::Paragraph object. Rofficate backslashes, untabify, put a zero-width
-# character at the beginning of each line to protect against commands, and
-# wrap in .Vb/.Ve.
-sub verbatim {
- my $self = shift;
- return if $$self{EXCLUDE};
- local $_ = shift;
- return if /^\s+$/;
- s/\s+$/\n/;
- my $lines = tr/\n/\n/;
- 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;
- s/\\/\\e/g;
- s/-/\\-/g;
- s/'/\\(aq/g;
- s/^(\s*\S)/'\&' . $1/gme;
- $self->makespace;
- $self->output (".Vb $lines\n$_.Ve\n");
- $$self{NEEDSPACE} = 1;
-}
-
-# 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};
- $self->output ($_[0]), return if $$self{VERBATIM};
-
- # Parse the tree. collapse knows about references to scalars as well as
- # scalars and does the right thing with them. Tidy up any trailing
- # whitespace.
- my $text = shift;
- $text = $self->parse ($text, @_);
- $text =~ s/\n\s*$/\n/;
-
- # 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;
- }
- $self->output (protect $self->textmapfonts ($text));
- $self->outindex;
- $$self{NEEDSPACE} = 1;
-}
-
-# Called for a formatting code. Takes a Pod::InteriorSequence object and
-# returns a reference to a scalar. This scalar is the final formatted text.
-# It's returned as a reference to an array so that other formatting codes
-# above us know that the text has already been processed.
-sub sequence {
- my ($self, $seq) = @_;
- my $command = $seq->cmd_name;
-
- # We have to defer processing of the inside of an L<> formatting code. If
- # this code is nested inside an L<> code, return the literal raw text of
- # it.
- my $parent = $seq->nested;
- while (defined $parent) {
- return $seq->raw_text if ($parent->cmd_name eq 'L');
- $parent = $parent->nested;
- }
-
- # Zero-width characters.
- return [ '\&' ] if ($command eq 'Z');
-
- # C<>, L<>, X<>, and E<> don't apply guesswork to their contents. C<>
- # needs some additional special handling.
- my $literal = ($command =~ /^[CELX]$/);
- local $_ = $self->collapse ($seq->parse_tree, $literal, $command eq 'C');
-
- # Handle E<> escapes. Numeric escapes that match one of the supported ISO
- # 8859-1 characters don't work at present.
- if ($command eq 'E') {
- if (/^\d+$/) {
- return [ chr ($_) ];
- } elsif (exists $ESCAPES{$_}) {
- return [ $ESCAPES{$_} ];
- } else {
- my ($file, $line) = $seq->file_line;
- warn "$file:$line: Unknown escape E<$_>\n";
- return [ "E<$_>" ];
- }
- }
-
- # For all the other codes, empty content produces no output.
- return '' if $_ eq '';
-
- # Handle simple formatting codes.
- if ($command eq 'B') {
- return [ '\f(BS' . $_ . '\f(BE' ];
- } elsif ($command eq 'F' || $command eq 'I') {
- return [ '\f(IS' . $_ . '\f(IE' ];
- } elsif ($command eq 'C') {
- return [ $self->quote_literal ($_) ];
- }
-
- # Handle links.
- if ($command eq 'L') {
- my ($text, $type) = (parselink ($_))[1,4];
- return '' unless $text;
- my ($file, $line) = $seq->file_line;
- $text = $self->parse ($text, $line);
- $text = '<' . $text . '>' if $type eq 'url';
- return [ $text ];
- }
-
- # Whitespace protection replaces whitespace with "\ ".
- if ($command eq 'S') {
- s/\s+/\\ /g;
- return [ $_ ];
- }
-
- # Add an index entry to the list of ones waiting to be output.
- if ($command eq 'X') {
- push (@{ $$self{INDEX} }, $_);
- return '';
- }
-
- # Anything else is unknown.
- my ($file, $line) = $seq->file_line;
- warn "$file:$line: Unknown formatting code $command<$_>\n";
-}
-
-
-##############################################################################
-# Command paragraphs
-##############################################################################
-
-# All command paragraphs take the paragraph and the line number.
-
-# 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 \s1 and \s-1. Maintain IN_NAME as
-# appropriate, but don't leave it set while calling parse() so as to not
-# override guesswork on section headings after NAME.
-sub cmd_head1 {
- my $self = shift;
- $$self{IN_NAME} = 0;
- local $_ = $self->parse (@_);
- s/\s+$//;
- s/\\s-?\d//g;
- s/\s*\n\s*/ /g;
- if ($$self{ITEMS} > 1) {
- $$self{ITEMS} = 0;
- $self->output (".PD\n");
- }
- $self->output ($self->switchquotes ('.SH', $self->mapfonts ($_)));
- $self->outindex (($_ eq 'NAME') ? () : ('Header', $_));
- $$self{NEEDSPACE} = 0;
- $$self{IN_NAME} = ($_ eq 'NAME');
-}
-
-# Second level heading.
-sub cmd_head2 {
- my $self = shift;
- local $_ = $self->parse (@_);
- s/\s+$//;
- s/\s*\n\s*/ /g;
- if ($$self{ITEMS} > 1) {
- $$self{ITEMS} = 0;
- $self->output (".PD\n");
- }
- $self->output ($self->switchquotes ('.Sh', $self->mapfonts ($_)));
- $self->outindex ('Subsection', $_);
- $$self{NEEDSPACE} = 0;
-}
-
-# Third level heading.
-sub cmd_head3 {
- my $self = shift;
- local $_ = $self->parse (@_);
- s/\s+$//;
- s/\s*\n\s*/ /g;
- if ($$self{ITEMS} > 1) {
- $$self{ITEMS} = 0;
- $self->output (".PD\n");
- }
- $self->makespace;
- $self->output ($self->textmapfonts ('\f(IS' . $_ . '\f(IE') . "\n");
- $self->outindex ('Subsection', $_);
- $$self{NEEDSPACE} = 1;
-}
-
-# Fourth level heading.
-sub cmd_head4 {
- my $self = shift;
- local $_ = $self->parse (@_);
- s/\s+$//;
- s/\s*\n\s*/ /g;
- if ($$self{ITEMS} > 1) {
- $$self{ITEMS} = 0;
- $self->output (".PD\n");
- }
- $self->makespace;
- $self->output ($self->textmapfonts ($_) . "\n");
- $self->outindex ('Subsection', $_);
- $$self{NEEDSPACE} = 1;
-}
-
-# Start a list. For indents after the first, wrap the outside indent in .RS
-# so that hanging paragraph tags will be correct.
-sub cmd_over {
- my $self = shift;
- local $_ = shift;
- unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }
- if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) {
- $self->output (".RS $$self{INDENT}\n");
- push (@{ $$self{SHIFTS} }, $$self{INDENT});
- }
- push (@{ $$self{INDENTS} }, $$self{INDENT});
- push (@{ $$self{ITEMTYPES} }, 'unknown');
- $$self{INDENT} = ($_ + 0);
- $$self{SHIFTWAIT} = 1;
-}
-
-# End a list. If we've closed an embedded indent, we've mangled the hanging
-# paragraph indent, so temporarily replace it with .RS and set WEIRDINDENT.
-# We'll close that .RS at the next =back or =item.
-sub cmd_back {
- my $self = shift;
- $$self{INDENT} = pop @{ $$self{INDENTS} };
- if (defined $$self{INDENT}) {
- pop @{ $$self{ITEMTYPES} };
- } else {
- my ($file, $line, $paragraph) = @_;
- ($file, $line) = $paragraph->file_line;
- warn "$file:$line: Unmatched =back\n";
- $$self{INDENT} = 0;
- }
- if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) {
- $self->output (".RE\n");
- pop @{ $$self{SHIFTS} };
- }
- if (@{ $$self{INDENTS} } > 0) {
- $self->output (".RE\n");
- $self->output (".RS $$self{INDENT}\n");
- }
- $$self{NEEDSPACE} = 1;
- $$self{SHIFTWAIT} = 0;
-}
-
-# An individual list item. Emit an index entry for anything that's
-# interesting, but don't emit index entries for things like bullets and
-# numbers. rofficate bullets too while we're at it (so for nice output, use *
-# for your lists rather than o or . or - or some other thing). Newlines in an
-# item title are turned into spaces since *roff can't handle them embedded.
-sub cmd_item {
- my $self = shift;
- local $_ = $self->parse (@_);
- s/\s+$//;
- s/\s*\n\s*/ /g;
- my $index;
- if (/\w/ && !/^\w[.\)]\s*$/) {
- $index = $_;
- $index =~ s/^\s*[-*+o.]?(?:\s+|\Z)//;
- }
- $_ = '*' unless length ($_) > 0;
- my $type = $$self{ITEMTYPES}[0];
- unless (defined $type) {
- my ($file, $line, $paragraph) = @_;
- ($file, $line) = $paragraph->file_line;
- $type = 'unknown';
- }
- if ($type eq 'unknown') {
- $type = /^\*\s*\Z/ ? 'bullet' : 'text';
- $$self{ITEMTYPES}[0] = $type if $$self{ITEMTYPES}[0];
- }
- s/^\*\s*\Z/\\\(bu/ if $type eq 'bullet';
- if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) {
- $self->output (".RE\n");
- pop @{ $$self{SHIFTS} };
- }
- $_ = $self->textmapfonts ($_);
- $self->output (".PD 0\n") if ($$self{ITEMS} == 1);
- $self->output ($self->switchquotes ('.IP', $_, $$self{INDENT}));
- $self->outindex ($index ? ('Item', $index) : ());
- $$self{NEEDSPACE} = 0;
- $$self{ITEMS}++;
- $$self{SHIFTWAIT} = 0;
-}
-
-# 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 'man' || $kind eq 'roff') {
- $$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 man or roff, in which case we output it verbatim.
-sub cmd_for {
- my $self = shift;
- local $_ = shift;
- return unless s/^(?:man|roff)\b[ \t]*\n?//;
- $self->output ($_);
-}
-
-
-##############################################################################
-# Escaping and fontification
-##############################################################################
-
-# At this point, we'll have embedded font codes of the form \f(<font>[SE]
-# where <font> is one of B, I, or F. Turn those into the right font start or
-# end codes. The old pod2man didn't get B<someI<thing> else> right; after I<>
-# it switched back to normal text rather than bold. We take care of this by
-# using variables as a combined pointer to our current font sequence, and set
-# each to the number of current nestings of start tags for that font. Use
-# them as a vector to look up what font sequence to use.
-#
-# \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 = shift;
- local $_ = shift;
-
- my ($fixed, $bold, $italic) = (0, 0, 0);
- my %magic = (F => \$fixed, B => \$bold, I => \$italic);
- my $last = '\fR';
- 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;
- $_;
-}
-
-# 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 = shift;
- local $_ = shift;
-
- my ($fixed, $bold, $italic) = (0, 0, 0);
- my %magic = (F => \$fixed, B => \$bold, I => \$italic);
- s { \\f\((.)(.) } {
- ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
- $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)};
- }gxe;
- $_;
-}
-
-
-##############################################################################
-# *roff-specific parsing and magic
-##############################################################################
-
-# Called instead of parse_text, calls parse_text with the right flags.
-sub parse {
- my $self = shift;
- $self->parse_text ({ -expand_seq => 'sequence',
- -expand_ptree => 'collapse' }, @_);
-}
-
-# Takes a parse tree, a flag saying whether or not to treat it as literal text
-# (not call guesswork on it), and a flag saying whether or not to clean some
-# things up for *roff, and returns the concatenation of all of the text
-# strings in that parse tree. If the literal flag isn't true, guesswork()
-# will be called on all plain scalars in the parse tree. Otherwise, if
-# collapse is being called on a C<> code, $cleanup should be set to true and
-# some additional cleanup will be done. Assumes that everything in the parse
-# tree is either a scalar or a reference to a scalar.
-sub collapse {
- my ($self, $ptree, $literal, $cleanup) = @_;
-
- # If we're processing the NAME section, don't do normal guesswork. This
- # is because NAME lines are often extracted by utilities like catman that
- # require plain text and don't understand *roff markup. We still need to
- # escape backslashes and hyphens for *roff (and catman expects \- instead
- # of -).
- if ($$self{IN_NAME}) {
- $literal = 1;
- $cleanup = 1;
- }
-
- # Do the collapse of the parse tree as described above.
- return join ('', map {
- if (ref $_) {
- join ('', @$_);
- } elsif ($literal) {
- if ($cleanup) {
- s/\\/\\e/g;
- s/-/\\-/g;
- s/__/_\\|_/g;
- }
- $_;
- } else {
- $self->guesswork ($_);
- }
- } $ptree->children);
-}
-
-# Takes a text block to perform guesswork on; this is guaranteed not to
-# contain any formatting codes. Returns the text block with remapping done.
-sub guesswork {
- my $self = shift;
- local $_ = shift;
-
- # rofficate backslashes.
- s/\\/\\e/g;
-
- # Ensure double underbars have a tiny space between them.
- s/__/_\\|_/g;
-
- # Leave hyphens only if they're part of regular words and there is only
- # one dash at a time. Leave a dash after the first character as a regular
- # non-breaking dash, but don't let it mark the rest of the word invalid
- # for hyphenation.
- s/-/\\-/g;
- 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.
- s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx;
- s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx;
-
- # Make all caps a little smaller. Be careful here, since we don't want to
- # make @ARGV into small caps, nor do we want to fix the MIME in
- # MIME-Version, since it looks weird with the full-height V.
- s{
- ( ^ | [\s\(\"\'\`\[\{<>] )
- ( [A-Z] [A-Z] (?: [/A-Z+:\d_\$&] | \\- )* )
- (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | $ )
- } { $1 . '\s-1' . $2 . '\s0' }egx;
-
- # Italize functions in the form func().
- s{
- ( \b | \\s-1 )
- (
- [A-Za-z_] ([:\w]|\\s-?[01])+ \(\)
- )
- } { $1 . '\f(IS' . $2 . '\f(IE' }egx;
-
- # func(n) is a reference to a manual page. Make it \fIfunc\fR\|(n).
- 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.
- s{
- ( \s+ )
- ( [\$\@%] [\w:]+ )
- (?! \( )
- } { $1 . '\f(FS' . $2 . '\f(FE'}egx;
-
- # Fix up double quotes.
- s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx;
-
- # Make C++ into \*(C+, which is a squinched version.
- s{ \b C\+\+ } {\\*\(C+}gx;
-
- # All done.
- $_;
-}
-
-# Handles C<> text, deciding whether to put \*C` around it or not. This is a
-# whole bunch of messy heuristics to try to avoid overquoting, originally from
-# Barrie Slaymaker. This largely duplicates similar code in Pod::Text.
-sub quote_literal {
- my $self = shift;
- local $_ = shift;
-
- # A regex that matches the portion of a variable reference that's the
- # array or hash index, separated out just because we want to use it in
- # several places in the following regex.
- my $index = '(?: \[.*\] | \{.*\} )?';
-
- # Check for things that we don't want to quote, and if we find any of
- # them, return the string with just a font change and no quoting.
- m{
- ^\s*
- (?:
- ( [\'\`\"] ) .* \1 # already quoted
- | \` .* \' # `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 '\f(FS' . $_ . '\f(FE';
-
- # If we didn't return, go ahead and quote the text.
- return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE";
-}
-
-
-##############################################################################
-# Output formatting
-##############################################################################
-
-# Make vertical whitespace.
-sub makespace {
- my $self = shift;
- $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);
- $$self{INDEX} = [];
- my @output;
- if (@entries) {
- push (@output, [ 'Xref', join (' ', @entries) ]);
- }
- if ($section) {
- $index =~ s/\\-/-/g;
- $index =~ s/\\(?:s-?\d|.\(..|.)//g;
- push (@output, [ $section, $index ]);
- }
- for (@output) {
- my ($type, $entry) = @$_;
- $entry =~ s/\"/\"\"/g;
- $entry =~ s/\\/\\e/g;
- $self->output (".IX $type " . '"' . $entry . '"' . "\n");
- }
-}
-
-# Output text to the output device.
-sub output { print { $_[0]->output_handle } $_[1] }
-
-# 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 = shift;
- my $command = shift;
- local $_ = shift;
- my $extra = shift;
- 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 (/\"/ || /$fixedpat/) {
- s/\"/\"\"/g;
- my $nroff = $_;
- my $troff = $_;
- $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
- if ($c_is_quote && /\\\*\(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. Only bother with .ie if the nroff
- # and troff output isn't the same.
- if ($nroff ne $troff) {
- return ".ie n $command $nroff\n.el $command $troff\n";
- } else {
- return "$command $nroff\n";
- }
- } else {
- $_ = qq("$_") . ($extra ? " $extra" : '');
- return "$command $_\n";
- }
-}
-
-##############################################################################
-# Module return value and documentation
-##############################################################################
-
-1;
-__END__
-
-=head1 NAME
-
-Pod::Man - Convert POD data to formatted *roff input
-
-=head1 SYNOPSIS
-
- use Pod::Man;
- my $parser = Pod::Man->new (release => $VERSION, section => 8);
-
- # Read POD from STDIN and write to STDOUT.
- $parser->parse_from_filehandle;
-
- # 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::Parser, Pod::Man supports the same methods and
-interfaces. See L<Pod::Parser> for all the details; briefly, one creates a
-new parser with C<< Pod::Man->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. 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
-STDIN for input).
-
-Pod::Man assumes that your *roff formatters have a fixed-width font named
-CW. If yours is called something else (like 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 underbars, 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 STDIN), and the date will be formatted as
-YYYY-MM-DD.
-
-=item fixed
-
-The fixed-width font to use for vertabim text and code. Defaults to CW.
-Some systems may want CR instead. Only matters for B<troff> output.
-
-=item fixedbold
-
-Bold version of the fixed-width font. Defaults to 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 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 CB. Some systems
-(such as Solaris) have this font available as 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 .pm in which case
-section 3 will be selected.
-
-=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 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 link %s
-
-(W) The POD source contained a C<LE<lt>E<gt>> formatting code that
-Pod::Man was unable to parse. You should never see this error message; it
-probably indicates a bug in Pod::Man.
-
-=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.
-
-=item %s:%d: Unknown command paragraph "%s".
-
-(W) The POD source contained a non-standard command paragraph (something of
-the form C<=command args>) that Pod::Man didn't know about. It was ignored.
-
-=item %s:%d: Unknown escape EE<lt>%sE<gt>
-
-(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::Man didn't
-know about. C<EE<lt>%sE<gt>> was printed verbatim in the output.
-
-=item %s:%d: Unknown formatting code %s
-
-(W) The POD source contained a non-standard formatting code (something of
-the form C<XE<lt>E<gt>>) that Pod::Man didn't know about. It was ignored.
-
-=item %s:%d: Unmatched =back
-
-(W) Pod::Man encountered a C<=back> command that didn't correspond to an
-C<=over> command.
-
-=back
-
-=head1 BUGS
-
-Eight-bit input data isn't handled at all well at present. The correct
-approach would be to map EE<lt>E<gt> escapes to the appropriate UTF-8
-characters and then do a translation pass on the output according to the
-user-specified output character set. Unfortunately, we can't send eight-bit
-data directly to the output unless the user says this is okay, since some
-vendor *roff implementations can't handle eight-bit data. If the *roff
-implementation can, however, that's far superior to the current hacked
-characters that only work under troff.
-
-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).
-
-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.
-
-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 EE<lt>E<gt> escapes for 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
-
-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.
-
-=head1 SEE ALSO
-
-L<Pod::Parser>, 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.
-
-=head1 AUTHOR
-
-Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
-B<pod2man> by Tom Christiansen <tchrist@mox.perl.com>.
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 1999, 2000, 2001, 2002, 2003 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/installer/perllib/Pod/ParseLink.pm b/Master/tlpkg/installer/perllib/Pod/ParseLink.pm
deleted file mode 100644
index 7e4153da3d0..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/ParseLink.pm
+++ /dev/null
@@ -1,184 +0,0 @@
-# Pod::ParseLink -- Parse an L<> formatting code in POD text.
-# $Id: ParseLink.pm,v 1.6 2002/07/15 05:46:00 eagle Exp $
-#
-# Copyright 2001 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);
-
-# Don't use the CVS revision as the version, since this module is also in Perl
-# core and too many things could munge CVS magic revision strings. This
-# number should ideally be the same as the CVS revision in podlators, however.
-$VERSION = 1.06;
-
-
-##############################################################################
-# Implementation
-##############################################################################
-
-# Parse the name and section portion of a link into a name and section.
-sub _parse_section {
- my ($link) = @_;
- $link =~ s/^\s+//;
- $link =~ s/\s+$//;
-
- # If the whole link is enclosed in quotes, interpret it all as a section
- # even if it contains a slash.
- return (undef, $1) if ($link =~ /^"\s*(.*?)\s*"$/);
-
- # Split into page and section on slash, and then clean up quoting in the
- # section. If there is no section and the name contains spaces, also
- # guess that it's an old section link.
- my ($page, $section) = split (/\s*\/\s*/, $link, 2);
- $section =~ s/^"\s*(.*?)\s*"$/$1/ if $section;
- if ($page && $page =~ / / && !defined ($section)) {
- $section = $page;
- $page = undef;
- } else {
- $page = undef unless $page;
- $section = undef unless $section;
- }
- return ($page, $section);
-}
-
-# Infer link text from the page and section.
-sub _infer_text {
- my ($page, $section) = @_;
- my $inferred;
- if ($page && !$section) {
- $inferred = $page;
- } elsif (!$page && $section) {
- $inferred = '"' . $section . '"';
- } elsif ($page && $section) {
- $inferred = '"' . $section . '" in ' . $page;
- }
- return $inferred;
-}
-
-# Given the contents of an L<> formatting code, parse it into the link text,
-# the possibly inferred link text, the name or URL, the section, and the type
-# of link (pod, man, or url).
-sub parselink {
- my ($link) = @_;
- $link =~ s/\s+/ /g;
- if ($link =~ /\A\w+:[^:\s]\S*\Z/) {
- return (undef, $link, $link, undef, 'url');
- } else {
- my $text;
- if ($link =~ /\|/) {
- ($text, $link) = split (/\|/, $link, 2);
- }
- my ($name, $section) = _parse_section ($link);
- my $inferred = $text || _infer_text ($name, $section);
- my $type = ($name && $name =~ /\(\S*\)/) ? 'man' : 'pod';
- return ($text, $inferred, $name, $section, $type);
- }
-}
-
-
-##############################################################################
-# Module return value and documentation
-##############################################################################
-
-# Ensure we evaluate to true.
-1;
-__END__
-
-=head1 NAME
-
-Pod::ParseLink - Parse an LE<lt>E<gt> formatting code in POD text
-
-=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 'url', 'pod', or '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 backwards 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 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/installer/perllib/Pod/ParseUtils.pm b/Master/tlpkg/installer/perllib/Pod/ParseUtils.pm
deleted file mode 100644
index 878860121d3..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/ParseUtils.pm
+++ /dev/null
@@ -1,852 +0,0 @@
-#############################################################################
-# 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 vars qw($VERSION);
-$VERSION = 1.33; ## 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 undef 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 undef;
- }
-
- ## 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(m!^($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(m!^(.*?)\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
- elsif(m!^(\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);
- }
- # nonstandard: alttext and hyperlink
- elsif(m!^(.*?)\s*[|]\s*(\w+:[^:\s]\S*)$!) {
- ($alttext, $node) = ($1,$2);
- $type = 'hyperlink';
- }
- # 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 {
- $_[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();
- }
- $_[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();
- }
- $_[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();
- }
- $_[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();
- $text =~ s/\|/E<verbar>/g;
- $text =~ 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";
- }
- $link;
-}
-
-sub _invalid_link {
- my ($msg) = @_;
- # this sets @_
- #eval { die "$msg\n" };
- #chomp $@;
- $@ = $msg; # this seems to work, too!
- undef;
-}
-
-#-----------------------------------------------------------------------------
-# 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 $_;
- }
- }
- undef;
-}
-
-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 arry) 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
- }
- }
- undef;
-}
-
-=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/installer/perllib/Pod/Parser.pm b/Master/tlpkg/installer/perllib/Pod/Parser.pm
deleted file mode 100644
index a5fde848503..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Parser.pm
+++ /dev/null
@@ -1,1799 +0,0 @@
-#############################################################################
-# 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 vars qw($VERSION);
-$VERSION = 1.32; ## 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 preprocesssing 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 intepret 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 vars qw(@ISA);
-use strict;
-#use diagnostics;
-use Pod::InputObjects;
-use Carp;
-use Exporter;
-BEGIN {
- if ($] < 5.6) {
- require Symbol;
- import Symbol;
- }
-}
-@ISA = qw(Exporter);
-
-## These "variables" are used as local "glob aliases" for performance
-use vars qw(%myData %myOpts @input_stack);
-
-#############################################################################
-
-=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 = shift;
- my $class = ref($this) || $this;
- ## Any remaining arguments are treated as initial values for the
- ## hash that is used to represent this object.
- my %params = @_;
- 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 curresponding 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 ($self, $iseq) = @_;
- my $args = join("", $iseq->parse_tree->children);
- return $self->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 += tr/\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 warn($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 (length $cmd) {
- ## A command paragraph
- $self->command($cmd, $text, $line_num, $pod_para);
- }
- elsif ($text =~ /^\s+/) {
- ## Indented text - must be a verbatim paragraph
- $self->verbatim($text, $line_num, $pod_para);
- }
- else {
- ## Looks like an ordinary block of text
- $self->textblock($text, $line_num, $pod_para);
- }
- 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));
-
- ## Issue a warning about any non-empty blank lines
- if (length($1) > 0 and $myOpts{'-warnings'} and ! $myData{_CUTTING}) {
- my $errorsub = $self->errorsub();
- my $file = $self->input_file();
- my $errmsg = "*** WARNING: line containing nothing but whitespace".
- " in paragraph at line $nlines in file $file\n";
- (ref $errorsub) and &{$errorsub}($errmsg)
- or (defined $errorsub) and $self->$errorsub($errmsg)
- or warn($errmsg);
- }
-
- ## 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.
-
-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, an L<IO::String> object is also accepted as an output
-file handle.
-
-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) = (gensym(), gensym()) if ($] < 5.006);
- 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<warn>
-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 warn($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<warn> 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 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>
-
-=cut
-
-1;
-# vim: ts=4 sw=4 et
diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc.pm
deleted file mode 100644
index 8f9614838fb..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc.pm
+++ /dev/null
@@ -1,1762 +0,0 @@
-
-require 5;
-use 5.006; # we use some open(X, "<", $y) syntax
-package Pod::Perldoc;
-use strict;
-use warnings;
-use Config '%Config';
-
-use Fcntl; # for sysopen
-use File::Spec::Functions qw(catfile catdir splitdir);
-
-use vars qw($VERSION @Pagers $Bindir $Pod2man
- $Temp_Files_Created $Temp_File_Lifetime
-);
-$VERSION = '3.14';
-#..........................................................................
-
-BEGIN { # Make a DEBUG constant very first thing...
- unless(defined &DEBUG) {
- if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
- eval("sub DEBUG () {$1}");
- die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
- } else {
- *DEBUG = sub () {0};
- }
- }
-}
-
-use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
-
-#..........................................................................
-
-sub TRUE () {1}
-sub FALSE () {return}
-
-BEGIN {
- *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS;
- *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
- *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
- *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
- *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
- *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux;
- *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX;
-}
-
-$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
- # If it's older than five days, it's quite unlikely
- # that anyone's still looking at it!!
- # (Currently used only by the MSWin cleanup routine)
-
-
-#..........................................................................
-{ my $pager = $Config{'pager'};
- push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
-}
-$Bindir = $Config{'scriptdirexp'};
-$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
-
-# End of class-init stuff
-#
-###########################################################################
-#
-# Option accessors...
-
-foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdU}) {
- 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_w_with { # Specify an option for the formatter subclass
- my($self, $value) = @_;
- if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
- my $option = $1;
- my $option_value = defined($2) ? $2 : "TRUE";
- $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
- $self->add_formatter_option( $option, $option_value );
- } else {
- warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
- }
- return;
-}
-
-sub opt_M_with { # specify formatter class name(s)
- my($self, $classes) = @_;
- return unless defined $classes and length $classes;
- DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
- my @classes_to_add;
- foreach my $classname (split m/[,;]+/s, $classes) {
- next unless $classname =~ m/\S/;
- if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
- # A mildly restrictive concept of what modulenames are valid.
- push @classes_to_add, $1; # untaint
- } else {
- warn "\"$classname\" isn't a valid classname. Ignoring.\n";
- }
- }
-
- unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
-
- DEBUG > 3 and print(
- "Adding @classes_to_add to the list of formatter classes, "
- . "making them @{ $self->{'formatter_classes'} }.\n"
- );
-
- return;
-}
-
-sub opt_V { # report version and exit
- print join '',
- "Perldoc v$VERSION, under perl v$] for $^O",
-
- (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
- ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
-
- (chr(65) eq 'A') ? () : " (non-ASCII)",
-
- "\n",
- ;
- exit;
-}
-
-sub opt_t { # choose plaintext as output format
- my $self = shift;
- $self->opt_o_with('text') if @_ and $_[0];
- return $self->_elem('opt_t', @_);
-}
-
-sub opt_u { # choose raw pod as output format
- my $self = shift;
- $self->opt_o_with('pod') if @_ and $_[0];
- return $self->_elem('opt_u', @_);
-}
-
-sub opt_n_with {
- # choose man as the output format, and specify the proggy to run
- my $self = shift;
- $self->opt_o_with('man') if @_ and $_[0];
- $self->_elem('opt_n', @_);
-}
-
-sub opt_o_with { # "o" for output format
- my($self, $rest) = @_;
- return unless defined $rest and length $rest;
- if($rest =~ m/^(\w+)$/s) {
- $rest = $1; #untaint
- } else {
- warn "\"$rest\" isn't a valid output format. Skipping.\n";
- return;
- }
-
- $self->aside("Noting \"$rest\" as desired output format...\n");
-
- # Figure out what class(es) that could actually mean...
-
- my @classes;
- foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
- # Messy but smart:
- foreach my $stem (
- $rest, # Yes, try it first with the given capitalization
- "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
-
- ) {
- push @classes, $prefix . $stem;
- #print "Considering $prefix$stem\n";
- }
-
- # Tidier, but misses too much:
- #push @classes, $prefix . ucfirst(lc($rest));
- }
- $self->opt_M_with( join ";", @classes );
- return;
-}
-
-###########################################################################
-# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
-
-sub run { # to be called by the "perldoc" executable
- my $class = shift;
- if(DEBUG > 3) {
- print "Parameters to $class\->run:\n";
- my @x = @_;
- while(@x) {
- $x[1] = '<undef>' unless defined $x[1];
- $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
- print " [$x[0]] => [$x[1]]\n";
- splice @x,0,2;
- }
- print "\n";
- }
- return $class -> new(@_) -> process() || 0;
-}
-
-# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
-###########################################################################
-
-sub new { # yeah, nothing fancy
- my $class = shift;
- my $new = bless {@_}, (ref($class) || $class);
- DEBUG > 1 and print "New $class object $new\n";
- $new->init();
- $new;
-}
-
-#..........................................................................
-
-sub aside { # If we're in -v or DEBUG mode, say this.
- my $self = shift;
- if( DEBUG or $self->opt_v ) {
- my $out = join( '',
- DEBUG ? do {
- my $callsub = (caller(1))[3];
- my $package = quotemeta(__PACKAGE__ . '::');
- $callsub =~ s/^$package/'/os;
- # the o is justified, as $package really won't change.
- $callsub . ": ";
- } : '',
- @_,
- );
- if(DEBUG) { print $out } else { print STDERR $out }
- }
- return;
-}
-
-#..........................................................................
-
-sub usage {
- my $self = shift;
- warn "@_\n" if @_;
-
- # Erase evidence of previous errors (if any), so exit status is simple.
- $! = 0;
-
- die <<EOF;
-perldoc [options] PageName|ModuleName|ProgramName...
-perldoc [options] -f BuiltinFunction
-perldoc [options] -q FAQRegex
-
-Options:
- -h Display this help message
- -V report version
- -r Recursive search (slow)
- -i Ignore case
- -t Display pod using pod2text instead of pod2man and nroff
- (-t is the default on win32 unless -n is specified)
- -u Display unformatted pod text
- -m Display module's file in its entirety
- -n Specify replacement for nroff
- -l Display the module's file name
- -F Arguments are file names, not modules
- -v Verbosely describe what's going on
- -T Send output to STDOUT without any pager
- -d output_filename_to_send_to
- -o output_format_name
- -M FormatterModuleNameToUse
- -w formatter_option:option_value
- -X use index if present (looks for pod.idx at $Config{archlib})
- -q Search the text of questions (not answers) in perlfaq[1-9]
-
-PageName|ModuleName...
- is the name of a piece of documentation that you want to look at. You
- may either give a descriptive name of the page (as in the case of
- `perlfunc') the name of a module, either like `Term::Info' or like
- `Term/Info', or the name of a program, like `perldoc'.
-
-BuiltinFunction
- is the name of a perl function. Will extract documentation from
- `perlfunc'.
-
-FAQRegex
- is a regex. Will search perlfaq[1-9] for and extract any
- questions that match.
-
-Any switches in the PERLDOC environment variable will be used before the
-command line arguments. The optional pod index file contains a list of
-filenames, one per line.
- [Perldoc v$VERSION]
-EOF
-
-}
-
-#..........................................................................
-
-sub usage_brief {
- my $me = $0; # Editing $0 is unportable
-
- $me =~ s,.*[/\\],,; # get basename
-
- die <<"EOUSAGE";
-Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-F] [-X] PageName|ModuleName|ProgramName
- $me -f PerlFunc
- $me -q FAQKeywords
-
-The -h option prints more help. Also try "perldoc perldoc" to get
-acquainted with the system. [Perldoc v$VERSION]
-EOUSAGE
-
-}
-
-#..........................................................................
-
-sub pagers { @{ shift->{'pagers'} } }
-
-#..........................................................................
-
-sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
- if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
- else { return $_[0]{ $_[1] } }
-}
-#..........................................................................
-###########################################################################
-#
-# Init formatter switches, and start it off with __bindir and all that
-# other stuff that ToMan.pm needs.
-#
-
-sub init {
- my $self = shift;
-
- # Make sure creat()s are neither too much nor too little
- eval { umask(0077) }; # doubtless someone has no mask
-
- $self->{'args'} ||= \@ARGV;
- $self->{'found'} ||= [];
- $self->{'temp_file_list'} ||= [];
-
-
- $self->{'target'} = undef;
-
- $self->init_formatter_class_list;
-
- $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
- $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
- $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
-
- push @{ $self->{'formatter_switches'} = [] }, (
- # Yeah, we could use a hashref, but maybe there's some class where options
- # have to be ordered; so we'll use an arrayref.
-
- [ '__bindir' => $self->{'bindir' } ],
- [ '__pod2man' => $self->{'pod2man'} ],
- );
-
- DEBUG > 3 and printf "Formatter switches now: [%s]\n",
- join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
-
- return;
-}
-
-#..........................................................................
-
-sub init_formatter_class_list {
- my $self = shift;
- $self->{'formatter_classes'} ||= [];
-
- # Remember, no switches have been read yet, when
- # we've started this routine.
-
- $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
- $self->opt_o_with('text');
- $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
- || !($ENV{TERM} && (
- ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
- ));
-
- return;
-}
-
-#..........................................................................
-
-sub process {
- # if this ever returns, its retval will be used for exit(RETVAL)
-
- my $self = shift;
- DEBUG > 1 and print " Beginning process.\n";
- DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
- if(DEBUG > 3) {
- print "Object contents:\n";
- my @x = %$self;
- while(@x) {
- $x[1] = '<undef>' unless defined $x[1];
- $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
- print " [$x[0]] => [$x[1]]\n";
- splice @x,0,2;
- }
- print "\n";
- }
-
- # TODO: make it deal with being invoked as various different things
- # such as perlfaq".
-
- return $self->usage_brief unless @{ $self->{'args'} };
- $self->pagers_guessing;
- $self->options_reading;
- $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
- $self->drop_privs_maybe;
- $self->options_processing;
-
- # Hm, we have @pages and @found, but we only really act on one
- # file per call, with the exception of the opt_q hack, and with
- # -l things
-
- $self->aside("\n");
-
- my @pages;
- $self->{'pages'} = \@pages;
- if( $self->opt_f) { @pages = ("perlfunc") }
- elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
- else { @pages = @{$self->{'args'}};
- # @pages = __FILE__
- # if @pages == 1 and $pages[0] eq 'perldoc';
- }
-
- return $self->usage_brief unless @pages;
-
- $self->find_good_formatter_class();
- $self->formatter_sanity_check();
-
- $self->maybe_diddle_INC();
- # for when we're apparently in a module or extension directory
-
- my @found = $self->grand_search_init(\@pages);
- exit (IS_VMS ? 98962 : 1) unless @found;
-
- if ($self->opt_l) {
- DEBUG and print "We're in -l mode, so byebye after this:\n";
- print join("\n", @found), "\n";
- return;
- }
-
- $self->tweak_found_pathnames(\@found);
- $self->assert_closing_stdout;
- return $self->page_module_file(@found) if $self->opt_m;
- DEBUG > 2 and print "Found: [@found]\n";
-
- return $self->render_and_page(\@found);
-}
-
-#..........................................................................
-{
-
-my( %class_seen, %class_loaded );
-sub find_good_formatter_class {
- my $self = $_[0];
- my @class_list = @{ $self->{'formatter_classes'} || [] };
- die "WHAT? Nothing in the formatter class list!?" unless @class_list;
-
- my $good_class_found;
- foreach my $c (@class_list) {
- DEBUG > 4 and print "Trying to load $c...\n";
- if($class_loaded{$c}) {
- DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
- $good_class_found = $c;
- last;
- }
-
- if($class_seen{$c}) {
- DEBUG > 4 and print
- "I've tried $c before, and it's no good. Skipping.\n";
- next;
- }
-
- $class_seen{$c} = 1;
-
- if( $c->can('parse_from_file') ) {
- DEBUG > 4 and print
- "Interesting, the formatter class $c is already loaded!\n";
-
- } elsif(
- (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
- # the alway case-insensitive fs's
- and $class_seen{lc("~$c")}++
- ) {
- DEBUG > 4 and print
- "We already used something quite like \"\L$c\E\", so no point using $c\n";
- # This avoids redefining the package.
- } else {
- DEBUG > 4 and print "Trying to eval 'require $c'...\n";
-
- local $^W = $^W;
- if(DEBUG() or $self->opt_v) {
- # feh, let 'em see it
- } else {
- $^W = 0;
- # The average user just has no reason to be seeing
- # $^W-suppressable warnings from the the require!
- }
-
- eval "require $c";
- if($@) {
- DEBUG > 4 and print "Couldn't load $c: $!\n";
- next;
- }
- }
-
- if( $c->can('parse_from_file') ) {
- DEBUG > 4 and print "Settling on $c\n";
- my $v = $c->VERSION;
- $v = ( defined $v and length $v ) ? " version $v" : '';
- $self->aside("Formatter class $c$v successfully loaded!\n");
- $good_class_found = $c;
- last;
- } else {
- DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
- }
- }
-
- die "Can't find any loadable formatter class in @class_list?!\nAborting"
- unless $good_class_found;
-
- $self->{'formatter_class'} = $good_class_found;
- $self->aside("Will format with the class $good_class_found\n");
-
- return;
-}
-
-}
-#..........................................................................
-
-sub formatter_sanity_check {
- my $self = shift;
- my $formatter_class = $self->{'formatter_class'}
- || die "NO FORMATTER CLASS YET!?";
-
- if(!$self->opt_T # so -T can FORCE sending to STDOUT
- and $formatter_class->can('is_pageable')
- and !$formatter_class->is_pageable
- and !$formatter_class->can('page_for_perldoc')
- ) {
- my $ext =
- ($formatter_class->can('output_extension')
- && $formatter_class->output_extension
- ) || '';
- $ext = ".$ext" if length $ext;
-
- die
- "When using Perldoc to format with $formatter_class, you have to\n"
- . "specify -T or -dsomefile$ext\n"
- . "See `perldoc perldoc' for more information on those switches.\n"
- ;
- }
-}
-
-#..........................................................................
-
-sub render_and_page {
- my($self, $found_list) = @_;
-
- $self->maybe_generate_dynamic_pod($found_list);
-
- my($out, $formatter) = $self->render_findings($found_list);
-
- if($self->opt_d) {
- printf "Perldoc (%s) output saved to %s\n",
- $self->{'formatter_class'} || ref($self),
- $out;
- print "But notice that it's 0 bytes long!\n" unless -s $out;
-
-
- } elsif( # Allow the formatter to "page" itself, if it wants.
- $formatter->can('page_for_perldoc')
- and do {
- $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
- if( $formatter->page_for_perldoc($out, $self) ) {
- $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
- 1;
- } else {
- $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
- '';
- }
- }
- ) {
- # Do nothing, since the formatter has "paged" it for itself.
-
- } else {
- # Page it normally (internally)
-
- if( -s $out ) { # Usual case:
- $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
-
- } else {
- # Odd case:
- $self->aside("Skipping $out (from $$found_list[0] "
- . "via $$self{'formatter_class'}) as it is 0-length.\n");
-
- push @{ $self->{'temp_file_list'} }, $out;
- $self->unlink_if_temp_file($out);
- }
- }
-
- $self->after_rendering(); # any extra cleanup or whatever
-
- return;
-}
-
-#..........................................................................
-
-sub options_reading {
- my $self = shift;
-
- if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
- require Text::ParseWords;
- $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
- # Yes, appends to the beginning
- unshift @{ $self->{'args'} },
- Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
- ;
- DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
- } else {
- DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
- }
-
- DEBUG > 1
- and print " Args right before switch processing: @{$self->{'args'}}\n";
-
- Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
- or return $self->usage;
-
- DEBUG > 1
- and print " Args after switch processing: @{$self->{'args'}}\n";
-
- return $self->usage if $self->opt_h;
-
- return;
-}
-
-#..........................................................................
-
-sub options_processing {
- my $self = shift;
-
- if ($self->opt_X) {
- my $podidx = "$Config{'archlib'}/pod.idx";
- $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
- $self->{'podidx'} = $podidx;
- }
-
- $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
-
- $self->options_sanity;
-
- $self->opt_n("nroff") unless $self->opt_n;
- $self->add_formatter_option( '__nroffer' => $self->opt_n );
-
- 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?
-
- 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;
- }
-
- # We must look both in @INC for library modules and in $bindir
- # for executables, like h2xs or perldoc itself.
-
- my @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" );
- }
- 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_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
-
- if( ! $self->opt_f and ! $self->opt_q ) {
- DEBUG > 4 and print "That's a non-dynamic pod search.\n";
- } elsif ( @dynamic_pod ) {
- $self->aside("Hm, I found some Pod from that search!\n");
- my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
-
- push @{ $self->{'temp_file_list'} }, $buffer;
- # I.e., it MIGHT be deleted at the end.
-
- my $in_list = $self->opt_f;
-
- print $buffd "=over 8\n\n" if $in_list;
- print $buffd @dynamic_pod or die "Can't print $buffer: $!";
- print $buffd "=back\n" if $in_list;
-
- close $buffd or die "Can't close $buffer: $!";
-
- @$found_things = $buffer;
- # Yes, so found_things never has more than one thing in
- # it, by time we leave here
-
- $self->add_formatter_option('__filter_nroff' => 1);
-
- } else {
- @$found_things = ();
- $self->aside("I found no Pod from that search!\n");
- }
-
- return;
-}
-
-#..........................................................................
-
-sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
- my $self = shift;
- push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
-
- DEBUG > 3 and printf "Formatter switches now: [%s]\n",
- join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
-
- return;
-}
-
-#..........................................................................
-
-sub 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";
-
- # Skip introduction
- local $_;
- while (<PFUNC>) {
- last if /^=head2 Alphabetical Listing of Perl Functions/;
- }
-
- # 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 join '',
- "Perldoc is only really meant for reading one document at a time.\n",
- "So these parameters are being ignored: ",
- join(' ', @$found_things[1 .. $#$found_things] ),
- "\n"
- }
-
- my $file = $found_things->[0];
-
- DEBUG > 3 and printf "Formatter switches now: [%s]\n",
- join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
-
- # Set formatter options:
- if( ref $formatter ) {
- foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
- my($switch, $value, $silent_fail) = @$f;
- if( $formatter->can($switch) ) {
- eval { $formatter->$switch( defined($value) ? $value : () ) };
- warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
- if $@;
- } else {
- if( $silent_fail or $switch =~ m/^__/s ) {
- DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
- } else {
- warn "$formatter_class doesn't recognize the $switch switch.\n";
- }
- }
- }
- }
-
- $self->{'output_is_binary'} =
- $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
-
- my ($out_fh, $out) = $self->new_output_file(
- ( $formatter->can('output_extension') && $formatter->output_extension )
- || undef,
- $self->useful_filename_bit,
- );
-
- # Now, finally, do the formatting!
- {
- local $^W = $^W;
- if(DEBUG() or $self->opt_v) {
- # feh, let 'em see it
- } else {
- $^W = 0;
- # The average user just has no reason to be seeing
- # $^W-suppressable warnings from the formatting!
- }
-
- eval { $formatter->parse_from_file( $file, $out_fh ) };
- }
-
- warn "Error while formatting with $formatter_class:\n $@\n" if $@;
- DEBUG > 2 and print "Back from formatting with $formatter_class\n";
-
- close $out_fh
- or warn "Can't close $out: $!\n(Did $formatter already close it?)";
- sleep 0; sleep 0; sleep 0;
- # Give the system a few timeslices to meditate on the fact
- # that the output file does in fact exist and is closed.
-
- $self->unlink_if_temp_file($file);
-
- unless( -s $out ) {
- if( $formatter->can( 'if_zero_length' ) ) {
- # Basically this is just a hook for Pod::Simple::Checker; since
- # what other class could /happily/ format an input file with Pod
- # as a 0-length output file?
- $formatter->if_zero_length( $file, $out, $out_fh );
- } else {
- warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
- }
- }
-
- DEBUG and print "Finished writing to $out.\n";
- return($out, $formatter) if wantarray;
- return $out;
-}
-
-#..........................................................................
-
-sub unlink_if_temp_file {
- # Unlink the specified file IFF it's in the list of temp files.
- # Really only used in the case of -f / -q things when we can
- # throw away the dynamically generated source pod file once
- # we've formatted it.
- #
- my($self, $file) = @_;
- return unless defined $file and length $file;
-
- my $temp_file_list = $self->{'temp_file_list'} || return;
- if(grep $_ eq $file, @$temp_file_list) {
- $self->aside("Unlinking $file\n");
- unlink($file) or warn "Odd, couldn't unlink $file: $!";
- } else {
- DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
- }
- return;
-}
-
-#..........................................................................
-
-sub MSWin_temp_cleanup {
-
- # Nothing particularly MSWin-specific in here, but I don't know if any
- # other OS needs its temp dir policed like MSWin does!
-
- my $self = shift;
-
- my $tempdir = $ENV{'TEMP'};
- return unless defined $tempdir and length $tempdir
- and -e $tempdir and -d _ and -w _;
-
- $self->aside(
- "Considering whether any old files of mine in $tempdir need unlinking.\n"
- );
-
- opendir(TMPDIR, $tempdir) || return;
- my @to_unlink;
-
- my $limit = time() - $Temp_File_Lifetime;
-
- DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
- ($limit) x 2;
-
- my $filespec;
-
- while(defined($filespec = readdir(TMPDIR))) {
- if(
- $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
- ) {
- if( hex($1) < $limit ) {
- push @to_unlink, "$tempdir/$filespec";
- $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
- } else {
- DEBUG > 5 and
- printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
- }
- } else {
- DEBUG > 5 and
- print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
- }
- }
- closedir(TMPDIR);
- $self->aside(sprintf "Unlinked %s items of mine in %s\n",
- scalar(unlink(@to_unlink)),
- $tempdir
- );
- return;
-}
-
-# . . . . . . . . . . . . . . . . . . . . . . . . .
-
-sub MSWin_perldoc_tempfile {
- my($self, $suffix, $infix) = @_;
-
- my $tempdir = $ENV{'TEMP'};
- return unless defined $tempdir and length $tempdir
- and -e $tempdir and -d _ and -w _;
-
- my $spec;
-
- do {
- $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
- # Yes, we embed the create-time in the filename!
- $tempdir,
- $infix || 'x',
- time(),
- $$,
- defined( &Win32::GetTickCount )
- ? (Win32::GetTickCount() & 0xff)
- : int(rand 256)
- # Under MSWin, $$ values get reused quickly! So if we ran
- # perldoc foo and then perldoc bar before there was time for
- # time() to increment time."_$$" would likely be the same
- # for each process! So we tack on the tick count's lower
- # bits (or, in a pinch, rand)
- ,
- $suffix || 'txt';
- ;
- } while( -e $spec );
-
- my $counter = 0;
-
- while($counter < 50) {
- my $fh;
- # If we are running before perl5.6.0, we can't autovivify
- if ($] < 5.006) {
- require Symbol;
- $fh = Symbol::gensym();
- }
- DEBUG > 3 and print "About to try making temp file $spec\n";
- return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism
- $self->aside("Can't create temp file $spec: $!\n");
- }
-
- $self->aside("Giving up on making a temp file!\n");
- die "Can't make a tempfile!?";
-}
-
-#..........................................................................
-
-
-sub after_rendering {
- my $self = $_[0];
- $self->after_rendering_VMS if IS_VMS;
- $self->after_rendering_MSWin32 if IS_MSWin32;
- $self->after_rendering_Dos if IS_Dos;
- $self->after_rendering_OS2 if IS_OS2;
- return;
-}
-
-sub after_rendering_VMS { return }
-sub after_rendering_Dos { return }
-sub after_rendering_OS2 { return }
-
-sub after_rendering_MSWin32 {
- shift->MSWin_temp_cleanup() if $Temp_Files_Created;
-}
-
-#..........................................................................
-# : : : : : : : : :
-#..........................................................................
-
-
-sub minus_f_nocase { # i.e., do like -f, but without regard to case
-
- my($self, $dir, $file) = @_;
- my $path = catfile($dir,$file);
- return $path if -f $path and -r _;
-
- if(!$self->opt_i
- or IS_VMS or IS_MSWin32
- or IS_Dos or IS_OS2
- ) {
- # On a case-forgiving file system, or if case is important,
- # that is it, all we can do.
- warn "Ignored $path: unreadable\n" if -f _;
- return '';
- }
-
- local *DIR;
- my @p = ($dir);
- my($p,$cip);
- foreach $p (splitdir $file){
- my $try = catfile @p, $p;
- $self->aside("Scrutinizing $try...\n");
- stat $try;
- if (-d _) {
- push @p, $p;
- if ( $p eq $self->{'target'} ) {
- my $tmp_path = catfile @p;
- my $path_f = 0;
- for (@{ $self->{'found'} }) {
- $path_f = 1 if $_ eq $tmp_path;
- }
- push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
- $self->aside( "Found as $tmp_path but directory\n" );
- }
- }
- elsif (-f _ && -r _) {
- return $try;
- }
- elsif (-f _) {
- warn "Ignored $try: unreadable\n";
- }
- elsif (-d catdir(@p)) { # at least we see the containing directory!
- my $found = 0;
- my $lcp = lc $p;
- my $p_dirspec = catdir(@p);
- opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
- while(defined( $cip = readdir(DIR) )) {
- if (lc $cip eq $lcp){
- $found++;
- last; # XXX stop at the first? what if there's others?
- }
- }
- closedir DIR or die "closedir $p_dirspec: $!";
- return "" unless $found;
-
- push @p, $cip;
- my $p_filespec = catfile(@p);
- return $p_filespec if -f $p_filespec and -r _;
- warn "Ignored $p_filespec: unreadable\n" if -f _;
- }
- }
- return "";
-}
-
-#..........................................................................
-
-sub pagers_guessing {
- my $self = shift;
-
- my @pagers;
- push @pagers, $self->pagers;
- $self->{'pagers'} = \@pagers;
-
- if (IS_MSWin32) {
- push @pagers, qw( more< less notepad );
- unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
- }
- elsif (IS_VMS) {
- push @pagers, qw( most more less type/page );
- }
- elsif (IS_Dos) {
- push @pagers, qw( less.exe more.com< );
- unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
- }
- else {
- if (IS_OS2) {
- unshift @pagers, 'less', 'cmd /c more <';
- }
- push @pagers, qw( more less pg view cat );
- unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
- }
-
- if (IS_Cygwin) {
- if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
- unshift @pagers, '/usr/bin/less -isrR';
- }
- }
-
- unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
-
- return;
-}
-
-#..........................................................................
-
-sub page_module_file {
- my($self, @found) = @_;
-
- # Security note:
- # Don't ever just pass this off to anything like MSWin's "start.exe",
- # since we might be calling on a .pl file, and we wouldn't want that
- # to actually /execute/ the file that we just want to page thru!
- # Also a consideration if one were to use a web browser as a pager;
- # doing so could trigger the browser's MIME mapping for whatever
- # it thinks .pm/.pl/whatever is. Probably just a (useless and
- # annoying) "Save as..." dialog, but potentially executing the file
- # in question -- particularly in the case of MSIE and it's, ahem,
- # occasionally hazy distinction between OS-local extension
- # associations, and browser-specific MIME mappings.
-
- if ($self->{'output_to_stdout'}) {
- $self->aside("Sending unpaged output to STDOUT.\n");
- local $_;
- my $any_error = 0;
- foreach my $output (@found) {
- unless( open(TMP, "<", $output) ) { # XXX 5.6ism
- warn("Can't open $output: $!");
- $any_error = 1;
- next;
- }
- while (<TMP>) {
- print or die "Can't print to stdout: $!";
- }
- close TMP or die "Can't close while $output: $!";
- $self->unlink_if_temp_file($output);
- }
- return $any_error; # successful
- }
-
- foreach my $pager ( $self->pagers ) {
- $self->aside("About to try calling $pager @found\n");
- if (system($pager, @found) == 0) {
- $self->aside("Yay, it worked.\n");
- return 0;
- }
- $self->aside("That didn't work.\n");
-
- # Odd -- when it fails, under Win32, this seems to neither
- # return with a fail nor return with a success!!
- # That's discouraging!
- }
-
- $self->aside(
- sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
- join(' ', @found),
- join(' ', $self->pagers),
- );
-
- if (IS_VMS) {
- DEBUG > 1 and print "Bailing out in a VMSish way.\n";
- eval q{
- use vmsish qw(status exit);
- exit $?;
- 1;
- } or die;
- }
-
- return 1;
- # i.e., an UNSUCCESSFUL return value!
-}
-
-#..........................................................................
-
-sub check_file {
- my($self, $dir, $file) = @_;
-
- unless( ref $self ) {
- # Should never get called:
- $Carp::Verbose = 1;
- require Carp;
- Carp::croak( join '',
- "Crazy ", __PACKAGE__, " error:\n",
- "check_file must be an object_method!\n",
- "Aborting"
- );
- }
-
- if(length $dir and not -d $dir) {
- DEBUG > 3 and print " No dir $dir -- skipping.\n";
- return "";
- }
-
- if ($self->opt_m) {
- return $self->minus_f_nocase($dir,$file);
- }
-
- else {
- my $path = $self->minus_f_nocase($dir,$file);
- if( length $path and $self->containspod($path) ) {
- DEBUG > 3 and print
- " The file $path indeed looks promising!\n";
- return $path;
- }
- }
- DEBUG > 3 and print " No good: $file in $dir\n";
-
- return "";
-}
-
-#..........................................................................
-
-sub containspod {
- my($self, $file, $readit) = @_;
- return 1 if !$readit && $file =~ /\.pod\z/i;
-
-
- # Under cygwin the /usr/bin/perl is legal executable, but
- # you cannot open a file with that name. It must be spelled
- # out as "/usr/bin/perl.exe".
- #
- # The following if-case under cygwin prevents error
- #
- # $ perldoc perl
- # Cannot open /usr/bin/perl: no such file or directory
- #
- # This would work though
- #
- # $ perldoc perl.pod
-
- if ( IS_Cygwin and -x $file and -f "$file.exe" )
- {
- warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_v;
- return 0;
- }
-
- local($_);
- open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism
- while (<TEST>) {
- if (/^=head/) {
- close(TEST) or die "Can't close $file: $!";
- return 1;
- }
- }
- close(TEST) or die "Can't close $file: $!";
- return 0;
-}
-
-#..........................................................................
-
-sub maybe_diddle_INC {
- my $self = shift;
-
- # Does this look like a module or extension directory?
-
- if (-f "Makefile.PL") {
-
- # Add "." and "lib" to @INC (if they exist)
- eval q{ use lib qw(. lib); 1; } or die;
-
- # don't add if superuser
- if ($< && $> && -f "blib") { # don't be looking too hard now!
- eval q{ use blib; 1 };
- warn $@ if $@ && $self->opt_v;
- }
- }
-
- return;
-}
-
-#..........................................................................
-
-sub new_output_file {
- my $self = shift;
- my $outspec = $self->opt_d; # Yes, -d overrides all else!
- # So don't call this twice per format-job!
-
- return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
-
- # Otherwise open a write-handle on opt_d!f
-
- my $fh;
- # If we are running before perl5.6.0, we can't autovivify
- if ($] < 5.006) {
- require Symbol;
- $fh = Symbol::gensym();
- }
- DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
- die "Can't write-open $outspec: $!"
- unless open($fh, ">", $outspec); # XXX 5.6ism
-
- DEBUG > 3 and print "Successfully opened $outspec\n";
- binmode($fh) if $self->{'output_is_binary'};
- return($fh, $outspec);
-}
-
-#..........................................................................
-
-sub useful_filename_bit {
- # This tries to provide a meaningful bit of text to do with the query,
- # such as can be used in naming the file -- since if we're going to be
- # opening windows on temp files (as a "pager" may well do!) then it's
- # better if the temp file's name (which may well be used as the window
- # title) isn't ALL just random garbage!
- # In other words "perldoc_LWPSimple_2371981429" is a better temp file
- # name than "perldoc_2371981429". So this routine is what tries to
- # provide the "LWPSimple" bit.
- #
- my $self = shift;
- my $pages = $self->{'pages'} || return undef;
- return undef unless @$pages;
-
- my $chunk = $pages->[0];
- return undef unless defined $chunk;
- $chunk =~ s/:://g;
- $chunk =~ s/\.\w+$//g; # strip any extension
- if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
- $chunk = $1;
- } else {
- return undef;
- }
- $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
- $chunk = substr($chunk, -10) if length($chunk) > 10;
- return $chunk;
-}
-
-#..........................................................................
-
-sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
- my $self = shift;
-
- ++$Temp_Files_Created;
-
- if( IS_MSWin32 ) {
- my @out = $self->MSWin_perldoc_tempfile(@_);
- return @out if @out;
- # otherwise fall thru to the normal stuff below...
- }
-
- require File::Temp;
- return File::Temp::tempfile(UNLINK => 1);
-}
-
-#..........................................................................
-
-sub page { # apply a pager to the output file
- my ($self, $output, $output_to_stdout, @pagers) = @_;
- if ($output_to_stdout) {
- $self->aside("Sending unpaged output to STDOUT.\n");
- open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism
- local $_;
- while (<TMP>) {
- print or die "Can't print to stdout: $!";
- }
- close TMP or die "Can't close while $output: $!";
- $self->unlink_if_temp_file($output);
- } else {
- # On VMS, quoting prevents logical expansion, and temp files with no
- # extension get the wrong default extension (such as .LIS for TYPE)
-
- $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
-
- $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
- # Altho "/" under MSWin is in theory good as a pathsep,
- # many many corners of the OS don't like it. So we
- # have to force it to be "\" to make everyone happy.
-
- foreach my $pager (@pagers) {
- $self->aside("About to try calling $pager $output\n");
- if (IS_VMS) {
- last if system("$pager $output") == 0;
- } else {
- last if system("$pager \"$output\"") == 0;
- }
- }
- }
- return;
-}
-
-#..........................................................................
-
-sub searchfor {
- my($self, $recurse,$s,@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; # some dirs in @INC are optional
- ($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__
-
-# See "perldoc perldoc" for basic details.
-#
-# Perldoc -- look up a piece of documentation in .pod format that
-# is embedded in the perl installation tree.
-#
-#~~~~~~
-#
-# See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
-#
-# Version 3.01: Sun Nov 10 21:38:09 MST 2002
-# Sean M. Burke <sburke@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/installer/perllib/Pod/Perldoc/BaseTo.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/BaseTo.pm
deleted file mode 100644
index 6ca2a8c7e54..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/BaseTo.pm
+++ /dev/null
@@ -1,28 +0,0 @@
-
-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;
-
diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/GetOptsOO.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/GetOptsOO.pm
deleted file mode 100644
index b29aeb10906..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/GetOptsOO.pm
+++ /dev/null
@@ -1,106 +0,0 @@
-
-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;
-
diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToChecker.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToChecker.pm
deleted file mode 100644
index c60290d6502..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToChecker.pm
+++ /dev/null
@@ -1,72 +0,0 @@
-
-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
-
-Sean M. Burke C<sburke@cpan.org>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToMan.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToMan.pm
deleted file mode 100644
index 43191222376..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToMan.pm
+++ /dev/null
@@ -1,187 +0,0 @@
-
-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
-
-Sean M. Burke C<sburke@cpan.org>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToNroff.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToNroff.pm
deleted file mode 100644
index d0568605068..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToNroff.pm
+++ /dev/null
@@ -1,100 +0,0 @@
-
-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
-
-Sean M. Burke C<sburke@cpan.org>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToPod.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToPod.pm
deleted file mode 100644
index bccbfcadbd6..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToPod.pm
+++ /dev/null
@@ -1,90 +0,0 @@
-
-# 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
-
-Sean M. Burke C<sburke@cpan.org>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToRtf.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToRtf.pm
deleted file mode 100644
index 25e609e313a..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToRtf.pm
+++ /dev/null
@@ -1,85 +0,0 @@
-
-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
-
-Sean M. Burke C<sburke@cpan.org>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToText.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToText.pm
deleted file mode 100644
index 2eb9e0644ac..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToText.pm
+++ /dev/null
@@ -1,91 +0,0 @@
-
-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
-
-Sean M. Burke C<sburke@cpan.org>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToTk.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToTk.pm
deleted file mode 100644
index 39459629503..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToTk.pm
+++ /dev/null
@@ -1,129 +0,0 @@
-
-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
-
-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/installer/perllib/Pod/Perldoc/ToXml.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToXml.pm
deleted file mode 100644
index dd0d15cc10b..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToXml.pm
+++ /dev/null
@@ -1,63 +0,0 @@
-
-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
-
-Sean M. Burke C<sburke@cpan.org>
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Pod/PlainText.pm b/Master/tlpkg/installer/perllib/Pod/PlainText.pm
deleted file mode 100644
index 3f5ce90d2ba..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/PlainText.pm
+++ /dev/null
@@ -1,705 +0,0 @@
-# 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;
-
-require 5.005;
-
-use Carp qw(carp croak);
-use Pod::Select ();
-
-use strict;
-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.02';
-
-
-############################################################################
-# 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.
-
- $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');
- $self->item ("\n") if defined $$self{ITEM};
- $command = 'cmd_' . $command;
- $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;
- $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};
- $self->output ($_[0]), return if $$self{VERBATIM};
- 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/;
- 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;
- $_;
-}
-
-
-############################################################################
-# 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+$//;
- $_ = $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+$//;
- $_ = $self->interpolate ($_, shift);
- if ($$self{alt}) {
- $self->output ("\n== $_ ==\n\n");
- } else {
- $self->output (' ' x ($$self{indent} / 2) . $_ . "\n\n");
- }
-}
-
-# 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+$//;
- $$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;
- }
- $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 warn "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/;
- $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;
- }
- $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]) {
- local *IN;
- unless (open (IN, $_[0])) {
- croak ("Can't open $_[0] for reading: $!\n");
- return;
- }
- $_[0] = \*IN;
- 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<=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 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/installer/perllib/Pod/Plainer.pm b/Master/tlpkg/installer/perllib/Pod/Plainer.pm
deleted file mode 100644
index 373e8d090af..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Plainer.pm
+++ /dev/null
@@ -1,69 +0,0 @@
-package Pod::Plainer;
-use strict;
-use Pod::Parser;
-our @ISA = qw(Pod::Parser);
-our $VERSION = '0.01';
-
-our %E = qw( < lt > gt );
-
-sub escape_ltgt {
- (undef, my $text) = @_;
- $text =~ s/([<>])/E<$E{$1}>/g;
- $text
-}
-
-sub simple_delimiters {
- (undef, my $seq) = @_;
- $seq -> left_delimiter( '<' );
- $seq -> right_delimiter( '>' );
- $seq;
-}
-
-sub textblock {
- my($parser,$text,$line) = @_;
- print {$parser->output_handle()}
- $parser->parse_text(
- { -expand_text => q(escape_ltgt),
- -expand_seq => q(simple_delimiters) },
- $text, $line ) -> raw_text();
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Pod::Plainer - Perl extension for converting Pod to old style Pod.
-
-=head1 SYNOPSIS
-
- use Pod::Plainer;
-
- my $parser = Pod::Plainer -> new ();
- $parser -> parse_from_filehandle(\*STDIN);
-
-=head1 DESCRIPTION
-
-Pod::Plainer uses Pod::Parser which takes Pod with the (new)
-'CE<lt>E<lt> .. E<gt>E<gt>' constructs
-and returns the old(er) style with just 'CE<lt>E<gt>';
-'<' and '>' are replaced by 'EE<lt>ltE<gt>' and 'EE<lt>gtE<gt>'.
-
-This can be used to pre-process Pod before using tools which do not
-recognise the new style Pods.
-
-=head2 EXPORT
-
-None by default.
-
-=head1 AUTHOR
-
-Robin Barker, rmb1@cise.npl.co.uk
-
-=head1 SEE ALSO
-
-See L<Pod::Parser>.
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Pod/Select.pm b/Master/tlpkg/installer/perllib/Pod/Select.pm
deleted file mode 100644
index 1cc14dff4b6..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Select.pm
+++ /dev/null
@@ -1,754 +0,0 @@
-#############################################################################
-# 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 vars qw($VERSION);
-$VERSION = 1.30; ## 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 strict;
-#use diagnostics;
-use Carp;
-use Pod::Parser 1.04;
-use vars qw(@ISA @EXPORT $MAX_HEADING_LEVEL);
-
-@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_
-
-use vars qw(%myData @section_headings);
-
-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
-
-use vars qw(@selected_sections);
-
-sub select {
- my $self = shift;
- my @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 > 0) {
- 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
- my $spec;
- for $spec (@sections) {
- if ( defined($_ = &_compile_section_spec($spec)) ) {
- ## Store them in our sections array
- push(@selected_sections, $_);
- }
- else {
- carp "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;
- $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;
- $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 explictly 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} > 0));
-
- ## 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
- my ($section_spec, $regex, $negated, $match);
- for $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.
- ##------------------------------------------------------
- $match = 1;
- for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
- $regex = $section_spec->[$i];
- $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 interpeted 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 "/$_/"; ## check regex syntax
- if ($@) {
- ++$bad_regexs;
- carp "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/installer/perllib/Pod/Text.pm b/Master/tlpkg/installer/perllib/Pod/Text.pm
deleted file mode 100644
index 1028f2e9e1b..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Text.pm
+++ /dev/null
@@ -1,848 +0,0 @@
-# Pod::Text -- Convert POD data to formatted ASCII text.
-# $Id: Text.pm,v 2.21 2002/08/04 03:34:58 eagle Exp $
-#
-# Copyright 1999, 2000, 2001, 2002 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 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 Carp qw(carp croak);
-use Exporter ();
-use Pod::ParseLink qw(parselink);
-use Pod::Select ();
-
-use strict;
-use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
-
-# We inherit from Pod::Select instead of Pod::Parser so that we can be used by
-# Pod::Usage.
-@ISA = qw(Pod::Select Exporter);
-
-# We have to export pod2text for backward compatibility.
-@EXPORT = qw(pod2text);
-
-# Don't use the CVS revision as the version, since this module is also in Perl
-# core and too many things could munge CVS magic revision strings. This
-# number should ideally be the same as the CVS revision in podlators, however.
-$VERSION = 2.21;
-
-
-##############################################################################
-# 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. :) "iexcl" to
-# "divide" added by Tim Jenness.
-%ESCAPES = (
- 'amp' => '&', # ampersand
- 'apos' => "'", # apostrophe
- 'lt' => '<', # left chevron, less-than
- 'gt' => '>', # right chevron, greater-than
- 'quot' => '"', # double quote
- 'sol' => '/', # solidus (forward slash)
- 'verbar' => '|', # vertical bar
-
- "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" => "\xCC", # capital I, grave accent
- "igrave" => "\xEC", # 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
-
- "laquo" => "\xAB", # left pointing double angle quotation mark
- "lchevron" => "\xAB", # synonym (backwards compatibility)
- "raquo" => "\xBB", # right pointing double angle quotation mark
- "rchevron" => "\xBB", # synonym (backwards compatibility)
-
- "iexcl" => "\xA1", # inverted exclamation mark
- "cent" => "\xA2", # cent sign
- "pound" => "\xA3", # (UK) pound sign
- "curren" => "\xA4", # currency sign
- "yen" => "\xA5", # yen sign
- "brvbar" => "\xA6", # broken vertical bar
- "sect" => "\xA7", # section sign
- "uml" => "\xA8", # diaresis
- "copy" => "\xA9", # Copyright symbol
- "ordf" => "\xAA", # feminine ordinal indicator
- "not" => "\xAC", # not sign
- "shy" => '', # soft (discretionary) hyphen
- "reg" => "\xAE", # registered trademark
- "macr" => "\xAF", # macron, overline
- "deg" => "\xB0", # degree sign
- "plusmn" => "\xB1", # plus-minus sign
- "sup2" => "\xB2", # superscript 2
- "sup3" => "\xB3", # superscript 3
- "acute" => "\xB4", # acute accent
- "micro" => "\xB5", # micro sign
- "para" => "\xB6", # pilcrow sign = paragraph sign
- "middot" => "\xB7", # middle dot = Georgian comma
- "cedil" => "\xB8", # cedilla
- "sup1" => "\xB9", # superscript 1
- "ordm" => "\xBA", # masculine ordinal indicator
- "frac14" => "\xBC", # vulgar fraction one quarter
- "frac12" => "\xBD", # vulgar fraction one half
- "frac34" => "\xBE", # vulgar fraction three quarters
- "iquest" => "\xBF", # inverted question mark
- "times" => "\xD7", # multiplication sign
- "divide" => "\xF7", # division sign
-
- "nbsp" => "\x01", # non-breaking space
-);
-
-
-##############################################################################
-# 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{margin} = 0 unless defined $$self{margin};
- $$self{loose} = 0 unless defined $$self{loose};
- $$self{sentence} = 0 unless defined $$self{sentence};
- $$self{width} = 76 unless defined $$self{width};
-
- # Figure out what quotes we'll be using for C<> text.
- $$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}");
- }
-
- # Stack of indentations.
- $$self{INDENTS} = [];
-
- # Current left margin.
- $$self{MARGIN} = $$self{indent} + $$self{margin};
-
- $self->SUPER::initialize;
-
- # Tell Pod::Parser that we want the non-POD stuff too if code was set.
- $self->parseopts ('-want_nonPODs' => 1) if $$self{code};
-}
-
-
-##############################################################################
-# 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 ($self->can ('cmd_' . $command)) {
- $command = 'cmd_' . $command;
- $self->$command (@_);
- } else {
- my ($text, $line, $paragraph) = @_;
- my $file;
- ($file, $line) = $paragraph->file_line;
- $text =~ s/\n+\z//;
- $text = " $text" if ($text =~ /^\S/);
- warn qq($file:$line: Unknown command paragraph: =$command$text\n);
- return;
- }
-}
-
-# 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;
- $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};
- $self->output ($_[0]), return if $$self{VERBATIM};
- local $_ = shift;
- my $line = shift;
-
- # Interpolate and output the paragraph.
- $_ = $self->interpolate ($_, $line);
- s/\s+$/\n/;
- if (defined $$self{ITEM}) {
- $self->item ($_ . "\n");
- } else {
- $self->output ($self->reformat ($_ . "\n"));
- }
-}
-
-# Called for a formatting code. Gets the command, argument, and a
-# Pod::InteriorSequence object and is expected to return the resulting text.
-# Calls methods for code, bold, italic, file, and link to handle those types
-# of codes, and handles S<>, E<>, X<>, and Z<> directly.
-sub interior_sequence {
- local $_;
- my ($self, $command, $seq);
- ($self, $command, $_, $seq) = @_;
-
- # We have to defer processing of the inside of an L<> formatting code. If
- # this code is nested inside an L<> code, return the literal raw text of
- # it.
- my $parent = $seq->nested;
- while (defined $parent) {
- return $seq->raw_text if ($parent->cmd_name eq 'L');
- $parent = $parent->nested;
- }
-
- # Index entries are ignored in plain text.
- return '' if ($command eq 'X' || $command eq 'Z');
-
- # Expand escapes into the actual character now, warning if invalid.
- if ($command eq 'E') {
- if (/^\d+$/) {
- return chr;
- } else {
- return $ESCAPES{$_} if defined $ESCAPES{$_};
- my ($file, $line) = $seq->file_line;
- warn "$file:$line: Unknown escape: E<$_>\n";
- return "E<$_>";
- }
- }
-
- # For all the other formatting codes, 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+/ /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 ($_, $seq) }
- else {
- my ($file, $line) = $seq->file_line;
- warn "$file:$line: Unknown formatting code: $command<$_>\n";
- }
-}
-
-# Called for each paragraph that's actually part of the POD. We take
-# advantage of this opportunity to untabify the input. Also, if given the
-# code option, we may see paragraphs that aren't part of the POD and need to
-# output them directly.
-sub preprocess_paragraph {
- my $self = shift;
- local $_ = shift;
- 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;
- $self->output_code ($_) if $self->cutting;
- $_;
-}
-
-
-##############################################################################
-# Command paragraphs
-##############################################################################
-
-# All command paragraphs take the paragraph and the line number.
-
-# First level heading.
-sub cmd_head1 {
- my ($self, $text, $line) = @_;
- $self->heading ($text, $line, 0, '====');
-}
-
-# Second level heading.
-sub cmd_head2 {
- my ($self, $text, $line) = @_;
- $self->heading ($text, $line, $$self{indent} / 2, '== ');
-}
-
-# Third level heading.
-sub cmd_head3 {
- my ($self, $text, $line) = @_;
- $self->heading ($text, $line, $$self{indent} * 2 / 3 + 0.5, '= ');
-}
-
-# Third level heading.
-sub cmd_head4 {
- my ($self, $text, $line) = @_;
- $self->heading ($text, $line, $$self{indent} * 3 / 4 + 0.5, '- ');
-}
-
-# Start a list.
-sub cmd_over {
- my $self = shift;
- local $_ = shift;
- $self->item ("\n\n") if defined $$self{ITEM};
- unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }
- push (@{ $$self{INDENTS} }, $$self{MARGIN});
- $$self{MARGIN} += ($_ + 0);
-}
-
-# End a list.
-sub cmd_back {
- my ($self, $text, $line, $paragraph) = @_;
- $self->item ("\n\n") if defined $$self{ITEM};
- $$self{MARGIN} = pop @{ $$self{INDENTS} };
- unless (defined $$self{MARGIN}) {
- my $file;
- ($file, $line) = $paragraph->file_line;
- warn "$file:$line: Unmatched =back\n";
- $$self{MARGIN} = $$self{indent};
- }
-}
-
-# An individual list item.
-sub cmd_item {
- my $self = shift;
- if (defined $$self{ITEM}) { $self->item }
- local $_ = shift;
- 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);
-}
-
-
-##############################################################################
-# Formatting codes
-##############################################################################
-
-# The simple 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_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] }
-sub seq_i { return '*' . $_[1] . '*' }
-
-# 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 seq_c {
- my $self = shift;
- local $_ = shift;
-
- # A regex that matches the portion of a variable reference that's the
- # array or hash index, separated out just because we want to use it in
- # several places in the following regex.
- my $index = '(?: \[.*\] | \{.*\} )?';
-
- # Check for things that we don't want to quote, and if we find any of
- # them, return the string with just a font change and no quoting.
- m{
- ^\s*
- (?:
- ( [\'\`\"] ) .* \1 # already quoted
- | \` .* \' # `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 $_;
-
- # If we didn't return, go ahead and quote the text.
- return $$self{alt} ? "``$_''" : "$$self{LQUOTE}$_$$self{RQUOTE}";
-}
-
-# 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. Most of the
-# work is done by Pod::ParseLink.
-sub seq_l {
- my ($self, $link, $seq) = @_;
- my ($text, $type) = (parselink ($link))[1,4];
- my ($file, $line) = $seq->file_line;
- $text = $self->interpolate ($text, $line);
- $text = '<' . $text . '>' if $type eq 'url';
- return $text || '';
-}
-
-
-##############################################################################
-# Header handling
-##############################################################################
-
-# The common code for handling all headers. Takes the interpolated header
-# text, the line number, the indentation, and the surrounding marker for the
-# alt formatting method.
-sub heading {
- my ($self, $text, $line, $indent, $marker) = @_;
- $self->item ("\n\n") if defined $$self{ITEM};
- $text =~ s/\s+$//;
- $text = $self->interpolate ($text, $line);
- if ($$self{alt}) {
- my $closemark = reverse (split (//, $marker));
- my $margin = ' ' x $$self{margin};
- $self->output ("\n" . "$margin$marker $text $closemark" . "\n\n");
- } else {
- $text .= "\n" if $$self{loose};
- my $margin = ' ' x ($$self{margin} + $indent);
- $self->output ($margin . $text . "\n");
- }
-}
-
-
-##############################################################################
-# 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 $margin = ' ' x $$self{margin};
- if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) {
- my $realindent = $$self{MARGIN};
- $$self{MARGIN} = $indent;
- my $output = $self->reformat ($tag);
- $output =~ s/^$margin /$margin:/ if ($$self{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 $_ && $_ =~ /^\s*$/;
-
- $self->output ($output);
- $$self{MARGIN} = $realindent;
- $self->output ($self->reformat ($_)) if $_ && /\S/;
- } else {
- my $space = ' ' x $indent;
- $space =~ s/^$margin /$margin:/ if $$self{alt};
- $_ = $self->reformat ($_);
- s/^$margin /$margin:/ if ($$self{alt} && $indent > 0);
- my $tagspace = ' ' x length $tag;
- s/^($space)$tagspace/$1$tag/ or warn "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/;
- $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;
- }
- $self->wrap ($_);
-}
-
-# Output text to the output device.
-sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] }
-
-# 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]) }
-
-
-##############################################################################
-# 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;
- return $parser->parse_from_filehandle (@fhs);
- } else {
- return $parser->parse_from_file (@_);
- }
-}
-
-
-##############################################################################
-# Module return value and documentation
-##############################################################################
-
-1;
-__END__
-
-=head1 NAME
-
-Pod::Text - Convert POD data to formatted ASCII text
-
-=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::Parser, Pod::Text supports the same methods and
-interfaces. See L<Pod::Parser> for all the details; briefly, one creates a
-new parser with C<< Pod::Text->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 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 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
-
-=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.
-
-=item %s:%d: Unknown command paragraph: %s
-
-(W) The POD source contained a non-standard command paragraph (something of
-the form C<=command args>) that Pod::Man didn't know about. It was ignored.
-
-=item %s:%d: Unknown escape: %s
-
-(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::Text didn't
-know about.
-
-=item %s:%d: Unknown formatting code: %s
-
-(W) The POD source contained a non-standard formatting code (something of
-the form C<XE<lt>E<gt>>) that Pod::Text didn't know about.
-
-=item %s:%d: Unmatched =back
-
-(W) Pod::Text 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>.
-
-=head1 SEE ALSO
-
-L<Pod::Parser>, L<Pod::Text::Termcap>, 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>.
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 1999, 2000, 2001, 2002 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/installer/perllib/Pod/Text/Color.pm b/Master/tlpkg/installer/perllib/Pod/Text/Color.pm
deleted file mode 100644
index 2ba31369b96..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Text/Color.pm
+++ /dev/null
@@ -1,145 +0,0 @@
-# Pod::Text::Color -- Convert POD data to formatted color ASCII text
-# $Id: Color.pm,v 1.4 2002/07/15 05:46:00 eagle Exp $
-#
-# Copyright 1999, 2001 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 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);
-
-# Don't use the CVS revision as the version, since this module is also in Perl
-# core and too many things could munge CVS magic revision strings. This
-# number should ideally be the same as the CVS revision in podlators, however.
-$VERSION = 1.04;
-
-
-##############################################################################
-# Overrides
-##############################################################################
-
-# Make level one headings bold.
-sub cmd_head1 {
- my $self = shift;
- local $_ = shift;
- s/\s+$//;
- $self->SUPER::cmd_head1 (colored ($_, 'bold'));
-}
-
-# Make level two headings bold.
-sub cmd_head2 {
- my $self = shift;
- local $_ = shift;
- s/\s+$//;
- $self->SUPER::cmd_head2 (colored ($_, 'bold'));
-}
-
-# Fix the various formatting codes.
-sub seq_b { return colored ($_[1], 'bold') }
-sub seq_f { return colored ($_[1], 'cyan') }
-sub seq_i { return colored ($_[1], 'yellow') }
-
-# Output any included code in green.
-sub output_code {
- my ($self, $code) = @_;
- $code = colored ($code, 'green');
- $self->output ($code);
-}
-
-# 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{width} - $$self{MARGIN};
- while (length > $width) {
- if (s/^((?:(?:\e\[[\d;]+m)?[^\n]){0,$width})\s+//
- || s/^((?:(?:\e\[[\d;]+m)?[^\n]){$width})//) {
- $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
-
-=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::Parser>
-
-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 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/installer/perllib/Pod/Text/Overstrike.pm b/Master/tlpkg/installer/perllib/Pod/Text/Overstrike.pm
deleted file mode 100644
index 8ba918396c1..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Text/Overstrike.pm
+++ /dev/null
@@ -1,208 +0,0 @@
-# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text
-# $Id: Overstrike.pm,v 1.10 2002/08/04 03:35:01 eagle Exp $
-#
-# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000
-# (based on Pod::Text::Color 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 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);
-
-# Don't use the CVS revision as the version, since this module is also in Perl
-# core and too many things could munge CVS magic revision strings. This
-# number should ideally be the same as the CVS revision in podlators, however.
-$VERSION = 1.10;
-
-
-##############################################################################
-# Overrides
-##############################################################################
-
-# Make level one headings bold, overridding any existing formatting.
-sub cmd_head1 {
- my ($self, $text, $line) = @_;
- $text =~ s/\s+$//;
- $text = $self->strip_format ($self->interpolate ($text, $line));
- $text =~ s/(.)/$1\b$1/g;
- $self->SUPER::cmd_head1 ($text);
-}
-
-# Make level two headings bold, overriding any existing formatting.
-sub cmd_head2 {
- my ($self, $text, $line) = @_;
- $text =~ s/\s+$//;
- $text = $self->strip_format ($self->interpolate ($text, $line));
- $text =~ s/(.)/$1\b$1/g;
- $self->SUPER::cmd_head2 ($text);
-}
-
-# Make level three headings underscored, overriding any existing formatting.
-sub cmd_head3 {
- my ($self, $text, $line) = @_;
- $text =~ s/\s+$//;
- $text = $self->strip_format ($self->interpolate ($text, $line));
- $text =~ s/(.)/_\b$1/g;
- $self->SUPER::cmd_head3 ($text);
-}
-
-# Level four headings look like level three headings.
-sub cmd_head4 {
- my ($self, $text, $line) = @_;
- $text =~ s/\s+$//;
- $text = $self->strip_format ($self->interpolate ($text, $line));
- $text =~ s/(.)/_\b$1/g;
- $self->SUPER::cmd_head4 ($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, $line, $indent, $marker) = @_;
- $self->item ("\n\n") if defined $$self{ITEM};
- $text .= "\n" if $$self{loose};
- my $margin = ' ' x ($$self{margin} + $indent);
- $self->output ($margin . $text . "\n");
-}
-
-# Fix the various formatting codes.
-sub seq_b { local $_ = strip_format (@_); s/(.)/$1\b$1/g; $_ }
-sub seq_f { local $_ = strip_format (@_); s/(.)/_\b$1/g; $_ }
-sub seq_i { local $_ = strip_format (@_); 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);
-}
-
-# 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{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/;
- $output;
-}
-
-##############################################################################
-# Utility functions
-##############################################################################
-
-# 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;
-}
-
-##############################################################################
-# Module return value and documentation
-##############################################################################
-
-1;
-__END__
-
-=head1 NAME
-
-Pod::Text::Overstrike - Convert POD data to formatted overstrike text
-
-=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
-hardcopy terminals and/or lineprinters, yet is readable on softcopy (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::Parser>
-
-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 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/installer/perllib/Pod/Text/Termcap.pm b/Master/tlpkg/installer/perllib/Pod/Text/Termcap.pm
deleted file mode 100644
index 02a7fb9842a..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Text/Termcap.pm
+++ /dev/null
@@ -1,180 +0,0 @@
-# Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes.
-# $Id: Termcap.pm,v 1.11 2003/07/09 21:52:30 eagle Exp $
-#
-# Copyright 1999, 2001, 2002 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 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);
-
-# Don't use the CVS revision as the version, since this module is also in Perl
-# core and too many things could munge CVS magic revision strings. This
-# number should ideally be the same as the CVS revision in podlators, however.
-$VERSION = 1.11;
-
-
-##############################################################################
-# Overrides
-##############################################################################
-
-# In the initialization method, grab our terminal characteristics as well as
-# do all the stuff we normally do.
-sub initialize {
- my $self = shift;
- my ($ospeed, $term, $termios);
-
- # $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{width} = $ENV{COLUMNS} || $$term{_co} || 80;
- $$self{width} -= 2;
- }
-
- $self->SUPER::initialize;
-}
-
-# Make level one headings bold.
-sub cmd_head1 {
- my $self = shift;
- local $_ = shift;
- s/\s+$//;
- $self->SUPER::cmd_head1 ("$$self{BOLD}$_$$self{NORM}");
-}
-
-# Make level two headings bold.
-sub cmd_head2 {
- my $self = shift;
- local $_ = shift;
- s/\s+$//;
- $self->SUPER::cmd_head2 ("$$self{BOLD}$_$$self{NORM}");
-}
-
-# Fix up B<> and I<>. Note that we intentionally don't do F<>.
-sub seq_b { my $self = shift; return "$$self{BOLD}$_[0]$$self{NORM}" }
-sub seq_i { my $self = shift; return "$$self{UNDL}$_[0]$$self{NORM}" }
-
-# Output any included code in bold.
-sub output_code {
- my ($self, $code) = @_;
- $self->output ($$self{BOLD} . $code . $$self{NORM});
-}
-
-# 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{width} - $$self{MARGIN};
- my $code = "(?:\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)";
- while (length > $width) {
- if (s/^((?:$code?[^\n]){0,$width})\s+//
- || s/^((?:$code?[^\n]){$width})//) {
- $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::Termcap - Convert POD data to ASCII text with format escapes
-
-=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::Parser>, 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 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/installer/perllib/Pod/Usage.pm b/Master/tlpkg/installer/perllib/Pod/Usage.pm
deleted file mode 100644
index c298e941f21..00000000000
--- a/Master/tlpkg/installer/perllib/Pod/Usage.pm
+++ /dev/null
@@ -1,659 +0,0 @@
-#############################################################################
-# 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 vars qw($VERSION);
-$VERSION = 1.33; ## 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 -section
-parameter; then these sections are extracted (see L<Pod::Select>)
-and printed.
-
-=item C<-section>
-
-A string representing a selection list for sections to be printed
-when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">.
-
-=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>).
-
-=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
-desireable to exit with a status of 1 (as opposed to 0) after issuing
-the user-requested usage message. It is also desireable 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>.
-
-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 ACKNOWLEDGEMENTS
-
-Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience
-with re-writing this manpage.
-
-=cut
-
-#############################################################################
-
-use strict;
-#use diagnostics;
-use Carp;
-use Config;
-use Exporter;
-use File::Spec;
-
-use vars qw(@ISA @EXPORT);
-@EXPORT = qw(&pod2usage);
-BEGIN {
- if ( $] >= 5.005_58 ) {
- require Pod::Text;
- @ISA = qw( Pod::Text );
- }
- else {
- require Pod::PlainText;
- @ISA = qw( Pod::PlainText );
- }
-}
-
-
-##---------------------------------------------------------------------------
-
-##---------------------------------
-## 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 $val = $opts{$_};
- s/^(?=\w)/-/;
- /^-msg/i and $_ = '-message';
- /^-exit/i and $_ = '-exitval';
- lc($_) => $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 ($dirname, $basename) = ('', $opts{"-input"});
- my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/) ? ";"
- : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ":");
- my $pathspec = $opts{"-pathlist"} || $ENV{PATH} || $ENV{PERL5LIB};
-
- my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec);
- for $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\s*');
- }
- elsif ($opts{"-verbose"} == 1) {
- my $opt_re = '(?i)' .
- '(?:OPTIONS|ARGUMENTS)' .
- '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
- $parser->select( 'SYNOPSIS', $opt_re, "DESCRIPTION/$opt_re" );
- }
- elsif ($opts{"-verbose"} == 99) {
- $parser->select( $opts{"-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");
- system($progpath, $opts{"-input"});
- }
- 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, @res) = @_;
- if ($ISA[0]->can('select')) {
- $self->SUPER::select(@_);
- } else {
- $self->{USAGE_SELECT} = \@res;
- }
-}
-
-# 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_HEAD1} = $$self{PENDING}[-1][1];
- $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/;
- } elsif ($element eq 'head2') {
- $$self{USAGE_HEAD2} = $$self{PENDING}[-1][1];
- }
- if ($element eq 'head1' || $element eq 'head2') {
- $$self{USAGE_SKIPPING} = 1;
- my $heading = $$self{USAGE_HEAD1};
- $heading .= '/' . $$self{USAGE_HEAD2} if defined $$self{USAGE_HEAD2};
- for (@{ $$self{USAGE_SELECT} }) {
- if ($heading =~ /^$_\s*$/) {
- $$self{USAGE_SKIPPING} = 0;
- last;
- }
- }
-
- # Try to do some lowercasing instead of all-caps in headings, and use
- # a colon to end all headings.
- 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}) {
- pop @{ $$self{PENDING} };
- } else {
- $self->SUPER::_handle_element_end($element);
- }
-}
-
-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";
-}
-
-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/installer/perllib/Safe.pm b/Master/tlpkg/installer/perllib/Safe.pm
deleted file mode 100644
index e2a608023ca..00000000000
--- a/Master/tlpkg/installer/perllib/Safe.pm
+++ /dev/null
@@ -1,576 +0,0 @@
-package Safe;
-
-use 5.003_11;
-use strict;
-
-$Safe::VERSION = "2.12";
-
-# *** 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;
-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;
-my $default_share = ['*_']; #, '*main::'];
-
-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:
- croak("'$arg' not a valid symbol table name")
- unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/
- or $arg =~ /^\$\W$/;
- my ($var, $type);
- $type = $1 if ($var = $arg) =~ s/^(\W)//;
- # warn "share_from $pkg $type $var";
- *{$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);
- return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
-}
-
-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 Opcode(3) 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)
-
-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.
-
-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,
-mbeattie@sable.ox.ac.uk.
-
-Reworked to use the Opcode module and other changes added by Tim Bunce
-E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Scalar/Util.pm b/Master/tlpkg/installer/perllib/Scalar/Util.pm
deleted file mode 100644
index 4ae525a17c0..00000000000
--- a/Master/tlpkg/installer/perllib/Scalar/Util.pm
+++ /dev/null
@@ -1,147 +0,0 @@
-# Scalar::Util.pm
-#
-# Copyright (c) 1997-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 Scalar::Util;
-
-use strict;
-use vars qw(@ISA @EXPORT_OK $VERSION);
-require Exporter;
-require List::Util; # List::Util loads the XS
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
-$VERSION = "1.18";
-$VERSION = eval $VERSION;
-
-sub export_fail {
- if (grep { /^(weaken|isweak)$/ } @_ ) {
- require Carp;
- Carp::croak("Weak references are not implemented in the version of perl");
- }
- if (grep { /^(isvstring)$/ } @_ ) {
- require Carp;
- Carp::croak("Vstrings are not implemented in the version of perl");
- }
- if (grep { /^(dualvar|set_prototype)$/ } @_ ) {
- require Carp;
- Carp::croak("$1 is only avaliable with the XS version");
- }
-
- @_;
-}
-
-sub openhandle ($) {
- my $fh = shift;
- my $rt = reftype($fh) || '';
-
- return defined(fileno($fh)) ? $fh : undef
- if $rt eq 'IO';
-
- if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA)
- $fh = \(my $tmp=$fh);
- }
- elsif ($rt ne 'GLOB') {
- return undef;
- }
-
- (tied(*$fh) or defined(fileno($fh)))
- ? $fh : undef;
-}
-
-eval <<'ESQ' unless defined &dualvar;
-
-use vars qw(@EXPORT_FAIL);
-push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);
-
-# The code beyond here is only used if the XS is not installed
-
-# Hope nobody defines a sub by this name
-sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }
-
-sub blessed ($) {
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- length(ref($_[0]))
- ? eval { $_[0]->a_sub_not_likely_to_be_here }
- : undef
-}
-
-sub refaddr($) {
- my $pkg = ref($_[0]) or return undef;
- if (blessed($_[0])) {
- 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;
-}
-
-sub reftype ($) {
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- my $r = shift;
- my $t;
-
- length($t = ref($r)) or return undef;
-
- # This eval will fail if the reference is not blessed
- eval { $r->a_sub_not_likely_to_be_here; 1 }
- ? do {
- $t = eval {
- # we have a GLOB or an IO. Stringify a GLOB gives it's name
- my $q = *$r;
- $q =~ /^\*/ ? "GLOB" : "IO";
- }
- or do {
- # OK, if we don't have a GLOB what parts of
- # a glob will it populate.
- # NOTE: A glob always has a SCALAR
- local *glob = $r;
- defined *glob{ARRAY} && "ARRAY"
- or defined *glob{HASH} && "HASH"
- or defined *glob{CODE} && "CODE"
- or length(ref(${$r})) ? "REF" : "SCALAR";
- }
- }
- : $t
-}
-
-sub tainted {
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- local $^W = 0;
- eval { kill 0 * $_[0] };
- $@ =~ /^Insecure/;
-}
-
-sub readonly {
- return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
-
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- my $tmp = $_[0];
-
- !eval { $_[0] = $tmp; 1 };
-}
-
-sub looks_like_number {
- local $_ = shift;
-
- # checks from perlfaq4
- return 0 if !defined($_) or ref($_);
- return 1 if (/^[+-]?\d+$/); # is a +/- integer
- return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
- return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
-
- 0;
-}
-
-ESQ
-
-1;
-
-__END__
-
diff --git a/Master/tlpkg/installer/perllib/SelectSaver.pm b/Master/tlpkg/installer/perllib/SelectSaver.pm
deleted file mode 100644
index 1207b88a4a2..00000000000
--- a/Master/tlpkg/installer/perllib/SelectSaver.pm
+++ /dev/null
@@ -1,54 +0,0 @@
-package SelectSaver;
-
-our $VERSION = '1.01';
-
-=head1 NAME
-
-SelectSaver - save and restore selected file handle
-
-=head1 SYNOPSIS
-
- use SelectSaver;
-
- {
- my $saver = new SelectSaver(FILEHANDLE);
- # FILEHANDLE is selected
- }
- # previous handle is selected
-
- {
- my $saver = new SelectSaver;
- # new handle may be selected, or not
- }
- # previous handle is selected
-
-=head1 DESCRIPTION
-
-A C<SelectSaver> object contains a reference to the file handle that
-was selected when it was created. If its C<new> method gets an extra
-parameter, then that parameter is selected; otherwise, the selected
-file handle remains unchanged.
-
-When a C<SelectSaver> is destroyed, it re-selects the file handle
-that was selected when it was created.
-
-=cut
-
-require 5.000;
-use Carp;
-use Symbol;
-
-sub new {
- @_ >= 1 && @_ <= 2 or croak 'usage: new SelectSaver [FILEHANDLE]';
- my $fh = select;
- my $self = bless \$fh, $_[0];
- select qualify($_[1], caller) if @_ > 1;
- $self;
-}
-
-sub DESTROY {
- my $self = $_[0];
- select $$self;
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/Symbol.pm b/Master/tlpkg/installer/perllib/Symbol.pm
deleted file mode 100644
index 3bb5d9240c1..00000000000
--- a/Master/tlpkg/installer/perllib/Symbol.pm
+++ /dev/null
@@ -1,170 +0,0 @@
-package Symbol;
-
-=head1 NAME
-
-Symbol - manipulate Perl symbols and their names
-
-=head1 SYNOPSIS
-
- use Symbol;
-
- $sym = gensym;
- open($sym, "filename");
- $_ = <$sym>;
- # etc.
-
- ungensym $sym; # no effect
-
- # replace *FOO{IO} handle but not $FOO, %FOO, etc.
- *FOO = geniosym;
-
- print qualify("x"), "\n"; # "Test::x"
- print qualify("x", "FOO"), "\n" # "FOO::x"
- print qualify("BAR::x"), "\n"; # "BAR::x"
- print qualify("BAR::x", "FOO"), "\n"; # "BAR::x"
- print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global)
- print qualify(\*x), "\n"; # returns \*x
- print qualify(\*x, "FOO"), "\n"; # returns \*x
-
- use strict refs;
- print { qualify_to_ref $fh } "foo!\n";
- $ref = qualify_to_ref $name, $pkg;
-
- use Symbol qw(delete_package);
- delete_package('Foo::Bar');
- print "deleted\n" unless exists $Foo::{'Bar::'};
-
-=head1 DESCRIPTION
-
-C<Symbol::gensym> creates an anonymous glob and returns a reference
-to it. Such a glob reference can be used as a file or directory
-handle.
-
-For backward compatibility with older implementations that didn't
-support anonymous globs, C<Symbol::ungensym> is also provided.
-But it doesn't do anything.
-
-C<Symbol::geniosym> creates an anonymous IO handle. This can be
-assigned into an existing glob without affecting the non-IO portions
-of the glob.
-
-C<Symbol::qualify> turns unqualified symbol names into qualified
-variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
-second parameter, C<qualify> uses it as the default package;
-otherwise, it uses the package of its caller. Regardless, global
-variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
-"main::".
-
-Qualification applies only to symbol names (strings). References are
-left unchanged under the assumption that they are glob references,
-which are qualified by their nature.
-
-C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
-returns a glob ref rather than a symbol name, so you can use the result
-even if C<use strict 'refs'> is in effect.
-
-C<Symbol::delete_package> wipes out a whole package namespace. Note
-this routine is not exported by default--you may want to import it
-explicitly.
-
-=head1 BUGS
-
-C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that
-lives in the specified package. Since perl, for performance reasons, does not
-perform a symbol table lookup each time a function is called or a global
-variable is accessed, some code that has already been loaded and that makes use
-of symbols in package C<Foo> may stop working after you delete C<Foo>, even if
-you reload the C<Foo> module afterwards.
-
-=cut
-
-BEGIN { require 5.005; }
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
-@EXPORT_OK = qw(delete_package geniosym);
-
-$VERSION = '1.06';
-
-my $genpkg = "Symbol::";
-my $genseq = 0;
-
-my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
-
-#
-# Note that we never _copy_ the glob; we just make a ref to it.
-# If we did copy it, then SVf_FAKE would be set on the copy, and
-# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
-#
-sub gensym () {
- my $name = "GEN" . $genseq++;
- my $ref = \*{$genpkg . $name};
- delete $$genpkg{$name};
- $ref;
-}
-
-sub geniosym () {
- my $sym = gensym();
- # force the IO slot to be filled
- select(select $sym);
- *$sym{IO};
-}
-
-sub ungensym ($) {}
-
-sub qualify ($;$) {
- my ($name) = @_;
- if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
- my $pkg;
- # Global names: special character, "^xyz", or other.
- if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
- # RGS 2001-11-05 : translate leading ^X to control-char
- $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
- $pkg = "main";
- }
- else {
- $pkg = (@_ > 1) ? $_[1] : caller;
- }
- $name = $pkg . "::" . $name;
- }
- $name;
-}
-
-sub qualify_to_ref ($;$) {
- return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
-}
-
-#
-# of Safe.pm lineage
-#
-sub delete_package ($) {
- my $pkg = shift;
-
- # expand to full symbol table name if needed
-
- unless ($pkg =~ /^main::.*::$/) {
- $pkg = "main$pkg" if $pkg =~ /^::/;
- $pkg = "main::$pkg" unless $pkg =~ /^main::/;
- $pkg .= '::' unless $pkg =~ /::$/;
- }
-
- my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
- my $stem_symtab = *{$stem}{HASH};
- return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
-
-
- # free all the symbols in the package
-
- my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
- foreach my $name (keys %$leaf_symtab) {
- undef *{$pkg . $name};
- }
-
- # delete the symbol table
-
- %$leaf_symtab = ();
- delete $stem_symtab->{$leaf};
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/Term/ANSIColor.pm b/Master/tlpkg/installer/perllib/Term/ANSIColor.pm
deleted file mode 100644
index 9320fa06b23..00000000000
--- a/Master/tlpkg/installer/perllib/Term/ANSIColor.pm
+++ /dev/null
@@ -1,472 +0,0 @@
-# Term::ANSIColor -- Color screen output using ANSI escape sequences.
-# $Id: ANSIColor.pm,v 1.10 2005/08/21 18:31:58 eagle Exp $
-#
-# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005
-# by 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.
-#
-# Ah, September, when the sysadmins turn colors and fall off the trees....
-# -- Dave Van Domelen
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Term::ANSIColor;
-require 5.001;
-
-use strict;
-use vars qw($AUTOLOAD $AUTORESET $EACHLINE @ISA @EXPORT @EXPORT_OK
- %EXPORT_TAGS $VERSION %attributes %attributes_r);
-
-use Exporter ();
-@ISA = qw(Exporter);
-@EXPORT = qw(color colored);
-@EXPORT_OK = qw(uncolor);
-%EXPORT_TAGS = (constants => [qw(CLEAR RESET BOLD DARK UNDERLINE UNDERSCORE
- BLINK REVERSE CONCEALED BLACK RED GREEN
- YELLOW BLUE MAGENTA CYAN WHITE ON_BLACK
- ON_RED ON_GREEN ON_YELLOW ON_BLUE ON_MAGENTA
- ON_CYAN ON_WHITE)]);
-Exporter::export_ok_tags ('constants');
-
-# Don't use the CVS revision as the version, since this module is also in Perl
-# core and too many things could munge CVS magic revision strings.
-$VERSION = '1.10';
-
-##############################################################################
-# Internal data structures
-##############################################################################
-
-%attributes = ('clear' => 0,
- 'reset' => 0,
- 'bold' => 1,
- 'dark' => 2,
- 'underline' => 4,
- 'underscore' => 4,
- 'blink' => 5,
- 'reverse' => 7,
- 'concealed' => 8,
-
- 'black' => 30, 'on_black' => 40,
- 'red' => 31, 'on_red' => 41,
- 'green' => 32, 'on_green' => 42,
- 'yellow' => 33, 'on_yellow' => 43,
- 'blue' => 34, 'on_blue' => 44,
- 'magenta' => 35, 'on_magenta' => 45,
- 'cyan' => 36, 'on_cyan' => 46,
- 'white' => 37, 'on_white' => 47);
-
-# Reverse lookup. Alphabetically first name for a sequence is preferred.
-for (reverse sort keys %attributes) {
- $attributes_r{$attributes{$_}} = $_;
-}
-
-##############################################################################
-# Implementation (constant form)
-##############################################################################
-
-# Time to have fun! We now want to define the constant subs, which are named
-# the same as the attributes above but in all caps. Each constant sub needs
-# to act differently depending on whether $AUTORESET is set. Without
-# autoreset:
-#
-# BLUE "text\n" ==> "\e[34mtext\n"
-#
-# If $AUTORESET is set, we should instead get:
-#
-# BLUE "text\n" ==> "\e[34mtext\n\e[0m"
-#
-# The sub also needs to handle the case where it has no arguments correctly.
-# Maintaining all of this as separate subs would be a major nightmare, as well
-# as duplicate the %attributes hash, so instead we define an AUTOLOAD sub to
-# define the constant subs on demand. To do that, we check the name of the
-# called sub against the list of attributes, and if it's an all-caps version
-# of one of them, we define the sub on the fly and then run it.
-#
-# If the environment variable ANSI_COLORS_DISABLED is set, turn all of the
-# generated subs into pass-through functions that don't add 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 {
- my $enable_colors = !defined $ENV{ANSI_COLORS_DISABLED};
- my $sub;
- ($sub = $AUTOLOAD) =~ s/^.*:://;
- my $attr = $attributes{lc $sub};
- if ($sub =~ /^[A-Z_]+$/ && defined $attr) {
- $attr = $enable_colors ? "\e[" . $attr . 'm' : '';
- eval qq {
- sub $AUTOLOAD {
- if (\$AUTORESET && \@_) {
- '$attr' . "\@_" . "\e[0m";
- } else {
- ('$attr' . "\@_");
- }
- }
- };
- goto &$AUTOLOAD;
- } else {
- require Carp;
- Carp::croak ("undefined subroutine &$AUTOLOAD called");
- }
-}
-
-##############################################################################
-# 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;
- ($attribute ne '') ? "\e[${attribute}m" : undef;
-}
-
-# Return a list of named color attributes for a given set of escape codes.
-# Escape sequences can be given with or without enclosing "\e[" and "m". The
-# empty escape sequence '' or "\e[m" gives an empty list of attrs.
-sub uncolor {
- my (@nums, @result);
- for (@_) {
- my $escape = $_;
- $escape =~ s/^\e\[//;
- $escape =~ s/m$//;
- unless ($escape =~ /^((?:\d+;)*\d*)$/) {
- require Carp;
- Carp::croak ("Bad escape sequence $_");
- }
- push (@nums, split (/;/, $1));
- }
- for (@nums) {
- $_ += 0; # Strip leading zeroes
- my $name = $attributes_r{$_};
- if (!defined $name) {
- require Carp;
- Carp::croak ("No name for escape sequence $_" );
- }
- push (@result, $name);
- }
- @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);
- join '',
- map { $_ ne $EACHLINE ? $attr . $_ . "\e[0m" : $_ }
- grep { length ($_) > 0 }
- split (/(\Q$EACHLINE\E)/, $string);
- } else {
- color (@codes) . $string . "\e[0m";
- }
-}
-
-##############################################################################
-# Module return value and documentation
-##############################################################################
-
-# Ensure we evaluate to true.
-1;
-__END__
-
-=head1 NAME
-
-Term::ANSIColor - Color screen output using ANSI escape sequences
-
-=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.\n", 'yellow on_magenta');
- print "This text is normal.\n";
- print colored ['yellow on_magenta'], "Yellow on magenta.\n";
-
- use Term::ANSIColor qw(uncolor);
- print uncolor '01;31', "\n";
-
- use Term::ANSIColor qw(:constants);
- print BOLD, BLUE, "This text is in bold blue.\n", RESET;
-
- use Term::ANSIColor qw(:constants);
- $Term::ANSIColor::AUTORESET = 1;
- print BOLD BLUE "This text is in bold blue.\n";
- print "This text is normal.\n";
-
-=head1 DESCRIPTION
-
-This module has two interfaces, one through color() and colored() and the
-other through constants. It also offers the utility function uncolor(),
-which has to be explicitly imported to be used (see L<SYNOPSIS>).
-
-color() takes any number of strings as arguments and considers them to be
-space-separated lists of attributes. It then forms and returns the escape
-sequence to set those attributes. It doesn't print it out, just returns it,
-so you'll have to print it yourself if you want to (this is so that you can
-save it as a string, pass it to something else, send it to a file handle, or
-do anything else with it that you might care to).
-
-uncolor() performs the opposite translation, turning escape sequences
-into a list of strings.
-
-The recognized attributes (all of which should be fairly intuitive) are
-clear, reset, dark, bold, underline, underscore, blink, reverse, concealed,
-black, red, green, yellow, blue, magenta, on_black, on_red, on_green,
-on_yellow, on_blue, on_magenta, on_cyan, and on_white. Case is not
-significant. Underline and underscore are equivalent, as are clear and
-reset, so use whichever is the most intuitive to you. The color alone sets
-the foreground color, and on_color sets the background color.
-
-Note that not all attributes are supported by all terminal types, and some
-terminals may not support any of these sequences. Dark, blink, and
-concealed in particular are frequently not implemented.
-
-Attributes, once set, last until they are unset (by sending the attribute
-"reset"). Be careful to do this, or otherwise your attribute will last
-after your script is done running, and people get very annoyed at having
-their prompt and typing changed to weird colors.
-
-As an aid to help with this, colored() takes a scalar as the first argument
-and any number of attribute strings as the second argument and returns the
-scalar wrapped in escape codes so that the attributes will be set as
-requested before the string and reset to normal after the string.
-Alternately, you can pass a reference to an array as the first argument, and
-then the contents of that array will be taken as attributes and color codes
-and the remainder of the arguments as text to colorize.
-
-Normally, colored() just puts attribute codes at the beginning and end of
-the string, but if you set $Term::ANSIColor::EACHLINE to some string, that
-string will be considered the line delimiter and the attribute will be set
-at the beginning of each line of the passed string and reset at the end of
-each line. This is often desirable if the output is being sent to a program
-like a pager that can be confused by attributes that span lines. Normally
-you'll want to set $Term::ANSIColor::EACHLINE to C<"\n"> to use this
-feature.
-
-Alternately, if you import C<:constants>, you can use the constants CLEAR,
-RESET, BOLD, DARK, UNDERLINE, UNDERSCORE, BLINK, REVERSE, CONCEALED, BLACK,
-RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE, ON_BLACK, ON_RED, ON_GREEN,
-ON_YELLOW, ON_BLUE, ON_MAGENTA, ON_CYAN, and ON_WHITE directly. These are
-the same as color('attribute') and can be used if you prefer typing:
-
- print BOLD BLUE ON_WHITE "Text\n", RESET;
-
-to
-
- print colored ("Text\n", 'bold blue on_white');
-
-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 afterwards, whereas:
-
- print BOLD, BLUE, "Text\n";
-
-will not.
-
-The subroutine interface has the advantage over the constants interface in
-that only two subroutines are exported into your namespace, versus
-twenty-two in the constants interface. On the flip side, the constants
-interface has the advantage of better compile time error checking, since
-misspelled names of colors or attributes in calls to color() and colored()
-won't be caught until runtime whereas misspelled names of constants will be
-caught at compile time. So, polute 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.
-
-=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.)
-
-For easier debuging, you may prefer to always use the commas when not
-setting $Term::ANSIColor::AUTORESET 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-48 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 dark under blink reverse conceal
- ------------------------------------------------------------------------
- xterm yes yes no yes bold yes yes
- linux yes yes yes bold yes yes no
- rxvt yes yes no yes bold/black yes no
- dtterm yes yes yes yes reverse yes yes
- teraterm yes reverse no yes rev/red yes no
- aixterm kinda normal no yes no yes yes
- PuTTY yes color no yes no yes no
- Windows yes no no no no yes no
- Cygwin SSH yes yes no color color color yes
- Mac Terminal yes yes no yes yes yes yes
-
-Windows is Windows telnet, Cygwin SSH is the OpenSSH implementation under
-Cygwin on Windows NT, and Mac Terminal is the Terminal application in Mac OS
-X. Where the entry is other than yes or no, that emulator displays the
-given attribute as something else instead. Note that on an aixterm, clear
-doesn't reset colors; you have to explicitly set the colors back to what you
-want. More entries in this table are welcome.
-
-Note that codes 3 (italic), 6 (rapid blink), and 9 (strikethrough) 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 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.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Term/Cap.pm b/Master/tlpkg/installer/perllib/Term/Cap.pm
deleted file mode 100644
index b71c51ceba4..00000000000
--- a/Master/tlpkg/installer/perllib/Term/Cap.pm
+++ /dev/null
@@ -1,669 +0,0 @@
-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.09';
-
-# 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.
-
-# TODO:
-# support Berkeley DB termcaps
-# should probably be a .xs module
-# 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,
- $ENV{'HOME'} . '/.termcap',
- '/etc/termcap',
- '/usr/share/misc/termcap',
- );
- }
-
- # return the list of those termcaps that exist
- return grep(-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};
- }
-
- $self->{TERM} = ($self->{TERM} || $ENV{TERM} || 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;
- }
- };
- }
- }
- }
-
- 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;
- 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/installer/perllib/Term/Complete.pm b/Master/tlpkg/installer/perllib/Term/Complete.pm
deleted file mode 100644
index 601e4956430..00000000000
--- a/Master/tlpkg/installer/perllib/Term/Complete.pm
+++ /dev/null
@@ -1,188 +0,0 @@
-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/installer/perllib/Term/ReadLine.pm b/Master/tlpkg/installer/perllib/Term/ReadLine.pm
deleted file mode 100644
index 48eb9911a6f..00000000000
--- a/Master/tlpkg/installer/perllib/Term/ReadLine.pm
+++ /dev/null
@@ -1,399 +0,0 @@
-=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 = new Term::ReadLine '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 = new Term::ReadLine '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;
-
- if ($^O eq 'MacOS') {
- $console = "Dev:Console";
- } elsif (-e "/dev/tty") {
- $console = "/dev/tty";
- } elsif (-e "con" or $^O eq 'MSWin32') {
- $console = "con";
- } 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";
- }
- }
-
- my $consoleOUT = $console;
- $console = "&STDIN" unless defined $console;
- if (!defined $consoleOUT) {
- $consoleOUT = defined fileno(STDERR) ? "&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;
-
- open(FIN, "<$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 }
-
-package Term::ReadLine; # So late to allow the above code be defined?
-
-our $VERSION = '1.02';
-
-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/installer/perllib/Text/Abbrev.pm b/Master/tlpkg/installer/perllib/Text/Abbrev.pm
deleted file mode 100644
index c6be63bcc60..00000000000
--- a/Master/tlpkg/installer/perllib/Text/Abbrev.pm
+++ /dev/null
@@ -1,84 +0,0 @@
-package Text::Abbrev;
-require 5.005; # Probably works on earlier versions too.
-require Exporter;
-
-our $VERSION = '1.01';
-
-=head1 NAME
-
-abbrev - create an abbreviation table from a list
-
-=head1 SYNOPSIS
-
- use Text::Abbrev;
- abbrev $hashref, LIST
-
-
-=head1 DESCRIPTION
-
-Stores all unambiguous truncations of each element of LIST
-as keys in the associative array referenced by C<$hashref>.
-The values are the original list elements.
-
-=head1 EXAMPLE
-
- $hashref = abbrev qw(list edit send abort gripe);
-
- %hash = abbrev qw(list edit send abort gripe);
-
- abbrev $hashref, qw(list edit send abort gripe);
-
- abbrev(*hash, qw(list edit send abort gripe));
-
-=cut
-
-@ISA = qw(Exporter);
-@EXPORT = qw(abbrev);
-
-# Usage:
-# abbrev \%foo, LIST;
-# ...
-# $long = $foo{$short};
-
-sub abbrev {
- my ($word, $hashref, $glob, %table, $returnvoid);
-
- @_ or return; # So we don't autovivify onto @_ and trigger warning
- if (ref($_[0])) { # hash reference preferably
- $hashref = shift;
- $returnvoid = 1;
- } elsif (ref \$_[0] eq 'GLOB') { # is actually a glob (deprecated)
- $hashref = \%{shift()};
- $returnvoid = 1;
- }
- %{$hashref} = ();
-
- WORD: foreach $word (@_) {
- for (my $len = (length $word) - 1; $len > 0; --$len) {
- my $abbrev = substr($word,0,$len);
- my $seen = ++$table{$abbrev};
- if ($seen == 1) { # We're the first word so far to have
- # this abbreviation.
- $hashref->{$abbrev} = $word;
- } elsif ($seen == 2) { # We're the second word to have this
- # abbreviation, so we can't use it.
- delete $hashref->{$abbrev};
- } else { # We're the third word to have this
- # abbreviation, so skip to the next word.
- next WORD;
- }
- }
- }
- # Non-abbreviations always get entered, even if they aren't unique
- foreach $word (@_) {
- $hashref->{$word} = $word;
- }
- return if $returnvoid;
- if (wantarray) {
- %{$hashref};
- } else {
- $hashref;
- }
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/Text/Balanced.pm b/Master/tlpkg/installer/perllib/Text/Balanced.pm
deleted file mode 100644
index 820ae255a71..00000000000
--- a/Master/tlpkg/installer/perllib/Text/Balanced.pm
+++ /dev/null
@@ -1,2302 +0,0 @@
-# EXTRACT VARIOUSLY DELIMITED TEXT SEQUENCES FROM STRINGS.
-# FOR FULL DOCUMENTATION SEE Balanced.pod
-
-use 5.005;
-use strict;
-
-package Text::Balanced;
-
-use Exporter;
-use SelfLoader;
-use vars qw { $VERSION @ISA %EXPORT_TAGS };
-
-$VERSION = '1.95';
-@ISA = qw ( Exporter );
-
-%EXPORT_TAGS = ( ALL => [ qw(
- &extract_delimited
- &extract_bracketed
- &extract_quotelike
- &extract_codeblock
- &extract_variable
- &extract_tagged
- &extract_multiple
-
- &gen_delimited_pat
- &gen_extract_tagged
-
- &delimited_pat
- ) ] );
-
-Exporter::export_ok_tags('ALL');
-
-# PROTOTYPES
-
-sub _match_bracketed($$$$$$);
-sub _match_variable($$);
-sub _match_codeblock($$$$$$$);
-sub _match_quotelike($$$$);
-
-# HANDLE RETURN VALUES IN VARIOUS CONTEXTS
-
-sub _failmsg {
- my ($message, $pos) = @_;
- $@ = bless { error=>$message, pos=>$pos }, "Text::Balanced::ErrorMsg";
-}
-
-sub _fail
-{
- my ($wantarray, $textref, $message, $pos) = @_;
- _failmsg $message, $pos if $message;
- return ("",$$textref,"") if $wantarray;
- return undef;
-}
-
-sub _succeed
-{
- $@ = undef;
- my ($wantarray,$textref) = splice @_, 0, 2;
- my ($extrapos, $extralen) = @_>18 ? splice(@_, -2, 2) : (0,0);
- my ($startlen) = $_[5];
- my $remainderpos = $_[2];
- if ($wantarray)
- {
- my @res;
- while (my ($from, $len) = splice @_, 0, 2)
- {
- push @res, substr($$textref,$from,$len);
- }
- if ($extralen) { # CORRECT FILLET
- my $extra = substr($res[0], $extrapos-$startlen, $extralen, "\n");
- $res[1] = "$extra$res[1]";
- eval { substr($$textref,$remainderpos,0) = $extra;
- substr($$textref,$extrapos,$extralen,"\n")} ;
- #REARRANGE HERE DOC AND FILLET IF POSSIBLE
- pos($$textref) = $remainderpos-$extralen+1; # RESET \G
- }
- else {
- pos($$textref) = $remainderpos; # RESET \G
- }
- return @res;
- }
- else
- {
- my $match = substr($$textref,$_[0],$_[1]);
- substr($match,$extrapos-$_[0]-$startlen,$extralen,"") if $extralen;
- my $extra = $extralen
- ? substr($$textref, $extrapos, $extralen)."\n" : "";
- eval {substr($$textref,$_[4],$_[1]+$_[5])=$extra} ; #CHOP OUT PREFIX & MATCH, IF POSSIBLE
- pos($$textref) = $_[4]; # RESET \G
- return $match;
- }
-}
-
-# BUILD A PATTERN MATCHING A SIMPLE DELIMITED STRING
-
-sub gen_delimited_pat($;$) # ($delimiters;$escapes)
-{
- my ($dels, $escs) = @_;
- return "" unless $dels =~ /\S/;
- $escs = '\\' unless $escs;
- $escs .= substr($escs,-1) x (length($dels)-length($escs));
- my @pat = ();
- my $i;
- for ($i=0; $i<length $dels; $i++)
- {
- my $del = quotemeta substr($dels,$i,1);
- my $esc = quotemeta substr($escs,$i,1);
- if ($del eq $esc)
- {
- push @pat, "$del(?:[^$del]*(?:(?:$del$del)[^$del]*)*)$del";
- }
- else
- {
- push @pat, "$del(?:[^$esc$del]*(?:$esc.[^$esc$del]*)*)$del";
- }
- }
- my $pat = join '|', @pat;
- return "(?:$pat)";
-}
-
-*delimited_pat = \&gen_delimited_pat;
-
-
-# THE EXTRACTION FUNCTIONS
-
-sub extract_delimited (;$$$$)
-{
- my $textref = defined $_[0] ? \$_[0] : \$_;
- my $wantarray = wantarray;
- my $del = defined $_[1] ? $_[1] : qq{\'\"\`};
- my $pre = defined $_[2] ? $_[2] : '\s*';
- my $esc = defined $_[3] ? $_[3] : qq{\\};
- my $pat = gen_delimited_pat($del, $esc);
- my $startpos = pos $$textref || 0;
- return _fail($wantarray, $textref, "Not a delimited pattern", 0)
- unless $$textref =~ m/\G($pre)($pat)/gc;
- my $prelen = length($1);
- my $matchpos = $startpos+$prelen;
- my $endpos = pos $$textref;
- return _succeed $wantarray, $textref,
- $matchpos, $endpos-$matchpos, # MATCH
- $endpos, length($$textref)-$endpos, # REMAINDER
- $startpos, $prelen; # PREFIX
-}
-
-sub extract_bracketed (;$$$)
-{
- my $textref = defined $_[0] ? \$_[0] : \$_;
- my $ldel = defined $_[1] ? $_[1] : '{([<';
- my $pre = defined $_[2] ? $_[2] : '\s*';
- my $wantarray = wantarray;
- my $qdel = "";
- my $quotelike;
- $ldel =~ s/'//g and $qdel .= q{'};
- $ldel =~ s/"//g and $qdel .= q{"};
- $ldel =~ s/`//g and $qdel .= q{`};
- $ldel =~ s/q//g and $quotelike = 1;
- $ldel =~ tr/[](){}<>\0-\377/[[(({{<</ds;
- my $rdel = $ldel;
- unless ($rdel =~ tr/[({</])}>/)
- {
- return _fail $wantarray, $textref,
- "Did not find a suitable bracket in delimiter: \"$_[1]\"",
- 0;
- }
- my $posbug = pos;
- $ldel = join('|', map { quotemeta $_ } split('', $ldel));
- $rdel = join('|', map { quotemeta $_ } split('', $rdel));
- pos = $posbug;
-
- my $startpos = pos $$textref || 0;
- my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel);
-
- return _fail ($wantarray, $textref) unless @match;
-
- return _succeed ( $wantarray, $textref,
- $match[2], $match[5]+2, # MATCH
- @match[8,9], # REMAINDER
- @match[0,1], # PREFIX
- );
-}
-
-sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rdel
-{
- my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_;
- my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0);
- unless ($$textref =~ m/\G$pre/gc)
- {
- _failmsg "Did not find prefix: /$pre/", $startpos;
- return;
- }
-
- $ldelpos = pos $$textref;
-
- unless ($$textref =~ m/\G($ldel)/gc)
- {
- _failmsg "Did not find opening bracket after prefix: \"$pre\"",
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
-
- my @nesting = ( $1 );
- my $textlen = length $$textref;
- while (pos $$textref < $textlen)
- {
- next if $$textref =~ m/\G\\./gcs;
-
- if ($$textref =~ m/\G($ldel)/gc)
- {
- push @nesting, $1;
- }
- elsif ($$textref =~ m/\G($rdel)/gc)
- {
- my ($found, $brackettype) = ($1, $1);
- if ($#nesting < 0)
- {
- _failmsg "Unmatched closing bracket: \"$found\"",
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- my $expected = pop(@nesting);
- $expected =~ tr/({[</)}]>/;
- if ($expected ne $brackettype)
- {
- _failmsg qq{Mismatched closing bracket: expected "$expected" but found "$found"},
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- last if $#nesting < 0;
- }
- elsif ($qdel && $$textref =~ m/\G([$qdel])/gc)
- {
- $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next;
- _failmsg "Unmatched embedded quote ($1)",
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- elsif ($quotelike && _match_quotelike($textref,"",1,0))
- {
- next;
- }
-
- else { $$textref =~ m/\G(?:[a-zA-Z0-9]+|.)/gcs }
- }
- if ($#nesting>=0)
- {
- _failmsg "Unmatched opening bracket(s): "
- . join("..",@nesting)."..",
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
-
- $endpos = pos $$textref;
-
- return (
- $startpos, $ldelpos-$startpos, # PREFIX
- $ldelpos, 1, # OPENING BRACKET
- $ldelpos+1, $endpos-$ldelpos-2, # CONTENTS
- $endpos-1, 1, # CLOSING BRACKET
- $endpos, length($$textref)-$endpos, # REMAINDER
- );
-}
-
-sub revbracket($)
-{
- my $brack = reverse $_[0];
- $brack =~ tr/[({</])}>/;
- return $brack;
-}
-
-my $XMLNAME = q{[a-zA-Z_:][a-zA-Z0-9_:.-]*};
-
-sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options)
-{
- my $textref = defined $_[0] ? \$_[0] : \$_;
- my $ldel = $_[1];
- my $rdel = $_[2];
- my $pre = defined $_[3] ? $_[3] : '\s*';
- my %options = defined $_[4] ? %{$_[4]} : ();
- my $omode = defined $options{fail} ? $options{fail} : '';
- my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}})
- : defined($options{reject}) ? $options{reject}
- : ''
- ;
- my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}})
- : defined($options{ignore}) ? $options{ignore}
- : ''
- ;
-
- if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; }
- $@ = undef;
-
- my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);
-
- return _fail(wantarray, $textref) unless @match;
- return _succeed wantarray, $textref,
- $match[2], $match[3]+$match[5]+$match[7], # MATCH
- @match[8..9,0..1,2..7]; # REM, PRE, BITS
-}
-
-sub _match_tagged # ($$$$$$$)
-{
- my ($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore) = @_;
- my $rdelspec;
-
- my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 );
-
- unless ($$textref =~ m/\G($pre)/gc)
- {
- _failmsg "Did not find prefix: /$pre/", pos $$textref;
- goto failed;
- }
-
- $opentagpos = pos($$textref);
-
- unless ($$textref =~ m/\G$ldel/gc)
- {
- _failmsg "Did not find opening tag: /$ldel/", pos $$textref;
- goto failed;
- }
-
- $textpos = pos($$textref);
-
- if (!defined $rdel)
- {
- $rdelspec = $&;
- unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2". revbracket($1) /oes)
- {
- _failmsg "Unable to construct closing tag to match: $rdel",
- pos $$textref;
- goto failed;
- }
- }
- else
- {
- $rdelspec = eval "qq{$rdel}" || do {
- my $del;
- for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',)
- { next if $rdel =~ /\Q$_/; $del = $_; last }
- unless ($del) {
- use Carp;
- croak "Can't interpolate right delimiter $rdel"
- }
- eval "qq$del$rdel$del";
- };
- }
-
- while (pos($$textref) < length($$textref))
- {
- next if $$textref =~ m/\G\\./gc;
-
- if ($$textref =~ m/\G(\n[ \t]*\n)/gc )
- {
- $parapos = pos($$textref) - length($1)
- unless defined $parapos;
- }
- elsif ($$textref =~ m/\G($rdelspec)/gc )
- {
- $closetagpos = pos($$textref)-length($1);
- goto matched;
- }
- elsif ($ignore && $$textref =~ m/\G(?:$ignore)/gc)
- {
- next;
- }
- elsif ($bad && $$textref =~ m/\G($bad)/gcs)
- {
- pos($$textref) -= length($1); # CUT OFF WHATEVER CAUSED THE SHORTNESS
- goto short if ($omode eq 'PARA' || $omode eq 'MAX');
- _failmsg "Found invalid nested tag: $1", pos $$textref;
- goto failed;
- }
- elsif ($$textref =~ m/\G($ldel)/gc)
- {
- my $tag = $1;
- pos($$textref) -= length($tag); # REWIND TO NESTED TAG
- unless (_match_tagged(@_)) # MATCH NESTED TAG
- {
- goto short if $omode eq 'PARA' || $omode eq 'MAX';
- _failmsg "Found unbalanced nested tag: $tag",
- pos $$textref;
- goto failed;
- }
- }
- else { $$textref =~ m/./gcs }
- }
-
-short:
- $closetagpos = pos($$textref);
- goto matched if $omode eq 'MAX';
- goto failed unless $omode eq 'PARA';
-
- if (defined $parapos) { pos($$textref) = $parapos }
- else { $parapos = pos($$textref) }
-
- return (
- $startpos, $opentagpos-$startpos, # PREFIX
- $opentagpos, $textpos-$opentagpos, # OPENING TAG
- $textpos, $parapos-$textpos, # TEXT
- $parapos, 0, # NO CLOSING TAG
- $parapos, length($$textref)-$parapos, # REMAINDER
- );
-
-matched:
- $endpos = pos($$textref);
- return (
- $startpos, $opentagpos-$startpos, # PREFIX
- $opentagpos, $textpos-$opentagpos, # OPENING TAG
- $textpos, $closetagpos-$textpos, # TEXT
- $closetagpos, $endpos-$closetagpos, # CLOSING TAG
- $endpos, length($$textref)-$endpos, # REMAINDER
- );
-
-failed:
- _failmsg "Did not find closing tag", pos $$textref unless $@;
- pos($$textref) = $startpos;
- return;
-}
-
-sub extract_variable (;$$)
-{
- my $textref = defined $_[0] ? \$_[0] : \$_;
- return ("","","") unless defined $$textref;
- my $pre = defined $_[1] ? $_[1] : '\s*';
-
- my @match = _match_variable($textref,$pre);
-
- return _fail wantarray, $textref unless @match;
-
- return _succeed wantarray, $textref,
- @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX
-}
-
-sub _match_variable($$)
-{
-# $#
-# $^
-# $$
- my ($textref, $pre) = @_;
- my $startpos = pos($$textref) = pos($$textref)||0;
- unless ($$textref =~ m/\G($pre)/gc)
- {
- _failmsg "Did not find prefix: /$pre/", pos $$textref;
- return;
- }
- my $varpos = pos($$textref);
- unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci)
- {
- unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc)
- {
- _failmsg "Did not find leading dereferencer", pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- my $deref = $1;
-
- unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci
- or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0)
- or $deref eq '$#' or $deref eq '$$' )
- {
- _failmsg "Bad identifier after dereferencer", pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- }
-
- while (1)
- {
- next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc;
- next if _match_codeblock($textref,
- qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/,
- qr/[({[]/, qr/[)}\]]/,
- qr/[({[]/, qr/[)}\]]/, 0);
- next if _match_codeblock($textref,
- qr/\s*/, qr/[{[]/, qr/[}\]]/,
- qr/[{[]/, qr/[}\]]/, 0);
- next if _match_variable($textref,'\s*->\s*');
- next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc;
- last;
- }
-
- my $endpos = pos($$textref);
- return ($startpos, $varpos-$startpos,
- $varpos, $endpos-$varpos,
- $endpos, length($$textref)-$endpos
- );
-}
-
-sub extract_codeblock (;$$$$$)
-{
- my $textref = defined $_[0] ? \$_[0] : \$_;
- my $wantarray = wantarray;
- my $ldel_inner = defined $_[1] ? $_[1] : '{';
- my $pre = defined $_[2] ? $_[2] : '\s*';
- my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner;
- my $rd = $_[4];
- my $rdel_inner = $ldel_inner;
- my $rdel_outer = $ldel_outer;
- my $posbug = pos;
- for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds }
- for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds }
- for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer)
- {
- $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')'
- }
- pos = $posbug;
-
- my @match = _match_codeblock($textref, $pre,
- $ldel_outer, $rdel_outer,
- $ldel_inner, $rdel_inner,
- $rd);
- return _fail($wantarray, $textref) unless @match;
- return _succeed($wantarray, $textref,
- @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX
- );
-
-}
-
-sub _match_codeblock($$$$$$$)
-{
- my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_;
- my $startpos = pos($$textref) = pos($$textref) || 0;
- unless ($$textref =~ m/\G($pre)/gc)
- {
- _failmsg qq{Did not match prefix /$pre/ at"} .
- substr($$textref,pos($$textref),20) .
- q{..."},
- pos $$textref;
- return;
- }
- my $codepos = pos($$textref);
- unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER
- {
- _failmsg qq{Did not find expected opening bracket at "} .
- substr($$textref,pos($$textref),20) .
- q{..."},
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- my $closing = $1;
- $closing =~ tr/([<{/)]>}/;
- my $matched;
- my $patvalid = 1;
- while (pos($$textref) < length($$textref))
- {
- $matched = '';
- if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc)
- {
- $patvalid = 0;
- next;
- }
-
- if ($$textref =~ m/\G\s*#.*/gc)
- {
- next;
- }
-
- if ($$textref =~ m/\G\s*($rdel_outer)/gc)
- {
- unless ($matched = ($closing && $1 eq $closing) )
- {
- next if $1 eq '>'; # MIGHT BE A "LESS THAN"
- _failmsg q{Mismatched closing bracket at "} .
- substr($$textref,pos($$textref),20) .
- qq{...". Expected '$closing'},
- pos $$textref;
- }
- last;
- }
-
- if (_match_variable($textref,'\s*') ||
- _match_quotelike($textref,'\s*',$patvalid,$patvalid) )
- {
- $patvalid = 0;
- next;
- }
-
-
- # NEED TO COVER MANY MORE CASES HERE!!!
- if ($$textref =~ m#\G\s*(?!$ldel_inner)
- ( [-+*x/%^&|.]=?
- | [!=]~
- | =(?!>)
- | (\*\*|&&|\|\||<<|>>)=?
- | split|grep|map|return
- | [([]
- )#gcx)
- {
- $patvalid = 1;
- next;
- }
-
- if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) )
- {
- $patvalid = 1;
- next;
- }
-
- if ($$textref =~ m/\G\s*$ldel_outer/gc)
- {
- _failmsg q{Improperly nested codeblock at "} .
- substr($$textref,pos($$textref),20) .
- q{..."},
- pos $$textref;
- last;
- }
-
- $patvalid = 0;
- $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc;
- }
- continue { $@ = undef }
-
- unless ($matched)
- {
- _failmsg 'No match found for opening bracket', pos $$textref
- unless $@;
- return;
- }
-
- my $endpos = pos($$textref);
- return ( $startpos, $codepos-$startpos,
- $codepos, $endpos-$codepos,
- $endpos, length($$textref)-$endpos,
- );
-}
-
-
-my %mods = (
- 'none' => '[cgimsox]*',
- 'm' => '[cgimsox]*',
- 's' => '[cegimsox]*',
- 'tr' => '[cds]*',
- 'y' => '[cds]*',
- 'qq' => '',
- 'qx' => '',
- 'qw' => '',
- 'qr' => '[imsx]*',
- 'q' => '',
- );
-
-sub extract_quotelike (;$$)
-{
- my $textref = $_[0] ? \$_[0] : \$_;
- my $wantarray = wantarray;
- my $pre = defined $_[1] ? $_[1] : '\s*';
-
- my @match = _match_quotelike($textref,$pre,1,0);
- return _fail($wantarray, $textref) unless @match;
- return _succeed($wantarray, $textref,
- $match[2], $match[18]-$match[2], # MATCH
- @match[18,19], # REMAINDER
- @match[0,1], # PREFIX
- @match[2..17], # THE BITS
- @match[20,21], # ANY FILLET?
- );
-};
-
-sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match)
-{
- my ($textref, $pre, $rawmatch, $qmark) = @_;
-
- my ($textlen,$startpos,
- $oppos,
- $preld1pos,$ld1pos,$str1pos,$rd1pos,
- $preld2pos,$ld2pos,$str2pos,$rd2pos,
- $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 );
-
- unless ($$textref =~ m/\G($pre)/gc)
- {
- _failmsg qq{Did not find prefix /$pre/ at "} .
- substr($$textref, pos($$textref), 20) .
- q{..."},
- pos $$textref;
- return;
- }
- $oppos = pos($$textref);
-
- my $initial = substr($$textref,$oppos,1);
-
- if ($initial && $initial =~ m|^[\"\'\`]|
- || $rawmatch && $initial =~ m|^/|
- || $qmark && $initial =~ m|^\?|)
- {
- unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx)
- {
- _failmsg qq{Did not find closing delimiter to match '$initial' at "} .
- substr($$textref, $oppos, 20) .
- q{..."},
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- $modpos= pos($$textref);
- $rd1pos = $modpos-1;
-
- if ($initial eq '/' || $initial eq '?')
- {
- $$textref =~ m/\G$mods{none}/gc
- }
-
- my $endpos = pos($$textref);
- return (
- $startpos, $oppos-$startpos, # PREFIX
- $oppos, 0, # NO OPERATOR
- $oppos, 1, # LEFT DEL
- $oppos+1, $rd1pos-$oppos-1, # STR/PAT
- $rd1pos, 1, # RIGHT DEL
- $modpos, 0, # NO 2ND LDEL
- $modpos, 0, # NO 2ND STR
- $modpos, 0, # NO 2ND RDEL
- $modpos, $endpos-$modpos, # MODIFIERS
- $endpos, $textlen-$endpos, # REMAINDER
- );
- }
-
- unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc)
- {
- _failmsg q{No quotelike operator found after prefix at "} .
- substr($$textref, pos($$textref), 20) .
- q{..."},
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
-
- my $op = $1;
- $preld1pos = pos($$textref);
- if ($op eq '<<') {
- $ld1pos = pos($$textref);
- my $label;
- if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) {
- $label = $1;
- }
- elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) '
- | \G " ([^"\\]* (?:\\.[^"\\]*)*) "
- | \G ` ([^`\\]* (?:\\.[^`\\]*)*) `
- }gcsx) {
- $label = $+;
- }
- else {
- $label = "";
- }
- my $extrapos = pos($$textref);
- $$textref =~ m{.*\n}gc;
- $str1pos = pos($$textref);
- unless ($$textref =~ m{.*?\n(?=$label\n)}gc) {
- _failmsg qq{Missing here doc terminator ('$label') after "} .
- substr($$textref, $startpos, 20) .
- q{..."},
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- $rd1pos = pos($$textref);
- $$textref =~ m{$label\n}gc;
- $ld2pos = pos($$textref);
- return (
- $startpos, $oppos-$startpos, # PREFIX
- $oppos, length($op), # OPERATOR
- $ld1pos, $extrapos-$ld1pos, # LEFT DEL
- $str1pos, $rd1pos-$str1pos, # STR/PAT
- $rd1pos, $ld2pos-$rd1pos, # RIGHT DEL
- $ld2pos, 0, # NO 2ND LDEL
- $ld2pos, 0, # NO 2ND STR
- $ld2pos, 0, # NO 2ND RDEL
- $ld2pos, 0, # NO MODIFIERS
- $ld2pos, $textlen-$ld2pos, # REMAINDER
- $extrapos, $str1pos-$extrapos, # FILLETED BIT
- );
- }
-
- $$textref =~ m/\G\s*/gc;
- $ld1pos = pos($$textref);
- $str1pos = $ld1pos+1;
-
- unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD
- {
- _failmsg "No block delimiter found after quotelike $op",
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN
- my ($ldel1, $rdel1) = ("\Q$1","\Q$1");
- if ($ldel1 =~ /[[(<{]/)
- {
- $rdel1 =~ tr/[({</])}>/;
- _match_bracketed($textref,"",$ldel1,"","",$rdel1)
- || do { pos $$textref = $startpos; return };
- }
- else
- {
- $$textref =~ /$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs
- || do { pos $$textref = $startpos; return };
- }
- $ld2pos = $rd1pos = pos($$textref)-1;
-
- my $second_arg = $op =~ /s|tr|y/ ? 1 : 0;
- if ($second_arg)
- {
- my ($ldel2, $rdel2);
- if ($ldel1 =~ /[[(<{]/)
- {
- unless ($$textref =~ /\G\s*(\S)/gc) # SHOULD USE LOOKAHEAD
- {
- _failmsg "Missing second block for quotelike $op",
- pos $$textref;
- pos $$textref = $startpos;
- return;
- }
- $ldel2 = $rdel2 = "\Q$1";
- $rdel2 =~ tr/[({</])}>/;
- }
- else
- {
- $ldel2 = $rdel2 = $ldel1;
- }
- $str2pos = $ld2pos+1;
-
- if ($ldel2 =~ /[[(<{]/)
- {
- pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD
- _match_bracketed($textref,"",$ldel2,"","",$rdel2)
- || do { pos $$textref = $startpos; return };
- }
- else
- {
- $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs
- || do { pos $$textref = $startpos; return };
- }
- $rd2pos = pos($$textref)-1;
- }
- else
- {
- $ld2pos = $str2pos = $rd2pos = $rd1pos;
- }
-
- $modpos = pos $$textref;
-
- $$textref =~ m/\G($mods{$op})/gc;
- my $endpos = pos $$textref;
-
- return (
- $startpos, $oppos-$startpos, # PREFIX
- $oppos, length($op), # OPERATOR
- $ld1pos, 1, # LEFT DEL
- $str1pos, $rd1pos-$str1pos, # STR/PAT
- $rd1pos, 1, # RIGHT DEL
- $ld2pos, $second_arg, # 2ND LDEL (MAYBE)
- $str2pos, $rd2pos-$str2pos, # 2ND STR (MAYBE)
- $rd2pos, $second_arg, # 2ND RDEL (MAYBE)
- $modpos, $endpos-$modpos, # MODIFIERS
- $endpos, $textlen-$endpos, # REMAINDER
- );
-}
-
-my $def_func =
-[
- sub { extract_variable($_[0], '') },
- sub { extract_quotelike($_[0],'') },
- sub { extract_codeblock($_[0],'{}','') },
-];
-
-sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown)
-{
- my $textref = defined($_[0]) ? \$_[0] : \$_;
- my $posbug = pos;
- my ($lastpos, $firstpos);
- my @fields = ();
-
- #for ($$textref)
- {
- my @func = defined $_[1] ? @{$_[1]} : @{$def_func};
- my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000;
- my $igunk = $_[3];
-
- pos $$textref ||= 0;
-
- unless (wantarray)
- {
- use Carp;
- carp "extract_multiple reset maximal count to 1 in scalar context"
- if $^W && defined($_[2]) && $max > 1;
- $max = 1
- }
-
- my $unkpos;
- my $func;
- my $class;
-
- my @class;
- foreach $func ( @func )
- {
- if (ref($func) eq 'HASH')
- {
- push @class, (keys %$func)[0];
- $func = (values %$func)[0];
- }
- else
- {
- push @class, undef;
- }
- }
-
- FIELD: while (pos($$textref) < length($$textref))
- {
- my ($field, $rem);
- my @bits;
- foreach my $i ( 0..$#func )
- {
- my $pref;
- $func = $func[$i];
- $class = $class[$i];
- $lastpos = pos $$textref;
- if (ref($func) eq 'CODE')
- { ($field,$rem,$pref) = @bits = $func->($$textref);
- # print "[$field|$rem]" if $field;
- }
- elsif (ref($func) eq 'Text::Balanced::Extractor')
- { @bits = $field = $func->extract($$textref) }
- elsif( $$textref =~ m/\G$func/gc )
- { @bits = $field = defined($1) ? $1 : $& }
- $pref ||= "";
- if (defined($field) && length($field))
- {
- if (!$igunk) {
- $unkpos = pos $$textref
- if length($pref) && !defined($unkpos);
- if (defined $unkpos)
- {
- push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref;
- $firstpos = $unkpos unless defined $firstpos;
- undef $unkpos;
- last FIELD if @fields == $max;
- }
- }
- push @fields, $class
- ? bless (\$field, $class)
- : $field;
- $firstpos = $lastpos unless defined $firstpos;
- $lastpos = pos $$textref;
- last FIELD if @fields == $max;
- next FIELD;
- }
- }
- if ($$textref =~ /\G(.)/gcs)
- {
- $unkpos = pos($$textref)-1
- unless $igunk || defined $unkpos;
- }
- }
-
- if (defined $unkpos)
- {
- push @fields, substr($$textref, $unkpos);
- $firstpos = $unkpos unless defined $firstpos;
- $lastpos = length $$textref;
- }
- last;
- }
-
- pos $$textref = $lastpos;
- return @fields if wantarray;
-
- $firstpos ||= 0;
- eval { substr($$textref,$firstpos,$lastpos-$firstpos)="";
- pos $$textref = $firstpos };
- return $fields[0];
-}
-
-
-sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options)
-{
- my $ldel = $_[0];
- my $rdel = $_[1];
- my $pre = defined $_[2] ? $_[2] : '\s*';
- my %options = defined $_[3] ? %{$_[3]} : ();
- my $omode = defined $options{fail} ? $options{fail} : '';
- my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}})
- : defined($options{reject}) ? $options{reject}
- : ''
- ;
- my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}})
- : defined($options{ignore}) ? $options{ignore}
- : ''
- ;
-
- if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; }
-
- my $posbug = pos;
- for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ }
- pos = $posbug;
-
- my $closure = sub
- {
- my $textref = defined $_[0] ? \$_[0] : \$_;
- my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);
-
- return _fail(wantarray, $textref) unless @match;
- return _succeed wantarray, $textref,
- $match[2], $match[3]+$match[5]+$match[7], # MATCH
- @match[8..9,0..1,2..7]; # REM, PRE, BITS
- };
-
- bless $closure, 'Text::Balanced::Extractor';
-}
-
-package Text::Balanced::Extractor;
-
-sub extract($$) # ($self, $text)
-{
- &{$_[0]}($_[1]);
-}
-
-package Text::Balanced::ErrorMsg;
-
-use overload '""' => sub { "$_[0]->{error}, detected at offset $_[0]->{pos}" };
-
-1;
-
-__END__
-
-=head1 NAME
-
-Text::Balanced - Extract delimited text sequences from strings.
-
-
-=head1 SYNOPSIS
-
- use Text::Balanced qw (
- extract_delimited
- extract_bracketed
- extract_quotelike
- extract_codeblock
- extract_variable
- extract_tagged
- extract_multiple
-
- gen_delimited_pat
- gen_extract_tagged
- );
-
- # Extract the initial substring of $text that is delimited by
- # two (unescaped) instances of the first character in $delim.
-
- ($extracted, $remainder) = extract_delimited($text,$delim);
-
-
- # Extract the initial substring of $text that is bracketed
- # with a delimiter(s) specified by $delim (where the string
- # in $delim contains one or more of '(){}[]<>').
-
- ($extracted, $remainder) = extract_bracketed($text,$delim);
-
-
- # Extract the initial substring of $text that is bounded by
- # an XML tag.
-
- ($extracted, $remainder) = extract_tagged($text);
-
-
- # Extract the initial substring of $text that is bounded by
- # a C<BEGIN>...C<END> pair. Don't allow nested C<BEGIN> tags
-
- ($extracted, $remainder) =
- extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]});
-
-
- # Extract the initial substring of $text that represents a
- # Perl "quote or quote-like operation"
-
- ($extracted, $remainder) = extract_quotelike($text);
-
-
- # Extract the initial substring of $text that represents a block
- # of Perl code, bracketed by any of character(s) specified by $delim
- # (where the string $delim contains one or more of '(){}[]<>').
-
- ($extracted, $remainder) = extract_codeblock($text,$delim);
-
-
- # Extract the initial substrings of $text that would be extracted by
- # one or more sequential applications of the specified functions
- # or regular expressions
-
- @extracted = extract_multiple($text,
- [ \&extract_bracketed,
- \&extract_quotelike,
- \&some_other_extractor_sub,
- qr/[xyz]*/,
- 'literal',
- ]);
-
-# Create a string representing an optimized pattern (a la Friedl)
-# that matches a substring delimited by any of the specified characters
-# (in this case: any type of quote or a slash)
-
- $patstring = gen_delimited_pat(q{'"`/});
-
-
-# Generate a reference to an anonymous sub that is just like extract_tagged
-# but pre-compiled and optimized for a specific pair of tags, and consequently
-# much faster (i.e. 3 times faster). It uses qr// for better performance on
-# repeated calls, so it only works under Perl 5.005 or later.
-
- $extract_head = gen_extract_tagged('<HEAD>','</HEAD>');
-
- ($extracted, $remainder) = $extract_head->($text);
-
-
-=head1 DESCRIPTION
-
-The various C<extract_...> subroutines may be used to
-extract a delimited substring, possibly after skipping a
-specified prefix string. By default, that prefix is
-optional whitespace (C</\s*/>), but you can change it to whatever
-you wish (see below).
-
-The substring to be extracted must appear at the
-current C<pos> location of the string's variable
-(or at index zero, if no C<pos> position is defined).
-In other words, the C<extract_...> subroutines I<don't>
-extract the first occurance of a substring anywhere
-in a string (like an unanchored regex would). Rather,
-they extract an occurance of the substring appearing
-immediately at the current matching position in the
-string (like a C<\G>-anchored regex would).
-
-
-
-=head2 General behaviour in list contexts
-
-In a list context, all the subroutines return a list, the first three
-elements of which are always:
-
-=over 4
-
-=item [0]
-
-The extracted string, including the specified delimiters.
-If the extraction fails an empty string is returned.
-
-=item [1]
-
-The remainder of the input string (i.e. the characters after the
-extracted string). On failure, the entire string is returned.
-
-=item [2]
-
-The skipped prefix (i.e. the characters before the extracted string).
-On failure, the empty string is returned.
-
-=back
-
-Note that in a list context, the contents of the original input text (the first
-argument) are not modified in any way.
-
-However, if the input text was passed in a variable, that variable's
-C<pos> value is updated to point at the first character after the
-extracted text. That means that in a list context the various
-subroutines can be used much like regular expressions. For example:
-
- while ( $next = (extract_quotelike($text))[0] )
- {
- # process next quote-like (in $next)
- }
-
-
-=head2 General behaviour in scalar and void contexts
-
-In a scalar context, the extracted string is returned, having first been
-removed from the input text. Thus, the following code also processes
-each quote-like operation, but actually removes them from $text:
-
- while ( $next = extract_quotelike($text) )
- {
- # process next quote-like (in $next)
- }
-
-Note that if the input text is a read-only string (i.e. a literal),
-no attempt is made to remove the extracted text.
-
-In a void context the behaviour of the extraction subroutines is
-exactly the same as in a scalar context, except (of course) that the
-extracted substring is not returned.
-
-=head2 A note about prefixes
-
-Prefix patterns are matched without any trailing modifiers (C</gimsox> etc.)
-This can bite you if you're expecting a prefix specification like
-'.*?(?=<H1>)' to skip everything up to the first <H1> tag. Such a prefix
-pattern will only succeed if the <H1> tag is on the current line, since
-. normally doesn't match newlines.
-
-To overcome this limitation, you need to turn on /s matching within
-the prefix pattern, using the C<(?s)> directive: '(?s).*?(?=<H1>)'
-
-
-=head2 C<extract_delimited>
-
-The C<extract_delimited> function formalizes the common idiom
-of extracting a single-character-delimited substring from the start of
-a string. For example, to extract a single-quote delimited string, the
-following code is typically used:
-
- ($remainder = $text) =~ s/\A('(\\.|[^'])*')//s;
- $extracted = $1;
-
-but with C<extract_delimited> it can be simplified to:
-
- ($extracted,$remainder) = extract_delimited($text, "'");
-
-C<extract_delimited> takes up to four scalars (the input text, the
-delimiters, a prefix pattern to be skipped, and any escape characters)
-and extracts the initial substring of the text that
-is appropriately delimited. If the delimiter string has multiple
-characters, the first one encountered in the text is taken to delimit
-the substring.
-The third argument specifies a prefix pattern that is to be skipped
-(but must be present!) before the substring is extracted.
-The final argument specifies the escape character to be used for each
-delimiter.
-
-All arguments are optional. If the escape characters are not specified,
-every delimiter is escaped with a backslash (C<\>).
-If the prefix is not specified, the
-pattern C<'\s*'> - optional whitespace - is used. If the delimiter set
-is also not specified, the set C</["'`]/> is used. If the text to be processed
-is not specified either, C<$_> is used.
-
-In list context, C<extract_delimited> returns a array of three
-elements, the extracted substring (I<including the surrounding
-delimiters>), the remainder of the text, and the skipped prefix (if
-any). If a suitable delimited substring is not found, the first
-element of the array is the empty string, the second is the complete
-original text, and the prefix returned in the third element is an
-empty string.
-
-In a scalar context, just the extracted substring is returned. In
-a void context, the extracted substring (and any prefix) are simply
-removed from the beginning of the first argument.
-
-Examples:
-
- # Remove a single-quoted substring from the very beginning of $text:
-
- $substring = extract_delimited($text, "'", '');
-
- # Remove a single-quoted Pascalish substring (i.e. one in which
- # doubling the quote character escapes it) from the very
- # beginning of $text:
-
- $substring = extract_delimited($text, "'", '', "'");
-
- # Extract a single- or double- quoted substring from the
- # beginning of $text, optionally after some whitespace
- # (note the list context to protect $text from modification):
-
- ($substring) = extract_delimited $text, q{"'};
-
-
- # Delete the substring delimited by the first '/' in $text:
-
- $text = join '', (extract_delimited($text,'/','[^/]*')[2,1];
-
-Note that this last example is I<not> the same as deleting the first
-quote-like pattern. For instance, if C<$text> contained the string:
-
- "if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }"
-
-then after the deletion it would contain:
-
- "if ('.$UNIXCMD/s) { $cmd = $1; }"
-
-not:
-
- "if ('./cmd' =~ ms) { $cmd = $1; }"
-
-
-See L<"extract_quotelike"> for a (partial) solution to this problem.
-
-
-=head2 C<extract_bracketed>
-
-Like C<"extract_delimited">, the C<extract_bracketed> function takes
-up to three optional scalar arguments: a string to extract from, a delimiter
-specifier, and a prefix pattern. As before, a missing prefix defaults to
-optional whitespace and a missing text defaults to C<$_>. However, a missing
-delimiter specifier defaults to C<'{}()[]E<lt>E<gt>'> (see below).
-
-C<extract_bracketed> extracts a balanced-bracket-delimited
-substring (using any one (or more) of the user-specified delimiter
-brackets: '(..)', '{..}', '[..]', or '<..>'). Optionally it will also
-respect quoted unbalanced brackets (see below).
-
-A "delimiter bracket" is a bracket in list of delimiters passed as
-C<extract_bracketed>'s second argument. Delimiter brackets are
-specified by giving either the left or right (or both!) versions
-of the required bracket(s). Note that the order in which
-two or more delimiter brackets are specified is not significant.
-
-A "balanced-bracket-delimited substring" is a substring bounded by
-matched brackets, such that any other (left or right) delimiter
-bracket I<within> the substring is also matched by an opposite
-(right or left) delimiter bracket I<at the same level of nesting>. Any
-type of bracket not in the delimiter list is treated as an ordinary
-character.
-
-In other words, each type of bracket specified as a delimiter must be
-balanced and correctly nested within the substring, and any other kind of
-("non-delimiter") bracket in the substring is ignored.
-
-For example, given the string:
-
- $text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }";
-
-then a call to C<extract_bracketed> in a list context:
-
- @result = extract_bracketed( $text, '{}' );
-
-would return:
-
- ( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" )
-
-since both sets of C<'{..}'> brackets are properly nested and evenly balanced.
-(In a scalar context just the first element of the array would be returned. In
-a void context, C<$text> would be replaced by an empty string.)
-
-Likewise the call in:
-
- @result = extract_bracketed( $text, '{[' );
-
-would return the same result, since all sets of both types of specified
-delimiter brackets are correctly nested and balanced.
-
-However, the call in:
-
- @result = extract_bracketed( $text, '{([<' );
-
-would fail, returning:
-
- ( undef , "{ an '[irregularly :-(] {} parenthesized >:-)' string }" );
-
-because the embedded pairs of C<'(..)'>s and C<'[..]'>s are "cross-nested" and
-the embedded C<'E<gt>'> is unbalanced. (In a scalar context, this call would
-return an empty string. In a void context, C<$text> would be unchanged.)
-
-Note that the embedded single-quotes in the string don't help in this
-case, since they have not been specified as acceptable delimiters and are
-therefore treated as non-delimiter characters (and ignored).
-
-However, if a particular species of quote character is included in the
-delimiter specification, then that type of quote will be correctly handled.
-for example, if C<$text> is:
-
- $text = '<A HREF=">>>>">link</A>';
-
-then
-
- @result = extract_bracketed( $text, '<">' );
-
-returns:
-
- ( '<A HREF=">>>>">', 'link</A>', "" )
-
-as expected. Without the specification of C<"> as an embedded quoter:
-
- @result = extract_bracketed( $text, '<>' );
-
-the result would be:
-
- ( '<A HREF=">', '>>>">link</A>', "" )
-
-In addition to the quote delimiters C<'>, C<">, and C<`>, full Perl quote-like
-quoting (i.e. q{string}, qq{string}, etc) can be specified by including the
-letter 'q' as a delimiter. Hence:
-
- @result = extract_bracketed( $text, '<q>' );
-
-would correctly match something like this:
-
- $text = '<leftop: conj /and/ conj>';
-
-See also: C<"extract_quotelike"> and C<"extract_codeblock">.
-
-
-=head2 C<extract_variable>
-
-C<extract_variable> extracts any valid Perl variable or
-variable-involved expression, including scalars, arrays, hashes, array
-accesses, hash look-ups, method calls through objects, subroutine calles
-through subroutine references, etc.
-
-The subroutine takes up to two optional arguments:
-
-=over 4
-
-=item 1.
-
-A string to be processed (C<$_> if the string is omitted or C<undef>)
-
-=item 2.
-
-A string specifying a pattern to be matched as a prefix (which is to be
-skipped). If omitted, optional whitespace is skipped.
-
-=back
-
-On success in a list context, an array of 3 elements is returned. The
-elements are:
-
-=over 4
-
-=item [0]
-
-the extracted variable, or variablish expression
-
-=item [1]
-
-the remainder of the input text,
-
-=item [2]
-
-the prefix substring (if any),
-
-=back
-
-On failure, all of these values (except the remaining text) are C<undef>.
-
-In a scalar context, C<extract_variable> returns just the complete
-substring that matched a variablish expression. C<undef> is returned on
-failure. In addition, the original input text has the returned substring
-(and any prefix) removed from it.
-
-In a void context, the input text just has the matched substring (and
-any specified prefix) removed.
-
-
-=head2 C<extract_tagged>
-
-C<extract_tagged> extracts and segments text between (balanced)
-specified tags.
-
-The subroutine takes up to five optional arguments:
-
-=over 4
-
-=item 1.
-
-A string to be processed (C<$_> if the string is omitted or C<undef>)
-
-=item 2.
-
-A string specifying a pattern to be matched as the opening tag.
-If the pattern string is omitted (or C<undef>) then a pattern
-that matches any standard XML tag is used.
-
-=item 3.
-
-A string specifying a pattern to be matched at the closing tag.
-If the pattern string is omitted (or C<undef>) then the closing
-tag is constructed by inserting a C</> after any leading bracket
-characters in the actual opening tag that was matched (I<not> the pattern
-that matched the tag). For example, if the opening tag pattern
-is specified as C<'{{\w+}}'> and actually matched the opening tag
-C<"{{DATA}}">, then the constructed closing tag would be C<"{{/DATA}}">.
-
-=item 4.
-
-A string specifying a pattern to be matched as a prefix (which is to be
-skipped). If omitted, optional whitespace is skipped.
-
-=item 5.
-
-A hash reference containing various parsing options (see below)
-
-=back
-
-The various options that can be specified are:
-
-=over 4
-
-=item C<reject =E<gt> $listref>
-
-The list reference contains one or more strings specifying patterns
-that must I<not> appear within the tagged text.
-
-For example, to extract
-an HTML link (which should not contain nested links) use:
-
- extract_tagged($text, '<A>', '</A>', undef, {reject => ['<A>']} );
-
-=item C<ignore =E<gt> $listref>
-
-The list reference contains one or more strings specifying patterns
-that are I<not> be be treated as nested tags within the tagged text
-(even if they would match the start tag pattern).
-
-For example, to extract an arbitrary XML tag, but ignore "empty" elements:
-
- extract_tagged($text, undef, undef, undef, {ignore => ['<[^>]*/>']} );
-
-(also see L<"gen_delimited_pat"> below).
-
-
-=item C<fail =E<gt> $str>
-
-The C<fail> option indicates the action to be taken if a matching end
-tag is not encountered (i.e. before the end of the string or some
-C<reject> pattern matches). By default, a failure to match a closing
-tag causes C<extract_tagged> to immediately fail.
-
-However, if the string value associated with <reject> is "MAX", then
-C<extract_tagged> returns the complete text up to the point of failure.
-If the string is "PARA", C<extract_tagged> returns only the first paragraph
-after the tag (up to the first line that is either empty or contains
-only whitespace characters).
-If the string is "", the the default behaviour (i.e. failure) is reinstated.
-
-For example, suppose the start tag "/para" introduces a paragraph, which then
-continues until the next "/endpara" tag or until another "/para" tag is
-encountered:
-
- $text = "/para line 1\n\nline 3\n/para line 4";
-
- extract_tagged($text, '/para', '/endpara', undef,
- {reject => '/para', fail => MAX );
-
- # EXTRACTED: "/para line 1\n\nline 3\n"
-
-Suppose instead, that if no matching "/endpara" tag is found, the "/para"
-tag refers only to the immediately following paragraph:
-
- $text = "/para line 1\n\nline 3\n/para line 4";
-
- extract_tagged($text, '/para', '/endpara', undef,
- {reject => '/para', fail => MAX );
-
- # EXTRACTED: "/para line 1\n"
-
-Note that the specified C<fail> behaviour applies to nested tags as well.
-
-=back
-
-On success in a list context, an array of 6 elements is returned. The elements are:
-
-=over 4
-
-=item [0]
-
-the extracted tagged substring (including the outermost tags),
-
-=item [1]
-
-the remainder of the input text,
-
-=item [2]
-
-the prefix substring (if any),
-
-=item [3]
-
-the opening tag
-
-=item [4]
-
-the text between the opening and closing tags
-
-=item [5]
-
-the closing tag (or "" if no closing tag was found)
-
-=back
-
-On failure, all of these values (except the remaining text) are C<undef>.
-
-In a scalar context, C<extract_tagged> returns just the complete
-substring that matched a tagged text (including the start and end
-tags). C<undef> is returned on failure. In addition, the original input
-text has the returned substring (and any prefix) removed from it.
-
-In a void context, the input text just has the matched substring (and
-any specified prefix) removed.
-
-
-=head2 C<gen_extract_tagged>
-
-(Note: This subroutine is only available under Perl5.005)
-
-C<gen_extract_tagged> generates a new anonymous subroutine which
-extracts text between (balanced) specified tags. In other words,
-it generates a function identical in function to C<extract_tagged>.
-
-The difference between C<extract_tagged> and the anonymous
-subroutines generated by
-C<gen_extract_tagged>, is that those generated subroutines:
-
-=over 4
-
-=item *
-
-do not have to reparse tag specification or parsing options every time
-they are called (whereas C<extract_tagged> has to effectively rebuild
-its tag parser on every call);
-
-=item *
-
-make use of the new qr// construct to pre-compile the regexes they use
-(whereas C<extract_tagged> uses standard string variable interpolation
-to create tag-matching patterns).
-
-=back
-
-The subroutine takes up to four optional arguments (the same set as
-C<extract_tagged> except for the string to be processed). It returns
-a reference to a subroutine which in turn takes a single argument (the text to
-be extracted from).
-
-In other words, the implementation of C<extract_tagged> is exactly
-equivalent to:
-
- sub extract_tagged
- {
- my $text = shift;
- $extractor = gen_extract_tagged(@_);
- return $extractor->($text);
- }
-
-(although C<extract_tagged> is not currently implemented that way, in order
-to preserve pre-5.005 compatibility).
-
-Using C<gen_extract_tagged> to create extraction functions for specific tags
-is a good idea if those functions are going to be called more than once, since
-their performance is typically twice as good as the more general-purpose
-C<extract_tagged>.
-
-
-=head2 C<extract_quotelike>
-
-C<extract_quotelike> attempts to recognize, extract, and segment any
-one of the various Perl quotes and quotelike operators (see
-L<perlop(3)>) Nested backslashed delimiters, embedded balanced bracket
-delimiters (for the quotelike operators), and trailing modifiers are
-all caught. For example, in:
-
- extract_quotelike 'q # an octothorpe: \# (not the end of the q!) #'
-
- extract_quotelike ' "You said, \"Use sed\"." '
-
- extract_quotelike ' s{([A-Z]{1,8}\.[A-Z]{3})} /\L$1\E/; '
-
- extract_quotelike ' tr/\\\/\\\\/\\\//ds; '
-
-the full Perl quotelike operations are all extracted correctly.
-
-Note too that, when using the /x modifier on a regex, any comment
-containing the current pattern delimiter will cause the regex to be
-immediately terminated. In other words:
-
- 'm /
- (?i) # CASE INSENSITIVE
- [a-z_] # LEADING ALPHABETIC/UNDERSCORE
- [a-z0-9]* # FOLLOWED BY ANY NUMBER OF ALPHANUMERICS
- /x'
-
-will be extracted as if it were:
-
- 'm /
- (?i) # CASE INSENSITIVE
- [a-z_] # LEADING ALPHABETIC/'
-
-This behaviour is identical to that of the actual compiler.
-
-C<extract_quotelike> takes two arguments: the text to be processed and
-a prefix to be matched at the very beginning of the text. If no prefix
-is specified, optional whitespace is the default. If no text is given,
-C<$_> is used.
-
-In a list context, an array of 11 elements is returned. The elements are:
-
-=over 4
-
-=item [0]
-
-the extracted quotelike substring (including trailing modifiers),
-
-=item [1]
-
-the remainder of the input text,
-
-=item [2]
-
-the prefix substring (if any),
-
-=item [3]
-
-the name of the quotelike operator (if any),
-
-=item [4]
-
-the left delimiter of the first block of the operation,
-
-=item [5]
-
-the text of the first block of the operation
-(that is, the contents of
-a quote, the regex of a match or substitution or the target list of a
-translation),
-
-=item [6]
-
-the right delimiter of the first block of the operation,
-
-=item [7]
-
-the left delimiter of the second block of the operation
-(that is, if it is a C<s>, C<tr>, or C<y>),
-
-=item [8]
-
-the text of the second block of the operation
-(that is, the replacement of a substitution or the translation list
-of a translation),
-
-=item [9]
-
-the right delimiter of the second block of the operation (if any),
-
-=item [10]
-
-the trailing modifiers on the operation (if any).
-
-=back
-
-For each of the fields marked "(if any)" the default value on success is
-an empty string.
-On failure, all of these values (except the remaining text) are C<undef>.
-
-
-In a scalar context, C<extract_quotelike> returns just the complete substring
-that matched a quotelike operation (or C<undef> on failure). In a scalar or
-void context, the input text has the same substring (and any specified
-prefix) removed.
-
-Examples:
-
- # Remove the first quotelike literal that appears in text
-
- $quotelike = extract_quotelike($text,'.*?');
-
- # Replace one or more leading whitespace-separated quotelike
- # literals in $_ with "<QLL>"
-
- do { $_ = join '<QLL>', (extract_quotelike)[2,1] } until $@;
-
-
- # Isolate the search pattern in a quotelike operation from $text
-
- ($op,$pat) = (extract_quotelike $text)[3,5];
- if ($op =~ /[ms]/)
- {
- print "search pattern: $pat\n";
- }
- else
- {
- print "$op is not a pattern matching operation\n";
- }
-
-
-=head2 C<extract_quotelike> and "here documents"
-
-C<extract_quotelike> can successfully extract "here documents" from an input
-string, but with an important caveat in list contexts.
-
-Unlike other types of quote-like literals, a here document is rarely
-a contiguous substring. For example, a typical piece of code using
-here document might look like this:
-
- <<'EOMSG' || die;
- This is the message.
- EOMSG
- exit;
-
-Given this as an input string in a scalar context, C<extract_quotelike>
-would correctly return the string "<<'EOMSG'\nThis is the message.\nEOMSG",
-leaving the string " || die;\nexit;" in the original variable. In other words,
-the two separate pieces of the here document are successfully extracted and
-concatenated.
-
-In a list context, C<extract_quotelike> would return the list
-
-=over 4
-
-=item [0]
-
-"<<'EOMSG'\nThis is the message.\nEOMSG\n" (i.e. the full extracted here document,
-including fore and aft delimiters),
-
-=item [1]
-
-" || die;\nexit;" (i.e. the remainder of the input text, concatenated),
-
-=item [2]
-
-"" (i.e. the prefix substring -- trivial in this case),
-
-=item [3]
-
-"<<" (i.e. the "name" of the quotelike operator)
-
-=item [4]
-
-"'EOMSG'" (i.e. the left delimiter of the here document, including any quotes),
-
-=item [5]
-
-"This is the message.\n" (i.e. the text of the here document),
-
-=item [6]
-
-"EOMSG" (i.e. the right delimiter of the here document),
-
-=item [7..10]
-
-"" (a here document has no second left delimiter, second text, second right
-delimiter, or trailing modifiers).
-
-=back
-
-However, the matching position of the input variable would be set to
-"exit;" (i.e. I<after> the closing delimiter of the here document),
-which would cause the earlier " || die;\nexit;" to be skipped in any
-sequence of code fragment extractions.
-
-To avoid this problem, when it encounters a here document whilst
-extracting from a modifiable string, C<extract_quotelike> silently
-rearranges the string to an equivalent piece of Perl:
-
- <<'EOMSG'
- This is the message.
- EOMSG
- || die;
- exit;
-
-in which the here document I<is> contiguous. It still leaves the
-matching position after the here document, but now the rest of the line
-on which the here document starts is not skipped.
-
-To prevent <extract_quotelike> from mucking about with the input in this way
-(this is the only case where a list-context C<extract_quotelike> does so),
-you can pass the input variable as an interpolated literal:
-
- $quotelike = extract_quotelike("$var");
-
-
-=head2 C<extract_codeblock>
-
-C<extract_codeblock> attempts to recognize and extract a balanced
-bracket delimited substring that may contain unbalanced brackets
-inside Perl quotes or quotelike operations. That is, C<extract_codeblock>
-is like a combination of C<"extract_bracketed"> and
-C<"extract_quotelike">.
-
-C<extract_codeblock> takes the same initial three parameters as C<extract_bracketed>:
-a text to process, a set of delimiter brackets to look for, and a prefix to
-match first. It also takes an optional fourth parameter, which allows the
-outermost delimiter brackets to be specified separately (see below).
-
-Omitting the first argument (input text) means process C<$_> instead.
-Omitting the second argument (delimiter brackets) indicates that only C<'{'> is to be used.
-Omitting the third argument (prefix argument) implies optional whitespace at the start.
-Omitting the fourth argument (outermost delimiter brackets) indicates that the
-value of the second argument is to be used for the outermost delimiters.
-
-Once the prefix an dthe outermost opening delimiter bracket have been
-recognized, code blocks are extracted by stepping through the input text and
-trying the following alternatives in sequence:
-
-=over 4
-
-=item 1.
-
-Try and match a closing delimiter bracket. If the bracket was the same
-species as the last opening bracket, return the substring to that
-point. If the bracket was mismatched, return an error.
-
-=item 2.
-
-Try to match a quote or quotelike operator. If found, call
-C<extract_quotelike> to eat it. If C<extract_quotelike> fails, return
-the error it returned. Otherwise go back to step 1.
-
-=item 3.
-
-Try to match an opening delimiter bracket. If found, call
-C<extract_codeblock> recursively to eat the embedded block. If the
-recursive call fails, return an error. Otherwise, go back to step 1.
-
-=item 4.
-
-Unconditionally match a bareword or any other single character, and
-then go back to step 1.
-
-=back
-
-
-Examples:
-
- # Find a while loop in the text
-
- if ($text =~ s/.*?while\s*\{/{/)
- {
- $loop = "while " . extract_codeblock($text);
- }
-
- # Remove the first round-bracketed list (which may include
- # round- or curly-bracketed code blocks or quotelike operators)
-
- extract_codeblock $text, "(){}", '[^(]*';
-
-
-The ability to specify a different outermost delimiter bracket is useful
-in some circumstances. For example, in the Parse::RecDescent module,
-parser actions which are to be performed only on a successful parse
-are specified using a C<E<lt>defer:...E<gt>> directive. For example:
-
- sentence: subject verb object
- <defer: {$::theVerb = $item{verb}} >
-
-Parse::RecDescent uses C<extract_codeblock($text, '{}E<lt>E<gt>')> to extract the code
-within the C<E<lt>defer:...E<gt>> directive, but there's a problem.
-
-A deferred action like this:
-
- <defer: {if ($count>10) {$count--}} >
-
-will be incorrectly parsed as:
-
- <defer: {if ($count>
-
-because the "less than" operator is interpreted as a closing delimiter.
-
-But, by extracting the directive using
-S<C<extract_codeblock($text, '{}', undef, 'E<lt>E<gt>')>>
-the '>' character is only treated as a delimited at the outermost
-level of the code block, so the directive is parsed correctly.
-
-=head2 C<extract_multiple>
-
-The C<extract_multiple> subroutine takes a string to be processed and a
-list of extractors (subroutines or regular expressions) to apply to that string.
-
-In an array context C<extract_multiple> returns an array of substrings
-of the original string, as extracted by the specified extractors.
-In a scalar context, C<extract_multiple> returns the first
-substring successfully extracted from the original string. In both
-scalar and void contexts the original string has the first successfully
-extracted substring removed from it. In all contexts
-C<extract_multiple> starts at the current C<pos> of the string, and
-sets that C<pos> appropriately after it matches.
-
-Hence, the aim of of a call to C<extract_multiple> in a list context
-is to split the processed string into as many non-overlapping fields as
-possible, by repeatedly applying each of the specified extractors
-to the remainder of the string. Thus C<extract_multiple> is
-a generalized form of Perl's C<split> subroutine.
-
-The subroutine takes up to four optional arguments:
-
-=over 4
-
-=item 1.
-
-A string to be processed (C<$_> if the string is omitted or C<undef>)
-
-=item 2.
-
-A reference to a list of subroutine references and/or qr// objects and/or
-literal strings and/or hash references, specifying the extractors
-to be used to split the string. If this argument is omitted (or
-C<undef>) the list:
-
- [
- sub { extract_variable($_[0], '') },
- sub { extract_quotelike($_[0],'') },
- sub { extract_codeblock($_[0],'{}','') },
- ]
-
-is used.
-
-
-=item 3.
-
-An number specifying the maximum number of fields to return. If this
-argument is omitted (or C<undef>), split continues as long as possible.
-
-If the third argument is I<N>, then extraction continues until I<N> fields
-have been successfully extracted, or until the string has been completely
-processed.
-
-Note that in scalar and void contexts the value of this argument is
-automatically reset to 1 (under C<-w>, a warning is issued if the argument
-has to be reset).
-
-=item 4.
-
-A value indicating whether unmatched substrings (see below) within the
-text should be skipped or returned as fields. If the value is true,
-such substrings are skipped. Otherwise, they are returned.
-
-=back
-
-The extraction process works by applying each extractor in
-sequence to the text string.
-
-If the extractor is a subroutine it is called in a list context and is
-expected to return a list of a single element, namely the extracted
-text. It may optionally also return two further arguments: a string
-representing the text left after extraction (like $' for a pattern
-match), and a string representing any prefix skipped before the
-extraction (like $` in a pattern match). Note that this is designed
-to facilitate the use of other Text::Balanced subroutines with
-C<extract_multiple>. Note too that the value returned by an extractor
-subroutine need not bear any relationship to the corresponding substring
-of the original text (see examples below).
-
-If the extractor is a precompiled regular expression or a string,
-it is matched against the text in a scalar context with a leading
-'\G' and the gc modifiers enabled. The extracted value is either
-$1 if that variable is defined after the match, or else the
-complete match (i.e. $&).
-
-If the extractor is a hash reference, it must contain exactly one element.
-The value of that element is one of the
-above extractor types (subroutine reference, regular expression, or string).
-The key of that element is the name of a class into which the successful
-return value of the extractor will be blessed.
-
-If an extractor returns a defined value, that value is immediately
-treated as the next extracted field and pushed onto the list of fields.
-If the extractor was specified in a hash reference, the field is also
-blessed into the appropriate class,
-
-If the extractor fails to match (in the case of a regex extractor), or returns an empty list or an undefined value (in the case of a subroutine extractor), it is
-assumed to have failed to extract.
-If none of the extractor subroutines succeeds, then one
-character is extracted from the start of the text and the extraction
-subroutines reapplied. Characters which are thus removed are accumulated and
-eventually become the next field (unless the fourth argument is true, in which
-case they are disgarded).
-
-For example, the following extracts substrings that are valid Perl variables:
-
- @fields = extract_multiple($text,
- [ sub { extract_variable($_[0]) } ],
- undef, 1);
-
-This example separates a text into fields which are quote delimited,
-curly bracketed, and anything else. The delimited and bracketed
-parts are also blessed to identify them (the "anything else" is unblessed):
-
- @fields = extract_multiple($text,
- [
- { Delim => sub { extract_delimited($_[0],q{'"}) } },
- { Brack => sub { extract_bracketed($_[0],'{}') } },
- ]);
-
-This call extracts the next single substring that is a valid Perl quotelike
-operator (and removes it from $text):
-
- $quotelike = extract_multiple($text,
- [
- sub { extract_quotelike($_[0]) },
- ], undef, 1);
-
-Finally, here is yet another way to do comma-separated value parsing:
-
- @fields = extract_multiple($csv_text,
- [
- sub { extract_delimited($_[0],q{'"}) },
- qr/([^,]+)(.*)/,
- ],
- undef,1);
-
-The list in the second argument means:
-I<"Try and extract a ' or " delimited string, otherwise extract anything up to a comma...">.
-The undef third argument means:
-I<"...as many times as possible...">,
-and the true value in the fourth argument means
-I<"...discarding anything else that appears (i.e. the commas)">.
-
-If you wanted the commas preserved as separate fields (i.e. like split
-does if your split pattern has capturing parentheses), you would
-just make the last parameter undefined (or remove it).
-
-
-=head2 C<gen_delimited_pat>
-
-The C<gen_delimited_pat> subroutine takes a single (string) argument and
- > builds a Friedl-style optimized regex that matches a string delimited
-by any one of the characters in the single argument. For example:
-
- gen_delimited_pat(q{'"})
-
-returns the regex:
-
- (?:\"(?:\\\"|(?!\").)*\"|\'(?:\\\'|(?!\').)*\')
-
-Note that the specified delimiters are automatically quotemeta'd.
-
-A typical use of C<gen_delimited_pat> would be to build special purpose tags
-for C<extract_tagged>. For example, to properly ignore "empty" XML elements
-(which might contain quoted strings):
-
- my $empty_tag = '<(' . gen_delimited_pat(q{'"}) . '|.)+/>';
-
- extract_tagged($text, undef, undef, undef, {ignore => [$empty_tag]} );
-
-
-C<gen_delimited_pat> may also be called with an optional second argument,
-which specifies the "escape" character(s) to be used for each delimiter.
-For example to match a Pascal-style string (where ' is the delimiter
-and '' is a literal ' within the string):
-
- gen_delimited_pat(q{'},q{'});
-
-Different escape characters can be specified for different delimiters.
-For example, to specify that '/' is the escape for single quotes
-and '%' is the escape for double quotes:
-
- gen_delimited_pat(q{'"},q{/%});
-
-If more delimiters than escape chars are specified, the last escape char
-is used for the remaining delimiters.
-If no escape char is specified for a given specified delimiter, '\' is used.
-
-Note that
-C<gen_delimited_pat> was previously called
-C<delimited_pat>. That name may still be used, but is now deprecated.
-
-
-=head1 DIAGNOSTICS
-
-In a list context, all the functions return C<(undef,$original_text)>
-on failure. In a scalar context, failure is indicated by returning C<undef>
-(in this case the input text is not modified in any way).
-
-In addition, on failure in I<any> context, the C<$@> variable is set.
-Accessing C<$@-E<gt>{error}> returns one of the error diagnostics listed
-below.
-Accessing C<$@-E<gt>{pos}> returns the offset into the original string at
-which the error was detected (although not necessarily where it occurred!)
-Printing C<$@> directly produces the error message, with the offset appended.
-On success, the C<$@> variable is guaranteed to be C<undef>.
-
-The available diagnostics are:
-
-=over 4
-
-=item C<Did not find a suitable bracket: "%s">
-
-The delimiter provided to C<extract_bracketed> was not one of
-C<'()[]E<lt>E<gt>{}'>.
-
-=item C<Did not find prefix: /%s/>
-
-A non-optional prefix was specified but wasn't found at the start of the text.
-
-=item C<Did not find opening bracket after prefix: "%s">
-
-C<extract_bracketed> or C<extract_codeblock> was expecting a
-particular kind of bracket at the start of the text, and didn't find it.
-
-=item C<No quotelike operator found after prefix: "%s">
-
-C<extract_quotelike> didn't find one of the quotelike operators C<q>,
-C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y> at the start of the substring
-it was extracting.
-
-=item C<Unmatched closing bracket: "%c">
-
-C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> encountered
-a closing bracket where none was expected.
-
-=item C<Unmatched opening bracket(s): "%s">
-
-C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> ran
-out of characters in the text before closing one or more levels of nested
-brackets.
-
-=item C<Unmatched embedded quote (%s)>
-
-C<extract_bracketed> attempted to match an embedded quoted substring, but
-failed to find a closing quote to match it.
-
-=item C<Did not find closing delimiter to match '%s'>
-
-C<extract_quotelike> was unable to find a closing delimiter to match the
-one that opened the quote-like operation.
-
-=item C<Mismatched closing bracket: expected "%c" but found "%s">
-
-C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> found
-a valid bracket delimiter, but it was the wrong species. This usually
-indicates a nesting error, but may indicate incorrect quoting or escaping.
-
-=item C<No block delimiter found after quotelike "%s">
-
-C<extract_quotelike> or C<extract_codeblock> found one of the
-quotelike operators C<q>, C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y>
-without a suitable block after it.
-
-=item C<Did not find leading dereferencer>
-
-C<extract_variable> was expecting one of '$', '@', or '%' at the start of
-a variable, but didn't find any of them.
-
-=item C<Bad identifier after dereferencer>
-
-C<extract_variable> found a '$', '@', or '%' indicating a variable, but that
-character was not followed by a legal Perl identifier.
-
-=item C<Did not find expected opening bracket at %s>
-
-C<extract_codeblock> failed to find any of the outermost opening brackets
-that were specified.
-
-=item C<Improperly nested codeblock at %s>
-
-A nested code block was found that started with a delimiter that was specified
-as being only to be used as an outermost bracket.
-
-=item C<Missing second block for quotelike "%s">
-
-C<extract_codeblock> or C<extract_quotelike> found one of the
-quotelike operators C<s>, C<tr> or C<y> followed by only one block.
-
-=item C<No match found for opening bracket>
-
-C<extract_codeblock> failed to find a closing bracket to match the outermost
-opening bracket.
-
-=item C<Did not find opening tag: /%s/>
-
-C<extract_tagged> did not find a suitable opening tag (after any specified
-prefix was removed).
-
-=item C<Unable to construct closing tag to match: /%s/>
-
-C<extract_tagged> matched the specified opening tag and tried to
-modify the matched text to produce a matching closing tag (because
-none was specified). It failed to generate the closing tag, almost
-certainly because the opening tag did not start with a
-bracket of some kind.
-
-=item C<Found invalid nested tag: %s>
-
-C<extract_tagged> found a nested tag that appeared in the "reject" list
-(and the failure mode was not "MAX" or "PARA").
-
-=item C<Found unbalanced nested tag: %s>
-
-C<extract_tagged> found a nested opening tag that was not matched by a
-corresponding nested closing tag (and the failure mode was not "MAX" or "PARA").
-
-=item C<Did not find closing tag>
-
-C<extract_tagged> reached the end of the text without finding a closing tag
-to match the original opening tag (and the failure mode was not
-"MAX" or "PARA").
-
-
-
-
-=back
-
-
-=head1 AUTHOR
-
-Damian Conway (damian@conway.org)
-
-
-=head1 BUGS AND IRRITATIONS
-
-There are undoubtedly serious bugs lurking somewhere in this code, if
-only because parts of it give the impression of understanding a great deal
-more about Perl than they really do.
-
-Bug reports and other feedback are most welcome.
-
-
-=head1 COPYRIGHT
-
- Copyright (c) 1997-2001, Damian Conway. All Rights Reserved.
- This module is free software. It may be used, redistributed
- and/or modified under the same terms as Perl itself.
diff --git a/Master/tlpkg/installer/perllib/Text/ParseWords.pm b/Master/tlpkg/installer/perllib/Text/ParseWords.pm
deleted file mode 100644
index 2f6812ade80..00000000000
--- a/Master/tlpkg/installer/perllib/Text/ParseWords.pm
+++ /dev/null
@@ -1,263 +0,0 @@
-package Text::ParseWords;
-
-use vars qw($VERSION @ISA @EXPORT $PERL_SINGLE_QUOTE);
-$VERSION = "3.24";
-
-require 5.000;
-
-use Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(shellwords quotewords nested_quotewords parse_line);
-@EXPORT_OK = qw(old_shellwords);
-
-
-sub shellwords {
- my(@lines) = @_;
- $lines[$#lines] =~ s/\s+$//;
- return(quotewords('\s+', 0, @lines));
-}
-
-
-
-sub quotewords {
- my($delim, $keep, @lines) = @_;
- my($line, @words, @allwords);
-
- foreach $line (@lines) {
- @words = parse_line($delim, $keep, $line);
- return() unless (@words || !length($line));
- push(@allwords, @words);
- }
- return(@allwords);
-}
-
-
-
-sub nested_quotewords {
- my($delim, $keep, @lines) = @_;
- my($i, @allwords);
-
- for ($i = 0; $i < @lines; $i++) {
- @{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]);
- return() unless (@{$allwords[$i]} || !length($lines[$i]));
- }
- return(@allwords);
-}
-
-
-
-sub parse_line {
- my($delimiter, $keep, $line) = @_;
- my($word, @pieces);
-
- no warnings 'uninitialized'; # we will be testing undef strings
-
- while (length($line)) {
- $line =~ s/^(["']) # a $quote
- ((?:\\.|(?!\1)[^\\])*) # and $quoted text
- \1 # followed by the same quote
- | # --OR--
- ^((?:\\.|[^\\"'])*?) # an $unquoted text
- (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["']))
- # plus EOL, delimiter, or quote
- //xs or return; # extended layout
- my($quote, $quoted, $unquoted, $delim) = ($1, $2, $3, $4);
- return() unless( defined($quote) || length($unquoted) || length($delim));
-
- if ($keep) {
- $quoted = "$quote$quoted$quote";
- }
- else {
- $unquoted =~ s/\\(.)/$1/sg;
- if (defined $quote) {
- $quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
- $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'");
- }
- }
- $word .= substr($line, 0, 0); # leave results tainted
- $word .= defined $quote ? $quoted : $unquoted;
-
- if (length($delim)) {
- push(@pieces, $word);
- push(@pieces, $delim) if ($keep eq 'delimiters');
- undef $word;
- }
- if (!length($line)) {
- push(@pieces, $word);
- }
- }
- return(@pieces);
-}
-
-
-
-sub old_shellwords {
-
- # Usage:
- # use ParseWords;
- # @words = old_shellwords($line);
- # or
- # @words = old_shellwords(@lines);
- # or
- # @words = old_shellwords(); # defaults to $_ (and clobbers it)
-
- no warnings 'uninitialized'; # we will be testing undef strings
- local *_ = \join('', @_) if @_;
- my (@words, $snippet);
-
- s/\A\s+//;
- while ($_ ne '') {
- my $field = substr($_, 0, 0); # leave results tainted
- for (;;) {
- if (s/\A"(([^"\\]|\\.)*)"//s) {
- ($snippet = $1) =~ s#\\(.)#$1#sg;
- }
- elsif (/\A"/) {
- require Carp;
- Carp::carp("Unmatched double quote: $_");
- return();
- }
- elsif (s/\A'(([^'\\]|\\.)*)'//s) {
- ($snippet = $1) =~ s#\\(.)#$1#sg;
- }
- elsif (/\A'/) {
- require Carp;
- Carp::carp("Unmatched single quote: $_");
- return();
- }
- elsif (s/\A\\(.)//s) {
- $snippet = $1;
- }
- elsif (s/\A([^\s\\'"]+)//) {
- $snippet = $1;
- }
- else {
- s/\A\s+//;
- last;
- }
- $field .= $snippet;
- }
- push(@words, $field);
- }
- return @words;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Text::ParseWords - parse text into an array of tokens or array of arrays
-
-=head1 SYNOPSIS
-
- use Text::ParseWords;
- @lists = &nested_quotewords($delim, $keep, @lines);
- @words = &quotewords($delim, $keep, @lines);
- @words = &shellwords(@lines);
- @words = &parse_line($delim, $keep, $line);
- @words = &old_shellwords(@lines); # DEPRECATED!
-
-=head1 DESCRIPTION
-
-The &nested_quotewords() and &quotewords() functions accept a delimiter
-(which can be a regular expression)
-and a list of lines and then breaks those lines up into a list of
-words ignoring delimiters that appear inside quotes. &quotewords()
-returns all of the tokens in a single long list, while &nested_quotewords()
-returns a list of token lists corresponding to the elements of @lines.
-&parse_line() does tokenizing on a single string. The &*quotewords()
-functions simply call &parse_line(), so if you're only splitting
-one line you can call &parse_line() directly and save a function
-call.
-
-The $keep argument is a boolean flag. If true, then the tokens are
-split on the specified delimiter, but all other characters (quotes,
-backslashes, etc.) are kept in the tokens. If $keep is false then the
-&*quotewords() functions remove all quotes and backslashes that are
-not themselves backslash-escaped or inside of single quotes (i.e.,
-&quotewords() tries to interpret these characters just like the Bourne
-shell). NB: these semantics are significantly different from the
-original version of this module shipped with Perl 5.000 through 5.004.
-As an additional feature, $keep may be the keyword "delimiters" which
-causes the functions to preserve the delimiters in each string as
-tokens in the token lists, in addition to preserving quote and
-backslash characters.
-
-&shellwords() is written as a special case of &quotewords(), and it
-does token parsing with whitespace as a delimiter-- similar to most
-Unix shells.
-
-=head1 EXAMPLES
-
-The sample program:
-
- use Text::ParseWords;
- @words = &quotewords('\s+', 0, q{this is "a test" of\ quotewords \"for you});
- $i = 0;
- foreach (@words) {
- print "$i: <$_>\n";
- $i++;
- }
-
-produces:
-
- 0: <this>
- 1: <is>
- 2: <a test>
- 3: <of quotewords>
- 4: <"for>
- 5: <you>
-
-demonstrating:
-
-=over 4
-
-=item 0
-
-a simple word
-
-=item 1
-
-multiple spaces are skipped because of our $delim
-
-=item 2
-
-use of quotes to include a space in a word
-
-=item 3
-
-use of a backslash to include a space in a word
-
-=item 4
-
-use of a backslash to remove the special meaning of a double-quote
-
-=item 5
-
-another simple word (note the lack of effect of the
-backslashed double-quote)
-
-=back
-
-Replacing C<&quotewords('\s+', 0, q{this is...})>
-with C<&shellwords(q{this is...})>
-is a simpler way to accomplish the same thing.
-
-=head1 AUTHORS
-
-Maintainer is Hal Pomeranz <pomeranz@netcom.com>, 1994-1997 (Original
-author unknown). Much of the code for &parse_line() (including the
-primary regexp) from Joerk Behrends <jbehrends@multimediaproduzenten.de>.
-
-Examples section another documentation provided by John Heidemann
-<johnh@ISI.EDU>
-
-Bug reports, patches, and nagging provided by lots of folks-- thanks
-everybody! Special thanks to Michael Schwern <schwern@envirolink.org>
-for assuring me that a &nested_quotewords() would be useful, and to
-Jeff Friedl <jfriedl@yahoo-inc.com> for telling me not to worry about
-error-checking (sort of-- you had to be there).
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Text/Soundex.pm b/Master/tlpkg/installer/perllib/Text/Soundex.pm
deleted file mode 100644
index 64a9e6507d5..00000000000
--- a/Master/tlpkg/installer/perllib/Text/Soundex.pm
+++ /dev/null
@@ -1,150 +0,0 @@
-package Text::Soundex;
-require 5.000;
-require Exporter;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(&soundex $soundex_nocode);
-
-$VERSION = '1.01';
-
-# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $
-#
-# Implementation of soundex algorithm as described by Knuth in volume
-# 3 of The Art of Computer Programming, with ideas stolen from Ian
-# Phillipps <ian@pipex.net>.
-#
-# Mike Stok <Mike.Stok@meiko.concord.ma.us>, 2 March 1994.
-#
-# Knuth's test cases are:
-#
-# Euler, Ellery -> E460
-# Gauss, Ghosh -> G200
-# Hilbert, Heilbronn -> H416
-# Knuth, Kant -> K530
-# Lloyd, Ladd -> L300
-# Lukasiewicz, Lissajous -> L222
-#
-# $Log: soundex.pl,v $
-# Revision 1.2 1994/03/24 00:30:27 mike
-# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu>
-# in the way I handles leasing characters which were different but had
-# the same soundex code. This showed up comparing it with Oracle's
-# soundex output.
-#
-# Revision 1.1 1994/03/02 13:01:30 mike
-# Initial revision
-#
-#
-##############################################################################
-
-# $soundex_nocode is used to indicate a string doesn't have a soundex
-# code, I like undef other people may want to set it to 'Z000'.
-
-$soundex_nocode = undef;
-
-sub soundex
-{
- local (@s, $f, $fc, $_) = @_;
-
- push @s, '' unless @s; # handle no args as a single empty string
-
- foreach (@s)
- {
- $_ = uc $_;
- tr/A-Z//cd;
-
- if ($_ eq '')
- {
- $_ = $soundex_nocode;
- }
- else
- {
- ($f) = /^(.)/;
- tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/;
- ($fc) = /^(.)/;
- s/^$fc+//;
- tr///cs;
- tr/0//d;
- $_ = $f . $_ . '000';
- s/^(.{4}).*/$1/;
- }
- }
-
- wantarray ? @s : shift @s;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Text::Soundex - Implementation of the Soundex Algorithm as Described by Knuth
-
-=head1 SYNOPSIS
-
- use Text::Soundex;
-
- $code = soundex $string; # get soundex code for a string
- @codes = soundex @list; # get list of codes for list of strings
-
- # set value to be returned for strings without soundex code
-
- $soundex_nocode = 'Z000';
-
-=head1 DESCRIPTION
-
-This module implements the soundex algorithm as described by Donald Knuth
-in Volume 3 of B<The Art of Computer Programming>. The algorithm is
-intended to hash words (in particular surnames) into a small space using a
-simple model which approximates the sound of the word when spoken by an English
-speaker. Each word is reduced to a four character string, the first
-character being an upper case letter and the remaining three being digits.
-
-If there is no soundex code representation for a string then the value of
-C<$soundex_nocode> is returned. This is initially set to C<undef>, but
-many people seem to prefer an I<unlikely> value like C<Z000>
-(how unlikely this is depends on the data set being dealt with.) Any value
-can be assigned to C<$soundex_nocode>.
-
-In scalar context C<soundex> returns the soundex code of its first
-argument, and in list context a list is returned in which each element is the
-soundex code for the corresponding argument passed to C<soundex> e.g.
-
- @codes = soundex qw(Mike Stok);
-
-leaves C<@codes> containing C<('M200', 'S320')>.
-
-=head1 EXAMPLES
-
-Knuth's examples of various names and the soundex codes they map to
-are listed below:
-
- Euler, Ellery -> E460
- Gauss, Ghosh -> G200
- Hilbert, Heilbronn -> H416
- Knuth, Kant -> K530
- Lloyd, Ladd -> L300
- Lukasiewicz, Lissajous -> L222
-
-so:
-
- $code = soundex 'Knuth'; # $code contains 'K530'
- @list = soundex qw(Lloyd Gauss); # @list contains 'L300', 'G200'
-
-=head1 LIMITATIONS
-
-As the soundex algorithm was originally used a B<long> time ago in the US
-it considers only the English alphabet and pronunciation.
-
-As it is mapping a large space (arbitrary length strings) onto a small
-space (single letter plus 3 digits) no inference can be made about the
-similarity of two strings which end up with the same soundex code. For
-example, both C<Hilbert> and C<Heilbronn> end up with a soundex code
-of C<H416>.
-
-=head1 AUTHOR
-
-This code was implemented by Mike Stok (C<stok@cybercom.net>) from the
-description given by Knuth. Ian Phillipps (C<ian@pipex.net>) and Rich Pinder
-(C<rpinder@hsc.usc.edu>) supplied ideas and spotted mistakes.
diff --git a/Master/tlpkg/installer/perllib/Text/Tabs.pm b/Master/tlpkg/installer/perllib/Text/Tabs.pm
deleted file mode 100644
index 36107fcfe3e..00000000000
--- a/Master/tlpkg/installer/perllib/Text/Tabs.pm
+++ /dev/null
@@ -1,121 +0,0 @@
-
-package Text::Tabs;
-
-require Exporter;
-
-@ISA = (Exporter);
-@EXPORT = qw(expand unexpand $tabstop);
-
-use vars qw($VERSION $tabstop $debug);
-$VERSION = 2005.0824;
-
-use strict;
-
-BEGIN {
- $tabstop = 8;
- $debug = 0;
-}
-
-sub expand {
- my @l;
- my $pad;
- for ( @_ ) {
- my $s = '';
- for (split(/^/m, $_, -1)) {
- my $offs = 0;
- s{\t}{
- $pad = $tabstop - (pos() + $offs) % $tabstop;
- $offs += $pad - 1;
- " " x $pad;
- }eg;
- $s .= $_;
- }
- push(@l, $s);
- }
- return @l if wantarray;
- return $l[0];
-}
-
-sub unexpand
-{
- my (@l) = @_;
- my @e;
- my $x;
- my $line;
- my @lines;
- my $lastbit;
- for $x (@l) {
- @lines = split("\n", $x, -1);
- for $line (@lines) {
- $line = expand($line);
- @e = split(/(.{$tabstop})/,$line,-1);
- $lastbit = pop(@e);
- $lastbit = '' unless defined $lastbit;
- $lastbit = "\t"
- if $lastbit eq " "x$tabstop;
- for $_ (@e) {
- if ($debug) {
- my $x = $_;
- $x =~ s/\t/^I\t/gs;
- print "sub on '$x'\n";
- }
- s/ +$/\t/;
- }
- $line = join('',@e, $lastbit);
- }
- $x = join("\n", @lines);
- }
- return @l if wantarray;
- return $l[0];
-}
-
-1;
-__END__
-
-sub expand
-{
- my (@l) = @_;
- for $_ (@l) {
- 1 while s/(^|\n)([^\t\n]*)(\t+)/
- $1. $2 . (" " x
- ($tabstop * length($3)
- - (length($2) % $tabstop)))
- /sex;
- }
- return @l if wantarray;
- return $l[0];
-}
-
-
-=head1 NAME
-
-Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1)
-
-=head1 SYNOPSIS
-
- use Text::Tabs;
-
- $tabstop = 4;
- @lines_without_tabs = expand(@lines_with_tabs);
- @lines_with_tabs = unexpand(@lines_without_tabs);
-
-=head1 DESCRIPTION
-
-Text::Tabs does about what the unix utilities expand(1) and unexpand(1)
-do. Given a line with tabs in it, expand will replace the tabs with
-the appropriate number of spaces. Given a line with or without tabs in
-it, unexpand will add tabs when it can save bytes by doing so. Invisible
-compression with plain ascii!
-
-=head1 BUGS
-
-expand doesn't handle newlines very quickly -- do not feed it an
-entire document in one string. Instead feed it an array of lines.
-
-=head1 LICENSE
-
-Copyright (C) 1996-2002,2005 David Muir Sharnoff.
-Copyright (C) 2005 Aristotle Pagaltzis
-This module may be modified, used, copied, and redistributed at your own risk.
-Publicly redistributed modified versions must use a different name.
-
diff --git a/Master/tlpkg/installer/perllib/Text/Wrap.pm b/Master/tlpkg/installer/perllib/Text/Wrap.pm
deleted file mode 100644
index d364cfc1195..00000000000
--- a/Master/tlpkg/installer/perllib/Text/Wrap.pm
+++ /dev/null
@@ -1,223 +0,0 @@
-package Text::Wrap;
-
-require Exporter;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(wrap fill);
-@EXPORT_OK = qw($columns $break $huge);
-
-$VERSION = 2005.0824_01;
-
-use vars qw($VERSION $columns $debug $break $huge $unexpand $tabstop
- $separator $separator2);
-use strict;
-
-BEGIN {
- $columns = 76; # <= screen width
- $debug = 0;
- $break = '\s';
- $huge = 'wrap'; # alternatively: 'die' or 'overflow'
- $unexpand = 1;
- $tabstop = 8;
- $separator = "\n";
- $separator2 = undef;
-}
-
-use Text::Tabs qw(expand unexpand);
-
-sub wrap
-{
- my ($ip, $xp, @t) = @_;
-
- local($Text::Tabs::tabstop) = $tabstop;
- my $r = "";
- my $tail = pop(@t);
- my $t = expand(join("", (map { /\s+\z/ ? ( $_ ) : ($_, ' ') } @t), $tail));
- my $lead = $ip;
- my $ll = $columns - length(expand($ip)) - 1;
- $ll = 0 if $ll < 0;
- my $nll = $columns - length(expand($xp)) - 1;
- my $nl = "";
- my $remainder = "";
-
- use re 'taint';
-
- pos($t) = 0;
- while ($t !~ /\G\s*\Z/gc) {
- if ($t =~ /\G([^\n]{0,$ll})($break|\n*\z)/xmgc) {
- $r .= $unexpand
- ? unexpand($nl . $lead . $1)
- : $nl . $lead . $1;
- $remainder = $2;
- } elsif ($huge eq 'wrap' && $t =~ /\G([^\n]{$ll})/gc) {
- $r .= $unexpand
- ? unexpand($nl . $lead . $1)
- : $nl . $lead . $1;
- $remainder = defined($separator2) ? $separator2 : $separator;
- } elsif ($huge eq 'overflow' && $t =~ /\G([^\n]*?)($break|\z)/xmgc) {
- $r .= $unexpand
- ? unexpand($nl . $lead . $1)
- : $nl . $lead . $1;
- $remainder = $2;
- } elsif ($huge eq 'die') {
- die "couldn't wrap '$t'";
- } else {
- die "This shouldn't happen";
- }
-
- $lead = $xp;
- $ll = $nll;
- $nl = defined($separator2)
- ? ($remainder eq "\n"
- ? "\n"
- : $separator2)
- : $separator;
- }
- $r .= $remainder;
-
- print "-----------$r---------\n" if $debug;
-
- print "Finish up with '$lead'\n" if $debug;
-
- $r .= $lead . substr($t, pos($t), length($t)-pos($t))
- if pos($t) ne length($t);
-
- print "-----------$r---------\n" if $debug;;
-
- return $r;
-}
-
-sub fill
-{
- my ($ip, $xp, @raw) = @_;
- my @para;
- my $pp;
-
- for $pp (split(/\n\s+/, join("\n",@raw))) {
- $pp =~ s/\s+/ /g;
- my $x = wrap($ip, $xp, $pp);
- push(@para, $x);
- }
-
- # if paragraph_indent is the same as line_indent,
- # separate paragraphs with blank lines
-
- my $ps = ($ip eq $xp) ? "\n\n" : "\n";
- return join ($ps, @para);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Text::Wrap - line wrapping to form simple paragraphs
-
-=head1 SYNOPSIS
-
-B<Example 1>
-
- use Text::Wrap
-
- $initial_tab = "\t"; # Tab before first line
- $subsequent_tab = ""; # All other lines flush left
-
- print wrap($initial_tab, $subsequent_tab, @text);
- print fill($initial_tab, $subsequent_tab, @text);
-
- $lines = wrap($initial_tab, $subsequent_tab, @text);
-
- @paragraphs = fill($initial_tab, $subsequent_tab, @text);
-
-B<Example 2>
-
- use Text::Wrap qw(wrap $columns $huge);
-
- $columns = 132; # Wrap at 132 characters
- $huge = 'die';
- $huge = 'wrap';
- $huge = 'overflow';
-
-B<Example 3>
-
- use Text::Wrap
-
- $Text::Wrap::columns = 72;
- print wrap('', '', @text);
-
-=head1 DESCRIPTION
-
-C<Text::Wrap::wrap()> is a very simple paragraph formatter. It formats a
-single paragraph at a time by breaking lines at word boundries.
-Indentation is controlled for the first line (C<$initial_tab>) and
-all subsequent lines (C<$subsequent_tab>) independently. Please note:
-C<$initial_tab> and C<$subsequent_tab> are the literal strings that will
-be used: it is unlikley you would want to pass in a number.
-
-Text::Wrap::fill() is a simple multi-paragraph formatter. It formats
-each paragraph separately and then joins them together when it's done. It
-will destroy any whitespace in the original text. It breaks text into
-paragraphs by looking for whitespace after a newline. In other respects
-it acts like wrap().
-
-=head1 OVERRIDES
-
-C<Text::Wrap::wrap()> has a number of variables that control its behavior.
-Because other modules might be using C<Text::Wrap::wrap()> it is suggested
-that you leave these variables alone! If you can't do that, then
-use C<local($Text::Wrap::VARIABLE) = YOURVALUE> when you change the
-values so that the original value is restored. This C<local()> trick
-will not work if you import the variable into your own namespace.
-
-Lines are wrapped at C<$Text::Wrap::columns> columns. C<$Text::Wrap::columns>
-should be set to the full width of your output device. In fact,
-every resulting line will have length of no more than C<$columns - 1>.
-
-It is possible to control which characters terminate words by
-modifying C<$Text::Wrap::break>. Set this to a string such as
-C<'[\s:]'> (to break before spaces or colons) or a pre-compiled regexp
-such as C<qr/[\s']/> (to break before spaces or apostrophes). The
-default is simply C<'\s'>; that is, words are terminated by spaces.
-(This means, among other things, that trailing punctuation such as
-full stops or commas stay with the word they are "attached" to.)
-
-Beginner note: In example 2, above C<$columns> is imported into
-the local namespace, and set locally. In example 3,
-C<$Text::Wrap::columns> is set in its own namespace without importing it.
-
-C<Text::Wrap::wrap()> starts its work by expanding all the tabs in its
-input into spaces. The last thing it does it to turn spaces back
-into tabs. If you do not want tabs in your results, set
-C<$Text::Wrap::unexpand> to a false value. Likewise if you do not
-want to use 8-character tabstops, set C<$Text::Wrap::tabstop> to
-the number of characters you do want for your tabstops.
-
-If you want to separate your lines with something other than C<\n>
-then set C<$Text::Wrap::separator> to your preference. This replaces
-all newlines with C<$Text::Wrap::separator>. If you just to preserve
-existing newlines but add new breaks with something else, set
-C<$Text::Wrap::separator2> instead.
-
-When words that are longer than C<$columns> are encountered, they
-are broken up. C<wrap()> adds a C<"\n"> at column C<$columns>.
-This behavior can be overridden by setting C<$huge> to
-'die' or to 'overflow'. When set to 'die', large words will cause
-C<die()> to be called. When set to 'overflow', large words will be
-left intact.
-
-Historical notes: 'die' used to be the default value of
-C<$huge>. Now, 'wrap' is the default value.
-
-=head1 EXAMPLE
-
- print wrap("\t","","This is a bit of text that forms
- a normal book-style paragraph");
-
-=head1 LICENSE
-
-David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and
-many many others. Copyright (C) 1996-2002 David Muir Sharnoff.
-This module may be modified, used, copied, and redistributed at
-your own risk. Publicly redistributed modified versions must use
-a different name.
-
diff --git a/Master/tlpkg/installer/perllib/Tie/Array.pm b/Master/tlpkg/installer/perllib/Tie/Array.pm
deleted file mode 100644
index af8f51e9f51..00000000000
--- a/Master/tlpkg/installer/perllib/Tie/Array.pm
+++ /dev/null
@@ -1,287 +0,0 @@
-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/installer/perllib/Tie/File.pm b/Master/tlpkg/installer/perllib/Tie/File.pm
deleted file mode 100644
index a1f40afe199..00000000000
--- a/Master/tlpkg/installer/perllib/Tie/File.pm
+++ /dev/null
@@ -1,2632 +0,0 @@
-
-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";
-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 accomodate 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., 59 Temple Place,
-Suite 330, Boston, MA 02111 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/installer/perllib/Tie/Handle.pm b/Master/tlpkg/installer/perllib/Tie/Handle.pm
deleted file mode 100644
index d8747f12af1..00000000000
--- a/Master/tlpkg/installer/perllib/Tie/Handle.pm
+++ /dev/null
@@ -1,234 +0,0 @@
-package Tie::Handle;
-
-use 5.006_001;
-our $VERSION = '4.1';
-
-=head1 NAME
-
-Tie::Handle, 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
-
-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";
-}
-
-package Tie::StdHandle;
-our @ISA = 'Tie::Handle';
-use Carp;
-
-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/installer/perllib/Tie/Hash.pm b/Master/tlpkg/installer/perllib/Tie/Hash.pm
deleted file mode 100644
index a838915482b..00000000000
--- a/Master/tlpkg/installer/perllib/Tie/Hash.pm
+++ /dev/null
@@ -1,257 +0,0 @@
-package Tie::Hash;
-
-our $VERSION = '1.02';
-
-=head1 NAME
-
-Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes
-
-=head1 SYNOPSIS
-
- package NewHash;
- require Tie::Hash;
-
- @ISA = (Tie::Hash);
-
- sub DELETE { ... } # Provides needed method
- sub CLEAR { ... } # Overrides inherited method
-
-
- package NewStdHash;
- require Tie::Hash;
-
- @ISA = (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 = (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<pertie/"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/installer/perllib/Tie/Memoize.pm b/Master/tlpkg/installer/perllib/Tie/Memoize.pm
deleted file mode 100644
index 2793a04590d..00000000000
--- a/Master/tlpkg/installer/perllib/Tie/Memoize.pm
+++ /dev/null
@@ -1,128 +0,0 @@
-use strict;
-package Tie::Memoize;
-use Tie::Hash;
-our @ISA = 'Tie::ExtraHash';
-our $VERSION = '1.0';
-
-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]);
- $_[0][1]{$key} = 0, return unless @res; # Cache non-existence
- # Now we know it exists
- return ($_[0][1]{$key} = 1) if $a->[5]; # Only existence reported
- # Now know the value
- $_[0][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/installer/perllib/Tie/RefHash.pm b/Master/tlpkg/installer/perllib/Tie/RefHash.pm
deleted file mode 100644
index cfcdd5b5a10..00000000000
--- a/Master/tlpkg/installer/perllib/Tie/RefHash.pm
+++ /dev/null
@@ -1,170 +0,0 @@
-package Tie::RefHash;
-
-our $VERSION = 1.32;
-
-=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 AUTHOR
-
-Gurusamy Sarathy gsar@activestate.com
-
-'Nestable' by Ed Avis ed@membled.com
-
-=head1 VERSION
-
-Version 1.32
-
-=head1 SEE ALSO
-
-perl(1), perlfunc(1), perltie(1)
-
-=cut
-
-use Tie::Hash;
-use vars '@ISA';
-@ISA = qw(Tie::Hash);
-use strict;
-
-require overload; # to support objects with overloaded ""
-
-sub TIEHASH {
- my $c = shift;
- my $s = [];
- bless $s, $c;
- while (@_) {
- $s->STORE(shift, shift);
- }
- return $s;
-}
-
-sub FETCH {
- my($s, $k) = @_;
- if (ref $k) {
- my $kstr = overload::StrVal($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]{overload::StrVal($k)} = [$k, $v];
- }
- else {
- $s->[1]{$k} = $v;
- }
- $v;
-}
-
-sub DELETE {
- my($s, $k) = @_;
- (ref $k)
- ? (delete($s->[0]{overload::StrVal($k)}) || [])->[1]
- : delete($s->[1]{$k});
-}
-
-sub EXISTS {
- my($s, $k) = @_;
- (ref $k) ? exists($s->[0]{overload::StrVal($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/installer/perllib/Tie/Scalar.pm b/Master/tlpkg/installer/perllib/Tie/Scalar.pm
deleted file mode 100644
index c23c12187a8..00000000000
--- a/Master/tlpkg/installer/perllib/Tie/Scalar.pm
+++ /dev/null
@@ -1,140 +0,0 @@
-package Tie::Scalar;
-
-our $VERSION = '1.00';
-
-=head1 NAME
-
-Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
-
-=head1 SYNOPSIS
-
- package NewScalar;
- require Tie::Scalar;
-
- @ISA = (Tie::Scalar);
-
- sub FETCH { ... } # Provide a needed method
- sub TIESCALAR { ... } # Overrides inherited method
-
-
- package NewStdScalar;
- require Tie::Scalar;
-
- @ISA = (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 = (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/installer/perllib/Tie/SubstrHash.pm b/Master/tlpkg/installer/perllib/Tie/SubstrHash.pm
deleted file mode 100644
index 476dd686787..00000000000
--- a/Master/tlpkg/installer/perllib/Tie/SubstrHash.pm
+++ /dev/null
@@ -1,215 +0,0 @@
-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/installer/perllib/Tie/Watch.pm b/Master/tlpkg/installer/perllib/Tie/Watch.pm
deleted file mode 100644
index 48f46acd2b0..00000000000
--- a/Master/tlpkg/installer/perllib/Tie/Watch.pm
+++ /dev/null
@@ -1,560 +0,0 @@
-$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/installer/perllib/Time/HiRes.pm b/Master/tlpkg/installer/perllib/Time/HiRes.pm
deleted file mode 100644
index 964e4385dfc..00000000000
--- a/Master/tlpkg/installer/perllib/Time/HiRes.pm
+++ /dev/null
@@ -1,500 +0,0 @@
-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);
-
-$VERSION = '1.86';
-$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 );
-
- 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
- ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF );
-
- setitimer ($which, $floating_seconds, $floating_interval );
- getitimer ($which);
-
- $realtime = clock_gettime(CLOCK_REALTIME);
- $resolution = clock_getres(CLOCK_REALTIME);
-
- clock_nanosleep(CLOCK_REALTIME, 1.5);
- clock_nanosleep(CLOCK_REALTIME, time() + 10, TIMER_ABSTIME);
-
- my $ticktock = clock();
-
-=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.
-
-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.
-
-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<ualarm()>. 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.
-
-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 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 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 (for example) Win32
-and Cygwin have only C<ITIMER_REAL>, and only Solaris seems to have
-C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
-
-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. 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(), 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, $seconds, $flags = 0)
-
-Sleeps for the number of seconds (1e9ths of a second) specified.
-Returns the number of seconds 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.
-
-=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);
-
- # 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;
-
-=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 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?
-
-=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).
-
-=head1 SEE ALSO
-
-Perl modules L<BSD::Resource>, L<Time::TAI64>.
-
-Your system documentation for C<clock_gettime>, C<clock_settime>,
-C<gettimeofday>, C<getitimer>, C<setitimer>, 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 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/installer/perllib/Time/Local.pm b/Master/tlpkg/installer/perllib/Time/Local.pm
deleted file mode 100644
index 912f17d0310..00000000000
--- a/Master/tlpkg/installer/perllib/Time/Local.pm
+++ /dev/null
@@ -1,366 +0,0 @@
-package Time::Local;
-
-require Exporter;
-use Carp;
-use Config;
-use strict;
-use integer;
-
-use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
-$VERSION = '1.11';
-$VERSION = eval $VERSION;
-@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, %Min, %Max);
-my ($MinInt, $MaxInt);
-
-if ($^O eq 'MacOS') {
- # time_t is unsigned...
- $MaxInt = (1 << (8 * $Config{intsize})) - 1;
- $MinInt = 0;
-} else {
- $MaxInt = ((1 << (8 * $Config{intsize} - 2))-1)*2 + 1;
- $MinInt = -$MaxInt - 1;
-
- # On Win32 (and others?) time_t appears to be signed, but negative
- # epochs still don't work. - XXX - this is experimental
- $MinInt = 0
- unless defined ((localtime(-1))[0]);
-}
-
-$Max{Day} = ($MaxInt >> 1) / 43200;
-$Min{Day} = $MinInt ? -($Max{Day} + 1) : 0;
-
-$Max{Sec} = $MaxInt - 86400 * $Max{Day};
-$Min{Sec} = $MinInt - 86400 * $Min{Day};
-
-# 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') {
- no integer;
-
- # 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 {
- $_[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] + 60 * $_[1] + 3600 * $_[2];
-
- no integer;
-
- $sec + 86400 * &_daygm;
-}
-
-
-sub _zoneadjust {
- my ($day, $sec, $time) = @_;
-
- $sec = $sec + _timegm(localtime($time)) - $time;
- if ($sec >= 86400) { $day++; $sec -= 86400; }
- if ($sec < 0) { $day--; $sec += 86400; }
-
- ($day, $sec);
-}
-
-
-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}) {
- if (abs($year) >= 0x7fff) {
- $year += 1900;
- croak "Cannot handle date ($sec, $min, $hour, $mday, $month, *$year*)";
- }
-
- croak "Month '$month' out of range 0..11" if $month > 11 or $month < 0;
-
- my $md = $MonthDays[$month];
-# ++$md if $month == 1 and $year % 4 == 0 and
-# ($year % 100 != 0 or ($year + 1900) % 400 == 0);
- ++$md unless $month != 1 or $year % 4 or !($year % 400);
-
- 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);
- my $xsec = $sec + $SecOff + 60*$min + 3600*$hour;
-
- unless ($Options{no_range_check}
- or ($days > $Min{Day} or $days == $Min{Day} and $xsec >= $Min{Sec})
- and ($days < $Max{Day} or $days == $Max{Day} and $xsec <= $Max{Sec}))
- {
- warn "Day too small - $days > $Min{Day}\n" if $days < $Min{Day};
- warn "Day too big - $days > $Max{Day}\n" if $days > $Max{Day};
- warn "Sec too small - $days < $Min{Sec}\n" if $days < $Min{Sec};
- warn "Sec too big - $days > $Max{Sec}\n" if $days > $Max{Sec};
- $year += 1900;
- croak "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)";
- }
-
- no integer;
-
- $xsec + 86400 * $days;
-}
-
-
-sub timegm_nocheck {
- local $Options{no_range_check} = 1;
- &timegm;
-}
-
-
-sub timelocal {
- # Adjust Max/Min allowed times to fit local time zone and call timegm
- local ($Max{Day}, $Max{Sec}) = _zoneadjust($Max{Day}, $Max{Sec}, $MaxInt);
- local ($Min{Day}, $Min{Sec}) = _zoneadjust($Min{Day}, $Min{Sec}, $MinInt);
- my $ref_t = &timegm;
-
- # Calculate first guess with a one-day delta to avoid localtime overflow
- my $delta = ($_[5] < 100)? 86400 : -86400;
- my $loc_t = _timegm(localtime( $ref_t + $delta )) - $delta;
-
- # Is there a timezone offset from GMT or are we done
- my $zone_off = $ref_t - $loc_t
- or return $loc_t;
-
- # This hack is needed to always pick the first matching time
- # during a DST change when time would otherwise be ambiguous
- $zone_off -= 3600 if ($delta > 0 && $ref_t >= 3600);
-
- # Adjust for timezone
- $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))
- or return $loc_t;
-
- # Adjust for DST change
- $loc_t += $dst_off;
-
- return $loc_t if $dst_off >= 0;
-
- # for a negative offset from GMT, and if the original date
- # was a non-extent gap in a forward DST jump, we should
- # now have the wrong answer - undo the DST adjust;
-
- my ($s,$m,$h) = localtime($loc_t);
- $loc_t -= $dst_off if $s != $_[0] || $m != $_[1] || $h != $_[2];
-
- $loc_t;
-}
-
-
-sub timelocal_nocheck {
- local $Options{no_range_check} = 1;
- &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
-
-These routines are the inverse of built-in perl functions localtime()
-and gmtime(). They accept a date as a six-element array, and return
-the corresponding 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 localtime() and gmtime().
-
-The timelocal() and timegm() functions perform range checking on the
-input $sec, $min, $hour, $mday, and $mon values by default. If you'd
-rather they didn't, you can explicitly import the timelocal_nocheck()
-and timegm_nocheck() functions.
-
- use Time::Local 'timelocal_nocheck';
-
- {
- # The 365th day of 1999
- print scalar localtime timelocal_nocheck 0,0,0,365,0,99;
-
- # The twenty thousandth day since 1970
- print scalar localtime timelocal_nocheck 0,0,0,20000,0,70;
-
- # And even the 10,000,000th second since 1999!
- print scalar localtime timelocal_nocheck 10000000,0,0,1,0,99;
- }
-
-Your mileage may vary when trying these with minutes and hours,
-and it doesn't work at all for months.
-
-Strictly speaking, the year should also be specified in a form consistent
-with 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.
-
-Please note, however, that the range of dates that can be actually be handled
-depends on the size of an integer (time_t) on a given platform.
-Currently, this is 32 bits for most systems, yielding an approximate range
-from Dec 1901 to Jan 2038.
-
-Both timelocal() and 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 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 (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 localtime() and 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 gmtime().
-
-timelocal() 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 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 using the RT system at rt.cpan.org, or as a last
-resort, to the datetime@perl.org list.
-
-=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/installer/perllib/Time/gmtime.pm b/Master/tlpkg/installer/perllib/Time/gmtime.pm
deleted file mode 100644
index 4e1359b36d9..00000000000
--- a/Master/tlpkg/installer/perllib/Time/gmtime.pm
+++ /dev/null
@@ -1,90 +0,0 @@
-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.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 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 w(:FIELDS;
- printf "The day in Greenwich is %s\n",
- (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm_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/installer/perllib/Time/localtime.pm b/Master/tlpkg/installer/perllib/Time/localtime.pm
deleted file mode 100644
index c3d9fb36085..00000000000
--- a/Master/tlpkg/installer/perllib/Time/localtime.pm
+++ /dev/null
@@ -1,86 +0,0 @@
-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/installer/perllib/Time/tm.pm b/Master/tlpkg/installer/perllib/Time/tm.pm
deleted file mode 100644
index 2c308ebb411..00000000000
--- a/Master/tlpkg/installer/perllib/Time/tm.pm
+++ /dev/null
@@ -1,33 +0,0 @@
-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/installer/perllib/Tk.pm b/Master/tlpkg/installer/perllib/Tk.pm
deleted file mode 100644
index deb453172eb..00000000000
--- a/Master/tlpkg/installer/perllib/Tk.pm
+++ /dev/null
@@ -1,821 +0,0 @@
-#
-# Copyright (c) 1992-1994 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
-# This program is free software; you can redistribute it and/or
-
-# modify it under the same terms as Perl itself, subject
-# to additional disclaimer in Tk/license.terms due to partial
-# derivation from Tk8.0 sources.
-#
-package Tk;
-require 5.007;
-use Tk::Event ();
-use AutoLoader qw(AUTOLOAD);
-use DynaLoader;
-use Cwd();
-use base qw(Exporter DynaLoader);
-
-*fileevent = \&Tk::Event::IO::fileevent;
-
-use Encode;
-$Tk::encodeStopOnError = Encode::FB_QUIET();
-$Tk::encodeFallback = Encode::FB_PERLQQ(); # Encode::FB_DEFAULT();
-
-our %font_encoding = ('jis0208' => 'jis0208-raw',
- 'jis0212' => 'jis0212-raw',
- 'ksc5601' => 'ksc5601-raw',
- 'gb2312' => 'gb2312-raw',
- 'unicode' => 'ucs-2le',
- );
-
-BEGIN {
- if($^O eq 'cygwin')
- {
- require Tk::Config;
- $Tk::platform = $Tk::Config::win_arch;
- $Tk::platform = 'unix' if $Tk::platform eq 'x';
- }
- else
- {
- $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix';
- }
-};
-
-$Tk::tearoff = 1 if ($Tk::platform eq 'unix');
-
-
-@EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit);
-@EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION
- DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS
- IDLE_EVENTS ALL_EVENTS
- NORMAL_BG ACTIVE_BG SELECT_BG
- SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE);
-%EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS
- TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)],
- variables => [qw(*widget *event)],
- colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG
- TROUGH INDICATOR DISABLED BLACK WHITE)],
- );
-
-use strict;
-use Carp;
-
-# Record author's perforce depot record
-$Tk::CHANGE = q$Change: 3279 $;
-
-# $tk_version and $tk_patchLevel are reset by pTk when a mainwindow
-# is created, $VERSION is checked by bootstrap
-$Tk::version = '8.4';
-$Tk::patchLevel = '8.4';
-$Tk::VERSION = '804.027';
-$Tk::XS_VERSION = $Tk::VERSION;
-$Tk::strictMotif = 0;
-
-
-{($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;}
-$Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library);
-
-$Tk::widget = undef;
-$Tk::event = undef;
-
-use vars qw($inMainLoop);
-
-bootstrap Tk;
-
-my $boot_time = timeofday();
-
-# This is a workround for Solaris X11 locale handling
-Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11'))
- if (NeedPreload() && -d '/usr/openwin/lib');
-
-use Tk::Submethods ('option' => [qw(add get clear readfile)],
- 'clipboard' => [qw(clear append)]
- );
-
-#
-# Next few routines are here as perl code as doing caller()
-# in XS code is very complicated - so instead C code calls BackTrace
-#
-sub _backTrace
-{
- my $w = shift;
- my $i = 1;
- my ($pack,$file,$line,$sub) = caller($i++);
- while (1)
- {
- my $loc = "at $file line $line";
- ($pack,$file,$line,$sub) = caller($i++);
- last unless defined($sub);
- return 1 if $sub eq '(eval)';
- $w->AddErrorInfo("$sub $loc");
- }
- return 0;
-}
-
-sub BackTrace
-{
- my $w = shift;
- return unless (@_ || $@);
- my $mess = (@_) ? shift : "$@";
- die "$mess\n" if $w->_backTrace;
- # if we get here we are not in an eval so report now
- $w->Fail($mess);
- $w->idletasks;
- die "$mess\n";
-}
-
-#
-# This is a $SIG{__DIE__} handler which does not change the $@
-# string in the way 'croak' does, but rather add to Tk's ErrorInfo.
-# It stops at 1st enclosing eval on assumption that the eval
-# is part of Tk call process and will add its own context to ErrorInfo
-# and then pass on the error.
-#
-sub __DIE__
-{
- my $mess = shift;
- my $w = $Tk::widget;
- # Note that if a __DIE__ handler returns it re-dies up the chain.
- return unless defined($w) && Exists($w);
- # This special message is for exit() as an exception see pTkCallback.c
- return if $mess =~/^_TK_EXIT_\(\d+\)/;
- return if $w->_backTrace;
- # Not in an eval - should not happen
-}
-
-sub XEvent::xy { shift->Info('xy') }
-
-sub XEvent::AUTOLOAD
-{
- my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/;
- no strict 'refs';
- *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) };
- goto &$XEvent::AUTOLOAD;
-}
-
-sub NoOp { }
-
-sub Ev
-{
- if (@_ == 1)
- {
- my $arg = $_[0];
- return bless (((ref $arg) ? $arg : \$arg), 'Tk::Ev');
- }
- else
- {
- return bless [@_],'Tk::Ev';
- }
-}
-
-sub InitClass
-{
- my ($package,$parent) = @_;
- croak "Unexpected type of parent $parent" unless(ref $parent);
- croak "$parent is not a widget" unless($parent->IsWidget);
- my $mw = $parent->MainWindow;
- my $hash = $mw->TkHash('_ClassInit_');
- unless (exists $hash->{$package})
- {
- $package->Install($mw);
- $hash->{$package} = $package->ClassInit($mw);
- }
-}
-
-require Tk::Widget;
-require Tk::Image;
-require Tk::MainWindow;
-
-sub Exists
-{my $w = shift;
- return defined($w) && ref($w) && $w->IsWidget && $w->exists;
-}
-
-sub Time_So_Far
-{
- return timeofday() - $boot_time;
-}
-
-# Selection* are not autoloaded as names are too long.
-
-sub SelectionOwn
-{my $widget = shift;
- selection('own',(@_,$widget));
-}
-
-sub SelectionOwner
-{
- selection('own','-displayof',@_);
-}
-
-sub SelectionClear
-{
- selection('clear','-displayof',@_);
-}
-
-sub SelectionExists
-{
- selection('exists','-displayof',@_);
-}
-
-sub SelectionHandle
-{my $widget = shift;
- my $command = pop;
- selection('handle',@_,$widget,$command);
-}
-
-sub SplitString
-{
- local $_ = shift;
- my (@arr, $tmp);
- while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) {
- if (defined $1) { push @arr, $1 }
- else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp }
- }
- # carp '('.join(',',@arr).")";
- return @arr;
-}
-
-sub Methods
-{
- my ($package) = caller;
- no strict 'refs';
- foreach my $meth (@_)
- {
- my $name = $meth;
- *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) };
- }
-}
-
-my %dialog = ( tk_chooseColor => 'ColorDialog',
- tk_messageBox => 'MessageBox',
- tk_getOpenFile => 'FDialog',
- tk_getSaveFile => 'FDialog',
- tk_chooseDirectory => 'FDialog'
-# Slaven claims NI-S's version above does not work
-# and provides this
-# tk_chooseDirectory => 'DirDialog'
- );
-
-foreach my $dialog (keys %dialog)
- {
- no strict 'refs';
- unless (defined &$dialog)
- {
- my $kind = $dialog;
- my $code = \&{"Tk::$dialog{$dialog}"};
- *$dialog = sub { &$code($kind,@_) };
- }
- }
-
-sub MessageBox {
- my ($kind,%args) = @_;
- require Tk::Dialog;
- my $parent = delete $args{'-parent'};
- my $args = \%args;
-
- $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon};
- $args->{-text} = delete $args->{-message} if defined $args->{-message};
- $args->{-type} = 'OK' unless defined $args->{-type};
-
- my $type;
- if (defined($type = delete $args->{-type})) {
- delete $args->{-type};
- my @buttons = grep($_,map(ucfirst($_),
- split(/(abort|retry|ignore|yes|no|cancel|ok)/,
- lc($type))));
- $args->{-buttons} = [@buttons];
- $args->{-default_button} = ucfirst(delete $args->{-default}) if
- defined $args->{-default};
- if (not defined $args->{-default_button} and scalar(@buttons) == 1) {
- $args->{-default_button} = $buttons[0];
- }
- my $md = $parent->Dialog(%$args);
- my $an = $md->Show;
- $md->destroy;
- return $an;
- }
-} # end messageBox
-
-sub messageBox
-{
- my ($widget,%args) = @_;
- # remove in a later version:
- if (exists $args{'-text'})
- {
- warn "The -text option is deprecated. Please use -message instead";
- if (!exists $args{'-message'})
- {
- $args{'-message'} = delete $args{'-text'};
- }
- }
- $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok';
- $args{'-default'} = lc($args{'-default'}) if (exists $args{'-default'});
- ucfirst tk_messageBox(-parent => $widget, %args);
-}
-
-sub getOpenFile
-{
- tk_getOpenFile(-parent => shift,@_);
-}
-
-sub getSaveFile
-{
- tk_getSaveFile(-parent => shift,@_);
-}
-
-sub chooseColor
-{
- tk_chooseColor(-parent => shift,@_);
-}
-
-sub chooseDirectory
-{
- tk_chooseDirectory(-parent => shift,@_);
-}
-
-sub DialogWrapper
-{
- my ($method,$kind,%args) = @_;
- my $created = 0;
- my $w = delete $args{'-parent'};
- if (defined $w)
- {
- $args{'-popover'} = $w;
- }
- else
- {
- $w = MainWindow->new;
- $w->withdraw;
- $created = 1;
- }
- my $mw = $w->toplevel;
- my $fs = $mw->{$kind};
- unless (defined $fs)
- {
- $mw->{$kind} = $fs = $mw->$method(%args);
- }
- else
- {
- $fs->configure(%args);
- }
- my $val = $fs->Show;
- $w->destroy if $created;
- return $val;
-}
-
-sub ColorDialog
-{
- require Tk::ColorEditor;
- DialogWrapper('ColorDialog',@_);
-}
-
-sub FDialog
-{
- require Tk::FBox;
- my $cmd = shift;
- if ($cmd =~ /Save/)
- {
- push @_, -type => 'save';
- }
- elsif ($cmd =~ /Directory/)
- {
- push @_, -type => 'dir';
- }
- DialogWrapper('FBox', $cmd, @_);
-}
-
-sub DirDialog
-{
- require Tk::DirTree;
- DialogWrapper('DirTreeDialog',@_);
-}
-
-*MotifFDialog = \&FDialog;
-
-*CORE::GLOBAL::exit = \&exit;
-
-sub MainLoop
-{
- unless ($inMainLoop)
- {
- local $inMainLoop = 1;
- while (Tk::MainWindow->Count)
- {
- DoOneEvent(0);
- }
- }
-}
-
-sub tkinit { return MainWindow->new(@_) }
-
-# a wrapper on eval which turns off user $SIG{__DIE__}
-sub catch (&)
-{
- my $sub = shift;
- eval {local $SIG{'__DIE__'}; &$sub };
-}
-
-my $Home;
-
-sub TranslateFileName
-{
- local $_ = shift;
- unless (defined $Home)
- {
- $Home = $ENV{'HOME'} || (defined $ENV{'HOMEDRIVE'} && defined $ENV{'HOMEPATH'} ? $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'} : "");
- $Home =~ s#\\#/#g;
- $Home .= '/' unless $Home =~ m#/$#;
- }
- s#~/#$Home#g;
- # warn $_;
- return $_;
-}
-
-sub findINC
-{
- my $file = join('/',@_);
- my $dir;
- $file =~ s,::,/,g;
- foreach $dir (@INC)
- {
- my $path;
- return $path if (-e ($path = "$dir/$file"));
- }
- return undef;
-}
-
-sub idletasks
-{
- shift->update('idletasks');
-}
-
-sub backtrace
-{
- my ($self,$msg,$i) = @_;
- $i = 1 if @_ < 3;
- while (1)
- {
- my ($pack,$file,$line,$sub) = caller($i++);
- last unless defined($sub);
- $msg .= "\n $sub at $file line $line";
- }
- return "$msg\n";
-}
-
-sub die_with_trace
-{
- my ($self,$msg) = @_;
- die $self->backtrace($msg,1);
-}
-
-
-
-1;
-
-__END__
-
-sub Error
-{my $w = shift;
- my $error = shift;
- if (Exists($w))
- {
- my $grab = $w->grab('current');
- $grab->Unbusy if (defined $grab);
- }
- chomp($error);
- warn "Tk::Error: $error\n " . join("\n ",@_)."\n";
-}
-
-sub CancelRepeat
-{
- my $w = shift->MainWindow;
- my $id = delete $w->{_afterId_};
- $w->after('cancel',$id) if (defined $id);
-}
-
-sub RepeatId
-{
- my ($w,$id) = @_;
- $w = $w->MainWindow;
- $w->CancelRepeat;
- $w->{_afterId_} = $id;
-}
-
-
-
-#----------------------------------------------------------------------------
-# focus.tcl --
-#
-# This file defines several procedures for managing the input
-# focus.
-#
-# @(#) focus.tcl 1.6 94/12/19 17:06:46
-#
-# Copyright (c) 1994 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-
-sub FocusChildren { shift->children }
-
-#
-# focusNext --
-# This procedure is invoked to move the input focus to the next window
-# after a given one. "Next" is defined in terms of the window
-# stacking order, with all the windows underneath a given top-level
-# (no matter how deeply nested in the hierarchy) considered except
-# for frames and toplevels.
-#
-# Arguments:
-# w - Name of a window: the procedure will set the focus
-# to the next window after this one in the traversal
-# order.
-sub focusNext
-{
- my $w = shift;
- my $cur = $w;
- 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)
- {
- $cur->tabFocus;
- return;
- }
- }
-}
-# 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;
- 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)
- {
- $cur->tabFocus;
- return;
- }
- }
-
-}
-
-sub FocusOK
-{
- my $w = shift;
- my $value;
- catch { $value = $w->cget('-takefocus') };
- if (!$@ && defined($value))
- {
- return 0 if ($value eq '0');
- return $w->viewable if ($value eq '1');
- if ($value)
- {
- $value = $w->$value();
- return $value if (defined $value);
- }
- }
- if (!$w->viewable)
- {
- return 0;
- }
- catch { $value = $w->cget('-state') } ;
- if (!$@ && defined($value) && $value eq 'disabled')
- {
- return 0;
- }
- $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w)));
- return $value;
-}
-
-
-# focusFollowsMouse
-#
-# If this procedure is invoked, Tk will enter "focus-follows-mouse"
-# mode, where the focus is always on whatever window contains the
-# mouse. If this procedure isn't invoked, then the user typically
-# has to click on a window to give it the focus.
-#
-# Arguments:
-# None.
-
-sub EnterFocus
-{
- my $w = shift;
- return unless $w;
- my $Ev = $w->XEvent;
- my $d = $Ev->d;
- $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior');
-}
-
-sub tabFocus
-{
- shift->Tk::focus;
-}
-
-sub focusFollowsMouse
-{
- my $widget = shift;
- $widget->bind('all','<Enter>','EnterFocus');
-}
-
-# tkTraverseToMenu --
-# This procedure implements keyboard traversal of menus. Given an
-# ASCII character "char", it looks for a menubutton with that character
-# underlined. If one is found, it posts the menubutton's menu
-#
-# Arguments:
-# w - Window in which the key was typed (selects
-# a toplevel window).
-# char - Character that selects a menu. The case
-# is ignored. If an empty string, nothing
-# happens.
-sub TraverseToMenu
-{
- my $w = shift;
- my $char = shift;
- return unless(defined $char && $char ne '');
- $w = $w->toplevel->FindMenu($char);
-}
-# tkFirstMenu --
-# This procedure traverses to the first menubutton in the toplevel
-# for a given window, and posts that menubutton's menu.
-#
-# Arguments:
-# w - Name of a window. Selects which toplevel
-# to search for menubuttons.
-sub FirstMenu
-{
- my $w = shift;
- $w = $w->toplevel->FindMenu('');
-}
-
-# These wrappers don't use method syntax so need to live
-# in same package as raw Tk routines are newXS'ed into.
-
-sub Selection
-{my $widget = shift;
- my $cmd = shift;
- croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own');
- croak "Use Selection\u$cmd()";
-}
-
-# If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....)
-# calls it when it does its eval "require $base"
-#sub Clipboard
-#{my $w = shift;
-# my $cmd = shift;
-# croak "Use clipboard\u$cmd()";
-#}
-
-sub Receive
-{
- my $w = shift;
- warn 'Receive(' . join(',',@_) .')';
- die 'Tk rejects send(' . join(',',@_) .")\n";
-}
-
-sub break
-{
- die "_TK_BREAK_\n";
-}
-
-sub updateWidgets
-{
- my ($w) = @_;
- while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS))
- {
- }
- $w;
-}
-
-sub ImageNames
-{
- image('names');
-}
-
-sub ImageTypes
-{
- image('types');
-}
-
-sub interps
-{
- my $w = shift;
- return $w->winfo('interps','-displayof');
-}
-
-sub lsearch
-{my $ar = shift;
- my $x = shift;
- my $i;
- for ($i = 0; $i < scalar @$ar; $i++)
- {
- return $i if ($$ar[$i] eq $x);
- }
- return -1;
-}
-
-
-sub getEncoding
-{
- my ($class,$name) = @_;
- eval { require Encode };
- if ($@)
- {
- require Tk::DummyEncode;
- return Tk::DummyEncode->getEncoding($name);
- }
- $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name};
- my $enc = Encode::find_encoding($name);
-
- unless ($enc)
- {
- $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//)
- }
-# if ($enc)
-# {
-# print STDERR "Lookup '$name' => ".$enc->name."\n";
-# }
-# else
-# {
-# print STDERR "Failed '$name'\n";
-# }
- unless ($enc)
- {
- if ($name eq 'X11ControlChars')
- {
- require Tk::DummyEncode;
- $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name);
- }
- }
- return $enc;
-}
-
-
-
diff --git a/Master/tlpkg/installer/perllib/Tk/After.pm b/Master/tlpkg/installer/perllib/Tk/After.pm
deleted file mode 100644
index 85a0e406ee5..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/After.pm
+++ /dev/null
@@ -1,104 +0,0 @@
-# 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/installer/perllib/Tk/Button.pm b/Master/tlpkg/installer/perllib/Tk/Button.pm
deleted file mode 100644
index efa597dee14..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Button.pm
+++ /dev/null
@@ -1,148 +0,0 @@
-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.008'; # $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 $relief);
-
-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')
- {
- $w->configure('-state' => 'active');
- $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow)
- }
- $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');
- $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow);
- 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;
- $relief = $w->cget('-relief');
- if ($w->cget('-state') ne 'disabled')
- {
- $buttonWindow = $w;
- $w->configure('-relief' => 'sunken')
- }
-}
-
-# 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;
- $w->configure('-relief' => $relief);
- if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled')
- {
- $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;
- }
-}
-
-
-
-1;
-
-__END__
-
-
-
-
-
diff --git a/Master/tlpkg/installer/perllib/Tk/Canvas.pm b/Master/tlpkg/installer/perllib/Tk/Canvas.pm
deleted file mode 100644
index 210bc30bfc2..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Canvas.pm
+++ /dev/null
@@ -1,1436 +0,0 @@
-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/installer/perllib/Tk/Checkbutton.pm b/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm
deleted file mode 100644
index 491d8cd2444..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm
+++ /dev/null
@@ -1,42 +0,0 @@
-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/installer/perllib/Tk/Clipboard.pm b/Master/tlpkg/installer/perllib/Tk/Clipboard.pm
deleted file mode 100644
index b0eb0ea2b07..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Clipboard.pm
+++ /dev/null
@@ -1,122 +0,0 @@
-# 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/installer/perllib/Tk/CmdLine.pm b/Master/tlpkg/installer/perllib/Tk/CmdLine.pm
deleted file mode 100644
index 2e821e826ae..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/CmdLine.pm
+++ /dev/null
@@ -1,954 +0,0 @@
-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.006'; # $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__
-
-=cut
-
-=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/installer/perllib/Tk/Configure.pm b/Master/tlpkg/installer/perllib/Tk/Configure.pm
deleted file mode 100644
index 26252ae4958..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Configure.pm
+++ /dev/null
@@ -1,69 +0,0 @@
-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/installer/perllib/Tk/Derived.pm b/Master/tlpkg/installer/perllib/Tk/Derived.pm
deleted file mode 100644
index c31c205d2fb..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Derived.pm
+++ /dev/null
@@ -1,512 +0,0 @@
-# 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/installer/perllib/Tk/Dialog.pm b/Master/tlpkg/installer/perllib/Tk/Dialog.pm
deleted file mode 100644
index 8173f4a5acc..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Dialog.pm
+++ /dev/null
@@ -1,70 +0,0 @@
-package Tk::Dialog;
-
-use vars qw($VERSION);
-$VERSION = '4.004'; # $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__
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Tk/DialogBox.pm b/Master/tlpkg/installer/perllib/Tk/DialogBox.pm
deleted file mode 100644
index 13335404e15..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/DialogBox.pm
+++ /dev/null
@@ -1,135 +0,0 @@
-#
-# 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 = 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;
-
- $cw->{'selected_button'} = '';
- $cw->transient($cw->Parent->toplevel);
- $cw->withdraw;
- if (@$buttons == 1) {
- $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'default_button'}->invoke });
- } else {
- $cw->protocol('WM_DELETE_WINDOW' => sub {});
- }
-
- # 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) {
- if ($Tk::platform eq 'MSWin32') {
- $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
- } else {
- 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);
- }
- }
- $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;
- $cw->withdraw;
- $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/installer/perllib/Tk/DummyEncode.pm b/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm
deleted file mode 100644
index 5ead808405d..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm
+++ /dev/null
@@ -1,46 +0,0 @@
-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/installer/perllib/Tk/Entry.pm b/Master/tlpkg/installer/perllib/Tk/Entry.pm
deleted file mode 100644
index 51b3f0c6767..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Entry.pm
+++ /dev/null
@@ -1,615 +0,0 @@
-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/installer/perllib/Tk/Event.pm b/Master/tlpkg/installer/perllib/Tk/Event.pm
deleted file mode 100644
index cecd57c54ae..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Event.pm
+++ /dev/null
@@ -1,13 +0,0 @@
-package Tk::Event;
-use vars qw($VERSION $XS_VERSION @EXPORT_OK);
-END { CleanupGlue() }
-$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/;
-$XS_VERSION = '804.027';
-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/installer/perllib/Tk/Event/IO.pm b/Master/tlpkg/installer/perllib/Tk/Event/IO.pm
deleted file mode 100644
index 10b47e246ff..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Event/IO.pm
+++ /dev/null
@@ -1,132 +0,0 @@
-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/installer/perllib/Tk/Font.pm b/Master/tlpkg/installer/perllib/Tk/Font.pm
deleted file mode 100644
index bb1b52cc7c5..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Font.pm
+++ /dev/null
@@ -1,163 +0,0 @@
-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/installer/perllib/Tk/Frame.pm b/Master/tlpkg/installer/perllib/Tk/Frame.pm
deleted file mode 100644
index a5716cdf9bd..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Frame.pm
+++ /dev/null
@@ -1,378 +0,0 @@
-# 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/installer/perllib/Tk/Image.pm b/Master/tlpkg/installer/perllib/Tk/Image.pm
deleted file mode 100644
index 0f41c387fc2..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Image.pm
+++ /dev/null
@@ -1,74 +0,0 @@
-# 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/installer/perllib/Tk/Label.pm b/Master/tlpkg/installer/perllib/Tk/Label.pm
deleted file mode 100644
index ebea1741c2f..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Label.pm
+++ /dev/null
@@ -1,21 +0,0 @@
-# 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/installer/perllib/Tk/Labelframe.pm b/Master/tlpkg/installer/perllib/Tk/Labelframe.pm
deleted file mode 100644
index 14c577b5e35..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Labelframe.pm
+++ /dev/null
@@ -1,16 +0,0 @@
-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/installer/perllib/Tk/MainWindow.pm b/Master/tlpkg/installer/perllib/Tk/MainWindow.pm
deleted file mode 100644
index 5384ccb560b..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/MainWindow.pm
+++ /dev/null
@@ -1,213 +0,0 @@
-# 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 = 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__
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Tk/Menu.pm b/Master/tlpkg/installer/perllib/Tk/Menu.pm
deleted file mode 100644
index 91e9aceed61..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Menu.pm
+++ /dev/null
@@ -1,1145 +0,0 @@
-# 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 = 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;
- $menu->postcascade('active');
- if (defined $Tk::postedMb)
- {
- $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->Unpost();
- $w->tearOffMenu();
- }
- 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)
- {
- if ($m2->cget('-type') ne 'menubar')
- {
- $menu->activate('none');
- $menu->GenerateMenuSelect;
- $m2->SetFocus;
- # This code unposts any posted submenu in the parent.
- my $tmp = $m2->index('active');
- $m2->activate('none');
- $m2->activate($tmp);
- 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 (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);
- $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," $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);
- # 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');
- 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;
- }
-}
-
-1;
-
-__END__
-
-
diff --git a/Master/tlpkg/installer/perllib/Tk/Menu/Item.pm b/Master/tlpkg/installer/perllib/Tk/Menu/Item.pm
deleted file mode 100644
index 403052ef5bd..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Menu/Item.pm
+++ /dev/null
@@ -1,180 +0,0 @@
-package Tk::Menu::Item;
-
-require Tk::Menu;
-
-use Carp;
-use strict;
-
-use vars qw($VERSION);
-$VERSION = '4.004'; # $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__
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/Tk/PNG.pm b/Master/tlpkg/installer/perllib/Tk/PNG.pm
deleted file mode 100644
index 1ecb4001d17..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/PNG.pm
+++ /dev/null
@@ -1,43 +0,0 @@
-package Tk::PNG;
-require DynaLoader;
-
-use vars qw($VERSION);
-$VERSION = 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 Tk800.* which supplies
-PNG format loader for Photo image type.
-
-
-=head1 AUTHOR
-
-Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
-
-=cut
-
-
diff --git a/Master/tlpkg/installer/perllib/Tk/Photo.pm b/Master/tlpkg/installer/perllib/Tk/Photo.pm
deleted file mode 100644
index a596dc4d78b..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Photo.pm
+++ /dev/null
@@ -1,22 +0,0 @@
-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/installer/perllib/Tk/Pretty.pm b/Master/tlpkg/installer/perllib/Tk/Pretty.pm
deleted file mode 100644
index 7e442a4bcbc..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Pretty.pm
+++ /dev/null
@@ -1,93 +0,0 @@
-# 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/installer/perllib/Tk/ProgressBar.pm b/Master/tlpkg/installer/perllib/Tk/ProgressBar.pm
deleted file mode 100644
index 206d843ea13..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/ProgressBar.pm
+++ /dev/null
@@ -1,498 +0,0 @@
-package Tk::ProgressBar;
-
-use vars qw($VERSION);
-$VERSION = 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($c->find('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/installer/perllib/Tk/ROText.pm b/Master/tlpkg/installer/perllib/Tk/ROText.pm
deleted file mode 100644
index cc5634f5475..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/ROText.pm
+++ /dev/null
@@ -1,43 +0,0 @@
-# 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/installer/perllib/Tk/Radiobutton.pm b/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm
deleted file mode 100644
index d09d41b4208..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm
+++ /dev/null
@@ -1,45 +0,0 @@
-# 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/installer/perllib/Tk/Scrollbar.pm b/Master/tlpkg/installer/perllib/Tk/Scrollbar.pm
deleted file mode 100644
index 6b416e04b30..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Scrollbar.pm
+++ /dev/null
@@ -1,429 +0,0 @@
-# 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/installer/perllib/Tk/Submethods.pm b/Master/tlpkg/installer/perllib/Tk/Submethods.pm
deleted file mode 100644
index a2b8e3bd186..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Submethods.pm
+++ /dev/null
@@ -1,46 +0,0 @@
-package Tk::Submethods;
-
-use vars qw($VERSION);
-$VERSION = '4.004'; # $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__
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Tk/Text.pm b/Master/tlpkg/installer/perllib/Tk/Text.pm
deleted file mode 100644
index fe0aa0bf4c1..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Text.pm
+++ /dev/null
@@ -1,1653 +0,0 @@
-# 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*$/;
-
-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->insert($Ev->xy,$w->SelectionGet) }
- }
-}
-
-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.
-
-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/installer/perllib/Tk/Toplevel.pm b/Master/tlpkg/installer/perllib/Tk/Toplevel.pm
deleted file mode 100644
index 7bcd156d475..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Toplevel.pm
+++ /dev/null
@@ -1,211 +0,0 @@
-# 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/installer/perllib/Tk/Trace.pm b/Master/tlpkg/installer/perllib/Tk/Trace.pm
deleted file mode 100644
index 1e38e79a065..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Trace.pm
+++ /dev/null
@@ -1,405 +0,0 @@
-package Tk::Trace;
-
-use vars qw($VERSION);
-$VERSION = 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/installer/perllib/Tk/Widget.pm b/Master/tlpkg/installer/perllib/Tk/Widget.pm
deleted file mode 100644
index e94c037e6fe..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Widget.pm
+++ /dev/null
@@ -1,1510 +0,0 @@
-# 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 = 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.
-sub setPalette
-{
- my $w = shift->MainWindow;
- 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});
- $new{'foreground'} = 'black' unless (exists $new{foreground});
- my @bg = $w->rgb($new{'background'});
- 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;
-
- # Walk the widget hierarchy, recoloring all existing windows.
- $w->RecolorTree(\%new);
- # 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 $Palette = $w->Palette;
- foreach my $dbOption (keys %$colors)
- {
- my $option = "-\L$dbOption";
- my $value;
- eval {local $SIG{'__DIE__'}; $value = $w->cget($option) };
- if (defined $value)
- {
- if ($value eq $Palette->{$dbOption})
- {
- $w->configure($option,$colors->{$dbOption});
- }
- }
- }
- foreach my $child ($w->children)
- {
- $child->RecolorTree($colors);
- }
-}
-# 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;
- eval {local $SIG{'__DIE__'}; $w->grab };
- $w->update;
- if ($sub)
- {
- 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;
-}
diff --git a/Master/tlpkg/installer/perllib/Tk/Wm.pm b/Master/tlpkg/installer/perllib/Tk/Wm.pm
deleted file mode 100644
index ffbe4877857..00000000000
--- a/Master/tlpkg/installer/perllib/Tk/Wm.pm
+++ /dev/null
@@ -1,174 +0,0 @@
-# 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 = 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
- iconwindow maxsize minsize overrideredirect positionfrom
- protocol resizable sizefrom 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/installer/perllib/UNIVERSAL.pm b/Master/tlpkg/installer/perllib/UNIVERSAL.pm
deleted file mode 100644
index 7b7bfc4058a..00000000000
--- a/Master/tlpkg/installer/perllib/UNIVERSAL.pm
+++ /dev/null
@@ -1,147 +0,0 @@
-package UNIVERSAL;
-
-our $VERSION = '1.01';
-
-# UNIVERSAL should not contain any extra subs/methods beyond those
-# that it exists to define. The use of Exporter below is a historical
-# accident that can't be fixed without breaking code. Note that we
-# *don't* set @ISA here, don't want all classes/objects inheriting from
-# Exporter. It's bad enough that all classes have a import() method
-# whenever UNIVERSAL.pm is loaded.
-require Exporter;
-*import = \&Exporter::import;
-@EXPORT_OK = qw(isa can VERSION);
-
-1;
-__END__
-
-=head1 NAME
-
-UNIVERSAL - base class for ALL classes (blessed references)
-
-=head1 SYNOPSIS
-
- $is_io = $fd->isa("IO::Handle");
- $is_io = Class->isa("IO::Handle");
-
- $sub = $obj->can("print");
- $sub = Class->can("print");
-
- use UNIVERSAL qw( isa can VERSION );
- $yes = isa $ref, "HASH" ;
- $sub = can $ref, "fandango" ;
- $ver = VERSION $obj ;
-
-=head1 DESCRIPTION
-
-C<UNIVERSAL> is the base class which all bless references will inherit from,
-see L<perlobj>.
-
-C<UNIVERSAL> provides the following methods and functions:
-
-=over 4
-
-=item C<< $obj->isa( TYPE ) >>
-
-=item C<< CLASS->isa( TYPE ) >>
-
-=item C<isa( VAL, TYPE )>
-
-Where
-
-=over 4
-
-=item C<TYPE>
-
-is a package name
-
-=item C<$obj>
-
-is a blessed reference or a string containing a package name
-
-=item C<CLASS>
-
-is a package name
-
-=item C<VAL>
-
-is any of the above or an unblessed reference
-
-=back
-
-When used as an instance or class method (C<< $obj->isa( TYPE ) >>),
-C<isa> returns I<true> if $obj is blessed into package C<TYPE> or
-inherits from package C<TYPE>.
-
-When used as a class method (C<< CLASS->isa( TYPE ) >>: sometimes
-referred to as a static method), C<isa> returns I<true> if C<CLASS>
-inherits from (or is itself) the name of the package C<TYPE> or
-inherits from package C<TYPE>.
-
-When used as a function, like
-
- use UNIVERSAL qw( isa ) ;
- $yes = isa $h, "HASH";
- $yes = isa "Foo", "Bar";
-
-or
-
- require UNIVERSAL ;
- $yes = UNIVERSAL::isa $a, "ARRAY";
-
-C<isa> returns I<true> in the same cases as above and also if C<VAL> is an
-unblessed reference to a perl variable of type C<TYPE>, such as "HASH",
-"ARRAY", or "Regexp".
-
-=item C<< $obj->can( METHOD ) >>
-
-=item C<< CLASS->can( METHOD ) >>
-
-=item C<can( VAL, METHOD )>
-
-C<can> checks if the object or class has a method called C<METHOD>. If it does
-then a reference to the sub is returned. If it does not then I<undef> is
-returned. This includes methods inherited or imported by C<$obj>, C<CLASS>, or
-C<VAL>.
-
-C<can> cannot know whether an object will be able to provide a method
-through AUTOLOAD, so a return value of I<undef> does not necessarily mean
-the object will not be able to handle the method call. To get around
-this some module authors use a forward declaration (see L<perlsub>)
-for methods they will handle via AUTOLOAD. For such 'dummy' subs, C<can>
-will still return a code reference, which, when called, will fall through
-to the AUTOLOAD. If no suitable AUTOLOAD is provided, calling the coderef
-will cause an error.
-
-C<can> can be called as a class (static) method, an object method, or a
-function.
-
-When used as a function, if C<VAL> is a blessed reference or package name which
-has a method called C<METHOD>, C<can> returns a reference to the subroutine.
-If C<VAL> is not a blessed reference, or if it does not have a method
-C<METHOD>, I<undef> is returned.
-
-=item C<VERSION ( [ REQUIRE ] )>
-
-C<VERSION> will return the value of the variable C<$VERSION> in the
-package the object is blessed into. If C<REQUIRE> is given then
-it will do a comparison and die if the package version is not
-greater than or equal to C<REQUIRE>.
-
-C<VERSION> can be called as either a class (static) method, an object
-method or a function.
-
-
-=back
-
-=head1 EXPORTS
-
-None by default.
-
-You may request the import of all three functions (C<isa>, C<can>, and
-C<VERSION>), however it isn't usually necessary to do so. Perl magically
-makes these functions act as methods on all objects. The one exception is
-C<isa>, which is useful as a function when operating on non-blessed
-references.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Win32.pm b/Master/tlpkg/installer/perllib/Win32.pm
deleted file mode 100644
index e55bfee4dfe..00000000000
--- a/Master/tlpkg/installer/perllib/Win32.pm
+++ /dev/null
@@ -1,712 +0,0 @@
-package Win32;
-
-BEGIN {
- use strict;
- use vars qw|$VERSION @ISA @EXPORT @EXPORT_OK|;
-
- require Exporter;
- require DynaLoader;
-
- @ISA = qw|Exporter DynaLoader|;
- $VERSION = '0.2601';
-
- @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
- );
-}
-
-# Routines available in core:
-# Win32::GetLastError
-# Win32::LoginName
-# Win32::NodeName
-# Win32::DomainName
-# Win32::FsType
-# Win32::GetCwd
-# Win32::GetOSVersion
-# Win32::FormatMessage ERRORCODE
-# Win32::Spawn COMMAND, ARGS, PID
-# Win32::GetTickCount
-# Win32::IsWinNT
-# Win32::IsWin95
-
-# 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 ($found_os, $found_desc);
-
-sub GetOSName {
- my ($os,$desc,$major, $minor, $build, $id)=("","");
- unless (defined $found_os) {
- # If we have a run this already, we have the results cached
- # If so, return them
-
- # Use the standard API call to determine the version
- ($desc, $major, $minor, $build, $id) = Win32::GetOSVersion();
-
- # If id==0 then its a win32s box -- Meaning Win3.11
- unless($id) {
- $os = 'Win32s';
- }
- else {
- # Magic numbers from MSDN documentation of OSVERSIONINFO
- # Most version names can be parsed from just the id and minor
- # version
- $os = {
- 1 => {
- 0 => "95",
- 10 => "98",
- 90 => "Me"
- },
- 2 => {
- 0 => "NT4",
- 1 => "XP/.Net",
- 2 => "2003",
- 51 => "NT3.51"
- }
- }->{$id}->{$minor};
- }
-
- # This _really_ shouldnt happen. At least not for quite a while
- # Politely warn and return undef
- unless (defined $os) {
- warn qq[Windows version [$id:$major:$minor] unknown!];
- return undef;
- }
-
- my $tag = "";
-
- # But distinguising W2k and Vista from NT4 requires looking at the major version
- if ($os eq "NT4") {
- $os = {5 => "2000", 6 => "Vista"}->{$major} || "NT4";
- }
-
- # For the rest we take a look at the build numbers and try to deduce
- # the exact release name, but we put that in the $desc
- elsif ($os eq "95") {
- if ($build eq '67109814') {
- $tag = '(a)';
- }
- elsif ($build eq '67306684') {
- $tag = '(b1)';
- }
- elsif ($build eq '67109975') {
- $tag = '(b2)';
- }
- }
- elsif ($os eq "98" && $build eq '67766446') {
- $tag = '(2nd ed)';
- }
-
- if (length $tag) {
- if (length $desc) {
- $desc = "$tag $desc";
- }
- else {
- $desc = $tag;
- }
- }
-
- # cache the results, so we dont have to do this again
- $found_os = "Win$os";
- $found_desc = $desc;
- }
-
- return wantarray ? ($found_os, $found_desc) : $found_os;
-}
-
-bootstrap Win32;
-
-1;
-
-__END__
-
-=head1 NAME
-
-Win32 - Interfaces to some Win32 API Functions
-
-=head1 DESCRIPTION
-
-Perl on Win32 contains several functions to access Win32 APIs. Some
-are included in Perl itself (on Win32) and some are only available
-after explicitly requesting the Win32 module with:
-
- use Win32;
-
-The builtin functions are marked as [CORE] and the other ones
-as [EXT] in the following alphabetical listing.
-
-=head2 Alphabetical Listing of Win32 Functions
-
-=over
-
-=item Win32::AbortSystemShutdown(MACHINE)
-
-[EXT] 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::DomainName()
-
-[CORE] Returns the name of the Microsoft Network domain that the
-owner of the current perl process is logged into. This function does
-B<not> work on Windows 9x.
-
-=item Win32::ExpandEnvironmentStrings(STRING)
-
-[EXT] 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
-
-=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)
-
-[EXT] 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::GetArchName()
-
-[EXT] Use of this function is deprecated. It is equivalent with
-$ENV{PROCESSOR_ARCHITECTURE}. This might not work on Win9X.
-
-=item Win32::GetChipName()
-
-[EXT] 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.
-
-=item Win32::GetFileVersion(FILENAME)
-
-[EXT] 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])
-
-[EXT] 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
-
-=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.
-
-=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.
-
-=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. 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
-
-On Windows NT 4 SP6 and later this function returns the following
-additional values: SPMAJOR, SPMINOR, SUITEMASK, PRODUCTTYPE.
-
-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)
- 2 - Domaincontroller
- 3 - Server
-
-=item Win32::GetOSName()
-
-[EXT] 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
-
- Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003
-
-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.
-
-=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. Compare with Win32::GetFullPathName and
-Win32::GetLongPathName.
-
-=item Win32::GetProcAddress(INSTANCE, PROCNAME)
-
-[EXT] 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()
-
-[EXT] 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)
-
-[EXT] 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()
-
-[EXT] 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.
-Returns the undefined value 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)
-
-[EXT] 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.
-
-=item Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE)
-
-[EXT] Looks up ACCOUNT on SYSTEM and returns the domain name the SID and
-the SID type.
-
-=item Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE)
-
-[EXT] Looks up SID on SYSTEM and returns the account name, domain name,
-and the SID type.
-
-=item Win32::MsgBox(MESSAGE [, FLAGS [, TITLE]])
-
-[EXT] 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::RegisterServer(LIBRARYNAME)
-
-[EXT] 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>.
-
-[EXT] 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)
-
-[EXT] Loads the DLL LIBRARYNAME and calls the function
-DllUnregisterServer.
-
-=back
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/API.pm b/Master/tlpkg/installer/perllib/Win32/API.pm
deleted file mode 100644
index e1bac5cda48..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/API.pm
+++ /dev/null
@@ -1,745 +0,0 @@
-package Win32::API;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-#######################################################################
-#
-# Win32::API - Perl Win32 API Import Facility
-#
-# Version: 0.47
-# Date: 12 Nov 2007
-# 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,v 1.0 2001/10/30 13:57:31 dada Exp $
-#
-#######################################################################
-
-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;
-BEGIN {
- if ($^O eq 'cygwin') {
- require File::Basename;
- }
-}
-
-#######################################################################
-# STATIC OBJECT PROPERTIES
-#
-$VERSION = '0.47';
-
-#### 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) = @_;
- 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}) = 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);
- }
-
- #### 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) = @_;
- $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) 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}});
- }
-}
-
-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+(\S+)\s*\(([^\)]*)\)/) {
- my $ret = $1;
- my $proc = $2;
- my $params = $3;
-
- $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') );
- } 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)) );
- }
- } else {
- warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
- return ( $proc, \@in_params, \@in_types, type_to_num('I') );
- }
-
- } 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 anything (parameters input and output is limited
-to simpler cases), and anyway a regular XS extension is
-always safer and faster.
-
-The current version of Win32::API is available at my website:
-
- http://dada.perl.it/
-
-It's also available on your nearest CPAN mirror (but allow a few days
-for worldwide spreading of the latest version) reachable at:
-
- http://www.perl.com/CPAN/authors/Aldo_Calpini/
-
-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 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.
-
-
-=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
-
-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.
-
-=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 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> )
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/API.pm.orig b/Master/tlpkg/installer/perllib/Win32/API.pm.orig
deleted file mode 100644
index 9e4accd8bf6..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/API.pm.orig
+++ /dev/null
@@ -1,741 +0,0 @@
-package Win32::API;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-#######################################################################
-#
-# Win32::API - Perl Win32 API Import Facility
-#
-# Version: 0.47
-# Date: 12 Nov 2007
-# 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,v 1.0 2001/10/30 13:57:31 dada Exp $
-#
-#######################################################################
-
-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.47';
-
-#### 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) = @_;
- 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}) = 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);
- }
-
- #### 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) = @_;
- $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) 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}});
- }
-}
-
-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+(\S+)\s*\(([^\)]*)\)/) {
- my $ret = $1;
- my $proc = $2;
- my $params = $3;
-
- $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') );
- } 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)) );
- }
- } else {
- warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
- return ( $proc, \@in_params, \@in_types, type_to_num('I') );
- }
-
- } 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 anything (parameters input and output is limited
-to simpler cases), and anyway a regular XS extension is
-always safer and faster.
-
-The current version of Win32::API is available at my website:
-
- http://dada.perl.it/
-
-It's also available on your nearest CPAN mirror (but allow a few days
-for worldwide spreading of the latest version) reachable at:
-
- http://www.perl.com/CPAN/authors/Aldo_Calpini/
-
-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 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.
-
-
-=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
-
-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.
-
-=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 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> )
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/API/Callback.pm b/Master/tlpkg/installer/perllib/Win32/API/Callback.pm
deleted file mode 100644
index 22de9d4f46a..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/API/Callback.pm
+++ /dev/null
@@ -1,174 +0,0 @@
-package Win32::API::Callback;
-
-# 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,v 1.0 2001/10/30 13:57:31 dada Exp $
-#
-#######################################################################
-
-$VERSION = '0.47';
-
-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/installer/perllib/Win32/API/Struct.pm b/Master/tlpkg/installer/perllib/Win32/API/Struct.pm
deleted file mode 100644
index 05a4c8c60a5..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/API/Struct.pm
+++ /dev/null
@@ -1,532 +0,0 @@
-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,v 1.0 2001/10/30 13:57:31 dada Exp $
-#######################################################################
-
-$VERSION = '0.47';
-
-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/installer/perllib/Win32/API/Test.pm b/Master/tlpkg/installer/perllib/Win32/API/Test.pm
deleted file mode 100644
index 6cbeed6bfac..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/API/Test.pm
+++ /dev/null
@@ -1,120 +0,0 @@
-#
-# Win32::API::Test - Test helper package for Win32::API
-#
-# Version: 0.01
-# Date: 23 Dec 2006
-# Author: Cosimo Streppone <cosimo@cpan.org>
-#
-# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
-#
-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.
-#
-# ***
-# *** IT DOES NOT WORK NOW.
-# *** FOR REASONS I DON'T KNOW, CL.EXE OUTPUTS ITS
-# *** VERSION STRING IN THE FIRST TWO LINES THAT
-# *** I'M NOT ABLE TO CATCH...
-# ***
-#
-sub compiler_version_from_shell () {
- my $cc = compiler_name();
- my $ver;
- # MSVC
- if($cc eq 'cl')
- {
- my @ver = `$cc`;
- my $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`);
- 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/installer/perllib/Win32/API/Type.pm b/Master/tlpkg/installer/perllib/Win32/API/Type.pm
deleted file mode 100644
index 334b0b731e1..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/API/Type.pm
+++ /dev/null
@@ -1,446 +0,0 @@
-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,v 1.0 2001/10/30 13:57:31 dada Exp $
-#######################################################################
-
-$VERSION = '0.47';
-
-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 = $_[0];
-
- if(packing($type) eq 'c' and is_pointer($type)) {
- $_[1] = pack("Z*", $_[1]);
- return $_[1];
- }
- $_[1] = pack( packing($type), $_[1]);
- return $_[1];
-}
-
-sub Unpack {
- my $type = $_[0];
- if(packing($type) eq 'c' and is_pointer($type)) {
- DEBUG "(PM)Type::Unpack: got packing 'c', is a pointer, unpacking 'Z*' '$_[1]'\n";
- $_[1] = unpack("Z*", $_[1]);
- DEBUG "(PM)Type::Unpack: returning '$_[1]'\n";
- return $_[1];
- }
- DEBUG "(PM)Type::Unpack: unpacking '".packing($type)."' '$_[1]'\n";
- $_[1] = unpack( packing($type), $_[1]);
- DEBUG "(PM)Type::Unpack: returning '$_[1]'\n";
- return $_[1];
-}
-
-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
-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/installer/perllib/Win32/ChangeNotify.pm b/Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm
deleted file mode 100644
index a86682da376..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm
+++ /dev/null
@@ -1,198 +0,0 @@
-#---------------------------------------------------------------------
-package Win32::ChangeNotify;
-#
-# Copyright 1998 Christopher J. Madsen
-#
-# Created: 3 Feb 1998 from the ActiveWare version
-# (c) 1995 Microsoft Corporation. All rights reserved.
-# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com
-#
-# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com>
-#
-# Author: Christopher J. Madsen <cjm@pobox.com>
-# Version: 1.02 (13-Jun-1999)
-#
-# This program 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. See either the
-# GNU General Public License or the Artistic License for more details.
-#
-# Monitor directory for changes
-#---------------------------------------------------------------------
-# 1.04 -Minor changes by Yves Orton to fix the trueness of $subtree (Dec 2002)
-
-$VERSION = '1.05';
-
-use Carp;
-use Win32::IPC 1.00 '/./'; # Import everything
-require Exporter;
-require DynaLoader;
-
-@ISA = qw(Exporter DynaLoader Win32::IPC);
-# 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(
- FILE_NOTIFY_CHANGE_ATTRIBUTES
- FILE_NOTIFY_CHANGE_DIR_NAME
- FILE_NOTIFY_CHANGE_FILE_NAME
- FILE_NOTIFY_CHANGE_LAST_WRITE
- FILE_NOTIFY_CHANGE_SECURITY
- FILE_NOTIFY_CHANGE_SIZE
- INFINITE
-);
-@EXPORT_OK = qw(
- wait_all wait_any
-);
-
-sub AUTOLOAD {
- # This AUTOLOAD is used to 'autoload' constants from the constant()
- # XS function.
-
- my $constname;
- ($constname = $AUTOLOAD) =~ s/.*:://;
- if ($constname =~ /^(?:FILE_NOTIFY_CHANGE_|INFINITE)/) {
- local $! = 0;
- my $val = constant($constname);
- croak("$constname is not defined by Win32::ChangeNotify") if $! != 0;
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
- }
-} # end AUTOLOAD
-
-bootstrap Win32::ChangeNotify;
-
-sub new {
- my ($class,$path,$subtree,$filter) = @_;
-
- if ($filter =~ /\A[\s|A-Z_]+\Z/i) {
- $filter = 0;
- foreach (split(/[\s|]+/, $_[3])) {
- $filter |= constant("FILE_NOTIFY_CHANGE_" . uc $_);
- carp "Invalid filter $_" if $!;
- }
- }
- _new($class,$path,$subtree,$filter);
-} # end new
-
-sub Close { &close }
-
-sub FindFirst { $_[0] = Win32::ChangeNotify->_new(@_[1..3]); }
-
-sub FindNext { &reset }
-
-1;
-__END__
-
-=head1 NAME
-
-Win32::ChangeNotify - Monitor events related to files and directories
-
-=head1 SYNOPSIS
-
- require Win32::ChangeNotify;
-
- $notify = Win32::ChangeNotify->new($Path,$WatchSubTree,$Events);
- $notify->wait or warn "Something failed: $!\n";
- # There has been a change.
-
-=head1 DESCRIPTION
-
-This module allows the user to use a Win32 change notification event
-object from Perl. This allows the Perl program to monitor events
-relating to files and directory trees.
-
-Unfortunately, the Win32 API which implements this feature does not
-provide any indication of I<what> triggered the notification (as far
-as I know). If you're monitoring a directory for file changes, and
-you need to know I<which> file changed, you'll have to find some other
-way of determining that. Depending on exactly what you're trying to
-do, you may be able to check file timestamps to find recently changed
-files. Or, you may need to cache the directory contents somewhere and
-compare the current contents to your cached copy when you receive a
-change notification.
-
-The C<wait> method and C<wait_all> & C<wait_any> functions are
-inherited from the L<"Win32::IPC"> module.
-
-=head2 Methods
-
-=over 4
-
-=item $notify = Win32::ChangeNotify->new($path, $subtree, $filter)
-
-Constructor for a new ChangeNotification object. C<$path> is the
-directory to monitor. If C<$subtree> is true, then all directories
-under C<$path> will be monitored. C<$filter> indicates what events
-should trigger a notification. It should be a string containing any
-of the following flags (separated by whitespace and/or C<|>).
-
- ATTRIBUTES Any attribute change
- DIR_NAME Any directory name change
- FILE_NAME Any file name change (creating/deleting/renaming)
- LAST_WRITE Any change to a file's last write time
- SECURITY Any security descriptor change
- SIZE Any change in a file's size
-
-(C<$filter> can also be an integer composed from the
-C<FILE_NOTIFY_CHANGE_*> constants.)
-
-=item $notify->close
-
-Shut down monitoring. You could just C<undef $notify> instead (but
-C<close> works even if there are other copies of the object). This
-happens automatically when your program exits.
-
-=item $notify->reset
-
-Resets the ChangeNotification object after a change has been detected.
-The object will become signalled again after the next change. (It is
-OK to call this immediately after C<new>, but it is not required.)
-
-=item $notify->wait
-
-See L<"Win32::IPC">. Remember to call C<reset> afterwards if you want
-to continue monitoring.
-
-=back
-
-=head2 Deprecated Functions and Methods
-
-B<Win32::ChangeNotify> still supports the ActiveWare syntax, but its
-use is deprecated.
-
-=over 4
-
-=item FindFirst($Obj,$PathName,$WatchSubTree,$Filter)
-
-Use
-
- $Obj = Win32::ChangeNotify->new($PathName,$WatchSubTree,$Filter)
-
-instead.
-
-=item $obj->FindNext()
-
-Use C<$obj-E<gt>reset> instead.
-
-=item $obj->Close()
-
-Use C<$obj-E<gt>close> instead.
-
-=back
-
-=head1 AUTHOR
-
-Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt>
-
-Loosely based on the original module by ActiveWare Internet Corp.,
-F<http://www.ActiveWare.com>
-
-=cut
-
-# Local Variables:
-# tmtrack-file-task: "Win32::ChangeNotify"
-# End:
diff --git a/Master/tlpkg/installer/perllib/Win32/Client.pl b/Master/tlpkg/installer/perllib/Win32/Client.pl
deleted file mode 100644
index 6ae585b7c91..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Client.pl
+++ /dev/null
@@ -1,63 +0,0 @@
-use strict;
-use Win32::Pipe;
-
-####
-# You may notice that named pipe names are case INsensitive!
-####
-
-my $PipeName = "\\\\.\\pipe\\TEST this LoNG Named Pipe!";
-
-print "I am falling asleep for few seconds, so that we give time\nFor the server to get up and running.\n";
-sleep(4);
-print "\nOpening a pipe ...\n";
-
-if (my $Pipe = Win32::Pipe->new($PipeName)) {
- print "\n\nPipe has been opened, writing data to it...\n";
- print "-------------------------------------------\n";
- $Pipe->Write("\n" . Win32::Pipe::Credit() . "\n\n");
- while () {
- print "\nCommands:\n";
- print " FILE:xxxxx Dumps the file xxxxx.\n";
- print " Credit Dumps the credit screen.\n";
- print " Quit Quits this client (server remains running).\n";
- print " Exit Exits both client and server.\n";
- print " -----------------------------------------\n";
-
- my $In = <STDIN>;
- chop($In);
-
- if ((my $File = $In) =~ s/^file:(.*)/$1/i){
- if (-s $File) {
- if (open(FILE, "< $File")) {
- while ($File = <FILE>) {
- $In .= $File;
- };
- close(FILE);
- }
- }
- }
-
- if ($In =~ /^credit$/i){
- $In = "\n" . Win32::Pipe::Credit() . "\n\n";
- }
-
- unless ($Pipe->Write($In)) {
- print "Writing to pipe failed.\n";
- last;
- }
-
- if ($In =~ /^(exit|quit)$/i) {
- print "\nATTENTION: Closing due to user request.\n";
- last;
- }
- }
- print "Closing...\n";
- $Pipe->Close();
-}
-else {
- my($Error, $ErrorText) = Win32::Pipe::Error();
- print "Error:$Error \"$ErrorText\"\n";
- sleep(4);
-}
-
-print "Done...\n";
diff --git a/Master/tlpkg/installer/perllib/Win32/Clipboard.pm b/Master/tlpkg/installer/perllib/Win32/Clipboard.pm
deleted file mode 100644
index ba4038a5ade..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Clipboard.pm
+++ /dev/null
@@ -1,369 +0,0 @@
-package Win32::Clipboard;
-#######################################################################
-#
-# Win32::Clipboard - Interaction with the Windows clipboard
-#
-# Version: 0.52
-# Author: Aldo Calpini <dada@perl.it>
-#
-# Modified by: Hideyo Imazu <himazu@gmail.com>
-#
-#######################################################################
-
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
-
-@ISA = qw( Exporter DynaLoader );
-@EXPORT = qw(
- CF_TEXT
- CF_BITMAP
- CF_METAFILEPICT
- CF_SYLK
- CF_DIF
- CF_TIFF
- CF_OEMTEXT
- CF_DIB
- CF_PALETTE
- CF_PENDATA
- CF_RIFF
- CF_WAVE
- CF_UNICODETEXT
- CF_ENHMETAFILE
- CF_HDROP
- CF_LOCALE
-);
-
-#######################################################################
-# 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 $! = 0;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
- if ($! =~ /Invalid/) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- } else {
- my ($pack, $file, $line) = caller;
- die "Win32::Clipboard::$constname is not defined, used at $file line $line.";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-
-#######################################################################
-# STATIC OBJECT PROPERTIES
-#
-$VERSION = "0.5201";
-
-#######################################################################
-# FUNCTIONS
-#
-
-sub new {
- my($class, $value) = @_;
- my $self = "I'm the Clipboard!";
- Set($value) if defined($value);
- return bless(\$self);
-}
-
-sub Version {
- return $VERSION;
-}
-
-sub Get {
- if( IsBitmap() ) { return GetBitmap(); }
- elsif( IsFiles() ) { return GetFiles(); }
- else { return GetText(); }
-}
-
-sub TIESCALAR {
- my $class = shift;
- my $value = shift;
- Set($value) if defined $value;
- my $self = "I'm the Clipboard!";
- return bless \$self, $class;
-}
-
-sub FETCH { Get() }
-sub STORE { shift; Set(@_) }
-
-sub DESTROY {
- my($self) = @_;
- undef $self;
- StopClipboardViewer();
-}
-
-END {
- StopClipboardViewer();
-}
-
-#######################################################################
-# dynamically load in the Clipboard.pll module.
-#
-
-bootstrap Win32::Clipboard;
-
-#######################################################################
-# a little hack to use the module itself as a class.
-#
-
-sub main::Win32::Clipboard {
- my($value) = @_;
- my $self={};
- my $result = Win32::Clipboard::Set($value) if defined($value);
- return bless($self, "Win32::Clipboard");
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Win32::Clipboard - Interaction with the Windows clipboard
-
-=head1 SYNOPSIS
-
- use Win32::Clipboard;
-
- $CLIP = Win32::Clipboard();
-
- print "Clipboard contains: ", $CLIP->Get(), "\n";
-
- $CLIP->Set("some text to copy into the clipboard");
-
- $CLIP->Empty();
-
- $CLIP->WaitForChange();
- print "Clipboard has changed!\n";
-
-
-=head1 DESCRIPTION
-
-This module lets you interact with the Windows clipboard: you can get its content,
-set it, empty it, or let your script sleep until it changes.
-This version supports 3 formats for clipboard data:
-
-=over 4
-
-=item *
-text (C<CF_TEXT>)
-
-The clipboard contains some text; this is the B<only> format you can use to set
-clipboard data; you get it as a single string.
-
-Example:
-
- $text = Win32::Clipboard::GetText();
- print $text;
-
-=item *
-bitmap (C<CF_DIB>)
-
-The clipboard contains an image, either a bitmap or a picture copied in the
-clipboard from a graphic application. The data you get is a binary buffer
-ready to be written to a bitmap (BMP format) file.
-
-Example:
-
- $image = Win32::Clipboard::GetBitmap();
- open BITMAP, ">some.bmp";
- binmode BITMAP;
- print BITMAP $image;
- close BITMAP;
-
-=item *
-list of files (C<CF_HDROP>)
-
-The clipboard contains files copied or cutted from an Explorer-like
-application; you get a list of filenames.
-
-Example:
-
- @files = Win32::Clipboard::GetFiles();
- print join("\n", @files);
-
-=back
-
-=head2 REFERENCE
-
-All the functions can be used either with their full name (eg. B<Win32::Clipboard::Get>)
-or as methods of a C<Win32::Clipboard> object.
-For the syntax, refer to L</SYNOPSIS> above. Note also that you can create a clipboard
-object and set its content at the same time with:
-
- $CLIP = Win32::Clipboard("blah blah blah");
-
-or with the more common form:
-
- $CLIP = new Win32::Clipboard("blah blah blah");
-
-If you prefer, you can even tie the Clipboard to a variable like this:
-
- tie $CLIP, 'Win32::Clipboard';
-
- print "Clipboard content: $CLIP\n";
-
- $CLIP = "some text to copy to the clipboard...";
-
-In this case, you can still access other methods using the tied() function:
-
- tied($CLIP)->Empty;
- print "got the picture" if tied($CLIP)->IsBitmap;
-
-=over 4
-
-=item Empty()
-
-Empty the clipboard.
-
-=for html <P>
-
-=item EnumFormats()
-
-Returns an array of identifiers describing the format for the data currently in the
-clipboard. Formats can be standard ones (described in the L</CONSTANTS> section) or
-application-defined custom ones. See also IsFormatAvailable().
-
-=for html <P>
-
-=item Get()
-
-Returns the clipboard content; note that the result depends on the nature of
-clipboard data; to ensure that you get only the desired format, you should use
-GetText(), GetBitmap() or GetFiles() instead. Get() is in fact implemented as:
-
- if( IsBitmap() ) { return GetBitmap(); }
- elsif( IsFiles() ) { return GetFiles(); }
- else { return GetText(); }
-
-See also IsBitmap(), IsFiles(), IsText(), EnumFormats() and IsFormatAvailable()
-to check the clipboard format before getting data.
-
-=for html <P>
-
-=item GetAs(FORMAT)
-
-Returns the clipboard content in the desired FORMAT (can be one of the constants
-defined in the L</CONSTANTS> section or a custom format). Note that the only
-meaningful identifiers are C<CF_TEXT>, C<CF_DIB> and C<CF_HDROP>; any other
-format is treated as a string.
-
-=for html <P>
-
-=item GetBitmap()
-
-Returns the clipboard content as an image, or C<undef> on errors.
-
-=for html <P>
-
-=item GetFiles()
-
-Returns the clipboard content as a list of filenames, or C<undef> on errors.
-
-=for html <P>
-
-=item GetFormatName(FORMAT)
-
-Returns the name of the specified custom clipboard format, or C<undef> on errors;
-note that you cannot get the name of the standard formats (described in the
-L</CONSTANTS> section).
-
-=for html <P>
-
-=item GetText()
-
-Returns the clipboard content as a string, or C<undef> on errors.
-
-=for html <P>
-
-=item IsBitmap()
-
-Returns a boolean value indicating if the clipboard contains an image.
-See also GetBitmap().
-
-=for html <P>
-
-=item IsFiles()
-
-Returns a boolean value indicating if the clipboard contains a list of
-files. See also GetFiles().
-
-=for html <P>
-
-=item IsFormatAvailable(FORMAT)
-
-Checks if the clipboard data matches the specified FORMAT (one of the constants
-described in the L</CONSTANTS> section); returns zero if the data does not match,
-a nonzero value if it matches.
-
-=for html <P>
-
-=item IsText()
-
-Returns a boolean value indicating if the clipboard contains text.
-See also GetText().
-
-=for html <P>
-
-=item Set(VALUE)
-
-Set the clipboard content to the specified string.
-
-=for html <P>
-
-=item WaitForChange([TIMEOUT])
-
-This function halts the script until the clipboard content changes. If you specify
-a C<TIMEOUT> value (in milliseconds), the function will return when this timeout
-expires, even if the clipboard hasn't changed. If no value is given, it will wait
-indefinitely. Returns 1 if the clipboard has changed, C<undef> on errors.
-
-=back
-
-=head2 CONSTANTS
-
-These constants are the standard clipboard formats recognized by Win32::Clipboard:
-
- CF_TEXT 1
- CF_DIB 8
- CF_HDROP 15
-
-The following formats are B<not recognized> by Win32::Clipboard; they are,
-however, exported constants and can eventually be used with the EnumFormats(),
-IsFormatAvailable() and GetAs() functions:
-
- CF_BITMAP 2
- CF_METAFILEPICT 3
- CF_SYLK 4
- CF_DIF 5
- CF_TIFF 6
- CF_OEMTEXT 7
- CF_PALETTE 9
- CF_PENDATA 10
- CF_RIFF 11
- CF_WAVE 12
- CF_UNICODETEXT 13
- CF_ENHMETAFILE 14
- CF_LOCALE 16
-
-=head1 AUTHOR
-
-This version was released by Hideyo Imazu <F<himazu@gmail.com>>.
-
-Aldo Calpini <F<dada@perl.it>> was the former maintainer.
-
-Original XS porting by Gurusamy Sarathy <F<gsar@activestate.com>>.
-
-=cut
-
-
diff --git a/Master/tlpkg/installer/perllib/Win32/Console.pm b/Master/tlpkg/installer/perllib/Win32/Console.pm
deleted file mode 100644
index 1e3876a6a33..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Console.pm
+++ /dev/null
@@ -1,1463 +0,0 @@
-#######################################################################
-#
-# Win32::Console - Win32 Console and Character Mode Functions
-#
-#######################################################################
-
-package Win32::Console;
-
-require Exporter;
-require DynaLoader;
-
-$VERSION = "0.07";
-
-@ISA= qw( Exporter DynaLoader );
-@EXPORT = qw(
- BACKGROUND_BLUE
- BACKGROUND_GREEN
- BACKGROUND_INTENSITY
- BACKGROUND_RED
- CAPSLOCK_ON
- CONSOLE_TEXTMODE_BUFFER
- CTRL_BREAK_EVENT
- CTRL_C_EVENT
- ENABLE_ECHO_INPUT
- ENABLE_LINE_INPUT
- ENABLE_MOUSE_INPUT
- ENABLE_PROCESSED_INPUT
- ENABLE_PROCESSED_OUTPUT
- ENABLE_WINDOW_INPUT
- ENABLE_WRAP_AT_EOL_OUTPUT
- ENHANCED_KEY
- FILE_SHARE_READ
- FILE_SHARE_WRITE
- FOREGROUND_BLUE
- FOREGROUND_GREEN
- FOREGROUND_INTENSITY
- FOREGROUND_RED
- LEFT_ALT_PRESSED
- LEFT_CTRL_PRESSED
- NUMLOCK_ON
- GENERIC_READ
- GENERIC_WRITE
- RIGHT_ALT_PRESSED
- RIGHT_CTRL_PRESSED
- SCROLLLOCK_ON
- SHIFT_PRESSED
- STD_INPUT_HANDLE
- STD_OUTPUT_HANDLE
- STD_ERROR_HANDLE
- $FG_BLACK
- $FG_GRAY
- $FG_BLUE
- $FG_LIGHTBLUE
- $FG_RED
- $FG_LIGHTRED
- $FG_GREEN
- $FG_LIGHTGREEN
- $FG_MAGENTA
- $FG_LIGHTMAGENTA
- $FG_CYAN
- $FG_LIGHTCYAN
- $FG_BROWN
- $FG_YELLOW
- $FG_LIGHTGRAY
- $FG_WHITE
- $BG_BLACK
- $BG_GRAY
- $BG_BLUE
- $BG_LIGHTBLUE
- $BG_RED
- $BG_LIGHTRED
- $BG_GREEN
- $BG_LIGHTGREEN
- $BG_MAGENTA
- $BG_LIGHTMAGENTA
- $BG_CYAN
- $BG_LIGHTCYAN
- $BG_BROWN
- $BG_YELLOW
- $BG_LIGHTGRAY
- $BG_WHITE
- $ATTR_NORMAL
- $ATTR_INVERSE
- @CONSOLE_COLORS
-);
-
-
-#######################################################################
-# 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 $! = 0;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
-# if ($! =~ /Invalid/) {
-# $AutoLoader::AUTOLOAD = $AUTOLOAD;
-# goto &AutoLoader::AUTOLOAD;
-# } else {
- ($pack, $file, $line) = caller; undef $pack;
- die "Symbol Win32::Console::$constname not defined, used at $file line $line.";
-# }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-
-#######################################################################
-# STATIC OBJECT PROPERTIES
-#
-
-# %HandlerRoutineStack = ();
-# $HandlerRoutineRegistered = 0;
-
-#######################################################################
-# PUBLIC METHODS
-#
-
-#========
-sub new {
-#========
- my($class, $param1, $param2) = @_;
-
- my $self = {};
-
- if (defined($param1)
- and ($param1 == constant("STD_INPUT_HANDLE", 0)
- or $param1 == constant("STD_OUTPUT_HANDLE", 0)
- or $param1 == constant("STD_ERROR_HANDLE", 0)))
- {
- $self->{'handle'} = _GetStdHandle($param1);
- }
- else {
- $param1 = constant("GENERIC_READ", 0) | constant("GENERIC_WRITE", 0) unless $param1;
- $param2 = constant("FILE_SHARE_READ", 0) | constant("FILE_SHARE_WRITE", 0) unless $param2;
- $self->{'handle'} = _CreateConsoleScreenBuffer($param1, $param2,
- constant("CONSOLE_TEXTMODE_BUFFER", 0));
- }
- bless $self, $class;
- return $self;
-}
-
-#============
-sub Display {
-#============
- my($self) = @_;
- return undef unless ref($self);
- return _SetConsoleActiveScreenBuffer($self->{'handle'});
-}
-
-#===========
-sub Select {
-#===========
- my($self, $type) = @_;
- return undef unless ref($self);
- return _SetStdHandle($type, $self->{'handle'});
-}
-
-#===========
-sub SetIcon {
-#===========
- my($self, $icon) = @_;
- $icon = $self unless ref($self);
- return _SetConsoleIcon($icon);
-}
-
-#==========
-sub Title {
-#==========
- my($self, $title) = @_;
- $title = $self unless ref($self);
-
- if (defined($title)) {
- return _SetConsoleTitle($title);
- }
- else {
- return _GetConsoleTitle();
- }
-}
-
-#==============
-sub WriteChar {
-#==============
- my($self, $text, $col, $row) = @_;
- return undef unless ref($self);
- return _WriteConsoleOutputCharacter($self->{'handle'},$text,$col,$row);
-}
-
-#=============
-sub ReadChar {
-#=============
- my($self, $size, $col, $row) = @_;
- return undef unless ref($self);
-
- my $buffer = (" " x $size);
- if (_ReadConsoleOutputCharacter($self->{'handle'}, $buffer, $size, $col, $row)) {
- return $buffer;
- }
- else {
- return undef;
- }
-}
-
-#==============
-sub WriteAttr {
-#==============
- my($self, $attr, $col, $row) = @_;
- return undef unless ref($self);
- return _WriteConsoleOutputAttribute($self->{'handle'}, $attr, $col, $row);
-}
-
-#=============
-sub ReadAttr {
-#=============
- my($self, $size, $col, $row) = @_;
- return undef unless ref($self);
- return _ReadConsoleOutputAttribute($self->{'handle'}, $size, $col, $row);
-}
-
-#==========
-sub Write {
-#==========
- my($self,$string) = @_;
- return undef unless ref($self);
- return _WriteConsole($self->{'handle'}, $string);
-}
-
-#=============
-sub ReadRect {
-#=============
- my($self, $left, $top, $right, $bottom) = @_;
- return undef unless ref($self);
-
- my $col = $right - $left + 1;
- my $row = $bottom - $top + 1;
-
- my $buffer = (" " x ($col*$row*4));
- if (_ReadConsoleOutput($self->{'handle'}, $buffer,
- $col, $row, 0, 0,
- $left, $top, $right, $bottom))
- {
- return $buffer;
- }
- else {
- return undef;
- }
-}
-
-#==============
-sub WriteRect {
-#==============
- my($self, $buffer, $left, $top, $right, $bottom) = @_;
- return undef unless ref($self);
-
- my $col = $right - $left + 1;
- my $row = $bottom - $top + 1;
-
- return _WriteConsoleOutput($self->{'handle'}, $buffer,
- $col, $row, 0, 0,
- $left, $top, $right, $bottom);
-}
-
-#===========
-sub Scroll {
-#===========
- my($self, $left1, $top1, $right1, $bottom1,
- $col, $row, $char, $attr,
- $left2, $top2, $right2, $bottom2) = @_;
- return undef unless ref($self);
-
- return _ScrollConsoleScreenBuffer($self->{'handle'},
- $left1, $top1, $right1, $bottom1,
- $col, $row, $char, $attr,
- $left2, $top2, $right2, $bottom2);
-}
-
-#==============
-sub MaxWindow {
-#==============
- my($self, $flag) = @_;
- return undef unless ref($self);
-
- if (not defined($flag)) {
- my @info = _GetConsoleScreenBufferInfo($self->{'handle'});
- return $info[9], $info[10];
- }
- else {
- return _GetLargestConsoleWindowSize($self->{'handle'});
- }
-}
-
-#=========
-sub Info {
-#=========
- my($self) = @_;
- return undef unless ref($self);
- return _GetConsoleScreenBufferInfo($self->{'handle'});
-}
-
-#===========
-sub Window {
-#===========
- my($self, $flag, $left, $top, $right, $bottom) = @_;
- return undef unless ref($self);
-
- if (not defined($flag)) {
- my @info = _GetConsoleScreenBufferInfo($self->{'handle'});
- return $info[5], $info[6], $info[7], $info[8];
- }
- else {
- return _SetConsoleWindowInfo($self->{'handle'}, $flag, $left, $top, $right, $bottom);
- }
-}
-
-#==============
-sub GetEvents {
-#==============
- my($self) = @_;
- return undef unless ref($self);
- return _GetNumberOfConsoleInputEvents($self->{'handle'});
-}
-
-#==========
-sub Flush {
-#==========
- my($self) = @_;
- return undef unless ref($self);
- return _FlushConsoleInputBuffer($self->{'handle'});
-}
-
-#==============
-sub InputChar {
-#==============
- my($self, $number) = @_;
- return undef unless ref($self);
-
- $number = 1 unless defined($number);
-
- my $buffer = (" " x $number);
- if (_ReadConsole($self->{'handle'}, $buffer, $number) == $number) {
- return $buffer;
- }
- else {
- return undef;
- }
-}
-
-#==========
-sub Input {
-#==========
- my($self) = @_;
- return undef unless ref($self);
- return _ReadConsoleInput($self->{'handle'});
-}
-
-#==============
-sub PeekInput {
-#==============
- my($self) = @_;
- return undef unless ref($self);
- return _PeekConsoleInput($self->{'handle'});
-}
-
-#===============
-sub WriteInput {
-#===============
- my($self) = shift;
- return undef unless ref($self);
- return _WriteConsoleInput($self->{'handle'}, @_);
-}
-
-#=========
-sub Mode {
-#=========
- my($self, $mode) = @_;
- return undef unless ref($self);
- if (defined($mode)) {
- return _SetConsoleMode($self->{'handle'}, $mode);
- }
- else {
- return _GetConsoleMode($self->{'handle'});
- }
-}
-
-#========
-sub Cls {
-#========
- my($self, $attr) = @_;
- return undef unless ref($self);
-
- $attr = $ATTR_NORMAL unless defined($attr);
-
- my ($x, $y) = $self->Size();
- my($left, $top, $right ,$bottom) = $self->Window();
- my $vx = $right - $left;
- my $vy = $bottom - $top;
- $self->FillChar(" ", $x*$y, 0, 0);
- $self->FillAttr($attr, $x*$y, 0, 0);
- $self->Cursor(0, 0);
- $self->Window(1, 0, 0, $vx, $vy);
-}
-
-#=========
-sub Attr {
-#=========
- my($self, $attr) = @_;
- return undef unless ref($self);
-
- if (not defined($attr)) {
- return (_GetConsoleScreenBufferInfo($self->{'handle'}))[4];
- }
- else {
- return _SetConsoleTextAttribute($self->{'handle'}, $attr);
- }
-}
-
-#===========
-sub Cursor {
-#===========
- my($self, $col, $row, $size, $visi) = @_;
- return undef unless ref($self);
-
- my $curr_row = 0;
- my $curr_col = 0;
- my $curr_size = 0;
- my $curr_visi = 0;
- my $return = 0;
- my $discard = 0;
-
-
- if (defined($col)) {
- $row = -1 if not defined($row);
- if ($col == -1 or $row == -1) {
- ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
- $col=$curr_col if $col==-1;
- $row=$curr_row if $row==-1;
- }
- $return += _SetConsoleCursorPosition($self->{'handle'}, $col, $row);
- if (defined($size) and defined($visi)) {
- if ($size == -1 or $visi == -1) {
- ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'});
- $size = $curr_size if $size == -1;
- $visi = $curr_visi if $visi == -1;
- }
- $size = 1 if $size < 1;
- $size = 99 if $size > 99;
- $return += _SetConsoleCursorInfo($self->{'handle'}, $size, $visi);
- }
- return $return;
- }
- else {
- ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
- ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'});
- return ($curr_col, $curr_row, $curr_size, $curr_visi);
- }
-}
-
-#=========
-sub Size {
-#=========
- my($self, $col, $row) = @_;
- return undef unless ref($self);
-
- if (not defined($col)) {
- ($col, $row) = _GetConsoleScreenBufferInfo($self->{'handle'});
- return ($col, $row);
- }
- else {
- $row = -1 if not defined($row);
- if ($col == -1 or $row == -1) {
- ($curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
- $col=$curr_col if $col==-1;
- $row=$curr_row if $row==-1;
- }
- return _SetConsoleScreenBufferSize($self->{'handle'}, $col, $row);
- }
-}
-
-#=============
-sub FillAttr {
-#=============
- my($self, $attr, $number, $col, $row) = @_;
- return undef unless ref($self);
-
- $number = 1 unless $number;
-
- if (!defined($col) or !defined($row) or $col == -1 or $row == -1) {
- ($discard, $discard,
- $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
- $col = $curr_col if !defined($col) or $col == -1;
- $row = $curr_row if !defined($row) or $row == -1;
- }
- return _FillConsoleOutputAttribute($self->{'handle'}, $attr, $number, $col, $row);
-}
-
-#=============
-sub FillChar {
-#=============
- my($self, $char, $number, $col, $row) = @_;
- return undef unless ref($self);
-
- if (!defined($col) or !defined($row) or $col == -1 or $row == -1) {
- ($discard, $discard,
- $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
- $col = $curr_col if !defined($col) or $col == -1;
- $row = $curr_row if !defined($row) or $row == -1;
- }
- return _FillConsoleOutputCharacter($self->{'handle'}, $char, $number, $col, $row);
-}
-
-#============
-sub InputCP {
-#============
- my($self, $codepage) = @_;
- $codepage = $self if (defined($self) and ref($self) ne "Win32::Console");
- if (defined($codepage)) {
- return _SetConsoleCP($codepage);
- }
- else {
- return _GetConsoleCP();
- }
-}
-
-#=============
-sub OutputCP {
-#=============
- my($self, $codepage) = @_;
- $codepage = $self if (defined($self) and ref($self) ne "Win32::Console");
- if (defined($codepage)) {
- return _SetConsoleOutputCP($codepage);
- }
- else {
- return _GetConsoleOutputCP();
- }
-}
-
-#======================
-sub GenerateCtrlEvent {
-#======================
- my($self, $type, $pid) = @_;
- $type = constant("CTRL_C_EVENT", 0) unless defined($type);
- $pid = 0 unless defined($pid);
- return _GenerateConsoleCtrlEvent($type, $pid);
-}
-
-#===================
-#sub SetCtrlHandler {
-#===================
-# my($name, $add) = @_;
-# $add = 1 unless defined($add);
-# my @nor = keys(%HandlerRoutineStack);
-# if ($add == 0) {
-# foreach $key (@nor) {
-# delete $HandlerRoutineStack{$key}, last if $HandlerRoutineStack{$key}==$name;
-# }
-# $HandlerRoutineRegistered--;
-# } else {
-# if ($#nor == -1) {
-# my $r = _SetConsoleCtrlHandler();
-# if (!$r) {
-# print "WARNING: SetConsoleCtrlHandler failed...\n";
-# }
-# }
-# $HandlerRoutineRegistered++;
-# $HandlerRoutineStack{$HandlerRoutineRegistered} = $name;
-# }
-#}
-
-#===================
-sub get_Win32_IPC_HANDLE { # So Win32::IPC can wait on a console handle
-#===================
- $_[0]->{'handle'};
-}
-
-########################################################################
-# PRIVATE METHODS
-#
-
-#================
-#sub CtrlHandler {
-#================
-# my($ctrltype) = @_;
-# my $routine;
-# my $result = 0;
-# CALLEM: foreach $routine (sort { $b <=> $a } keys %HandlerRoutineStack) {
-# #print "CtrlHandler: calling $HandlerRoutineStack{$routine}($ctrltype)\n";
-# $result = &{"main::".$HandlerRoutineStack{$routine}}($ctrltype);
-# last CALLEM if $result;
-# }
-# return $result;
-#}
-
-#============
-sub DESTROY {
-#============
- my($self) = @_;
- _CloseHandle($self->{'handle'});
-}
-
-#######################################################################
-# dynamically load in the Console.pll module.
-#
-
-bootstrap Win32::Console;
-
-#######################################################################
-# ADDITIONAL CONSTANTS EXPORTED IN THE MAIN NAMESPACE
-#
-
-$FG_BLACK = 0;
-$FG_GRAY = constant("FOREGROUND_INTENSITY",0);
-$FG_BLUE = constant("FOREGROUND_BLUE",0);
-$FG_LIGHTBLUE = constant("FOREGROUND_BLUE",0)|
- constant("FOREGROUND_INTENSITY",0);
-$FG_RED = constant("FOREGROUND_RED",0);
-$FG_LIGHTRED = constant("FOREGROUND_RED",0)|
- constant("FOREGROUND_INTENSITY",0);
-$FG_GREEN = constant("FOREGROUND_GREEN",0);
-$FG_LIGHTGREEN = constant("FOREGROUND_GREEN",0)|
- constant("FOREGROUND_INTENSITY",0);
-$FG_MAGENTA = constant("FOREGROUND_RED",0)|
- constant("FOREGROUND_BLUE",0);
-$FG_LIGHTMAGENTA = constant("FOREGROUND_RED",0)|
- constant("FOREGROUND_BLUE",0)|
- constant("FOREGROUND_INTENSITY",0);
-$FG_CYAN = constant("FOREGROUND_GREEN",0)|
- constant("FOREGROUND_BLUE",0);
-$FG_LIGHTCYAN = constant("FOREGROUND_GREEN",0)|
- constant("FOREGROUND_BLUE",0)|
- constant("FOREGROUND_INTENSITY",0);
-$FG_BROWN = constant("FOREGROUND_RED",0)|
- constant("FOREGROUND_GREEN",0);
-$FG_YELLOW = constant("FOREGROUND_RED",0)|
- constant("FOREGROUND_GREEN",0)|
- constant("FOREGROUND_INTENSITY",0);
-$FG_LIGHTGRAY = constant("FOREGROUND_RED",0)|
- constant("FOREGROUND_GREEN",0)|
- constant("FOREGROUND_BLUE",0);
-$FG_WHITE = constant("FOREGROUND_RED",0)|
- constant("FOREGROUND_GREEN",0)|
- constant("FOREGROUND_BLUE",0)|
- constant("FOREGROUND_INTENSITY",0);
-
-$BG_BLACK = 0;
-$BG_GRAY = constant("BACKGROUND_INTENSITY",0);
-$BG_BLUE = constant("BACKGROUND_BLUE",0);
-$BG_LIGHTBLUE = constant("BACKGROUND_BLUE",0)|
- constant("BACKGROUND_INTENSITY",0);
-$BG_RED = constant("BACKGROUND_RED",0);
-$BG_LIGHTRED = constant("BACKGROUND_RED",0)|
- constant("BACKGROUND_INTENSITY",0);
-$BG_GREEN = constant("BACKGROUND_GREEN",0);
-$BG_LIGHTGREEN = constant("BACKGROUND_GREEN",0)|
- constant("BACKGROUND_INTENSITY",0);
-$BG_MAGENTA = constant("BACKGROUND_RED",0)|
- constant("BACKGROUND_BLUE",0);
-$BG_LIGHTMAGENTA = constant("BACKGROUND_RED",0)|
- constant("BACKGROUND_BLUE",0)|
- constant("BACKGROUND_INTENSITY",0);
-$BG_CYAN = constant("BACKGROUND_GREEN",0)|
- constant("BACKGROUND_BLUE",0);
-$BG_LIGHTCYAN = constant("BACKGROUND_GREEN",0)|
- constant("BACKGROUND_BLUE",0)|
- constant("BACKGROUND_INTENSITY",0);
-$BG_BROWN = constant("BACKGROUND_RED",0)|
- constant("BACKGROUND_GREEN",0);
-$BG_YELLOW = constant("BACKGROUND_RED",0)|
- constant("BACKGROUND_GREEN",0)|
- constant("BACKGROUND_INTENSITY",0);
-$BG_LIGHTGRAY = constant("BACKGROUND_RED",0)|
- constant("BACKGROUND_GREEN",0)|
- constant("BACKGROUND_BLUE",0);
-$BG_WHITE = constant("BACKGROUND_RED",0)|
- constant("BACKGROUND_GREEN",0)|
- constant("BACKGROUND_BLUE",0)|
- constant("BACKGROUND_INTENSITY",0);
-
-$ATTR_NORMAL = $FG_LIGHTGRAY|$BG_BLACK;
-$ATTR_INVERSE = $FG_BLACK|$BG_LIGHTGRAY;
-
-for my $fg ($FG_BLACK, $FG_GRAY, $FG_BLUE, $FG_GREEN,
- $FG_CYAN, $FG_RED, $FG_MAGENTA, $FG_BROWN,
- $FG_LIGHTBLUE, $FG_LIGHTGREEN, $FG_LIGHTCYAN,
- $FG_LIGHTRED, $FG_LIGHTMAGENTA, $FG_YELLOW,
- $FG_LIGHTGRAY, $FG_WHITE)
-{
- for my $bg ($BG_BLACK, $BG_GRAY, $BG_BLUE, $BG_GREEN,
- $BG_CYAN, $BG_RED, $BG_MAGENTA, $BG_BROWN,
- $BG_LIGHTBLUE, $BG_LIGHTGREEN, $BG_LIGHTCYAN,
- $BG_LIGHTRED, $BG_LIGHTMAGENTA, $BG_YELLOW,
- $BG_LIGHTGRAY, $BG_WHITE)
- {
- push(@CONSOLE_COLORS, $fg|$bg);
- }
-}
-
-# Preloaded methods go here.
-
-#Currently Autoloading is not implemented in Perl for win32
-# Autoload methods go after __END__, and are processed by the autosplit program.
-
-1;
-
-__END__
-
-=head1 NAME
-
-Win32::Console - Win32 Console and Character Mode Functions
-
-
-=head1 DESCRIPTION
-
-This module implements the Win32 console and character mode
-functions. They give you full control on the console input and output,
-including: support of off-screen console buffers (eg. multiple screen
-pages)
-
-=over
-
-=item *
-
-reading and writing of characters, attributes and whole portions of
-the screen
-
-=item *
-
-complete processing of keyboard and mouse events
-
-=item *
-
-some very funny additional features :)
-
-=back
-
-Those functions should also make possible a port of the Unix's curses
-library; if there is anyone interested (and/or willing to contribute)
-to this project, e-mail me. Thank you.
-
-
-=head1 REFERENCE
-
-
-=head2 Methods
-
-=over
-
-=item Alloc
-
-Allocates a new console for the process. Returns C<undef> on errors, a
-nonzero value on success. A process cannot be associated with more
-than one console, so this method will fail if there is already an
-allocated console. Use Free to detach the process from the console,
-and then call Alloc to create a new console. See also: C<Free>
-
-Example:
-
- $CONSOLE->Alloc();
-
-=item Attr [attr]
-
-Gets or sets the current console attribute. This attribute is used by
-the Write method.
-
-Example:
-
- $attr = $CONSOLE->Attr();
- $CONSOLE->Attr($FG_YELLOW | $BG_BLUE);
-
-=item 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).
-
-Example:
-
- $LINK->Close();
-
-=item Cls [attr]
-
-Clear the console, with the specified I<attr> if given, or using
-ATTR_NORMAL otherwise.
-
-Example:
-
- $CONSOLE->Cls();
- $CONSOLE->Cls($FG_WHITE | $BG_GREEN);
-
-=item Cursor [x, y, size, visible]
-
-Gets or sets cursor position and appearance. Returns C<undef> on
-errors, or a 4-element list containing: I<x>, I<y>, I<size>,
-I<visible>. I<x> and I<y> are the current cursor position; ...
-
-Example:
-
- ($x, $y, $size, $visible) = $CONSOLE->Cursor();
-
- # Get position only
- ($x, $y) = $CONSOLE->Cursor();
-
- $CONSOLE->Cursor(40, 13, 50, 1);
-
- # Set position only
- $CONSOLE->Cursor(40, 13);
-
- # Set size and visibility without affecting position
- $CONSOLE->Cursor(-1, -1, 50, 1);
-
-=item Display
-
-Displays the specified console on the screen. Returns C<undef> on errors,
-a nonzero value on success.
-
-Example:
-
- $CONSOLE->Display();
-
-=item FillAttr [attribute, number, col, row]
-
-Fills the specified number of consecutive attributes, beginning at
-I<col>, I<row>, with the value specified in I<attribute>. Returns the
-number of attributes filled, or C<undef> on errors. See also:
-C<FillChar>.
-
-Example:
-
- $CONSOLE->FillAttr($FG_BLACK | $BG_BLACK, 80*25, 0, 0);
-
-=item FillChar char, number, col, row
-
-Fills the specified number of consecutive characters, beginning at
-I<col>, I<row>, with the character specified in I<char>. Returns the
-number of characters filled, or C<undef> on errors. See also:
-C<FillAttr>.
-
-Example:
-
- $CONSOLE->FillChar("X", 80*25, 0, 0);
-
-=item Flush
-
-Flushes the console input buffer. All the events in the buffer are
-discarded. Returns C<undef> on errors, a nonzero value on success.
-
-Example:
-
- $CONSOLE->Flush();
-
-=item Free
-
-Detaches the process from the console. Returns C<undef> on errors, a
-nonzero value on success. See also: C<Alloc>.
-
-Example:
-
- $CONSOLE->Free();
-
-=item GenerateCtrlEvent [type, processgroup]
-
-Sends a break signal of the specified I<type> to the specified
-I<processgroup>. I<type> can be one of the following constants:
-
- CTRL_BREAK_EVENT
- CTRL_C_EVENT
-
-they signal, respectively, the pressing of Control + Break and of
-Control + C; if not specified, it defaults to CTRL_C_EVENT.
-I<processgroup> is the pid of a process sharing the same console. If
-omitted, it defaults to 0 (the current process), which is also the
-only meaningful value that you can pass to this function. Returns
-C<undef> on errors, a nonzero value on success.
-
-Example:
-
- # break this script now
- $CONSOLE->GenerateCtrlEvent();
-
-=item GetEvents
-
-Returns the number of unread input events in the console's input
-buffer, or C<undef> on errors. See also: C<Input>, C<InputChar>,
-C<PeekInput>, C<WriteInput>.
-
-Example:
-
- $events = $CONSOLE->GetEvents();
-
-=item Info
-
-Returns an array of informations about the console (or C<undef> on
-errors), which contains:
-
-=over
-
-=item *
-
-columns (X size) of the console buffer.
-
-=item *
-
-rows (Y size) of the console buffer.
-
-=item *
-
-current column (X position) of the cursor.
-
-=item *
-
-current row (Y position) of the cursor.
-
-=item *
-
-current attribute used for C<Write>.
-
-=item *
-
-left column (X of the starting point) of the current console window.
-
-=item *
-
-top row (Y of the starting point) of the current console window.
-
-=item *
-
-right column (X of the final point) of the current console window.
-
-=item *
-
-bottom row (Y of the final point) of the current console window.
-
-=item *
-
-maximum number of columns for the console window, given the current
-buffer size, font and the screen size.
-
-=item *
-
-maximum number of rows for the console window, given the current
-buffer size, font and the screen size.
-
-=back
-
-See also: C<Attr>, C<Cursor>, C<Size>, C<Window>, C<MaxWindow>.
-
-Example:
-
- @info = $CONSOLE->Info();
- print "Cursor at $info[3], $info[4].\n";
-
-=item Input
-
-Reads an event from the input buffer. Returns a list of values, which
-depending on the event's nature are:
-
-=over
-
-=item keyboard event
-
-The list will contain:
-
-=over
-
-=item *
-
-event type: 1 for keyboard
-
-=item *
-
-key down: TRUE if the key is being pressed, FALSE if the key is being released
-
-=item *
-
-repeat count: the number of times the key is being held down
-
-=item *
-
-virtual keycode: the virtual key code of the key
-
-=item *
-
-virtual scancode: the virtual scan code of the key
-
-=item *
-
-char: the ASCII code of the character (if the key is a character key, 0 otherwise)
-
-=item *
-
-control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.)
-
-=back
-
-=item mouse event
-
-The list will contain:
-
-=over
-
-=item *
-
-event type: 2 for mouse
-
-=item *
-
-mouse pos. X: X coordinate (column) of the mouse location
-
-=item *
-
-mouse pos. Y: Y coordinate (row) of the mouse location
-
-=item *
-
-button state: the mouse button(s) which are pressed
-
-=item *
-
-control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.)
-
-=item *
-
-event flags: the type of the mouse event
-
-=back
-
-=back
-
-This method will return C<undef> on errors. Note that the events
-returned are depending on the input C<Mode> of the console; for example,
-mouse events are not intercepted unless ENABLE_MOUSE_INPUT is
-specified. See also: C<GetEvents>, C<InputChar>, C<Mode>,
-C<PeekInput>, C<WriteInput>.
-
-Example:
-
- @event = $CONSOLE->Input();
-
-=item InputChar number
-
-Reads and returns I<number> characters from the console input buffer,
-or C<undef> on errors. See also: C<Input>, C<Mode>.
-
-Example:
-
- $key = $CONSOLE->InputChar(1);
-
-=item InputCP [codepage]
-
-Gets or sets the input code page used by the console. Note that this
-doesn't apply to a console object, but to the standard input
-console. This attribute is used by the Write method. See also:
-C<OutputCP>.
-
-Example:
-
- $codepage = $CONSOLE->InputCP();
- $CONSOLE->InputCP(437);
-
- # you may want to use the non-instanciated form to avoid confuzion :)
- $codepage = Win32::Console::InputCP();
- Win32::Console::InputCP(437);
-
-=item MaxWindow
-
-Returns the size of the largest possible console window, based on the
-current font and the size of the display. The result is C<undef> on
-errors, otherwise a 2-element list containing col, row.
-
-Example:
-
- ($maxCol, $maxRow) = $CONSOLE->MaxWindow();
-
-=item Mode [flags]
-
-Gets or sets the input or output mode of a console. I<flags> can be a
-combination of the following constants:
-
- ENABLE_LINE_INPUT
- ENABLE_ECHO_INPUT
- ENABLE_PROCESSED_INPUT
- ENABLE_WINDOW_INPUT
- ENABLE_MOUSE_INPUT
- ENABLE_PROCESSED_OUTPUT
- ENABLE_WRAP_AT_EOL_OUTPUT
-
-For more informations on the meaning of those flags, please refer to
-the L<"Microsoft's Documentation">.
-
-Example:
-
- $mode = $CONSOLE->Mode();
- $CONSOLE->Mode(ENABLE_MOUSE_INPUT | ENABLE_PROCESSED_INPUT);
-
-=item MouseButtons
-
-Returns the number of the buttons on your mouse, or C<undef> on errors.
-
-Example:
-
- print "Your mouse has ", $CONSOLE->MouseButtons(), " buttons.\n";
-
-=item new Win32::Console standard_handle
-
-=item new Win32::Console [accessmode, sharemode]
-
-Creates a new console object. The first form creates a handle to a
-standard channel, I<standard_handle> can be one of the following:
-
- STD_OUTPUT_HANDLE
- STD_ERROR_HANDLE
- STD_INPUT_HANDLE
-
-The second form, instead, creates a console screen buffer in memory,
-which you can access for reading and writing as a normal console, and
-then redirect on the standard output (the screen) with C<Display>. In
-this case, you can specify one or both of the following values for
-I<accessmode>:
-
- GENERIC_READ
- GENERIC_WRITE
-
-which are the permissions you will have on the created buffer, and one
-or both of the following values for I<sharemode>:
-
- FILE_SHARE_READ
- FILE_SHARE_WRITE
-
-which affect the way the console can be shared. If you don't specify
-any of those parameters, all 4 flags will be used.
-
-Example:
-
- $STDOUT = new Win32::Console(STD_OUTPUT_HANDLE);
- $STDERR = new Win32::Console(STD_ERROR_HANDLE);
- $STDIN = new Win32::Console(STD_INPUT_HANDLE);
-
- $BUFFER = new Win32::Console();
- $BUFFER = new Win32::Console(GENERIC_READ | GENERIC_WRITE);
-
-=item OutputCP [codepage]
-
-Gets or sets the output code page used by the console. Note that this
-doesn't apply to a console object, but to the standard output console.
-See also: C<InputCP>.
-
-Example:
-
- $codepage = $CONSOLE->OutputCP();
- $CONSOLE->OutputCP(437);
-
- # you may want to use the non-instanciated form to avoid confuzion :)
- $codepage = Win32::Console::OutputCP();
- Win32::Console::OutputCP(437);
-
-=item PeekInput
-
-Does exactly the same as C<Input>, except that the event read is not
-removed from the input buffer. See also: C<GetEvents>, C<Input>,
-C<InputChar>, C<Mode>, C<WriteInput>.
-
-Example:
-
- @event = $CONSOLE->PeekInput();
-
-=item ReadAttr [number, col, row]
-
-Reads the specified I<number> of consecutive attributes, beginning at
-I<col>, I<row>, from the console. Returns the attributes read (a
-variable containing one character for each attribute), or C<undef> on
-errors. You can then pass the returned variable to C<WriteAttr> to
-restore the saved attributes on screen. See also: C<ReadChar>,
-C<ReadRect>.
-
-Example:
-
- $colors = $CONSOLE->ReadAttr(80*25, 0, 0);
-
-=item ReadChar [number, col, row]
-
-Reads the specified I<number> of consecutive characters, beginning at
-I<col>, I<row>, from the console. Returns a string containing the
-characters read, or C<undef> on errors. You can then pass the
-returned variable to C<WriteChar> to restore the saved characters on
-screen. See also: C<ReadAttr>, C<ReadRect>.
-
-Example:
-
- $chars = $CONSOLE->ReadChar(80*25, 0, 0);
-
-=item ReadRect left, top, right, bottom
-
-Reads the content (characters and attributes) of the rectangle
-specified by I<left>, I<top>, I<right>, I<bottom> from the console.
-Returns a string containing the rectangle read, or C<undef> on errors.
-You can then pass the returned variable to C<WriteRect> to restore the
-saved rectangle on screen (or on another console). See also:
-C<ReadAttr>, C<ReadChar>.
-
-Example:
-
- $rect = $CONSOLE->ReadRect(0, 0, 80, 25);
-
-=item Scroll left, top, right, bottom, col, row, char, attr,
- [cleft, ctop, cright, cbottom]
-
-Moves a block of data in a console buffer; the block is identified by
-I<left>, I<top>, I<right>, I<bottom>, while I<row>, I<col> identify
-the new location of the block. The cells left empty as a result of
-the move are filled with the character I<char> and attribute I<attr>.
-Optionally you can specify a clipping region with I<cleft>, I<ctop>,
-I<cright>, I<cbottom>, so that the content of the console outside this
-rectangle are unchanged. Returns C<undef> on errors, a nonzero value
-on success.
-
-Example:
-
- # scrolls the screen 10 lines down, filling with black spaces
- $CONSOLE->Scroll(0, 0, 80, 25, 0, 10, " ", $FG_BLACK | $BG_BLACK);
-
-=item Select standard_handle
-
-Redirects a standard handle to the specified console.
-I<standard_handle> can have one of the following values:
-
- STD_INPUT_HANDLE
- STD_OUTPUT_HANDLE
- STD_ERROR_HANDLE
-
-Returns C<undef> on errors, a nonzero value on success.
-
-Example:
-
- $CONSOLE->Select(STD_OUTPUT_HANDLE);
-
-=item SetIcon icon_file
-
-Sets the icon in the title bar of the current console window.
-
-Example:
-
- $CONSOLE->SetIcon("C:/My/Path/To/Custom.ico");
-
-=item Size [col, row]
-
-Gets or sets the console buffer size.
-
-Example:
-
- ($x, $y) = $CONSOLE->Size();
- $CONSOLE->Size(80, 25);
-
-=item Title [title]
-
-Gets or sets the title of the current console window.
-
-Example:
-
- $title = $CONSOLE->Title();
- $CONSOLE->Title("This is a title");
-
-=item Window [flag, left, top, right, bottom]
-
-Gets or sets the current console window size. If called without
-arguments, returns a 4-element list containing the current window
-coordinates in the form of I<left>, I<top>, I<right>, I<bottom>. To
-set the window size, you have to specify an additional I<flag>
-parameter: if it is 0 (zero), coordinates are considered relative to
-the current coordinates; if it is non-zero, coordinates are absolute.
-
-Example:
-
- ($left, $top, $right, $bottom) = $CONSOLE->Window();
- $CONSOLE->Window(1, 0, 0, 80, 50);
-
-=item Write string
-
-Writes I<string> on the console, using the current attribute, that you
-can set with C<Attr>, and advancing the cursor as needed. This isn't
-so different from Perl's "print" statement. Returns the number of
-characters written or C<undef> on errors. See also: C<WriteAttr>,
-C<WriteChar>, C<WriteRect>.
-
-Example:
-
- $CONSOLE->Write("Hello, world!");
-
-=item WriteAttr attrs, col, row
-
-Writes the attributes in the string I<attrs>, beginning at I<col>,
-I<row>, without affecting the characters that are on screen. The
-string attrs can be the result of a C<ReadAttr> function, or you can
-build your own attribute string; in this case, keep in mind that every
-attribute is treated as a character, not a number (see example).
-Returns the number of attributes written or C<undef> on errors. See
-also: C<Write>, C<WriteChar>, C<WriteRect>.
-
-Example:
-
- $CONSOLE->WriteAttr($attrs, 0, 0);
-
- # note the use of chr()...
- $attrs = chr($FG_BLACK | $BG_WHITE) x 80;
- $CONSOLE->WriteAttr($attrs, 0, 0);
-
-=item WriteChar chars, col, row
-
-Writes the characters in the string I<attr>, beginning at I<col>, I<row>,
-without affecting the attributes that are on screen. The string I<chars>
-can be the result of a C<ReadChar> function, or a normal string. Returns
-the number of characters written or C<undef> on errors. See also:
-C<Write>, C<WriteAttr>, C<WriteRect>.
-
-Example:
-
- $CONSOLE->WriteChar("Hello, worlds!", 0, 0);
-
-=item WriteInput (event)
-
-Pushes data in the console input buffer. I<(event)> is a list of values,
-for more information see C<Input>. The string chars can be the result of
-a C<ReadChar> function, or a normal string. Returns the number of
-characters written or C<undef> on errors. See also: C<Write>,
-C<WriteAttr>, C<WriteRect>.
-
-Example:
-
- $CONSOLE->WriteInput(@event);
-
-=item WriteRect rect, left, top, right, bottom
-
-Writes a rectangle of characters and attributes (contained in I<rect>)
-on the console at the coordinates specified by I<left>, I<top>,
-I<right>, I<bottom>. I<rect> can be the result of a C<ReadRect>
-function. Returns C<undef> on errors, otherwise a 4-element list
-containing the coordinates of the affected rectangle, in the format
-I<left>, I<top>, I<right>, I<bottom>. See also: C<Write>,
-C<WriteAttr>, C<WriteChar>.
-
-Example:
-
- $CONSOLE->WriteRect($rect, 0, 0, 80, 25);
-
-=back
-
-
-=head2 Constants
-
-The following constants are exported in the main namespace of your
-script using Win32::Console:
-
- BACKGROUND_BLUE
- BACKGROUND_GREEN
- BACKGROUND_INTENSITY
- BACKGROUND_RED
- CAPSLOCK_ON
- CONSOLE_TEXTMODE_BUFFER
- ENABLE_ECHO_INPUT
- ENABLE_LINE_INPUT
- ENABLE_MOUSE_INPUT
- ENABLE_PROCESSED_INPUT
- ENABLE_PROCESSED_OUTPUT
- ENABLE_WINDOW_INPUT
- ENABLE_WRAP_AT_EOL_OUTPUT
- ENHANCED_KEY
- FILE_SHARE_READ
- FILE_SHARE_WRITE
- FOREGROUND_BLUE
- FOREGROUND_GREEN
- FOREGROUND_INTENSITY
- FOREGROUND_RED
- LEFT_ALT_PRESSED
- LEFT_CTRL_PRESSED
- NUMLOCK_ON
- GENERIC_READ
- GENERIC_WRITE
- RIGHT_ALT_PRESSED
- RIGHT_CTRL_PRESSED
- SCROLLLOCK_ON
- SHIFT_PRESSED
- STD_INPUT_HANDLE
- STD_OUTPUT_HANDLE
- STD_ERROR_HANDLE
-
-Additionally, the following variables can be used:
-
- $FG_BLACK
- $FG_GRAY
- $FG_BLUE
- $FG_LIGHTBLUE
- $FG_RED
- $FG_LIGHTRED
- $FG_GREEN
- $FG_LIGHTGREEN
- $FG_MAGENTA
- $FG_LIGHTMAGENTA
- $FG_CYAN
- $FG_LIGHTCYAN
- $FG_BROWN
- $FG_YELLOW
- $FG_LIGHTGRAY
- $FG_WHITE
-
- $BG_BLACK
- $BG_GRAY
- $BG_BLUE
- $BG_LIGHTBLUE
- $BG_RED
- $BG_LIGHTRED
- $BG_GREEN
- $BG_LIGHTGREEN
- $BG_MAGENTA
- $BG_LIGHTMAGENTA
- $BG_CYAN
- $BG_LIGHTCYAN
- $BG_BROWN
- $BG_YELLOW
- $BG_LIGHTGRAY
- $BG_WHITE
-
- $ATTR_NORMAL
- $ATTR_INVERSE
-
-ATTR_NORMAL is set to gray foreground on black background (DOS's
-standard colors).
-
-
-=head2 Microsoft's Documentation
-
-Documentation for the Win32 Console and Character mode Functions can
-be found on Microsoft's site at this URL:
-
-http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar.htm
-
-A reference of the available functions is at:
-
-http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar_34.htm
-
-
-=head1 AUTHOR
-
-Aldo Calpini <a.calpini@romagiubileo.it>
-
-=head1 CREDITS
-
-Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the
-Perl-Win32-Users community.
-
-=head1 DISCLAIMER
-
-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 responsibility 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.
diff --git a/Master/tlpkg/installer/perllib/Win32/Event.pm b/Master/tlpkg/installer/perllib/Win32/Event.pm
deleted file mode 100644
index 5faddf5a76e..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Event.pm
+++ /dev/null
@@ -1,104 +0,0 @@
-#---------------------------------------------------------------------
-package Win32::Event;
-#
-# Copyright 1998 Christopher J. Madsen
-#
-# Author: Christopher J. Madsen <cjm@pobox.com>
-# Created: 3 Feb 1998 from the ActiveWare version
-# Version: 1.00 (6-Feb-1998)
-#
-# This program 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. See either the
-# GNU General Public License or the Artistic License for more details.
-#
-# Use Win32 event objects for synchronization
-#---------------------------------------------------------------------
-
-$VERSION = '1.01';
-
-use Win32::IPC 1.00 '/./'; # Import everything
-require Exporter;
-require DynaLoader;
-
-@ISA = qw(Exporter DynaLoader Win32::IPC);
-@EXPORT_OK = qw(
- wait_all wait_any INFINITE
-);
-
-bootstrap Win32::Event;
-
-1;
-__END__
-
-=head1 NAME
-
-Win32::Event - Use Win32 event objects from Perl
-
-=head1 SYNOPSIS
-
- use Win32::Event;
-
- $event = Win32::Event->new($manual,$initial,$name);
- $event->wait();
-
-=head1 DESCRIPTION
-
-This module allows access to the Win32 event objects. The C<wait>
-method and C<wait_all> & C<wait_any> functions are inherited from the
-L<"Win32::IPC"> module.
-
-=head2 Methods
-
-=over 4
-
-=item $event = Win32::Event->new([$manual, [$initial, [$name]]])
-
-Constructor for a new event object. If C<$manual> is true, you must
-manually reset the event after it is signalled (the default is false).
-If C<$initial> is true, the initial state of the object is signalled
-(default false). If C<$name> is omitted, creates an unnamed event
-object.
-
-If C<$name> signifies an existing event object, then C<$manual> and
-C<$initial> are ignored and the object is opened. If this happens,
-C<$^E> will be set to 183 (ERROR_ALREADY_EXISTS).
-
-=item $event = Win32::Event->open($name)
-
-Constructor for opening an existing event object.
-
-=item $event->pulse
-
-Signal the C<$event> and then immediately reset it. If C<$event> is a
-manual-reset event, releases all threads currently blocking on it. If
-it's an auto-reset event, releases just one thread.
-
-If no threads are waiting, just resets the event.
-
-=item $event->reset
-
-Reset the C<$event> to nonsignalled.
-
-=item $event->set
-
-Set the C<$event> to signalled.
-
-=item $event->wait([$timeout])
-
-Wait for C<$event> to be signalled. See L<"Win32::IPC">.
-
-=back
-
-=head1 AUTHOR
-
-Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt>
-
-=cut
-
-# Local Variables:
-# tmtrack-file-task: "Win32::Event"
-# End:
diff --git a/Master/tlpkg/installer/perllib/Win32/EventLog.pm b/Master/tlpkg/installer/perllib/Win32/EventLog.pm
deleted file mode 100644
index 141821556e7..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/EventLog.pm
+++ /dev/null
@@ -1,471 +0,0 @@
-#
-# 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.074';
-
-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/installer/perllib/Win32/File.pm b/Master/tlpkg/installer/perllib/Win32/File.pm
deleted file mode 100644
index d67a25448c8..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/File.pm
+++ /dev/null
@@ -1,118 +0,0 @@
-package Win32::File;
-
-#
-# File.pm
-# Written by Douglas_Lankshear@ActiveWare.com
-#
-# subsequent hacks:
-# Gurusamy Sarathy
-#
-
-$VERSION = '0.05';
-
-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/installer/perllib/Win32/FileSecurity.pm b/Master/tlpkg/installer/perllib/Win32/FileSecurity.pm
deleted file mode 100644
index 6c6e5865336..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/FileSecurity.pm
+++ /dev/null
@@ -1,308 +0,0 @@
-package Win32::FileSecurity;
-
-#
-# FileSecurity.pm
-# By Monte Mitzelfelt, monte@conchas.nm.org
-# Larry Wall's Artistic License applies to all related Perl
-# and C code for this module
-# Thanks to the guys at ActiveWare!
-# ver 0.67 ALPHA 1997.07.07
-#
-
-require Exporter;
-require DynaLoader;
-use Carp ;
-
-$VERSION = '1.04';
-
-require Win32 unless defined &Win32::IsWinNT;
-croak "The Win32::FileSecurity module works only on Windows NT" unless Win32::IsWinNT();
-
-@ISA= qw( Exporter DynaLoader );
-
-require Exporter ;
-require DynaLoader ;
-
-@ISA = qw(Exporter DynaLoader) ;
-@EXPORT_OK = qw(
- Get
- Set
- EnumerateRights
- MakeMask
- DELETE
- READ_CONTROL
- WRITE_DAC
- WRITE_OWNER
- SYNCHRONIZE
- STANDARD_RIGHTS_REQUIRED
- STANDARD_RIGHTS_READ
- STANDARD_RIGHTS_WRITE
- STANDARD_RIGHTS_EXECUTE
- STANDARD_RIGHTS_ALL
- SPECIFIC_RIGHTS_ALL
- ACCESS_SYSTEM_SECURITY
- MAXIMUM_ALLOWED
- GENERIC_READ
- GENERIC_WRITE
- GENERIC_EXECUTE
- GENERIC_ALL
- F
- FULL
- R
- READ
- C
- CHANGE
- A
- ADD
- ) ;
-
-sub AUTOLOAD {
- local($constname);
- ($constname = $AUTOLOAD) =~ s/.*:://;
- #reset $! to zero to reset any current errors.
- local $! = 0;
- $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::FileSecurity macro "
- ."$constname, used in $file at line $line.";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-bootstrap Win32::FileSecurity;
-
-1;
-
-__END__
-
-=head1 NAME
-
-Win32::FileSecurity - manage FileSecurity Discretionary Access Control Lists in perl
-
-=head1 SYNOPSIS
-
- use Win32::FileSecurity;
-
-=head1 DESCRIPTION
-
-This module offers control over the administration of system FileSecurity DACLs.
-You may want to use Get and EnumerateRights to get an idea of what mask values
-correspond to what rights as viewed from File Manager.
-
-=head1 CONSTANTS
-
- DELETE, READ_CONTROL, WRITE_DAC, WRITE_OWNER,
- SYNCHRONIZE, STANDARD_RIGHTS_REQUIRED,
- STANDARD_RIGHTS_READ, STANDARD_RIGHTS_WRITE,
- STANDARD_RIGHTS_EXECUTE, STANDARD_RIGHTS_ALL,
- SPECIFIC_RIGHTS_ALL, ACCESS_SYSTEM_SECURITY,
- MAXIMUM_ALLOWED, GENERIC_READ, GENERIC_WRITE,
- GENERIC_EXECUTE, GENERIC_ALL, F, FULL, R, READ,
- C, CHANGE
-
-=head1 FUNCTIONS
-
-=head2 NOTE:
-
-All of the functions return false if they fail, unless otherwise noted.
-Errors returned via $! containing both Win32 GetLastError() and a text message
-indicating Win32 function that failed.
-
-=over 10
-
-=item constant( $name, $set )
-
-Stores the value of named constant $name into $set.
-Same as C<$set = Win32::FileSecurity::NAME_OF_CONSTANT();>.
-
-=item Get( $filename, \%permisshash )
-
-Gets the DACLs of a file or directory.
-
-=item Set( $filename, \%permisshash )
-
-Sets the DACL for a file or directory.
-
-=item EnumerateRights( $mask, \@rightslist )
-
-Turns the bitmask in $mask into a list of strings in @rightslist.
-
-=item MakeMask( qw( DELETE READ_CONTROL ) )
-
-Takes a list of strings representing constants and returns a bitmasked
-integer value.
-
-=back
-
-=head2 %permisshash
-
-Entries take the form $permisshash{USERNAME} = $mask ;
-
-=head1 EXAMPLE1
-
- # Gets the rights for all files listed on the command line.
- use Win32::FileSecurity qw(Get EnumerateRights);
-
- foreach( @ARGV ) {
- next unless -e $_ ;
- if ( Get( $_, \%hash ) ) {
- while( ($name, $mask) = each %hash ) {
- print "$name:\n\t";
- EnumerateRights( $mask, \@happy ) ;
- print join( "\n\t", @happy ), "\n";
- }
- }
- else {
- print( "Error #", int( $! ), ": $!" ) ;
- }
- }
-
-=head1 EXAMPLE2
-
- # Gets existing DACL and modifies Administrator rights
- use Win32::FileSecurity qw(MakeMask Get Set);
-
- # These masks show up as Full Control in File Manager
- $file = MakeMask( qw( FULL ) );
-
- $dir = MakeMask( qw(
- FULL
- GENERIC_ALL
- ) );
-
- foreach( @ARGV ) {
- s/\\$//;
- next unless -e;
- Get( $_, \%hash ) ;
- $hash{Administrator} = ( -d ) ? $dir : $file ;
- Set( $_, \%hash ) ;
- }
-
-=head1 COMMON MASKS FROM CACLS AND WINFILE
-
-=head2 READ
-
- MakeMask( qw( FULL ) ); # for files
- MakeMask( qw( READ GENERIC_READ GENERIC_EXECUTE ) ); # for directories
-
-=head2 CHANGE
-
- MakeMask( qw( CHANGE ) ); # for files
- MakeMask( qw( CHANGE GENERIC_WRITE GENERIC_READ GENERIC_EXECUTE ) ); # for directories
-
-=head2 ADD & READ
-
- MakeMask( qw( ADD GENERIC_READ GENERIC_EXECUTE ) ); # for directories only!
-
-=head2 FULL
-
- MakeMask( qw( FULL ) ); # for files
- MakeMask( qw( FULL GENERIC_ALL ) ); # for directories
-
-=head1 RESOURCES
-
-From Microsoft: check_sd
- http://premium.microsoft.com/download/msdn/samples/2760.exe
-
-(thanks to Guert Schimmel at Sybase for turning me on to this one)
-
-=head1 VERSION
-
-1.03 ALPHA 97-12-14
-
-=head1 REVISION NOTES
-
-=over 10
-
-=item 1.03 ALPHA 1998.01.11
-
-Imported diffs from 0.67 (parent) version
-
-=item 1.02 ALPHA 1997.12.14
-
-Pod fixes, @EXPORT list additions <gsar@activestate.com>
-
-Fix unitialized vars on unknown ACLs <jmk@exc.bybyte.de>
-
-=item 1.01 ALPHA 1997.04.25
-
-CORE Win32 version imported from 0.66 <gsar@activestate.com>
-
-=item 0.67 ALPHA 1997.07.07
-
-Kludged bug in mapping bits to separate ACE's. Notably, this screwed
-up CHANGE access by leaving out a delete bit in the
-C<INHERIT_ONLY_ACE | OBJECT_INHERIT_ACE> Access Control Entry.
-
-May need to rethink...
-
-=item 0.66 ALPHA 1997.03.13
-
-Fixed bug in memory allocation check
-
-=item 0.65 ALPHA 1997.02.25
-
-Tested with 5.003 build 303
-
-Added ISA exporter, and @EXPORT_OK
-
-Added F, FULL, R, READ, C, CHANGE as composite pre-built mask names.
-
-Added server\ to keys returned in hash from Get
-
-Made constants and MakeMask case insensitive (I don't know why I did that)
-
-Fixed mask comparison in ListDacl and Enumerate Rights from simple & mask
-to exact bit match ! ( ( x & y ) ^ x ) makes sure all bits in x
-are set in y
-
-Fixed some "wild" pointers
-
-=item 0.60 ALPHA 1996.07.31
-
-Now suitable for file and directory permissions
-
-Included ListDacl.exe in bundle for debugging
-
-Added "intuitive" inheritance for directories, basically functions like FM
-triggered by presence of GENERIC_ rights this may need to change
-
-see EXAMPLE2
-
-Changed from AddAccessAllowedAce to AddAce for control over inheritance
-
-=item 0.51 ALPHA 1996.07.20
-
-Fixed memory allocation bug
-
-=item 0.50 ALPHA 1996.07.29
-
-Base functionality
-
-Using AddAccessAllowedAce
-
-Suitable for file permissions
-
-=back
-
-=head1 KNOWN ISSUES / BUGS
-
-=over 10
-
-=item 1
-
-May not work on remote drives.
-
-=item 2
-
-Errors croak, don't return via $! as documented.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/IPC.pm b/Master/tlpkg/installer/perllib/Win32/IPC.pm
deleted file mode 100644
index c97279b24c5..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/IPC.pm
+++ /dev/null
@@ -1,195 +0,0 @@
-#---------------------------------------------------------------------
-package Win32::IPC;
-#
-# Copyright 1998 Christopher J. Madsen
-#
-# Created: 3 Feb 1998 from the ActiveWare version
-# (c) 1995 Microsoft Corporation. All rights reserved.
-# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com
-#
-# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com>
-#
-# Author: Christopher J. Madsen <cjm@pobox.com>
-# Version: 1.03 (11-Jul-2003)
-#
-# This program 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. See either the
-# GNU General Public License or the Artistic License for more details.
-#
-# Base class for Win32 synchronization objects
-#---------------------------------------------------------------------
-
-$VERSION = '1.03';
-
-require Exporter;
-require DynaLoader;
-use strict;
-use vars qw($AUTOLOAD $VERSION @ISA @EXPORT @EXPORT_OK);
-
-@ISA = qw(Exporter DynaLoader);
-@EXPORT = qw(
- INFINITE
- WaitForMultipleObjects
-);
-@EXPORT_OK = qw(
- wait_any wait_all
-);
-
-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::IPC macro $constname, used at $file line $line.";
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-} # end AUTOLOAD
-
-bootstrap Win32::IPC;
-
-# How's this for cryptic? Use wait_any or wait_all!
-sub WaitForMultipleObjects
-{
- my $result = (($_[1] ? wait_all($_[0], $_[2])
- : wait_any($_[0], $_[2]))
- ? 1
- : 0);
- @{$_[0]} = (); # Bug for bug compatibility! Use wait_any or wait_all!
- $result;
-} # end WaitForMultipleObjects
-
-1;
-__END__
-
-=head1 NAME
-
-Win32::IPC - Base class for Win32 synchronization objects
-
-=head1 SYNOPSIS
-
- use Win32::Event 1.00 qw(wait_any);
- #Create objects.
-
- wait_any(@ListOfObjects,$timeout);
-
-=head1 DESCRIPTION
-
-This module is loaded by the other Win32 synchronization modules. You
-shouldn't need to load it yourself. It supplies the wait functions to
-those modules.
-
-The synchronization modules are L<"Win32::ChangeNotify">,
-L<"Win32::Event">, L<"Win32::Mutex">, & L<"Win32::Semaphore">.
-
-In addition, you can use C<wait_any> and C<wait_all> with
-L<"Win32::Console"> and L<"Win32::Process"> objects. (However, those
-modules do not export the wait functions; you must load one of the
-synchronization modules (or just Win32::IPC)).
-
-=head2 Methods
-
-B<Win32::IPC> supplies one method to all synchronization objects.
-
-=over 4
-
-=item $obj->wait([$timeout])
-
-Waits for C<$obj> to become signalled. C<$timeout> is the maximum time
-to wait (in milliseconds). If C<$timeout> is omitted, waits forever.
-If C<$timeout> is 0, returns immediately.
-
-Returns:
-
- +1 The object is signalled
- -1 The object is an abandoned mutex
- 0 Timed out
- undef An error occurred
-
-=back
-
-=head2 Functions
-
-=over 4
-
-=item wait_any(@objects, [$timeout])
-
-Waits for at least one of the C<@objects> to become signalled.
-C<$timeout> is the maximum time to wait (in milliseconds). If
-C<$timeout> is omitted, waits forever. If C<$timeout> is 0, returns
-immediately.
-
-The return value indicates which object ended the wait:
-
- +N $object[N-1] is signalled
- -N $object[N-1] is an abandoned mutex
- 0 Timed out
- undef An error occurred
-
-If more than one object became signalled, the one with the lowest
-index is used.
-
-=item wait_all(@objects, [$timeout])
-
-This is the same as C<wait_any>, but it waits for all the C<@objects>
-to become signalled. The return value indicates the last object to
-become signalled, and is negative if at least one of the C<@objects>
-is an abandoned mutex.
-
-=back
-
-=head2 Deprecated Functions and Methods
-
-B<Win32::IPC> still supports the ActiveWare syntax, but its use is
-deprecated.
-
-=over 4
-
-=item INFINITE
-
-Constant value for an infinite timeout. Omit the C<$timeout> argument
-instead.
-
-=item WaitForMultipleObjects(\@objects, $wait_all, $timeout)
-
-Warning: C<WaitForMultipleObjects> erases C<@objects>!
-Use C<wait_all> or C<wait_any> instead.
-
-=item $obj->Wait($timeout)
-
-Similar to C<not $obj-E<gt>wait($timeout)>.
-
-=back
-
-=head1 INTERNALS
-
-The C<wait_any> and C<wait_all> functions support two kinds of
-objects. Objects derived from C<Win32::IPC> are expected to consist
-of a reference to a scalar containing the Win32 HANDLE as an IV.
-
-Other objects (for which C<UNIVERSAL::isa($object, "Win32::IPC")> is
-false), are expected to implement a C<get_Win32_IPC_HANDLE> method.
-When called in scalar context with no arguments, this method should
-return a Win32 HANDLE (as an IV) suitable for passing to the Win32
-WaitForMultipleObjects API function.
-
-=head1 AUTHOR
-
-Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt>
-
-Loosely based on the original module by ActiveWare Internet Corp.,
-F<http://www.ActiveWare.com>
-
-=cut
-
-# Local Variables:
-# tmtrack-file-task: "Win32::IPC"
-# End:
diff --git a/Master/tlpkg/installer/perllib/Win32/Internet.pm b/Master/tlpkg/installer/perllib/Win32/Internet.pm
deleted file mode 100644
index f6dac3130af..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Internet.pm
+++ /dev/null
@@ -1,3009 +0,0 @@
-#######################################################################
-#
-# Win32::Internet - Perl Module for Internet Extensions
-# ^^^^^^^^^^^^^^^
-# This module creates an object oriented interface to the Win32
-# Internet Functions (WININET.DLL).
-#
-# Version: 0.08 (14 Feb 1997)
-# Version: 0.081 (25 Sep 1999)
-# Version: 0.082 (04 Sep 2001)
-#
-#######################################################################
-
-# changes:
-# - fixed 2 bugs in Option(s) related subs
-# - works with build 30x also
-
-package Win32::Internet;
-
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
-
-# use Win32::WinError; # for windows constants.
-
-@ISA= qw( Exporter DynaLoader );
-@EXPORT = qw(
- HTTP_ADDREQ_FLAG_ADD
- HTTP_ADDREQ_FLAG_REPLACE
- HTTP_QUERY_ALLOW
- HTTP_QUERY_CONTENT_DESCRIPTION
- HTTP_QUERY_CONTENT_ID
- HTTP_QUERY_CONTENT_LENGTH
- HTTP_QUERY_CONTENT_TRANSFER_ENCODING
- HTTP_QUERY_CONTENT_TYPE
- HTTP_QUERY_COST
- HTTP_QUERY_CUSTOM
- HTTP_QUERY_DATE
- HTTP_QUERY_DERIVED_FROM
- HTTP_QUERY_EXPIRES
- HTTP_QUERY_FLAG_REQUEST_HEADERS
- HTTP_QUERY_FLAG_SYSTEMTIME
- HTTP_QUERY_LANGUAGE
- HTTP_QUERY_LAST_MODIFIED
- HTTP_QUERY_MESSAGE_ID
- HTTP_QUERY_MIME_VERSION
- HTTP_QUERY_PRAGMA
- HTTP_QUERY_PUBLIC
- HTTP_QUERY_RAW_HEADERS
- HTTP_QUERY_RAW_HEADERS_CRLF
- HTTP_QUERY_REQUEST_METHOD
- HTTP_QUERY_SERVER
- HTTP_QUERY_STATUS_CODE
- HTTP_QUERY_STATUS_TEXT
- HTTP_QUERY_URI
- HTTP_QUERY_USER_AGENT
- HTTP_QUERY_VERSION
- HTTP_QUERY_WWW_LINK
- ICU_BROWSER_MODE
- ICU_DECODE
- ICU_ENCODE_SPACES_ONLY
- ICU_ESCAPE
- ICU_NO_ENCODE
- ICU_NO_META
- ICU_USERNAME
- INTERNET_FLAG_PASSIVE
- INTERNET_FLAG_ASYNC
- INTERNET_HYPERLINK
- INTERNET_FLAG_KEEP_CONNECTION
- INTERNET_FLAG_MAKE_PERSISTENT
- INTERNET_FLAG_NO_AUTH
- INTERNET_FLAG_NO_AUTO_REDIRECT
- INTERNET_FLAG_NO_CACHE_WRITE
- INTERNET_FLAG_NO_COOKIES
- INTERNET_FLAG_READ_PREFETCH
- INTERNET_FLAG_RELOAD
- INTERNET_FLAG_RESYNCHRONIZE
- INTERNET_FLAG_TRANSFER_ASCII
- INTERNET_FLAG_TRANSFER_BINARY
- INTERNET_INVALID_PORT_NUMBER
- INTERNET_INVALID_STATUS_CALLBACK
- INTERNET_OPEN_TYPE_DIRECT
- INTERNET_OPEN_TYPE_PROXY
- INTERNET_OPEN_TYPE_PROXY_PRECONFIG
- INTERNET_OPTION_CONNECT_BACKOFF
- INTERNET_OPTION_CONNECT_RETRIES
- INTERNET_OPTION_CONNECT_TIMEOUT
- INTERNET_OPTION_CONTROL_SEND_TIMEOUT
- INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT
- INTERNET_OPTION_DATA_SEND_TIMEOUT
- INTERNET_OPTION_DATA_RECEIVE_TIMEOUT
- INTERNET_OPTION_HANDLE_SIZE
- INTERNET_OPTION_LISTEN_TIMEOUT
- INTERNET_OPTION_PASSWORD
- INTERNET_OPTION_READ_BUFFER_SIZE
- INTERNET_OPTION_USER_AGENT
- INTERNET_OPTION_USERNAME
- INTERNET_OPTION_VERSION
- INTERNET_OPTION_WRITE_BUFFER_SIZE
- INTERNET_SERVICE_FTP
- INTERNET_SERVICE_GOPHER
- INTERNET_SERVICE_HTTP
- INTERNET_STATUS_CLOSING_CONNECTION
- INTERNET_STATUS_CONNECTED_TO_SERVER
- INTERNET_STATUS_CONNECTING_TO_SERVER
- INTERNET_STATUS_CONNECTION_CLOSED
- INTERNET_STATUS_HANDLE_CLOSING
- INTERNET_STATUS_HANDLE_CREATED
- INTERNET_STATUS_NAME_RESOLVED
- INTERNET_STATUS_RECEIVING_RESPONSE
- INTERNET_STATUS_REDIRECT
- INTERNET_STATUS_REQUEST_COMPLETE
- INTERNET_STATUS_REQUEST_SENT
- INTERNET_STATUS_RESOLVING_NAME
- INTERNET_STATUS_RESPONSE_RECEIVED
- INTERNET_STATUS_SENDING_REQUEST
-);
-
-
-#######################################################################
-# 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 $! = 0;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
-
- # [dada] This results in an ugly Autoloader error
- #if ($! =~ /Invalid/) {
- # $AutoLoader::AUTOLOAD = $AUTOLOAD;
- # goto &AutoLoader::AUTOLOAD;
- #} else {
-
- # [dada] ... I prefer this one :)
-
- ($pack,$file,$line) = caller; undef $pack;
- die "Win32::Internet::$constname is not defined, used at $file line $line.";
-
- #}
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-
-#######################################################################
-# STATIC OBJECT PROPERTIES
-#
-$VERSION = "0.082";
-
-%callback_code = ();
-%callback_info = ();
-
-
-#######################################################################
-# PUBLIC METHODS
-#
-
-#======== ### CLASS CONSTRUCTOR
-sub new {
-#========
- my($class, $useragent, $opentype, $proxy, $proxybypass, $flags) = @_;
- my $self = {};
-
- if(ref($useragent) and ref($useragent) eq "HASH") {
- $opentype = $useragent->{'opentype'};
- $proxy = $useragent->{'proxy'};
- $proxybypass = $useragent->{'proxybypass'};
- $flags = $useragent->{'flags'};
- my $myuseragent = $useragent->{'useragent'};
- undef $useragent;
- $useragent = $myuseragent;
- }
-
- $useragent = "Perl-Win32::Internet/".$VERSION unless defined($useragent);
- $opentype = constant("INTERNET_OPEN_TYPE_DIRECT",0) unless defined($opentype);
- $proxy = "" unless defined($proxy);
- $proxybypass = "" unless defined($proxybypass);
- $flags = 0 unless defined($flags);
-
-
- my $handle = InternetOpen($useragent, $opentype, $proxy, $proxybypass, $flags);
- if ($handle) {
- $self->{'connections'} = 0;
- $self->{'pasv'} = 0;
- $self->{'handle'} = $handle;
- $self->{'useragent'} = $useragent;
- $self->{'proxy'} = $proxy;
- $self->{'proxybypass'} = $proxybypass;
- $self->{'flags'} = $flags;
- $self->{'Type'} = "Internet";
-
- # [dada] I think it's better to call SetStatusCallback explicitly...
- #if($flags & constant("INTERNET_FLAG_ASYNC",0)) {
- # my $callbackresult=InternetSetStatusCallback($handle);
- # if($callbackresult==&constant("INTERNET_INVALID_STATUS_CALLBACK",0)) {
- # $self->{'Error'} = -2;
- # }
- #}
-
- bless $self;
- } else {
- $self->{'handle'} = undef;
- bless $self;
- }
- $self;
-}
-
-
-#============
-sub OpenURL {
-#============
- my($self,$new,$URL) = @_;
- return undef unless ref($self);
-
- my $newhandle=InternetOpenUrl($self->{'handle'},$URL,"",0,0,0);
- if(!$newhandle) {
- $self->{'Error'} = "Cannot open URL.";
- return undef;
- } else {
- $self->{'connections'}++;
- $_[1] = _new($newhandle);
- $_[1]->{'Type'} = "URL";
- $_[1]->{'URL'} = $URL;
- return $newhandle;
- }
-}
-
-
-#================
-sub TimeConvert {
-#================
- my($self, $sec, $min, $hour, $day, $mon, $year, $wday, $rfc) = @_;
- return undef unless ref($self);
-
- if(!defined($rfc)) {
- return InternetTimeToSystemTime($sec);
- } else {
- return InternetTimeFromSystemTime($sec, $min, $hour,
- $day, $mon, $year,
- $wday, $rfc);
- }
-}
-
-
-#=======================
-sub QueryDataAvailable {
-#=======================
- my($self) = @_;
- return undef unless ref($self);
-
- return InternetQueryDataAvailable($self->{'handle'});
-}
-
-
-#=============
-sub ReadFile {
-#=============
- my($self, $buffersize) = @_;
- return undef unless ref($self);
-
- my $howmuch = InternetQueryDataAvailable($self->{'handle'});
- $buffersize = $howmuch unless defined($buffersize);
- return InternetReadFile($self->{'handle'}, ($howmuch<$buffersize) ? $howmuch
- : $buffersize);
-}
-
-
-#===================
-sub ReadEntireFile {
-#===================
- my($handle) = @_;
- my $content = "";
- my $buffersize = 16000;
- my $howmuch = 0;
- my $buffer = "";
-
- $handle = $handle->{'handle'} if defined($handle) and ref($handle);
-
- $howmuch = InternetQueryDataAvailable($handle);
- # print "\nReadEntireFile: $howmuch bytes to read...\n";
-
- while($howmuch>0) {
- $buffer = InternetReadFile($handle, ($howmuch<$buffersize) ? $howmuch
- : $buffersize);
- # print "\nReadEntireFile: ", length($buffer), " bytes read...\n";
-
- if(!defined($buffer)) {
- return undef;
- } else {
- $content .= $buffer;
- }
- $howmuch = InternetQueryDataAvailable($handle);
- # print "\nReadEntireFile: still $howmuch bytes to read...\n";
-
- }
- return $content;
-}
-
-
-#=============
-sub FetchURL {
-#=============
- # (OpenURL+Read+Close)...
- my($self, $URL) = @_;
- return undef unless ref($self);
-
- my $newhandle = InternetOpenUrl($self->{'handle'}, $URL, "", 0, 0, 0);
- if(!$newhandle) {
- $self->{'Error'} = "Cannot open URL.";
- return undef;
- } else {
- my $content = ReadEntireFile($newhandle);
- InternetCloseHandle($newhandle);
- return $content;
- }
-}
-
-
-#================
-sub Connections {
-#================
- my($self) = @_;
- return undef unless ref($self);
-
- return $self->{'connections'} if $self->{'Type'} eq "Internet";
- return undef;
-}
-
-
-#================
-sub GetResponse {
-#================
- my($num, $text) = InternetGetLastResponseInfo();
- return $text;
-}
-
-#===========
-sub Option {
-#===========
- my($self, $option, $value) = @_;
- return undef unless ref($self);
-
- my $retval = 0;
-
- $option = constant("INTERNET_OPTION_USER_AGENT", 0) unless defined($option);
-
- if(!defined($value)) {
- $retval = InternetQueryOption($self->{'handle'}, $option);
- } else {
- $retval = InternetSetOption($self->{'handle'}, $option, $value);
- }
- return $retval;
-}
-
-
-#==============
-sub UserAgent {
-#==============
- my($self, $value) = @_;
- return undef unless ref($self);
-
- return Option($self, constant("INTERNET_OPTION_USER_AGENT", 0), $value);
-}
-
-
-#=============
-sub Username {
-#=============
- my($self, $value) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") {
- $self->{'Error'} = "Username() only on FTP or HTTP sessions.";
- return undef;
- }
-
- return Option($self, constant("INTERNET_OPTION_USERNAME", 0), $value);
-}
-
-
-#=============
-sub Password {
-#=============
- my($self, $value)=@_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") {
- $self->{'Error'} = "Password() only on FTP or HTTP sessions.";
- return undef;
- }
-
- return Option($self, constant("INTERNET_OPTION_PASSWORD", 0), $value);
-}
-
-
-#===================
-sub ConnectTimeout {
-#===================
- my($self, $value) = @_;
- return undef unless ref($self);
-
- return Option($self, constant("INTERNET_OPTION_CONNECT_TIMEOUT", 0), $value);
-}
-
-
-#===================
-sub ConnectRetries {
-#===================
- my($self, $value) = @_;
- return undef unless ref($self);
-
- return Option($self, constant("INTERNET_OPTION_CONNECT_RETRIES", 0), $value);
-}
-
-
-#===================
-sub ConnectBackoff {
-#===================
- my($self,$value)=@_;
- return undef unless ref($self);
-
- return Option($self, constant("INTERNET_OPTION_CONNECT_BACKOFF", 0), $value);
-}
-
-
-#====================
-sub DataSendTimeout {
-#====================
- my($self,$value) = @_;
- return undef unless ref($self);
-
- return Option($self, constant("INTERNET_OPTION_DATA_SEND_TIMEOUT", 0), $value);
-}
-
-
-#=======================
-sub DataReceiveTimeout {
-#=======================
- my($self, $value) = @_;
- return undef unless ref($self);
-
- return Option($self, constant("INTERNET_OPTION_DATA_RECEIVE_TIMEOUT", 0), $value);
-}
-
-
-#==========================
-sub ControlReceiveTimeout {
-#==========================
- my($self, $value) = @_;
- return undef unless ref($self);
-
- return Option($self, constant("INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT", 0), $value);
-}
-
-
-#=======================
-sub ControlSendTimeout {
-#=======================
- my($self, $value) = @_;
- return undef unless ref($self);
-
- return Option($self, constant("INTERNET_OPTION_CONTROL_SEND_TIMEOUT", 0), $value);
-}
-
-
-#================
-sub QueryOption {
-#================
- my($self, $option) = @_;
- return undef unless ref($self);
-
- return InternetQueryOption($self->{'handle'}, $option);
-}
-
-
-#==============
-sub SetOption {
-#==============
- my($self, $option, $value) = @_;
- return undef unless ref($self);
-
- return InternetSetOption($self->{'handle'}, $option, $value);
-}
-
-
-#=============
-sub CrackURL {
-#=============
- my($self, $URL, $flags) = @_;
- return undef unless ref($self);
-
- $flags = constant("ICU_ESCAPE", 0) unless defined($flags);
-
- my @newurl = InternetCrackUrl($URL, $flags);
-
- if(!defined($newurl[0])) {
- $self->{'Error'} = "Cannot crack URL.";
- return undef;
- } else {
- return @newurl;
- }
-}
-
-
-#==============
-sub CreateURL {
-#==============
- my($self, $scheme, $hostname, $port,
- $username, $password,
- $path, $extrainfo, $flags) = @_;
- return undef unless ref($self);
-
- if(ref($scheme) and ref($scheme) eq "HASH") {
- $flags = $hostname;
- $hostname = $scheme->{'hostname'};
- $port = $scheme->{'port'};
- $username = $scheme->{'username'};
- $password = $scheme->{'password'};
- $path = $scheme->{'path'};
- $extrainfo = $scheme->{'extrainfo'};
- my $myscheme = $scheme->{'scheme'};
- undef $scheme;
- $scheme = $myscheme;
- }
-
- $hostname = "" unless defined($hostname);
- $port = 0 unless defined($port);
- $username = "" unless defined($username);
- $password = "" unless defined($password);
- $path = "" unless defined($path);
- $extrainfo = "" unless defined($extrainfo);
- $flags = constant("ICU_ESCAPE", 0) unless defined($flags);
-
- my $newurl = InternetCreateUrl($scheme, $hostname, $port,
- $username, $password,
- $path, $extrainfo, $flags);
- if(!defined($newurl)) {
- $self->{'Error'} = "Cannot create URL.";
- return undef;
- } else {
- return $newurl;
- }
-}
-
-
-#====================
-sub CanonicalizeURL {
-#====================
- my($self, $URL, $flags) = @_;
- return undef unless ref($self);
-
- my $newurl = InternetCanonicalizeUrl($URL, $flags);
- if(!defined($newurl)) {
- $self->{'Error'} = "Cannot canonicalize URL.";
- return undef;
- } else {
- return $newurl;
- }
-}
-
-
-#===============
-sub CombineURL {
-#===============
- my($self, $baseURL, $relativeURL, $flags) = @_;
- return undef unless ref($self);
-
- my $newurl = InternetCombineUrl($baseURL, $relativeURL, $flags);
- if(!defined($newurl)) {
- $self->{'Error'} = "Cannot combine URL(s).";
- return undef;
- } else {
- return $newurl;
- }
-}
-
-
-#======================
-sub SetStatusCallback {
-#======================
- my($self) = @_;
- return undef unless ref($self);
-
- my $callback = InternetSetStatusCallback($self->{'handle'});
- print "callback=$callback, constant=",constant("INTERNET_INVALID_STATUS_CALLBACK", 0), "\n";
- if($callback == constant("INTERNET_INVALID_STATUS_CALLBACK", 0)) {
- return undef;
- } else {
- return $callback;
- }
-}
-
-
-#======================
-sub GetStatusCallback {
-#======================
- my($self, $context) = @_;
- $context = $self if not defined $context;
- return($callback_code{$context}, $callback_info{$context});
-}
-
-
-#==========
-sub Error {
-#==========
- my($self) = @_;
- return undef unless ref($self);
-
- require Win32 unless defined &Win32::GetLastError;
- my $errtext = "";
- my $tmp = "";
- my $errnum = Win32::GetLastError();
-
- if($errnum < 12000) {
- $errtext = Win32::FormatMessage($errnum);
- $errtext =~ s/[\r\n]//g;
- } elsif($errnum == 12003) {
- ($tmp, $errtext) = InternetGetLastResponseInfo();
- chomp $errtext;
- 1 while($errtext =~ s/(.*)\n//); # the last line should be significative...
- # otherwise call GetResponse() to get it whole
- } elsif($errnum >= 12000) {
- $errtext = FormatMessage($errnum);
- $errtext =~ s/[\r\n]//g;
- } else {
- $errtext="Error";
- }
- if($errnum == 0 and defined($self->{'Error'})) {
- if($self->{'Error'} == -2) {
- $errnum = -2;
- $errtext = "Asynchronous operations not available.";
- } else {
- $errnum = -1;
- $errtext = $self->{'Error'};
- }
- }
- return (wantarray)? ($errnum, $errtext) : "\[".$errnum."\] ".$errtext;
-}
-
-
-#============
-sub Version {
-#============
- my $dll = InternetDllVersion();
- $dll =~ s/\0//g;
- return (wantarray)? ($Win32::Internet::VERSION, $dll)
- : $Win32::Internet::VERSION."/".$dll;
-}
-
-
-#==========
-sub Close {
-#==========
- my($self, $handle) = @_;
- if(!defined($handle)) {
- return undef unless ref($self);
- $handle = $self->{'handle'};
- }
- InternetCloseHandle($handle);
-}
-
-
-
-#######################################################################
-# FTP CLASS METHODS
-#
-
-#======== ### FTP CONSTRUCTOR
-sub FTP {
-#========
- my($self, $new, $server, $username, $password, $port, $pasv, $context) = @_;
- return undef unless ref($self);
-
- if(ref($server) and ref($server) eq "HASH") {
- $port = $server->{'port'};
- $username = $server->{'username'};
- $password = $password->{'host'};
- my $myserver = $server->{'server'};
- $pasv = $server->{'pasv'};
- $context = $server->{'context'};
- undef $server;
- $server = $myserver;
- }
-
- $server = "" unless defined($server);
- $username = "anonymous" unless defined($username);
- $password = "" unless defined($password);
- $port = 21 unless defined($port);
- $context = 0 unless defined($context);
-
- $pasv = $self->{'pasv'} unless defined $pasv;
- $pasv = $pasv ? constant("INTERNET_FLAG_PASSIVE",0) : 0;
-
- my $newhandle = InternetConnect($self->{'handle'}, $server, $port,
- $username, $password,
- constant("INTERNET_SERVICE_FTP", 0),
- $pasv, $context);
- if($newhandle) {
- $self->{'connections'}++;
- $_[1] = _new($newhandle);
- $_[1]->{'Type'} = "FTP";
- $_[1]->{'Mode'} = "bin";
- $_[1]->{'pasv'} = $pasv;
- $_[1]->{'username'} = $username;
- $_[1]->{'password'} = $password;
- $_[1]->{'server'} = $server;
- return $newhandle;
- } else {
- return undef;
- }
-}
-
-#========
-sub Pwd {
-#========
- my($self) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) {
- $self->{'Error'} = "Pwd() only on FTP sessions.";
- return undef;
- }
-
- return FtpGetCurrentDirectory($self->{'handle'});
-}
-
-
-#=======
-sub Cd {
-#=======
- my($self, $path) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP" || !defined($self->{'handle'})) {
- $self->{'Error'} = "Cd() only on FTP sessions.";
- return undef;
- }
-
- my $retval = FtpSetCurrentDirectory($self->{'handle'}, $path);
- if(!defined($retval)) {
- return undef;
- } else {
- return $path;
- }
-}
-#====================
-sub Cwd { Cd(@_); }
-sub Chdir { Cd(@_); }
-#====================
-
-
-#==========
-sub Mkdir {
-#==========
- my($self, $path) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) {
- $self->{'Error'} = "Mkdir() only on FTP sessions.";
- return undef;
- }
-
- my $retval = FtpCreateDirectory($self->{'handle'}, $path);
- $self->{'Error'} = "Can't create directory." unless defined($retval);
- return $retval;
-}
-#====================
-sub Md { Mkdir(@_); }
-#====================
-
-
-#=========
-sub Mode {
-#=========
- my($self, $value) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) {
- $self->{'Error'} = "Mode() only on FTP sessions.";
- return undef;
- }
-
- if(!defined($value)) {
- return $self->{'Mode'};
- } else {
- my $modesub = ($value =~ /^a/i) ? "Ascii" : "Binary";
- $self->$modesub($_[0]);
- }
- return $self->{'Mode'};
-}
-
-
-#==========
-sub Rmdir {
-#==========
- my($self, $path) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) {
- $self->{'Error'} = "Rmdir() only on FTP sessions.";
- return undef;
- }
- my $retval = FtpRemoveDirectory($self->{'handle'}, $path);
- $self->{'Error'} = "Can't remove directory." unless defined($retval);
- return $retval;
-}
-#====================
-sub Rd { Rmdir(@_); }
-#====================
-
-
-#=========
-sub Pasv {
-#=========
- my($self, $value) = @_;
- return undef unless ref($self);
-
- if(defined($value) and $self->{'Type'} eq "Internet") {
- if($value == 0) {
- $self->{'pasv'} = 0;
- } else {
- $self->{'pasv'} = 1;
- }
- }
- return $self->{'pasv'};
-}
-
-#=========
-sub List {
-#=========
- my($self, $pattern, $retmode) = @_;
- return undef unless ref($self);
-
- my $retval = "";
- my $size = "";
- my $attr = "";
- my $ctime = "";
- my $atime = "";
- my $mtime = "";
- my $csec = 0; my $cmin = 0; my $chou = 0; my $cday = 0; my $cmon = 0; my $cyea = 0;
- my $asec = 0; my $amin = 0; my $ahou = 0; my $aday = 0; my $amon = 0; my $ayea = 0;
- my $msec = 0; my $mmin = 0; my $mhou = 0; my $mday = 0; my $mmon = 0; my $myea = 0;
- my $newhandle = 0;
- my $nextfile = 1;
- my @results = ();
- my ($filename, $altname, $file);
-
- if($self->{'Type'} ne "FTP") {
- $self->{'Error'} = "List() only on FTP sessions.";
- return undef;
- }
-
- $pattern = "" unless defined($pattern);
- $retmode = 1 unless defined($retmode);
-
- if($retmode == 2) {
-
- ( $newhandle,$filename, $altname, $size, $attr,
- $csec, $cmin, $chou, $cday, $cmon, $cyea,
- $asec, $amin, $ahou, $aday, $amon, $ayea,
- $msec, $mmin, $mhou, $mday, $mmon, $myea
- ) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0);
-
- if(!$newhandle) {
- $self->{'Error'} = "Can't read FTP directory.";
- return undef;
- } else {
-
- while($nextfile) {
- $ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea));
- $atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea));
- $mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea));
- push(@results, $filename, $altname, $size, $attr, $ctime, $atime, $mtime);
-
- ( $nextfile, $filename, $altname, $size, $attr,
- $csec, $cmin, $chou, $cday, $cmon, $cyea,
- $asec, $amin, $ahou, $aday, $amon, $ayea,
- $msec, $mmin, $mhou, $mday, $mmon, $myea
- ) = InternetFindNextFile($newhandle);
-
- }
- InternetCloseHandle($newhandle);
- return @results;
-
- }
-
- } elsif($retmode == 3) {
-
- ( $newhandle,$filename, $altname, $size, $attr,
- $csec, $cmin, $chou, $cday, $cmon, $cyea,
- $asec, $amin, $ahou, $aday, $amon, $ayea,
- $msec, $mmin, $mhou, $mday, $mmon, $myea
- ) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0);
-
- if(!$newhandle) {
- $self->{'Error'} = "Can't read FTP directory.";
- return undef;
-
- } else {
-
- while($nextfile) {
- $ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea));
- $atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea));
- $mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea));
- $file = { "name" => $filename,
- "altname" => $altname,
- "size" => $size,
- "attr" => $attr,
- "ctime" => $ctime,
- "atime" => $atime,
- "mtime" => $mtime,
- };
- push(@results, $file);
-
- ( $nextfile, $filename, $altname, $size, $attr,
- $csec, $cmin, $chou, $cday, $cmon, $cyea,
- $asec, $amin, $ahou, $aday, $amon, $ayea,
- $msec, $mmin, $mhou, $mday, $mmon, $myea
- ) = InternetFindNextFile($newhandle);
-
- }
- InternetCloseHandle($newhandle);
- return @results;
- }
-
- } else {
-
- ($newhandle, $filename) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0);
-
- if(!$newhandle) {
- $self->{'Error'} = "Can't read FTP directory.";
- return undef;
-
- } else {
-
- while($nextfile) {
- push(@results, $filename);
-
- ($nextfile, $filename) = InternetFindNextFile($newhandle);
- # print "List.no more files\n" if !$nextfile;
-
- }
- InternetCloseHandle($newhandle);
- return @results;
- }
- }
-}
-#====================
-sub Ls { List(@_); }
-sub Dir { List(@_); }
-#====================
-
-
-#=================
-sub FileAttrInfo {
-#=================
- my($self,$attr) = @_;
- my @attrinfo = ();
- push(@attrinfo, "READONLY") if $attr & 1;
- push(@attrinfo, "HIDDEN") if $attr & 2;
- push(@attrinfo, "SYSTEM") if $attr & 4;
- push(@attrinfo, "DIRECTORY") if $attr & 16;
- push(@attrinfo, "ARCHIVE") if $attr & 32;
- push(@attrinfo, "NORMAL") if $attr & 128;
- push(@attrinfo, "TEMPORARY") if $attr & 256;
- push(@attrinfo, "COMPRESSED") if $attr & 2048;
- return (wantarray)? @attrinfo : join(" ", @attrinfo);
-}
-
-
-#===========
-sub Binary {
-#===========
- my($self) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP") {
- $self->{'Error'} = "Binary() only on FTP sessions.";
- return undef;
- }
- $self->{'Mode'} = "bin";
- return undef;
-}
-#======================
-sub Bin { Binary(@_); }
-#======================
-
-
-#==========
-sub Ascii {
-#==========
- my($self) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP") {
- $self->{'Error'} = "Ascii() only on FTP sessions.";
- return undef;
- }
- $self->{'Mode'} = "asc";
- return undef;
-}
-#=====================
-sub Asc { Ascii(@_); }
-#=====================
-
-
-#========
-sub Get {
-#========
- my($self, $remote, $local, $overwrite, $flags, $context) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP") {
- $self->{'Error'} = "Get() only on FTP sessions.";
- return undef;
- }
- my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2);
-
- $remote = "" unless defined($remote);
- $local = $remote unless defined($local);
- $overwrite = 0 unless defined($overwrite);
- $flags = 0 unless defined($flags);
- $context = 0 unless defined($context);
-
- my $retval = FtpGetFile($self->{'handle'},
- $remote,
- $local,
- $overwrite,
- $flags,
- $mode,
- $context);
- $self->{'Error'} = "Can't get file." unless defined($retval);
- return $retval;
-}
-
-
-#===========
-sub Rename {
-#===========
- my($self, $oldname, $newname) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP") {
- $self->{'Error'} = "Rename() only on FTP sessions.";
- return undef;
- }
-
- my $retval = FtpRenameFile($self->{'handle'}, $oldname, $newname);
- $self->{'Error'} = "Can't rename file." unless defined($retval);
- return $retval;
-}
-#======================
-sub Ren { Rename(@_); }
-#======================
-
-
-#===========
-sub Delete {
-#===========
- my($self, $filename) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP") {
- $self->{'Error'} = "Delete() only on FTP sessions.";
- return undef;
- }
- my $retval = FtpDeleteFile($self->{'handle'}, $filename);
- $self->{'Error'} = "Can't delete file." unless defined($retval);
- return $retval;
-}
-#======================
-sub Del { Delete(@_); }
-#======================
-
-
-#========
-sub Put {
-#========
- my($self, $local, $remote, $context) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "FTP") {
- $self->{'Error'} = "Put() only on FTP sessions.";
- return undef;
- }
- my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2);
-
- $context = 0 unless defined($context);
-
- my $retval = FtpPutFile($self->{'handle'}, $local, $remote, $mode, $context);
- $self->{'Error'} = "Can't put file." unless defined($retval);
- return $retval;
-}
-
-
-#######################################################################
-# HTTP CLASS METHODS
-#
-
-#========= ### HTTP CONSTRUCTOR
-sub HTTP {
-#=========
- my($self, $new, $server, $username, $password, $port, $flags, $context) = @_;
- return undef unless ref($self);
-
- if(ref($server) and ref($server) eq "HASH") {
- my $myserver = $server->{'server'};
- $username = $server->{'username'};
- $password = $password->{'host'};
- $port = $server->{'port'};
- $flags = $server->{'flags'};
- $context = $server->{'context'};
- undef $server;
- $server = $myserver;
- }
-
- $server = "" unless defined($server);
- $username = "anonymous" unless defined($username);
- $password = "" unless defined($password);
- $port = 80 unless defined($port);
- $flags = 0 unless defined($flags);
- $context = 0 unless defined($context);
-
- my $newhandle = InternetConnect($self->{'handle'}, $server, $port,
- $username, $password,
- constant("INTERNET_SERVICE_HTTP", 0),
- $flags, $context);
- if($newhandle) {
- $self->{'connections'}++;
- $_[1] = _new($newhandle);
- $_[1]->{'Type'} = "HTTP";
- $_[1]->{'username'} = $username;
- $_[1]->{'password'} = $password;
- $_[1]->{'server'} = $server;
- $_[1]->{'accept'} = "text/*\0image/gif\0image/jpeg\0\0";
- return $newhandle;
- } else {
- return undef;
- }
-}
-
-
-#================
-sub OpenRequest {
-#================
- # alternatively to Request:
- # it creates a new HTTP_Request object
- # you can act upon it with AddHeader, SendRequest, ReadFile, QueryInfo, Close, ...
-
- my($self, $new, $path, $method, $version, $referer, $accept, $flags, $context) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "HTTP") {
- $self->{'Error'} = "OpenRequest() only on HTTP sessions.";
- return undef;
- }
-
- if(ref($path) and ref($path) eq "HASH") {
- $method = $path->{'method'};
- $version = $path->{'version'};
- $referer = $path->{'referer'};
- $accept = $path->{'accept'};
- $flags = $path->{'flags'};
- $context = $path->{'context'};
- my $mypath = $path->{'path'};
- undef $path;
- $path = $mypath;
- }
-
- $method = "GET" unless defined($method);
- $path = "/" unless defined($path);
- $version = "HTTP/1.0" unless defined($version);
- $referer = "" unless defined($referer);
- $accept = $self->{'accept'} unless defined($accept);
- $flags = 0 unless defined($flags);
- $context = 0 unless defined($context);
-
- $path = "/".$path if substr($path,0,1) ne "/";
- # accept string list needs to be terminated by double-NULL
- $accept .= "\0\0" unless $accept =~ /\0\0\z/;
-
- my $newhandle = HttpOpenRequest($self->{'handle'},
- $method,
- $path,
- $version,
- $referer,
- $accept,
- $flags,
- $context);
- if($newhandle) {
- $_[1] = _new($newhandle);
- $_[1]->{'Type'} = "HTTP_Request";
- $_[1]->{'method'} = $method;
- $_[1]->{'request'} = $path;
- $_[1]->{'accept'} = $accept;
- return $newhandle;
- } else {
- return undef;
- }
-}
-
-#================
-sub SendRequest {
-#================
- my($self, $postdata) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "HTTP_Request") {
- $self->{'Error'} = "SendRequest() only on HTTP requests.";
- return undef;
- }
-
- $postdata = "" unless defined($postdata);
-
- return HttpSendRequest($self->{'handle'}, "", $postdata);
-}
-
-
-#==============
-sub AddHeader {
-#==============
- my($self, $header, $flags) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "HTTP_Request") {
- $self->{'Error'} = "AddHeader() only on HTTP requests.";
- return undef;
- }
-
- $flags = constant("HTTP_ADDREQ_FLAG_ADD", 0) if (!defined($flags) or $flags == 0);
-
- return HttpAddRequestHeaders($self->{'handle'}, $header, $flags);
-}
-
-
-#==============
-sub QueryInfo {
-#==============
- my($self, $header, $flags) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "HTTP_Request") {
- $self->{'Error'}="QueryInfo() only on HTTP requests.";
- return undef;
- }
-
- $flags = constant("HTTP_QUERY_CUSTOM", 0) if (!defined($flags) and defined($header));
- my @queryresult = HttpQueryInfo($self->{'handle'}, $flags, $header);
- return (wantarray)? @queryresult : join(" ", @queryresult);
-}
-
-
-#============
-sub Request {
-#============
- # HttpOpenRequest+HttpAddHeaders+HttpSendRequest+InternetReadFile+HttpQueryInfo
- my($self, $path, $method, $version, $referer, $accept, $flags, $postdata) = @_;
- return undef unless ref($self);
-
- if($self->{'Type'} ne "HTTP") {
- $self->{'Error'} = "Request() only on HTTP sessions.";
- return undef;
- }
-
- if(ref($path) and ref($path) eq "HASH") {
- $method = $path->{'method'};
- $version = $path->{'version'};
- $referer = $path->{'referer'};
- $accept = $path->{'accept'};
- $flags = $path->{'flags'};
- $postdata = $path->{'postdata'};
- my $mypath = $path->{'path'};
- undef $path;
- $path = $mypath;
- }
-
- my $content = "";
- my $result = "";
- my @queryresult = ();
- my $statuscode = "";
- my $headers = "";
-
- $path = "/" unless defined($path);
- $method = "GET" unless defined($method);
- $version = "HTTP/1.0" unless defined($version);
- $referer = "" unless defined($referer);
- $accept = $self->{'accept'} unless defined($accept);
- $flags = 0 unless defined($flags);
- $postdata = "" unless defined($postdata);
-
- $path = "/".$path if substr($path,0,1) ne "/";
- # accept string list needs to be terminated by double-NULL
- $accept .= "\0\0" unless $accept =~ /\0\0\z/;
-
- my $newhandle = HttpOpenRequest($self->{'handle'},
- $method,
- $path,
- $version,
- $referer,
- $accept,
- $flags,
- 0);
-
- if($newhandle) {
-
- $result = HttpSendRequest($newhandle, "", $postdata);
-
- if(defined($result)) {
- $statuscode = HttpQueryInfo($newhandle,
- constant("HTTP_QUERY_STATUS_CODE", 0), "");
- $headers = HttpQueryInfo($newhandle,
- constant("HTTP_QUERY_RAW_HEADERS_CRLF", 0), "");
- $content = ReadEntireFile($newhandle);
-
- InternetCloseHandle($newhandle);
-
- return($statuscode, $headers, $content);
- } else {
- return undef;
- }
- } else {
- return undef;
- }
-}
-
-
-#######################################################################
-# END OF THE PUBLIC METHODS
-#
-
-
-#========= ### SUB-CLASSES CONSTRUCTOR
-sub _new {
-#=========
- my $self = {};
- if ($_[0]) {
- $self->{'handle'} = $_[0];
- bless $self;
- } else {
- undef($self);
- }
- $self;
-}
-
-
-#============ ### CLASS DESTRUCTOR
-sub DESTROY {
-#============
- my($self) = @_;
- # print "Closing handle $self->{'handle'}...\n";
- InternetCloseHandle($self->{'handle'});
- # [dada] rest in peace
-}
-
-
-#=============
-sub callback {
-#=============
- my($name, $status, $info) = @_;
- $callback_code{$name} = $status;
- $callback_info{$name} = $info;
-}
-
-#######################################################################
-# dynamically load in the Internet.pll module.
-#
-
-bootstrap Win32::Internet;
-
-# Preloaded methods go here.
-
-#Currently Autoloading is not implemented in Perl for win32
-# Autoload methods go after __END__, and are processed by the autosplit program.
-
-1;
-__END__
-
-=head1 NAME
-
-Win32::Internet - Access to WININET.DLL functions
-
-=head1 INTRODUCTION
-
-This extension to Perl implements the Win32 Internet APIs (found in
-F<WININET.DLL>). They give a complete support for HTTP, FTP and GOPHER
-connections.
-
-See the L<"Version History"> and the L<"Functions Table"> for a list
-of the currently supported features. You should also get a copy of the
-L<"Microsoft Win32 Internet Functions"> documentation.
-
-=head1 REFERENCE
-
-To use this module, first add the following line at the beginning of
-your script:
-
- use Win32::Internet;
-
-Then you have to open an Internet connection with this command:
-
- $Connection = new Win32::Internet();
-
-This is required to use any of the function of this module. It will
-create an Internet object in Perl on which you can act upon with the
-L<"General Internet Functions"> explained later.
-
-The objects available are:
-
-=over
-
-=item *
-
-Internet connections (the main object, see C<new>)
-
-=item *
-
-URLs (see C<OpenURL>)
-
-=item *
-
-FTP sessions (see C<FTP>)
-
-=item *
-
-HTTP sessions (see C<HTTP>)
-
-=item *
-
-HTTP requests (see C<OpenRequest>)
-
-=back
-
-As in the good Perl tradition, there are in this extension different
-ways to do the same thing; there are, in fact, different levels of
-implementation of the Win32 Internet Functions. Some routines use
-several Win32 API functions to perform a complex task in a single
-call; they are simpler to use, but of course less powerful.
-
-There are then other functions that implement nothing more and nothing
-less than the corresponding API function, so you can use all of their
-power, but with some additional programming steps.
-
-To make an example, there is a function called C<FetchURL> that you
-can use to fetch the content of any HTTP, FTP or GOPHER URL with this
-simple commands:
-
- $INET = new Win32::Internet();
- $file = $INET->FetchURL("http://www.yahoo.com");
-
-You can have the same result (and this is actually what is done by
-C<FetchURL>) this way:
-
- $INET = new Win32::Internet();
- $URL = $INET->OpenURL("http://www.yahoo.com");
- $file = $URL->ReadFile();
- $URL->Close();
-
-Or, you can open a complete HTTP session:
-
- $INET = new Win32::Internet();
- $HTTP = $INET->HTTP("www.yahoo.com", "anonymous", "dada@divinf.it");
- ($statuscode, $headers, $file) = $HTTP->Request("/");
- $HTTP->Close();
-
-Finally, you can choose to manage even the HTTP request:
-
- $INET = new Win32::Internet();
- $HTTP = $INET->HTTP("www.yahoo.com", "anonymous", "dada@divinf.it");
- $HTTP->OpenRequest($REQ, "/");
- $REQ->AddHeader("If-Modified-Since: Saturday, 16-Nov-96 15:58:50 GMT");
- $REQ->SendRequest();
- $statuscode = $REQ->QueryInfo("",HTTP_QUERY_STATUS_CODE);
- $lastmodified = $REQ->QueryInfo("Last-Modified");
- $file = $REQ->ReadEntireFile();
- $REQ->Close();
- $HTTP->Close();
-
-To open and control a complete FTP session, type:
-
- $Connection->FTP($Session, "ftp://ftp.activeware.com", "anonymous", "dada\@divinf.it");
-
-This will create an FTP object in Perl to which you can apply the L<"FTP
-functions"> provided by the package:
-
- $Session->Cd("/ntperl/perl5.001m/CurrentBuild");
- $Session->Ascii();
- $Session->Get("110-i86.zip");
- $Session->Close();
-
-For a more complete example, see the TEST.PL file that comes with the
-package.
-
-=head2 General Internet Functions
-
-B<General Note>
-
-All methods assume that you have the line:
-
- use Win32::Internet;
-
-somewhere before the method calls, and that you have an Internet
-object called $INET which was created using this call:
-
- $INET = new Win32::Internet();
-
-See C<new> for more information.
-
-B<Methods>
-
-=over
-
-=item CanonicalizeURL URL, [flags]
-
-Converts a URL to a canonical format, which includes converting unsafe
-characters to escape sequences. Returns the canonicalized URL or
-C<undef> on errors. For the possible values of I<flags>, refer to the
-L<"Microsoft Win32 Internet Functions"> document. See also
-C<CombineURL> and C<OpenURL>.
-
-Example:
-
- $cURL = $INET->CanonicalizeURL($URL);
- $URL = $INET->CanonicalizeURL($cURL, ICU_DECODE);
-
-=item Close
-
-=item Close object
-
-Closes an Internet connection. This can be applied to any
-Win32::Internet object (Internet connections, URLs, FTP sessions,
-etc.). Note that it is not "strictly" required to close the
-connections you create, since the Win32::Internet objects are
-automatically closed when the program ends (or when you elsehow
-destroy such an object).
-
-Example:
-
- $INET->Close();
- $FTP->Close();
- $INET->Close($FTP); # same as above...
-
-=item CombineURL baseURL, relativeURL, [flags]
-
-Combines a base and relative URL into a single URL. Returns the
-(canonicalized) combined URL or C<undef> on errors. For the possible
-values of I<flags>, refer to the L<"Microsoft Win32 Internet
-Functions"> document. See also C<CombineURL> and C<OpenURL>.
-
-Example:
-
- $URL = $INET->CombineURL("http://www.divinf.it/dada/perl/internet", "..");
-
-=item ConnectBackoff [value]
-
-Reads or sets the delay value, in milliseconds, to wait between
-connection retries. If no I<value> parameter is specified, the
-current value is returned; otherwise, the delay between retries is set
-to I<value>. See also C<ConnectTimeout>, C<ConnectRetries>,
-C<QueryOption> and C<SetOption>.
-
-Example:
-
- $HTTP->ConnectBackoff(2000);
- $backoff = $HTTP->ConnectBackoff();
-
-=item ConnectRetries [value]
-
-Reads or sets the number of times a connection is retried before
-considering it failed. If no I<value> parameter is specified, the
-current value is returned; otherwise, the number of retries is set to
-I<value>. The default value for C<ConnectRetries> is 5. See also
-C<ConnectBackoff>, C<ConnectTimeout>, C<QueryOption> and C<SetOption>.
-
-Example:
-
- $HTTP->ConnectRetries(20);
- $retries = $HTTP->ConnectRetries();
-
-=item ConnectTimeout [value]
-
-Reads or sets the timeout value (in milliseconds) before a connection
-is considered failed. If no I<value> parameter is specified, the
-current value is returned; otherwise, the timeout is set to I<value>.
-The default value for C<ConnectTimeout> is infinite. See also
-C<ConnectBackoff>, C<ConnectRetries>, C<QueryOption> and C<SetOption>.
-
-Example:
-
- $HTTP->ConnectTimeout(10000);
- $timeout = $HTTP->ConnectTimeout();
-
-=item ControlReceiveTimeout [value]
-
-Reads or sets the timeout value (in milliseconds) to use for non-data
-(control) receive requests before they are canceled. Currently, this
-value has meaning only for C<FTP> sessions. If no I<value> parameter
-is specified, the current value is returned; otherwise, the timeout is
-set to I<value>. The default value for C<ControlReceiveTimeout> is
-infinite. See also C<ControlSendTimeout>, C<QueryOption> and
-C<SetOption>.
-
-Example:
-
- $HTTP->ControlReceiveTimeout(10000);
- $timeout = $HTTP->ControlReceiveTimeout();
-
-=item ControlSendTimeout [value]
-
-Reads or sets the timeout value (in milliseconds) to use for non-data
-(control) send requests before they are canceled. Currently, this
-value has meaning only for C<FTP> sessions. If no I<value> parameter
-is specified, the current value is returned; otherwise, the timeout is
-set to I<value>. The default value for C<ControlSendTimeout> is
-infinite. See also C<ControlReceiveTimeout>, C<QueryOption> and
-C<SetOption>.
-
-Example:
-
- $HTTP->ControlSendTimeout(10000);
- $timeout = $HTTP->ControlSendTimeout();
-
-=item CrackURL URL, [flags]
-
-Splits an URL into its component parts and returns them in an array.
-Returns C<undef> on errors, otherwise the array will contain the
-following values: I<scheme, host, port, username, password, path,
-extrainfo>.
-
-For example, the URL "http://www.divinf.it/index.html#top" can be
-splitted in:
-
- http, www.divinf.it, 80, anonymous, dada@divinf.it, /index.html, #top
-
-If you don't specify a I<flags> parameter, ICU_ESCAPE will be used by
-default; for the possible values of I<flags> refer to the L<"Microsoft
-Win32 Internet Functions"> documentation. See also C<CreateURL>.
-
-Example:
-
- @parts=$INET->CrackURL("http://www.activeware.com");
- ($scheme, $host, $port, $user, $pass, $path, $extra) =
- $INET->CrackURL("http://www.divinf.it:80/perl-win32/index.sht#feedback");
-
-=item CreateURL scheme, hostname, port, username, password, path, extrainfo, [flags]
-
-=item CreateURL hashref, [flags]
-
-Creates a URL from its component parts. Returns C<undef> on errors,
-otherwise the created URL.
-
-If you pass I<hashref> (a reference to an hash array), the following
-values are taken from the array:
-
- %hash=(
- "scheme" => "scheme",
- "hostname" => "hostname",
- "port" => port,
- "username" => "username",
- "password" => "password",
- "path" => "path",
- "extrainfo" => "extrainfo",
- );
-
-If you don't specify a I<flags> parameter, ICU_ESCAPE will be used by
-default; for the other possible values of I<flags> refer to the
-L<"Microsoft Win32 Internet Functions"> documentation. See also
-C<CrackURL>.
-
-Example:
-
- $URL=$I->CreateURL("http", "www.divinf.it", 80, "", "", "/perl-win32/index.sht", "#feedback");
- $URL=$I->CreateURL(\%params);
-
-=item DataReceiveTimeout [value]
-
-Reads or sets the timeout value (in milliseconds) to use for data
-receive requests before they are canceled. If no I<value> parameter
-is specified, the current value is returned; otherwise, the timeout is
-set to I<value>. The default value for DataReceiveTimeout is
-infinite. See also C<DataSendTimeout>, C<QueryOption> and
-C<SetOption>.
-
-Example:
-
- $HTTP->DataReceiveTimeout(10000);
- $timeout = $HTTP->DataReceiveTimeout();
-
-=item DataSendTimeout [value]
-
-Reads or sets the timeout value (in milliseconds) to use for data send
-requests before they are canceled. If no I<value> parameter is
-specified, the current value is returned; otherwise, the timeout is
-set to I<value>. The default value for DataSendTimeout is infinite.
-See also C<DataReceiveTimeout>, C<QueryOption> and C<SetOption>.
-
-Example:
-
- $HTTP->DataSendTimeout(10000);
- $timeout = $HTTP->DataSendTimeout();
-
-=item Error
-
-Returns the last recorded error in the form of an array or string
-(depending upon the context) containing the error number and an error
-description. Can be applied on any Win32::Internet object (FTP
-sessions, etc.). There are 3 types of error you can encounter; they
-are recognizable by the error number returned:
-
-=over
-
-=item * -1
-
-A "trivial" error has occurred in the package. For example, you tried
-to use a method on the wrong type of object.
-
-=item * 1 .. 11999
-
-A generic error has occurred and the Win32::GetLastError error message
-is returned.
-
-=item * 12000 and higher
-
-An Internet error has occurred; the extended Win32 Internet API error
-message is returned.
-
-=back
-
-See also C<GetResponse>.
-
-Example:
-
- die $INET->Error(), qq(\n);
- ($ErrNum, $ErrText) = $INET->Error();
-
-=item FetchURL URL
-
-Fetch the content of an HTTP, FTP or GOPHER URL. Returns the content
-of the file read (or C<undef> if there was an error and nothing was
-read). See also C<OpenURL> and C<ReadFile>.
-
-Example:
-
- $file = $INET->FetchURL("http://www.yahoo.com/");
- $file = $INET->FetchURL("ftp://www.activeware.com/contrib/internet.zip");
-
-=item FTP ftpobject, server, username, password, [port, pasv, context]
-
-=item FTP ftpobject, hashref
-
-Opens an FTP connection to server logging in with the given
-I<username> and I<password>.
-
-The parameters and their values are:
-
-=over
-
-=item * server
-
-The server to connect to. Default: I<none>.
-
-=item * username
-
-The username used to login to the server. Default: anonymous.
-
-=item * password
-
-The password used to login to the server. Default: I<none>.
-
-=item * port
-
-The port of the FTP service on the server. Default: 21.
-
-=item * pasv
-
-If it is a value other than 0, use passive transfer mode. Default is
-taken from the parent Internet connection object; you can set this
-value with the C<Pasv> method.
-
-=item * context
-
-A number to identify this operation if it is asynchronous. See
-C<SetStatusCallback> and C<GetStatusCallback> for more info on
-asynchronous operations. Default: I<none>.
-
-=back
-
-If you pass I<hashref> (a reference to an hash array), the following
-values are taken from the array:
-
- %hash=(
- "server" => "server",
- "username" => "username",
- "password" => "password",
- "port" => port,
- "pasv" => pasv,
- "context" => context,
- );
-
-This method returns C<undef> if the connection failed, a number
-otherwise. You can then call any of the L<"FTP functions"> as methods
-of the newly created I<ftpobject>.
-
-Example:
-
- $result = $INET->FTP($FTP, "ftp.activeware.com", "anonymous", "dada\@divinf.it");
- # and then for example...
- $FTP->Cd("/ntperl/perl5.001m/CurrentBuild");
-
- $params{"server"} = "ftp.activeware.com";
- $params{"password"} = "dada\@divinf.it";
- $params{"pasv"} = 0;
- $result = $INET->FTP($FTP,\%params);
-
-=item GetResponse
-
-Returns the text sent by a remote server in response to the last
-function executed. It applies on any Win32::Internet object,
-particularly of course on L<FTP sessions|"FTP functions">. See also
-the C<Error> function.
-
-Example:
-
- print $INET->GetResponse();
- $INET->FTP($FTP, "ftp.activeware.com", "anonymous", "dada\@divinf.it");
- print $FTP->GetResponse();
-
-=item GetStatusCallback context
-
-Returns information about the progress of the asynchronous operation
-identified by I<context>; those informations consist of two values: a
-status code (one of the INTERNET_STATUS_* L<"Constants">) and an
-additional value depending on the status code; for example, if the
-status code returned is INTERNET_STATUS_HANDLE_CREATED, the second
-value will hold the handle just created. For more informations on
-those values, please refer to the L<"Microsoft Win32 Internet
-Functions"> documentation. See also C<SetStatusCallback>.
-
-Example:
-
- ($status, $info) = $INET->GetStatusCallback(1);
-
-=item HTTP httpobject, server, username, password, [port, flags, context]
-
-=item HTTP httpobject, hashref
-
-Opens an HTTP connection to I<server> logging in with the given
-I<username> and I<password>.
-
-The parameters and their values are:
-
-=over
-
-=item * server
-
-The server to connect to. Default: I<none>.
-
-=item * username
-
-The username used to login to the server. Default: anonymous.
-
-=item * password
-
-The password used to login to the server. Default: I<none>.
-
-=item * port
-
-The port of the HTTP service on the server. Default: 80.
-
-=item * flags
-
-Additional flags affecting the behavior of the function. Default:
-I<none>.
-
-=item * context
-
-A number to identify this operation if it is asynchronous. See
-C<SetStatusCallback> and C<GetStatusCallback> for more info on
-asynchronous operations. Default: I<none>.
-
-=back
-
-Refer to the L<"Microsoft Win32 Internet Functions"> documentation for
-more details on those parameters.
-
-If you pass I<hashref> (a reference to an hash array), the following
-values are taken from the array:
-
- %hash=(
- "server" => "server",
- "username" => "username",
- "password" => "password",
- "port" => port,
- "flags" => flags,
- "context" => context,
- );
-
-This method returns C<undef> if the connection failed, a number
-otherwise. You can then call any of the L<"HTTP functions"> as
-methods of the newly created I<httpobject>.
-
-Example:
-
- $result = $INET->HTTP($HTTP,"www.activeware.com","anonymous","dada\@divinf.it");
- # and then for example...
- ($statuscode, $headers, $file) = $HTTP->Request("/gifs/camel.gif");
-
- $params{"server"} = "www.activeware.com";
- $params{"password"} = "dada\@divinf.it";
- $params{"flags"} = INTERNET_FLAG_RELOAD;
- $result = $INET->HTTP($HTTP,\%params);
-
-=item new Win32::Internet [useragent, opentype, proxy, proxybypass, flags]
-
-=item new Win32::Internet [hashref]
-
-Creates a new Internet object and initializes the use of the Internet
-functions; this is required before any of the functions of this
-package can be used. Returns C<undef> if the connection fails, a number
-otherwise. The parameters and their values are:
-
-=over
-
-=item * useragent
-
-The user agent passed to HTTP requests. See C<OpenRequest>. Default:
-Perl-Win32::Internet/I<version>.
-
-=item * opentype
-
-How to access to the Internet (eg. directly or using a proxy).
-Default: INTERNET_OPEN_TYPE_DIRECT.
-
-=item * proxy
-
-Name of the proxy server (or servers) to use. Default: I<none>.
-
-=item * proxybypass
-
-Optional list of host names or IP addresses, or both, that are known
-locally. Default: I<none>.
-
-=item * flags
-
-Additional flags affecting the behavior of the function. Default:
-I<none>.
-
-=back
-
-Refer to the L<"Microsoft Win32 Internet Functions"> documentation for
-more details on those parameters. If you pass I<hashref> (a reference to
-an hash array), the following values are taken from the array:
-
- %hash=(
- "useragent" => "useragent",
- "opentype" => "opentype",
- "proxy" => "proxy",
- "proxybypass" => "proxybypass",
- "flags" => flags,
- );
-
-Example:
-
- $INET = new Win32::Internet();
- die qq(Cannot connect to Internet...\n) if ! $INET;
-
- $INET = new Win32::Internet("Mozilla/3.0", INTERNET_OPEN_TYPE_PROXY, "www.microsoft.com", "");
-
- $params{"flags"} = INTERNET_FLAG_ASYNC;
- $INET = new Win32::Internet(\%params);
-
-=item OpenURL urlobject, URL
-
-Opens a connection to an HTTP, FTP or GOPHER Uniform Resource Location
-(URL). Returns C<undef> on errors or a number if the connection was
-succesful. You can then retrieve the URL content by applying the
-methods C<QueryDataAvailable> and C<ReadFile> on the newly created
-I<urlobject>. See also C<FetchURL>.
-
-Example:
-
- $INET->OpenURL($URL, "http://www.yahoo.com/");
- $bytes = $URL->QueryDataAvailable();
- $file = $URL->ReadEntireFile();
- $URL->Close();
-
-=item Password [password]
-
-Reads or sets the password used for an C<FTP> or C<HTTP> connection.
-If no I<password> parameter is specified, the current value is
-returned; otherwise, the password is set to I<password>. See also
-C<Username>, C<QueryOption> and C<SetOption>.
-
-Example:
-
- $HTTP->Password("splurfgnagbxam");
- $password = $HTTP->Password();
-
-=item QueryDataAvailable
-
-Returns the number of bytes of data that are available to be read
-immediately by a subsequent call to C<ReadFile> (or C<undef> on
-errors). Can be applied to URL or HTTP request objects. See
-C<OpenURL> or C<OpenRequest>.
-
-Example:
-
- $INET->OpenURL($URL, "http://www.yahoo.com/");
- $bytes = $URL->QueryDataAvailable();
-
-=item QueryOption option
-
-Queries an Internet option. For the possible values of I<option>,
-refer to the L<"Microsoft Win32 Internet Functions"> document. See
-also C<SetOption>.
-
-Example:
-
- $value = $INET->QueryOption(INTERNET_OPTION_CONNECT_TIMEOUT);
- $value = $HTTP->QueryOption(INTERNET_OPTION_USERNAME);
-
-=item ReadEntireFile
-
-Reads all the data available from an opened URL or HTTP request
-object. Returns what have been read or C<undef> on errors. See also
-C<OpenURL>, C<OpenRequest> and C<ReadFile>.
-
-Example:
-
- $INET->OpenURL($URL, "http://www.yahoo.com/");
- $file = $URL->ReadEntireFile();
-
-=item ReadFile bytes
-
-Reads I<bytes> bytes of data from an opened URL or HTTP request
-object. Returns what have been read or C<undef> on errors. See also
-C<OpenURL>, C<OpenRequest>, C<QueryDataAvailable> and
-C<ReadEntireFile>.
-
-B<Note:> be careful to keep I<bytes> to an acceptable value (eg. don't
-tell him to swallow megabytes at once...). C<ReadEntireFile> in fact
-uses C<QueryDataAvailable> and C<ReadFile> in a loop to read no more
-than 16k at a time.
-
-Example:
-
- $INET->OpenURL($URL, "http://www.yahoo.com/");
- $chunk = $URL->ReadFile(16000);
-
-=item SetOption option, value
-
-Sets an Internet option. For the possible values of I<option>, refer to
-the L<"Microsoft Win32 Internet Functions"> document. See also
-C<QueryOption>.
-
-Example:
-
- $INET->SetOption(INTERNET_OPTION_CONNECT_TIMEOUT,10000);
- $HTTP->SetOption(INTERNET_OPTION_USERNAME,"dada");
-
-=item SetStatusCallback
-
-Initializes the callback routine used to return data about the
-progress of an asynchronous operation.
-
-Example:
-
- $INET->SetStatusCallback();
-
-This is one of the step required to perform asynchronous operations;
-the complete procedure is:
-
- # use the INTERNET_FLAG_ASYNC when initializing
- $params{'flags'}=INTERNET_FLAG_ASYNC;
- $INET = new Win32::Internet(\%params);
-
- # initialize the callback routine
- $INET->SetStatusCallback();
-
- # specify the context parameter (the last 1 in this case)
- $INET->HTTP($HTTP, "www.yahoo.com", "anonymous", "dada\@divinf.it", 80, 0, 1);
-
-At this point, control returns immediately to Perl and $INET->Error()
-will return 997, which means an asynchronous I/O operation is
-pending. Now, you can call
-
- $HTTP->GetStatusCallback(1);
-
-in a loop to verify what's happening; see also C<GetStatusCallback>.
-
-=item TimeConvert time
-
-=item TimeConvert seconds, minute, hours, day, month, year,
- day_of_week, RFC
-
-The first form takes a HTTP date/time string and returns the date/time
-converted in the following array: I<seconds, minute, hours, day,
-month, year, day_of_week>.
-
-The second form does the opposite (or at least it should, because
-actually seems to be malfunctioning): it takes the values and returns
-an HTTP date/time string, in the RFC format specified by the I<RFC>
-parameter (OK, I didn't find yet any accepted value in the range
-0..2000, let me know if you have more luck with it).
-
-Example:
-
- ($sec, $min, $hour, $day, $mday, $year, $wday) =
- $INET->TimeConvert("Sun, 26 Jan 1997 20:01:52 GMT");
-
- # the opposite DOESN'T WORK! which value should $RFC have???
- $time = $INET->TimeConvert(52, 1, 20, 26, 1, 1997, 0, $RFC);
-
-=item UserAgent [name]
-
-Reads or sets the user agent used for HTTP requests. If no I<name>
-parameter is specified, the current value is returned; otherwise, the
-user agent is set to I<name>. See also C<QueryOption> and
-C<SetOption>.
-
-Example:
-
- $INET->UserAgent("Mozilla/3.0");
- $useragent = $INET->UserAgent();
-
-=item Username [name]
-
-Reads or sets the username used for an C<FTP> or C<HTTP> connection.
-If no I<name> parameter is specified, the current value is returned;
-otherwise, the username is set to I<name>. See also C<Password>,
-C<QueryOption> and SetOption.
-
-Example:
-
- $HTTP->Username("dada");
- $username = $HTTP->Username();
-
-=item Version
-
-Returns the version numbers for the Win32::Internet package and the
-WININET.DLL version, as an array or string, depending on the context.
-The string returned will contain "package_version/DLL_version", while
-the array will contain: "package_version", "DLL_version".
-
-Example:
-
- $version = $INET->Version(); # should return "0.06/4.70.1215"
- @version = $INET->Version(); # should return ("0.06", "4.70.1215")
-
-=back
-
-
-=head2 FTP Functions
-
-B<General Note>
-
-All methods assume that you have the following lines:
-
- use Win32::Internet;
- $INET = new Win32::Internet();
- $INET->FTP($FTP, "hostname", "username", "password");
-
-somewhere before the method calls; in other words, we assume that you
-have an Internet object called $INET and an open FTP session called
-$FTP.
-
-See C<new> and C<FTP> for more information.
-
-
-B<Methods>
-
-=over
-
-=item Ascii
-
-=item Asc
-
-Sets the ASCII transfer mode for this FTP session. It will be applied
-to the subsequent C<Get> functions. See also the C<Binary> and
-C<Mode> function.
-
-Example:
-
- $FTP->Ascii();
-
-=item Binary
-
-=item Bin
-
-Sets the binary transfer mode for this FTP session. It will be
-applied to the subsequent C<Get> functions. See also the C<Ascii> and
-C<Mode> function.
-
-Example:
-
- $FTP->Binary();
-
-=item Cd path
-
-=item Cwd path
-
-=item Chdir path
-
-Changes the current directory on the FTP remote host. Returns I<path>
-or C<undef> on error.
-
-Example:
-
- $FTP->Cd("/pub");
-
-=item Delete file
-
-=item Del file
-
-Deletes a file on the FTP remote host. Returns C<undef> on error.
-
-Example:
-
- $FTP->Delete("110-i86.zip");
-
-=item Get remote, [local, overwrite, flags, context]
-
-Gets the I<remote> FTP file and saves it locally in I<local>. If
-I<local> is not specified, it will be the same name as I<remote>.
-Returns C<undef> on error. The parameters and their values are:
-
-=over
-
-=item * remote
-
-The name of the remote file on the FTP server. Default: I<none>.
-
-=item * local
-
-The name of the local file to create. Default: remote.
-
-=item * overwrite
-
-If 0, overwrites I<local> if it exists; with any other value, the
-function fails if the I<local> file already exists. Default: 0.
-
-=item * flags
-
-Additional flags affecting the behavior of the function. Default:
-I<none>.
-
-=item * context
-
-A number to identify this operation if it is asynchronous. See
-C<SetStatusCallback> and C<GetStatusCallback> for more info on
-asynchronous operations. Default: I<none>.
-
-=back
-
-Refer to the L<"Microsoft Win32 Internet Functions"> documentation for
-more details on those parameters.
-
-Example:
-
- $FTP->Get("110-i86.zip");
- $FTP->Get("/pub/perl/languages/CPAN/00index.html", "CPAN_index.html");
-
-=item List [pattern, listmode]
-
-=item Ls [pattern, listmode]
-
-=item Dir [pattern, listmode]
-
-Returns a list containing the files found in this directory,
-eventually matching the given I<pattern> (which, if omitted, is
-considered "*.*"). The content of the returned list depends on the
-I<listmode> parameter, which can have the following values:
-
-=over
-
-=item * listmode=1 (or omitted)
-
-the list contains the names of the files found. Example:
-
- @files = $FTP->List();
- @textfiles = $FTP->List("*.txt");
- foreach $file (@textfiles) {
- print "Name: ", $file, "\n";
- }
-
-=item * listmode=2
-
-the list contains 7 values for each file, which respectively are:
-
-=over
-
-=item * the file name
-
-=item * the DOS short file name, aka 8.3
-
-=item * the size
-
-=item * the attributes
-
-=item * the creation time
-
-=item * the last access time
-
-=item * the last modified time
-
-=back
-
-Example:
-
- @files = $FTP->List("*.*", 2);
- for($i=0; $i<=$#files; $i+=7) {
- print "Name: ", @files[$i], "\n";
- print "Size: ", @files[$i+2], "\n";
- print "Attr: ", @files[$i+3], "\n";
- }
-
-=item * listmode=3
-
-the list contains a reference to an hash array for each found file;
-each hash contains:
-
-=over
-
-=item * name => the file name
-
-=item * altname => the DOS short file name, aka 8.3
-
-=item * size => the size
-
-=item * attr => the attributes
-
-=item * ctime => the creation time
-
-=item * atime => the last access time
-
-=item * mtime => the last modified time
-
-=back
-
-Example:
-
- @files = $FTP->List("*.*", 3);
- foreach $file (@files) {
- print $file->{'name'}, " ", $file->{'size'}, " ", $file->{'attr'}, "\n";
- }
-
-B<Note:> all times are reported as strings of the following format:
-I<second, hour, minute, day, month, year>.
-
-Example:
-
- $file->{'mtime'} == "0,10,58,9,12,1996" stands for 09 Dec 1996 at 10:58:00
-
-=back
-
-=item Mkdir name
-
-=item Md name
-
-Creates a directory on the FTP remote host. Returns C<undef> on error.
-
-Example:
-
- $FTP->Mkdir("NextBuild");
-
-=item Mode [mode]
-
-If called with no arguments, returns the current transfer mode for
-this FTP session ("asc" for ASCII or "bin" for binary). The I<mode>
-argument can be "asc" or "bin", in which case the appropriate transfer
-mode is selected. See also the Ascii and Binary functions. Returns
-C<undef> on errors.
-
-Example:
-
- print "Current mode is: ", $FTP->Mode();
- $FTP->Mode("asc"); # ... same as $FTP->Ascii();
-
-=item Pasv [mode]
-
-If called with no arguments, returns 1 if the current FTP session has
-passive transfer mode enabled, 0 if not.
-
-You can call it with a I<mode> parameter (0/1) only as a method of a
-Internet object (see C<new>), in which case it will set the default
-value for the next C<FTP> objects you create (read: set it before,
-because you can't change this value once you opened the FTP session).
-
-Example:
-
- print "Pasv is: ", $FTP->Pasv();
-
- $INET->Pasv(1);
- $INET->FTP($FTP,"ftp.activeware.com", "anonymous", "dada\@divinf.it");
- $FTP->Pasv(0); # this will be ignored...
-
-=item Put local, [remote, context]
-
-Upload the I<local> file to the FTP server saving it under the name
-I<remote>, which if if omitted is the same name as I<local>. Returns
-C<undef> on error.
-
-I<context> is a number to identify this operation if it is asynchronous.
-See C<SetStatusCallback> and C<GetStatusCallback> for more info on
-asynchronous operations.
-
-Example:
-
- $FTP->Put("internet.zip");
- $FTP->Put("d:/users/dada/temp.zip", "/temp/dada.zip");
-
-=item Pwd
-
-Returns the current directory on the FTP server or C<undef> on errors.
-
-Example:
-
- $path = $FTP->Pwd();
-
-=item Rename oldfile, newfile
-
-=item Ren oldfile, newfile
-
-Renames a file on the FTP remote host. Returns C<undef> on error.
-
-Example:
-
- $FTP->Rename("110-i86.zip", "68i-011.zip");
-
-=item Rmdir name
-
-=item Rd name
-
-Removes a directory on the FTP remote host. Returns C<undef> on error.
-
-Example:
-
- $FTP->Rmdir("CurrentBuild");
-
-=back
-
-=head2 HTTP Functions
-
-B<General Note>
-
-All methods assume that you have the following lines:
-
- use Win32::Internet;
- $INET = new Win32::Internet();
- $INET->HTTP($HTTP, "hostname", "username", "password");
-
-somewhere before the method calls; in other words, we assume that you
-have an Internet object called $INET and an open HTTP session called
-$HTTP.
-
-See C<new> and C<HTTP> for more information.
-
-
-B<Methods>
-
-=over
-
-=item AddHeader header, [flags]
-
-Adds HTTP request headers to an HTTP request object created with
-C<OpenRequest>. For the possible values of I<flags> refer to the
-L<"Microsoft Win32 Internet Functions"> document.
-
-Example:
-
- $HTTP->OpenRequest($REQUEST,"/index.html");
- $REQUEST->AddHeader("If-Modified-Since: Sunday, 17-Nov-96 11:40:03 GMT");
- $REQUEST->AddHeader("Accept: text/html\r\n", HTTP_ADDREQ_FLAG_REPLACE);
-
-=item OpenRequest requestobject, [path, method, version, referer, accept, flags, context]
-
-=item OpenRequest requestobject, hashref
-
-Opens an HTTP request. Returns C<undef> on errors or a number if the
-connection was succesful. You can then use one of the C<AddHeader>,
-C<SendRequest>, C<QueryInfo>, C<QueryDataAvailable> and C<ReadFile>
-methods on the newly created I<requestobject>. The parameters and
-their values are:
-
-=over
-
-=item * path
-
-The object to request. This is generally a file name, an executable
-module, etc. Default: /
-
-=item * method
-
-The method to use; can actually be GET, POST, HEAD or PUT. Default:
-GET
-
-=item * version
-
-The HTTP version. Default: HTTP/1.0
-
-=item * referer
-
-The URL of the document from which the URL in the request was
-obtained. Default: I<none>
-
-=item * accept
-
-A single string with "\0" (ASCII zero) delimited list of content
-types accepted. The string must be terminated by "\0\0".
-Default: "text/*\0image/gif\0image/jpeg\0\0"
-
-=item * flags
-
-Additional flags affecting the behavior of the function. Default:
-I<none>
-
-=item * context
-
-A number to identify this operation if it is asynchronous. See
-C<SetStatusCallback> and C<GetStatusCallback> for more info on
-asynchronous operations. Default: I<none>
-
-=back
-
-Refer to the L<"Microsoft Win32 Internet Functions"> documentation for
-more details on those parameters. If you pass I<hashref> (a reference to
-an hash array), the following values are taken from the array:
-
- %hash=(
- "path" => "path",
- "method" => "method",
- "version" => "version",
- "referer" => "referer",
- "accept" => "accept",
- "flags" => flags,
- "context" => context,
- );
-
-See also C<Request>.
-
-Example:
-
- $HTTP->OpenRequest($REQUEST, "/index.html");
- $HTTP->OpenRequest($REQUEST, "/index.html", "GET", "HTTP/0.9");
-
- $params{"path"} = "/index.html";
- $params{"flags"} = "
- $HTTP->OpenRequest($REQUEST, \%params);
-
-=item QueryInfo header, [flags]
-
-Queries information about an HTTP request object created with
-C<OpenRequest>. You can specify an I<header> (for example,
-"Content-type") and/or one or more I<flags>. If you don't specify
-I<flags>, HTTP_QUERY_CUSTOM will be used by default; this means that
-I<header> should contain a valid HTTP header name. For the possible
-values of I<flags> refer to the L<"Microsoft Win32 Internet
-Functions"> document.
-
-Example:
-
- $HTTP->OpenRequest($REQUEST,"/index.html");
- $statuscode = $REQUEST->QueryInfo("", HTTP_QUERY_STATUS_CODE);
- $headers = $REQUEST->QueryInfo("", HTTP_QUERY_RAW_HEADERS_CRLF); # will get all the headers
- $length = $REQUEST->QueryInfo("Content-length");
-
-=item Request [path, method, version, referer, accept, flags]
-
-=item Request hashref
-
-Performs an HTTP request and returns an array containing the status
-code, the headers and the content of the file. It is a one-step
-procedure that makes an C<OpenRequest>, a C<SendRequest>, some
-C<QueryInfo>, C<ReadFile> and finally C<Close>. For a description of
-the parameters, see C<OpenRequest>.
-
-Example:
-
- ($statuscode, $headers, $file) = $HTTP->Request("/index.html");
- ($s, $h, $f) = $HTTP->Request("/index.html", "GET", "HTTP/1.0");
-
-=item SendRequest [postdata]
-
-Send an HTTP request to the destination server. I<postdata> are any
-optional data to send immediately after the request header; this is
-generally used for POST or PUT requests. See also C<OpenRequest>.
-
-Example:
-
- $HTTP->OpenRequest($REQUEST, "/index.html");
- $REQUEST->SendRequest();
-
- # A POST request...
- $HTTP->OpenRequest($REQUEST, "/cgi-bin/somescript.pl", "POST");
-
- #This line is a must -> (thanks Philip :)
- $REQUEST->AddHeader("Content-Type: application/x-www-form-urlencoded");
-
- $REQUEST->SendRequest("key1=value1&key2=value2&key3=value3");
-
-=back
-
-
-=head1 APPENDIX
-
-
-=head2 Microsoft Win32 Internet Functions
-
-Complete documentation for the Microsoft Win32 Internet Functions can
-be found, in both HTML and zipped Word format, at this address:
-
- http://www.microsoft.com/intdev/sdk/docs/wininet/
-
-=head2 Functions Table
-
-This table reports the correspondence between the functions offered by
-WININET.DLL and their implementation in the Win32::Internet
-extension. Functions showing a "---" are not currently
-implemented. Functions enclosed in parens ( ) aren't implemented
-straightforwardly, but in a higher-level routine, eg. together with
-other functions.
-
- WININET.DLL Win32::Internet
-
- InternetOpen new Win32::Internet
- InternetConnect FTP / HTTP
- InternetCloseHandle Close
- InternetQueryOption QueryOption
- InternetSetOption SetOption
- InternetSetOptionEx ---
- InternetSetStatusCallback SetStatusCallback
- InternetStatusCallback GetStatusCallback
- InternetConfirmZoneCrossing ---
- InternetTimeFromSystemTime TimeConvert
- InternetTimeToSystemTime TimeConvert
- InternetAttemptConnect ---
- InternetReadFile ReadFile
- InternetSetFilePointer ---
- InternetFindNextFile (List)
- InternetQueryDataAvailable QueryDataAvailable
- InternetGetLastResponseInfo GetResponse
- InternetWriteFile ---
- InternetCrackUrl CrackURL
- InternetCreateUrl CreateURL
- InternetCanonicalizeUrl CanonicalizeURL
- InternetCombineUrl CombineURL
- InternetOpenUrl OpenURL
- FtpFindFirstFile (List)
- FtpGetFile Get
- FtpPutFile Put
- FtpDeleteFile Delete
- FtpRenameFile Rename
- FtpOpenFile ---
- FtpCreateDirectory Mkdir
- FtpRemoveDirectory Rmdir
- FtpSetCurrentDirectory Cd
- FtpGetCurrentDirectory Pwd
- HttpOpenRequest OpenRequest
- HttpAddRequestHeaders AddHeader
- HttpSendRequest SendRequest
- HttpQueryInfo QueryInfo
- InternetErrorDlg ---
-
-
-Actually, I don't plan to add support for Gopher, Cookie and Cache
-functions. I will if there will be consistent requests to do so.
-
-There are a number of higher-level functions in the Win32::Internet
-that simplify some usual procedures, calling more that one WININET API
-function. This table reports those functions and the relative WININET
-functions they use.
-
- Win32::Internet WININET.DLL
-
- FetchURL InternetOpenUrl
- InternetQueryDataAvailable
- InternetReadFile
- InternetCloseHandle
-
- ReadEntireFile InternetQueryDataAvailable
- InternetReadFile
-
- Request HttpOpenRequest
- HttpSendRequest
- HttpQueryInfo
- InternetQueryDataAvailable
- InternetReadFile
- InternetCloseHandle
-
- List FtpFindFirstFile
- InternetFindNextFile
-
-
-=head2 Constants
-
-Those are the constants exported by the package in the main namespace
-(eg. you can use them in your scripts); for their meaning and proper
-use, refer to the Microsoft Win32 Internet Functions document.
-
- HTTP_ADDREQ_FLAG_ADD
- HTTP_ADDREQ_FLAG_REPLACE
- HTTP_QUERY_ALLOW
- HTTP_QUERY_CONTENT_DESCRIPTION
- HTTP_QUERY_CONTENT_ID
- HTTP_QUERY_CONTENT_LENGTH
- HTTP_QUERY_CONTENT_TRANSFER_ENCODING
- HTTP_QUERY_CONTENT_TYPE
- HTTP_QUERY_COST
- HTTP_QUERY_CUSTOM
- HTTP_QUERY_DATE
- HTTP_QUERY_DERIVED_FROM
- HTTP_QUERY_EXPIRES
- HTTP_QUERY_FLAG_REQUEST_HEADERS
- HTTP_QUERY_FLAG_SYSTEMTIME
- HTTP_QUERY_LANGUAGE
- HTTP_QUERY_LAST_MODIFIED
- HTTP_QUERY_MESSAGE_ID
- HTTP_QUERY_MIME_VERSION
- HTTP_QUERY_PRAGMA
- HTTP_QUERY_PUBLIC
- HTTP_QUERY_RAW_HEADERS
- HTTP_QUERY_RAW_HEADERS_CRLF
- HTTP_QUERY_REQUEST_METHOD
- HTTP_QUERY_SERVER
- HTTP_QUERY_STATUS_CODE
- HTTP_QUERY_STATUS_TEXT
- HTTP_QUERY_URI
- HTTP_QUERY_USER_AGENT
- HTTP_QUERY_VERSION
- HTTP_QUERY_WWW_LINK
- ICU_BROWSER_MODE
- ICU_DECODE
- ICU_ENCODE_SPACES_ONLY
- ICU_ESCAPE
- ICU_NO_ENCODE
- ICU_NO_META
- ICU_USERNAME
- INTERNET_FLAG_PASSIVE
- INTERNET_FLAG_ASYNC
- INTERNET_FLAG_HYPERLINK
- INTERNET_FLAG_KEEP_CONNECTION
- INTERNET_FLAG_MAKE_PERSISTENT
- INTERNET_FLAG_NO_AUTH
- INTERNET_FLAG_NO_AUTO_REDIRECT
- INTERNET_FLAG_NO_CACHE_WRITE
- INTERNET_FLAG_NO_COOKIES
- INTERNET_FLAG_READ_PREFETCH
- INTERNET_FLAG_RELOAD
- INTERNET_FLAG_RESYNCHRONIZE
- INTERNET_FLAG_TRANSFER_ASCII
- INTERNET_FLAG_TRANSFER_BINARY
- INTERNET_INVALID_PORT_NUMBER
- INTERNET_INVALID_STATUS_CALLBACK
- INTERNET_OPEN_TYPE_DIRECT
- INTERNET_OPEN_TYPE_PROXY
- INTERNET_OPEN_TYPE_PROXY_PRECONFIG
- INTERNET_OPTION_CONNECT_BACKOFF
- INTERNET_OPTION_CONNECT_RETRIES
- INTERNET_OPTION_CONNECT_TIMEOUT
- INTERNET_OPTION_CONTROL_SEND_TIMEOUT
- INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT
- INTERNET_OPTION_DATA_SEND_TIMEOUT
- INTERNET_OPTION_DATA_RECEIVE_TIMEOUT
- INTERNET_OPTION_HANDLE_TYPE
- INTERNET_OPTION_LISTEN_TIMEOUT
- INTERNET_OPTION_PASSWORD
- INTERNET_OPTION_READ_BUFFER_SIZE
- INTERNET_OPTION_USER_AGENT
- INTERNET_OPTION_USERNAME
- INTERNET_OPTION_VERSION
- INTERNET_OPTION_WRITE_BUFFER_SIZE
- INTERNET_SERVICE_FTP
- INTERNET_SERVICE_GOPHER
- INTERNET_SERVICE_HTTP
- INTERNET_STATUS_CLOSING_CONNECTION
- INTERNET_STATUS_CONNECTED_TO_SERVER
- INTERNET_STATUS_CONNECTING_TO_SERVER
- INTERNET_STATUS_CONNECTION_CLOSED
- INTERNET_STATUS_HANDLE_CLOSING
- INTERNET_STATUS_HANDLE_CREATED
- INTERNET_STATUS_NAME_RESOLVED
- INTERNET_STATUS_RECEIVING_RESPONSE
- INTERNET_STATUS_REDIRECT
- INTERNET_STATUS_REQUEST_COMPLETE
- INTERNET_STATUS_REQUEST_SENT
- INTERNET_STATUS_RESOLVING_NAME
- INTERNET_STATUS_RESPONSE_RECEIVED
- INTERNET_STATUS_SENDING_REQUEST
-
-
-=head1 VERSION HISTORY
-
-=over
-
-=item * 0.082 (4 Sep 2001)
-
-=over
-
-=item *
-
-Fix passive FTP mode. INTERNET_FLAG_PASSIVE was misspelled in earlier
-versions (as INTERNET_CONNECT_FLAG_PASSIVE) and wouldn't work. Found
-by Steve Raynesford <stever@evolvecomm.com>.
-
-=back
-
-=item * 0.081 (25 Sep 1999)
-
-=over
-
-=item *
-
-Documentation converted to pod format by Jan Dubois <JanD@ActiveState.com>.
-
-=item *
-
-Minor changes from Perl 5.005xx compatibility.
-
-=back
-
-=item * 0.08 (14 Feb 1997)
-
-=over
-
-=item *
-
-fixed 2 more bugs in Option(s) related subs (thanks to Brian
-Helterline!).
-
-=item *
-
-Error() now gets error messages directly from WININET.DLL.
-
-=item *
-
-The PLL file now comes in 2 versions, one for Perl version 5.001
-(build 100) and one for Perl version 5.003 (build 300 and
-higher). Everybody should be happy now :)
-
-=item *
-
-added an installation program.
-
-=back
-
-=item * 0.07 (10 Feb 1997)
-
-=over
-
-=item *
-
-fixed a bug in Version() introduced with 0.06...
-
-=item *
-
-completely reworked PM file, fixed *lots* of minor bugs, and removed
-almost all the warnings with "perl -w".
-
-=back
-
-=item * 0.06 (26 Jan 1997)
-
-=over
-
-=item *
-
-fixed another hideous bug in "new" (the 'class' parameter was still
-missing).
-
-=item *
-
-added support for asynchronous operations (work still in embryo).
-
-=item *
-
-removed the ending \0 (ASCII zero) from the DLL version returned by
-"Version".
-
-=item *
-
-added a lot of constants.
-
-=item *
-
-added safefree() after every safemalloc() in C... wonder why I didn't
-it before :)
-
-=item *
-
-added TimeConvert, which actually works one way only.
-
-=back
-
-=item * 0.05f (29 Nov 1996)
-
-=over
-
-=item *
-
-fixed a bug in "new" (parameters passed were simply ignored).
-
-=item *
-
-fixed another bug: "Chdir" and "Cwd" were aliases of RMDIR instead of
-CD..
-
-=back
-
-=item * 0.05 (29 Nov 1996)
-
-=over
-
-=item *
-
-added "CrackURL" and "CreateURL".
-
-=item *
-
-corrected an error in TEST.PL (there was a GetUserAgent instead of
-UserAgent).
-
-=back
-
-=item * 0.04 (25 Nov 1996)
-
-=over
-
-=item *
-
-added "Version" to retrieve package and DLL versions.
-
-=item *
-
-added proxies and other options to "new".
-
-=item *
-
-changed "OpenRequest" and "Request" to read parameters from a hash.
-
-=item *
-
-added "SetOption/QueryOption" and a lot of relative functions
-(connect, username, password, useragent, etc.).
-
-=item *
-
-added "CanonicalizeURL" and "CombineURL".
-
-=item *
-
-"Error" covers a wider spectrum of errors.
-
-=back
-
-=item * 0.02 (18 Nov 1996)
-
-=over
-
-=item *
-
-added support for HTTP sessions and requests.
-
-=back
-
-=item * 0.01 (11 Nov 1996)
-
-=over
-
-=item *
-
-fetching of HTTP, FTP and GOPHER URLs.
-
-=item *
-
-complete set of commands to manage an FTP session.
-
-=back
-
-=back
-
-=head1 AUTHOR
-
-Version 0.08 (14 Feb 1997) by Aldo Calpini <a.calpini@romagiubileo.it>
-
-
-=head1 CREDITS
-
-Win32::Internet is based on the Win32::Registry code written by Jesse
-Dougherty.
-
-Additional thanks to: Carl Tichler for his help in the initial
-development; Tore Haraldsen, Brian Helterline for the bugfixes; Dave
-Roth for his great source code examples.
-
-
-=head1 DISCLAIMER
-
-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.
diff --git a/Master/tlpkg/installer/perllib/Win32/Job.pm b/Master/tlpkg/installer/perllib/Win32/Job.pm
deleted file mode 100644
index 3350f76400d..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Job.pm
+++ /dev/null
@@ -1,370 +0,0 @@
-package Win32::Job;
-
-use strict;
-use base qw(DynaLoader);
-use vars qw($VERSION);
-
-$VERSION = '0.01';
-
-use constant WIN32s => 0;
-use constant WIN9X => 1;
-use constant WINNT => 2;
-
-require Win32 unless defined &Win32::GetOSVersion;
-my @ver = Win32::GetOSVersion;
-die "Win32::Job is not supported on $ver[0]" unless (
- $ver[4] == WINNT and (
- $ver[1] > 5 or
- ($ver[1] == 5 and $ver[2] > 0) or
- ($ver[1] == 5 and $ver[2] == 0 and $ver[3] >= 0)
- )
-);
-
-Win32::Job->bootstrap($VERSION);
-
-1;
-
-__END__
-
-=head1 NAME
-
-Win32::Job - Run sub-processes in a "job" environment
-
-=head1 SYNOPSIS
-
- use Win32::Job;
-
- my $job = Win32::Job->new;
-
- # Run 'perl Makefile.PL' for 10 seconds
- $job->spawn($Config{perlpath}, "perl Makefile.PL");
- $job->run(10);
-
-=head1 PLATFORMS
-
-Win32::Job requires Windows 2000 or later. Windows 95, 98, NT, and Me are not
-supported.
-
-=head1 DESCRIPTION
-
-Windows 2000 introduced the concept of a "job": a collection of processes
-which can be controlled as a single unit. For example, you can reliably kill a
-process and all of its children by launching the process in a job, then
-telling Windows to kill all processes in the job. Win32::Job makes this
-feature available to Perl.
-
-For example, imagine you want to allow 2 minutes for a process to complete.
-If you have control over the child process, you can probably just run it in
-the background, then poll every second to see if it has finished.
-
-That's fine as long as the child process doesn't spawn any child processes.
-What if it does? If you wrote the child process yourself and made an effort to
-clean up your child processes before terminating, you don't have to worry.
-If not, you will leave hanging processes (called "zombie" processes in Unix).
-
-With Win32::Job, just create a new Job, then use the job to spawn the child
-process. All I<its> children will also be created in the new Job. When you
-time out, just call the job's kill() method and the entire process tree will
-be terminated.
-
-=head1 Using Win32::Job
-
-The following methods are available:
-
-=over 4
-
-=item 1
-
-new()
-
- new();
-
-Creates a new Job object using the Win32 API call CreateJobObject(). The job
-is created with a default security context, and is unnamed.
-
-Note: this method returns C<undef> if CreateJobObject() fails. Look at C<$^E>
-for more detailed error information.
-
-=item 2
-
-spawn()
-
- spawn($exe, $args, \%opts);
-
-Creates a new process and associates it with the Job. The process is initially
-suspended, and can be resumed with one of the other methods. Uses the Win32
-API call CreateProcess(). Returns the PID of the newly created process.
-
-Note: this method returns C<undef> if CreateProcess() fails. See C<$^E> for
-more detailed error information. One reason this will fail is if the calling
-process is itself part of a job, and the job's security context does not allow
-child processes to be created in a different job context than the parent.
-
-The arguments are described here:
-
-=over 4
-
-=item 1
-
-$exe
-
-The executable program to run. This may be C<undef>, in which case the first
-argument in $args is the program to run.
-
-If this has path information in it, it is used "as is" and passed to
-CreateProcess(), which interprets it as either an absolute path, or a
-path relative to the current drive and directory. If you did not specify an
-extension, ".exe" is assumed.
-
-If there are no path separators (either backslashes or forward slashes),
-then Win32::Job will search the current directory and your PATH, looking
-for the file. In addition, if you did not specify an extension, then
-Win32::Job checks ".exe", ".com", and ".bat" in order. If it finds a ".bat"
-file, Win32::Job will actually call F<cmd.exe> and prepend "cmd.exe" to the
-$args.
-
-For example, assuming a fairly normal PATH:
-
- spawn(q{c:\winnt\system\cmd.exe}, q{cmd /C "echo %PATH%"})
- exefile: c:\winnt\system\cmd.exe
- cmdline: cmd /C "echo %PATH%"
-
- spawn("cmd.exe", q{cmd /C "echo %PATH%"})
- exefile: c:\winnt\system\cmd.exe
- cmdline: cmd /C "echo %PATH%"
-
-=item 2
-
-$args
-
-The commandline to pass to the executable program. The first word will be
-C<argv[0]> to an EXE file, so you should repeat the command name in $args.
-
-For example:
-
- $job->spawn($Config{perlpath}, "perl foo.pl");
-
-In this case, the "perl" is ignored, since perl.exe doesn't use it.
-
-=item 3
-
-%opts
-
-A hash reference for advanced options. This parameter is optional.
-the following keys are recognized:
-
-=over 4
-
-=item cwd
-
-A string specifying the current directory of the new process.
-
-By default, the process shares the parent's current directory, C<.>.
-
-=item new_console
-
-A boolean; if true, the process is started in a new console window.
-
-By default, the process shares the parent's console. This has no effect on GUI
-programs which do not interact with the console.
-
-=item window_attr
-
-Either C<minimized>, which displays the new window minimized; C<maximimzed>,
-which shows the new window maximized; or C<hidden>, which does not display the
-new window.
-
-By default, the window is displayed using its application's defaults.
-
-=item new_group
-
-A boolean; if true, the process is the root of a new process group. This
-process group includes all descendents of the child.
-
-By default, the process is in the parent's process group (but in a new job).
-
-=item no_window
-
-A boolean; if true, the process is run without a console window. This flag is
-only valid when starting a console application, otherwise it is ignored. If you
-are launching a GUI application, use the C<window_attr> tag instead.
-
-By default, the process shares its parent's console.
-
-=item stdin
-
-An open input filehandle, or the name of an existing file. The resulting
-filehandle will be used for the child's standard input handle.
-
-By default, the child process shares the parent's standard input.
-
-=item stdout
-
-An open output filehandle or filename (will be opened for append). The
-resulting filehandle will be used for the child's standard output handle.
-
-By default, the child process shares the parent's standard output.
-
-=item stderr
-
-An open output filehandle or filename (will be opened for append). The
-resulting filehandle will be used for the child's standard error handle.
-
-By default, the child process shares the parent's standard error.
-
-=back
-
-Unrecognized keys are ignored.
-
-=back
-
-=item 3
-
-run()
-
- run($timeout, $which);
-
-Provides a simple way to run the programs with a time limit. The
-$timeout is in seconds with millisecond accuracy. This call blocks for
-up to $timeout seconds, or until the processes finish.
-
-The $which parameter specifies whether to wait for I<all> processes to
-complete within the $timeout, or whether to wait for I<any> process to
-complete. You should set this to a boolean, where a true value means to
-wait for I<all> the processes to complete, and a false value to wait
-for I<any>. If you do not specify $which, it defaults to true (C<all>).
-
-Returns a boolean indicating whether the processes exited by themselves,
-or whether the time expired. A true return value means the processes
-exited normally; a false value means one or more processes was killed
-will $timeout.
-
-You can get extended information on process exit codes using the
-status() method.
-
-For example, this is how to build two perl modules at the same time,
-with a 5 minute timeout:
-
- use Win32::Job;
- $job = Win32::Job->new;
- $job->spawn("cmd", q{cmd /C "cd Mod1 && nmake"});
- $job->spawn("cmd", q{cmd /C "cd Mod2 && nmake"});
- $ok = $job->run(5 * 60);
- print "Mod1 and Mod2 built ok!\n" if $ok;
-
-=item 4
-
-watch()
-
- watch(\&handler, $interval, $which);
-
- handler($job);
-
-Provides more fine-grained control over how to stop the programs. You specify
-a callback and an interval in seconds, and Win32::Job will call the "watchdog"
-function at this interval, either until the processes finish or your watchdog
-tells Win32::Job to stop. You must return a value indicating whether to stop: a
-true value means to terminate the processes immediately.
-
-The $which parameter has the same meaning as run()'s.
-
-Returns a boolean with the same meaning as run()'s.
-
-The handler may do anything it wants. One useful application of the watch()
-method is to check the filesize of the output file, and terminate the Job if
-the file becomes larger than a certain limit:
-
- use Win32::Job;
- $job = Win32::Job->new;
- $job->spawn("cmd", q{cmd /C "cd Mod1 && nmake"}, {
- stdin => 'NUL', # the NUL device
- stdout => 'stdout.log',
- stderr => 'stdout.log',
- });
- $ok = $job->watch(sub {
- return 1 if -s "stdout.log" > 1_000_000;
- }, 1);
- print "Mod1 built ok!\n" if $ok;
-
-=item 5
-
-status()
-
- status()
-
-Returns a hash containing information about the processes in the job.
-Only returns valid information I<after> calling either run() or watch();
-returns an empty hash if you have not yet called them. May be called from a
-watch() callback, in which case the C<exitcode> field should be ignored.
-
-The keys of the hash are the process IDs; the values are a subhash
-containing the following keys:
-
-=over 4
-
-=item exitcode
-
-The exit code returned by the process. If the process was killed because
-of a timeout, the value is 293.
-
-=item time
-
-The time accumulated by the process. This is yet another subhash containing
-the subkeys (i) C<user>, the amount of time the process spent in user
-space; (ii) C<kernel>, the amount of time the process spent in kernel space;
-and (iii) C<elapsed>, the total time the process was running.
-
-=back
-
-=item 6
-
-kill()
-
- kill();
-
-Kills all processes and subprocesses in the Job. Has no return value.
-Sets the exit code to all processes killed to 293, which you can check
-for in the status() return value.
-
-=back
-
-=head1 SEE ALSO
-
-For more information about jobs, see Microsoft's online help at
-
- http://msdn.microsoft.com/
-
-For other modules which do similar things (but not as well), see:
-
-=over 4
-
-=item 1
-
-Win32::Process
-
-Low-level access to creating processes in Win32. See L<Win32::Process>.
-
-=item 2
-
-Win32::Console
-
-Low-level access to consoles in Win32. See L<Win32::Console>.
-
-=item 3
-
-Win32::ProcFarm
-
-Manage pools of threads to perform CPU-intensive tasks on Windows. See
-L<Win32::ProcFarm>.
-
-=back
-
-=head1 AUTHOR
-
-ActiveState (support@ActiveState.com)
-
-=head1 COPYRIGHT
-
-Copyright (c) 2002, ActiveState Corporation. All Rights Reserved.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/Mutex.pm b/Master/tlpkg/installer/perllib/Win32/Mutex.pm
deleted file mode 100644
index 801c2d35cda..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Mutex.pm
+++ /dev/null
@@ -1,125 +0,0 @@
-#---------------------------------------------------------------------
-package Win32::Mutex;
-#
-# Copyright 1998 Christopher J. Madsen
-#
-# Created: 3 Feb 1998 from the ActiveWare version
-# (c) 1995 Microsoft Corporation. All rights reserved.
-# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com
-#
-# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com>
-#
-# Author: Christopher J. Madsen <cjm@pobox.com>
-# Version: 1.00 (6-Feb-1998)
-#
-# This program 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. See either the
-# GNU General Public License or the Artistic License for more details.
-#
-# Use Win32 mutex objects for synchronization
-#---------------------------------------------------------------------
-
-$VERSION = '1.02';
-
-use Win32::IPC 1.00 '/./'; # Import everything
-require Exporter;
-require DynaLoader;
-
-@ISA = qw(Exporter DynaLoader Win32::IPC);
-@EXPORT_OK = qw(
- wait_all wait_any
-);
-
-bootstrap Win32::Mutex;
-
-sub Create { $_[0] = Win32::Mutex->new(@_[1..2]) }
-sub Open { $_[0] = Win32::Mutex->open($_[1]) }
-sub Release { &release }
-
-1;
-__END__
-
-=head1 NAME
-
-Win32::Mutex - Use Win32 mutex objects from Perl
-
-=head1 SYNOPSIS
-
- require Win32::Mutex;
-
- $mutex = Win32::Mutex->new($initial,$name);
- $mutex->wait;
-
-=head1 DESCRIPTION
-
-This module allows access to the Win32 mutex objects. The C<wait>
-method and C<wait_all> & C<wait_any> functions are inherited from the
-L<"Win32::IPC"> module.
-
-=head2 Methods
-
-=over 4
-
-=item $mutex = Win32::Mutex->new([$initial, [$name]])
-
-Constructor for a new mutex object. If C<$initial> is true, requests
-immediate ownership of the mutex (default false). If C<$name> is
-omitted, creates an unnamed mutex object.
-
-If C<$name> signifies an existing mutex object, then C<$initial> is
-ignored and the object is opened. If this happens, C<$^E> will be set
-to 183 (ERROR_ALREADY_EXISTS).
-
-=item $mutex = Win32::Mutex->open($name)
-
-Constructor for opening an existing mutex object.
-
-=item $mutex->release
-
-Release ownership of a C<$mutex>. You should have obtained ownership
-of the mutex through C<new> or one of the wait functions. Returns
-true if successful.
-
-=item $mutex->wait([$timeout])
-
-Wait for ownership of C<$mutex>. See L<"Win32::IPC">.
-
-=back
-
-=head2 Deprecated Functions and Methods
-
-B<Win32::Mutex> still supports the ActiveWare syntax, but its use is
-deprecated.
-
-=over 4
-
-=item Create($MutObj,$Initial,$Name)
-
-Use C<$MutObj = Win32::Mutex-E<gt>new($Initial,$Name)> instead.
-
-=item Open($MutObj,$Name)
-
-Use C<$MutObj = Win32::Mutex-E<gt>open($Name)> instead.
-
-=item $MutObj->Release()
-
-Use C<$MutObj-E<gt>release> instead.
-
-=back
-
-=head1 AUTHOR
-
-Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt>
-
-Loosely based on the original module by ActiveWare Internet Corp.,
-F<http://www.ActiveWare.com>
-
-=cut
-
-# Local Variables:
-# tmtrack-file-task: "Win32::Mutex"
-# End:
diff --git a/Master/tlpkg/installer/perllib/Win32/NetAdmin.pm b/Master/tlpkg/installer/perllib/Win32/NetAdmin.pm
deleted file mode 100644
index ace31a619e4..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/NetAdmin.pm
+++ /dev/null
@@ -1,419 +0,0 @@
-package Win32::NetAdmin;
-
-#
-#NetAdmin.pm
-#Written by Douglas_Lankshear@ActiveWare.com
-#
-
-$VERSION = '0.08';
-
-require Exporter;
-require DynaLoader;
-
-require Win32 unless defined &Win32::IsWinNT;
-die "The Win32::NetAdmin module works only on Windows NT" unless Win32::IsWinNT();
-
-@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(
- DOMAIN_ALIAS_RID_ACCOUNT_OPS
- DOMAIN_ALIAS_RID_ADMINS
- DOMAIN_ALIAS_RID_BACKUP_OPS
- DOMAIN_ALIAS_RID_GUESTS
- DOMAIN_ALIAS_RID_POWER_USERS
- DOMAIN_ALIAS_RID_PRINT_OPS
- DOMAIN_ALIAS_RID_REPLICATOR
- DOMAIN_ALIAS_RID_SYSTEM_OPS
- DOMAIN_ALIAS_RID_USERS
- DOMAIN_GROUP_RID_ADMINS
- DOMAIN_GROUP_RID_GUESTS
- DOMAIN_GROUP_RID_USERS
- DOMAIN_USER_RID_ADMIN
- DOMAIN_USER_RID_GUEST
- FILTER_TEMP_DUPLICATE_ACCOUNT
- FILTER_NORMAL_ACCOUNT
- FILTER_INTERDOMAIN_TRUST_ACCOUNT
- FILTER_WORKSTATION_TRUST_ACCOUNT
- FILTER_SERVER_TRUST_ACCOUNT
- SV_TYPE_WORKSTATION
- SV_TYPE_SERVER
- SV_TYPE_SQLSERVER
- SV_TYPE_DOMAIN_CTRL
- SV_TYPE_DOMAIN_BAKCTRL
- SV_TYPE_TIMESOURCE
- SV_TYPE_AFP
- SV_TYPE_NOVELL
- SV_TYPE_DOMAIN_MEMBER
- SV_TYPE_PRINT
- SV_TYPE_PRINTQ_SERVER
- SV_TYPE_DIALIN
- SV_TYPE_DIALIN_SERVER
- SV_TYPE_XENIX_SERVER
- SV_TYPE_NT
- SV_TYPE_WFW
- SV_TYPE_POTENTIAL_BROWSER
- SV_TYPE_BACKUP_BROWSER
- SV_TYPE_MASTER_BROWSER
- SV_TYPE_DOMAIN_MASTER
- SV_TYPE_DOMAIN_ENUM
- SV_TYPE_SERVER_UNIX
- SV_TYPE_SERVER_MFPN
- SV_TYPE_SERVER_NT
- SV_TYPE_SERVER_OSF
- SV_TYPE_SERVER_VMS
- SV_TYPE_WINDOWS
- SV_TYPE_DFS
- SV_TYPE_ALTERNATE_XPORT
- SV_TYPE_LOCAL_LIST_ONLY
- SV_TYPE_ALL
- UF_TEMP_DUPLICATE_ACCOUNT
- UF_NORMAL_ACCOUNT
- UF_INTERDOMAIN_TRUST_ACCOUNT
- UF_WORKSTATION_TRUST_ACCOUNT
- UF_SERVER_TRUST_ACCOUNT
- UF_MACHINE_ACCOUNT_MASK
- UF_ACCOUNT_TYPE_MASK
- UF_DONT_EXPIRE_PASSWD
- UF_SETTABLE_BITS
- UF_SCRIPT
- UF_ACCOUNTDISABLE
- UF_HOMEDIR_REQUIRED
- UF_LOCKOUT
- UF_PASSWD_NOTREQD
- UF_PASSWD_CANT_CHANGE
- USE_FORCE
- USE_LOTS_OF_FORCE
- USE_NOFORCE
- USER_PRIV_MASK
- USER_PRIV_GUEST
- USER_PRIV_USER
- USER_PRIV_ADMIN
-);
-
-@EXPORT_OK = qw(
- GetError
- GetDomainController
- GetAnyDomainController
- UserCreate
- UserDelete
- UserGetAttributes
- UserSetAttributes
- UserChangePassword
- UsersExist
- GetUsers
- GroupCreate
- GroupDelete
- GroupGetAttributes
- GroupSetAttributes
- GroupAddUsers
- GroupDeleteUsers
- GroupIsMember
- GroupGetMembers
- LocalGroupCreate
- LocalGroupDelete
- LocalGroupGetAttributes
- LocalGroupSetAttributes
- LocalGroupIsMember
- LocalGroupGetMembers
- LocalGroupGetMembersWithDomain
- LocalGroupAddUsers
- LocalGroupDeleteUsers
- GetServers
- GetTransports
- LoggedOnUsers
- GetAliasFromRID
- GetUserGroupFromRID
- GetServerDisks
-);
-$EXPORT_TAGS{ALL}= \@EXPORT_OK;
-
-=head1 NAME
-
-Win32::NetAdmin - manage network groups and users in perl
-
-=head1 SYNOPSIS
-
- use Win32::NetAdmin;
-
-=head1 DESCRIPTION
-
-This module offers control over the administration of groups and users over a
-network.
-
-=head1 FUNCTIONS
-
-=head2 NOTE
-
-All of the functions return false if they fail, unless otherwise noted.
-When a function fails call Win32::NetAdmin::GetError() rather than
-GetLastError() or $^E to retrieve the error code.
-
-C<server> is optional for all the calls below. If not given the local machine is
-assumed.
-
-=over 10
-
-=item GetError()
-
-Returns the error code of the last call to this module.
-
-=item GetDomainController(server, domain, returnedName)
-
-Returns the name of the domain controller for server.
-
-=item GetAnyDomainController(server, domain, returnedName)
-
-Returns the name of any domain controller for a domain that is directly trusted
-by the server.
-
-=item UserCreate(server, userName, password, passwordAge, privilege, homeDir, comment, flags, scriptPath)
-
-Creates a user on server with password, passwordAge, privilege, homeDir, comment,
-flags, and scriptPath.
-
-=item UserDelete(server, user)
-
-Deletes a user from server.
-
-=item UserGetAttributes(server, userName, password, passwordAge, privilege, homeDir, comment, flags, scriptPath)
-
-Gets password, passwordAge, privilege, homeDir, comment, flags, and scriptPath
-for user.
-
-=item UserSetAttributes(server, userName, password, passwordAge, privilege, homeDir, comment, flags, scriptPath)
-
-Sets password, passwordAge, privilege, homeDir, comment, flags, and scriptPath
-for user.
-
-=item UserChangePassword(domainname, username, oldpassword, newpassword)
-
-Changes a users password. Can be run under any account.
-
-=item UsersExist(server, userName)
-
-Checks if a user exists.
-
-=item GetUsers(server, filter, userRef)
-
-Fills userRef with user names if it is an array reference and with the user
-names and the full names if it is a hash reference.
-
-=item GroupCreate(server, group, comment)
-
-Creates a group.
-
-=item GroupDelete(server, group)
-
-Deletes a group.
-
-=item GroupGetAttributes(server, groupName, comment)
-
-Gets the comment.
-
-=item GroupSetAttributes(server, groupName, comment)
-
-Sets the comment.
-
-=item GroupAddUsers(server, groupName, users)
-
-Adds a user to a group.
-
-=item GroupDeleteUsers(server, groupName, users)
-
-Deletes a users from a group.
-
-=item GroupIsMember(server, groupName, user)
-
-Returns TRUE if user is a member of groupName.
-
-=item GroupGetMembers(server, groupName, userArrayRef)
-
-Fills userArrayRef with the members of groupName.
-
-=item LocalGroupCreate(server, group, comment)
-
-Creates a local group.
-
-=item LocalGroupDelete(server, group)
-
-Deletes a local group.
-
-=item LocalGroupGetAttributes(server, groupName, comment)
-
-Gets the comment.
-
-=item LocalGroupSetAttributes(server, groupName, comment)
-
-Sets the comment.
-
-=item LocalGroupIsMember(server, groupName, user)
-
-Returns TRUE if user is a member of groupName.
-
-=item LocalGroupGetMembers(server, groupName, userArrayRef)
-
-Fills userArrayRef with the members of groupName.
-
-=item LocalGroupGetMembersWithDomain(server, groupName, userRef)
-
-This function is similar LocalGroupGetMembers but accepts an array or
-a hash reference. Unlike LocalGroupGetMembers it returns each user name
-as C<DOMAIN\USERNAME>. If a hash reference is given, the function
-returns to each user or group name the type (group, user, alias etc.).
-The possible types are as follows:
-
- $SidTypeUser = 1;
- $SidTypeGroup = 2;
- $SidTypeDomain = 3;
- $SidTypeAlias = 4;
- $SidTypeWellKnownGroup = 5;
- $SidTypeDeletedAccount = 6;
- $SidTypeInvalid = 7;
- $SidTypeUnknown = 8;
-
-=item LocalGroupAddUsers(server, groupName, users)
-
-Adds a user to a group.
-
-=item LocalGroupDeleteUsers(server, groupName, users)
-
-Deletes a users from a group.
-
-=item GetServers(server, domain, flags, serverRef)
-
-Gets an array of server names or an hash with the server names and the
-comments as seen in the Network Neighborhood or the server manager.
-For flags, see SV_TYPE_* constants.
-
-=item GetTransports(server, transportRef)
-
-Enumerates the network transports of a computer. If transportRef is an array
-reference, it is filled with the transport names. If transportRef is a hash
-reference then a hash of hashes is filled with the data for the transports.
-
-=item LoggedOnUsers(server, userRef)
-
-Gets an array or hash with the users logged on at the specified computer. If
-userRef is a hash reference, the value is a semikolon separated string of
-username, logon domain and logon server.
-
-=item GetAliasFromRID(server, RID, returnedName)
-
-=item GetUserGroupFromRID(server, RID, returnedName)
-
-Retrieves the name of an alias (i.e local group) or a user group for a RID
-from the specified server. These functions can be used for example to get the
-account name for the administrator account if it is renamed or localized.
-
-Possible values for C<RID>:
-
- DOMAIN_ALIAS_RID_ACCOUNT_OPS
- DOMAIN_ALIAS_RID_ADMINS
- DOMAIN_ALIAS_RID_BACKUP_OPS
- DOMAIN_ALIAS_RID_GUESTS
- DOMAIN_ALIAS_RID_POWER_USERS
- DOMAIN_ALIAS_RID_PRINT_OPS
- DOMAIN_ALIAS_RID_REPLICATOR
- DOMAIN_ALIAS_RID_SYSTEM_OPS
- DOMAIN_ALIAS_RID_USERS
- DOMAIN_GROUP_RID_ADMINS
- DOMAIN_GROUP_RID_GUESTS
- DOMAIN_GROUP_RID_USERS
- DOMAIN_USER_RID_ADMIN
- DOMAIN_USER_RID_GUEST
-
-=item GetServerDisks(server, arrayRef)
-
-Returns an array with the disk drives of the specified server. The array
-contains two-character strings (drive letter followed by a colon).
-
-=back
-
-=head1 EXAMPLE
-
- # Simple script using Win32::NetAdmin to set the login script for
- # all members of the NT group "Domain Users". Only works if you
- # run it on the PDC. (From Robert Spier <rspier@seas.upenn.edu>)
- #
- # FILTER_TEMP_DUPLICATE_ACCOUNTS
- # Enumerates local user account data on a domain controller.
- #
- # FILTER_NORMAL_ACCOUNT
- # Enumerates global user account data on a computer.
- #
- # FILTER_INTERDOMAIN_TRUST_ACCOUNT
- # Enumerates domain trust account data on a domain controller.
- #
- # FILTER_WORKSTATION_TRUST_ACCOUNT
- # Enumerates workstation or member server account data on a domain
- # controller.
- #
- # FILTER_SERVER_TRUST_ACCOUNT
- # Enumerates domain controller account data on a domain controller.
-
-
- use Win32::NetAdmin qw(GetUsers GroupIsMember
- UserGetAttributes UserSetAttributes);
-
- my %hash;
- GetUsers("", FILTER_NORMAL_ACCOUNT , \%hash)
- or die "GetUsers() failed: $^E";
-
- foreach (keys %hash) {
- my ($password, $passwordAge, $privilege,
- $homeDir, $comment, $flags, $scriptPath);
- if (GroupIsMember("", "Domain Users", $_)) {
- print "Updating $_ ($hash{$_})\n";
- UserGetAttributes("", $_, $password, $passwordAge, $privilege,
- $homeDir, $comment, $flags, $scriptPath)
- or die "UserGetAttributes() failed: $^E";
- $scriptPath = "dnx_login.bat"; # this is the new login script
- UserSetAttributes("", $_, $password, $passwordAge, $privilege,
- $homeDir, $comment, $flags, $scriptPath)
- or die "UserSetAttributes() failed: $^E";
- }
- }
-
-=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::NetAdmin macro $constname, used in $file at line $line.";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-$SidTypeUser = 1;
-$SidTypeGroup = 2;
-$SidTypeDomain = 3;
-$SidTypeAlias = 4;
-$SidTypeWellKnownGroup = 5;
-$SidTypeDeletedAccount = 6;
-$SidTypeInvalid = 7;
-$SidTypeUnknown = 8;
-
-sub GetError() {
- our $__lastError;
- $__lastError;
-}
-
-bootstrap Win32::NetAdmin;
-
-1;
-__END__
-
diff --git a/Master/tlpkg/installer/perllib/Win32/NetResource.pm b/Master/tlpkg/installer/perllib/Win32/NetResource.pm
deleted file mode 100644
index 04ac87acabd..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/NetResource.pm
+++ /dev/null
@@ -1,456 +0,0 @@
-package Win32::NetResource;
-
-require Exporter;
-require DynaLoader;
-require AutoLoader;
-
-$VERSION = '0.053';
-
-@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(
- RESOURCEDISPLAYTYPE_DOMAIN
- RESOURCEDISPLAYTYPE_FILE
- RESOURCEDISPLAYTYPE_GENERIC
- RESOURCEDISPLAYTYPE_GROUP
- RESOURCEDISPLAYTYPE_SERVER
- RESOURCEDISPLAYTYPE_SHARE
- RESOURCEDISPLAYTYPE_TREE
- RESOURCETYPE_ANY
- RESOURCETYPE_DISK
- RESOURCETYPE_PRINT
- RESOURCETYPE_UNKNOWN
- RESOURCEUSAGE_CONNECTABLE
- RESOURCEUSAGE_CONTAINER
- RESOURCEUSAGE_RESERVED
- RESOURCE_CONNECTED
- RESOURCE_GLOBALNET
- RESOURCE_REMEMBERED
- STYPE_DISKTREE
- STYPE_PRINTQ
- STYPE_DEVICE
- STYPE_IPC
- STYPE_SPECIAL
- SHARE_NETNAME_PARMNUM
- SHARE_TYPE_PARMNUM
- SHARE_REMARK_PARMNUM
- SHARE_PERMISSIONS_PARMNUM
- SHARE_MAX_USES_PARMNUM
- SHARE_CURRENT_USES_PARMNUM
- SHARE_PATH_PARMNUM
- SHARE_PASSWD_PARMNUM
- SHARE_FILE_SD_PARMNUM
-);
-
-@EXPORT_OK = qw(
- GetSharedResources
- AddConnection
- CancelConnection
- WNetGetLastError
- GetError
- GetUNCName
- NetShareAdd
- NetShareCheck
- NetShareDel
- NetShareGetInfo
- NetShareSetInfo
-);
-
-=head1 NAME
-
-Win32::NetResource - manage network resources in perl
-
-=head1 SYNOPSIS
-
- use Win32::NetResource;
-
- $ShareInfo = {
- 'path' => "C:\\MyShareDir",
- 'netname' => "MyShare",
- 'remark' => "It is good to share",
- 'passwd' => "",
- 'current-users' =>0,
- 'permissions' => 0,
- 'maxusers' => -1,
- 'type' => 0,
- };
-
- Win32::NetResource::NetShareAdd( $ShareInfo,$parm )
- or die "unable to add share";
-
-
-=head1 DESCRIPTION
-
-This module offers control over the network resources of Win32.Disks,
-printers etc can be shared over a network.
-
-=head1 DATA TYPES
-
-There are two main data types required to control network resources.
-In Perl these are represented by hash types.
-
-=over 4
-
-=item %NETRESOURCE
-
- KEY VALUE
-
- 'Scope' => Scope of an Enumeration
- RESOURCE_CONNECTED,
- RESOURCE_GLOBALNET,
- RESOURCE_REMEMBERED.
-
- 'Type' => The type of resource to Enum
- RESOURCETYPE_ANY All resources
- RESOURCETYPE_DISK Disk resources
- RESOURCETYPE_PRINT Print resources
-
- 'DisplayType' => The way the resource should be displayed.
- RESOURCEDISPLAYTYPE_DOMAIN
- The object should be displayed as a domain.
- RESOURCEDISPLAYTYPE_GENERIC
- The method used to display the object does not matter.
- RESOURCEDISPLAYTYPE_SERVER
- The object should be displayed as a server.
- RESOURCEDISPLAYTYPE_SHARE
- The object should be displayed as a sharepoint.
-
- 'Usage' => Specifies the Resources usage:
- RESOURCEUSAGE_CONNECTABLE
- RESOURCEUSAGE_CONTAINER.
-
- 'LocalName' => Name of the local device the resource is
- connected to.
-
- 'RemoteName' => The network name of the resource.
-
- 'Comment' => A string comment.
-
- 'Provider' => Name of the provider of the resource.
-
-=back
-
-=item %SHARE_INFO
-
-This hash represents the SHARE_INFO_502 struct.
-
-=over 4
-
- KEY VALUE
- 'netname' => Name of the share.
- 'type' => type of share.
- 'remark' => A string comment.
- 'permissions' => Permissions value
- 'maxusers' => the max # of users.
- 'current-users' => the current # of users.
- 'path' => The path of the share.
- 'passwd' => A password if one is req'd
-
-=back
-
-=head1 FUNCTIONS
-
-=head2 NOTE
-
-All of the functions return false if they fail.
-
-=over 4
-
-=item GetSharedResources(\@Resources,dwType,\%NetResource = NULL)
-
-Creates a list in @Resources of %NETRESOURCE hash references.
-
-The return value indicates whether there was an error in accessing
-any of the shared resources. All the shared resources that were
-encountered (until the point of an error, if any) are pushed into
-@Resources as references to %NETRESOURCE hashes. See example
-below. The \%NetResource argument is optional. If it is not supplied,
-the root (that is, the topmost container) of the network is assumed,
-and all network resources available from the toplevel container will
-be enumerated.
-
-=item AddConnection(\%NETRESOURCE,$Password,$UserName,$Connection)
-
-Makes a connection to a network resource specified by %NETRESOURCE
-
-=item CancelConnection($Name,$Connection,$Force)
-
-Cancels a connection to a network resource connected to local device
-$name.$Connection is either 1 - persistent connection or 0, non-persistent.
-
-=item WNetGetLastError($ErrorCode,$Description,$Name)
-
-Gets the Extended Network Error.
-
-=item GetError( $ErrorCode )
-
-Gets the last Error for a Win32::NetResource call.
-
-=item GetUNCName( $UNCName, $LocalPath );
-
-Returns the UNC name of the disk share connected to $LocalPath in $UNCName.
-$LocalPath should be a drive based path. e.g. "C:\\share\\subdir"
-
-=back
-
-=head2 NOTE
-
-$servername is optional for all the calls below. (if not given the
-local machine is assumed.)
-
-=over 4
-
-=item NetShareAdd(\%SHARE,$parm_err,$servername = NULL )
-
-Add a share for sharing.
-
-=item NetShareCheck($device,$type,$servername = NULL )
-
-Check if a directory or a device is available for connection from the
-network through a share. This includes all directories that are
-reachable through a shared directory or device, meaning that if C:\foo
-is shared, C:\foo\bar is also available for sharing. This means that
-this function is pretty useless, given that by default every disk
-volume has an administrative share such as "C$" associated with its
-root directory.
-
-$device must be a drive name, directory, or a device. For example,
-"C:", "C:\dir", "LPT1", "D$", "IPC$" are all valid as the $device
-argument. $type is an output argument that will be set to one of
-the following constants that describe the type of share:
-
- STYPE_DISKTREE Disk drive
- STYPE_PRINTQ Print queue
- STYPE_DEVICE Communication device
- STYPE_IPC Interprocess communication (IPC)
- STYPE_SPECIAL Special share reserved for interprocess
- communication (IPC$) or remote administration
- of the server (ADMIN$). Can also refer to
- administrative shares such as C$, D$, etc.
-
-=item NetShareDel( $netname, $servername = NULL )
-
-Remove a share from a machines list of shares.
-
-=item NetShareGetInfo( $netname, \%SHARE,$servername=NULL )
-
-Get the %SHARE_INFO information about the share $netname on the
-server $servername.
-
-=item NetShareSetInfo( $netname,\%SHARE,$parm_err,$servername=NULL)
-
-Set the information for share $netname.
-
-=back
-
-=head1 EXAMPLE
-
-=over 4
-
-=item Enumerating all resources on the network
-
- #
- # This example displays all the share points in the entire
- # visible part of the network.
- #
-
- use strict;
- use Win32::NetResource qw(:DEFAULT GetSharedResources GetError);
- my $resources = [];
- unless(GetSharedResources($resources, RESOURCETYPE_ANY)) {
- my $err;
- GetError($err);
- warn Win32::FormatMessage($err);
- }
-
- foreach my $href (@$resources) {
- next if ($$href{DisplayType} != RESOURCEDISPLAYTYPE_SHARE);
- print "-----\n";
- foreach( keys %$href){
- print "$_: $href->{$_}\n";
- }
- }
-
-=item Enumerating all resources on a particular host
-
- #
- # This example displays all the share points exported by the local
- # host.
- #
-
- use strict;
- use Win32::NetResource qw(:DEFAULT GetSharedResources GetError);
- if (GetSharedResources(my $resources, RESOURCETYPE_ANY,
- { RemoteName => "\\\\" . Win32::NodeName() }))
- {
- foreach my $href (@$resources) {
- print "-----\n";
- foreach(keys %$href) { print "$_: $href->{$_}\n"; }
- }
- }
-
-=back
-
-=head1 AUTHOR
-
-Jesse Dougherty for Hip Communications.
-
-Additional general cleanups and bug fixes by Gurusamy Sarathy <gsar@activestate.com>.
-
-=cut
-
-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;
- 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::NetResource macro $constname, used at $file line $line.
-";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-sub AddConnection
-{
- my $h = $_[0];
- die "AddConnection: HASH reference required" unless ref($h) eq "HASH";
-
- #
- # The last four items *must* not be deallocated until the
- # _AddConnection() completes (since the packed structure is
- # pointing into these values.
- #
- my $netres = pack( 'i4 p4', $h->{Scope},
- $h->{Type},
- $h->{DisplayType},
- $h->{Usage},
- $h->{LocalName},
- $h->{RemoteName},
- $h->{Comment},
- $h->{Provider});
- _AddConnection($netres,$_[1],$_[2],$_[3]);
-}
-
-#use Data::Dumper;
-
-sub GetSharedResources
-{
- die "GetSharedResources: ARRAY reference required"
- if defined $_[0] and ref($_[0]) ne "ARRAY";
-
- my $aref = [];
-
- # Get the shared resources.
-
- my $ret;
-
- if (@_ > 2 and $_[2]) {
- my $netres = pack('i4 p4', @{$_[2]}{qw(Scope
- Type
- DisplayType
- Usage
- LocalName
- RemoteName
- Comment
- Provider)});
- $ret = _GetSharedResources( $aref , $_[1], $netres );
- }
- else {
- $ret = _GetSharedResources( $aref , $_[1] );
- }
-
- # build the array of hashes in $_[0]
-# print Dumper($aref);
- foreach ( @$aref ) {
- my %hash;
- @hash{'Scope',
- 'Type',
- 'DisplayType',
- 'Usage',
- 'LocalName',
- 'RemoteName',
- 'Comment',
- 'Provider'} = split /\001/, $_;
- push @{$_[0]}, \%hash;
- }
-
- $ret;
-}
-
-sub NetShareAdd
-{
- my $shareinfo = _hash2SHARE( $_[0] );
- _NetShareAdd($shareinfo,$_[1], $_[2] || "");
-}
-
-sub NetShareGetInfo
-{
- my ($netinfo,$val);
- $val = _NetShareGetInfo( $_[0],$netinfo,$_[2] || "");
- %{$_[1]} = %{_SHARE2hash( $netinfo )};
- $val;
-}
-
-sub NetShareSetInfo
-{
- my $shareinfo = _hash2SHARE( $_[1] );
- _NetShareSetInfo( $_[0],$shareinfo,$_[2],$_[3] || "");
-}
-
-
-# These are private functions to work with the ShareInfo structure.
-# please note that the implementation of these calls requires the
-# SHARE_INFO_502 level of information.
-
-sub _SHARE2hash
-{
- my %hash = ();
- @hash{'type',
- 'permissions',
- 'maxusers',
- 'current-users',
- 'remark',
- 'netname',
- 'path',
- 'passwd'} = unpack('i4 A257 A81 A257 A257',$_[0]);
-
- return \%hash;
-}
-
-sub _hash2SHARE
-{
- my $h = $_[0];
- die "Argument must be a HASH reference" unless ref($h) eq "HASH";
-
- return pack 'i4 a257 a81 a257 a257',
- @$h{'type',
- 'permissions',
- 'maxusers',
- 'current-users',
- 'remark',
- 'netname',
- 'path',
- 'passwd'};
-}
-
-
-bootstrap Win32::NetResource;
-
-1;
-__END__
diff --git a/Master/tlpkg/installer/perllib/Win32/ODBC.pm b/Master/tlpkg/installer/perllib/Win32/ODBC.pm
deleted file mode 100644
index a51616388ea..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/ODBC.pm
+++ /dev/null
@@ -1,1493 +0,0 @@
-package Win32::ODBC;
-
-$VERSION = '0.032';
-
-# Win32::ODBC.pm
-# +==========================================================+
-# | |
-# | ODBC.PM package |
-# | --------------- |
-# | |
-# | Copyright (c) 1996, 1997 Dave Roth. All rights reserved. |
-# | This program is free software; you can redistribute |
-# | it and/or modify it under the same terms as Perl itself. |
-# | |
-# +==========================================================+
-#
-#
-# based on original code by Dan DeMaggio (dmag@umich.edu)
-#
-# Use under GNU General Public License or Larry Wall's "Artistic License"
-#
-# Check the README.TXT file that comes with this package for details about
-# it's history.
-#
-
-require Exporter;
-require DynaLoader;
-
-$ODBCPackage = "Win32::ODBC";
-$ODBCPackage::Version = 970208;
-$::ODBC = $ODBCPackage;
-$CacheConnection = 0;
-
- # Reserve ODBC in the main namespace for US!
-*ODBC::=\%Win32::ODBC::;
-
-
-@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(
- ODBC_ADD_DSN
- ODBC_REMOVE_DSN
- ODBC_CONFIG_DSN
- ODBC_ADD_SYS_DSN
- ODBC_REMOVE_SYS_DSN
- ODBC_CONFIG_SYS_DSN
-
- SQL_DONT_CLOSE
- SQL_DROP
- SQL_CLOSE
- SQL_UNBIND
- SQL_RESET_PARAMS
-
- SQL_FETCH_NEXT
- SQL_FETCH_FIRST
- SQL_FETCH_LAST
- SQL_FETCH_PRIOR
- SQL_FETCH_ABSOLUTE
- SQL_FETCH_RELATIVE
- SQL_FETCH_BOOKMARK
-
- SQL_COLUMN_COUNT
- SQL_COLUMN_NAME
- SQL_COLUMN_TYPE
- SQL_COLUMN_LENGTH
- SQL_COLUMN_PRECISION
- SQL_COLUMN_SCALE
- SQL_COLUMN_DISPLAY_SIZE
- SQL_COLUMN_NULLABLE
- SQL_COLUMN_UNSIGNED
- SQL_COLUMN_MONEY
- SQL_COLUMN_UPDATABLE
- SQL_COLUMN_AUTO_INCREMENT
- SQL_COLUMN_CASE_SENSITIVE
- SQL_COLUMN_SEARCHABLE
- SQL_COLUMN_TYPE_NAME
- SQL_COLUMN_TABLE_NAME
- SQL_COLUMN_OWNER_NAME
- SQL_COLUMN_QUALIFIER_NAME
- SQL_COLUMN_LABEL
- SQL_COLATT_OPT_MAX
- SQL_COLUMN_DRIVER_START
- SQL_COLATT_OPT_MIN
- SQL_ATTR_READONLY
- SQL_ATTR_WRITE
- SQL_ATTR_READWRITE_UNKNOWN
- SQL_UNSEARCHABLE
- SQL_LIKE_ONLY
- SQL_ALL_EXCEPT_LIKE
- SQL_SEARCHABLE
- );
- #The above are included for backward compatibility
-
-
-sub new
-{
- my ($n, $self);
- my ($type) = shift;
- my ($DSN) = shift;
- my (@Results) = @_;
-
- if (ref $DSN){
- @Results = ODBCClone($DSN->{'connection'});
- }else{
- @Results = ODBCConnect($DSN, @Results);
- }
- @Results = processError(-1, @Results);
- if (! scalar(@Results)){
- return undef;
- }
- $self = bless {};
- $self->{'connection'} = $Results[0];
- $ErrConn = $Results[0];
- $ErrText = $Results[1];
- $ErrNum = 0;
- $self->{'DSN'} = $DSN;
- $self;
-}
-
-####
-# Close this ODBC session (or all sessions)
-####
-sub Close
-{
- my ($self, $Result) = shift;
- $Result = DESTROY($self);
- $self->{'connection'} = -1;
- return $Result;
-}
-
-####
-# Auto-Kill an instance of this module
-####
-sub DESTROY
-{
- my ($self) = shift;
- my (@Results) = (0);
- if($self->{'connection'} > -1){
- @Results = ODBCDisconnect($self->{'connection'});
- @Results = processError($self, @Results);
- if ($Results[0]){
- undef $self->{'DSN'};
- undef @{$self->{'fnames'}};
- undef %{$self->{'field'}};
- undef %{$self->{'connection'}};
- }
- }
- return $Results[0];
-}
-
-
-sub sql{
- return (Sql(@_));
-}
-
-####
-# Submit an SQL Execute statement for processing
-####
-sub Sql{
- my ($self, $Sql, @Results) = @_;
- @Results = ODBCExecute($self->{'connection'}, $Sql);
- return updateResults($self, @Results);
-}
-
-####
-# Retrieve data from a particular field
-####
-sub Data{
-
- # Change by JOC 06-APR-96
- # Altered by Dave Roth <dave@roth.net> 96.05.07
- my($self) = shift;
- my(@Fields) = @_;
- my(@Results, $Results, $Field);
-
- if ($self->{'Dirty'}){
- GetData($self);
- $self->{'Dirty'} = 0;
- }
- @Fields = @{$self->{'fnames'}} if (! scalar(@Fields));
- foreach $Field (@Fields) {
- if (wantarray) {
- push(@Results, data($self, $Field));
- } else {
- $Results .= data($self, $Field);
- }
- }
- return wantarray ? @Results : $Results;
-}
-
-sub DataHash{
- my($self, @Results) = @_;
- my(%Results, $Element);
-
- if ($self->{'Dirty'}){
- GetData($self);
- $self->{'Dirty'} = 0;
- }
- @Results = @{$self->{'fnames'}} if (! scalar(@Results));
- foreach $Element (@Results) {
- $Results{$Element} = data($self, $Element);
- }
-
- return %Results;
-}
-
-####
-# Retrieve data from the data buffer
-####
-sub data
-{ $_[0]->{'data'}->{$_[1]}; }
-
-
-sub fetchrow{
- return (FetchRow(@_));
-}
-####
-# Put a row from an ODBC data set into data buffer
-####
-sub FetchRow{
- my ($self, @Results) = @_;
- my ($item, $num, $sqlcode);
- # Added by JOC 06-APR-96
- # $num = 0;
- $num = 0;
- undef $self->{'data'};
-
-
- @Results = ODBCFetch($self->{'connection'}, @Results);
- if (! (@Results = processError($self, @Results))){
- ####
- # There should be an innocuous error "No records remain"
- # This indicates no more records in the dataset
- ####
- return undef;
- }
- # Set the Dirty bit so we will go and extract data via the
- # ODBCGetData function. Otherwise use the cache.
- $self->{'Dirty'} = 1;
-
- # Return the array of field Results.
- return @Results;
-}
-
-sub GetData{
- my($self) = @_;
- my @Results;
- my $num = 0;
-
- @Results = ODBCGetData($self->{'connection'});
- if (!(@Results = processError($self, @Results))){
- return undef;
- }
- ####
- # This is a special case. Do not call processResults
- ####
- ClearError();
- foreach (@Results){
- s/ +$// if defined $_; # HACK
- $self->{'data'}->{ ${$self->{'fnames'}}[$num] } = $_;
- $num++;
- }
- # return is a hack to interface with a assoc array.
- return wantarray? (1, 1): 1;
-}
-
-####
-# See if any more ODBC Results Sets
-# Added by Brian Dunfordshore <Brian_Dunfordshore@bridge.com>
-# 96.07.10
-####
-sub MoreResults{
- my ($self) = @_;
-
- my(@Results) = ODBCMoreResults($self->{'connection'});
- return (processError($self, @Results))[0];
-}
-
-####
-# Retrieve the catalog from the current DSN
-# NOTE: All Field names are uppercase!!!
-####
-sub Catalog{
- my ($self) = shift;
- my ($Qualifier, $Owner, $Name, $Type) = @_;
- my (@Results) = ODBCTableList($self->{'connection'}, $Qualifier, $Owner, $Name, $Type);
-
- # If there was an error return 0 else 1
- return (updateResults($self, @Results) != 1);
-}
-
-####
-# Return an array of names from the catalog for the current DSN
-# TableList($Qualifier, $Owner, $Name, $Type)
-# Return: (array of names of tables)
-# NOTE: All Field names are uppercase!!!
-####
-sub TableList{
- my ($self) = shift;
- my (@Results) = @_;
- if (! scalar(@Results)){
- @Results = ("", "", "%", "TABLE");
- }
-
- if (! Catalog($self, @Results)){
- return undef;
- }
- undef @Results;
- while (FetchRow($self)){
- push(@Results, Data($self, "TABLE_NAME"));
- }
- return sort(@Results);
-}
-
-
-sub fieldnames{
- return (FieldNames(@_));
-}
-####
-# Return an array of fieldnames extracted from the current dataset
-####
-sub FieldNames { $self = shift; return @{$self->{'fnames'}}; }
-
-
-####
-# Closes this connection. This is used mostly for testing. You should
-# probably use Close().
-####
-sub ShutDown{
- my($self) = @_;
- print "\nClosing connection $self->{'connection'}...";
- $self->Close();
- print "\nDone\n";
-}
-
-####
-# Return this connection number
-####
-sub Connection{
- my($self) = @_;
- return $self->{'connection'};
-}
-
-####
-# Returns the current connections that are in use.
-####
-sub GetConnections{
- return ODBCGetConnections();
-}
-
-####
-# Set the Max Buffer Size for this connection. This determines just how much
-# ram can be allocated when a fetch() is performed that requires a HUGE amount
-# of memory. The default max is 10k and the absolute max is 100k.
-# This will probably never be used but I put it in because I noticed a fetch()
-# of a MEMO field in an Access table was something like 4Gig. Maybe I did
-# something wrong, but after checking several times I decided to impliment
-# this limit thingie.
-####
-sub SetMaxBufSize{
- my($self, $Size) = @_;
- my(@Results) = ODBCSetMaxBufSize($self->{'connection'}, $Size);
- return (processError($self, @Results))[0];
-}
-
-####
-# Returns the Max Buffer Size for this connection. See SetMaxBufSize().
-####
-sub GetMaxBufSize{
- my($self) = @_;
- my(@Results) = ODBCGetMaxBufSize($self->{'connection'});
- return (processError($self, @Results))[0];
-}
-
-
-####
-# Returns the DSN for this connection as an associative array.
-####
-sub GetDSN{
- my($self, $DSN) = @_;
- if(! ref($self)){
- $DSN = $self;
- $self = 0;
- }
- if (! $DSN){
- $self = $self->{'connection'};
- }
- my(@Results) = ODBCGetDSN($self, $DSN);
- return (processError($self, @Results));
-}
-
-####
-# Returns an associative array of $XXX{'DSN'}=Description
-####
-sub DataSources{
- my($self, $DSN) = @_;
- if(! ref $self){
- $DSN = $self;
- $self = 0;
- }
- my(@Results) = ODBCDataSources($DSN);
- return (processError($self, @Results));
-}
-
-####
-# Returns an associative array of $XXX{'Driver Name'}=Driver Attributes
-####
-sub Drivers{
- my($self) = @_;
- if(! ref $self){
- $self = 0;
- }
- my(@Results) = ODBCDrivers();
- return (processError($self, @Results));
-}
-
-####
-# Returns the number of Rows that were affected by the previous SQL command.
-####
-sub RowCount{
- my($self, $Connection) = @_;
- if (! ref($self)){
- $Connection = $self;
- $self = 0;
- }
- if (! $Connection){$Connection = $self->{'connection'};}
- my(@Results) = ODBCRowCount($Connection);
- return (processError($self, @Results))[0];
-}
-
-####
-# Returns the Statement Close Type -- how does ODBC Close a statment.
-# Types:
-# SQL_DROP
-# SQL_CLOSE
-# SQL_UNBIND
-# SQL_RESET_PARAMS
-####
-sub GetStmtCloseType{
- my($self, $Connection) = @_;
- if (! ref($self)){
- $Connection = $self;
- $self = 0;
- }
- if (! $Connection){$Connection = $self->{'connection'};}
- my(@Results) = ODBCGetStmtCloseType($Connection);
- return (processError($self, @Results));
-}
-
-####
-# Sets the Statement Close Type -- how does ODBC Close a statment.
-# Types:
-# SQL_DROP
-# SQL_CLOSE
-# SQL_UNBIND
-# SQL_RESET_PARAMS
-# Returns the newly set value.
-####
-sub SetStmtCloseType{
- my($self, $Type, $Connection) = @_;
- if (! ref($self)){
- $Connection = $Type;
- $Type = $self;
- $self = 0;
- }
- if (! $Connection){$Connection = $self->{'connection'};}
- my(@Results) = ODBCSetStmtCloseType($Connection, $Type);
- return (processError($self, @Results))[0];
-}
-
-sub ColAttributes{
- my($self, $Type, @Field) = @_;
- my(%Results, @Results, $Results, $Attrib, $Connection, $Temp);
- if (! ref($self)){
- $Type = $Field;
- $Field = $self;
- $self = 0;
- }
- $Connection = $self->{'connection'};
- if (! scalar(@Field)){ @Field = $self->fieldnames;}
- foreach $Temp (@Field){
- @Results = ODBCColAttributes($Connection, $Temp, $Type);
- ($Attrib) = processError($self, @Results);
- if (wantarray){
- $Results{$Temp} = $Attrib;
- }else{
- $Results .= "$Temp";
- }
- }
- return wantarray? %Results:$Results;
-}
-
-sub GetInfo{
- my($self, $Type) = @_;
- my($Connection, @Results);
- if(! ref $self){
- $Type = $self;
- $self = 0;
- $Connection = 0;
- }else{
- $Connection = $self->{'connection'};
- }
- @Results = ODBCGetInfo($Connection, $Type);
- return (processError($self, @Results))[0];
-}
-
-sub GetConnectOption{
- my($self, $Type) = @_;
- my(@Results);
- if(! ref $self){
- $Type = $self;
- $self = 0;
- }
- @Results = ODBCGetConnectOption($self->{'connection'}, $Type);
- return (processError($self, @Results))[0];
-}
-
-sub SetConnectOption{
- my($self, $Type, $Value) = @_;
- if(! ref $self){
- $Value = $Type;
- $Type = $self;
- $self = 0;
- }
- my(@Results) = ODBCSetConnectOption($self->{'connection'}, $Type, $Value);
- return (processError($self, @Results))[0];
-}
-
-
-sub Transact{
- my($self, $Type) = @_;
- my(@Results);
- if(! ref $self){
- $Type = $self;
- $self = 0;
- }
- @Results = ODBCTransact($self->{'connection'}, $Type);
- return (processError($self, @Results))[0];
-}
-
-
-sub SetPos{
- my($self, @Results) = @_;
- @Results = ODBCSetPos($self->{'connection'}, @Results);
- $self->{'Dirty'} = 1;
- return (processError($self, @Results))[0];
-}
-
-sub ConfigDSN{
- my($self) = shift @_;
- my($Type, $Connection);
- if(! ref $self){
- $Type = $self;
- $Connection = 0;
- $self = 0;
- }else{
- $Type = shift @_;
- $Connection = $self->{'connection'};
- }
- my($Driver, @Attributes) = @_;
- @Results = ODBCConfigDSN($Connection, $Type, $Driver, @Attributes);
- return (processError($self, @Results))[0];
-}
-
-
-sub Version{
- my($self, @Packages) = @_;
- my($Temp, @Results);
- if (! ref($self)){
- push(@Packages, $self);
- }
- my($ExtName, $ExtVersion) = Info();
- if (! scalar(@Packages)){
- @Packages = ("ODBC.PM", "ODBC.PLL");
- }
- foreach $Temp (@Packages){
- if ($Temp =~ /pll/i){
- push(@Results, "ODBC.PM:$Win32::ODBC::Version");
- }elsif ($Temp =~ /pm/i){
- push(@Results, "ODBC.PLL:$ExtVersion");
- }
- }
- return @Results;
-}
-
-
-sub SetStmtOption{
- my($self, $Option, $Value) = @_;
- if(! ref $self){
- $Value = $Option;
- $Option = $self;
- $self = 0;
- }
- my(@Results) = ODBCSetStmtOption($self->{'connection'}, $Option, $Value);
- return (processError($self, @Results))[0];
-}
-
-sub GetStmtOption{
- my($self, $Type) = @_;
- if(! ref $self){
- $Type = $self;
- $self = 0;
- }
- my(@Results) = ODBCGetStmtOption($self->{'connection'}, $Type);
- return (processError($self, @Results))[0];
-}
-
-sub GetFunctions{
- my($self, @Results)=@_;
- @Results = ODBCGetFunctions($self->{'connection'}, @Results);
- return (processError($self, @Results));
-}
-
-sub DropCursor{
- my($self) = @_;
- my(@Results) = ODBCDropCursor($self->{'connection'});
- return (processError($self, @Results))[0];
-}
-
-sub SetCursorName{
- my($self, $Name) = @_;
- my(@Results) = ODBCSetCursorName($self->{'connection'}, $Name);
- return (processError($self, @Results))[0];
-}
-
-sub GetCursorName{
- my($self) = @_;
- my(@Results) = ODBCGetCursorName($self->{'connection'});
- return (processError($self, @Results))[0];
-}
-
-sub GetSQLState{
- my($self) = @_;
- my(@Results) = ODBCGetSQLState($self->{'connection'});
- return (processError($self, @Results))[0];
-}
-
-
-# ----------- R e s u l t P r o c e s s i n g F u n c t i o n s ----------
-####
-# Generic processing of data into associative arrays
-####
-sub updateResults{
- my ($self, $Error, @Results) = @_;
-
- undef %{$self->{'field'}};
-
- ClearError($self);
- if ($Error){
- SetError($self, $Results[0], $Results[1]);
- return ($Error);
- }
-
- @{$self->{'fnames'}} = @Results;
-
- foreach (0..$#{$self->{'fnames'}}){
- s/ +$//;
- $self->{'field'}->{${$self->{'fnames'}}[$_]} = $_;
- }
- return undef;
-}
-
-# ----------------------------------------------------------------------------
-# ----------------- D e b u g g i n g F u n c t i o n s --------------------
-
-sub Debug{
- my($self, $iDebug, $File) = @_;
- my(@Results);
- if (! ref($self)){
- if (defined $self){
- $File = $iDebug;
- $iDebug = $self;
- }
- $Connection = 0;
- $self = 0;
- }else{
- $Connection = $self->{'connection'};
- }
- push(@Results, ($Connection, $iDebug));
- push(@Results, $File) if ($File ne "");
- @Results = ODBCDebug(@Results);
- return (processError($self, @Results))[0];
-}
-
-####
-# Prints out the current dataset (used mostly for testing)
-####
-sub DumpData {
- my($self) = @_; my($f, $goo);
-
- # Changed by JOC 06-Apr-96
- # print "\nDumping Data for connection: $conn->{'connection'}\n";
- print "\nDumping Data for connection: $self->{'connection'}\n";
- print "Error: \"";
- print $self->Error();
- print "\"\n";
- if (! $self->Error()){
- foreach $f ($self->FieldNames){
- print $f . " ";
- $goo .= "-" x length($f);
- $goo .= " ";
- }
- print "\n$goo\n";
- while ($self->FetchRow()){
- foreach $f ($self->FieldNames){
- print $self->Data($f) . " ";
- }
- print "\n";
- }
- }
-}
-
-sub DumpError{
- my($self) = @_;
- my($ErrNum, $ErrText, $ErrConn);
- my($Temp);
-
- print "\n---------- Error Report: ----------\n";
- if (ref $self){
- ($ErrNum, $ErrText, $ErrConn) = $self->Error();
- ($Temp = $self->GetDSN()) =~ s/.*DSN=(.*?);.*/$1/i;
- print "Errors for \"$Temp\" on connection " . $self->{'connection'} . ":\n";
- }else{
- ($ErrNum, $ErrText, $ErrConn) = Error();
- print "Errors for the package:\n";
- }
-
- print "Connection Number: $ErrConn\nError number: $ErrNum\nError message: \"$ErrText\"\n";
- print "-----------------------------------\n";
-
-}
-
-####
-# Submit an SQL statement and print data about it (used mostly for testing)
-####
-sub Run{
- my($self, $Sql) = @_;
-
- print "\nExcecuting connection $self->{'connection'}\nsql statement: \"$Sql\"\n";
- $self->Sql($Sql);
- print "Error: \"";
- print $self->error;
- print "\"\n";
- print "--------------------\n\n";
-}
-
-# ----------------------------------------------------------------------------
-# ----------- E r r o r P r o c e s s i n g F u n c t i o n s ------------
-
-####
-# Process Errors returned from a call to ODBCxxxx().
-# It is assumed that the Win32::ODBC function returned the following structure:
-# ($ErrorNumber, $ResultsText, ...)
-# $ErrorNumber....0 = No Error
-# >0 = Error Number
-# $ResultsText.....if no error then this is the first Results element.
-# if error then this is the error text.
-####
-sub processError{
- my($self, $Error, @Results) = @_;
- if ($Error){
- SetError($self, $Results[0], $Results[1]);
- undef @Results;
- }
- return @Results;
-}
-
-####
-# Return the last recorded error message
-####
-sub error{
- return (Error(@_));
-}
-
-sub Error{
- my($self) = @_;
- if(ref($self)){
- if($self->{'ErrNum'}){
- my($State) = ODBCGetSQLState($self->{'connection'});
- return (wantarray)? ($self->{'ErrNum'}, $self->{'ErrText'}, $self->{'connection'}, $State) :"[$self->{'ErrNum'}] [$self->{'connection'}] [$State] \"$self->{'ErrText'}\"";
- }
- }elsif ($ErrNum){
- return (wantarray)? ($ErrNum, $ErrText, $ErrConn):"[$ErrNum] [$ErrConn] \"$ErrText\"";
- }
- return undef
-}
-
-####
-# SetError:
-# Assume that if $self is not a reference then it is just a placeholder
-# and should be ignored.
-####
-sub SetError{
- my($self, $Num, $Text, $Conn) = @_;
- if (ref $self){
- $self->{'ErrNum'} = $Num;
- $self->{'ErrText'} = $Text;
- $Conn = $self->{'connection'} if ! $Conn;
- }
- $ErrNum = $Num;
- $ErrText = $Text;
-
- ####
- # Test Section Begin
- ####
-# $! = ($Num, $Text);
- ####
- # Test Section End
- ####
-
- $ErrConn = $Conn;
-}
-
-sub ClearError{
- my($self, $Num, $Text) = @_;
- if (ref $self){
- undef $self->{'ErrNum'};
- undef $self->{'ErrText'};
- }else{
- undef $ErrConn;
- undef $ErrNum;
- undef $ErrText;
- }
- ODBCCleanError();
- return 1;
-}
-
-
-sub GetError{
- my($self, $Connection) = @_;
- my(@Results);
- if (! ref($self)){
- $Connection = $self;
- $self = 0;
- }else{
- if (! defined($Connection)){
- $Connection = $self->{'connection'};
- }
- }
-
- @Results = ODBCGetError($Connection);
- return @Results;
-}
-
-
-
-
-# ----------------------------------------------------------------------------
-# ------------------ A U T O L O A D F U N C T I O N -----------------------
-
-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;
- $val = constant($constname);
-
- if ($! != 0) {
- if ($! =~ /Invalid/) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
-
- # Added by JOC 06-APR-96
- # $pack = 0;
- $pack = 0;
- ($pack,$file,$line) = caller;
- print "Your vendor has not defined Win32::ODBC macro $constname, used in $file at line $line.";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-
- # --------------------------------------------------------------
- #
- #
- # Make sure that we shutdown ODBC and free memory even if we are
- # using perlis.dll on Win32 platform!
-END{
-# ODBCShutDown() unless $CacheConnection;
-}
-
-
-bootstrap Win32::ODBC;
-
-# Preloaded methods go here.
-
-# Autoload methods go after __END__, and are processed by the autosplit program.
-
-1;
-__END__
-
-=head1 NAME
-
-Win32::ODBC - ODBC Extension for Win32
-
-=head1 SYNOPSIS
-
-To use this module, include the following statement at the top of your
-script:
-
- use Win32::ODBC;
-
-Next, create a data connection to your DSN:
-
- $Data = new Win32::ODBC("MyDSN");
-
-B<NOTE>: I<MyDSN> can be either the I<DSN> as defined in the ODBC
-Administrator, I<or> it can be an honest-to-God I<DSN Connect String>.
-
- Example: "DSN=My Database;UID=Brown Cow;PWD=Moo;"
-
-You should check to see if C<$Data> is indeed defined, otherwise there
-has been an error.
-
-You can now send SQL queries and retrieve info to your heart's
-content! See the description of the methods provided by this module
-below and also the file F<TEST.PL> as referred to in L<INSTALLATION
-NOTES> to see how it all works.
-
-Finally, B<MAKE SURE> that you close your connection when you are
-finished:
-
- $Data->Close();
-
-=head1 DESCRIPTION
-
-=head2 Background
-
-This is a hack of Dan DeMaggio's <dmag@umich.edu> F<NTXS.C> ODBC
-implementation. I have recoded and restructured most of it including
-most of the F<ODBC.PM> package, but its very core is still based on
-Dan's code (thanks Dan!).
-
-The history of this extension is found in the file F<HISTORY.TXT> that
-comes with the original archive (see L<INSTALLATION NOTES> below).
-
-=head2 Benefits
-
-And what are the benefits of this module?
-
-=over
-
-=item *
-
-The number of ODBC connections is limited by memory and ODBC itself
-(have as many as you want!).
-
-=item *
-
-The working limit for the size of a field is 10,240 bytes, but you can
-increase that limit (if needed) to a max of 2,147,483,647 bytes. (You
-can always recompile to increase the max limit.)
-
-=item *
-
-You can open a connection by either specifing a DSN or a connection
-string!
-
-=item *
-
-You can open and close the connections in any order!
-
-=item *
-
-Other things that I can not think of right now... :)
-
-=back
-
-=head1 CONSTANTS
-
-This package defines a number of constants. You may refer to each of
-these constants using the notation C<ODBC::xxxxx>, where C<xxxxx> is
-the constant.
-
-Example:
-
- print ODBC::SQL_SQL_COLUMN_NAME, "\n";
-
-=head1 SPECIAL NOTATION
-
-For the method documentation that follows, an B<*> following the
-method parameters indicates that that method is new or has been
-modified for this version.
-
-=head1 CONSTRUCTOR
-
-=over
-
-=item new ( ODBC_OBJECT | DSN [, (OPTION1, VALUE1), (OPTION2, VALUE2) ...] )
-*
-
-Creates a new ODBC connection based on C<DSN>, or, if you specify an
-already existing ODBC object, then a new ODBC object will be created
-but using the ODBC Connection specified by C<ODBC_OBJECT>. (The new
-object will be a new I<hstmt> using the I<hdbc> connection in
-C<ODBC_OBJECT>.)
-
-C<DSN> is I<Data Source Name> or a proper C<ODBCDriverConnect> string.
-
-You can specify SQL Connect Options that are implemented before the
-actual connection to the DSN takes place. These option/values are the
-same as specified in C<GetConnectOption>/C<SetConnectOption> (see
-below) and are defined in the ODBC API specs.
-
-Returns a handle to the database on success, or I<undef> on failure.
-
-=back
-
-=head1 METHODS
-
-=over
-
-=item Catalog ( QUALIFIER, OWNER, NAME, TYPE )
-
-Tells ODBC to create a data set that contains table information about
-the DSN. Use C<Fetch> and C<Data> or C<DataHash> to retrieve the data.
-The returned format is:
-
- [Qualifier] [Owner] [Name] [Type]
-
-Returns I<true> on error.
-
-=item ColAttributes ( ATTRIBUTE [, FIELD_NAMES ] )
-
-Returns the attribute C<ATTRIBUTE> on each of the fields in the list
-C<FIELD_NAMES> in the current record set. If C<FIELD_NAMES> is empty,
-then all fields are assumed. The attributes are returned as an
-associative array.
-
-=item ConfigDSN ( OPTION, DRIVER, ATTRIBUTE1 [, ATTRIBUTE2, ATTRIBUTE3, ...
-] )
-
-Configures a DSN. C<OPTION> takes on one of the following values:
-
- ODBC_ADD_DSN.......Adds a new DSN.
- ODBC_MODIFY_DSN....Modifies an existing DSN.
- ODBC_REMOVE_DSN....Removes an existing DSN.
-
- ODBC_ADD_SYS_DSN.......Adds a new System DSN.
- ODBC_MODIFY_SYS_DSN....Modifies an existing System DSN.
- ODBC_REMOVE_SYS_DSN....Removes an existing System DSN.
-
-You must specify the driver C<DRIVER> (which can be retrieved by using
-C<DataSources> or C<Drivers>).
-
-C<ATTRIBUTE1> B<should> be I<"DSN=xxx"> where I<xxx> is the name of
-the DSN. Other attributes can be any DSN attribute such as:
-
- "UID=Cow"
- "PWD=Moo"
- "Description=My little bitty Data Source Name"
-
-Returns I<true> on success, I<false> on failure.
-
-B<NOTE 1>: If you use C<ODBC_ADD_DSN>, then you must include at least
-I<"DSN=xxx"> and the location of the database.
-
-Example: For MS Access databases, you must specify the
-I<DatabaseQualifier>:
-
- "DBQ=c:\\...\\MyDatabase.mdb"
-
-B<NOTE 2>: If you use C<ODBC_MODIFY_DSN>, then you need only specify
-the I<"DNS=xxx"> attribute. Any other attribute you include will be
-changed to what you specify.
-
-B<NOTE 3>: If you use C<ODBC_REMOVE_DSN>, then you need only specify
-the I<"DSN=xxx"> attribute.
-
-=item Connection ()
-
-Returns the connection number associated with the ODBC connection.
-
-=item Close ()
-
-Closes the ODBC connection. No return value.
-
-=item Data ( [ FIELD_NAME ] )
-
-Returns the contents of column name C<FIELD_NAME> or the current row
-(if nothing is specified).
-
-=item DataHash ( [ FIELD1, FIELD2, ... ] )
-
-Returns the contents for C<FIELD1, FIELD2, ...> or the entire row (if
-nothing is specified) as an associative array consisting of:
-
- {Field Name} => Field Data
-
-=item DataSources ()
-
-Returns an associative array of Data Sources and ODBC remarks about them.
-They are returned in the form of:
-
- $ArrayName{'DSN'}=Driver
-
-where I<DSN> is the Data Source Name and ODBC Driver used.
-
-=item Debug ( [ 1 | 0 ] )
-
-Sets the debug option to on or off. If nothing is specified, then
-nothing is changed.
-
-Returns the debugging value (I<1> or I<0>).
-
-=item Drivers ()
-
-Returns an associative array of ODBC Drivers and their attributes.
-They are returned in the form of:
-
- $ArrayName{'DRIVER'}=Attrib1;Attrib2;Attrib3;...
-
-where I<DRIVER> is the ODBC Driver Name and I<AttribX> are the
-driver-defined attributes.
-
-=item DropCursor ( [ CLOSE_TYPE ] )
-
-Drops the cursor associated with the ODBC object. This forces the
-cursor to be deallocated. This overrides C<SetStmtCloseType>, but the
-ODBC object does not lose the C<StmtCloseType> setting. C<CLOSE_TYPE>
-can be any valid C<SmtpCloseType> and will perform a close on the stmt
-using the specified close type.
-
-Returns I<true> on success, I<false> on failure.
-
-=item DumpData ()
-
-Dumps to the screen the fieldnames and all records of the current data
-set. Used primarily for debugging. No return value.
-
-=item Error ()
-
-Returns the last encountered error. The returned value is context
-dependent:
-
-If called in a I<scalar> context, then a I<3-element array> is
-returned:
-
- ( ERROR_NUMBER, ERROR_TEXT, CONNECTION_NUMBER )
-
-If called in a I<string> context, then a I<string> is returned:
-
- "[ERROR_NUMBER] [CONNECTION_NUMBER] [ERROR_TEXT]"
-
-If debugging is on then two more variables are returned:
-
- ( ..., FUNCTION, LEVEL )
-
-where C<FUNCTION> is the name of the function in which the error
-occurred, and C<LEVEL> represents extra information about the error
-(usually the location of the error).
-
-=item FetchRow ( [ ROW [, TYPE ] ] )
-
-Retrieves the next record from the keyset. When C<ROW> and/or C<TYPE>
-are specified, the call is made using C<SQLExtendedFetch> instead of
-C<SQLFetch>.
-
-B<NOTE 1>: If you are unaware of C<SQLExtendedFetch> and its
-implications, stay with just regular C<FetchRow> with no parameters.
-
-B<NOTE 2>: The ODBC API explicitly warns against mixing calls to
-C<SQLFetch> and C<SQLExtendedFetch>; use one or the other but not
-both.
-
-If I<ROW> is specified, it moves the keyset B<RELATIVE> C<ROW> number
-of rows.
-
-If I<ROW> is specified and C<TYPE> is B<not>, then the type used is
-B<RELATIVE>.
-
-Returns I<true> when another record is available to read, and I<false>
-when there are no more records.
-
-=item FieldNames ()
-
-Returns an array of fieldnames found in the current data set. There is
-no guarantee on order.
-
-=item GetConnections ()
-
-Returns an array of connection numbers showing what connections are
-currently open.
-
-=item GetConnectOption ( OPTION )
-
-Returns the value of the specified connect option C<OPTION>. Refer to
-ODBC documentation for more information on the options and values.
-
-Returns a string or scalar depending upon the option specified.
-
-=item GetCursorName ()
-
-Returns the name of the current cursor as a string or I<undef>.
-
-=item GetData ()
-
-Retrieves the current row from the dataset. This is not generally
-used by users; it is used internally.
-
-Returns an array of field data where the first element is either
-I<false> (if successful) and I<true> (if B<not> successful).
-
-=item getDSN ( [ DSN ] )
-
-Returns an associative array indicating the configuration for the
-specified DSN.
-
-If no DSN is specified then the current connection is used.
-
-The returned associative array consists of:
-
- keys=DSN keyword; values=Keyword value. $Data{$Keyword}=Value
-
-=item GetFunctions ( [ FUNCTION1, FUNCTION2, ... ] )
-
-Returns an associative array indicating the ability of the ODBC Driver
-to support the specified functions. If no functions are specified,
-then a 100 element associative array is returned containing all
-possible functions and their values.
-
-C<FUNCTION> must be in the form of an ODBC API constant like
-C<SQL_API_SQLTRANSACT>.
-
-The returned array will contain the results like:
-
- $Results{SQL_API_SQLTRANSACT}=Value
-
-Example:
-
- $Results = $O->GetFunctions(
- $O->SQL_API_SQLTRANSACT,
- SQL_API_SQLSETCONNECTOPTION
- );
- $ConnectOption = $Results{SQL_API_SQLSETCONNECTOPTION};
- $Transact = $Results{SQL_API_SQLTRANSACT};
-
-=item GetInfo ( OPTION )
-
-Returns a string indicating the value of the particular
-option specified.
-
-=item GetMaxBufSize ()
-
-Returns the current allocated limit for I<MaxBufSize>. For more info,
-see C<SetMaxBufSize>.
-
-=item GetSQLState () *
-
-Returns a string indicating the SQL state as reported by ODBC. The SQL
-state is a code that the ODBC Manager or ODBC Driver returns after the
-execution of a SQL function. This is helpful for debugging purposes.
-
-=item GetStmtCloseType ( [ CONNECTION ] )
-
-Returns a string indicating the type of closure that will be used
-everytime the I<hstmt> is freed. See C<SetStmtCloseType> for details.
-
-By default, the connection of the current object will be used. If
-C<CONNECTION> is a valid connection number, then it will be used.
-
-=item GetStmtOption ( OPTION )
-
-Returns the value of the specified statement option C<OPTION>. Refer
-to ODBC documentation for more information on the options and values.
-
-Returns a string or scalar depending upon the option specified.
-
-=item MoreResults ()
-
-This will report whether there is data yet to be retrieved from the
-query. This can happen if the query was a multiple select.
-
-Example:
-
- "SELECT * FROM [foo] SELECT * FROM [bar]"
-
-B<NOTE>: Not all drivers support this.
-
-Returns I<1> if there is more data, I<undef> otherwise.
-
-=item RowCount ( CONNECTION )
-
-For I<UPDATE>, I<INSERT> and I<DELETE> statements, the returned value
-is the number of rows affected by the request or I<-1> if the number
-of affected rows is not available.
-
-B<NOTE 1>: This function is not supported by all ODBC drivers! Some
-drivers do support this but not for all statements (e.g., it is
-supported for I<UPDATE>, I<INSERT> and I<DELETE> commands but not for
-the I<SELECT> command).
-
-B<NOTE 2>: Many data sources cannot return the number of rows in a
-result set before fetching them; for maximum interoperability,
-applications should not rely on this behavior.
-
-Returns the number of affected rows, or I<-1> if not supported by the
-driver in the current context.
-
-=item Run ( SQL )
-
-Executes the SQL command B<SQL> and dumps to the screen info about
-it. Used primarily for debugging.
-
-No return value.
-
-=item SetConnectOption ( OPTION ) *
-
-Sets the value of the specified connect option B<OPTION>. Refer to
-ODBC documentation for more information on the options and values.
-
-Returns I<true> on success, I<false> otherwise.
-
-=item SetCursorName ( NAME ) *
-
-Sets the name of the current cursor.
-
-Returns I<true> on success, I<false> otherwise.
-
-=item SetPos ( ROW [, OPTION, LOCK ] ) *
-
-Moves the cursor to the row C<ROW> within the current keyset (B<not>
-the current data/result set).
-
-Returns I<true> on success, I<false> otherwise.
-
-=item SetMaxBufSize ( SIZE )
-
-This sets the I<MaxBufSize> for a particular connection. This will
-most likely never be needed but...
-
-The amount of memory that is allocated to retrieve the field data of a
-record is dynamic and changes when it need to be larger. I found that
-a memo field in an MS Access database ended up requesting 4 Gig of
-space. This was a bit much so there is an imposed limit (2,147,483,647
-bytes) that can be allocated for data retrieval.
-
-Since it is possible that someone has a database with field data
-greater than 10,240, you can use this function to increase the limit
-up to a ceiling of 2,147,483,647 (recompile if you need more).
-
-Returns the max number of bytes.
-
-=item SetStmtCloseType ( TYPE [, CONNECTION ] )
-
-Sets a particular I<hstmt> close type for the connection. This is the
-same as C<ODBCFreeStmt(hstmt, TYPE)>. By default, the connection of
-the current object will be used. If C<CONNECTION> is a valid
-connection number, then it will be used.
-
-C<TYPE> may be one of:
-
- SQL_CLOSE
- SQL_DROP
- SQL_UNBIND
- SQL_RESET_PARAMS
-
-Returns a string indicating the newly set type.
-
-=item SetStmtOption ( OPTION ) *
-
-Sets the value of the specified statement option C<OPTION>. Refer to
-ODBC documentation for more information on the options and values.
-
-Returns I<true> on success, I<false> otherwise.
-
-=item ShutDown ()
-
-Closes the ODBC connection and dumps to the screen info about
-it. Used primarily for debugging.
-
-No return value.
-
-=item Sql ( SQL_STRING )
-
-Executes the SQL command C<SQL_STRING> on the current connection.
-
-Returns I<?> on success, or an error number on failure.
-
-=item TableList ( QUALIFIER, OWNER, NAME, TYPE )
-
-Returns the catalog of tables that are available in the DSN. For an
-unknown parameter, just specify the empty string I<"">.
-
-Returns an array of table names.
-
-=item Transact ( TYPE ) *
-
-Forces the ODBC connection to perform a I<rollback> or I<commit>
-transaction.
-
-C<TYPE> may be one of:
-
- SQL_COMMIT
- SQL_ROLLBACK
-
-B<NOTE>: This only works with ODBC drivers that support transactions.
-Your driver supports it if I<true> is returned from:
-
- $O->GetFunctions($O->SQL_API_SQLTRANSACT)[1]
-
-(See C<GetFunctions> for more details.)
-
-Returns I<true> on success, I<false> otherwise.
-
-=item Version ( PACKAGES )
-
-Returns an array of version numbers for the requested packages
-(F<ODBC.pm> or F<ODBC.PLL>). If the list C<PACKAGES> is empty, then
-all version numbers are returned.
-
-=back
-
-=head1 LIMITATIONS
-
-What known problems does this thing have?
-
-=over
-
-=item *
-
-If the account under which the process runs does not have write
-permission on the default directory (for the process, not the ODBC
-DSN), you will probably get a runtime error during a
-C<SQLConnection>. I don't think that this is a problem with the code,
-but more like a problem with ODBC. This happens because some ODBC
-drivers need to write a temporary file. I noticed this using the MS
-Jet Engine (Access Driver).
-
-=item *
-
-This module has been neither optimized for speed nor optimized for
-memory consumption.
-
-=back
-
-=head1 INSTALLATION NOTES
-
-If you wish to use this module with a build of Perl other than
-ActivePerl, you may wish to fetch the original source distribution for
-this module at:
-
- ftp://ftp.roth.net:/pub/ntperl/ODBC/970208/Bin/Win32_ODBC_Build_CORE.zip
-
-or one of the other archives at that same location. See the included
-README for hints on installing this module manually, what to do if you
-get a I<parse exception>, and a pointer to a test script for this
-module.
-
-=head1 OTHER DOCUMENTATION
-
-Find a FAQ for Win32::ODBC at:
-
- http://www.roth.net/odbc/odbcfaq.htm
-
-=head1 AUTHOR
-
-Dave Roth <rothd@roth.net>
-
-=head1 CREDITS
-
-Based on original code by Dan DeMaggio <dmag@umich.edu>
-
-=head1 DISCLAIMER
-
-I do not guarantee B<ANYTHING> with this package. If you use it you
-are doing so B<AT YOUR OWN RISK>! I may or may not support this
-depending on my time schedule.
-
-=head1 HISTORY
-
-Last Modified 1999.09.25.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1996-1998 Dave Roth. All rights reserved.
-
-Courtesy of Roth Consulting: http://www.roth.net/consult/
-
-Use under GNU General Public License. Details can be found at:
-http://www.gnu.org/copyleft/gpl.html
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/PerfLib.pm b/Master/tlpkg/installer/perllib/Win32/PerfLib.pm
deleted file mode 100644
index 2b773d68f4b..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/PerfLib.pm
+++ /dev/null
@@ -1,538 +0,0 @@
-package Win32::PerfLib;
-
-use strict;
-use Carp;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
-
-require Exporter;
-require DynaLoader;
-require AutoLoader;
-
-@ISA = qw(Exporter DynaLoader);
-
-@EXPORT = qw(
- PERF_100NSEC_MULTI_TIMER
- PERF_100NSEC_MULTI_TIMER_INV
- PERF_100NSEC_TIMER
- PERF_100NSEC_TIMER_INV
- PERF_AVERAGE_BASE
- PERF_AVERAGE_BULK
- PERF_AVERAGE_TIMER
- PERF_COUNTER_BASE
- PERF_COUNTER_BULK_COUNT
- PERF_COUNTER_COUNTER
- PERF_COUNTER_DELTA
- PERF_COUNTER_ELAPSED
- PERF_COUNTER_FRACTION
- PERF_COUNTER_HISTOGRAM
- PERF_COUNTER_HISTOGRAM_TYPE
- PERF_COUNTER_LARGE_DELTA
- PERF_COUNTER_LARGE_QUEUELEN_TYPE
- PERF_COUNTER_LARGE_RAWCOUNT
- PERF_COUNTER_LARGE_RAWCOUNT_HEX
- PERF_COUNTER_MULTI_BASE
- PERF_COUNTER_MULTI_TIMER
- PERF_COUNTER_MULTI_TIMER_INV
- PERF_COUNTER_NODATA
- PERF_COUNTER_QUEUELEN
- PERF_COUNTER_QUEUELEN_TYPE
- PERF_COUNTER_RATE
- PERF_COUNTER_RAWCOUNT
- PERF_COUNTER_RAWCOUNT_HEX
- PERF_COUNTER_TEXT
- PERF_COUNTER_TIMER
- PERF_COUNTER_TIMER_INV
- PERF_COUNTER_VALUE
- PERF_DATA_REVISION
- PERF_DATA_VERSION
- PERF_DELTA_BASE
- PERF_DELTA_COUNTER
- PERF_DETAIL_ADVANCED
- PERF_DETAIL_EXPERT
- PERF_DETAIL_NOVICE
- PERF_DETAIL_WIZARD
- PERF_DISPLAY_NOSHOW
- PERF_DISPLAY_NO_SUFFIX
- PERF_DISPLAY_PERCENT
- PERF_DISPLAY_PER_SEC
- PERF_DISPLAY_SECONDS
- PERF_ELAPSED_TIME
- PERF_INVERSE_COUNTER
- PERF_MULTI_COUNTER
- PERF_NO_INSTANCES
- PERF_NO_UNIQUE_ID
- PERF_NUMBER_DECIMAL
- PERF_NUMBER_DEC_1000
- PERF_NUMBER_HEX
- PERF_OBJECT_TIMER
- PERF_RAW_BASE
- PERF_RAW_FRACTION
- PERF_SAMPLE_BASE
- PERF_SAMPLE_COUNTER
- PERF_SAMPLE_FRACTION
- PERF_SIZE_DWORD
- PERF_SIZE_LARGE
- PERF_SIZE_VARIABLE_LEN
- PERF_SIZE_ZERO
- PERF_TEXT_ASCII
- PERF_TEXT_UNICODE
- PERF_TIMER_100NS
- PERF_TIMER_TICK
- PERF_TYPE_COUNTER
- PERF_TYPE_NUMBER
- PERF_TYPE_TEXT
- PERF_TYPE_ZERO
- );
-
-$VERSION = '0.05';
-
-sub AUTOLOAD {
-
- my $constname;
- ($constname = $AUTOLOAD) =~ s/.*:://;
- local $! = 0;
- my $val = constant($constname);
- if ($! != 0) {
- if ($! =~ /Invalid/) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- croak "Your vendor has not defined Win32::PerfLib macro $constname";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-bootstrap Win32::PerfLib $VERSION;
-
-# Preloaded methods go here.
-
-sub new
-{
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $comp = shift;
- my $handle;
- my $self = {};
- if(PerfLibOpen($comp,$handle))
- {
- $self->{handle} = $handle;
- bless $self, $class;
- return $self;
- }
- else
- {
- return undef;
- }
-
-}
-
-sub Close
-{
- my $self = shift;
- return PerfLibClose($self->{handle});
-}
-
-sub DESTROY
-{
- my $self = shift;
- if(!PerfLibClose($self->{handle}))
- {
- croak "Error closing handle!\n";
- }
-}
-
-sub GetCounterNames
-{
- my($machine,$href) = @_;
- if(ref $href ne "HASH")
- {
- croak("usage: Win32::PerfLib::GetCounterNames(machine,hashRef)\n");
- }
- my($data,@data,$num,$name);
- my $retval = PerfLibGetNames($machine,$data);
- if($retval)
- {
- @data = split(/\0/, $data);
- while(@data)
- {
- $num = shift @data;
- $name = shift @data;
- $href->{$num} = $name;
- }
- }
- $retval;
-}
-
-sub GetCounterHelp
-{
- my($machine,$href) = @_;
- if(ref $href ne "HASH")
- {
- croak("usage: Win32::PerfLib::GetCounterHelp(machine,hashRef)\n");
- }
- my($data,@data,$num,$name);
- my $retval = PerfLibGetHelp($machine,$data);
- if($retval)
- {
- @data = split(/\0/, $data);
- while(@data)
- {
- $num = shift @data;
- $name = shift @data;
- $href->{$num} = $name;
- }
- }
- $retval;
-}
-
-sub GetObjectList
-{
- my $self = shift;
- my $object = shift;
- my $data = shift;
- if(ref $data ne "HASH")
- {
- croak("reference isn't a hash reference!\n");
- }
- return PerfLibGetObjects($self->{handle}, $object, $data);
-}
-
-sub GetCounterType
-{
- my $type = shift;
- my $retval;
- if( &Win32::PerfLib::PERF_100NSEC_MULTI_TIMER == $type )
- {
- $retval = "PERF_100NSEC_MULTI_TIMER";
- }
- elsif( &Win32::PerfLib::PERF_100NSEC_MULTI_TIMER_INV == $type )
- {
- $retval = "PERF_100NSEC_MULTI_TIMER_INV";
- }
- elsif( &Win32::PerfLib::PERF_100NSEC_TIMER == $type )
- {
- $retval = "PERF_100NSEC_TIMER";
- }
- elsif( &Win32::PerfLib::PERF_100NSEC_TIMER_INV == $type )
- {
- $retval = "PERF_100NSEC_TIMER_INV";
- }
- elsif( &Win32::PerfLib::PERF_AVERAGE_BASE == $type )
- {
- $retval = "PERF_AVERAGE_BASE";
- }
- elsif( &Win32::PerfLib::PERF_AVERAGE_BULK == $type )
- {
- $retval = "PERF_AVERAGE_BULK";
- }
- elsif( &Win32::PerfLib::PERF_AVERAGE_TIMER == $type )
- {
- $retval = "PERF_AVERAGE_TIMER";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_BULK_COUNT == $type )
- {
- $retval = "PERF_COUNTER_BULK_COUNT";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_COUNTER == $type )
- {
- $retval = "PERF_COUNTER_COUNTER";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_DELTA == $type )
- {
- $retval = "PERF_COUNTER_DELTA";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_DELTA == $type )
- {
- $retval = "PERF_COUNTER_LARGE_DELTA";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_QUEUELEN_TYPE == $type )
- {
- $retval = "PERF_COUNTER_LARGE_QUEUELEN_TYPE";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_RAWCOUNT == $type )
- {
- $retval = "PERF_COUNTER_LARGE_RAWCOUNT";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_RAWCOUNT_HEX == $type )
- {
- $retval = "PERF_COUNTER_LARGE_RAWCOUNT_HEX";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_MULTI_BASE == $type )
- {
- $retval = "PERF_COUNTER_MULTI_BASE";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_MULTI_TIMER == $type )
- {
- $retval = "PERF_COUNTER_MULTI_TIMER";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_MULTI_TIMER_INV == $type )
- {
- $retval = "PERF_COUNTER_MULTI_TIMER_INV";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_NODATA == $type )
- {
- $retval = "PERF_COUNTER_NODATA";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_QUEUELEN_TYPE == $type )
- {
- $retval = "PERF_COUNTER_QUEUELEN_TYPE";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_RAWCOUNT == $type )
- {
- $retval = "PERF_COUNTER_RAWCOUNT";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_RAWCOUNT_HEX == $type )
- {
- $retval = "PERF_COUNTER_RAWCOUNT_HEX";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_TEXT == $type )
- {
- $retval = "PERF_COUNTER_TEXT";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_TIMER == $type )
- {
- $retval = "PERF_COUNTER_TIMER";
- }
- elsif( &Win32::PerfLib::PERF_COUNTER_TIMER_INV == $type )
- {
- $retval = "PERF_COUNTER_TIMER_INV";
- }
- elsif( &Win32::PerfLib::PERF_ELAPSED_TIME == $type )
- {
- $retval = "PERF_ELAPSED_TIME";
- }
- elsif( &Win32::PerfLib::PERF_RAW_BASE == $type )
- {
- $retval = "PERF_RAW_BASE";
- }
- elsif( &Win32::PerfLib::PERF_RAW_FRACTION == $type )
- {
- $retval = "PERF_RAW_FRACTION";
- }
- elsif( &Win32::PerfLib::PERF_SAMPLE_BASE == $type )
- {
- $retval = "PERF_SAMPLE_BASE";
- }
- elsif( &Win32::PerfLib::PERF_SAMPLE_COUNTER == $type )
- {
- $retval = "PERF_SAMPLE_COUNTER";
- }
- elsif( &Win32::PerfLib::PERF_SAMPLE_FRACTION == $type )
- {
- $retval = "PERF_SAMPLE_FRACTION";
- }
- $retval;
-}
-
-
-
-1;
-__END__
-
-=head1 NAME
-
-Win32::PerfLib - accessing the Windows NT Performance Counter
-
-=head1 SYNOPSIS
-
- use Win32::PerfLib;
- my $server = "";
- Win32::PerfLib::GetCounterNames($server, \%counter);
- %r_counter = map { $counter{$_} => $_ } keys %counter;
- # retrieve the id for process object
- $process_obj = $r_counter{Process};
- # retrieve the id for the process ID counter
- $process_id = $r_counter{'ID Process'};
-
- # create connection to $server
- $perflib = new Win32::PerfLib($server);
- $proc_ref = {};
- # get the performance data for the process object
- $perflib->GetObjectList($process_obj, $proc_ref);
- $perflib->Close();
- $instance_ref = $proc_ref->{Objects}->{$process_obj}->{Instances};
- foreach $p (sort keys %{$instance_ref})
- {
- $counter_ref = $instance_ref->{$p}->{Counters};
- foreach $i (keys %{$counter_ref})
- {
- if($counter_ref->{$i}->{CounterNameTitleIndex} == $process_id)
- {
- printf( "% 6d %s\n", $counter_ref->{$i}->{Counter},
- $instance_ref->{$p}->{Name}
- );
- }
- }
- }
-
-=head1 DESCRIPTION
-
-This module allows to retrieve the performance counter of any computer
-(running Windows NT) in the network.
-
-=head1 FUNCTIONS
-
-=head2 NOTE
-
-All of the functions return false if they fail, unless otherwise noted.
-If the $server argument is undef the local machine is assumed.
-
-=over 10
-
-=item Win32::PerfLib::GetCounterNames($server,$hashref)
-
-Retrieves the counter names and their indices from the registry and stores them
-in the hash reference
-
-=item Win32::PerfLib::GetCounterHelp($server,$hashref)
-
-Retrieves the counter help strings and their indices from the registry and
-stores them in the hash reference
-
-=item $perflib = Win32::PerfLib->new ($server)
-
-Creates a connection to the performance counters of the given server
-
-=item $perflib->GetObjectList($objectid,$hashref)
-
-retrieves the object and counter list of the given performance object.
-
-=item $perflib->Close($hashref)
-
-closes the connection to the performance counters
-
-=item Win32::PerfLib::GetCounterType(countertype)
-
-converts the counter type to readable string as referenced in L<calc.html> so
-that it is easier to find the appropriate formula to calculate the raw counter
-data.
-
-=back
-
-=head1 Datastructures
-
-The performance data is returned in the following data structure:
-
-=over 10
-
-=item Level 1
-
- $hashref = {
- 'NumObjectTypes' => VALUE
- 'Objects' => HASHREF
- 'PerfFreq' => VALUE
- 'PerfTime' => VALUE
- 'PerfTime100nSec' => VALUE
- 'SystemName' => STRING
- 'SystemTime' => VALUE
- }
-
-=item Level 2
-
-The hash reference $hashref->{Objects} has the returned object ID(s) as keys and
-a hash reference to the object counter data as value. Even there is only one
-object requested in the call to GetObjectList there may be more than one object
-in the result.
-
- $hashref->{Objects} = {
- <object1> => HASHREF
- <object2> => HASHREF
- ...
- }
-
-=item Level 3
-
-Each returned object ID has object-specific performance information. If an
-object has instances like the process object there is also a reference to
-the instance information.
-
- $hashref->{Objects}->{<object1>} = {
- 'DetailLevel' => VALUE
- 'Instances' => HASHREF
- 'Counters' => HASHREF
- 'NumCounters' => VALUE
- 'NumInstances' => VALUE
- 'ObjectHelpTitleIndex' => VALUE
- 'ObjectNameTitleIndex' => VALUE
- 'PerfFreq' => VALUE
- 'PerfTime' => VALUE
- }
-
-=item Level 4
-
-If there are instance information for the object available they are stored in
-the 'Instances' hashref. If the object has no instances there is an 'Counters'
-key instead. The instances or counters are numbered.
-
- $hashref->{Objects}->{<object1>}->{Instances} = {
- <1> => HASHREF
- <2> => HASHREF
- ...
- <n> => HASHREF
- }
- or
- $hashref->{Objects}->{<object1>}->{Counters} = {
- <1> => HASHREF
- <2> => HASHREF
- ...
- <n> => HASHREF
- }
-
-=item Level 5
-
- $hashref->{Objects}->{<object1>}->{Instances}->{<1>} = {
- Counters => HASHREF
- Name => STRING
- ParentObjectInstance => VALUE
- ParentObjectTitleIndex => VALUE
- }
- or
- $hashref->{Objects}->{<object1>}->{Counters}->{<1>} = {
- Counter => VALUE
- CounterHelpTitleIndex => VALUE
- CounterNameTitleIndex => VALUE
- CounterSize => VALUE
- CounterType => VALUE
- DefaultScale => VALUE
- DetailLevel => VALUE
- Display => STRING
- }
-
-=item Level 6
-
- $hashref->{Objects}->{<object1>}->{Instances}->{<1>}->{Counters} = {
- <1> => HASHREF
- <2> => HASHREF
- ...
- <n> => HASHREF
- }
-
-=item Level 7
-
- $hashref->{Objects}->{<object1>}->{Instances}->{<1>}->{Counters}->{<1>} = {
- Counter => VALUE
- CounterHelpTitleIndex => VALUE
- CounterNameTitleIndex => VALUE
- CounterSize => VALUE
- CounterType => VALUE
- DefaultScale => VALUE
- DetailLevel => VALUE
- Display => STRING
- }
-
-Depending on the B<CounterType> there are calculations to do (see calc.html).
-
-=back
-
-=head1 AUTHOR
-
-Jutta M. Klebe, jmk@bybyte.de
-
-=head1 SEE ALSO
-
-perl(1).
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/Pipe.pm b/Master/tlpkg/installer/perllib/Win32/Pipe.pm
deleted file mode 100644
index a99d5a0da08..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Pipe.pm
+++ /dev/null
@@ -1,414 +0,0 @@
-package Win32::Pipe;
-
-$VERSION = '0.022';
-
-# Win32::Pipe.pm
-# +==========================================================+
-# | |
-# | PIPE.PM package |
-# | --------------- |
-# | Release v96.05.11 |
-# | |
-# | Copyright (c) 1996 Dave Roth. All rights reserved. |
-# | This program is free software; you can redistribute |
-# | it and/or modify it under the same terms as Perl itself. |
-# | |
-# +==========================================================+
-#
-#
-# Use under GNU General Public License or Larry Wall's "Artistic License"
-#
-# Check the README.TXT file that comes with this package for details about
-# it's history.
-#
-
-require Exporter;
-require 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.
-@EXPORT = qw();
-
-$ErrorNum = 0;
-$ErrorText = "";
-
-sub new
-{
- my ($self, $Pipe);
- my ($Type, $Name, $Time) = @_;
-
- if (! $Time){
- $Time = DEFAULT_WAIT_TIME();
- }
- $Pipe = PipeCreate($Name, $Time);
- if ($Pipe){
- $self = bless {};
- $self->{'Pipe'} = $Pipe;
- }else{
- ($ErrorNum, $ErrorText) = PipeError();
- return undef;
- }
- $self;
-}
-
-sub Write{
- my($self, $Data) = @_;
- $Data = PipeWrite($self->{'Pipe'}, $Data);
- return $Data;
-}
-
-sub Read{
- my($self) = @_;
- my($Data);
- $Data = PipeRead($self->{'Pipe'});
- return $Data;
-}
-
-sub Error{
- my($self) = @_;
- my($MyError, $MyErrorText, $Temp);
- if (! ref($self)){
- undef $Temp;
- }else{
- $Temp = $self->{'Pipe'};
- }
- ($MyError, $MyErrorText) = PipeError($Temp);
- return wantarray? ($MyError, $MyErrorText):"[$MyError] \"$MyErrorText\"";
-}
-
-
-sub Close{
- my ($self) = shift;
- PipeClose($self->{'Pipe'});
- $self->{'Pipe'} = 0;
-}
-
-sub Connect{
- my ($self) = @_;
- my ($Result);
- $Result = PipeConnect($self->{'Pipe'});
- return $Result;
-}
-
-sub Disconnect{
- my ($self, $iPurge) = @_;
- my ($Result);
- if (! $iPurge){
- $iPurge = 1;
- }
- $Result = PipeDisconnect($self->{'Pipe'}, $iPurge);
- return $Result;
-}
-
-sub BufferSize{
- my($self) = @_;
- my($Result) = PipeBufferSize($self->{'Pipe'});
- return $Result;
-}
-
-sub ResizeBuffer{
- my($self, $Size) = @_;
- my($Result) = PipeResizeBuffer($self->{'Pipe'}, $Size);
- return $Result;
-}
-
-
-####
-# Auto-Kill an instance of this module
-####
-sub DESTROY
-{
- my ($self) = shift;
- Close($self);
-}
-
-
-sub Credit{
- my($Name, $Version, $Date, $Author, $CompileDate, $CompileTime, $Credits) = Win32::Pipe::Info();
- my($Out, $iWidth);
- $iWidth = 60;
- $Out .= "\n";
- $Out .= " +". "=" x ($iWidth). "+\n";
- $Out .= " |". Center("", $iWidth). "|\n";
- $Out .= " |" . Center("", $iWidth). "|\n";
- $Out .= " |". Center("$Name", $iWidth). "|\n";
- $Out .= " |". Center("-" x length("$Name"), $iWidth). "|\n";
- $Out .= " |". Center("", $iWidth). "|\n";
-
- $Out .= " |". Center("Version $Version ($Date)", $iWidth). "|\n";
- $Out .= " |". Center("by $Author", $iWidth). "|\n";
- $Out .= " |". Center("Compiled on $CompileDate at $CompileTime.", $iWidth). "|\n";
- $Out .= " |". Center("", $iWidth). "|\n";
- $Out .= " |". Center("Credits:", $iWidth). "|\n";
- $Out .= " |". Center(("-" x length("Credits:")), $iWidth). "|\n";
- foreach $Temp (split("\n", $Credits)){
- $Out .= " |". Center("$Temp", $iWidth). "|\n";
- }
- $Out .= " |". Center("", $iWidth). "|\n";
- $Out .= " +". "=" x ($iWidth). "+\n";
- return $Out;
-}
-
-sub Center{
- local($Temp, $Width) = @_;
- local($Len) = ($Width - length($Temp)) / 2;
- return " " x int($Len) . $Temp . " " x (int($Len) + (($Len != int($Len))? 1:0));
-}
-
-# ------------------ A U T O L O A D F U N C T I O N ---------------------
-
-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;
- $val = constant($constname, @_ ? $_[0] : 0);
-
- if ($! != 0) {
- if ($! =~ /Invalid/) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
-
- # Added by JOC 06-APR-96
- # $pack = 0;
- $pack = 0;
- ($pack,$file,$line) = caller;
- print "Your vendor has not defined Win32::Pipe macro $constname, used in $file at line $line.";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-bootstrap Win32::Pipe;
-
-1;
-__END__
-
-=head1 NAME
-
-Win32::Pipe - Win32 Named Pipe
-
-=head1 SYNOPSIS
-
-To use this extension, follow these basic steps. First, you need to
-'use' the pipe extension:
-
- use Win32::Pipe;
-
-Then you need to create a server side of a named pipe:
-
- $Pipe = new Win32::Pipe("My Pipe Name");
-
-or if you are going to connect to pipe that has already been created:
-
- $Pipe = new Win32::Pipe("\\\\server\\pipe\\My Pipe Name");
-
- NOTE: The "\\\\server\\pipe\\" is necessary when connecting
- to an existing pipe! If you are accessing the same
- machine you could use "\\\\.\\pipe\\" but either way
- works fine.
-
-You should check to see if C<$Pipe> is indeed defined otherwise there
-has been an error.
-
-Whichever end is the server, it must now wait for a connection...
-
- $Result = $Pipe->Connect();
-
- NOTE: The client end does not do this! When the client creates
- the pipe it has already connected!
-
-Now you can read and write data from either end of the pipe:
-
- $Data = $Pipe->Read();
-
- $Result = $Pipe->Write("Howdy! This is cool!");
-
-When the server is finished it must disconnect:
-
- $Pipe->Disconnect();
-
-Now the server could C<Connect> again (and wait for another client) or
-it could destroy the named pipe...
-
- $Data->Close();
-
-The client should C<Close> in order to properly end the session.
-
-=head1 DESCRIPTION
-
-=head2 General Use
-
-This extension gives Win32 Perl the ability to use Named Pipes. Why?
-Well considering that Win32 Perl does not (yet) have the ability to
-C<fork> I could not see what good the C<pipe(X,Y)> was. Besides, where
-I am as an admin I must have several perl daemons running on several
-NT Servers. It dawned on me one day that if I could pipe all these
-daemons' output to my workstation (across the net) then it would be
-much easier to monitor. This was the impetus for an extension using
-Named Pipes. I think that it is kinda cool. :)
-
-=head2 Benefits
-
-And what are the benefits of this module?
-
-=over
-
-=item *
-
-You may create as many named pipes as you want (uh, well, as many as
-your resources will allow).
-
-=item *
-
-Currently there is a limit of 256 instances of a named pipe (once a
-pipe is created you can have 256 client/server connections to that
-name).
-
-=item *
-
-The default buffer size is 512 bytes; this can be altered by the
-C<ResizeBuffer> method.
-
-=item *
-
-All named pipes are byte streams. There is currently no way to alter a
-pipe to be message based.
-
-=item *
-
-Other things that I cannot think of right now... :)
-
-=back
-
-=head1 CONSTRUCTOR
-
-=over
-
-=item new ( NAME )
-
-Creates a named pipe if used in server context or a connection to the
-specified named pipe if used in client context. Client context is
-determined by prepending $Name with "\\\\".
-
-Returns I<true> on success, I<false> on failure.
-
-=back
-
-=head1 METHODS
-
-=over
-
-=item BufferSize ()
-
-Returns the size of the instance of the buffer of the named pipe.
-
-=item Connect ()
-
-Tells the named pipe to create an instance of the named pipe and wait
-until a client connects. Returns I<true> on success, I<false> on
-failure.
-
-=item Close ()
-
-Closes the named pipe.
-
-=item Disconnect ()
-
-Disconnects (and destroys) the instance of the named pipe from the
-client. Returns I<true> on success, I<false> on failure.
-
-=item Error ()
-
-Returns the last error messages pertaining to the named pipe. If used
-in context to the package. Returns a list containing C<ERROR_NUMBER>
-and C<ERROR_TEXT>.
-
-=item Read ()
-
-Reads from the named pipe. Returns data read from the pipe on success,
-undef on failure.
-
-=item ResizeBuffer ( SIZE )
-
-Sets the size of the buffer of the instance of the named pipe to
-C<SIZE>. Returns the size of the buffer on success, I<false> on
-failure.
-
-=item Write ( DATA )
-
-Writes C<DATA> to the named pipe. Returns I<true> on success, I<false>
-on failure.
-
-=back
-
-=head1 LIMITATIONS
-
-What known problems does this thing have?
-
-=over
-
-=item *
-
-If someone is waiting on a C<Read> and the other end terminates then
-you will wait for one B<REALLY> long time! (If anyone has an idea on
-how I can detect the termination of the other end let me know!)
-
-=item *
-
-All pipes are blocking. I am considering using threads and callbacks
-into Perl to perform async IO but this may be too much for my time
-stress. ;)
-
-=item *
-
-There is no security placed on these pipes.
-
-=item *
-
-This module has neither been optimized for speed nor optimized for
-memory consumption. This may run into memory bloat.
-
-=back
-
-=head1 INSTALLATION NOTES
-
-If you wish to use this module with a build of Perl other than
-ActivePerl, you may wish to fetch the source distribution for this
-module. The source is included as part of the C<libwin32> bundle,
-which you can find in any CPAN mirror here:
-
- modules/by-authors/Gurusamy_Sarathy/libwin32-0.151.tar.gz
-
-The source distribution also contains a pair of sample client/server
-test scripts. For the latest information on this module, consult the
-following web site:
-
- http://www.roth.net/perl
-
-=head1 AUTHOR
-
-Dave Roth <rothd@roth.net>
-
-=head1 DISCLAIMER
-
-I do not guarantee B<ANYTHING> with this package. If you use it you
-are doing so B<AT YOUR OWN RISK>! I may or may not support this
-depending on my time schedule.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1996 Dave Roth. 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/installer/perllib/Win32/Process.pm b/Master/tlpkg/installer/perllib/Win32/Process.pm
deleted file mode 100644
index f07169b4080..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Process.pm
+++ /dev/null
@@ -1,217 +0,0 @@
-package Win32::Process;
-
-require Exporter;
-require DynaLoader;
-@ISA = qw(Exporter DynaLoader);
-
-$VERSION = '0.10';
-
-# 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
-);
-
-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).
-
-=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:
-
- STILL_ACTIVE
-
-=cut
-
-# Local Variables:
-# tmtrack-file-task: "Win32::Process"
-# End:
diff --git a/Master/tlpkg/installer/perllib/Win32/Registry.pm b/Master/tlpkg/installer/perllib/Win32/Registry.pm
deleted file mode 100644
index c83fca5a3b1..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Registry.pm
+++ /dev/null
@@ -1,547 +0,0 @@
-package Win32::Registry;
-
-=head1 NAME
-
-Win32::Registry - accessing the Windows registry [obsolete, use Win32::TieRegistry]
-
-=head1 SYNOPSIS
-
- use Win32::Registry;
- my $tips;
- $::HKEY_LOCAL_MACHINE->Open("SOFTWARE\\Microsoft\\Windows"
- ."\\CurrentVersion\\Explorer\\Tips", $tips)
- or die "Can't open tips: $^E";
- my ($type, $value);
- $tips->QueryValueEx("18", $type, $value) or die "No tip #18: $^E";
- print "Here's a tip: $value\n";
-
-=head1 DESCRIPTION
-
- NOTE: This module provides a very klunky interface to access the
- Windows registry, and is not currently being developed actively. It
- only exists for backward compatibility with old code that uses it.
- For more powerful and flexible ways to access the registry, use
- Win32::TieRegistry.
-
-Win32::Registry provides an object oriented interface to the Windows
-Registry.
-
-The following "root" registry objects are exported to the main:: name
-space. Additional keys must be opened by calling the provided methods
-on one of these.
-
- $HKEY_CLASSES_ROOT
- $HKEY_CURRENT_USER
- $HKEY_LOCAL_MACHINE
- $HKEY_USERS
- $HKEY_PERFORMANCE_DATA
- $HKEY_CURRENT_CONFIG
- $HKEY_DYN_DATA
-
-=cut
-
-use strict;
-require Exporter;
-require DynaLoader;
-use Win32::WinError;
-
-require Win32 unless defined &Win32::GetLastError;
-
-use vars qw($VERSION $AUTOLOAD @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
-
-$VERSION = '0.07';
-
-@ISA = qw( Exporter DynaLoader );
-@EXPORT = qw(
- HKEY_CLASSES_ROOT
- HKEY_CURRENT_USER
- HKEY_LOCAL_MACHINE
- HKEY_PERFORMANCE_DATA
- HKEY_CURRENT_CONFIG
- HKEY_DYN_DATA
- HKEY_USERS
- KEY_ALL_ACCESS
- KEY_CREATE_LINK
- KEY_CREATE_SUB_KEY
- KEY_ENUMERATE_SUB_KEYS
- KEY_EXECUTE
- KEY_NOTIFY
- KEY_QUERY_VALUE
- KEY_READ
- KEY_SET_VALUE
- KEY_WRITE
- REG_BINARY
- REG_CREATED_NEW_KEY
- REG_DWORD
- REG_DWORD_BIG_ENDIAN
- REG_DWORD_LITTLE_ENDIAN
- REG_EXPAND_SZ
- REG_FULL_RESOURCE_DESCRIPTOR
- REG_LEGAL_CHANGE_FILTER
- REG_LEGAL_OPTION
- REG_LINK
- REG_MULTI_SZ
- REG_NONE
- REG_NOTIFY_CHANGE_ATTRIBUTES
- REG_NOTIFY_CHANGE_LAST_SET
- REG_NOTIFY_CHANGE_NAME
- REG_NOTIFY_CHANGE_SECURITY
- REG_OPENED_EXISTING_KEY
- REG_OPTION_BACKUP_RESTORE
- REG_OPTION_CREATE_LINK
- REG_OPTION_NON_VOLATILE
- REG_OPTION_RESERVED
- REG_OPTION_VOLATILE
- REG_REFRESH_HIVE
- REG_RESOURCE_LIST
- REG_RESOURCE_REQUIREMENTS_LIST
- REG_SZ
- REG_WHOLE_HIVE_VOLATILE
-);
-
-@EXPORT_OK = qw(
- RegCloseKey
- RegConnectRegistry
- RegCreateKey
- RegCreateKeyEx
- RegDeleteKey
- RegDeleteValue
- RegEnumKey
- RegEnumValue
- RegFlushKey
- RegGetKeySecurity
- RegLoadKey
- RegNotifyChangeKeyValue
- RegOpenKey
- RegOpenKeyEx
- RegQueryInfoKey
- RegQueryValue
- RegQueryValueEx
- RegReplaceKey
- RegRestoreKey
- RegSaveKey
- RegSetKeySecurity
- RegSetValue
- RegSetValueEx
- RegUnLoadKey
-);
-$EXPORT_TAGS{ALL}= \@EXPORT_OK;
-
-bootstrap Win32::Registry;
-
-sub import {
- my $pkg = shift;
- if ($_[0] && "Win32" eq $_[0]) {
- Exporter::export($pkg, "Win32", @EXPORT_OK);
- shift;
- }
- Win32::Registry->export_to_level(1+$Exporter::ExportLevel, $pkg, @_);
-}
-
-#######################################################################
-# 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 $! = 0;
- my $val = constant($constname, 0);
- if ($! != 0) {
- if ($! =~ /Invalid/) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- my ($pack,$file,$line) = caller;
- die "Unknown constant $constname in Win32::Registry "
- . "at $file line $line.\n";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-#######################################################################
-# _new is a private constructor, not intended for public use.
-#
-
-sub _new {
- my $self;
- if ($_[0]) {
- $self->{'handle'} = $_[0];
- bless $self;
- }
- $self;
-}
-
-#define the basic registry objects to be exported.
-#these had to be hardwired unfortunately.
-# XXX Yuck!
-
-{
- package main;
- use vars qw(
- $HKEY_CLASSES_ROOT
- $HKEY_CURRENT_USER
- $HKEY_LOCAL_MACHINE
- $HKEY_USERS
- $HKEY_PERFORMANCE_DATA
- $HKEY_CURRENT_CONFIG
- $HKEY_DYN_DATA
- );
-}
-
-$::HKEY_CLASSES_ROOT = _new(&HKEY_CLASSES_ROOT);
-$::HKEY_CURRENT_USER = _new(&HKEY_CURRENT_USER);
-$::HKEY_LOCAL_MACHINE = _new(&HKEY_LOCAL_MACHINE);
-$::HKEY_USERS = _new(&HKEY_USERS);
-$::HKEY_PERFORMANCE_DATA = _new(&HKEY_PERFORMANCE_DATA);
-$::HKEY_CURRENT_CONFIG = _new(&HKEY_CURRENT_CONFIG);
-$::HKEY_DYN_DATA = _new(&HKEY_DYN_DATA);
-
-=head2 Methods
-
-The following methods are supported. Note that subkeys can be
-specified as a path name, separated by backslashes (which may
-need to be doubled if you put them in double quotes).
-
-=over 8
-
-=item Open
-
- $reg_obj->Open($sub_key_name, $sub_reg_obj);
-
-Opens a subkey of a registry object, returning the new registry object
-in $sub_reg_obj.
-
-=cut
-
-sub Open {
- my $self = shift;
- die 'usage: $obj->Open($sub_key_name, $sub_reg_obj)' if @_ != 2;
-
- my ($subkey) = @_;
- my ($result,$subhandle);
-
- $result = RegOpenKey($self->{'handle'},$subkey,$subhandle);
- $_[1] = _new($subhandle);
-
- return 0 unless $_[1];
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item Close
-
- $reg_obj->Close();
-
-Closes an open registry key.
-
-=cut
-
-sub Close {
- my $self = shift;
- die 'usage: $obj->Close()' if @_ != 0;
-
- return unless exists $self->{'handle'};
- my $result = RegCloseKey($self->{'handle'});
- if ($result) {
- delete $self->{'handle'};
- }
- else {
- $! = Win32::GetLastError();
- }
- return $result;
-}
-
-sub DESTROY {
- my $self = shift;
- return unless exists $self->{'handle'};
- RegCloseKey($self->{'handle'});
- delete $self->{'handle'};
-}
-
-
-=item Connect
-
- $reg_obj->Connect($node_name, $new_reg_obj);
-
-Connects to a remote Registry on the node specified by $node_name,
-returning it in $new_reg_obj. Returns false if it fails.
-
-=cut
-
-sub Connect {
- my $self = shift;
- die 'usage: $obj->Connect($node_name, $new_reg_obj)' if @_ != 2;
-
- my ($node) = @_;
- my ($result,$subhandle);
-
- $result = RegConnectRegistry ($node, $self->{'handle'}, $subhandle);
- $_[1] = _new($subhandle);
-
- return 0 unless $_[1];
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item Create
-
- $reg_obj->Create($sub_key_name, $new_reg_obj);
-
-Opens the subkey specified by $sub_key_name, returning the new registry
-object in $new_reg_obj. If the specified subkey doesn't exist, it is
-created.
-
-=cut
-
-sub Create {
- my $self = shift;
- die 'usage: $obj->Create($sub_key_name, $new_reg_obj)' if @_ != 2;
-
- my ($subkey) = @_;
- my ($result,$subhandle);
-
- $result = RegCreateKey($self->{'handle'},$subkey,$subhandle);
- $_[1] = _new ($subhandle);
-
- return 0 unless $_[1];
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item SetValue
-
- $reg_obj->SetValue($sub_key_name, $type, $value);
-
-Sets the default value for a subkey specified by $sub_key_name.
-
-=cut
-
-sub SetValue {
- my $self = shift;
- die 'usage: $obj->SetValue($subkey, $type, $value)' if @_ != 3;
- my $result = RegSetValue($self->{'handle'}, @_);
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item SetValueEx
-
- $reg_obj->SetValueEx($value_name, $reserved, $type, $value);
-
-Sets the value for the value name identified by $value_name
-in the key specified by $reg_obj.
-
-=cut
-
-sub SetValueEx {
- my $self = shift;
- die 'usage: $obj->SetValueEx($value_name, $reserved, $type, $value)' if @_ != 4;
- my $result = RegSetValueEx($self->{'handle'}, @_);
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item QueryValue
-
- $reg_obj->QueryValue($sub_key_name, $value);
-
-Gets the default value of the subkey specified by $sub_key_name.
-
-=cut
-
-sub QueryValue {
- my $self = shift;
- die 'usage: $obj->QueryValue($sub_key_name, $value)' if @_ != 2;
- my $result = RegQueryValue($self->{'handle'}, $_[0], $_[1]);
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item QueryKey
-
- $reg_obj->QueryKey($classref, $number_of_subkeys, $number_of_values);
-
-Gets information on a key specified by $reg_obj.
-
-=cut
-
-sub QueryKey {
- my $garbage;
- my $self = shift;
- die 'usage: $obj->QueryKey($classref, $number_of_subkeys, $number_of_values)'
- if @_ != 3;
-
- my $result = RegQueryInfoKey($self->{'handle'}, $_[0],
- $garbage, $garbage, $_[1],
- $garbage, $garbage, $_[2],
- $garbage, $garbage, $garbage, $garbage);
-
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item QueryValueEx
-
- $reg_obj->QueryValueEx($value_name, $type, $value);
-
-Gets the value for the value name identified by $value_name
-in the key specified by $reg_obj.
-
-=cut
-
-sub QueryValueEx {
- my $self = shift;
- die 'usage: $obj->QueryValueEx($value_name, $type, $value)' if @_ != 3;
- my $result = RegQueryValueEx($self->{'handle'}, $_[0], undef, $_[1], $_[2]);
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item GetKeys
-
- my @keys;
- $reg_obj->GetKeys(\@keys);
-
-Populates the supplied array reference with the names of all the keys
-within the registry object $reg_obj.
-
-=cut
-
-sub GetKeys {
- my $self = shift;
- die 'usage: $obj->GetKeys($arrayref)' if @_ != 1 or ref($_[0]) ne 'ARRAY';
-
- my ($result, $i, $keyname);
- $keyname = "DummyVal";
- $i = 0;
- $result = 1;
-
- while ( $result ) {
- $result = RegEnumKey( $self->{'handle'},$i++, $keyname );
- if ($result) {
- push( @{$_[0]}, $keyname );
- }
- }
- return(1);
-}
-
-=item GetValues
-
- my %values;
- $reg_obj->GetValues(\%values);
-
-Populates the supplied hash reference with entries of the form
-
- $value_name => [ $value_name, $type, $data ]
-
-for each value in the registry object $reg_obj.
-
-=cut
-
-sub GetValues {
- my $self = shift;
- die 'usage: $obj->GetValues($hashref)' if @_ != 1;
-
- my ($result,$name,$type,$data,$i);
- $name = "DummyVal";
- $i = 0;
- while ( $result=RegEnumValue( $self->{'handle'},
- $i++,
- $name,
- undef,
- $type,
- $data ))
- {
- $_[0]->{$name} = [ $name, $type, $data ];
- }
- return(1);
-}
-
-=item DeleteKey
-
- $reg_obj->DeleteKey($sub_key_name);
-
-Deletes a subkey specified by $sub_key_name from the registry.
-
-=cut
-
-sub DeleteKey {
- my $self = shift;
- die 'usage: $obj->DeleteKey($sub_key_name)' if @_ != 1;
- my $result = RegDeleteKey($self->{'handle'}, @_);
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item DeleteValue
-
- $reg_obj->DeleteValue($value_name);
-
-Deletes a value identified by $value_name from the registry.
-
-=cut
-
-sub DeleteValue {
- my $self = shift;
- die 'usage: $obj->DeleteValue($value_name)' if @_ != 1;
- my $result = RegDeleteValue($self->{'handle'}, @_);
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item Save
-
- $reg_obj->Save($filename);
-
-Saves the hive specified by $reg_obj to a file.
-
-=cut
-
-sub Save {
- my $self = shift;
- die 'usage: $obj->Save($filename)' if @_ != 1;
- my $result = RegSaveKey($self->{'handle'}, @_);
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item Load
-
- $reg_obj->Load($sub_key_name, $file_name);
-
-Loads a key specified by $sub_key_name from a file.
-
-=cut
-
-sub Load {
- my $self = shift;
- die 'usage: $obj->Load($sub_key_name, $file_name)' if @_ != 2;
- my $result = RegLoadKey($self->{'handle'}, @_);
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-=item UnLoad
-
- $reg_obj->Unload($sub_key_name);
-
-Unloads a registry hive.
-
-=cut
-
-sub UnLoad {
- my $self = shift;
- die 'usage: $obj->UnLoad($sub_key_name)' if @_ != 1;
- my $result = RegUnLoadKey($self->{'handle'}, @_);
- $! = Win32::GetLastError() unless $result;
- return $result;
-}
-
-1;
-__END__
diff --git a/Master/tlpkg/installer/perllib/Win32/Semaphore.pm b/Master/tlpkg/installer/perllib/Win32/Semaphore.pm
deleted file mode 100644
index 2e2096eb6ed..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Semaphore.pm
+++ /dev/null
@@ -1,128 +0,0 @@
-#---------------------------------------------------------------------
-package Win32::Semaphore;
-#
-# Copyright 1998 Christopher J. Madsen
-#
-# Created: 3 Feb 1998 from the ActiveWare version
-# (c) 1995 Microsoft Corporation. All rights reserved.
-# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com
-#
-# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com>
-#
-# Author: Christopher J. Madsen <cjm@pobox.com>
-# Version: 1.00 (6-Feb-1998)
-#
-# This program 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. See either the
-# GNU General Public License or the Artistic License for more details.
-#
-# Use Win32 semaphore objects for synchronization
-#---------------------------------------------------------------------
-
-$VERSION = '1.02';
-
-use Win32::IPC 1.00 '/./'; # Import everything
-require Exporter;
-require DynaLoader;
-
-@ISA = qw(Exporter DynaLoader Win32::IPC);
-@EXPORT_OK = qw(
- wait_all wait_any
-);
-
-bootstrap Win32::Semaphore;
-
-sub Create { $_[0] = new('Win32::Semaphore',@_[1..3]) }
-sub Open { $_[0] = Win32::Semaphore->open($_[1]) }
-sub Release { &release }
-
-1;
-__END__
-
-=head1 NAME
-
-Win32::Semaphore - Use Win32 semaphore objects from Perl
-
-=head1 SYNOPSIS
- require Win32::Semaphore;
-
- $sem = Win32::Semaphore->new($initial,$maximum,$name);
- $sem->wait;
-
-=head1 DESCRIPTION
-
-This module allows access to Win32 semaphore objects. The C<wait>
-method and C<wait_all> & C<wait_any> functions are inherited from the
-L<"Win32::IPC"> module.
-
-=head2 Methods
-
-=over 4
-
-=item $semaphore = Win32::Semaphore->new($initial, $maximum, [$name])
-
-Constructor for a new semaphore object. C<$initial> is the initial
-count, and C<$maximum> is the maximum count for the semaphore. If
-C<$name> is omitted, creates an unnamed semaphore object.
-
-If C<$name> signifies an existing semaphore object, then C<$initial>
-and C<$maximum> are ignored and the object is opened. If this
-happens, C<$^E> will be set to 183 (ERROR_ALREADY_EXISTS).
-
-=item $semaphore = Win32::Semaphore->open($name)
-
-Constructor for opening an existing semaphore object.
-
-=item $semaphore->release([$increment, [$previous]])
-
-Increment the count of C<$semaphore> by C<$increment> (default 1).
-If C<$increment> plus the semaphore's current count is more than its
-maximum count, the count is not changed. Returns true if the
-increment is successful.
-
-The semaphore's count (before incrementing) is stored in the second
-argument (if any).
-
-It is not necessary to wait on a semaphore before calling C<release>,
-but you'd better know what you're doing.
-
-=item $semaphore->wait([$timeout])
-
-Wait for C<$semaphore>'s count to be nonzero, then decrement it by 1.
-See L<"Win32::IPC">.
-
-=back
-
-=head2 Deprecated Functions and Methods
-
-B<Win32::Semaphore> still supports the ActiveWare syntax, but its use
-is deprecated.
-
-=over 4
-
-=item Win32::Semaphore::Create($SemObject,$Initial,$Max,$Name)
-
-Use C<$SemObject = Win32::Semaphore-E<gt>new($Initial,$Max,$Name)> instead.
-
-=item Win32::Semaphore::Open($SemObject, $Name)
-
-Use C<$SemObject = Win32::Semaphore-E<gt>open($Name)> instead.
-
-=item $SemObj->Release($Count,$LastVal)
-
-Use C<$SemObj-E<gt>release($Count,$LastVal)> instead.
-
-=back
-
-=head1 AUTHOR
-
-Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt>
-
-Loosely based on the original module by ActiveWare Internet Corp.,
-F<http://www.ActiveWare.com>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/Server.pl b/Master/tlpkg/installer/perllib/Win32/Server.pl
deleted file mode 100644
index ecfb91ba864..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Server.pl
+++ /dev/null
@@ -1,48 +0,0 @@
-use strict;
-use Win32::Pipe;
-
-my $PipeName = "TEST this long named pipe!";
-my $NewSize = 2048;
-my $iMessage;
-
-while () {
- print "Creating pipe \"$PipeName\".\n";
- if (my $Pipe = new Win32::Pipe($PipeName)) {
- my $PipeSize = $Pipe->BufferSize();
- print "This pipe's current size is $PipeSize byte" . (($PipeSize == 1)? "":"s") . ".\nWe shall change it to $NewSize ...";
- print +(($Pipe->ResizeBuffer($NewSize) == $NewSize)? "Successful":"Unsucessful") . "!\n\n";
-
- print "\n\nR e a d y f o r r e a d i n g :\n";
- print "-----------------------------------\n";
-
- print "Openning the pipe...\n";
- while ($Pipe->Connect()) {
- while () {
- ++$iMessage;
- print "Reading Message #$iMessage: ";
- my $In = $Pipe->Read();
- unless ($In) {
- print "Recieved no data, closing connection....\n";
- last;
- }
- if ($In =~ /^quit/i){
- print "\n\nQuitting this connection....\n";
- last;
- }
- elsif ($In =~ /^exit/i){
- print "\n\nExitting.....\n";
- exit;
- }
- else{
- print "\"$In\"\n";
- }
- }
- print "Disconnecting...\n";
- $Pipe->Disconnect();
- }
- print "Closing...\n";
- $Pipe->Close();
- }
-}
-
-print "You can't get here...\n";
diff --git a/Master/tlpkg/installer/perllib/Win32/Service.pm b/Master/tlpkg/installer/perllib/Win32/Service.pm
deleted file mode 100644
index 0ae33b13ef8..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Service.pm
+++ /dev/null
@@ -1,103 +0,0 @@
-package Win32::Service;
-
-#
-# Service.pm
-# Written by Douglas_Lankshear@ActiveWare.com
-#
-# subsequently hacked by Gurusamy Sarathy <gsar@activestate.com>
-#
-
-$VERSION = '0.05';
-
-require Exporter;
-require DynaLoader;
-
-require Win32 unless defined &Win32::IsWinNT;
-die "The Win32::Service module works only on Windows NT" unless Win32::IsWinNT();
-
-@ISA= qw( Exporter DynaLoader );
-@EXPORT_OK =
- qw(
- StartService
- StopService
- GetStatus
- PauseService
- ResumeService
- GetServices
- );
-
-=head1 NAME
-
-Win32::Service - manage system services in perl
-
-=head1 SYNOPSIS
-
- use Win32::Service;
-
-=head1 DESCRIPTION
-
-This module offers control over the administration of system services.
-
-=head1 FUNCTIONS
-
-=head2 NOTE:
-
-All of the functions return false if they fail, unless otherwise noted.
-If hostName is an empty string, the local machine is assumed.
-
-=over 10
-
-=item StartService(hostName, serviceName)
-
-Start the service serviceName on machine hostName.
-
-=item StopService(hostName, serviceName)
-
-Stop the service serviceName on the machine hostName.
-
-=item GetStatus(hostName, serviceName, status)
-
-Get the status of a service. The third argument must be a hash
-reference that will be populated with entries corresponding
-to the SERVICE_STATUS structure of the Win32 API. See the
-Win32 Platform SDK documentation for details of this structure.
-
-=item PauseService(hostName, serviceName)
-
-=item ResumeService(hostName, serviceName)
-
-=item GetServices(hostName, hashref)
-
-Enumerates both active and inactive Win32 services at the specified host.
-The hashref is populated with the descriptive service names as keys
-and the short names as the values.
-
-=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::Service macro $constname, used in $file at line $line.";
- }
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-bootstrap Win32::Service;
-
-1;
-__END__
diff --git a/Master/tlpkg/installer/perllib/Win32/Shortcut.pm b/Master/tlpkg/installer/perllib/Win32/Shortcut.pm
deleted file mode 100644
index d4dadafdcf2..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Shortcut.pm
+++ /dev/null
@@ -1,323 +0,0 @@
-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.04";
-
-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 $self = {};
- my $ilink = 0;
- my $ifile = 0;
-
- ($ilink, $ifile) = _Instance();
-
- if($ilink and $ifile) {
- $self->{'ilink'} = $ilink;
- $self->{'ifile'} = $ifile;
- bless $self;
- # Initialize properties
- $self->{'File'} = "";
- $self->{'Path'} = "";
- $self->{'Arguments'} = "";
- $self->{'WorkingDirectory'} = "";
- $self->{'Description'} = "";
- $self->{'ShowCmd'} = 0;
- $self->{'Hotkey'} = 0;
- $self->{'IconLocation'} = "";
- $self->{'IconNumber'} = 0;
-
- $self->Load($file) if $file;
-
- } else {
- return undef;
- }
- $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;
diff --git a/Master/tlpkg/installer/perllib/Win32/Sound.pm b/Master/tlpkg/installer/perllib/Win32/Sound.pm
deleted file mode 100644
index a8d52a95117..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Sound.pm
+++ /dev/null
@@ -1,582 +0,0 @@
-#######################################################################
-#
-# Win32::Sound - An extension to play with Windows sounds
-#
-# Author: Aldo Calpini <dada@divinf.it>
-# Version: 0.47
-# Info:
-# http://www.divinf.it/dada/perl
-# http://www.perl.com/CPAN/authors/Aldo_Calpini
-#
-#######################################################################
-# Version history:
-# 0.01 (19 Nov 1996) file created
-# 0.03 (08 Apr 1997) first release
-# 0.30 (20 Oct 1998) added Volume/Format/Devices/DeviceInfo
-# (thanks Dave Roth!)
-# 0.40 (16 Mar 1999) added the WaveOut object
-# 0.45 (09 Apr 1999) added $! support, documentation et goodies
-# 0.46 (25 Sep 1999) fixed small bug in DESTROY, wo was used without being
-# initialized (Gurusamy Sarathy <gsar@activestate.com>)
-# 0.47 (22 May 2000) support for passing Unicode string to Play()
-# (Doug Lankshear <dougl@activestate.com>)
-
-package Win32::Sound;
-
-# See the bottom of this file for the POD documentation.
-# Search for the string '=head'.
-
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
-
-@ISA= qw( Exporter DynaLoader );
-@EXPORT = qw(
- SND_ASYNC
- SND_NODEFAULT
- SND_LOOP
- SND_NOSTOP
-);
-
-#######################################################################
-# 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 $! = 0;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
-
- # [dada] This results in an ugly Autoloader error
-
- #if ($! =~ /Invalid/) {
- # $AutoLoader::AUTOLOAD = $AUTOLOAD;
- # goto &AutoLoader::AUTOLOAD;
- #} else {
-
- # [dada] ... I prefer this one :)
-
- ($pack, $file, $line) = caller;
- undef $pack; # [dada] and get rid of "used only once" warning...
- die "Win32::Sound::$constname is not defined, used at $file line $line.";
-
- #}
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-
-#######################################################################
-# STATIC OBJECT PROPERTIES
-#
-$VERSION="0.47";
-undef unless $VERSION; # [dada] to avoid "possible typo" warning
-
-#######################################################################
-# METHODS
-#
-
-sub Version { $VERSION }
-
-sub Volume {
- my(@in) = @_;
- # Allows '0%'..'100%'
- $in[0] =~ s{ ([\d\.]+)%$ }{ int($1*100/255) }ex if defined $in[0];
- $in[1] =~ s{ ([\d\.]+)%$ }{ int($1*100/255) }ex if defined $in[1];
- _Volume(@in);
-}
-
-#######################################################################
-# dynamically load in the Sound.dll module.
-#
-
-bootstrap Win32::Sound;
-
-#######################################################################
-# Win32::Sound::WaveOut
-#
-
-package Win32::Sound::WaveOut;
-
-sub new {
- my($class, $one, $two, $three) = @_;
- my $self = {};
- bless($self, $class);
-
- if($one !~ /^\d+$/
- and not defined($two)
- and not defined($three)) {
- # Looks like a file
- $self->Open($one);
- } else {
- # Default format if not given
- $self->{samplerate} = ($one or 44100);
- $self->{bits} = ($two or 16);
- $self->{channels} = ($three or 2);
- $self->OpenDevice();
- }
- return $self;
-}
-
-sub Volume {
- my(@in) = @_;
- # Allows '0%'..'100%'
- $in[0] =~ s{ ([\d\.]+)%$ }{ int($1*255/100) }ex if defined $in[0];
- $in[1] =~ s{ ([\d\.]+)%$ }{ int($1*255/100) }ex if defined $in[1];
- _Volume(@in);
-}
-
-sub Pitch {
- my($self, $pitch) = @_;
- my($int, $frac);
- if(defined($pitch)) {
- $pitch =~ /(\d+).?(\d+)?/;
- $int = $1;
- $frac = $2 or 0;
- $int = $int << 16;
- $frac = eval("0.$frac * 65536");
- $pitch = $int + $frac;
- return _Pitch($self, $pitch);
- } else {
- $pitch = _Pitch($self);
- $int = ($pitch & 0xFFFF0000) >> 16;
- $frac = $pitch & 0x0000FFFF;
- return eval("$int.$frac");
- }
-}
-
-sub PlaybackRate {
- my($self, $rate) = @_;
- my($int, $frac);
- if(defined($rate)) {
- $rate =~ /(\d+).?(\d+)?/;
- $int = $1;
- $frac = $2 or 0;
- $int = $int << 16;
- $frac = eval("0.$frac * 65536");
- $rate = $int + $frac;
- return _PlaybackRate($self, $rate);
- } else {
- $rate = _PlaybackRate($self);
- $int = ($rate & 0xFFFF0000) >> 16;
- $frac = $rate & 0x0000FFFF;
- return eval("$int.$frac");
- }
-}
-
-# Preloaded methods go here.
-
-#Currently Autoloading is not implemented in Perl for win32
-# Autoload methods go after __END__, and are processed by the autosplit program.
-
-1;
-__END__
-
-
-=head1 NAME
-
-Win32::Sound - An extension to play with Windows sounds
-
-=head1 SYNOPSIS
-
- use Win32::Sound;
- Win32::Sound::Volume('100%');
- Win32::Sound::Play("file.wav");
- Win32::Sound::Stop();
-
- # ...and read on for more fun ;-)
-
-=head1 FUNCTIONS
-
-=over 4
-
-=item B<Win32::Sound::Play(SOUND, [FLAGS])>
-
-Plays the specified sound: SOUND can the be name of a WAV file
-or one of the following predefined sound names:
-
- SystemDefault
- SystemAsterisk
- SystemExclamation
- SystemExit
- SystemHand
- SystemQuestion
- SystemStart
-
-Additionally, if the named sound could not be found, the
-function plays the system default sound (unless you specify the
-C<SND_NODEFAULT> flag). If no parameters are given, this function
-stops the sound actually playing (see also Win32::Sound::Stop).
-
-FLAGS can be a combination of the following constants:
-
-=over 4
-
-=item C<SND_ASYNC>
-
-The sound is played asynchronously and the function
-returns immediately after beginning the sound
-(if this flag is not specified, the sound is
-played synchronously and the function returns
-when the sound ends).
-
-=item C<SND_LOOP>
-
-The sound plays repeatedly until it is stopped.
-You must also specify C<SND_ASYNC> flag.
-
-=item C<SND_NODEFAULT>
-
-No default sound is used. If the specified I<sound>
-cannot be found, the function returns without
-playing anything.
-
-=item C<SND_NOSTOP>
-
-If a sound is already playing, the function fails.
-By default, any new call to the function will stop
-previously playing sounds.
-
-=back
-
-=item B<Win32::Sound::Stop()>
-
-Stops the sound currently playing.
-
-=item B<Win32::Sound::Volume()>
-
-Returns the wave device volume; if
-called in an array context, returns left
-and right values. Otherwise, returns a single
-32 bit value (left in the low word, right
-in the high word).
-In case of error, returns C<undef> and sets
-$!.
-
-Examples:
-
- ($L, $R) = Win32::Sound::Volume();
- if( not defined Win32::Sound::Volume() ) {
- die "Can't get volume: $!";
- }
-
-=item B<Win32::Sound::Volume(LEFT, [RIGHT])>
-
-Sets the wave device volume; if two arguments
-are given, sets left and right channels
-independently, otherwise sets them both to
-LEFT (eg. RIGHT=LEFT). Values range from
-0 to 65535 (0xFFFF), but they can also be
-given as percentage (use a string containing
-a number followed by a percent sign).
-
-Returns C<undef> and sets $! in case of error,
-a true value if successful.
-
-Examples:
-
- Win32::Sound::Volume('50%');
- Win32::Sound::Volume(0xFFFF, 0x7FFF);
- Win32::Sound::Volume('100%', '50%');
- Win32::Sound::Volume(0);
-
-=item B<Win32::Sound::Format(filename)>
-
-Returns information about the specified WAV file format;
-the array contains:
-
-=over
-
-=item * sample rate (in Hz)
-
-=item * bits per sample (8 or 16)
-
-=item * channels (1 for mono, 2 for stereo)
-
-=back
-
-Example:
-
- ($hz, $bits, $channels)
- = Win32::Sound::Format("file.wav");
-
-
-=item B<Win32::Sound::Devices()>
-
-Returns all the available sound devices;
-their names contain the type of the
-device (WAVEOUT, WAVEIN, MIDIOUT,
-MIDIIN, AUX or MIXER) and
-a zero-based ID number: valid devices
-names are for example:
-
- WAVEOUT0
- WAVEOUT1
- WAVEIN0
- MIDIOUT0
- MIDIIN0
- AUX0
- AUX1
- AUX2
-
-There are also two special device
-names, C<WAVE_MAPPER> and C<MIDI_MAPPER>
-(the default devices for wave output
-and midi output).
-
-Example:
-
- @devices = Win32::Sound::Devices();
-
-=item Win32::Sound::DeviceInfo(DEVICE)
-
-Returns an associative array of information
-about the sound device named DEVICE (the
-same format of Win32::Sound::Devices).
-
-The content of the array depends on the device
-type queried. Each device type returns B<at least>
-the following information:
-
- manufacturer_id
- product_id
- name
- driver_version
-
-For additional data refer to the following
-table:
-
- WAVEIN..... formats
- channels
-
- WAVEOUT.... formats
- channels
- support
-
- MIDIOUT.... technology
- voices
- notes
- channels
- support
-
- AUX........ technology
- support
-
- MIXER...... destinations
- support
-
-The meaning of the fields, where not
-obvious, can be evinced from the
-Microsoft SDK documentation (too long
-to report here, maybe one day... :-).
-
-Example:
-
- %info = Win32::Sound::DeviceInfo('WAVE_MAPPER');
- print "$info{name} version $info{driver_version}\n";
-
-=back
-
-=head1 THE WaveOut PACKAGE
-
-Win32::Sound also provides a different, more
-powerful approach to wave audio data with its
-C<WaveOut> package. It has methods to load and
-then play WAV files, with the additional feature
-of specifying the start and end range, so you
-can play only a portion of an audio file.
-
-Furthermore, it is possible to load arbitrary
-binary data to the soundcard to let it play and
-save them back into WAV files; in a few words,
-you can do some sound synthesis work.
-
-=head2 FUNCTIONS
-
-=over
-
-=item new Win32::Sound::WaveOut(FILENAME)
-
-=item new Win32::Sound::WaveOut(SAMPLERATE, BITS, CHANNELS)
-
-=item new Win32::Sound::WaveOut()
-
-This function creates a C<WaveOut> object; the
-first form opens the specified wave file (see
-also C<Open()> ), so you can directly C<Play()> it.
-
-The second (and third) form opens the
-wave output device with the format given
-(or if none given, defaults to 44.1kHz,
-16 bits, stereo); to produce something
-audible you can either C<Open()> a wave file
-or C<Load()> binary data to the soundcard
-and then C<Write()> it.
-
-=item Close()
-
-Closes the wave file currently opened.
-
-=item CloseDevice()
-
-Closes the wave output device; you can change
-format and reopen it with C<OpenDevice()>.
-
-=item GetErrorText(ERROR)
-
-Returns the error text associated with
-the specified ERROR number; note it only
-works for wave-output-specific errors.
-
-=item Load(DATA)
-
-Loads the DATA buffer in the soundcard.
-The format of the data buffer depends
-on the format used; for example, with
-8 bit mono each sample is one character,
-while with 16 bit stereo each sample is
-four characters long (two 16 bit values
-for left and right channels). The sample
-rate defines how much samples are in one
-second of sound. For example, to fit one
-second at 44.1kHz 16 bit stereo your buffer
-must contain 176400 bytes (44100 * 4).
-
-=item Open(FILE)
-
-Opens the specified wave FILE.
-
-=item OpenDevice()
-
-Opens the wave output device with the
-current sound format (not needed unless
-you used C<CloseDevice()>).
-
-=item Pause()
-
-Pauses the sound currently playing;
-use C<Restart()> to continue playing.
-
-=item Play( [FROM, TO] )
-
-Plays the opened wave file. You can optionally
-specify a FROM - TO range, where FROM and TO
-are expressed in samples (or use FROM=0 for the
-first sample and TO=-1 for the last sample).
-Playback happens always asynchronously, eg. in
-the background.
-
-=item Position()
-
-Returns the sample number currently playing;
-note that the play position is not zeroed
-when the sound ends, so you have to call a
-C<Reset()> between plays to receive the
-correct position in the current sound.
-
-=item Reset()
-
-Stops playing and resets the play position
-(see C<Position()>).
-
-=item Restart()
-
-Continues playing the sound paused by C<Pause()>.
-
-=item Save(FILE, [DATA])
-
-Writes the DATA buffer (if not given, uses the
-buffer currently loaded in the soundcard)
-to the specified wave FILE.
-
-=item Status()
-
-Returns 0 if the soundcard is currently playing,
-1 if it's free, or C<undef> on errors.
-
-=item Unload()
-
-Frees the soundcard from the loaded data.
-
-=item Volume( [LEFT, RIGHT] )
-
-Gets or sets the volume for the wave output device.
-It works the same way as Win32::Sound::Volume.
-
-=item Write()
-
-Plays the data currently loaded in the soundcard;
-playback happens always asynchronously, eg. in
-the background.
-
-=back
-
-=head2 THE SOUND FORMAT
-
-The sound format is stored in three properties of
-the C<WaveOut> object: C<samplerate>, C<bits> and
-C<channels>.
-If you need to change them without creating a
-new object, you should close before and reopen
-afterwards the device.
-
- $WAV->CloseDevice();
- $WAV->{samplerate} = 44100; # 44.1kHz
- $WAV->{bits} = 8; # 8 bit
- $WAV->{channels} = 1; # mono
- $WAV->OpenDevice();
-
-You can also use the properties to query the
-sound format currently used.
-
-=head2 EXAMPLE
-
-This small example produces a 1 second sinusoidal
-wave at 440Hz and saves it in F<sinus.wav>:
-
- use Win32::Sound;
-
- # Create the object
- $WAV = new Win32::Sound::WaveOut(44100, 8, 2);
-
- $data = "";
- $counter = 0;
- $increment = 440/44100;
-
- # Generate 44100 samples ( = 1 second)
- for $i (1..44100) {
-
- # Calculate the pitch
- # (range 0..255 for 8 bits)
- $v = sin($counter/2*3.14) * 128 + 128;
-
- # "pack" it twice for left and right
- $data .= pack("cc", $v, $v);
-
- $counter += $increment;
- }
-
- $WAV->Load($data); # get it
- $WAV->Write(); # hear it
- 1 until $WAV->Status(); # wait for completion
- $WAV->Save("sinus.wav"); # write to disk
- $WAV->Unload(); # drop it
-
-=head1 VERSION
-
-Win32::Sound version 0.46, 25 Sep 1999.
-
-=head1 AUTHOR
-
-Aldo Calpini, C<dada@divinf.it>
-
-Parts of the code provided and/or suggested by Dave Roth.
-
-=cut
-
-
diff --git a/Master/tlpkg/installer/perllib/Win32/Test.pl b/Master/tlpkg/installer/perllib/Win32/Test.pl
deleted file mode 100644
index 235e94bdd78..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/Test.pl
+++ /dev/null
@@ -1,477 +0,0 @@
-#####
-# T E S T . P L
-# -------------
-# A test script for exercising the Win32::ODBC extension. Install
-# the ODBC.PLL extension and the ODBC.PM wrapper, set up an ODBC
-# DSN (Data Source Name) by the ODBC administrator, then give this a try!
-#
-# READ THE DOCUMENTATION -- I AM NOT RESPOSIBLE FOR ANY PROBLEMS THAT
-# THIS MAY CAUSE WHATSOEVER. BY USING THIS OR ANY ---
-# OF THE WIN32::ODBC PARTS FOUND IN THE DISTRIBUTION YOU ARE AGREEING
-# WITH THE TERMS OF THIS DISTRIBUTION!!!!!
-#
-#
-# You have been warned.
-# --- ---- ---- ------
-#
-# Updated to test newest version v961007. Dave Roth <rothd@roth.net>
-# This version contains a small sample database (in MS Access 7.0
-# format) called ODBCTest.mdb. Place this database in the same
-# directory as this test.pl file.
-#
-# --------------------------------------------------------------------
-#
-# SYNTAX:
-# perl test.pl ["DSN Name" [Max Rows]]
-#
-# DSN Name....Name of DSN that will be used. If this is
-# omitted then we will use the obnoxious default DSN.
-# Max Rows....Maximum number of rows wanted to be retrieved from
-# the DSN.
-# - If this is 0 then the request is to retrieve as
-# many as possible.
-# - If this is a value greater than that which the DSN
-# driver can handle the value will be the greatest
-# the DSN driver allows.
-# - If omitted then we use the default value.
-#####
-
- use Win32::ODBC;
-
-
- $TempDSN = "Win32 ODBC Test --123xxYYzz987--";
- $iTempDSN = 1;
-
- if (!($DSN = $ARGV[0])){
- $DSN = $TempDSN;
- }
- $MaxRows = 8 unless defined ($MaxRows = $ARGV[1]);
-
- $DriverType = "Microsoft Access Driver (*.mdb)";
- $Desc = "Description=The Win32::ODBC Test DSN for Perl";
- $Dir = Win32::GetCwd();
- $DBase = "ODBCTest.mdb";
-
- $iWidth=60;
- %SQLStmtTypes = (SQL_CLOSE, "SQL_CLOSE", SQL_DROP, "SQL_DROP", SQL_UNBIND, "SQL_UNBIND", SQL_RESET_PARAMS, "SQL_RESET_PARAMS");
-
-# Initialize();
-
- ($Name, $Version, $Date, $Author, $CompileDate, $CompileTime, $Credits) = Win32::ODBC::Info();
- print "\n";
- print "\t+", "=" x ($iWidth), "+\n";
- print "\t|", Center("", $iWidth), "|\n";
- print "\t|", Center("", $iWidth), "|\n";
- print "\t|", Center("$Name", $iWidth), "|\n";
- print "\t|", Center("-" x length("$Name"), $iWidth), "|\n";
- print "\t|", Center("", $iWidth), "|\n";
-
- print "\t|", Center("Version $Version ($Date)", $iWidth), "|\n";
- print "\t|", Center("by $Author", $iWidth), "|\n";
- print "\t|", Center("Compiled on $CompileDate at $CompileTime.", $iWidth), "|\n";
- print "\t|", Center("", $iWidth), "|\n";
- print "\t|", Center("Credits:", $iWidth), "|\n";
- print "\t|", Center(("-" x length("Credits:")), $iWidth), "|\n";
- foreach $Temp (split("\n", $Credits)){
- print "\t|", Center("$Temp", $iWidth), "|\n";
- }
- print "\t|", Center("", $iWidth), "|\n";
- print "\t+", "=" x ($iWidth), "+\n";
-
-####
-# T E S T 1
-####
- PrintTest(1, "Dump available ODBC Drivers");
- print "\nAvailable ODBC Drivers:\n";
- if (!(%Drivers = Win32::ODBC::Drivers())){
- $Failed{'Test 1'} = "Drivers(): " . Win32::ODBC::Error();
- }
- foreach $Driver (keys(%Drivers)){
- print " Driver=\"$Driver\"\n Attributes: ", join("\n" . " "x14, sort(split(';', $Drivers{$Driver}))), "\n\n";
- }
-
-
-####
-# T E S T 2
-####
- PrintTest(2,"Dump available datasources");
-
- ####
- # Notice you don't need an instantiated object to use this...
- ####
- print "\nHere are the available datasources...\n";
- if (!(%DSNs = Win32::ODBC::DataSources())){
- $Failed{'Test 2'} = "DataSources(): " . Win32::ODBC::Error();
- }
- foreach $Temp (keys(%DSNs)){
- if (($Temp eq $TempDSN) && ($DSNs{$Temp} eq $DriverType)){
- $iTempDSNExists++;
- }
- if ($DSN =~ /$Temp/i){
- $iTempDSN = 0;
- $DriverType = $DSNs{$Temp};
- }
- print "\tDSN=\"$Temp\" (\"$DSNs{$Temp}\")\n";
- }
-
-####
-# T E S T 2.5
-####
- # IF WE DO NOT find the DSN the user specified...
- if ($iTempDSN){
- PrintTest("2.5", "Create a Temporary DSN");
-
- print "\n\tCould not find the DSN (\"$DSN\") so we will\n\tuse a temporary one (\"$TempDSN\")...\n\n";
-
- $DSN = $TempDSN;
-
- if (! $iTempDSNExists){
- print "\tAdding DSN \"$DSN\"...";
- if (Win32::ODBC::ConfigDSN(ODBC_ADD_DSN, $DriverType, ("DSN=$DSN", "Description=The Win32 ODBC Test DSN for Perl", "DBQ=$Dir\\$DBase", "DEFAULTDIR=$Dir", "UID=", "PWD="))){
- print "Successful!\n";
- }else{
- print "Failure\n";
- $Failed{'Test 2.5'} = "ConfigDSN(): Could not add \"$DSN\": " . Win32::ODBC::Error();
- # If we failed here then use the last DSN we listed in Test 2
- $DriverType = $DSNs{$Temp};
- $DSN = $Temp;
- print "\n\tCould not add a temporary DSN so using the last one listed:\n";
- print "\t\t$DSN ($DriverType)\n";
-
- }
- }
- }
-
-####
-# Report What Driver/DSN we are using
-####
-
- print "\n\nWe are using the DSN:\n\tDSN = \"$DSN\"\n";
- print "\tDriver = \"$DriverType\"\n\n";
-
-
-####
-# T E S T 3
-####
- PrintTest(3, "Open several ODBC connections");
- print "\n\tOpening ODBC connection for \"$DSN\"...\n\t\t";
- if (!($O = new Win32::ODBC($DSN))){
- print "Failure. \n\n";
- $Failed{'Test 3a'} = "new(): " . Win32::ODBC::Error();
- PresentErrors();
- exit();
- }else{
- print "Success (connection #", $O->Connection(), ")\n\n";
- }
-
- print "\tOpening ODBC connection for \"$DSN\"...\n\t\t";
- if (!($O2 = new Win32::ODBC($DSN))){
- $Failed{'Test 3b'} = "new(): " . Win32::ODBC::Error();
- print "Failure. \n\n";
- }else{
- print "Success (connection #", $O2->Connection(), ")\n\n";
- }
-
- print "\tOpening ODBC connection for \"$DSN\"\n\t\t";
- if (!($O3 = new Win32::ODBC($DSN))){
- $Failed{'Test 3c'} = "new(): " . Win32::ODBC::Error();
- print "Failure. \n\n";
- }else{
- print "Success (connection #", $O3->Connection(), ")\n\n";
- }
-
-
-####
-# T E S T 4
-####
- PrintTest(4, "Close all but one connection");
-
- print "\n\tCurrently open ODBC connections are: \"", join(", ", sort($O2->GetConnections())), "\"\n";
- print "\tClosing ODBC connection #", $O2->Connection(), "...\n";
- print "\t\t...", (($O2->Close())? "Successful.":"Failure."), "\n";
-
- print "\n\tCurrently open ODBC connections are: \"", join(", ", sort($O3->GetConnections())), "\"\n";
- print "\tClosing ODBC connection #", $O3->Connection(), "...\n";
- print "\t\t...", (($O3->Close())? "Successful.":"Failure."), "\n";
-
- print "\n\tCurrently open ODBC connections are: \"", join(", ", sort($O2->GetConnections())), "\"\n";
-
-####
-# T E S T 5
-####
- PrintTest(5, "Set/query Max Buffer size for a connection");
-
- srand(time);
- $Temp = int(rand(10240)) + 10240;
- print "\nMaximum Buffer Size for connection #", $O->Connection(), ":\n";
- print "\tValue set at ", $O->GetMaxBufSize(), "\n";
-
- print "\tSetting Maximum Buffer Size to $Temp... it has been set to ", $O->SetMaxBufSize($Temp), "\n";
- print "\tValue set at ", $O->GetMaxBufSize(), "\n";
-
- $Temp += int(rand(10240)) + 102400;
- print "\tSetting Maximum Buffer Size to $Temp... (can not be more than 102400)\n\t\t...it has been set to ", $O->SetMaxBufSize($Temp), "\n";
- print "\tValue set at ", $O->GetMaxBufSize(), "\n";
-
- $Temp = int(rand(1024)) + 2048;
- print "\tSetting Maximum Buffer Size to $Temp... it has been set to ", $O->SetMaxBufSize($Temp), "\n";
-
- print "\tValue set at ", $O->GetMaxBufSize(), "\n";
-
-
-####
-# T E S T 6
-####
- PrintTest(6, "Set/query Stmt Close Type");
-
- print "\n\tStatement Close Type is currently set as ", $O->GetStmtCloseType(), " " . $O->Error . "\n";
- print "\tSetting Statement Close Type to SQL_CLOSE: (returned code of ", $O->SetStmtCloseType(SQL_CLOSE), ")" . $O->Error . "\n";
- print "\tStatement Close Type is currently set as ", $O->GetStmtCloseType(), " " . $O->Error ."\n";
-
-
-####
-# T E S T 7
-####
- PrintTest(7, "Dump DSN for current connection");
-
- if (! (%DSNAttributes = $O->GetDSN())){
- $Failed{'Test 7'} = "GetDSN(): " . $O->Error();
- }else{
- print"\nThe DSN for connection #", $O->Connection(), ":\n";
- print "\tDSN...\n";
- foreach (sort(keys(%DSNAttributes))){
- print "\t$_ = \"$DSNAttributes{$_}\"\n";
- }
- }
-
-
-
-####
-# T E S T 8
-####
- PrintTest(8, "Dump list of ALL tables in datasource");
-
- print "\nList of tables for \"$DSN\"\n\n";
- $Num = 0;
- if ($O->Catalog("", "", "%", "'TABLE','VIEW','SYSTEM TABLE', 'GLOBAL TEMPORARY','LOCAL TEMPORARY','ALIAS','SYNONYM'")){
-
- print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n";
- print "\tRenaming cursor to \"TestCursor\"...", (($O->SetCursorName("TestCursor"))? "Success":"Failure"), ".\n";
- print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n\n";
-
- @FieldNames = $O->FieldNames();
-
- $~ = "Test_8_Header";
- write;
-
- $~ = "Test_8_Body";
- while($O->FetchRow()){
- undef %Data;
- %Data = $O->DataHash();
- write;
- }
- }
- print "\n\tTotal number of tables displayed: $Num\n";
-
-
-
-####
-# T E S T 9
-####
- PrintTest(9, "Dump list of non-system tables and views in datasource");
-
- print "\n";
- $Num = 0;
-
- foreach $Temp ($O->TableList("", "", "%", "TABLE, VIEW, SYSTEM_TABLE")){
- $Table = $Temp;
- print "\t", ++$Num, ".) \"$Temp\"\n";
- }
- print "\n\tTotal number of tables displayed: $Num\n";
-
-
-####
-# T E S T 10
-####
- PrintTest(10, "Dump contents of the table: \"$Table\"");
-
- print "\n";
-
- print "\tResetting (dropping) cursor...", (($O->DropCursor())? "Successful":"Failure"), ".\n\n";
-
- print "\tCurrently the cursor type is: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n";
- print "\tSetting Cursor to Dynamic (", ($O->SQL_CURSOR_DYNAMIC), ")...", (($O->SetStmtOption($O->SQL_CURSOR_TYPE, $O->SQL_CURSOR_DYNAMIC))? "Success":"Failure"), ".\n";
- print "\t\tThis may have failed depending on your ODBC Driver.\n";
- print "\t\tThis is not really a problem, it will default to another value.\n";
- print "\tUsing the cursor type of: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n\n";
-
- print "\tSetting the connection to only grab $MaxRows row", ($MaxRows == 1)? "":"s", " maximum...";
- if ($O->SetStmtOption($O->SQL_MAX_ROWS, $MaxRows)){
- print "Success!\n";
- }else{
- $Failed{'Test 10a'} = "SetStmtOption(): " . Win32::ODBC::Error();
- print "Failure.\n";
- }
-
- $iTemp = $O->GetStmtOption($O->SQL_MAX_ROWS);
- print "\tUsing the maximum rows: ", (($iTemp)? $iTemp:"No maximum limit"), "\n\n";
-
- print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n";
- print "\tRenaming cursor to \"TestCursor\"...", (($O->SetCursorName("TestCursor"))? "Success":"Failure"), ".\n";
- print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n\n";
-
- if (! $O->Sql("SELECT * FROM [$Table]")){
- @FieldNames = $O->FieldNames();
- $Cols = $#FieldNames + 1;
- $Cols = 8 if ($Cols > 8);
-
- $FmH = "format Test_10_Header =\n";
- $FmH2 = "";
- $FmH3 = "";
- $FmB = "format Test_10_Body = \n";
- $FmB2 = "";
-
- for ($iTemp = 0; $iTemp < $Cols; $iTemp++){
- $FmH .= "@" . "<" x (80/$Cols - 2) . " ";
- $FmH2 .= "\$FieldNames[$iTemp],";
- $FmH3 .= "-" x (80/$Cols - 1) . " ";
-
- $FmB .= "@" . "<" x (80/$Cols - 2) . " ";
- $FmB2 .= "\$Data{\$FieldNames[$iTemp]},";
- }
- chop $FmH2;
- chop $FmB2;
-
- eval"$FmH\n$FmH2\n$FmH3\n.\n";
- eval "$FmB\n$FmB2\n.\n";
-
- $~ = "Test_10_Header";
- write();
- $~ = "Test_10_Body";
-
- # Fetch the next rowset
- while($O->FetchRow()){
- undef %Data;
- %Data = $O->DataHash();
- write();
- }
- ####
- # THE preceeding block could have been written like this:
- # ------------------------------------------------------
- #
- # print "\tCurrently the cursor type is: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n";
- # print "\tSetting Cursor to Dynamic (", ($O->SQL_CURSOR_DYNAMIC), ")...", (($O->SetStmtOption($O->SQL_CURSOR_TYPE, $O->SQL_CURSOR_DYNAMIC))? "Success":"Failure"), ".\n";
- # print "\t\tThis may have failed depending on your ODBC Driver. No real problem.\n";
- # print "\tUsing the cursor type of: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n\n";
- #
- # print "\tSetting rowset size = 15 ...", (($O->SetStmtOption($O->SQL_ROWSET_SIZE, 15))? "Success":"Failure"), ".\n";
- # print "\tGetting rowset size: ", $O->GetStmtOption($O->SQL_ROWSET_SIZE), "\n\n";
- #
- # while($O->FetchRow()){
- # $iNum = 1;
- # # Position yourself in the rowset
- # while($O->SetPos($iNum++ ,$O->SQL_POSITION, $O->SQL_LOCK_NO_CHANGE)){
- # undef %Data;
- # %Data = $O->DataHash();
- # write();
- # }
- # print "\t\tNext rowset...\n";
- # }
- #
- # The reason I didn't write it that way (which is easier) is to
- # show that we can now SetPos(). Also Fetch() now uses
- # SQLExtendedFetch() so it can position itself and retrieve
- # rowsets. Notice earlier in this Test 10 we set the
- # SQL_ROWSET_SIZE. If this was not set it would default to
- # no limit (depending upon your ODBC Driver).
- ####
-
- print "\n\tNo more records available.\n";
- }else{
- $Failed{'Test 10'} = "Sql(): " . $O->Error();
- }
-
- $O->Close();
-
-####
-# T E S T 11
-####
- if ($iTempDSN){
- PrintTest(11, "Remove the temporary DSN");
- print "\n\tRemoving the temporary DSN:\n";
- print "\t\tDSN = \"$DSN\"\n\t\tDriver = \"$DriverType\"\n";
-
- if (Win32::ODBC::ConfigDSN(ODBC_REMOVE_DSN, $DriverType, "DSN=$DSN")){
- print "\tSuccessful!\n";
- }else{
- print "\tFailed.\n";
- $Failed{'Test 11'} = "ConfigDSN(): Could not remove \"$DSN\":" . Win32::ODBC::Error();
- }
- }
-
-
- PrintTest("E N D O F T E S T");
- PresentErrors();
-
-
-
-#----------------------- F U N C T I O N S ---------------------------
-
-sub Error{
- my($Data) = @_;
- $Data->DumpError() if ref($Data);
- Win32::ODBC::DumpError() if ! ref($Data);
-}
-
-
-sub Center{
- local($Temp, $Width) = @_;
- local($Len) = ($Width - length($Temp)) / 2;
- return " " x int($Len), $Temp, " " x (int($Len) + (($Len != int($Len))? 1:0));
-}
-
-sub PrintTest{
- my($Num, $String) = @_;
- my($Temp);
- if (length($String)){
- $Temp = " T E S T $Num $String ";
- }else{
- $Temp = " $Num ";
- }
- $Len = length($Temp);
- print "\n", "-" x ((79 - $Len)/2), $Temp, "-" x ((79 - $Len)/2 - 1), "\n";
- print "\t$String\n";
-}
-
-sub PresentErrors{
- PrintTest("", "Error Report:");
- if (keys(%Failed)){
- print "The following were errors:\n";
- foreach (sort(keys(%Failed))){
- print "$_ = $Failed{$_}\n";
- }
- }else{
- print "\n\nThere were no errors reported during this test.\n\n";
- }
-}
-
-
-sub Initialize{
-format Test_8_Header =
- @<<<<<<<<<<<<<<<<<<<<<<<<<<< @|||||||||||| @|||||||||||| @|||||||||||
- $FieldNames[0], $FieldNames[1], $FieldNames[2], $FieldNames[3]
- ---------------------------- ------------- ------------- ------------
-.
-format Test_8_Body =
- @>. @<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<< @<<<<<<<<<<<< @<<<<<<<<<<<
- ++$Num, $Data{$FieldNames[0]}, $Data{$FieldNames[1]}, $Data{$FieldNames[2]}, $Data{$FieldNames[3]}
-.
-format Test_9_Header =
- @<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<<
- $FieldNames[0], $FieldNames[1], $FieldNames[2], $FieldNames[3]
-.
-format Test_9_Body =
- @<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<<
- $Data{$FieldNames[0]}, $Data{$FieldNames[1]}, $Data{$FieldNames[2]}, $Data{$FieldNames[3]}
-.
-}
diff --git a/Master/tlpkg/installer/perllib/Win32/TieRegistry.pm b/Master/tlpkg/installer/perllib/Win32/TieRegistry.pm
deleted file mode 100644
index 0abbbddb6b8..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/TieRegistry.pm
+++ /dev/null
@@ -1,3801 +0,0 @@
-# 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.
-#
-
-
-package Win32::TieRegistry;
-
-
-use strict;
-use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK );
-
-$PACK= "Win32::TieRegistry"; # Used in error messages.
-$VERSION= '0.26';
-
-
-use Carp;
-
-require Tie::Hash;
-@ISA= qw(Tie::Hash);
-
-# Required other modules:
-use Win32API::Registry 0.12 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 );
-$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 )= shift(@_);
- @_ 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;
- local $@;
- 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__
-
-=head1 NAME
-
-Win32::TieRegistry - Powerful and easy ways to manipulate a registry
-[on Win32 for now].
-
-=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 E<can> be blank and E<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 E<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()> E<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 E<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
-
-=cut
-
-# Autoload not currently supported by Perl under Windows.
diff --git a/Master/tlpkg/installer/perllib/Win32/WinError.pm b/Master/tlpkg/installer/perllib/Win32/WinError.pm
deleted file mode 100644
index 46028a79321..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/WinError.pm
+++ /dev/null
@@ -1,1017 +0,0 @@
-package Win32::WinError;
-
-require Exporter;
-require DynaLoader;
-
-$VERSION = '0.02';
-
-@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/installer/perllib/Win32/test-async.pl b/Master/tlpkg/installer/perllib/Win32/test-async.pl
deleted file mode 100644
index c47e2df04ec..00000000000
--- a/Master/tlpkg/installer/perllib/Win32/test-async.pl
+++ /dev/null
@@ -1,129 +0,0 @@
-#
-# TEST-ASYNC.PL
-# Test Win32::Internet's Asynchronous Operations
-# by Aldo Calpini <dada@divinf.it>
-#
-# WARNING: this code is most likely to fail with almost-random errors
-# I don't know what is wrong here, any hint will be greatly
-# appreciated!
-
-use Win32::Internet;
-
-$params{'flags'} = INTERNET_FLAG_ASYNC;
-$params{'opentype'} = INTERNET_OPEN_TYPE_DIRECT;
-$I = new Win32::Internet(\%params);
-
-# print "Error: ", $I->Error(), "\n";
-print "I.handle=", $I->{'handle'}, "\n";
-
-$return = $I->SetStatusCallback();
-print "SetStatusCallback=$return";
-print "ERROR" if $return eq undef;
-print "\n";
-
-$buffer = $I->QueryOption(INTERNET_OPTION_READ_BUFFER_SIZE);
-print "Buffer=$buffer\n";
-
-$host = "ftp.activeware.com";
-$user = "anonymous";
-$pass = "dada\@divinf.it";
-
-
-print "Doing FTP()...\n";
-
-$handle2 = $I->FTP($FTP, $host, $user, $pass, 21, 1);
-
-print "Returned from FTP()...\n";
-
-($n, $t) = $I->Error();
-
-if($n == 997) {
- print "Going asynchronous...\n";
- ($status, $info) = $I->GetStatusCallback(1);
- while($status != 100 and $status != 70) {
- if($oldstatus != $status) {
- if($status == 60) {
- $FTP->{'handle'} = $info;
- } elsif($status == 10) {
- print "resolving name... \n";
- } elsif($status == 11) {
- print "name resolved... \n";
- } elsif($status == 20) {
- print "connecting... \n";
- } elsif($status == 21) {
- print "connected... \n";
- } elsif($status == 30) {
- print "sending... \n";
- } elsif($status == 31) {
- print "$info bytes sent. \n";
- } elsif($status == 40) {
- print "receiving... \n";
- } elsif($status == 41) {
- print "$info bytes received. \n";
- } else {
- print "status=$status\n";
- }
- }
- $oldstatus = $status;
- ($status, $info) = $I->GetStatusCallback(1);
- }
-} else {
- print "Error=", $I->Error(), "\n";
-}
-print "FTP.handle=", $FTP->{'handle'}, "\n";
-print "STATUS(after FTP)=", $I->GetStatusCallback(1), "\n";
-
-# "/pub/microsoft/sdk/activex13.exe",
-
-print "Doing Get()...\n";
-
-$file = "/Perl-Win32/perl5.001m/currentBuild/110-i86.zip";
-
-$FTP->Get($file, "110-i86.zip", 1, 0, 2);
-
-print "Returned from Get()...\n";
-
-($n, $t) = $I->Error();
-if($n == 997) {
- print "Going asynchronous...\n";
- $bytes = 0;
- $oldstatus = 0;
- ($status, $info) = $I->GetStatusCallback(2);
- while($status != 100 and $status != 70) {
- # print "status=$status info=$info\n";
- # if($oldstatus!=$status) {
- if($status == 10) {
- print "resolving name... \n";
- } elsif($status == 11) {
- print "name resolved... \n";
- } elsif($status == 20) {
- print "connecting... \n";
- } elsif($status == 21) {
- print "connected... \n";
- #} elsif($status == 30) {
- # print "sending... \n";
- } elsif($status == 31) {
- print "$info bytes sent. \n";
- #} elsif($status == 40) {
- # print "receiving... \n";
- } elsif($status == 41) {
- $bytes = $bytes+$info;
- print "$bytes bytes received. \n";
- #} else {
- # print "status=$status\n";
- }
- # }
- $oldstatus = $status;
- undef $status, $info;
- ($status, $info) = $I->GetStatusCallback(2);
- }
-} else {
- print "Error=[$n] $t\n";
-}
-print "\n";
-($status, $info) = $I->GetStatusCallback(2);
-print "STATUS(after Get)=$status\n";
-print "Error=", $I->Error(), "\n";
-exit(0);
-
-
diff --git a/Master/tlpkg/installer/perllib/Win32API/Registry.pm b/Master/tlpkg/installer/perllib/Win32API/Registry.pm
deleted file mode 100644
index dbf98b4e2e9..00000000000
--- a/Master/tlpkg/installer/perllib/Win32API/Registry.pm
+++ /dev/null
@@ -1,1792 +0,0 @@
-# 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.24';
-
-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 $@;
-# }
-
-package Win32API::Registry::_error;
-
-use overload
- '""' => sub {
- require Win32 unless defined &Win32::FormatMessage;
- $_ = Win32::FormatMessage(Win32API::Registry::_regLastError());
- tr/\r\n//d;
- return $_;
- },
- '0+' => sub { Win32API::Registry::_regLastError() },
- 'fallback' => 1;
-
-sub new { return bless {}, shift }
-sub set { Win32API::Registry::_regLastError($_[1]); return $_[0] }
-
-package Win32API::Registry;
-
-my $_error = new Win32API::Registry::_error;
-
-sub regLastError {
- require Carp;
- Carp::croak('Usage: ',__PACKAGE__,'::regLastError( [$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::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.
-
-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].
-
-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/installer/perllib/Win32API/Registry/cRegistry.pc b/Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc
deleted file mode 100644
index 9659d0c4361..00000000000
--- a/Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc
+++ /dev/null
@@ -1,87 +0,0 @@
-# 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/installer/perllib/XSLoader.pm b/Master/tlpkg/installer/perllib/XSLoader.pm
deleted file mode 100644
index 34172dcfa70..00000000000
--- a/Master/tlpkg/installer/perllib/XSLoader.pm
+++ /dev/null
@@ -1,356 +0,0 @@
-# Generated from XSLoader.pm.PL (resolved %Config::Config value)
-
-package XSLoader;
-
-$VERSION = "0.06";
-
-#use strict;
-
-# enable debug/trace messages from DynaLoader perl code
-# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
-
- my $dl_dlext = 'dll';
-
-package DynaLoader;
-
-# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
-# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
-boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
- !defined(&dl_error);
-package XSLoader;
-
-sub load {
- package DynaLoader;
-
- die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_;
-
- my($module) = $_[0];
-
- # work with static linking too
- my $b = "$module\::bootstrap";
- goto &$b if defined &$b;
-
- goto retry unless $module and defined &dl_load_file;
-
- my @modparts = split(/::/,$module);
- my $modfname = $modparts[-1];
-
- my $modpname = join('/',@modparts);
- my $modlibname = (caller())[1];
- my $c = @modparts;
- $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
- my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext";
-
-# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
-
- my $bs = $file;
- $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
-
- goto retry if not -f $file or -s $bs;
-
- my $bootname = "boot_$module";
- $bootname =~ s/\W/_/g;
- @DynaLoader::dl_require_symbols = ($bootname);
-
- my $boot_symbol_ref;
-
- if ($^O eq 'darwin') {
- if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) {
- goto boot; #extension library has already been loaded, e.g. darwin
- }
- }
-
- # Many dynamic extension loading problems will appear to come from
- # this section of code: XYZ failed at line 123 of DynaLoader.pm.
- # Often these errors are actually occurring in the initialisation
- # C code of the extension XS file. Perl reports the error as being
- # in this perl code simply because this was the last perl code
- # it executed.
-
- my $libref = dl_load_file($file, 0) or do {
- require Carp;
- Carp::croak("Can't load '$file' for module $module: " . dl_error());
- };
- push(@DynaLoader::dl_librefs,$libref); # record loaded object
-
- my @unresolved = dl_undef_symbols();
- if (@unresolved) {
- require Carp;
- Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
- }
-
- $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do {
- require Carp;
- Carp::croak("Can't find '$bootname' symbol in $file\n");
- };
-
- push(@DynaLoader::dl_modules, $module); # record loaded module
-
- boot:
- my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
-
- # See comment block above
- push(@DynaLoader::dl_shared_objects, $file); # record files loaded
- return &$xs(@_);
-
- retry:
- my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') ||
- XSLoader->can('bootstrap_inherit');
- goto &$bootstrap_inherit;
-}
-
-# Versions of DynaLoader prior to 5.6.0 don't have this function.
-sub bootstrap_inherit {
- package DynaLoader;
-
- my $module = $_[0];
- local *DynaLoader::isa = *{"$module\::ISA"};
- local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader');
- # Cannot goto due to delocalization. Will report errors on a wrong line?
- require DynaLoader;
- DynaLoader::bootstrap(@_);
-}
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-XSLoader - Dynamically load C libraries into Perl code
-
-=head1 VERSION
-
-Version 0.06
-
-=head1 SYNOPSIS
-
- package YourPackage;
- use XSLoader;
-
- XSLoader::load 'YourPackage', $YourPackage::VERSION;
-
-=head1 DESCRIPTION
-
-This module defines a standard I<simplified> interface to the dynamic
-linking mechanisms available on many platforms. Its primary purpose is
-to implement cheap automatic dynamic loading of Perl modules.
-
-For a more complicated interface, see L<DynaLoader>. Many (most)
-features of C<DynaLoader> are not implemented in C<XSLoader>, like for
-example the C<dl_load_flags>, not honored by C<XSLoader>.
-
-=head2 Migration from C<DynaLoader>
-
-A typical module using L<DynaLoader|DynaLoader> starts like this:
-
- package YourPackage;
- require DynaLoader;
-
- our @ISA = qw( OnePackage OtherPackage DynaLoader );
- our $VERSION = '0.01';
- bootstrap YourPackage $VERSION;
-
-Change this to
-
- package YourPackage;
- use XSLoader;
-
- our @ISA = qw( OnePackage OtherPackage );
- our $VERSION = '0.01';
- XSLoader::load 'YourPackage', $VERSION;
-
-In other words: replace C<require DynaLoader> by C<use XSLoader>, remove
-C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not
-forget to quote the name of your package on the C<XSLoader::load> line,
-and add comma (C<,>) before the arguments (C<$VERSION> above).
-
-Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have
-the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the
-more backward-compatible
-
- use vars qw($VERSION @ISA);
-
-one can remove this reference to C<@ISA> together with the C<@ISA> assignment.
-
-If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes
-
- XSLoader::load 'YourPackage';
-
-=head2 Backward compatible boilerplate
-
-If you want to have your cake and eat it too, you need a more complicated
-boilerplate.
-
- package YourPackage;
- use vars qw($VERSION @ISA);
-
- @ISA = qw( OnePackage OtherPackage );
- $VERSION = '0.01';
- eval {
- require XSLoader;
- XSLoader::load('YourPackage', $VERSION);
- 1;
- } or do {
- require DynaLoader;
- push @ISA, 'DynaLoader';
- bootstrap YourPackage $VERSION;
- };
-
-The parentheses about C<XSLoader::load()> arguments are needed since we replaced
-C<use XSLoader> by C<require>, so the compiler does not know that a function
-C<XSLoader::load()> is present.
-
-This boilerplate uses the low-overhead C<XSLoader> if present; if used with
-an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>.
-
-=head1 Order of initialization: early load()
-
-I<Skip this section if the XSUB functions are supposed to be called from other
-modules only; read it only if you call your XSUBs from the code in your module,
-or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">).
-What is described here is equally applicable to the L<DynaLoader|DynaLoader>
-interface.>
-
-A sufficiently complicated module using XS would have both Perl code (defined
-in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this
-Perl code makes calls into this XS code, and/or this XS code makes calls to
-the Perl code, one should be careful with the order of initialization.
-
-The call to C<XSLoader::load()> (or C<bootstrap()>) has three side effects:
-
-=over
-
-=item *
-
-if C<$VERSION> was specified, a sanity check is done to ensure that the
-versions of the F<.pm> and the (compiled) F<.xs> parts are compatible;
-
-=item *
-
-the XSUBs are made accessible from Perl;
-
-=item *
-
-if a C<BOOT:> section was present in the F<.xs> file, the code there is called.
-
-=back
-
-Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is
-convenient to have XSUBs installed before the Perl code is defined; for
-example, this makes prototypes for XSUBs visible to this Perl code.
-Alternatively, if the C<BOOT:> section makes calls to Perl functions (or
-uses Perl variables) defined in the F<.pm> file, they must be defined prior to
-the call to C<XSLoader::load()> (or C<bootstrap()>).
-
-The first situation being much more frequent, it makes sense to rewrite the
-boilerplate as
-
- package YourPackage;
- use XSLoader;
- use vars qw($VERSION @ISA);
-
- BEGIN {
- @ISA = qw( OnePackage OtherPackage );
- $VERSION = '0.01';
-
- # Put Perl code used in the BOOT: section here
-
- XSLoader::load 'YourPackage', $VERSION;
- }
-
- # Put Perl code making calls into XSUBs here
-
-=head2 The most hairy case
-
-If the interdependence of your C<BOOT:> section and Perl code is
-more complicated than this (e.g., the C<BOOT:> section makes calls to Perl
-functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:>
-section altogether. Replace it with a function C<onBOOT()>, and call it like
-this:
-
- package YourPackage;
- use XSLoader;
- use vars qw($VERSION @ISA);
-
- BEGIN {
- @ISA = qw( OnePackage OtherPackage );
- $VERSION = '0.01';
- XSLoader::load 'YourPackage', $VERSION;
- }
-
- # Put Perl code used in onBOOT() function here; calls to XSUBs are
- # prototype-checked.
-
- onBOOT;
-
- # Put Perl initialization code assuming that XS is initialized here
-
-
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item Can't find '%s' symbol in %s
-
-B<(F)> The bootstrap symbol could not be found in the extension module.
-
-=item Can't load '%s' for module %s: %s
-
-B<(F)> The loading or initialisation of the extension module failed.
-The detailed error follows.
-
-=item Undefined symbols present after loading %s: %s
-
-B<(W)> As the message says, some symbols stay undefined although the
-extension module was correctly loaded and initialised. The list of undefined
-symbols follows.
-
-=item XSLoader::load('Your::Module', $Your::Module::VERSION)
-
-B<(F)> You tried to invoke C<load()> without any argument. You must supply
-a module name, and optionally its version.
-
-=back
-
-
-=head1 LIMITATIONS
-
-To reduce the overhead as much as possible, only one possible location
-is checked to find the extension DLL (this location is where C<make install>
-would put the DLL). If not found, the search for the DLL is transparently
-delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list.
-
-In particular, this is applicable to the structure of C<@INC> used for testing
-not-yet-installed extensions. This means that running uninstalled extensions
-may have much more overhead than running the same extensions after
-C<make install>.
-
-
-=head1 BUGS
-
-Please report any bugs or feature requests via the perlbug(1) utility.
-
-
-=head1 SEE ALSO
-
-L<DynaLoader>
-
-
-=head1 AUTHORS
-
-Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>.
-
-CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni
-E<lt>sebastien@aperghis.netE<gt>
-
-Previous maintainer was Michael G Schwern <schwern@pobox.com>
-
-
-=head1 COPYRIGHT
-
-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/installer/perllib/attributes.pm b/Master/tlpkg/installer/perllib/attributes.pm
deleted file mode 100644
index 714cb267218..00000000000
--- a/Master/tlpkg/installer/perllib/attributes.pm
+++ /dev/null
@@ -1,418 +0,0 @@
-package attributes;
-
-our $VERSION = 0.06;
-
-@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 ;
-#sub _warn_reserved () ;
-#
-# 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, @attrs);
- if (!@badattrs && @pkgattrs) {
- return unless _warn_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 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 receives a single argument, which is a reference to the
-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 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/installer/perllib/auto/Cwd/Cwd.bs b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll
deleted file mode 100755
index 67f6d7baa57..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Digest/MD5/MD5.bs b/Master/tlpkg/installer/perllib/auto/Digest/MD5/MD5.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Digest/MD5/MD5.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Digest/MD5/MD5.dll b/Master/tlpkg/installer/perllib/auto/Digest/MD5/MD5.dll
deleted file mode 100755
index 72ba4df2758..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Digest/MD5/MD5.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix b/Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix
deleted file mode 100644
index d7605efa074..00000000000
--- a/Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix
+++ /dev/null
@@ -1,8 +0,0 @@
-# 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/installer/perllib/auto/DynaLoader/dl_expandspec.al b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al
deleted file mode 100644
index 0bea19a3e4d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al
+++ /dev/null
@@ -1,34 +0,0 @@
-# NOTE: Derived from ../LIB\DynaLoader.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package DynaLoader;
-
-#line 377 "../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
-
- if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs
- require Carp;
- Carp::croak("dl_expandspec: should be defined in XS file!\n");
- } else {
- 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/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al
deleted file mode 100644
index 2232454ba69..00000000000
--- a/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al
+++ /dev/null
@@ -1,19 +0,0 @@
-# NOTE: Derived from ../LIB\DynaLoader.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package DynaLoader;
-
-#line 403 "../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/installer/perllib/auto/DynaLoader/dl_findfile.al b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al
deleted file mode 100644
index 9f8df39d00c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al
+++ /dev/null
@@ -1,115 +0,0 @@
-# NOTE: Derived from ../LIB\DynaLoader.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package DynaLoader;
-
-#line 269 "../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 ($Is_VMS && m%[:>/\]]% && -f $_) {
- push(@found,dl_expandspec(VMS::Filespec::vmsify($_)));
- last arg unless wantarray;
- next;
- }
- elsif ($Is_MacOS) {
- if (m/:/ && -f $_) {
- push(@found,$_);
- last arg unless wantarray;
- }
- }
- elsif (m:/: && -f $_ && !$do_expand) {
- 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; }
-
- if ($Is_MacOS) {
- # 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
- s/^-l//;
- push(@names, $_);
- foreach $dir (@dirs, @dl_library_path) {
- next unless -d $dir;
- $dir =~ s/^([^:]+)$/:$1/;
- $dir =~ s/:$//;
- foreach $name (@names) {
- my($file) = "$dir:$name";
- print STDERR " checking in $dir for $name\n" if $dl_debug;
- if (-f $file) {
- push(@found, $file);
- next arg; # no need to look any further
- }
- }
- }
- 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; }
-
- # VMS: we may be using native VMS directory syntax instead of
- # Unix emulation, so check this as well
- if ($Is_VMS && /[:>\]]/ && -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_ext") unless m/\.$dl_ext$/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, $_);
- }
- foreach $dir (@dirs, @dl_library_path) {
- next unless -d $dir;
- chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS;
- foreach $name (@names) {
- my($file) = "$dir/$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/installer/perllib/auto/Encode/Byte/Byte.bs b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll
deleted file mode 100755
index 88474ccb046..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Encode.bs b/Master/tlpkg/installer/perllib/auto/Encode/Encode.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Encode/Encode.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Encode.dll b/Master/tlpkg/installer/perllib/auto/Encode/Encode.dll
deleted file mode 100755
index 69c8ebf8acb..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Encode/Encode.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll
deleted file mode 100755
index 71a757a6b64..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.bs b/Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.dll b/Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.dll
deleted file mode 100755
index d053a295a71..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/IO/IO.bs b/Master/tlpkg/installer/perllib/auto/IO/IO.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/IO/IO.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/IO/IO.dll b/Master/tlpkg/installer/perllib/auto/IO/IO.dll
deleted file mode 100755
index 86276c177d9..00000000000
--- a/Master/tlpkg/installer/perllib/auto/IO/IO.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/List/Util/Util.bs b/Master/tlpkg/installer/perllib/auto/List/Util/Util.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/List/Util/Util.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/List/Util/Util.dll b/Master/tlpkg/installer/perllib/auto/List/Util/Util.dll
deleted file mode 100755
index 238b1648bea..00000000000
--- a/Master/tlpkg/installer/perllib/auto/List/Util/Util.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/POSIX.bs b/Master/tlpkg/installer/perllib/auto/POSIX/POSIX.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/POSIX.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/POSIX.dll b/Master/tlpkg/installer/perllib/auto/POSIX/POSIX.dll
deleted file mode 100755
index 49bdaee0917..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/POSIX.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/abs.al b/Master/tlpkg/installer/perllib/auto/POSIX/abs.al
deleted file mode 100644
index 89999433d53..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/abs.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\abs.al)"
-sub abs {
- usage "abs(x)" if @_ != 1;
- CORE::abs($_[0]);
-}
-
-# end of POSIX::abs
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/alarm.al b/Master/tlpkg/installer/perllib/auto/POSIX/alarm.al
deleted file mode 100644
index e1c864ed8e0..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/alarm.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 615 "..\..\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/installer/perllib/auto/POSIX/assert.al b/Master/tlpkg/installer/perllib/auto/POSIX/assert.al
deleted file mode 100644
index b3bce100406..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/assert.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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\assert.al)"
-sub assert {
- usage "assert(expr)" if @_ != 1;
- if (!$_[0]) {
- croak "Assertion failed";
- }
-}
-
-# end of POSIX::assert
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/atan2.al b/Master/tlpkg/installer/perllib/auto/POSIX/atan2.al
deleted file mode 100644
index 9482e3cff23..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/atan2.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 145 "..\..\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/installer/perllib/auto/POSIX/atexit.al b/Master/tlpkg/installer/perllib/auto/POSIX/atexit.al
deleted file mode 100644
index b0fdf7e97cf..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/atexit.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 403 "..\..\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/installer/perllib/auto/POSIX/atof.al b/Master/tlpkg/installer/perllib/auto/POSIX/atof.al
deleted file mode 100644
index fc1d1cef431..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/atof.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 407 "..\..\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/installer/perllib/auto/POSIX/atoi.al b/Master/tlpkg/installer/perllib/auto/POSIX/atoi.al
deleted file mode 100644
index 5eef246231b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/atoi.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 411 "..\..\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/installer/perllib/auto/POSIX/atol.al b/Master/tlpkg/installer/perllib/auto/POSIX/atol.al
deleted file mode 100644
index e6fc6869a1a..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/atol.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 415 "..\..\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/installer/perllib/auto/POSIX/autosplit.ix b/Master/tlpkg/installer/perllib/auto/POSIX/autosplit.ix
deleted file mode 100644
index 8ecf455bb80..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/autosplit.ix
+++ /dev/null
@@ -1,159 +0,0 @@
-# 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 handler ;
-sub mask ;
-sub flags ;
-sub safe ;
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/bsearch.al b/Master/tlpkg/installer/perllib/auto/POSIX/bsearch.al
deleted file mode 100644
index 4acc59b5a7d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/bsearch.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\bsearch.al)"
-sub bsearch {
- unimpl "bsearch() not supplied";
-}
-
-# end of POSIX::bsearch
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/calloc.al b/Master/tlpkg/installer/perllib/auto/POSIX/calloc.al
deleted file mode 100644
index 776029eff29..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/calloc.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\calloc.al)"
-sub calloc {
- unimpl "calloc() is C-specific, stopped";
-}
-
-# end of POSIX::calloc
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/chdir.al b/Master/tlpkg/installer/perllib/auto/POSIX/chdir.al
deleted file mode 100644
index 1bddab213d6..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/chdir.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 620 "..\..\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/installer/perllib/auto/POSIX/chmod.al b/Master/tlpkg/installer/perllib/auto/POSIX/chmod.al
deleted file mode 100644
index 8fc0d5a5e0b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/chmod.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 561 "..\..\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/installer/perllib/auto/POSIX/chown.al b/Master/tlpkg/installer/perllib/auto/POSIX/chown.al
deleted file mode 100644
index ca945bd855d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/chown.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 625 "..\..\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/installer/perllib/auto/POSIX/clearerr.al b/Master/tlpkg/installer/perllib/auto/POSIX/clearerr.al
deleted file mode 100644
index c360043abf9..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/clearerr.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 225 "..\..\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/installer/perllib/auto/POSIX/closedir.al b/Master/tlpkg/installer/perllib/auto/POSIX/closedir.al
deleted file mode 100644
index 16ae1cd4f76..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/closedir.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 97 "..\..\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/installer/perllib/auto/POSIX/cos.al b/Master/tlpkg/installer/perllib/auto/POSIX/cos.al
deleted file mode 100644
index ee01c091b27..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/cos.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 150 "..\..\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/installer/perllib/auto/POSIX/creat.al b/Master/tlpkg/installer/perllib/auto/POSIX/creat.al
deleted file mode 100644
index 2d1cfb7d55d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/creat.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 125 "..\..\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/installer/perllib/auto/POSIX/div.al b/Master/tlpkg/installer/perllib/auto/POSIX/div.al
deleted file mode 100644
index 4c751314da0..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/div.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\div.al)"
-sub div {
- unimpl "div() is C-specific, use /, % and int instead";
-}
-
-# end of POSIX::div
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/errno.al b/Master/tlpkg/installer/perllib/auto/POSIX/errno.al
deleted file mode 100644
index c57abdc4c3b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/errno.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 120 "..\..\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/installer/perllib/auto/POSIX/execl.al b/Master/tlpkg/installer/perllib/auto/POSIX/execl.al
deleted file mode 100644
index 3ffc4f5a671..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/execl.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 630 "..\..\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/installer/perllib/auto/POSIX/execle.al b/Master/tlpkg/installer/perllib/auto/POSIX/execle.al
deleted file mode 100644
index ec7e12da909..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/execle.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 634 "..\..\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/installer/perllib/auto/POSIX/execlp.al b/Master/tlpkg/installer/perllib/auto/POSIX/execlp.al
deleted file mode 100644
index a9e32524839..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/execlp.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 638 "..\..\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/installer/perllib/auto/POSIX/execv.al b/Master/tlpkg/installer/perllib/auto/POSIX/execv.al
deleted file mode 100644
index 1e6f20bba77..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/execv.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 642 "..\..\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/installer/perllib/auto/POSIX/execve.al b/Master/tlpkg/installer/perllib/auto/POSIX/execve.al
deleted file mode 100644
index ae23c53ea77..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/execve.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\execve.al)"
-sub execve {
- unimpl "execve() is C-specific, stopped";
-}
-
-# end of POSIX::execve
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/execvp.al b/Master/tlpkg/installer/perllib/auto/POSIX/execvp.al
deleted file mode 100644
index 88d5dd6764e..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/execvp.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\execvp.al)"
-sub execvp {
- unimpl "execvp() is C-specific, stopped";
-}
-
-# end of POSIX::execvp
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/exit.al b/Master/tlpkg/installer/perllib/auto/POSIX/exit.al
deleted file mode 100644
index d7806b3f4db..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/exit.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\exit.al)"
-sub exit {
- usage "exit(status)" if @_ != 1;
- CORE::exit($_[0]);
-}
-
-# end of POSIX::exit
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/exp.al b/Master/tlpkg/installer/perllib/auto/POSIX/exp.al
deleted file mode 100644
index 251dc740eaf..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/exp.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 155 "..\..\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/installer/perllib/auto/POSIX/fabs.al b/Master/tlpkg/installer/perllib/auto/POSIX/fabs.al
deleted file mode 100644
index ebe714729c2..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fabs.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 160 "..\..\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/installer/perllib/auto/POSIX/fclose.al b/Master/tlpkg/installer/perllib/auto/POSIX/fclose.al
deleted file mode 100644
index f662ef7cda6..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fclose.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 229 "..\..\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/installer/perllib/auto/POSIX/fcntl.al b/Master/tlpkg/installer/perllib/auto/POSIX/fcntl.al
deleted file mode 100644
index bf6ec04fb4c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fcntl.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 130 "..\..\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/installer/perllib/auto/POSIX/fdopen.al b/Master/tlpkg/installer/perllib/auto/POSIX/fdopen.al
deleted file mode 100644
index 392f8e27fbf..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fdopen.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 233 "..\..\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/installer/perllib/auto/POSIX/feof.al b/Master/tlpkg/installer/perllib/auto/POSIX/feof.al
deleted file mode 100644
index 4c8b5ea37af..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/feof.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\feof.al)"
-sub feof {
- redef "IO::Handle::eof()";
-}
-
-# end of POSIX::feof
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/ferror.al b/Master/tlpkg/installer/perllib/auto/POSIX/ferror.al
deleted file mode 100644
index 6ec8cccb11b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/ferror.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\ferror.al)"
-sub ferror {
- redef "IO::Handle::error()";
-}
-
-# end of POSIX::ferror
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fflush.al b/Master/tlpkg/installer/perllib/auto/POSIX/fflush.al
deleted file mode 100644
index 0ba6d1416f0..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fflush.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fflush.al)"
-sub fflush {
- redef "IO::Handle::flush()";
-}
-
-# end of POSIX::fflush
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fgetc.al b/Master/tlpkg/installer/perllib/auto/POSIX/fgetc.al
deleted file mode 100644
index f89a6f86334..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fgetc.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fgetc.al)"
-sub fgetc {
- redef "IO::Handle::getc()";
-}
-
-# end of POSIX::fgetc
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fgetpos.al b/Master/tlpkg/installer/perllib/auto/POSIX/fgetpos.al
deleted file mode 100644
index 7583bbf3da6..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fgetpos.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fgetpos.al)"
-sub fgetpos {
- redef "IO::Seekable::getpos()";
-}
-
-# end of POSIX::fgetpos
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fgets.al b/Master/tlpkg/installer/perllib/auto/POSIX/fgets.al
deleted file mode 100644
index 7edcffdd192..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fgets.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fgets.al)"
-sub fgets {
- redef "IO::Handle::gets()";
-}
-
-# end of POSIX::fgets
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fileno.al b/Master/tlpkg/installer/perllib/auto/POSIX/fileno.al
deleted file mode 100644
index 45f0908329c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fileno.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fileno.al)"
-sub fileno {
- redef "IO::Handle::fileno()";
-}
-
-# end of POSIX::fileno
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fopen.al b/Master/tlpkg/installer/perllib/auto/POSIX/fopen.al
deleted file mode 100644
index 795f272b2bb..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fopen.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fopen.al)"
-sub fopen {
- redef "IO::File::open()";
-}
-
-# end of POSIX::fopen
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fork.al b/Master/tlpkg/installer/perllib/auto/POSIX/fork.al
deleted file mode 100644
index cb0ee7aaf13..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fork.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\fork.al)"
-sub fork {
- usage "fork()" if @_ != 0;
- CORE::fork;
-}
-
-# end of POSIX::fork
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fprintf.al b/Master/tlpkg/installer/perllib/auto/POSIX/fprintf.al
deleted file mode 100644
index 6ac5cb6a065..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fprintf.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fprintf.al)"
-sub fprintf {
- unimpl "fprintf() is C-specific--use printf instead";
-}
-
-# end of POSIX::fprintf
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fputc.al b/Master/tlpkg/installer/perllib/auto/POSIX/fputc.al
deleted file mode 100644
index 71a3b2307bb..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fputc.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fputc.al)"
-sub fputc {
- unimpl "fputc() is C-specific--use print instead";
-}
-
-# end of POSIX::fputc
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fputs.al b/Master/tlpkg/installer/perllib/auto/POSIX/fputs.al
deleted file mode 100644
index 5cc9cdc175b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fputs.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fputs.al)"
-sub fputs {
- unimpl "fputs() is C-specific--use print instead";
-}
-
-# end of POSIX::fputs
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fread.al b/Master/tlpkg/installer/perllib/auto/POSIX/fread.al
deleted file mode 100644
index a2f731a784c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fread.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fread.al)"
-sub fread {
- unimpl "fread() is C-specific--use read instead";
-}
-
-# end of POSIX::fread
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/free.al b/Master/tlpkg/installer/perllib/auto/POSIX/free.al
deleted file mode 100644
index 71eff3059c3..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/free.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 436 "..\..\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/installer/perllib/auto/POSIX/freopen.al b/Master/tlpkg/installer/perllib/auto/POSIX/freopen.al
deleted file mode 100644
index 31e08a2a889..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/freopen.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\freopen.al)"
-sub freopen {
- unimpl "freopen() is C-specific--use open instead";
-}
-
-# end of POSIX::freopen
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fscanf.al b/Master/tlpkg/installer/perllib/auto/POSIX/fscanf.al
deleted file mode 100644
index c5a5e08217b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fscanf.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fscanf.al)"
-sub fscanf {
- unimpl "fscanf() is C-specific--use <> and regular expressions instead";
-}
-
-# end of POSIX::fscanf
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fseek.al b/Master/tlpkg/installer/perllib/auto/POSIX/fseek.al
deleted file mode 100644
index 0a591cca259..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fseek.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fseek.al)"
-sub fseek {
- redef "IO::Seekable::seek()";
-}
-
-# end of POSIX::fseek
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fsetpos.al b/Master/tlpkg/installer/perllib/auto/POSIX/fsetpos.al
deleted file mode 100644
index 311027b54ea..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fsetpos.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fsetpos.al)"
-sub fsetpos {
- redef "IO::Seekable::setpos()";
-}
-
-# end of POSIX::fsetpos
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fstat.al b/Master/tlpkg/installer/perllib/auto/POSIX/fstat.al
deleted file mode 100644
index 084979716d0..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fstat.al
+++ /dev/null
@@ -1,17 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 566 "..\..\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/installer/perllib/auto/POSIX/fsync.al b/Master/tlpkg/installer/perllib/auto/POSIX/fsync.al
deleted file mode 100644
index c8038d1d350..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fsync.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fsync.al)"
-sub fsync {
- redef "IO::Handle::sync()";
-}
-
-# end of POSIX::fsync
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/ftell.al b/Master/tlpkg/installer/perllib/auto/POSIX/ftell.al
deleted file mode 100644
index 1d3490c6033..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/ftell.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\ftell.al)"
-sub ftell {
- redef "IO::Seekable::tell()";
-}
-
-# end of POSIX::ftell
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/fwrite.al b/Master/tlpkg/installer/perllib/auto/POSIX/fwrite.al
deleted file mode 100644
index 1099587edbd..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/fwrite.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\fwrite.al)"
-sub fwrite {
- unimpl "fwrite() is C-specific--use print instead";
-}
-
-# end of POSIX::fwrite
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/getc.al b/Master/tlpkg/installer/perllib/auto/POSIX/getc.al
deleted file mode 100644
index 2ccc28cdf43..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getc.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\getc.al)"
-sub getc {
- usage "getc(handle)" if @_ != 1;
- CORE::getc($_[0]);
-}
-
-# end of POSIX::getc
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/getchar.al b/Master/tlpkg/installer/perllib/auto/POSIX/getchar.al
deleted file mode 100644
index 930386f6827..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getchar.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 318 "..\..\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/installer/perllib/auto/POSIX/getegid.al b/Master/tlpkg/installer/perllib/auto/POSIX/getegid.al
deleted file mode 100644
index 61c0942023f..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getegid.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 659 "..\..\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/installer/perllib/auto/POSIX/getenv.al b/Master/tlpkg/installer/perllib/auto/POSIX/getenv.al
deleted file mode 100644
index c6fec0ca34b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getenv.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 440 "..\..\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/installer/perllib/auto/POSIX/geteuid.al b/Master/tlpkg/installer/perllib/auto/POSIX/geteuid.al
deleted file mode 100644
index 710491ebcc3..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/geteuid.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 664 "..\..\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/installer/perllib/auto/POSIX/getgid.al b/Master/tlpkg/installer/perllib/auto/POSIX/getgid.al
deleted file mode 100644
index 7cd6164fb43..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getgid.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 669 "..\..\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/installer/perllib/auto/POSIX/getgrgid.al b/Master/tlpkg/installer/perllib/auto/POSIX/getgrgid.al
deleted file mode 100644
index 550e75a69f3..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getgrgid.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 135 "..\..\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/installer/perllib/auto/POSIX/getgrnam.al b/Master/tlpkg/installer/perllib/auto/POSIX/getgrnam.al
deleted file mode 100644
index a480731586c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getgrnam.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 140 "..\..\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/installer/perllib/auto/POSIX/getgroups.al b/Master/tlpkg/installer/perllib/auto/POSIX/getgroups.al
deleted file mode 100644
index 5fd0d9d3aea..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getgroups.al
+++ /dev/null
@@ -1,14 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 674 "..\..\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/installer/perllib/auto/POSIX/getlogin.al b/Master/tlpkg/installer/perllib/auto/POSIX/getlogin.al
deleted file mode 100644
index 55bcb4ee9fb..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getlogin.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\getlogin.al)"
-sub getlogin {
- usage "getlogin()" if @_ != 0;
- CORE::getlogin();
-}
-
-# end of POSIX::getlogin
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/getpgrp.al b/Master/tlpkg/installer/perllib/auto/POSIX/getpgrp.al
deleted file mode 100644
index ef0425b7b7f..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getpgrp.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\getpgrp.al)"
-sub getpgrp {
- usage "getpgrp()" if @_ != 0;
- CORE::getpgrp;
-}
-
-# end of POSIX::getpgrp
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/getpid.al b/Master/tlpkg/installer/perllib/auto/POSIX/getpid.al
deleted file mode 100644
index 9aeaa25b63e..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getpid.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\getpid.al)"
-sub getpid {
- usage "getpid()" if @_ != 0;
- $$;
-}
-
-# end of POSIX::getpid
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/getppid.al b/Master/tlpkg/installer/perllib/auto/POSIX/getppid.al
deleted file mode 100644
index 4951623eb04..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getppid.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 695 "..\..\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/installer/perllib/auto/POSIX/getpwnam.al b/Master/tlpkg/installer/perllib/auto/POSIX/getpwnam.al
deleted file mode 100644
index 296b87f28ef..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getpwnam.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 185 "..\..\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/installer/perllib/auto/POSIX/getpwuid.al b/Master/tlpkg/installer/perllib/auto/POSIX/getpwuid.al
deleted file mode 100644
index 5616a6daa2c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getpwuid.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 190 "..\..\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/installer/perllib/auto/POSIX/gets.al b/Master/tlpkg/installer/perllib/auto/POSIX/gets.al
deleted file mode 100644
index 34667890e6e..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/gets.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 323 "..\..\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/installer/perllib/auto/POSIX/getuid.al b/Master/tlpkg/installer/perllib/auto/POSIX/getuid.al
deleted file mode 100644
index 5a326ec67f0..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/getuid.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 700 "..\..\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/installer/perllib/auto/POSIX/gmtime.al b/Master/tlpkg/installer/perllib/auto/POSIX/gmtime.al
deleted file mode 100644
index 6bbf4fc6fef..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/gmtime.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 600 "..\..\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/installer/perllib/auto/POSIX/isatty.al b/Master/tlpkg/installer/perllib/auto/POSIX/isatty.al
deleted file mode 100644
index 9ab71b3c2a0..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/isatty.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 705 "..\..\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/installer/perllib/auto/POSIX/kill.al b/Master/tlpkg/installer/perllib/auto/POSIX/kill.al
deleted file mode 100644
index 12f5276f5f8..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/kill.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\kill.al)"
-sub kill {
- usage "kill(pid, sig)" if @_ != 2;
- CORE::kill $_[1], $_[0];
-}
-
-# end of POSIX::kill
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/labs.al b/Master/tlpkg/installer/perllib/auto/POSIX/labs.al
deleted file mode 100644
index 581a1897d73..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/labs.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 445 "..\..\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/installer/perllib/auto/POSIX/ldiv.al b/Master/tlpkg/installer/perllib/auto/POSIX/ldiv.al
deleted file mode 100644
index 1b704c1fad4..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/ldiv.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 449 "..\..\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/installer/perllib/auto/POSIX/link.al b/Master/tlpkg/installer/perllib/auto/POSIX/link.al
deleted file mode 100644
index e78401a321d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/link.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 710 "..\..\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/installer/perllib/auto/POSIX/load_imports.al b/Master/tlpkg/installer/perllib/auto/POSIX/load_imports.al
deleted file mode 100644
index 6c2ff0ad2ac..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/load_imports.al
+++ /dev/null
@@ -1,225 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 743 "..\..\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 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();
-for (values %EXPORT_TAGS) {
- push @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/installer/perllib/auto/POSIX/localtime.al b/Master/tlpkg/installer/perllib/auto/POSIX/localtime.al
deleted file mode 100644
index dde4f5769ef..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/localtime.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 605 "..\..\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/installer/perllib/auto/POSIX/log.al b/Master/tlpkg/installer/perllib/auto/POSIX/log.al
deleted file mode 100644
index 6e400f25866..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/log.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 165 "..\..\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/installer/perllib/auto/POSIX/longjmp.al b/Master/tlpkg/installer/perllib/auto/POSIX/longjmp.al
deleted file mode 100644
index f3dd3263086..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/longjmp.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 195 "..\..\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/installer/perllib/auto/POSIX/malloc.al b/Master/tlpkg/installer/perllib/auto/POSIX/malloc.al
deleted file mode 100644
index 2f50c6da70a..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/malloc.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 453 "..\..\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/installer/perllib/auto/POSIX/memchr.al b/Master/tlpkg/installer/perllib/auto/POSIX/memchr.al
deleted file mode 100644
index bcdfac6200b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/memchr.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 478 "..\..\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/installer/perllib/auto/POSIX/memcmp.al b/Master/tlpkg/installer/perllib/auto/POSIX/memcmp.al
deleted file mode 100644
index e01575259d4..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/memcmp.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 482 "..\..\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/installer/perllib/auto/POSIX/memcpy.al b/Master/tlpkg/installer/perllib/auto/POSIX/memcpy.al
deleted file mode 100644
index b096a059be9..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/memcpy.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 486 "..\..\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/installer/perllib/auto/POSIX/memmove.al b/Master/tlpkg/installer/perllib/auto/POSIX/memmove.al
deleted file mode 100644
index dd29e805f70..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/memmove.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 490 "..\..\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/installer/perllib/auto/POSIX/memset.al b/Master/tlpkg/installer/perllib/auto/POSIX/memset.al
deleted file mode 100644
index 407980dd938..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/memset.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\memset.al)"
-sub memset {
- unimpl "memset() is C-specific, use x instead";
-}
-
-# end of POSIX::memset
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/mkdir.al b/Master/tlpkg/installer/perllib/auto/POSIX/mkdir.al
deleted file mode 100644
index edb004a11e8..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/mkdir.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 575 "..\..\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/installer/perllib/auto/POSIX/offsetof.al b/Master/tlpkg/installer/perllib/auto/POSIX/offsetof.al
deleted file mode 100644
index 83c2df0e521..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/offsetof.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 221 "..\..\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/installer/perllib/auto/POSIX/opendir.al b/Master/tlpkg/installer/perllib/auto/POSIX/opendir.al
deleted file mode 100644
index 9c508b64371..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/opendir.al
+++ /dev/null
@@ -1,16 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 102 "..\..\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/installer/perllib/auto/POSIX/perror.al b/Master/tlpkg/installer/perllib/auto/POSIX/perror.al
deleted file mode 100644
index df53df18eff..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/perror.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 328 "..\..\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/installer/perllib/auto/POSIX/pow.al b/Master/tlpkg/installer/perllib/auto/POSIX/pow.al
deleted file mode 100644
index 9f1ac2fc14f..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/pow.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 170 "..\..\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/installer/perllib/auto/POSIX/printf.al b/Master/tlpkg/installer/perllib/auto/POSIX/printf.al
deleted file mode 100644
index 28b07d21cd1..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/printf.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 333 "..\..\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/installer/perllib/auto/POSIX/putc.al b/Master/tlpkg/installer/perllib/auto/POSIX/putc.al
deleted file mode 100644
index 484984bcd9f..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/putc.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 338 "..\..\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/installer/perllib/auto/POSIX/putchar.al b/Master/tlpkg/installer/perllib/auto/POSIX/putchar.al
deleted file mode 100644
index a85a0d79b36..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/putchar.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 342 "..\..\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/installer/perllib/auto/POSIX/puts.al b/Master/tlpkg/installer/perllib/auto/POSIX/puts.al
deleted file mode 100644
index 0bd3f4f3b3c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/puts.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 346 "..\..\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/installer/perllib/auto/POSIX/qsort.al b/Master/tlpkg/installer/perllib/auto/POSIX/qsort.al
deleted file mode 100644
index 1621e6db521..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/qsort.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 457 "..\..\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/installer/perllib/auto/POSIX/raise.al b/Master/tlpkg/installer/perllib/auto/POSIX/raise.al
deleted file mode 100644
index 3d078d08f35..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/raise.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 216 "..\..\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/installer/perllib/auto/POSIX/rand.al b/Master/tlpkg/installer/perllib/auto/POSIX/rand.al
deleted file mode 100644
index 78d16fe53cc..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/rand.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\rand.al)"
-sub rand {
- unimpl "rand() is non-portable, use Perl's rand instead";
-}
-
-# end of POSIX::rand
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/readdir.al b/Master/tlpkg/installer/perllib/auto/POSIX/readdir.al
deleted file mode 100644
index 395379abb86..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/readdir.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 110 "..\..\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/installer/perllib/auto/POSIX/realloc.al b/Master/tlpkg/installer/perllib/auto/POSIX/realloc.al
deleted file mode 100644
index 949c4fc3b77..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/realloc.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\realloc.al)"
-sub realloc {
- unimpl "realloc() is C-specific, stopped";
-}
-
-# end of POSIX::realloc
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/redef.al b/Master/tlpkg/installer/perllib/auto/POSIX/redef.al
deleted file mode 100644
index d667327d6b4..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/redef.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 69 "..\..\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/installer/perllib/auto/POSIX/remove.al b/Master/tlpkg/installer/perllib/auto/POSIX/remove.al
deleted file mode 100644
index e29b4531d68..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/remove.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 350 "..\..\lib\POSIX.pm (autosplit into ..\..\lib\auto\POSIX\remove.al)"
-sub remove {
- usage "remove(filename)" if @_ != 1;
- CORE::unlink($_[0]);
-}
-
-# end of POSIX::remove
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/rename.al b/Master/tlpkg/installer/perllib/auto/POSIX/rename.al
deleted file mode 100644
index 6087fefa798..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/rename.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 355 "..\..\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/installer/perllib/auto/POSIX/rewind.al b/Master/tlpkg/installer/perllib/auto/POSIX/rewind.al
deleted file mode 100644
index a07216f1c51..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/rewind.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 360 "..\..\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/installer/perllib/auto/POSIX/rewinddir.al b/Master/tlpkg/installer/perllib/auto/POSIX/rewinddir.al
deleted file mode 100644
index c01271a33d8..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/rewinddir.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 115 "..\..\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/installer/perllib/auto/POSIX/rmdir.al b/Master/tlpkg/installer/perllib/auto/POSIX/rmdir.al
deleted file mode 100644
index b94bdf166ee..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/rmdir.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 715 "..\..\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/installer/perllib/auto/POSIX/scanf.al b/Master/tlpkg/installer/perllib/auto/POSIX/scanf.al
deleted file mode 100644
index 2d4ff839328..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/scanf.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 365 "..\..\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/installer/perllib/auto/POSIX/setbuf.al b/Master/tlpkg/installer/perllib/auto/POSIX/setbuf.al
deleted file mode 100644
index a7de25518fa..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/setbuf.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 720 "..\..\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/installer/perllib/auto/POSIX/setjmp.al b/Master/tlpkg/installer/perllib/auto/POSIX/setjmp.al
deleted file mode 100644
index 780deb31940..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/setjmp.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 199 "..\..\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/installer/perllib/auto/POSIX/setvbuf.al b/Master/tlpkg/installer/perllib/auto/POSIX/setvbuf.al
deleted file mode 100644
index b134e52528d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/setvbuf.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 724 "..\..\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/installer/perllib/auto/POSIX/siglongjmp.al b/Master/tlpkg/installer/perllib/auto/POSIX/siglongjmp.al
deleted file mode 100644
index ab46fac02b6..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/siglongjmp.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 203 "..\..\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/installer/perllib/auto/POSIX/sigsetjmp.al b/Master/tlpkg/installer/perllib/auto/POSIX/sigsetjmp.al
deleted file mode 100644
index 31e563c6f4f..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/sigsetjmp.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 207 "..\..\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/installer/perllib/auto/POSIX/sin.al b/Master/tlpkg/installer/perllib/auto/POSIX/sin.al
deleted file mode 100644
index 9464a28bfea..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/sin.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 175 "..\..\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/installer/perllib/auto/POSIX/sleep.al b/Master/tlpkg/installer/perllib/auto/POSIX/sleep.al
deleted file mode 100644
index e58de4d5602..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/sleep.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 728 "..\..\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/installer/perllib/auto/POSIX/sprintf.al b/Master/tlpkg/installer/perllib/auto/POSIX/sprintf.al
deleted file mode 100644
index 75e6bc5e277..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/sprintf.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 369 "..\..\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/installer/perllib/auto/POSIX/sqrt.al b/Master/tlpkg/installer/perllib/auto/POSIX/sqrt.al
deleted file mode 100644
index 54a2976e2da..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/sqrt.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 180 "..\..\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/installer/perllib/auto/POSIX/srand.al b/Master/tlpkg/installer/perllib/auto/POSIX/srand.al
deleted file mode 100644
index b85fd14c60b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/srand.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\srand.al)"
-sub srand {
- unimpl "srand()";
-}
-
-# end of POSIX::srand
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/sscanf.al b/Master/tlpkg/installer/perllib/auto/POSIX/sscanf.al
deleted file mode 100644
index b6869491e5d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/sscanf.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 374 "..\..\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/installer/perllib/auto/POSIX/stat.al b/Master/tlpkg/installer/perllib/auto/POSIX/stat.al
deleted file mode 100644
index 4016c0e88ab..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/stat.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 580 "..\..\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/installer/perllib/auto/POSIX/strcat.al b/Master/tlpkg/installer/perllib/auto/POSIX/strcat.al
deleted file mode 100644
index 6b9602b93c6..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strcat.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\strcat.al)"
-sub strcat {
- unimpl "strcat() is C-specific, use .= instead";
-}
-
-# end of POSIX::strcat
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strchr.al b/Master/tlpkg/installer/perllib/auto/POSIX/strchr.al
deleted file mode 100644
index 36a59233340..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strchr.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\strchr.al)"
-sub strchr {
- unimpl "strchr() is C-specific, use index() instead";
-}
-
-# end of POSIX::strchr
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strcmp.al b/Master/tlpkg/installer/perllib/auto/POSIX/strcmp.al
deleted file mode 100644
index b0447b9f1db..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strcmp.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\strcmp.al)"
-sub strcmp {
- unimpl "strcmp() is C-specific, use eq instead";
-}
-
-# end of POSIX::strcmp
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strcpy.al b/Master/tlpkg/installer/perllib/auto/POSIX/strcpy.al
deleted file mode 100644
index 5660760b81d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strcpy.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\strcpy.al)"
-sub strcpy {
- unimpl "strcpy() is C-specific, use = instead";
-}
-
-# end of POSIX::strcpy
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strcspn.al b/Master/tlpkg/installer/perllib/auto/POSIX/strcspn.al
deleted file mode 100644
index 4a46be8baaa..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strcspn.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\strcspn.al)"
-sub strcspn {
- unimpl "strcspn() is C-specific, use regular expressions instead";
-}
-
-# end of POSIX::strcspn
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strerror.al b/Master/tlpkg/installer/perllib/auto/POSIX/strerror.al
deleted file mode 100644
index cc4c86dbae4..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strerror.al
+++ /dev/null
@@ -1,14 +0,0 @@
-# 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\strerror.al)"
-sub strerror {
- usage "strerror(errno)" if @_ != 1;
- local $! = $_[0];
- $! . "";
-}
-
-# end of POSIX::strerror
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strlen.al b/Master/tlpkg/installer/perllib/auto/POSIX/strlen.al
deleted file mode 100644
index 9cc9df2d315..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strlen.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 524 "..\..\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/installer/perllib/auto/POSIX/strncat.al b/Master/tlpkg/installer/perllib/auto/POSIX/strncat.al
deleted file mode 100644
index 4f09a52c298..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strncat.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 528 "..\..\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/installer/perllib/auto/POSIX/strncmp.al b/Master/tlpkg/installer/perllib/auto/POSIX/strncmp.al
deleted file mode 100644
index b4dfc9ab0b4..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strncmp.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 532 "..\..\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/installer/perllib/auto/POSIX/strncpy.al b/Master/tlpkg/installer/perllib/auto/POSIX/strncpy.al
deleted file mode 100644
index 98b3c081e68..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strncpy.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 536 "..\..\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/installer/perllib/auto/POSIX/strpbrk.al b/Master/tlpkg/installer/perllib/auto/POSIX/strpbrk.al
deleted file mode 100644
index 227c00d76cc..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strpbrk.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\strpbrk.al)"
-sub strpbrk {
- unimpl "strpbrk() is C-specific, stopped";
-}
-
-# end of POSIX::strpbrk
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strrchr.al b/Master/tlpkg/installer/perllib/auto/POSIX/strrchr.al
deleted file mode 100644
index 1dd2a6ebf04..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strrchr.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\strrchr.al)"
-sub strrchr {
- unimpl "strrchr() is C-specific, use rindex() instead";
-}
-
-# end of POSIX::strrchr
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strspn.al b/Master/tlpkg/installer/perllib/auto/POSIX/strspn.al
deleted file mode 100644
index 3bd65863563..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strspn.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\strspn.al)"
-sub strspn {
- unimpl "strspn() is C-specific, stopped";
-}
-
-# end of POSIX::strspn
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strstr.al b/Master/tlpkg/installer/perllib/auto/POSIX/strstr.al
deleted file mode 100644
index f755459b68f..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strstr.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\strstr.al)"
-sub strstr {
- usage "strstr(big, little)" if @_ != 2;
- CORE::index($_[0], $_[1]);
-}
-
-# end of POSIX::strstr
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/strtok.al b/Master/tlpkg/installer/perllib/auto/POSIX/strtok.al
deleted file mode 100644
index bae94c9282a..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/strtok.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 557 "..\..\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/installer/perllib/auto/POSIX/system.al b/Master/tlpkg/installer/perllib/auto/POSIX/system.al
deleted file mode 100644
index 1b51e8f5209..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/system.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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\system.al)"
-sub system {
- usage "system(command)" if @_ != 1;
- CORE::system($_[0]);
-}
-
-# end of POSIX::system
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/time.al b/Master/tlpkg/installer/perllib/auto/POSIX/time.al
deleted file mode 100644
index 6b404400fd4..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/time.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 610 "..\..\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/installer/perllib/auto/POSIX/tmpfile.al b/Master/tlpkg/installer/perllib/auto/POSIX/tmpfile.al
deleted file mode 100644
index aa223d6a27c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/tmpfile.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 378 "..\..\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/installer/perllib/auto/POSIX/tolower.al b/Master/tlpkg/installer/perllib/auto/POSIX/tolower.al
deleted file mode 100644
index 57937313fc9..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/tolower.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 87 "..\..\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/installer/perllib/auto/POSIX/toupper.al b/Master/tlpkg/installer/perllib/auto/POSIX/toupper.al
deleted file mode 100644
index a5484a70aa6..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/toupper.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 92 "..\..\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/installer/perllib/auto/POSIX/umask.al b/Master/tlpkg/installer/perllib/auto/POSIX/umask.al
deleted file mode 100644
index 8bf64ae7f0e..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/umask.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 585 "..\..\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/installer/perllib/auto/POSIX/ungetc.al b/Master/tlpkg/installer/perllib/auto/POSIX/ungetc.al
deleted file mode 100644
index 874e4416f71..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/ungetc.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 382 "..\..\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/installer/perllib/auto/POSIX/unimpl.al b/Master/tlpkg/installer/perllib/auto/POSIX/unimpl.al
deleted file mode 100644
index e1c36c60f85..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/unimpl.al
+++ /dev/null
@@ -1,14 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 74 "..\..\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/installer/perllib/auto/POSIX/unlink.al b/Master/tlpkg/installer/perllib/auto/POSIX/unlink.al
deleted file mode 100644
index c8f58ab9836..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/unlink.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 733 "..\..\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/installer/perllib/auto/POSIX/usage.al b/Master/tlpkg/installer/perllib/auto/POSIX/usage.al
deleted file mode 100644
index 0b2b0bd6115..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/usage.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 64 "..\..\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/installer/perllib/auto/POSIX/utime.al b/Master/tlpkg/installer/perllib/auto/POSIX/utime.al
deleted file mode 100644
index 68008e7e110..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/utime.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 738 "..\..\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/installer/perllib/auto/POSIX/vfprintf.al b/Master/tlpkg/installer/perllib/auto/POSIX/vfprintf.al
deleted file mode 100644
index fb502afc761..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/vfprintf.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 386 "..\..\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/installer/perllib/auto/POSIX/vprintf.al b/Master/tlpkg/installer/perllib/auto/POSIX/vprintf.al
deleted file mode 100644
index 28108face71..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/vprintf.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\vprintf.al)"
-sub vprintf {
- unimpl "vprintf() is C-specific";
-}
-
-# end of POSIX::vprintf
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/vsprintf.al b/Master/tlpkg/installer/perllib/auto/POSIX/vsprintf.al
deleted file mode 100644
index 9d4f008ebbc..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/vsprintf.al
+++ /dev/null
@@ -1,12 +0,0 @@
-# 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\vsprintf.al)"
-sub vsprintf {
- unimpl "vsprintf() is C-specific";
-}
-
-# end of POSIX::vsprintf
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/POSIX/wait.al b/Master/tlpkg/installer/perllib/auto/POSIX/wait.al
deleted file mode 100644
index 57d9701f4ff..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/wait.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 590 "..\..\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/installer/perllib/auto/POSIX/waitpid.al b/Master/tlpkg/installer/perllib/auto/POSIX/waitpid.al
deleted file mode 100644
index 6cd31c21009..00000000000
--- a/Master/tlpkg/installer/perllib/auto/POSIX/waitpid.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# NOTE: Derived from ..\..\lib\POSIX.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package POSIX;
-
-#line 595 "..\..\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/installer/perllib/auto/Tk/CancelRepeat.al b/Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al
deleted file mode 100644
index d0d6bb1b2a3..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# NOTE: Derived from blib\lib\Tk.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package Tk;
-
-#line 491 "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/installer/perllib/auto/Tk/Canvas/Canvas.bs b/Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.dll b/Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.dll
deleted file mode 100755
index 85fdb8e0f02..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix
deleted file mode 100644
index 9831f74facb..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix
+++ /dev/null
@@ -1,6 +0,0 @@
-# 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/installer/perllib/auto/Tk/Clipboard/getSelected.al b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al
deleted file mode 100644
index 44ba7b74bf0..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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/installer/perllib/auto/Tk/Entry/Entry.bs b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll
deleted file mode 100755
index 9b1c07a7792..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Error.al b/Master/tlpkg/installer/perllib/auto/Tk/Error.al
deleted file mode 100644
index 7efe2c7043d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Error.al
+++ /dev/null
@@ -1,20 +0,0 @@
-# NOTE: Derived from blib\lib\Tk.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package Tk;
-
-#line 479 "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/installer/perllib/auto/Tk/Event/Event.bs b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll
deleted file mode 100755
index 5a9706cb92e..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Frame/AddScrollbars.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/AddScrollbars.al
deleted file mode 100644
index aa12259f675..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/AddScrollbars.al
+++ /dev/null
@@ -1,52 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/FindMenu.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/FindMenu.al
deleted file mode 100644
index 66e71c29b21..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/FindMenu.al
+++ /dev/null
@@ -1,22 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix
deleted file mode 100644
index 6e5b939fce1..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix
+++ /dev/null
@@ -1,24 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/freeze_on_map.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/freeze_on_map.al
deleted file mode 100644
index 6a8b8a4f96e..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/freeze_on_map.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/label.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/label.al
deleted file mode 100644
index 83ec70ed803..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/label.al
+++ /dev/null
@@ -1,24 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/labelPack.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/labelPack.al
deleted file mode 100644
index 0cfa8631c24..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/labelPack.al
+++ /dev/null
@@ -1,50 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/labelVariable.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/labelVariable.al
deleted file mode 100644
index ca60cff1288..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/labelVariable.al
+++ /dev/null
@@ -1,27 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/packscrollbars.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/packscrollbars.al
deleted file mode 100644
index 9990eb67b13..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/packscrollbars.al
+++ /dev/null
@@ -1,86 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/queuePack.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/queuePack.al
deleted file mode 100644
index 59fe3ee4de0..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/queuePack.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/sbset.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/sbset.al
deleted file mode 100644
index cca4f0d642a..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/sbset.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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/installer/perllib/auto/Tk/Frame/scrollbars.al b/Master/tlpkg/installer/perllib/auto/Tk/Frame/scrollbars.al
deleted file mode 100644
index 21eeb53d2b9..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Frame/scrollbars.al
+++ /dev/null
@@ -1,24 +0,0 @@
-# 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/installer/perllib/auto/Tk/PNG/PNG.bs b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll
deleted file mode 100755
index 08bbbed4fcc..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al b/Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al
deleted file mode 100644
index e71d2a337a0..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al
+++ /dev/null
@@ -1,16 +0,0 @@
-# NOTE: Derived from blib\lib\Tk.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package Tk;
-
-#line 498 "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/installer/perllib/auto/Tk/Scrollbar/ButtonDown.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonDown.al
deleted file mode 100644
index d80e2217abc..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonDown.al
+++ /dev/null
@@ -1,55 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/ButtonUp.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonUp.al
deleted file mode 100644
index 68857548755..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonUp.al
+++ /dev/null
@@ -1,26 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/Drag.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Drag.al
deleted file mode 100644
index 988f9d4a3ef..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Drag.al
+++ /dev/null
@@ -1,43 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/EndDrag.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/EndDrag.al
deleted file mode 100644
index 8c401b6fc31..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/EndDrag.al
+++ /dev/null
@@ -1,28 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/Enter.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Enter.al
deleted file mode 100644
index 9584a7fa34c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Enter.al
+++ /dev/null
@@ -1,21 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/Leave.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Leave.al
deleted file mode 100644
index a6c5e89d91e..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Leave.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/Motion.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Motion.al
deleted file mode 100644
index 46aac656c70..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Motion.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/ScrlByPages.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByPages.al
deleted file mode 100644
index 9d4018e9128..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByPages.al
+++ /dev/null
@@ -1,38 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/ScrlByUnits.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByUnits.al
deleted file mode 100644
index a364b3e52ce..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByUnits.al
+++ /dev/null
@@ -1,37 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/ScrlToPos.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlToPos.al
deleted file mode 100644
index e277237953e..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlToPos.al
+++ /dev/null
@@ -1,35 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/ScrlTopBottom.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlTopBottom.al
deleted file mode 100644
index 7a00efe616f..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlTopBottom.al
+++ /dev/null
@@ -1,32 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/Scrollbar.bs b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.dll b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.dll
deleted file mode 100755
index e8caf25b628..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Select.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Select.al
deleted file mode 100644
index 0da50da443b..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Select.al
+++ /dev/null
@@ -1,59 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/StartDrag.al b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/StartDrag.al
deleted file mode 100644
index 32edbfdef24..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/StartDrag.al
+++ /dev/null
@@ -1,38 +0,0 @@
-# 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/installer/perllib/auto/Tk/Scrollbar/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/autosplit.ix
deleted file mode 100644
index 293d1322dd4..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/autosplit.ix
+++ /dev/null
@@ -1,30 +0,0 @@
-# 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/installer/perllib/auto/Tk/Text/Text.bs b/Master/tlpkg/installer/perllib/auto/Tk/Text/Text.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Text/Text.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Text/Text.dll b/Master/tlpkg/installer/perllib/auto/Tk/Text/Text.dll
deleted file mode 100755
index 2b0235a8221..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Text/Text.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Text/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Text/autosplit.ix
deleted file mode 100644
index 48a5455c34a..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Text/autosplit.ix
+++ /dev/null
@@ -1,3 +0,0 @@
-# Index created by AutoSplit for ..\blib\lib\Tk\Text.pm
-# (file acts as timestamp)
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Tk.bs b/Master/tlpkg/installer/perllib/auto/Tk/Tk.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Tk.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Tk.dll b/Master/tlpkg/installer/perllib/auto/Tk/Tk.dll
deleted file mode 100755
index 8d80944808d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Tk.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix
deleted file mode 100644
index 859b90d9a40..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix
+++ /dev/null
@@ -1,10 +0,0 @@
-# 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/installer/perllib/auto/Tk/Widget/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix
deleted file mode 100644
index b610773d4dc..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix
+++ /dev/null
@@ -1,11 +0,0 @@
-# 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
-;
-1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al
deleted file mode 100644
index 538612878ed..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al
+++ /dev/null
@@ -1,17 +0,0 @@
-# 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/installer/perllib/auto/Tk/Wm/FullScreen.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al
deleted file mode 100644
index 4d5702cc60d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al
+++ /dev/null
@@ -1,29 +0,0 @@
-# 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/installer/perllib/auto/Tk/Wm/Popup.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al
deleted file mode 100644
index 3f460c5bac6..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al
+++ /dev/null
@@ -1,50 +0,0 @@
-# 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/installer/perllib/auto/Tk/Wm/Post.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al
deleted file mode 100644
index f3f5c8e3e08..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al
+++ /dev/null
@@ -1,20 +0,0 @@
-# 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/installer/perllib/auto/Tk/Wm/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix
deleted file mode 100644
index 201dbe8ba99..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix
+++ /dev/null
@@ -1,14 +0,0 @@
-# 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/installer/perllib/auto/Tk/Wm/iconposition.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al
deleted file mode 100644
index 9254968f61c..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al
+++ /dev/null
@@ -1,24 +0,0 @@
-# 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/installer/perllib/auto/Tk/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix
deleted file mode 100644
index 7bd25b78a9a..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix
+++ /dev/null
@@ -1,45 +0,0 @@
-# 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 focusPrev
-;
-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/installer/perllib/auto/Tk/getEncoding.al b/Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al
deleted file mode 100644
index b9e230edbf1..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al
+++ /dev/null
@@ -1,43 +0,0 @@
-# NOTE: Derived from blib\lib\Tk.pm.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package Tk;
-
-#line 785 "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/installer/perllib/auto/Win32/API/API.bs b/Master/tlpkg/installer/perllib/auto/Win32/API/API.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Win32/API/API.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/API.dll b/Master/tlpkg/installer/perllib/auto/Win32/API/API.dll
deleted file mode 100644
index 3a7efc0adca..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Win32/API/API.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll
deleted file mode 100644
index 147c679d576..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.bs b/Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.dll b/Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.dll
deleted file mode 100644
index 17889059886..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs
+++ /dev/null
diff --git a/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll
deleted file mode 100755
index 45b7bc0688a..00000000000
--- a/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/base.pm b/Master/tlpkg/installer/perllib/base.pm
deleted file mode 100644
index 001914be4d3..00000000000
--- a/Master/tlpkg/installer/perllib/base.pm
+++ /dev/null
@@ -1,226 +0,0 @@
-package base;
-
-use strict 'vars';
-use vars qw($VERSION);
-$VERSION = '2.07';
-
-# constant.pm is slow
-sub SUCCESS () { 1 }
-
-sub PUBLIC () { 2**0 }
-sub PRIVATE () { 2**1 }
-sub INHERITED () { 2**2 }
-sub PROTECTED () { 2**3 }
-
-
-my $Fattr = \%fields::attr;
-
-sub has_fields {
- my($base) = shift;
- my $fglob = ${"$base\::"}{FIELDS};
- return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
-}
-
-sub has_version {
- my($base) = shift;
- my $vglob = ${$base.'::'}{VERSION};
- return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
-}
-
-sub has_attr {
- my($proto) = shift;
- my($class) = ref $proto || $proto;
- return exists $Fattr->{$class};
-}
-
-sub get_attr {
- $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
- return $Fattr->{$_[0]};
-}
-
-if ($] < 5.009) {
- *get_fields = sub {
- # Shut up a possible typo warning.
- () = \%{$_[0].'::FIELDS'};
- my $f = \%{$_[0].'::FIELDS'};
-
- # should be centralized in fields? perhaps
- # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
- # is used here anyway, it doesn't matter.
- bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
-
- return $f;
- }
-}
-else {
- *get_fields = sub {
- # Shut up a possible typo warning.
- () = \%{$_[0].'::FIELDS'};
- return \%{$_[0].'::FIELDS'};
- }
-}
-
-sub import {
- my $class = shift;
-
- return SUCCESS unless @_;
-
- # List of base classes from which we will inherit %FIELDS.
- my $fields_base;
-
- my $inheritor = caller(0);
-
- foreach my $base (@_) {
- next if $inheritor->isa($base);
-
- if (has_version($base)) {
- ${$base.'::VERSION'} = '-1, set by base.pm'
- unless defined ${$base.'::VERSION'};
- }
- else {
- local $SIG{__DIE__};
- eval "require $base";
- # Only ignore "Can't locate" errors from our eval require.
- # Other fatal errors (syntax etc) must be reported.
- die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
- unless (%{"$base\::"}) {
- require Carp;
- Carp::croak(<<ERROR);
-Base class package "$base" is empty.
- (Perhaps you need to 'use' the module which defines that package first.)
-ERROR
-
- }
- ${$base.'::VERSION'} = "-1, set by base.pm"
- unless defined ${$base.'::VERSION'};
- }
- push @{"$inheritor\::ISA"}, $base;
-
- if ( has_fields($base) || has_attr($base) ) {
- # No multiple fields inheritence *suck*
- if ($fields_base) {
- require Carp;
- Carp::croak("Can't multiply inherit %FIELDS");
- } else {
- $fields_base = $base;
- }
- }
- }
-
- if( defined $fields_base ) {
- inherit_fields($inheritor, $fields_base);
- }
-}
-
-
-sub inherit_fields {
- my($derived, $base) = @_;
-
- return SUCCESS unless $base;
-
- my $battr = get_attr($base);
- my $dattr = get_attr($derived);
- my $dfields = get_fields($derived);
- my $bfields = get_fields($base);
-
- $dattr->[0] = @$battr;
-
- if( keys %$dfields ) {
- warn "$derived is inheriting from $base but already has its own ".
- "fields!\n".
- "This will cause problems.\n".
- "Be sure you use base BEFORE declaring fields\n";
- }
-
- # Iterate through the base's fields adding all the non-private
- # ones to the derived class. Hang on to the original attribute
- # (Public, Private, etc...) and add Inherited.
- # This is all too complicated to do efficiently with add_fields().
- while (my($k,$v) = each %$bfields) {
- my $fno;
- if ($fno = $dfields->{$k} and $fno != $v) {
- require Carp;
- Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
- }
-
- if( $battr->[$v] & PRIVATE ) {
- $dattr->[$v] = PRIVATE | INHERITED;
- }
- else {
- $dattr->[$v] = INHERITED | $battr->[$v];
- $dfields->{$k} = $v;
- }
- }
-
- foreach my $idx (1..$#{$battr}) {
- next if defined $dattr->[$idx];
- $dattr->[$idx] = $battr->[$idx] & INHERITED;
- }
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-base - Establish IS-A relationship with base classes at compile time
-
-=head1 SYNOPSIS
-
- package Baz;
- use base 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. Roughly similar in effect to
-
- package Baz;
- BEGIN {
- require Foo;
- require Bar;
- push @ISA, qw(Foo Bar);
- }
-
-If any of the listed modules are not loaded yet, I<base> silently attempts to
-C<require> them (and silently continues if the C<require> failed). Whether to
-C<require> a base class module is determined by the absence of a global variable
-$VERSION in the base package. If $VERSION is not detected even after loading
-it, <base> will define $VERSION in the base package, setting it to the string
-C<-1, set by base.pm>.
-
-Will also initialize the fields if one of the base classes has it.
-Multiple inheritence of fields is B<NOT> supported, if two or more
-base classes each have inheritable fields the 'base' pragma will
-croak. See L<fields>, L<public> and L<protected> for a description of
-this feature.
-
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item Base class package "%s" is empty.
-
-base.pm was unable to require the base package, because it was not
-found in your path.
-
-=back
-
-=head1 HISTORY
-
-This module was introduced with Perl 5.004_04.
-
-
-=head1 CAVEATS
-
-Due to the limitations of the implementation, you must use
-base I<before> you declare any of your own fields.
-
-
-=head1 SEE ALSO
-
-L<fields>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/bytes.pm b/Master/tlpkg/installer/perllib/bytes.pm
deleted file mode 100644
index a8222794ddf..00000000000
--- a/Master/tlpkg/installer/perllib/bytes.pm
+++ /dev/null
@@ -1,88 +0,0 @@
-package bytes;
-
-our $VERSION = '1.02';
-
-$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/installer/perllib/bytes_heavy.pl b/Master/tlpkg/installer/perllib/bytes_heavy.pl
deleted file mode 100644
index 923381de58d..00000000000
--- a/Master/tlpkg/installer/perllib/bytes_heavy.pl
+++ /dev/null
@@ -1,40 +0,0 @@
-package bytes;
-
-sub length ($) {
- BEGIN { bytes::import() }
- return CORE::length($_[0]);
-}
-
-sub substr ($$;$$) {
- BEGIN { bytes::import() }
- return
- @_ == 2 ? CORE::substr($_[0], $_[1]) :
- @_ == 3 ? CORE::substr($_[0], $_[1], $_[2]) :
- CORE::substr($_[0], $_[1], $_[2], $_[3]) ;
-}
-
-sub ord ($) {
- BEGIN { bytes::import() }
- return CORE::ord($_[0]);
-}
-
-sub chr ($) {
- BEGIN { bytes::import() }
- return CORE::chr($_[0]);
-}
-
-sub index ($$;$) {
- BEGIN { bytes::import() }
- return
- @_ == 2 ? CORE::index($_[0], $_[1]) :
- CORE::index($_[0], $_[1], $_[2]) ;
-}
-
-sub rindex ($$;$) {
- BEGIN { bytes::import() }
- return
- @_ == 2 ? CORE::rindex($_[0], $_[1]) :
- CORE::rindex($_[0], $_[1], $_[2]) ;
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/constant.pm b/Master/tlpkg/installer/perllib/constant.pm
deleted file mode 100644
index 159c29978a5..00000000000
--- a/Master/tlpkg/installer/perllib/constant.pm
+++ /dev/null
@@ -1,340 +0,0 @@
-package constant;
-
-use strict;
-use 5.006_00;
-use warnings::register;
-
-our($VERSION, %declared);
-$VERSION = '1.05';
-
-#=======================================================================
-
-# Some names are evil choices.
-my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
-
-my %forced_into_main = map +($_, 1),
- qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
-
-my %forbidden = (%keywords, %forced_into_main);
-
-#=======================================================================
-# import() - import symbols into user's namespace
-#
-# What we actually do is define a function in the caller's namespace
-# which returns the value. The function we create will normally
-# be inlined as a constant, thereby avoiding further sub calling
-# overhead.
-#=======================================================================
-sub import {
- my $class = shift;
- return unless @_; # Ignore 'use constant;'
- my %constants = ();
- my $multiple = ref $_[0];
-
- 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");
- }
- my $pkg = caller;
-
- # Normal constant name
- if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) {
- # Everything is okay
-
- # Name forced into main, but we're not in main. Fatal.
- } elsif ($forced_into_main{$name} and $pkg ne 'main') {
- require Carp;
- Carp::croak("Constant name '$name' is forced into main::");
-
- # Starts with double underscore. Fatal.
- } elsif ($name =~ /^__/) {
- require Carp;
- Carp::croak("Constant name '$name' begins with '__'");
-
- # Maybe the name is tolerable
- } elsif ($name =~ /^[A-Za-z_]\w*\z/) {
- # Then we'll warn only if you've asked for warnings
- if (warnings::enabled()) {
- if ($keywords{$name}) {
- warnings::warn("Constant name '$name' is a Perl keyword");
- } elsif ($forced_into_main{$name}) {
- warnings::warn("Constant name '$name' is " .
- "forced into package main::");
- }
- }
-
- # Looks like a boolean
- # use constant FRED == fred;
- } elsif ($name =~ /^[01]?\z/) {
- 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) {
- my $scalar = $constants{$name};
- *$full_name = sub () { $scalar };
- } else {
- if (@_ == 1) {
- my $scalar = $_[0];
- *$full_name = sub () { $scalar };
- } elsif (@_) {
- my @list = @_;
- *$full_name = sub () { @list };
- } else {
- *$full_name = sub () { };
- }
- }
- }
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-constant - Perl pragma to declare constants
-
-=head1 SYNOPSIS
-
- use constant PI => 4 * atan2(1, 1);
- use constant DEBUG => 0;
-
- print "Pi equals ", PI, "...\n" if DEBUG;
-
- use constant {
- SEC => 0,
- MIN => 1,
- HOUR => 2,
- MDAY => 3,
- MON => 4,
- YEAR => 5,
- WDAY => 6,
- YDAY => 7,
- ISDST => 8,
- };
-
- use constant WEEKDAYS => qw(
- Sunday Monday Tuesday Wednesday Thursday Friday Saturday
- );
-
- print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n";
-
-=head1 DESCRIPTION
-
-This will declare a symbol to be a constant with the given value.
-
-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 localtime() in list context. To set it to the string
-returned by 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 BUGS
-
-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 AUTHOR
-
-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>.
-
-=head1 COPYRIGHT
-
-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/installer/perllib/fields.pm b/Master/tlpkg/installer/perllib/fields.pm
deleted file mode 100644
index cca778f905d..00000000000
--- a/Master/tlpkg/installer/perllib/fields.pm
+++ /dev/null
@@ -1,319 +0,0 @@
-package fields;
-
-require 5.005;
-use strict;
-no strict 'refs';
-unless( eval q{require warnings::register; warnings::register->import} ) {
- *warnings::warnif = sub {
- require Carp;
- Carp::carp(@_);
- }
-}
-use vars qw(%attr $VERSION);
-
-$VERSION = '2.03';
-
-# 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, keys %{$class.'::FIELDS'});
- return $self;
- }
-}
-
-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/installer/perllib/lib.pm b/Master/tlpkg/installer/perllib/lib.pm
deleted file mode 100644
index 06a03502368..00000000000
--- a/Master/tlpkg/installer/perllib/lib.pm
+++ /dev/null
@@ -1,206 +0,0 @@
-package lib;
-
-# THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL.
-# ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD.
-
-use Config;
-
-use strict;
-
-my $archname = $Config{archname};
-my $version = $Config{version};
-my @inc_version_list = reverse split / /, $Config{inc_version_list};
-
-
-our @ORIG_INC = @INC; # take a handy copy of 'original' value
-our $VERSION = '0.5565';
-my $Is_MacOS = $^O eq 'MacOS';
-my $Mac_FS;
-if ($Is_MacOS) {
- require File::Spec;
- $Mac_FS = eval { require Mac::FileSpec::Unixish };
-}
-
-sub import {
- shift;
-
- my %names;
- foreach (reverse @_) {
- my $path = $_; # we'll be modifying it, so break the alias
- if ($path eq '') {
- require Carp;
- Carp::carp("Empty compile time value given to use lib");
- }
-
- $path = _nativize($path);
-
- if (-e $path && ! -d _) {
- require Carp;
- Carp::carp("Parameter to use lib must be directory, not file");
- }
- unshift(@INC, $path);
- # Add any previous version directories we found at configure time
- foreach my $incver (@inc_version_list)
- {
- my $dir = $Is_MacOS
- ? File::Spec->catdir( $path, $incver )
- : "$path/$incver";
- unshift(@INC, $dir) if -d $dir;
- }
- # Put a corresponding archlib directory in front of $path if it
- # looks like $path has an archlib directory below it.
- my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
- = _get_dirs($path);
- unshift(@INC, $arch_dir) if -d $arch_auto_dir;
- unshift(@INC, $version_dir) if -d $version_dir;
- unshift(@INC, $version_arch_dir) if -d $version_arch_dir;
- }
-
- # remove trailing duplicates
- @INC = grep { ++$names{$_} == 1 } @INC;
- return;
-}
-
-
-sub unimport {
- shift;
-
- my %names;
- foreach (@_) {
- my $path = _nativize($_);
-
- my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
- = _get_dirs($path);
- ++$names{$path};
- ++$names{$arch_dir} if -d $arch_auto_dir;
- ++$names{$version_dir} if -d $version_dir;
- ++$names{$version_arch_dir} if -d $version_arch_dir;
- }
-
- # Remove ALL instances of each named directory.
- @INC = grep { !exists $names{$_} } @INC;
- return;
-}
-
-sub _get_dirs {
- my($dir) = @_;
- my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
-
- # we could use this for all platforms in the future, but leave it
- # Mac-only for now, until there is more time for testing it.
- if ($Is_MacOS) {
- $arch_auto_dir = File::Spec->catdir( $dir, $archname, 'auto' );
- $arch_dir = File::Spec->catdir( $dir, $archname, );
- $version_dir = File::Spec->catdir( $dir, $version );
- $version_arch_dir = File::Spec->catdir( $dir, $version, $archname );
- } else {
- $arch_auto_dir = "$dir/$archname/auto";
- $arch_dir = "$dir/$archname";
- $version_dir = "$dir/$version";
- $version_arch_dir = "$dir/$version/$archname";
- }
- return($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
-}
-
-sub _nativize {
- my($dir) = @_;
-
- if ($Is_MacOS && $Mac_FS && ! -d $dir) {
- $dir = Mac::FileSpec::Unixish::nativize($dir);
- $dir .= ":" unless $dir =~ /:$/;
- }
-
- return $dir;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-lib - manipulate @INC at compile time
-
-=head1 SYNOPSIS
-
- use lib LIST;
-
- no lib LIST;
-
-=head1 DESCRIPTION
-
-This is a small simple module which simplifies the manipulation of @INC
-at compile time.
-
-It is typically used to add extra directories to perl's search path so
-that later C<use> or C<require> statements will find modules which are
-not located on perl's default search path.
-
-=head2 Adding directories to @INC
-
-The parameters to C<use lib> are added to the start of the perl search
-path. Saying
-
- use lib LIST;
-
-is I<almost> the same as saying
-
- BEGIN { unshift(@INC, LIST) }
-
-For each directory in LIST (called $dir here) the lib module also
-checks to see if a directory called $dir/$archname/auto exists.
-If so the $dir/$archname directory is assumed to be a corresponding
-architecture specific directory and is added to @INC in front of $dir.
-
-To avoid memory leaks, all trailing duplicate entries in @INC are
-removed.
-
-=head2 Deleting directories from @INC
-
-You should normally only add directories to @INC. If you need to
-delete directories from @INC take care to only delete those which you
-added yourself or which you are certain are not needed by other modules
-in your script. Other modules may have added directories which they
-need for correct operation.
-
-The C<no lib> statement deletes all instances of each named directory
-from @INC.
-
-For each directory in LIST (called $dir here) the lib module also
-checks to see if a directory called $dir/$archname/auto exists.
-If so the $dir/$archname directory is assumed to be a corresponding
-architecture specific directory and is also deleted from @INC.
-
-=head2 Restoring original @INC
-
-When the lib module is first loaded it records the current value of @INC
-in an array C<@lib::ORIG_INC>. To restore @INC to that value you
-can say
-
- @INC = @lib::ORIG_INC;
-
-=head1 CAVEATS
-
-In order to keep lib.pm small and simple, it only works with Unix
-filepaths. This doesn't mean it only works on Unix, but non-Unix
-users must first translate their file paths to Unix conventions.
-
- # VMS users wanting to put [.stuff.moo] into
- # their @INC would write
- use lib 'stuff/moo';
-
-=head1 NOTES
-
-In the future, this module will likely use File::Spec for determining
-paths, as it does now for Mac OS (where Unix-style or Mac-style paths
-work, and Unix-style paths are converted properly to Mac-style paths
-before being added to @INC).
-
-=head1 SEE ALSO
-
-FindBin - optional module which deals with paths relative to the source file.
-
-=head1 AUTHOR
-
-Tim Bunce, 2nd June 1995.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/newgetopt.pl b/Master/tlpkg/installer/perllib/newgetopt.pl
deleted file mode 100644
index 95eef220fe7..00000000000
--- a/Master/tlpkg/installer/perllib/newgetopt.pl
+++ /dev/null
@@ -1,75 +0,0 @@
-# $Id: newgetopt.pl,v 1.18 2001-09-21 15:34:59+02 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/installer/perllib/overload.pm b/Master/tlpkg/installer/perllib/overload.pm
deleted file mode 100644
index 15b7e775e74..00000000000
--- a/Master/tlpkg/installer/perllib/overload.pm
+++ /dev/null
@@ -1,1434 +0,0 @@
-package overload;
-
-our $VERSION = '1.04';
-
-$overload::hint_bits = 0x20000; # HINT_LOCALIZE_HH
-
-sub nil {}
-
-sub OVERLOAD {
- $package = shift;
- my %arg = @_;
- my ($sub, $fb);
- $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
- *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
- for (keys %arg) {
- if ($_ eq 'fallback') {
- $fb = $arg{$_};
- } else {
- $sub = $arg{$_};
- if (not ref $sub and $sub !~ /::/) {
- $ {$package . "::(" . $_} = $sub;
- $sub = \&nil;
- }
- #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
- *{$package . "::(" . $_} = \&{ $sub };
- }
- }
- ${$package . "::()"} = $fb; # Make it findable too (fallback only).
-}
-
-sub import {
- $package = (caller())[0];
- # *{$package . "::OVERLOAD"} = \&OVERLOAD;
- shift;
- $package->overload::OVERLOAD(@_);
-}
-
-sub unimport {
- $package = (caller())[0];
- ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
- shift;
- for (@_) {
- if ($_ eq 'fallback') {
- undef $ {$package . "::()"};
- } else {
- delete $ {$package . "::"}{"(" . $_};
- }
- }
-}
-
-sub Overloaded {
- my $package = shift;
- $package = ref $package if ref $package;
- $package->can('()');
-}
-
-sub ov_method {
- my $globref = shift;
- return undef unless $globref;
- my $sub = \&{*$globref};
- return $sub if $sub ne \&nil;
- return shift->can($ {*$globref});
-}
-
-sub OverloadedStringify {
- my $package = shift;
- $package = ref $package if ref $package;
- #$package->can('(""')
- ov_method mycan($package, '(""'), $package
- or ov_method mycan($package, '(0+'), $package
- or ov_method mycan($package, '(bool'), $package
- or ov_method mycan($package, '(nomethod'), $package;
-}
-
-sub Method {
- my $package = shift;
- $package = ref $package if ref $package;
- #my $meth = $package->can('(' . shift);
- ov_method mycan($package, '(' . shift), $package;
- #return $meth if $meth ne \&nil;
- #return $ {*{$meth}};
-}
-
-sub AddrRef {
- my $package = ref $_[0];
- return "$_[0]" unless $package;
-
- require Scalar::Util;
- my $class = Scalar::Util::blessed($_[0]);
- my $class_prefix = defined($class) ? "$class=" : "";
- my $type = Scalar::Util::reftype($_[0]);
- my $addr = Scalar::Util::refaddr($_[0]);
- return sprintf("$class_prefix$type(0x%x)", $addr);
-}
-
-*StrVal = *AddrRef;
-
-sub mycan { # Real can would leave stubs.
- my ($package, $meth) = @_;
- return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
- my $p;
- foreach $p (@{$package . "::ISA"}) {
- my $out = mycan($p, $meth);
- return $out if $out;
- }
- return undef;
-}
-
-%constants = (
- 'integer' => 0x1000, # HINT_NEW_INTEGER
- 'float' => 0x2000, # HINT_NEW_FLOAT
- 'binary' => 0x4000, # HINT_NEW_BINARY
- 'q' => 0x8000, # HINT_NEW_STRING
- 'qr' => 0x10000, # HINT_NEW_RE
- );
-
-%ops = ( with_assign => "+ - * / % ** << >> x .",
- assign => "+= -= *= /= %= **= <<= >>= x= .=",
- num_comparison => "< <= > >= == !=",
- '3way_comparison'=> "<=> cmp",
- str_comparison => "lt le gt ge eq ne",
- binary => "& | ^",
- unary => "neg ! ~",
- mutators => '++ --',
- func => "atan2 cos sin exp abs log sqrt int",
- conversion => 'bool "" 0+',
- iterators => '<>',
- dereferencing => '${} @{} %{} &{} *{}',
- special => 'nomethod fallback =');
-
-use warnings::register;
-sub constant {
- # Arguments: what, sub
- while (@_) {
- if (@_ == 1) {
- warnings::warnif ("Odd number of arguments for overload::constant");
- last;
- }
- elsif (!exists $constants {$_ [0]}) {
- warnings::warnif ("`$_[0]' is not an overloadable type");
- }
- elsif (!ref $_ [1] || "$_[1]" !~ /CODE\(0x[\da-f]+\)$/) {
- # Can't use C<ref $_[1] eq "CODE"> above as code references can be
- # blessed, and C<ref> would return the package the ref is blessed into.
- if (warnings::enabled) {
- $_ [1] = "undef" unless defined $_ [1];
- warnings::warn ("`$_[1]' is not a code reference");
- }
- }
- else {
- $^H{$_[0]} = $_[1];
- $^H |= $constants{$_[0]} | $overload::hint_bits;
- }
- shift, shift;
- }
-}
-
-sub remove_constant {
- # Arguments: what, sub
- while (@_) {
- delete $^H{$_[0]};
- $^H &= ~ $constants{$_[0]};
- shift, shift;
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-overload - Package for overloading Perl operations
-
-=head1 SYNOPSIS
-
- package SomeThing;
-
- use overload
- '+' => \&myadd,
- '-' => \&mysub;
- # etc
- ...
-
- package main;
- $a = new SomeThing 57;
- $b=5+$a;
- ...
- if (overload::Overloaded $b) {...}
- ...
- $strval = overload::StrVal $b;
-
-=head1 DESCRIPTION
-
-=head2 Declaration of overloaded functions
-
-The compilation directive
-
- package Number;
- use overload
- "+" => \&add,
- "*=" => "muas";
-
-declares function Number::add() for addition, and method muas() in
-the "class" C<Number> (or one of its base classes)
-for the assignment form C<*=> of multiplication.
-
-Arguments of this directive come in (key, value) pairs. Legal values
-are values legal inside a C<&{ ... }> call, so the name of a
-subroutine, a reference to a subroutine, or an anonymous subroutine
-will all work. Note that values specified as strings are
-interpreted as methods, not subroutines. Legal keys are listed below.
-
-The subroutine C<add> will be called to execute C<$a+$b> if $a
-is a reference to an object blessed into the package C<Number>, or if $a is
-not an object from a package with defined mathemagic addition, but $b is a
-reference to a C<Number>. It can also be called in other situations, like
-C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical
-methods refer to methods triggered by an overloaded mathematical
-operator.)
-
-Since overloading respects inheritance via the @ISA hierarchy, the
-above declaration would also trigger overloading of C<+> and C<*=> in
-all the packages which inherit from C<Number>.
-
-=head2 Calling Conventions for Binary Operations
-
-The functions specified in the C<use overload ...> directive are called
-with three (in one particular case with four, see L<Last Resort>)
-arguments. If the corresponding operation is binary, then the first
-two arguments are the two arguments of the operation. However, due to
-general object calling conventions, the first argument should always be
-an object in the package, so in the situation of C<7+$a>, the
-order of the arguments is interchanged. It probably does not matter
-when implementing the addition method, but whether the arguments
-are reversed is vital to the subtraction method. The method can
-query this information by examining the third argument, which can take
-three different values:
-
-=over 7
-
-=item FALSE
-
-the order of arguments is as in the current operation.
-
-=item TRUE
-
-the arguments are reversed.
-
-=item C<undef>
-
-the current operation is an assignment variant (as in
-C<$a+=7>), but the usual function is called instead. This additional
-information can be used to generate some optimizations. Compare
-L<Calling Conventions for Mutators>.
-
-=back
-
-=head2 Calling Conventions for Unary Operations
-
-Unary operation are considered binary operations with the second
-argument being C<undef>. Thus the functions that overloads C<{"++"}>
-is called with arguments C<($a,undef,'')> when $a++ is executed.
-
-=head2 Calling Conventions for Mutators
-
-Two types of mutators have different calling conventions:
-
-=over
-
-=item C<++> and C<-->
-
-The routines which implement these operators are expected to actually
-I<mutate> their arguments. So, assuming that $obj is a reference to a
-number,
-
- sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n}
-
-is an appropriate implementation of overloaded C<++>. Note that
-
- sub incr { ++$ {$_[0]} ; shift }
-
-is OK if used with preincrement and with postincrement. (In the case
-of postincrement a copying will be performed, see L<Copy Constructor>.)
-
-=item C<x=> and other assignment versions
-
-There is nothing special about these methods. They may change the
-value of their arguments, and may leave it as is. The result is going
-to be assigned to the value in the left-hand-side if different from
-this value.
-
-This allows for the same method to be used as overloaded C<+=> and
-C<+>. Note that this is I<allowed>, but not recommended, since by the
-semantic of L<"Fallback"> Perl will call the method for C<+> anyway,
-if C<+=> is not overloaded.
-
-=back
-
-B<Warning.> Due to the presence of assignment versions of operations,
-routines which may be called in assignment context may create
-self-referential structures. Currently Perl will not free self-referential
-structures until cycles are C<explicitly> broken. You may get problems
-when traversing your structures too.
-
-Say,
-
- use overload '+' => sub { bless [ \$_[0], \$_[1] ] };
-
-is asking for trouble, since for code C<$obj += $foo> the subroutine
-is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj,
-\$foo]>. If using such a subroutine is an important optimization, one
-can overload C<+=> explicitly by a non-"optimized" version, or switch
-to non-optimized version if C<not defined $_[2]> (see
-L<Calling Conventions for Binary Operations>).
-
-Even if no I<explicit> assignment-variants of operators are present in
-the script, they may be generated by the optimizer. Say, C<",$obj,"> or
-C<',' . $obj . ','> may be both optimized to
-
- my $tmp = ',' . $obj; $tmp .= ',';
-
-=head2 Overloadable Operations
-
-The following symbols can be specified in C<use overload> directive:
-
-=over 5
-
-=item * I<Arithmetic operations>
-
- "+", "+=", "-", "-=", "*", "*=", "/", "/=", "%", "%=",
- "**", "**=", "<<", "<<=", ">>", ">>=", "x", "x=", ".", ".=",
-
-For these operations a substituted non-assignment variant can be called if
-the assignment variant is not available. Methods for operations C<+>,
-C<->, C<+=>, and C<-=> can be called to automatically generate
-increment and decrement methods. The operation C<-> can be used to
-autogenerate missing methods for unary minus or C<abs>.
-
-See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and
-L<"Calling Conventions for Binary Operations">) for details of these
-substitutions.
-
-=item * I<Comparison operations>
-
- "<", "<=", ">", ">=", "==", "!=", "<=>",
- "lt", "le", "gt", "ge", "eq", "ne", "cmp",
-
-If the corresponding "spaceship" variant is available, it can be
-used to substitute for the missing operation. During C<sort>ing
-arrays, C<cmp> is used to compare values subject to C<use overload>.
-
-=item * I<Bit operations>
-
- "&", "^", "|", "neg", "!", "~",
-
-C<neg> stands for unary minus. If the method for C<neg> is not
-specified, it can be autogenerated using the method for
-subtraction. If the method for C<!> is not specified, it can be
-autogenerated using the methods for C<bool>, or C<"">, or C<0+>.
-
-=item * I<Increment and decrement>
-
- "++", "--",
-
-If undefined, addition and subtraction methods can be
-used instead. These operations are called both in prefix and
-postfix form.
-
-=item * I<Transcendental functions>
-
- "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", "int"
-
-If C<abs> is unavailable, it can be autogenerated using methods
-for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction.
-
-Note that traditionally the Perl function L<int> rounds to 0, thus for
-floating-point-like types one should follow the same semantic. If
-C<int> is unavailable, it can be autogenerated using the overloading of
-C<0+>.
-
-=item * I<Boolean, string and numeric conversion>
-
- 'bool', '""', '0+',
-
-If one or two of these operations are not overloaded, the remaining ones can
-be used instead. C<bool> is used in the flow control operators
-(like C<while>) and for the ternary C<?:> operation. These functions can
-return any arbitrary Perl value. If the corresponding operation for this value
-is overloaded too, that operation will be called again with this value.
-
-As a special case if the overload returns the object itself then it will
-be used directly. An overloaded conversion returning the object is
-probably a bug, because you're likely to get something that looks like
-C<YourPackage=HASH(0x8172b34)>.
-
-=item * I<Iteration>
-
- "<>"
-
-If not overloaded, the argument will be converted to a filehandle or
-glob (which may require a stringification). The same overloading
-happens both for the I<read-filehandle> syntax C<E<lt>$varE<gt>> and
-I<globbing> syntax C<E<lt>${var}E<gt>>.
-
-B<BUGS> Even in list context, the iterator is currently called only
-once and with scalar context.
-
-=item * I<Dereferencing>
-
- '${}', '@{}', '%{}', '&{}', '*{}'.
-
-If not overloaded, the argument will be dereferenced I<as is>, thus
-should be of correct type. These functions should return a reference
-of correct type, or another object with overloaded dereferencing.
-
-As a special case if the overload returns the object itself then it
-will be used directly (provided it is the correct type).
-
-The dereference operators must be specified explicitly they will not be passed to
-"nomethod".
-
-=item * I<Special>
-
- "nomethod", "fallback", "=",
-
-see L<SPECIAL SYMBOLS FOR C<use overload>>.
-
-=back
-
-See L<"Fallback"> for an explanation of when a missing method can be
-autogenerated.
-
-A computer-readable form of the above table is available in the hash
-%overload::ops, with values being space-separated lists of names:
-
- with_assign => '+ - * / % ** << >> x .',
- assign => '+= -= *= /= %= **= <<= >>= x= .=',
- num_comparison => '< <= > >= == !=',
- '3way_comparison'=> '<=> cmp',
- str_comparison => 'lt le gt ge eq ne',
- binary => '& | ^',
- unary => 'neg ! ~',
- mutators => '++ --',
- func => 'atan2 cos sin exp abs log sqrt',
- conversion => 'bool "" 0+',
- iterators => '<>',
- dereferencing => '${} @{} %{} &{} *{}',
- special => 'nomethod fallback ='
-
-=head2 Inheritance and overloading
-
-Inheritance interacts with overloading in two ways.
-
-=over
-
-=item Strings as values of C<use overload> directive
-
-If C<value> in
-
- use overload key => value;
-
-is a string, it is interpreted as a method name.
-
-=item Overloading of an operation is inherited by derived classes
-
-Any class derived from an overloaded class is also overloaded. The
-set of overloaded methods is the union of overloaded methods of all
-the ancestors. If some method is overloaded in several ancestor, then
-which description will be used is decided by the usual inheritance
-rules:
-
-If C<A> inherits from C<B> and C<C> (in this order), C<B> overloads
-C<+> with C<\&D::plus_sub>, and C<C> overloads C<+> by C<"plus_meth">,
-then the subroutine C<D::plus_sub> will be called to implement
-operation C<+> for an object in package C<A>.
-
-=back
-
-Note that since the value of the C<fallback> key is not a subroutine,
-its inheritance is not governed by the above rules. In the current
-implementation, the value of C<fallback> in the first overloaded
-ancestor is used, but this is accidental and subject to change.
-
-=head1 SPECIAL SYMBOLS FOR C<use overload>
-
-Three keys are recognized by Perl that are not covered by the above
-description.
-
-=head2 Last Resort
-
-C<"nomethod"> should be followed by a reference to a function of four
-parameters. If defined, it is called when the overloading mechanism
-cannot find a method for some operation. The first three arguments of
-this function coincide with the arguments for the corresponding method if
-it were found, the fourth argument is the symbol
-corresponding to the missing method. If several methods are tried,
-the last one is used. Say, C<1-$a> can be equivalent to
-
- &nomethodMethod($a,1,1,"-")
-
-if the pair C<"nomethod" =E<gt> "nomethodMethod"> was specified in the
-C<use overload> directive.
-
-The C<"nomethod"> mechanism is I<not> used for the dereference operators
-( ${} @{} %{} &{} *{} ).
-
-
-If some operation cannot be resolved, and there is no function
-assigned to C<"nomethod">, then an exception will be raised via die()--
-unless C<"fallback"> was specified as a key in C<use overload> directive.
-
-
-=head2 Fallback
-
-The key C<"fallback"> governs what to do if a method for a particular
-operation is not found. Three different cases are possible depending on
-the value of C<"fallback">:
-
-=over 16
-
-=item * C<undef>
-
-Perl tries to use a
-substituted method (see L<MAGIC AUTOGENERATION>). If this fails, it
-then tries to calls C<"nomethod"> value; if missing, an exception
-will be raised.
-
-=item * TRUE
-
-The same as for the C<undef> value, but no exception is raised. Instead,
-it silently reverts to what it would have done were there no C<use overload>
-present.
-
-=item * defined, but FALSE
-
-No autogeneration is tried. Perl tries to call
-C<"nomethod"> value, and if this is missing, raises an exception.
-
-=back
-
-B<Note.> C<"fallback"> inheritance via @ISA is not carved in stone
-yet, see L<"Inheritance and overloading">.
-
-=head2 Copy Constructor
-
-The value for C<"="> is a reference to a function with three
-arguments, i.e., it looks like the other values in C<use
-overload>. However, it does not overload the Perl assignment
-operator. This would go against Camel hair.
-
-This operation is called in the situations when a mutator is applied
-to a reference that shares its object with some other reference, such
-as
-
- $a=$b;
- ++$a;
-
-To make this change $a and not change $b, a copy of C<$$a> is made,
-and $a is assigned a reference to this new object. This operation is
-done during execution of the C<++$a>, and not during the assignment,
-(so before the increment C<$$a> coincides with C<$$b>). This is only
-done if C<++> is expressed via a method for C<'++'> or C<'+='> (or
-C<nomethod>). Note that if this operation is expressed via C<'+'>
-a nonmutator, i.e., as in
-
- $a=$b;
- $a=$a+1;
-
-then C<$a> does not reference a new copy of C<$$a>, since $$a does not
-appear as lvalue when the above code is executed.
-
-If the copy constructor is required during the execution of some mutator,
-but a method for C<'='> was not specified, it can be autogenerated as a
-string copy if the object is a plain scalar.
-
-=over 5
-
-=item B<Example>
-
-The actually executed code for
-
- $a=$b;
- Something else which does not modify $a or $b....
- ++$a;
-
-may be
-
- $a=$b;
- Something else which does not modify $a or $b....
- $a = $a->clone(undef,"");
- $a->incr(undef,"");
-
-if $b was mathemagical, and C<'++'> was overloaded with C<\&incr>,
-C<'='> was overloaded with C<\&clone>.
-
-=back
-
-Same behaviour is triggered by C<$b = $a++>, which is consider a synonym for
-C<$b = $a; ++$a>.
-
-=head1 MAGIC AUTOGENERATION
-
-If a method for an operation is not found, and the value for C<"fallback"> is
-TRUE or undefined, Perl tries to autogenerate a substitute method for
-the missing operation based on the defined operations. Autogenerated method
-substitutions are possible for the following operations:
-
-=over 16
-
-=item I<Assignment forms of arithmetic operations>
-
-C<$a+=$b> can use the method for C<"+"> if the method for C<"+=">
-is not defined.
-
-=item I<Conversion operations>
-
-String, numeric, and boolean conversion are calculated in terms of one
-another if not all of them are defined.
-
-=item I<Increment and decrement>
-
-The C<++$a> operation can be expressed in terms of C<$a+=1> or C<$a+1>,
-and C<$a--> in terms of C<$a-=1> and C<$a-1>.
-
-=item C<abs($a)>
-
-can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>).
-
-=item I<Unary minus>
-
-can be expressed in terms of subtraction.
-
-=item I<Negation>
-
-C<!> and C<not> can be expressed in terms of boolean conversion, or
-string or numerical conversion.
-
-=item I<Concatenation>
-
-can be expressed in terms of string conversion.
-
-=item I<Comparison operations>
-
-can be expressed in terms of its "spaceship" counterpart: either
-C<E<lt>=E<gt>> or C<cmp>:
-
- <, >, <=, >=, ==, != in terms of <=>
- lt, gt, le, ge, eq, ne in terms of cmp
-
-=item I<Iterator>
-
- <> in terms of builtin operations
-
-=item I<Dereferencing>
-
- ${} @{} %{} &{} *{} in terms of builtin operations
-
-=item I<Copy operator>
-
-can be expressed in terms of an assignment to the dereferenced value, if this
-value is a scalar and not a reference.
-
-=back
-
-=head1 Losing overloading
-
-The restriction for the comparison operation is that even if, for example,
-`C<cmp>' should return a blessed reference, the autogenerated `C<lt>'
-function will produce only a standard logical value based on the
-numerical value of the result of `C<cmp>'. In particular, a working
-numeric conversion is needed in this case (possibly expressed in terms of
-other conversions).
-
-Similarly, C<.=> and C<x=> operators lose their mathemagical properties
-if the string conversion substitution is applied.
-
-When you chop() a mathemagical object it is promoted to a string and its
-mathemagical properties are lost. The same can happen with other
-operations as well.
-
-=head1 Run-time Overloading
-
-Since all C<use> directives are executed at compile-time, the only way to
-change overloading during run-time is to
-
- eval 'use overload "+" => \&addmethod';
-
-You can also use
-
- eval 'no overload "+", "--", "<="';
-
-though the use of these constructs during run-time is questionable.
-
-=head1 Public functions
-
-Package C<overload.pm> provides the following public functions:
-
-=over 5
-
-=item overload::StrVal(arg)
-
-Gives string value of C<arg> as in absence of stringify overloading. If you
-are using this to get the address of a reference (useful for checking if two
-references point to the same thing) then you may be better off using
-C<Scalar::Util::refaddr()>, which is faster.
-
-=item overload::Overloaded(arg)
-
-Returns true if C<arg> is subject to overloading of some operations.
-
-=item overload::Method(obj,op)
-
-Returns C<undef> or a reference to the method that implements C<op>.
-
-=back
-
-=head1 Overloading constants
-
-For some applications, the Perl parser mangles constants too much.
-It is possible to hook into this process via C<overload::constant()>
-and C<overload::remove_constant()> functions.
-
-These functions take a hash as an argument. The recognized keys of this hash
-are:
-
-=over 8
-
-=item integer
-
-to overload integer constants,
-
-=item float
-
-to overload floating point constants,
-
-=item binary
-
-to overload octal and hexadecimal constants,
-
-=item q
-
-to overload C<q>-quoted strings, constant pieces of C<qq>- and C<qx>-quoted
-strings and here-documents,
-
-=item qr
-
-to overload constant pieces of regular expressions.
-
-=back
-
-The corresponding values are references to functions which take three arguments:
-the first one is the I<initial> string form of the constant, the second one
-is how Perl interprets this constant, the third one is how the constant is used.
-Note that the initial string form does not
-contain string delimiters, and has backslashes in backslash-delimiter
-combinations stripped (thus the value of delimiter is not relevant for
-processing of this string). The return value of this function is how this
-constant is going to be interpreted by Perl. The third argument is undefined
-unless for overloaded C<q>- and C<qr>- constants, it is C<q> in single-quote
-context (comes from strings, regular expressions, and single-quote HERE
-documents), it is C<tr> for arguments of C<tr>/C<y> operators,
-it is C<s> for right-hand side of C<s>-operator, and it is C<qq> otherwise.
-
-Since an expression C<"ab$cd,,"> is just a shortcut for C<'ab' . $cd . ',,'>,
-it is expected that overloaded constant strings are equipped with reasonable
-overloaded catenation operator, otherwise absurd results will result.
-Similarly, negative numbers are considered as negations of positive constants.
-
-Note that it is probably meaningless to call the functions overload::constant()
-and overload::remove_constant() from anywhere but import() and unimport() methods.
-From these methods they may be called as
-
- sub import {
- shift;
- return unless @_;
- die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
- overload::constant integer => sub {Math::BigInt->new(shift)};
- }
-
-B<BUGS> Currently overloaded-ness of constants does not propagate
-into C<eval '...'>.
-
-=head1 IMPLEMENTATION
-
-What follows is subject to change RSN.
-
-The table of methods for all operations is cached in magic for the
-symbol table hash for the package. The cache is invalidated during
-processing of C<use overload>, C<no overload>, new function
-definitions, and changes in @ISA. However, this invalidation remains
-unprocessed until the next C<bless>ing into the package. Hence if you
-want to change overloading structure dynamically, you'll need an
-additional (fake) C<bless>ing to update the table.
-
-(Every SVish thing has a magic queue, and magic is an entry in that
-queue. This is how a single variable may participate in multiple
-forms of magic simultaneously. For instance, environment variables
-regularly have two forms at once: their %ENV magic and their taint
-magic. However, the magic which implements overloading is applied to
-the stashes, which are rarely used directly, thus should not slow down
-Perl.)
-
-If an object belongs to a package using overload, it carries a special
-flag. Thus the only speed penalty during arithmetic operations without
-overloading is the checking of this flag.
-
-In fact, if C<use overload> is not present, there is almost no overhead
-for overloadable operations, so most programs should not suffer
-measurable performance penalties. A considerable effort was made to
-minimize the overhead when overload is used in some package, but the
-arguments in question do not belong to packages using overload. When
-in doubt, test your speed with C<use overload> and without it. So far
-there have been no reports of substantial speed degradation if Perl is
-compiled with optimization turned on.
-
-There is no size penalty for data if overload is not used. The only
-size penalty if overload is used in some package is that I<all> the
-packages acquire a magic during the next C<bless>ing into the
-package. This magic is three-words-long for packages without
-overloading, and carries the cache table if the package is overloaded.
-
-Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is
-carried out before any operation that can imply an assignment to the
-object $a (or $b) refers to, like C<$a++>. You can override this
-behavior by defining your own copy constructor (see L<"Copy Constructor">).
-
-It is expected that arguments to methods that are not explicitly supposed
-to be changed are constant (but this is not enforced).
-
-=head1 Metaphor clash
-
-One may wonder why the semantic of overloaded C<=> is so counter intuitive.
-If it I<looks> counter intuitive to you, you are subject to a metaphor
-clash.
-
-Here is a Perl object metaphor:
-
-I< object is a reference to blessed data>
-
-and an arithmetic metaphor:
-
-I< object is a thing by itself>.
-
-The I<main> problem of overloading C<=> is the fact that these metaphors
-imply different actions on the assignment C<$a = $b> if $a and $b are
-objects. Perl-think implies that $a becomes a reference to whatever
-$b was referencing. Arithmetic-think implies that the value of "object"
-$a is changed to become the value of the object $b, preserving the fact
-that $a and $b are separate entities.
-
-The difference is not relevant in the absence of mutators. After
-a Perl-way assignment an operation which mutates the data referenced by $a
-would change the data referenced by $b too. Effectively, after
-C<$a = $b> values of $a and $b become I<indistinguishable>.
-
-On the other hand, anyone who has used algebraic notation knows the
-expressive power of the arithmetic metaphor. Overloading works hard
-to enable this metaphor while preserving the Perlian way as far as
-possible. Since it is not possible to freely mix two contradicting
-metaphors, overloading allows the arithmetic way to write things I<as
-far as all the mutators are called via overloaded access only>. The
-way it is done is described in L<Copy Constructor>.
-
-If some mutator methods are directly applied to the overloaded values,
-one may need to I<explicitly unlink> other values which references the
-same value:
-
- $a = new Data 23;
- ...
- $b = $a; # $b is "linked" to $a
- ...
- $a = $a->clone; # Unlink $b from $a
- $a->increment_by(4);
-
-Note that overloaded access makes this transparent:
-
- $a = new Data 23;
- $b = $a; # $b is "linked" to $a
- $a += 4; # would unlink $b automagically
-
-However, it would not make
-
- $a = new Data 23;
- $a = 4; # Now $a is a plain 4, not 'Data'
-
-preserve "objectness" of $a. But Perl I<has> a way to make assignments
-to an object do whatever you want. It is just not the overload, but
-tie()ing interface (see L<perlfunc/tie>). Adding a FETCH() method
-which returns the object itself, and STORE() method which changes the
-value of the object, one can reproduce the arithmetic metaphor in its
-completeness, at least for variables which were tie()d from the start.
-
-(Note that a workaround for a bug may be needed, see L<"BUGS">.)
-
-=head1 Cookbook
-
-Please add examples to what follows!
-
-=head2 Two-face scalars
-
-Put this in F<two_face.pm> in your Perl library directory:
-
- package two_face; # Scalars with separate string and
- # numeric values.
- sub new { my $p = shift; bless [@_], $p }
- use overload '""' => \&str, '0+' => \&num, fallback => 1;
- sub num {shift->[1]}
- sub str {shift->[0]}
-
-Use it as follows:
-
- require two_face;
- my $seven = new two_face ("vii", 7);
- printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1;
- print "seven contains `i'\n" if $seven =~ /i/;
-
-(The second line creates a scalar which has both a string value, and a
-numeric value.) This prints:
-
- seven=vii, seven=7, eight=8
- seven contains `i'
-
-=head2 Two-face references
-
-Suppose you want to create an object which is accessible as both an
-array reference and a hash reference, similar to the
-L<pseudo-hash|perlref/"Pseudo-hashes: Using an array as a hash">
-builtin Perl type. Let's make it better than a pseudo-hash by
-allowing index 0 to be treated as a normal element.
-
- package two_refs;
- use overload '%{}' => \&gethash, '@{}' => sub { $ {shift()} };
- sub new {
- my $p = shift;
- bless \ [@_], $p;
- }
- sub gethash {
- my %h;
- my $self = shift;
- tie %h, ref $self, $self;
- \%h;
- }
-
- sub TIEHASH { my $p = shift; bless \ shift, $p }
- my %fields;
- my $i = 0;
- $fields{$_} = $i++ foreach qw{zero one two three};
- sub STORE {
- my $self = ${shift()};
- my $key = $fields{shift()};
- defined $key or die "Out of band access";
- $$self->[$key] = shift;
- }
- sub FETCH {
- my $self = ${shift()};
- my $key = $fields{shift()};
- defined $key or die "Out of band access";
- $$self->[$key];
- }
-
-Now one can access an object using both the array and hash syntax:
-
- my $bar = new two_refs 3,4,5,6;
- $bar->[2] = 11;
- $bar->{two} == 11 or die 'bad hash fetch';
-
-Note several important features of this example. First of all, the
-I<actual> type of $bar is a scalar reference, and we do not overload
-the scalar dereference. Thus we can get the I<actual> non-overloaded
-contents of $bar by just using C<$$bar> (what we do in functions which
-overload dereference). Similarly, the object returned by the
-TIEHASH() method is a scalar reference.
-
-Second, we create a new tied hash each time the hash syntax is used.
-This allows us not to worry about a possibility of a reference loop,
-which would lead to a memory leak.
-
-Both these problems can be cured. Say, if we want to overload hash
-dereference on a reference to an object which is I<implemented> as a
-hash itself, the only problem one has to circumvent is how to access
-this I<actual> hash (as opposed to the I<virtual> hash exhibited by the
-overloaded dereference operator). Here is one possible fetching routine:
-
- sub access_hash {
- my ($self, $key) = (shift, shift);
- my $class = ref $self;
- bless $self, 'overload::dummy'; # Disable overloading of %{}
- my $out = $self->{$key};
- bless $self, $class; # Restore overloading
- $out;
- }
-
-To remove creation of the tied hash on each access, one may an extra
-level of indirection which allows a non-circular structure of references:
-
- package two_refs1;
- use overload '%{}' => sub { ${shift()}->[1] },
- '@{}' => sub { ${shift()}->[0] };
- sub new {
- my $p = shift;
- my $a = [@_];
- my %h;
- tie %h, $p, $a;
- bless \ [$a, \%h], $p;
- }
- sub gethash {
- my %h;
- my $self = shift;
- tie %h, ref $self, $self;
- \%h;
- }
-
- sub TIEHASH { my $p = shift; bless \ shift, $p }
- my %fields;
- my $i = 0;
- $fields{$_} = $i++ foreach qw{zero one two three};
- sub STORE {
- my $a = ${shift()};
- my $key = $fields{shift()};
- defined $key or die "Out of band access";
- $a->[$key] = shift;
- }
- sub FETCH {
- my $a = ${shift()};
- my $key = $fields{shift()};
- defined $key or die "Out of band access";
- $a->[$key];
- }
-
-Now if $baz is overloaded like this, then C<$baz> is a reference to a
-reference to the intermediate array, which keeps a reference to an
-actual array, and the access hash. The tie()ing object for the access
-hash is a reference to a reference to the actual array, so
-
-=over
-
-=item *
-
-There are no loops of references.
-
-=item *
-
-Both "objects" which are blessed into the class C<two_refs1> are
-references to a reference to an array, thus references to a I<scalar>.
-Thus the accessor expression C<$$foo-E<gt>[$ind]> involves no
-overloaded operations.
-
-=back
-
-=head2 Symbolic calculator
-
-Put this in F<symbolic.pm> in your Perl library directory:
-
- package symbolic; # Primitive symbolic calculator
- use overload nomethod => \&wrap;
-
- sub new { shift; bless ['n', @_] }
- sub wrap {
- my ($obj, $other, $inv, $meth) = @_;
- ($obj, $other) = ($other, $obj) if $inv;
- bless [$meth, $obj, $other];
- }
-
-This module is very unusual as overloaded modules go: it does not
-provide any usual overloaded operators, instead it provides the L<Last
-Resort> operator C<nomethod>. In this example the corresponding
-subroutine returns an object which encapsulates operations done over
-the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new
-symbolic 3> contains C<['+', 2, ['n', 3]]>.
-
-Here is an example of the script which "calculates" the side of
-circumscribed octagon using the above package:
-
- require symbolic;
- my $iter = 1; # 2**($iter+2) = 8
- my $side = new symbolic 1;
- my $cnt = $iter;
-
- while ($cnt--) {
- $side = (sqrt(1 + $side**2) - 1)/$side;
- }
- print "OK\n";
-
-The value of $side is
-
- ['/', ['-', ['sqrt', ['+', 1, ['**', ['n', 1], 2]],
- undef], 1], ['n', 1]]
-
-Note that while we obtained this value using a nice little script,
-there is no simple way to I<use> this value. In fact this value may
-be inspected in debugger (see L<perldebug>), but ony if
-C<bareStringify> B<O>ption is set, and not via C<p> command.
-
-If one attempts to print this value, then the overloaded operator
-C<""> will be called, which will call C<nomethod> operator. The
-result of this operator will be stringified again, but this result is
-again of type C<symbolic>, which will lead to an infinite loop.
-
-Add a pretty-printer method to the module F<symbolic.pm>:
-
- sub pretty {
- my ($meth, $a, $b) = @{+shift};
- $a = 'u' unless defined $a;
- $b = 'u' unless defined $b;
- $a = $a->pretty if ref $a;
- $b = $b->pretty if ref $b;
- "[$meth $a $b]";
- }
-
-Now one can finish the script by
-
- print "side = ", $side->pretty, "\n";
-
-The method C<pretty> is doing object-to-string conversion, so it
-is natural to overload the operator C<""> using this method. However,
-inside such a method it is not necessary to pretty-print the
-I<components> $a and $b of an object. In the above subroutine
-C<"[$meth $a $b]"> is a catenation of some strings and components $a
-and $b. If these components use overloading, the catenation operator
-will look for an overloaded operator C<.>; if not present, it will
-look for an overloaded operator C<"">. Thus it is enough to use
-
- use overload nomethod => \&wrap, '""' => \&str;
- sub str {
- my ($meth, $a, $b) = @{+shift};
- $a = 'u' unless defined $a;
- $b = 'u' unless defined $b;
- "[$meth $a $b]";
- }
-
-Now one can change the last line of the script to
-
- print "side = $side\n";
-
-which outputs
-
- side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]]
-
-and one can inspect the value in debugger using all the possible
-methods.
-
-Something is still amiss: consider the loop variable $cnt of the
-script. It was a number, not an object. We cannot make this value of
-type C<symbolic>, since then the loop will not terminate.
-
-Indeed, to terminate the cycle, the $cnt should become false.
-However, the operator C<bool> for checking falsity is overloaded (this
-time via overloaded C<"">), and returns a long string, thus any object
-of type C<symbolic> is true. To overcome this, we need a way to
-compare an object to 0. In fact, it is easier to write a numeric
-conversion routine.
-
-Here is the text of F<symbolic.pm> with such a routine added (and
-slightly modified str()):
-
- package symbolic; # Primitive symbolic calculator
- use overload
- nomethod => \&wrap, '""' => \&str, '0+' => \&num;
-
- sub new { shift; bless ['n', @_] }
- sub wrap {
- my ($obj, $other, $inv, $meth) = @_;
- ($obj, $other) = ($other, $obj) if $inv;
- bless [$meth, $obj, $other];
- }
- sub str {
- my ($meth, $a, $b) = @{+shift};
- $a = 'u' unless defined $a;
- if (defined $b) {
- "[$meth $a $b]";
- } else {
- "[$meth $a]";
- }
- }
- my %subr = ( n => sub {$_[0]},
- sqrt => sub {sqrt $_[0]},
- '-' => sub {shift() - shift()},
- '+' => sub {shift() + shift()},
- '/' => sub {shift() / shift()},
- '*' => sub {shift() * shift()},
- '**' => sub {shift() ** shift()},
- );
- sub num {
- my ($meth, $a, $b) = @{+shift};
- my $subr = $subr{$meth}
- or die "Do not know how to ($meth) in symbolic";
- $a = $a->num if ref $a eq __PACKAGE__;
- $b = $b->num if ref $b eq __PACKAGE__;
- $subr->($a,$b);
- }
-
-All the work of numeric conversion is done in %subr and num(). Of
-course, %subr is not complete, it contains only operators used in the
-example below. Here is the extra-credit question: why do we need an
-explicit recursion in num()? (Answer is at the end of this section.)
-
-Use this module like this:
-
- require symbolic;
- my $iter = new symbolic 2; # 16-gon
- my $side = new symbolic 1;
- my $cnt = $iter;
-
- while ($cnt) {
- $cnt = $cnt - 1; # Mutator `--' not implemented
- $side = (sqrt(1 + $side**2) - 1)/$side;
- }
- printf "%s=%f\n", $side, $side;
- printf "pi=%f\n", $side*(2**($iter+2));
-
-It prints (without so many line breaks)
-
- [/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1]
- [n 1]] 2]]] 1]
- [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]=0.198912
- pi=3.182598
-
-The above module is very primitive. It does not implement
-mutator methods (C<++>, C<-=> and so on), does not do deep copying
-(not required without mutators!), and implements only those arithmetic
-operations which are used in the example.
-
-To implement most arithmetic operations is easy; one should just use
-the tables of operations, and change the code which fills %subr to
-
- my %subr = ( 'n' => sub {$_[0]} );
- foreach my $op (split " ", $overload::ops{with_assign}) {
- $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
- }
- my @bins = qw(binary 3way_comparison num_comparison str_comparison);
- foreach my $op (split " ", "@overload::ops{ @bins }") {
- $subr{$op} = eval "sub {shift() $op shift()}";
- }
- foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
- print "defining `$op'\n";
- $subr{$op} = eval "sub {$op shift()}";
- }
-
-Due to L<Calling Conventions for Mutators>, we do not need anything
-special to make C<+=> and friends work, except filling C<+=> entry of
-%subr, and defining a copy constructor (needed since Perl has no
-way to know that the implementation of C<'+='> does not mutate
-the argument, compare L<Copy Constructor>).
-
-To implement a copy constructor, add C<< '=' => \&cpy >> to C<use overload>
-line, and code (this code assumes that mutators change things one level
-deep only, so recursive copying is not needed):
-
- sub cpy {
- my $self = shift;
- bless [@$self], ref $self;
- }
-
-To make C<++> and C<--> work, we need to implement actual mutators,
-either directly, or in C<nomethod>. We continue to do things inside
-C<nomethod>, thus add
-
- if ($meth eq '++' or $meth eq '--') {
- @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
- return $obj;
- }
-
-after the first line of wrap(). This is not a most effective
-implementation, one may consider
-
- sub inc { $_[0] = bless ['++', shift, 1]; }
-
-instead.
-
-As a final remark, note that one can fill %subr by
-
- my %subr = ( 'n' => sub {$_[0]} );
- foreach my $op (split " ", $overload::ops{with_assign}) {
- $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
- }
- my @bins = qw(binary 3way_comparison num_comparison str_comparison);
- foreach my $op (split " ", "@overload::ops{ @bins }") {
- $subr{$op} = eval "sub {shift() $op shift()}";
- }
- foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
- $subr{$op} = eval "sub {$op shift()}";
- }
- $subr{'++'} = $subr{'+'};
- $subr{'--'} = $subr{'-'};
-
-This finishes implementation of a primitive symbolic calculator in
-50 lines of Perl code. Since the numeric values of subexpressions
-are not cached, the calculator is very slow.
-
-Here is the answer for the exercise: In the case of str(), we need no
-explicit recursion since the overloaded C<.>-operator will fall back
-to an existing overloaded operator C<"">. Overloaded arithmetic
-operators I<do not> fall back to numeric conversion if C<fallback> is
-not explicitly requested. Thus without an explicit recursion num()
-would convert C<['+', $a, $b]> to C<$a + $b>, which would just rebuild
-the argument of num().
-
-If you wonder why defaults for conversion are different for str() and
-num(), note how easy it was to write the symbolic calculator. This
-simplicity is due to an appropriate choice of defaults. One extra
-note: due to the explicit recursion num() is more fragile than sym():
-we need to explicitly check for the type of $a and $b. If components
-$a and $b happen to be of some related type, this may lead to problems.
-
-=head2 I<Really> symbolic calculator
-
-One may wonder why we call the above calculator symbolic. The reason
-is that the actual calculation of the value of expression is postponed
-until the value is I<used>.
-
-To see it in action, add a method
-
- sub STORE {
- my $obj = shift;
- $#$obj = 1;
- @$obj->[0,1] = ('=', shift);
- }
-
-to the package C<symbolic>. After this change one can do
-
- my $a = new symbolic 3;
- my $b = new symbolic 4;
- my $c = sqrt($a**2 + $b**2);
-
-and the numeric value of $c becomes 5. However, after calling
-
- $a->STORE(12); $b->STORE(5);
-
-the numeric value of $c becomes 13. There is no doubt now that the module
-symbolic provides a I<symbolic> calculator indeed.
-
-To hide the rough edges under the hood, provide a tie()d interface to the
-package C<symbolic> (compare with L<Metaphor clash>). Add methods
-
- sub TIESCALAR { my $pack = shift; $pack->new(@_) }
- sub FETCH { shift }
- sub nop { } # Around a bug
-
-(the bug is described in L<"BUGS">). One can use this new interface as
-
- tie $a, 'symbolic', 3;
- tie $b, 'symbolic', 4;
- $a->nop; $b->nop; # Around a bug
-
- my $c = sqrt($a**2 + $b**2);
-
-Now numeric value of $c is 5. After C<$a = 12; $b = 5> the numeric value
-of $c becomes 13. To insulate the user of the module add a method
-
- sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
-
-Now
-
- my ($a, $b);
- symbolic->vars($a, $b);
- my $c = sqrt($a**2 + $b**2);
-
- $a = 3; $b = 4;
- printf "c5 %s=%f\n", $c, $c;
-
- $a = 12; $b = 5;
- printf "c13 %s=%f\n", $c, $c;
-
-shows that the numeric value of $c follows changes to the values of $a
-and $b.
-
-=head1 AUTHOR
-
-Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>.
-
-=head1 DIAGNOSTICS
-
-When Perl is run with the B<-Do> switch or its equivalent, overloading
-induces diagnostic messages.
-
-Using the C<m> command of Perl debugger (see L<perldebug>) one can
-deduce which operations are overloaded (and which ancestor triggers
-this overloading). Say, if C<eq> is overloaded, then the method C<(eq>
-is shown by debugger. The method C<()> corresponds to the C<fallback>
-key (in fact a presence of this method shows that this package has
-overloading enabled, and it is what is used by the C<Overloaded>
-function of module C<overload>).
-
-The module might issue the following warnings:
-
-=over 4
-
-=item Odd number of arguments for overload::constant
-
-(W) The call to overload::constant contained an odd number of arguments.
-The arguments should come in pairs.
-
-=item `%s' is not an overloadable type
-
-(W) You tried to overload a constant type the overload package is unaware of.
-
-=item `%s' is not a code reference
-
-(W) The second (fourth, sixth, ...) argument of overload::constant needs
-to be a code reference. Either an anonymous subroutine, or a reference
-to a subroutine.
-
-=back
-
-=head1 BUGS
-
-Because it is used for overloading, the per-package hash %OVERLOAD now
-has a special meaning in Perl. The symbol table is filled with names
-looking like line-noise.
-
-For the purpose of inheritance every overloaded package behaves as if
-C<fallback> is present (possibly undefined). This may create
-interesting effects if some package is not overloaded, but inherits
-from two overloaded packages.
-
-Relation between overloading and tie()ing is broken. Overloading is
-triggered or not basing on the I<previous> class of tie()d value.
-
-This happens because the presence of overloading is checked too early,
-before any tie()d access is attempted. If the FETCH()ed class of the
-tie()d value does not change, a simple workaround is to access the value
-immediately after tie()ing, so that after this call the I<previous> class
-coincides with the current one.
-
-B<Needed:> a way to fix this without a speed penalty.
-
-Barewords are not covered by overloaded string constants.
-
-This document is confusing. There are grammos and misleading language
-used in places. It would seem a total rewrite is needed.
-
-=cut
-
diff --git a/Master/tlpkg/installer/perllib/re.pm b/Master/tlpkg/installer/perllib/re.pm
deleted file mode 100644
index 6e9d1218ef0..00000000000
--- a/Master/tlpkg/installer/perllib/re.pm
+++ /dev/null
@@ -1,134 +0,0 @@
-package re;
-
-our $VERSION = 0.05;
-
-=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'; # NOT lexically scoped (as others are)
- /^(.*)$/s; # output debugging info during
- # compile and run time
-
- use re 'debugcolor'; # same as 'debug', but with colored output
- ...
-
-(We use $^X in these examples because it's tainted by default.)
-
-=head1 DESCRIPTION
-
-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.
-
-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.
-
-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.
-
-The directive C<use re 'debug'> is I<not lexically scoped>, as the
-other directives are. It has both compile-time and run-time effects.
-
-See L<perlmodlib/Pragmatic Modules>.
-
-=cut
-
-# N.B. File::Basename contains a literal for 'taint' as a fallback. If
-# taint is changed here, File::Basename must be updated as well.
-my %bitmask = (
-taint => 0x00100000, # HINT_RE_TAINT
-eval => 0x00200000, # HINT_RE_EVAL
-);
-
-sub setcolor {
- eval { # Ignore errors
- require Term::Cap;
-
- my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
- my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
- my @props = split /,/, $props;
- my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
-
- $colors =~ s/\0//g;
- $ENV{PERL_RE_COLORS} = $colors;
- };
-}
-
-sub bits {
- my $on = shift;
- my $bits = 0;
- unless (@_) {
- require Carp;
- Carp::carp("Useless use of \"re\" pragma");
- }
- foreach my $s (@_){
- if ($s eq 'debug' or $s eq 'debugcolor') {
- setcolor() if $s eq 'debugcolor';
- require XSLoader;
- XSLoader::load('re');
- install() if $on;
- uninstall() unless $on;
- next;
- }
- if (exists $bitmask{$s}) {
- $bits |= $bitmask{$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;
diff --git a/Master/tlpkg/installer/perllib/strict.pm b/Master/tlpkg/installer/perllib/strict.pm
deleted file mode 100644
index d14391add44..00000000000
--- a/Master/tlpkg/installer/perllib/strict.pm
+++ /dev/null
@@ -1,136 +0,0 @@
-package strict;
-
-$strict::VERSION = "1.03";
-
-my %bitmask = (
-refs => 0x00000002,
-subs => 0x00000200,
-vars => 0x00000400
-);
-
-sub bits {
- my $bits = 0;
- my @wrong;
- foreach my $s (@_) {
- push @wrong, $s unless exists $bitmask{$s};
- $bits |= $bitmask{$s} || 0;
- }
- if (@wrong) {
- require Carp;
- Carp::croak("Unknown 'strict' tag(s) '@wrong'");
- }
- $bits;
-}
-
-my $default_bits = bits(qw(refs subs vars));
-
-sub import {
- shift;
- $^H |= @_ ? bits(@_) : $default_bits;
-}
-
-sub unimport {
- shift;
- $^H &= ~ (@_ ? bits(@_) : $default_bits);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-strict - Perl pragma to restrict unsafe constructs
-
-=head1 SYNOPSIS
-
- use strict;
-
- use strict "vars";
- use strict "refs";
- use strict "subs";
-
- use strict;
- no strict "vars";
-
-=head1 DESCRIPTION
-
-If no import list is supplied, all possible restrictions are assumed.
-(This is the safest mode to operate in, but is sometimes too strict for
-casual programming.) Currently, there are three possible things to be
-strict about: "subs", "vars", and "refs".
-
-=over 6
-
-=item C<strict refs>
-
-This generates a runtime error if you
-use symbolic references (see L<perlref>).
-
- use strict 'refs';
- $ref = \$foo;
- print $$ref; # ok
- $ref = "foo";
- print $$ref; # runtime error; normally ok
- $file = "STDOUT";
- print $file "Hi!"; # error; note: no comma after $file
-
-There is one exception to this rule:
-
- $bar = \&{'foo'};
- &$bar;
-
-is allowed so that C<goto &$AUTOLOAD> would not break under stricture.
-
-
-=item C<strict vars>
-
-This generates a compile-time error if you access a variable that wasn't
-declared via C<our> or C<use vars>,
-localized via C<my()>, or wasn't fully qualified. Because this is to avoid
-variable suicide problems and subtle dynamic scoping issues, a merely
-local() variable isn't good enough. See L<perlfunc/my> and
-L<perlfunc/local>.
-
- use strict 'vars';
- $X::foo = 1; # ok, fully qualified
- my $foo = 10; # ok, my() var
- local $foo = 9; # blows up
-
- package Cinna;
- our $bar; # Declares $bar in current package
- $bar = 'HgS'; # ok, global declared via pragma
-
-The local() generated a compile-time error because you just touched a global
-name without fully qualifying it.
-
-Because of their special use by sort(), the variables $a and $b are
-exempted from this check.
-
-=item C<strict subs>
-
-This disables the poetry optimization, generating a compile-time error if
-you try to use a bareword identifier that's not a subroutine, unless it
-is a simple identifier (no colons) and that it appears in curly braces or
-on the left hand side of the C<< => >> symbol.
-
- use strict 'subs';
- $SIG{PIPE} = Plumber; # blows up
- $SIG{PIPE} = "Plumber"; # just fine: quoted string is always ok
- $SIG{PIPE} = \&Plumber; # preferred form
-
-=back
-
-See L<perlmodlib/Pragmatic Modules>.
-
-=head1 HISTORY
-
-C<strict 'subs'>, with Perl 5.6.1, erroneously permitted to use an unquoted
-compound identifier (e.g. C<Foo::Bar>) as a hash key (before C<< => >> or
-inside curlies), but without forcing it always to a literal string.
-
-Starting with Perl 5.8.1 strict is strict about its restrictions:
-if unknown restrictions are used, the strict pragma will abort with
-
- Unknown 'strict' tag(s) '...'
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/subs.pm b/Master/tlpkg/installer/perllib/subs.pm
deleted file mode 100644
index e5a9aa8827d..00000000000
--- a/Master/tlpkg/installer/perllib/subs.pm
+++ /dev/null
@@ -1,40 +0,0 @@
-package subs;
-
-our $VERSION = '1.00';
-
-=head1 NAME
-
-subs - Perl pragma to predeclare sub names
-
-=head1 SYNOPSIS
-
- use subs qw(frob);
- frob 3..10;
-
-=head1 DESCRIPTION
-
-This will predeclare all the subroutine whose names are
-in the list, allowing you to use them without parentheses
-even before they're declared.
-
-Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
-C<use subs> declarations are not BLOCK-scoped. They are thus effective
-for the entire file in which they appear. You may not rescind such
-declarations with C<no vars> or C<no subs>.
-
-See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>.
-
-=cut
-
-require 5.000;
-
-sub import {
- my $callpack = caller;
- my $pack = shift;
- my @imports = @_;
- foreach $sym (@imports) {
- *{"${callpack}::$sym"} = \&{"${callpack}::$sym"};
- }
-};
-
-1;
diff --git a/Master/tlpkg/installer/perllib/unicore/Canonical.pl b/Master/tlpkg/installer/perllib/unicore/Canonical.pl
deleted file mode 100644
index fce1e219700..00000000000
--- a/Master/tlpkg/installer/perllib/unicore/Canonical.pl
+++ /dev/null
@@ -1,1042 +0,0 @@
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is built by mktables from e.g. UnicodeData.txt.
-# Any changes made here will be lost!
-
-##
-## Data in this file used by ../utf8_heavy.pl
-##
-
-## Mapping from lc(canonical name) to filename in ./lib
-%utf8::Canonical = (
-
- # InAegeanNumbers
- aegeannumbers => 'InAegean',
-
- alphabetic => 'Alphabet',
-
- # InAlphabeticPresentationForms
- alphabeticpresentationforms => 'InAlphab',
-
- # InAncientGreekMusicalNotation
- ancientgreekmusicalnotation => 'InAncie2',
-
- # InAncientGreekNumbers
- ancientgreeknumbers => 'InAncien',
-
- arabic => 'Arab',
-
- # InArabicPresentationFormsA
- arabicpresentationformsa => 'InArabi4',
-
- # InArabicPresentationFormsB
- arabicpresentationformsb => 'InArabi3',
-
- # InArabicSupplement
- arabicsupplement => 'InArabi2',
-
- armenian => 'Armn',
-
- # InArrows
- arrows => 'InArrows',
-
- # AsciiHexDigit
- asciihexdigit => 'AsciiHex',
-
- # InBasicLatin
- basiclatin => 'InBasicL',
-
- bengali => 'Beng',
-
- # BidiControl
- bidicontrol => 'BidiCont',
-
- # InBlockElements
- blockelements => 'InBlockE',
-
- bopomofo => 'Bopo',
-
- # InBopomofoExtended
- bopomofoextended => 'InBopom2',
-
- # InBoxDrawing
- boxdrawing => 'InBoxDra',
-
- braille => 'Brai',
-
- # InBraillePatterns
- braillepatterns => 'InBraill',
-
- buginese => 'Bugi',
- buhid => 'Buhd',
-
- # InByzantineMusicalSymbols
- byzantinemusicalsymbols => 'InByzant',
-
- # CanadianAboriginal
- canadianaboriginal => 'Canadian',
-
- # CasedLetter
- casedletter => 'LC',
-
- cherokee => 'Cher',
-
- # InCjkCompatibility
- cjkcompatibility => 'InCjkCom',
-
- # InCjkCompatibilityForms
- cjkcompatibilityforms => 'InCjkCo2',
-
- # InCjkCompatibilityIdeographs
- cjkcompatibilityideographs => 'InCjkCo3',
-
- # InCjkCompatibilityIdeographsSupplement
- cjkcompatibilityideographssupplement => 'InCjkCo4',
-
- # InCjkRadicalsSupplement
- cjkradicalssupplement => 'InCjkRad',
-
- # InCjkStrokes
- cjkstrokes => 'InCjkStr',
-
- # InCjkSymbolsAndPunctuation
- cjksymbolsandpunctuation => 'InCjkSym',
-
- # InCjkUnifiedIdeographs
- cjkunifiedideographs => 'InCjkUni',
-
- # InCjkUnifiedIdeographsExtensionA
- cjkunifiedideographsextensiona => 'InCjkUn3',
-
- # InCjkUnifiedIdeographsExtensionB
- cjkunifiedideographsextensionb => 'InCjkUn2',
-
- # ClosePunctuation
- closepunctuation => 'Pe',
-
- # InCombiningDiacriticalMarks
- combiningdiacriticalmarks => 'InCombi2',
-
- # InCombiningDiacriticalMarksForSymbols
- combiningdiacriticalmarksforsymbols => 'InCombi4',
-
- # InCombiningDiacriticalMarksSupplement
- combiningdiacriticalmarkssupplement => 'InCombi3',
-
- # InCombiningHalfMarks
- combininghalfmarks => 'InCombin',
-
- common => 'Zyyy',
-
- # ConnectorPunctuation
- connectorpunctuation => 'Pc',
-
- control => 'Cc',
-
- # InControlPictures
- controlpictures => 'InContro',
-
- coptic => 'Copt',
-
- # CurrencySymbol
- currencysymbol => 'Sc',
-
- # InCurrencySymbols
- currencysymbols => 'InCurren',
-
- cypriot => 'Cprt',
-
- # InCypriotSyllabary
- cypriotsyllabary => 'InCyprio',
-
- cyrillic => 'Cyrl',
-
- # InCyrillicSupplement
- cyrillicsupplement => 'InCyril2',
-
- dash => 'Dash2',
-
- # DashPunctuation
- dashpunctuation => 'Pd',
-
- # DecimalNumber
- decimalnumber => 'Nd',
-
- deprecated => 'Deprecat',
- deseret => 'Dsrt',
- devanagari => 'Deva',
- diacritic => 'Diacriti',
-
- # InDingbats
- dingbats => 'InDingba',
-
- # InEnclosedAlphanumerics
- enclosedalphanumerics => 'InEnclos',
-
- # InEnclosedCjkLettersAndMonths
- enclosedcjklettersandmonths => 'InEnclo2',
-
- # EnclosingMark
- enclosingmark => 'Me',
-
- ethiopic => 'Ethi',
-
- # InEthiopicExtended
- ethiopicextended => 'InEthio2',
-
- # InEthiopicSupplement
- ethiopicsupplement => 'InEthio3',
-
- extender => 'Extender',
-
- # FinalPunctuation
- finalpunctuation => 'Pf',
-
- format => 'Cf',
-
- # InGeneralPunctuation
- generalpunctuation => 'InGenera',
-
- # InGeometricShapes
- geometricshapes => 'InGeomet',
-
- georgian => 'Geor',
-
- # InGeorgianSupplement
- georgiansupplement => 'InGeorg2',
-
- glagolitic => 'Glag',
- gothic => 'Goth',
-
- # GraphemeLink
- graphemelink => 'Grapheme',
-
- greek => 'Grek',
-
- # InGreekAndCoptic
- greekandcoptic => 'InGreekA',
-
- # InGreekExtended
- greekextended => 'InGreekE',
-
- gujarati => 'Gujr',
- gurmukhi => 'Guru',
-
- # InHalfwidthAndFullwidthForms
- halfwidthandfullwidthforms => 'InHalfwi',
-
- han => 'Hani',
- hangul => 'Hang',
-
- # InHangulCompatibilityJamo
- hangulcompatibilityjamo => 'InHangu3',
-
- # InHangulJamo
- hanguljamo => 'InHangul',
-
- # InHangulSyllables
- hangulsyllables => 'InHangu2',
-
- hanunoo => 'Hano',
- hebrew => 'Hebr',
-
- # HexDigit
- hexdigit => 'HexDigit',
-
- # InHighPrivateUseSurrogates
- highprivateusesurrogates => 'InHighPr',
-
- # InHighSurrogates
- highsurrogates => 'InHighSu',
-
- hiragana => 'Hira',
- hyphen => 'Hyphen2',
-
- # IdContinue
- idcontinue => 'IdContin',
-
- ideographic => 'Ideograp',
-
- # InIdeographicDescriptionCharacters
- ideographicdescriptioncharacters => 'InIdeogr',
-
- # IdsBinaryOperator
- idsbinaryoperator => 'IdsBinar',
-
- # IdStart
- idstart => 'IdStart',
-
- # IdsTrinaryOperator
- idstrinaryoperator => 'IdsTrina',
-
- # InAegeanNumbers
- inaegeannumbers => 'InAegean',
-
- # InAlphabeticPresentationForms
- inalphabeticpresentationforms => 'InAlphab',
-
- # InAncientGreekMusicalNotation
- inancientgreekmusicalnotation => 'InAncie2',
-
- # InAncientGreekNumbers
- inancientgreeknumbers => 'InAncien',
-
- # InArabic
- inarabic => 'InArabic',
-
- # InArabicPresentationFormsA
- inarabicpresentationformsa => 'InArabi4',
-
- # InArabicPresentationFormsB
- inarabicpresentationformsb => 'InArabi3',
-
- # InArabicSupplement
- inarabicsupplement => 'InArabi2',
-
- # InArmenian
- inarmenian => 'InArmeni',
-
- # InArrows
- inarrows => 'InArrows',
-
- # InBasicLatin
- inbasiclatin => 'InBasicL',
-
- # InBengali
- inbengali => 'InBengal',
-
- # InBlockElements
- inblockelements => 'InBlockE',
-
- # InBopomofo
- inbopomofo => 'InBopomo',
-
- # InBopomofoExtended
- inbopomofoextended => 'InBopom2',
-
- # InBoxDrawing
- inboxdrawing => 'InBoxDra',
-
- # InBraillePatterns
- inbraillepatterns => 'InBraill',
-
- # InBuginese
- inbuginese => 'InBugine',
-
- # InBuhid
- inbuhid => 'InBuhid',
-
- # InByzantineMusicalSymbols
- inbyzantinemusicalsymbols => 'InByzant',
-
- # InCherokee
- incherokee => 'InCherok',
-
- # InCjkCompatibility
- incjkcompatibility => 'InCjkCom',
-
- # InCjkCompatibilityForms
- incjkcompatibilityforms => 'InCjkCo2',
-
- # InCjkCompatibilityIdeographs
- incjkcompatibilityideographs => 'InCjkCo3',
-
- # InCjkCompatibilityIdeographsSupplement
- incjkcompatibilityideographssupplement => 'InCjkCo4',
-
- # InCjkRadicalsSupplement
- incjkradicalssupplement => 'InCjkRad',
-
- # InCjkStrokes
- incjkstrokes => 'InCjkStr',
-
- # InCjkSymbolsAndPunctuation
- incjksymbolsandpunctuation => 'InCjkSym',
-
- # InCjkUnifiedIdeographs
- incjkunifiedideographs => 'InCjkUni',
-
- # InCjkUnifiedIdeographsExtensionA
- incjkunifiedideographsextensiona => 'InCjkUn3',
-
- # InCjkUnifiedIdeographsExtensionB
- incjkunifiedideographsextensionb => 'InCjkUn2',
-
- # InCombiningDiacriticalMarks
- incombiningdiacriticalmarks => 'InCombi2',
-
- # InCombiningDiacriticalMarksForSymbols
- incombiningdiacriticalmarksforsymbols => 'InCombi4',
-
- # InCombiningDiacriticalMarksSupplement
- incombiningdiacriticalmarkssupplement => 'InCombi3',
-
- # InCombiningHalfMarks
- incombininghalfmarks => 'InCombin',
-
- # InControlPictures
- incontrolpictures => 'InContro',
-
- # InCoptic
- incoptic => 'InCoptic',
-
- # InCurrencySymbols
- incurrencysymbols => 'InCurren',
-
- # InCypriotSyllabary
- incypriotsyllabary => 'InCyprio',
-
- # InCyrillic
- incyrillic => 'InCyrill',
-
- # InCyrillicSupplement
- incyrillicsupplement => 'InCyril2',
-
- # InDeseret
- indeseret => 'InDesere',
-
- # InDevanagari
- indevanagari => 'InDevana',
-
- # InDingbats
- indingbats => 'InDingba',
-
- # InEnclosedAlphanumerics
- inenclosedalphanumerics => 'InEnclos',
-
- # InEnclosedCjkLettersAndMonths
- inenclosedcjklettersandmonths => 'InEnclo2',
-
- # InEthiopic
- inethiopic => 'InEthiop',
-
- # InEthiopicExtended
- inethiopicextended => 'InEthio2',
-
- # InEthiopicSupplement
- inethiopicsupplement => 'InEthio3',
-
- # InGeneralPunctuation
- ingeneralpunctuation => 'InGenera',
-
- # InGeometricShapes
- ingeometricshapes => 'InGeomet',
-
- # InGeorgian
- ingeorgian => 'InGeorgi',
-
- # InGeorgianSupplement
- ingeorgiansupplement => 'InGeorg2',
-
- # InGlagolitic
- inglagolitic => 'InGlagol',
-
- # InGothic
- ingothic => 'InGothic',
-
- # InGreekAndCoptic
- ingreekandcoptic => 'InGreekA',
-
- # InGreekExtended
- ingreekextended => 'InGreekE',
-
- # InGujarati
- ingujarati => 'InGujara',
-
- # InGurmukhi
- ingurmukhi => 'InGurmuk',
-
- # InHalfwidthAndFullwidthForms
- inhalfwidthandfullwidthforms => 'InHalfwi',
-
- # InHangulCompatibilityJamo
- inhangulcompatibilityjamo => 'InHangu3',
-
- # InHangulJamo
- inhanguljamo => 'InHangul',
-
- # InHangulSyllables
- inhangulsyllables => 'InHangu2',
-
- # InHanunoo
- inhanunoo => 'InHanuno',
-
- # InHebrew
- inhebrew => 'InHebrew',
-
- inherited => 'Qaai',
-
- # InHighPrivateUseSurrogates
- inhighprivateusesurrogates => 'InHighPr',
-
- # InHighSurrogates
- inhighsurrogates => 'InHighSu',
-
- # InHiragana
- inhiragana => 'InHiraga',
-
- # InIdeographicDescriptionCharacters
- inideographicdescriptioncharacters => 'InIdeogr',
-
- # InIpaExtensions
- inipaextensions => 'InIpaExt',
-
- # InitialPunctuation
- initialpunctuation => 'Pi',
-
- # InKanbun
- inkanbun => 'InKanbun',
-
- # InKangxiRadicals
- inkangxiradicals => 'InKangxi',
-
- # InKannada
- inkannada => 'InKannad',
-
- # InKatakana
- inkatakana => 'InKataka',
-
- # InKatakanaPhoneticExtensions
- inkatakanaphoneticextensions => 'InKatak2',
-
- # InKharoshthi
- inkharoshthi => 'InKharos',
-
- # InKhmer
- inkhmer => 'InKhmer',
-
- # InKhmerSymbols
- inkhmersymbols => 'InKhmerS',
-
- # InLao
- inlao => 'InLao',
-
- # InLatin1Supplement
- inlatin1supplement => 'InLatin1',
-
- # InLatinExtendedA
- inlatinextendeda => 'InLatin2',
-
- # InLatinExtendedAdditional
- inlatinextendedadditional => 'InLatin3',
-
- # InLatinExtendedB
- inlatinextendedb => 'InLatinE',
-
- # InLetterlikeSymbols
- inletterlikesymbols => 'InLetter',
-
- # InLimbu
- inlimbu => 'InLimbu',
-
- # InLinearBIdeograms
- inlinearbideograms => 'InLinear',
-
- # InLinearBSyllabary
- inlinearbsyllabary => 'InLinea2',
-
- # InLowSurrogates
- inlowsurrogates => 'InLowSur',
-
- # InMalayalam
- inmalayalam => 'InMalaya',
-
- # InMathematicalAlphanumericSymbols
- inmathematicalalphanumericsymbols => 'InMathe2',
-
- # InMathematicalOperators
- inmathematicaloperators => 'InMathem',
-
- # InMiscellaneousMathematicalSymbolsA
- inmiscellaneousmathematicalsymbolsa => 'InMisce4',
-
- # InMiscellaneousMathematicalSymbolsB
- inmiscellaneousmathematicalsymbolsb => 'InMisce5',
-
- # InMiscellaneousSymbols
- inmiscellaneoussymbols => 'InMiscel',
-
- # InMiscellaneousSymbolsAndArrows
- inmiscellaneoussymbolsandarrows => 'InMisce3',
-
- # InMiscellaneousTechnical
- inmiscellaneoustechnical => 'InMisce2',
-
- # InModifierToneLetters
- inmodifiertoneletters => 'InModifi',
-
- # InMongolian
- inmongolian => 'InMongol',
-
- # InMusicalSymbols
- inmusicalsymbols => 'InMusica',
-
- # InMyanmar
- inmyanmar => 'InMyanma',
-
- # InNewTaiLue
- innewtailue => 'InNewTai',
-
- # InNumberForms
- innumberforms => 'InNumber',
-
- # InOgham
- inogham => 'InOgham',
-
- # InOldItalic
- inolditalic => 'InOldIta',
-
- # InOldPersian
- inoldpersian => 'InOldPer',
-
- # InOpticalCharacterRecognition
- inopticalcharacterrecognition => 'InOptica',
-
- # InOriya
- inoriya => 'InOriya',
-
- # InOsmanya
- inosmanya => 'InOsmany',
-
- # InPhoneticExtensions
- inphoneticextensions => 'InPhonet',
-
- # InPhoneticExtensionsSupplement
- inphoneticextensionssupplement => 'InPhone2',
-
- # InPrivateUseArea
- inprivateusearea => 'InPrivat',
-
- # InRunic
- inrunic => 'InRunic',
-
- # InShavian
- inshavian => 'InShavia',
-
- # InSinhala
- insinhala => 'InSinhal',
-
- # InSmallFormVariants
- insmallformvariants => 'InSmallF',
-
- # InSpacingModifierLetters
- inspacingmodifierletters => 'InSpacin',
-
- # InSpecials
- inspecials => 'InSpecia',
-
- # InSuperscriptsAndSubscripts
- insuperscriptsandsubscripts => 'InSupers',
-
- # InSupplementalArrowsA
- insupplementalarrowsa => 'InSuppl2',
-
- # InSupplementalArrowsB
- insupplementalarrowsb => 'InSupple',
-
- # InSupplementalMathematicalOperators
- insupplementalmathematicaloperators => 'InSuppl6',
-
- # InSupplementalPunctuation
- insupplementalpunctuation => 'InSuppl3',
-
- # InSupplementaryPrivateUseAreaA
- insupplementaryprivateuseareaa => 'InSuppl4',
-
- # InSupplementaryPrivateUseAreaB
- insupplementaryprivateuseareab => 'InSuppl5',
-
- # InSylotiNagri
- insylotinagri => 'InSyloti',
-
- # InSyriac
- insyriac => 'InSyriac',
-
- # InTagalog
- intagalog => 'InTagalo',
-
- # InTagbanwa
- intagbanwa => 'InTagban',
-
- # InTags
- intags => 'InTags',
-
- # InTaiLe
- intaile => 'InTaiLe',
-
- # InTaiXuanJingSymbols
- intaixuanjingsymbols => 'InTaiXua',
-
- # InTamil
- intamil => 'InTamil',
-
- # InTelugu
- intelugu => 'InTelugu',
-
- # InThaana
- inthaana => 'InThaana',
-
- # InThai
- inthai => 'InThai',
-
- # InTibetan
- intibetan => 'InTibeta',
-
- # InTifinagh
- intifinagh => 'InTifina',
-
- # InUgaritic
- inugaritic => 'InUgarit',
-
- # InUnifiedCanadianAboriginalSyllabics
- inunifiedcanadianaboriginalsyllabics => 'InUnifie',
-
- # InVariationSelectors
- invariationselectors => 'InVariat',
-
- # InVariationSelectorsSupplement
- invariationselectorssupplement => 'InVaria2',
-
- # InVerticalForms
- inverticalforms => 'InVertic',
-
- # InYijingHexagramSymbols
- inyijinghexagramsymbols => 'InYijing',
-
- # InYiRadicals
- inyiradicals => 'InYiRadi',
-
- # InYiSyllables
- inyisyllables => 'InYiSyll',
-
- # InIpaExtensions
- ipaextensions => 'InIpaExt',
-
- # JoinControl
- joincontrol => 'JoinCont',
-
- # InKanbun
- kanbun => 'InKanbun',
-
- # InKangxiRadicals
- kangxiradicals => 'InKangxi',
-
- kannada => 'Knda',
- katakana => 'Kana',
-
- # InKatakanaPhoneticExtensions
- katakanaphoneticextensions => 'InKatak2',
-
- kharoshthi => 'Khar',
- khmer => 'Khmr',
-
- # InKhmerSymbols
- khmersymbols => 'InKhmerS',
-
- lao => 'Laoo',
- latin => 'Latn',
-
- # InLatin1Supplement
- latin1supplement => 'InLatin1',
-
- # InLatinExtendedA
- latinextendeda => 'InLatin2',
-
- # InLatinExtendedAdditional
- latinextendedadditional => 'InLatin3',
-
- # InLatinExtendedB
- latinextendedb => 'InLatinE',
-
- letter => 'L',
-
- # InLetterlikeSymbols
- letterlikesymbols => 'InLetter',
-
- # LetterNumber
- letternumber => 'Nl',
-
- limbu => 'Limb',
-
- # LinearB
- linearb => 'LinearB',
-
- # InLinearBIdeograms
- linearbideograms => 'InLinear',
-
- # InLinearBSyllabary
- linearbsyllabary => 'InLinea2',
-
- # LineSeparator
- lineseparator => 'Zl',
-
- # LogicalOrderException
- logicalorderexception => 'LogicalO',
-
- lowercase => 'Lowercas',
-
- # LowercaseLetter
- lowercaseletter => 'Ll',
-
- # InLowSurrogates
- lowsurrogates => 'InLowSur',
-
- malayalam => 'Mlym',
- mark => 'M',
- math => 'Math',
-
- # InMathematicalAlphanumericSymbols
- mathematicalalphanumericsymbols => 'InMathe2',
-
- # InMathematicalOperators
- mathematicaloperators => 'InMathem',
-
- # MathSymbol
- mathsymbol => 'Sm',
-
- # InMiscellaneousMathematicalSymbolsA
- miscellaneousmathematicalsymbolsa => 'InMisce4',
-
- # InMiscellaneousMathematicalSymbolsB
- miscellaneousmathematicalsymbolsb => 'InMisce5',
-
- # InMiscellaneousSymbols
- miscellaneoussymbols => 'InMiscel',
-
- # InMiscellaneousSymbolsAndArrows
- miscellaneoussymbolsandarrows => 'InMisce3',
-
- # InMiscellaneousTechnical
- miscellaneoustechnical => 'InMisce2',
-
- # ModifierLetter
- modifierletter => 'Lm',
-
- # ModifierSymbol
- modifiersymbol => 'Sk',
-
- # InModifierToneLetters
- modifiertoneletters => 'InModifi',
-
- mongolian => 'Mong',
-
- # InMusicalSymbols
- musicalsymbols => 'InMusica',
-
- myanmar => 'Mymr',
-
- # NewTaiLue
- newtailue => 'NewTaiLu',
-
- # NoncharacterCodePoint
- noncharactercodepoint => 'Nonchara',
-
- # NonspacingMark
- nonspacingmark => 'Mn',
-
- number => 'N',
-
- # InNumberForms
- numberforms => 'InNumber',
-
- ogham => 'Ogam',
-
- # OldItalic
- olditalic => 'OldItali',
-
- # OldPersian
- oldpersian => 'OldPersi',
-
- # OpenPunctuation
- openpunctuation => 'Ps',
-
- # InOpticalCharacterRecognition
- opticalcharacterrecognition => 'InOptica',
-
- oriya => 'Orya',
- osmanya => 'Osma',
- other => 'C',
-
- # OtherAlphabetic
- otheralphabetic => 'OtherAlp',
-
- # OtherDefaultIgnorableCodePoint
- otherdefaultignorablecodepoint => 'OtherDef',
-
- # OtherGraphemeExtend
- othergraphemeextend => 'OtherGra',
-
- # OtherIdContinue
- otheridcontinue => 'OtherIdC',
-
- # OtherIdStart
- otheridstart => 'OtherIdS',
-
- # OtherLetter
- otherletter => 'Lo',
-
- # OtherLowercase
- otherlowercase => 'OtherLow',
-
- # OtherMath
- othermath => 'OtherMat',
-
- # OtherNumber
- othernumber => 'No',
-
- # OtherPunctuation
- otherpunctuation => 'Po',
-
- # OtherSymbol
- othersymbol => 'So',
-
- # OtherUppercase
- otheruppercase => 'OtherUpp',
-
- # ParagraphSeparator
- paragraphseparator => 'Zp',
-
- # PatternSyntax
- patternsyntax => 'PatternS',
-
- # PatternWhiteSpace
- patternwhitespace => 'PatternW',
-
- # InPhoneticExtensions
- phoneticextensions => 'InPhonet',
-
- # InPhoneticExtensionsSupplement
- phoneticextensionssupplement => 'InPhone2',
-
- # PrivateUse
- privateuse => 'Co',
-
- # InPrivateUseArea
- privateusearea => 'InPrivat',
-
- punctuation => 'P',
-
- # QuotationMark
- quotationmark => 'Quotatio',
-
- radical => 'Radical2',
- runic => 'Runr',
- separator => 'Z',
- shavian => 'Shaw',
- sinhala => 'Sinh',
-
- # InSmallFormVariants
- smallformvariants => 'InSmallF',
-
- # SoftDotted
- softdotted => 'SoftDott',
-
- # SpaceSeparator
- spaceseparator => 'Zs',
-
- # SpacingMark
- spacingmark => 'Mc',
-
- # InSpacingModifierLetters
- spacingmodifierletters => 'InSpacin',
-
- # InSpecials
- specials => 'InSpecia',
-
- sterm => 'Sterm2',
-
- # InSuperscriptsAndSubscripts
- superscriptsandsubscripts => 'InSupers',
-
- # InSupplementalArrowsA
- supplementalarrowsa => 'InSuppl2',
-
- # InSupplementalArrowsB
- supplementalarrowsb => 'InSupple',
-
- # InSupplementalMathematicalOperators
- supplementalmathematicaloperators => 'InSuppl6',
-
- # InSupplementalPunctuation
- supplementalpunctuation => 'InSuppl3',
-
- # InSupplementaryPrivateUseAreaA
- supplementaryprivateuseareaa => 'InSuppl4',
-
- # InSupplementaryPrivateUseAreaB
- supplementaryprivateuseareab => 'InSuppl5',
-
- surrogate => 'Cs',
-
- # SylotiNagri
- sylotinagri => 'SylotiNa',
-
- symbol => 'S',
- syriac => 'Syrc',
- tagalog => 'Tglg',
- tagbanwa => 'Tagb',
-
- # InTags
- tags => 'InTags',
-
- # TaiLe
- taile => 'TaiLe',
-
- # InTaiXuanJingSymbols
- taixuanjingsymbols => 'InTaiXua',
-
- tamil => 'Taml',
- telugu => 'Telu',
-
- # TerminalPunctuation
- terminalpunctuation => 'Terminal',
-
- thaana => 'Thaa',
- thai => 'Thai',
- tibetan => 'Tibt',
- tifinagh => 'Tfng',
-
- # TitlecaseLetter
- titlecaseletter => 'Lt',
-
- ugaritic => 'Ugar',
- unassigned => 'Cn',
-
- # InUnifiedCanadianAboriginalSyllabics
- unifiedcanadianaboriginalsyllabics => 'InUnifie',
-
- # UnifiedIdeograph
- unifiedideograph => 'UnifiedI',
-
- uppercase => 'Uppercas',
-
- # UppercaseLetter
- uppercaseletter => 'Lu',
-
- # VariationSelector
- variationselector => 'Variatio',
-
- # InVariationSelectors
- variationselectors => 'InVariat',
-
- # InVariationSelectorsSupplement
- variationselectorssupplement => 'InVaria2',
-
- # InVerticalForms
- verticalforms => 'InVertic',
-
- # WhiteSpace
- whitespace => 'WhiteSpa',
-
- yi => 'Yiii',
-
- # InYijingHexagramSymbols
- yijinghexagramsymbols => 'InYijing',
-
- # InYiRadicals
- yiradicals => 'InYiRadi',
-
- # InYiSyllables
- yisyllables => 'InYiSyll',
-
-);
-1
diff --git a/Master/tlpkg/installer/perllib/unicore/Exact.pl b/Master/tlpkg/installer/perllib/unicore/Exact.pl
deleted file mode 100644
index 42312b054cc..00000000000
--- a/Master/tlpkg/installer/perllib/unicore/Exact.pl
+++ /dev/null
@@ -1,73 +0,0 @@
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is built by mktables from e.g. UnicodeData.txt.
-# Any changes made here will be lost!
-
-##
-## Data in this file used by ../utf8_heavy.pl
-##
-
-## Mapping from name to filename in ./lib/gc_sc
-%utf8::Exact = (
- ASCII => 'ASCII',
- All => 'Any',
- Alnum => 'Alnum',
- Alpha => 'Alpha',
- Any => 'Any',
- Assigned => 'Assigned',
- Blank => 'Blank',
- C => 'C',
- Cc => 'Cc',
- Cf => 'Cf',
- Cn => 'Cn',
- Cntrl => 'Cntrl',
- Co => 'Co',
- Cs => 'Cs',
- Digit => 'Digit',
- Graph => 'Graph',
- InGreek => 'InGreekA',
- L => 'L',
- LC => 'LC',
- Ll => 'Ll',
- Lm => 'Lm',
- Lo => 'Lo',
- Lower => 'Lower',
- Lt => 'Lt',
- Lu => 'Lu',
- M => 'M',
- Mc => 'Mc',
- Me => 'Me',
- Mn => 'Mn',
- N => 'N',
- Nd => 'Nd',
- Nl => 'Nl',
- No => 'No',
- P => 'P',
- Pc => 'Pc',
- Pd => 'Pd',
- Pe => 'Pe',
- Pf => 'Pf',
- Pi => 'Pi',
- Po => 'Po',
- Print => 'Print',
- Ps => 'Ps',
- Punct => 'Punct',
- S => 'S',
- Sc => 'Sc',
- Sk => 'Sk',
- Sm => 'Sm',
- So => 'So',
- Space => 'Space',
- SpacePerl => 'SpacePer',
- Title => 'Title',
- Upper => 'Upper',
- Word => 'Word',
- XDigit => 'XDigit',
- Z => 'Z',
- Zl => 'Zl',
- Zp => 'Zp',
- Zs => 'Zs',
- _CanonDCIJ => '_CanonDC',
- _CaseIgnorable => '_CaseIgn',
- _CombAbove => '_CombAbo',
-);
-1;
diff --git a/Master/tlpkg/installer/perllib/unicore/PVA.pl b/Master/tlpkg/installer/perllib/unicore/PVA.pl
deleted file mode 100644
index d836bdb7549..00000000000
--- a/Master/tlpkg/installer/perllib/unicore/PVA.pl
+++ /dev/null
@@ -1,2044 +0,0 @@
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is built by mktables from e.g. UnicodeData.txt.
-# Any changes made here will be lost!
-
-
-%utf8::PropertyAlias = (
-'sc',
-'Script',
-'xonfkd',
-'ExpandsOnNFKD',
-'patsyn',
-'PatternSyntax',
-'nfkcqc',
-'NFKCQuickCheck',
-'oalpha',
-'OtherAlphabetic',
-'gcb',
-'GraphemeClusterBreak',
-'nfcqc',
-'NFCQuickCheck',
-'ids',
-'IDStart',
-'lb',
-'LineBreak',
-'stc',
-'SimpleTitlecaseMapping',
-'xonfkc',
-'ExpandsOnNFKC',
-'patws',
-'PatternWhiteSpace',
-'tc',
-'TitlecaseMapping',
-'lower',
-'Lowercase',
-'idst',
-'IDSTrinaryOperator',
-'radical',
-'Radical',
-'fcnfkc',
-'FCNFKCClosure',
-'dm',
-'DecompositionMapping',
-'slc',
-'SimpleLowercaseMapping',
-'wspace',
-'WhiteSpace',
-'di',
-'DefaultIgnorableCodePoint',
-'nt',
-'NumericType',
-'ea',
-'EastAsianWidth',
-'ahex',
-'ASCIIHexDigit',
-'alpha',
-'Alphabetic',
-'uc',
-'UppercaseMapping',
-'dia',
-'Diacritic',
-'gc',
-'GeneralCategory',
-'xids',
-'XIDStart',
-'oupper',
-'OtherUppercase',
-'wb',
-'WordBreak',
-'math',
-'Math',
-'sb',
-'SentenceBreak',
-'qmark',
-'QuotationMark',
-'nfdqc',
-'NFDQuickCheck',
-'ideo',
-'Ideographic',
-'blk',
-'Block',
-'odi',
-'OtherDefaultIgnorableCodePoint',
-'hst',
-'HangulSyllableType',
-'bidim',
-'BidiMirrored',
-'olower',
-'OtherLowercase',
-'na',
-'Name',
-'hyphen',
-'Hyphen',
-'xidc',
-'XIDContinue',
-'oidc',
-'OtherIDContinue',
-'bidic',
-'BidiControl',
-'na1',
-'Unicode1Name',
-'compex',
-'FullCompositionExclusion',
-'ext',
-'Extender',
-'cf',
-'CaseFolding',
-'grlink',
-'GraphemeLink',
-'xonfc',
-'ExpandsOnNFC',
-'sd',
-'SoftDotted',
-'ccc',
-'CanonicalCombiningClass',
-'dash',
-'Dash',
-'hex',
-'HexDigit',
-'grbase',
-'GraphemeBase',
-'dt',
-'DecompositionType',
-'xonfd',
-'ExpandsOnNFD',
-'scc',
-'SpecialCaseCondition',
-'idsb',
-'IDSBinaryOperator',
-'age',
-'Age',
-'loe',
-'LogicalOrderException',
-'term',
-'TerminalPunctuation',
-'ce',
-'CompositionExclusion',
-'isc',
-'ISOComment',
-'dep',
-'Deprecated',
-'sfc',
-'SimpleCaseFolding',
-'bc',
-'BidiClass',
-'nchar',
-'NoncharacterCodePoint',
-'jt',
-'JoiningType',
-'upper',
-'Uppercase',
-'uideo',
-'UnifiedIdeograph',
-'sterm',
-'STerm',
-'nfkdqc',
-'NFKDQuickCheck',
-'oids',
-'OtherIDStart',
-'joinc',
-'JoinControl',
-'nv',
-'NumericValue',
-'suc',
-'SimpleUppercaseMapping',
-'urs',
-'UnicodeRadicalStroke',
-'bmg',
-'BidiMirroringGlyph',
-'grext',
-'GraphemeExtend',
-'idc',
-'IDContinue',
-'vs',
-'VariationSelector',
-'omath',
-'OtherMath',
-'lc',
-'LowercaseMapping',
-'ogrext',
-'OtherGraphemeExtend',
-'jg',
-'JoiningGroup',
-);
-
-%utf8::PA_reverse = (
-'linebreak',
-'lb',
-'bidiclass',
-'bc',
-'terminalpunctuation',
-'Term',
-'expandsonnfkc',
-'XONFKC',
-'extender',
-'Ext',
-'simplecasefolding',
-'sfc',
-'patternsyntax',
-'PatSyn',
-'sentencebreak',
-'SB',
-'numericvalue',
-'nv',
-'patternwhitespace',
-'PatWS',
-'softdotted',
-'SD',
-'logicalorderexception',
-'LOE',
-'idstart',
-'IDS',
-'generalcategory',
-'gc',
-'decompositiontype',
-'dt',
-'name',
-'na',
-'numerictype',
-'nt',
-'otherlowercase',
-'OLower',
-'joininggroup',
-'jg',
-'expandsonnfkd',
-'XONFKD',
-'deprecated',
-'Dep',
-'radical',
-'Radical',
-'idstrinaryoperator',
-'IDST',
-'xidstart',
-'XIDS',
-'lowercase',
-'Lower',
-'unifiedideograph',
-'UIdeo',
-'othergraphemeextend',
-'OGrExt',
-'eastasianwidth',
-'ea',
-'math',
-'Math',
-'graphemelink',
-'GrLink',
-'noncharactercodepoint',
-'NChar',
-'graphemebase',
-'GrBase',
-'bidimirrored',
-'BidiM',
-'casefolding',
-'cf',
-'simpleuppercasemapping',
-'suc',
-'fullcompositionexclusion',
-'CompEx',
-'compositionexclusion',
-'CE',
-'uppercasemapping',
-'uc',
-'decompositionmapping',
-'dm',
-'whitespace',
-'WSpace',
-'hyphen',
-'Hyphen',
-'ideographic',
-'Ideo',
-'idcontinue',
-'IDC',
-'idsbinaryoperator',
-'IDSB',
-'hangulsyllabletype',
-'hst',
-'asciihexdigit',
-'AHex',
-'otheruppercase',
-'OUpper',
-'nfkdquickcheck',
-'NFKDQC',
-'simpletitlecasemapping',
-'stc',
-'nfcquickcheck',
-'NFCQC',
-'bidicontrol',
-'BidiC',
-'diacritic',
-'Dia',
-'joiningtype',
-'jt',
-'otheralphabetic',
-'OAlpha',
-'canonicalcombiningclass',
-'ccc',
-'alphabetic',
-'Alpha',
-'titlecasemapping',
-'tc',
-'unicoderadicalstroke',
-'URS',
-'hexdigit',
-'Hex',
-'unicode1name',
-'na1',
-'dash',
-'Dash',
-'fcnfkcclosure',
-'FCNFKC',
-'graphemeextend',
-'GrExt',
-'joincontrol',
-'JoinC',
-'xidcontinue',
-'XIDC',
-'quotationmark',
-'QMark',
-'expandsonnfd',
-'XONFD',
-'age',
-'age',
-'otheridcontinue',
-'OIDC',
-'uppercase',
-'Upper',
-'expandsonnfc',
-'XONFC',
-'defaultignorablecodepoint',
-'DI',
-'nfdquickcheck',
-'NFDQC',
-'isocomment',
-'isc',
-'otherdefaultignorablecodepoint',
-'ODI',
-'variationselector',
-'VS',
-'specialcasecondition',
-'scc',
-'script',
-'sc',
-'otheridstart',
-'OIDS',
-'sterm',
-'STerm',
-'graphemeclusterbreak',
-'GCB',
-'nfkcquickcheck',
-'NFKCQC',
-'bidimirroringglyph',
-'bmg',
-'othermath',
-'OMath',
-'block',
-'blk',
-'wordbreak',
-'WB',
-'lowercasemapping',
-'lc',
-'simplelowercasemapping',
-'slc',
-);
-
-%utf8::PropValueAlias = (
-'sc',
-{
-'tglg',
-'Tagalog',
-'runr',
-'Runic',
-'osma',
-'Osmanya',
-'hano',
-'Hanunoo',
-'cans',
-'CanadianAboriginal',
-'tagb',
-'Tagbanwa',
-'mlym',
-'Malayalam',
-'knda',
-'Kannada',
-'grek',
-'Greek',
-'ethi',
-'Ethiopic',
-'orya',
-'Oriya',
-'cher',
-'Cherokee',
-'mong',
-'Mongolian',
-'khmr',
-'Khmer',
-'ogam',
-'Ogham',
-'hrkt',
-'KatakanaOrHiragana',
-'armn',
-'Armenian',
-'ital',
-'OldItalic',
-'hani',
-'Han',
-'shaw',
-'Shavian',
-'taml',
-'Tamil',
-'tibt',
-'Tibetan',
-'guru',
-'Gurmukhi',
-'ugar',
-'Ugaritic',
-'qaai',
-'Inherited',
-'kana',
-'Katakana',
-'gujr',
-'Gujarati',
-'thaa',
-'Thaana',
-'cyrl',
-'Cyrillic',
-'copt',
-'Coptic',
-'sylo',
-'SylotiNagri',
-'thai',
-'Thai',
-'talu',
-'NewTaiLue',
-'laoo',
-'Lao',
-'sinh',
-'Sinhala',
-'beng',
-'Bengali',
-'hira',
-'Hiragana',
-'brai',
-'Braille',
-'telu',
-'Telugu',
-'limb',
-'Limbu',
-'geor',
-'Georgian',
-'mymr',
-'Myanmar',
-'glag',
-'Glagolitic',
-'hang',
-'Hangul',
-'syrc',
-'Syriac',
-'tfng',
-'Tifinagh',
-'dsrt',
-'Deseret',
-'buhd',
-'Buhid',
-'yiii',
-'Yi',
-'arab',
-'Arabic',
-'bopo',
-'Bopomofo',
-'khar',
-'Kharoshthi',
-'linb',
-'LinearB',
-'deva',
-'Devanagari',
-'xpeo',
-'OldPersian',
-'goth',
-'Gothic',
-'cprt',
-'Cypriot',
-'tale',
-'TaiLe',
-'zyyy',
-'Common',
-'latn',
-'Latin',
-'bugi',
-'Buginese',
-'hebr',
-'Hebrew',
-},
-'dt',
-{
-'fra',
-'Fraction',
-'none',
-'None',
-'sml',
-'Small',
-'enc',
-'Circle',
-'font',
-'Font',
-'init',
-'Initial',
-'nb',
-'Nobreak',
-'iso',
-'Isolated',
-'sup',
-'Super',
-'fin',
-'Final',
-'wide',
-'Wide',
-'nar',
-'Narrow',
-'can',
-'Canonical',
-'med',
-'Medial',
-'sub',
-'Sub',
-'vert',
-'Vertical',
-'sqr',
-'Square',
-'com',
-'Compat',
-},
-'nt',
-{
-'none',
-'None',
-'di',
-'Digit',
-'de',
-'Decimal',
-'nu',
-'Numeric',
-},
-'ea',
-{
-'w',
-'Wide',
-'n',
-'Neutral',
-'h',
-'Halfwidth',
-'a',
-'Ambiguous',
-'f',
-'Fullwidth',
-'na',
-'Narrow',
-},
-'NFKC_QC',
-{
-'y',
-'Yes',
-'n',
-'No',
-'m',
-'Maybe',
-},
-'bc',
-{
-'r',
-'RightToLeft',
-'rlo',
-'RightToLeftOverride',
-'es',
-'EuropeanSeparator',
-'ws',
-'WhiteSpace',
-'rle',
-'RightToLeftEmbedding',
-'on',
-'OtherNeutral',
-'bn',
-'BoundaryNeutral',
-'et',
-'EuropeanTerminator',
-'pdf',
-'PopDirectionalFormat',
-'lro',
-'LeftToRightOverride',
-'s',
-'SegmentSeparator',
-'al',
-'ArabicLetter',
-'en',
-'EuropeanNumber',
-'l',
-'LeftToRight',
-'b',
-'ParagraphSeparator',
-'lre',
-'LeftToRightEmbedding',
-'cs',
-'CommonSeparator',
-'nsm',
-'NonspacingMark',
-'an',
-'ArabicNumber',
-},
-'gc',
-{
-'sc',
-'CurrencySymbol',
-'mc',
-'SpacingMark',
-'lm',
-'ModifierLetter',
-'cn',
-'Unassigned',
-'pf',
-'FinalPunctuation',
-'no',
-'OtherNumber',
-'cc',
-'Control',
-'lo',
-'OtherLetter',
-'po',
-'OtherPunctuation',
-'zs',
-'SpaceSeparator',
-'co',
-'PrivateUse',
-'so',
-'OtherSymbol',
-'ll',
-'LowercaseLetter',
-'nd',
-'DecimalNumber',
-'cf',
-'Format',
-'me',
-'EnclosingMark',
-'s',
-'Symbol',
-'zp',
-'ParagraphSeparator',
-'pd',
-'DashPunctuation',
-'c',
-'Other',
-'lt',
-'TitlecaseLetter',
-'cs',
-'Surrogate',
-'l&',
-'CasedLetter',
-'z',
-'Separator',
-'ps',
-'OpenPunctuation',
-'zl',
-'LineSeparator',
-'pc',
-'ConnectorPunctuation',
-'pi',
-'InitialPunctuation',
-'n',
-'Number',
-'m',
-'Mark',
-'nl',
-'LetterNumber',
-'sm',
-'MathSymbol',
-'l',
-'Letter',
-'mn',
-'NonspacingMark',
-'p',
-'Punctuation',
-'lc',
-'CasedLetter',
-'sk',
-'ModifierSymbol',
-'lu',
-'UppercaseLetter',
-'pe',
-'ClosePunctuation',
-},
-'GCB',
-{
-'cn',
-'Control',
-'ex',
-'Extend',
-'v',
-'V',
-'lv',
-'LV',
-'xx',
-'Other',
-'l',
-'L',
-'lvt',
-'LVT',
-'cr',
-'CR',
-'lf',
-'LF',
-'t',
-'T',
-},
-'lb',
-{
-'sp',
-'Space',
-'ba',
-'BreakAfter',
-'gl',
-'Glue',
-'xx',
-'Unknown',
-'nu',
-'Numeric',
-'cb',
-'ContingentBreak',
-'sy',
-'BreakSymbols',
-'cr',
-'CarriageReturn',
-'in',
-'Inseparable',
-'bb',
-'BreakBefore',
-'sg',
-'Surrogate',
-'sa',
-'ComplexContext',
-'po',
-'PostfixNumeric',
-'jl',
-'JL',
-'id',
-'Ideographic',
-'al',
-'Alphabetic',
-'bk',
-'MandatoryBreak',
-'pr',
-'PrefixNumeric',
-'b2',
-'BreakBoth',
-'op',
-'OpenPunctuation',
-'cl',
-'ClosePunctuation',
-'is',
-'InfixNumeric',
-'qu',
-'Quotation',
-'hy',
-'Hyphen',
-'wj',
-'WordJoiner',
-'zw',
-'ZWSpace',
-'jt',
-'JT',
-'ex',
-'Exclamation',
-'cm',
-'CombiningMark',
-'h2',
-'H2',
-'nl',
-'NextLine',
-'ns',
-'Nonstarter',
-'h3',
-'H3',
-'ai',
-'Ambiguous',
-'lf',
-'LineFeed',
-'jv',
-'JV',
-},
-'jt',
-{
-'l',
-'LeftJoining',
-'u',
-'NonJoining',
-'c',
-'JoinCausing',
-'r',
-'RightJoining',
-'d',
-'DualJoining',
-'t',
-'Transparent',
-},
-'NFKD_QC',
-{
-'y',
-'Yes',
-'n',
-'No',
-},
-'NFC_QC',
-{
-'y',
-'Yes',
-'n',
-'No',
-'m',
-'Maybe',
-},
-'hst',
-{
-'l',
-'LeadingJamo',
-'lvt',
-'LVTSyllable',
-'v',
-'VowelJamo',
-'lv',
-'LVSyllable',
-'t',
-'TrailingJamo',
-'na',
-'NotApplicable',
-},
-'NFD_QC',
-{
-'y',
-'Yes',
-'n',
-'No',
-},
-'WB',
-{
-'ml',
-'MidLetter',
-'le',
-'ALetter',
-'ex',
-'ExtendNumLet',
-'xx',
-'Other',
-'nu',
-'Numeric',
-'fo',
-'Format',
-'mn',
-'MidNum',
-'ka',
-'Katakana',
-},
-'SB',
-{
-'sp',
-'Sp',
-'cl',
-'Close',
-'le',
-'OLetter',
-'up',
-'Upper',
-'st',
-'STerm',
-'xx',
-'Other',
-'nu',
-'Numeric',
-'fo',
-'Format',
-'se',
-'Sep',
-'lo',
-'Lower',
-'at',
-'ATerm',
-},
-'ccc',
-{
-'atb',
-'AttachedBelow',
-'db',
-'DoubleBelow',
-'a',
-'Above',
-'r',
-'Right',
-'da',
-'DoubleAbove',
-'is',
-'IotaSubscript',
-'nr',
-'NotReordered',
-'ov',
-'Overlay',
-'br',
-'BelowRight',
-'nk',
-'Nukta',
-'atbl',
-'AttachedBelowLeft',
-'al',
-'AboveLeft',
-'ar',
-'AboveRight',
-'atar',
-'AttachedAboveRight',
-'l',
-'Left',
-'b',
-'Below',
-'vr',
-'Virama',
-'kv',
-'KanaVoicing',
-'bl',
-'BelowLeft',
-},
-);
-
-%utf8::PVA_reverse = (
-'sc',
-{
-'newtailue',
-'Talu',
-'canadianaboriginal',
-'Cans',
-'gujarati',
-'Gujr',
-'latin',
-'Latn',
-'hangul',
-'Hang',
-'deseret',
-'Dsrt',
-'hebrew',
-'Hebr',
-'inherited',
-'Qaai',
-'linearb',
-'Linb',
-'ugaritic',
-'Ugar',
-'taile',
-'Tale',
-'armenian',
-'Armn',
-'tifinagh',
-'Tfng',
-'myanmar',
-'Mymr',
-'gurmukhi',
-'Guru',
-'greek',
-'Grek',
-'coptic',
-'Copt',
-'cyrillic',
-'Cyrl',
-'thaana',
-'Thaa',
-'lao',
-'Laoo',
-'katakana',
-'Kana',
-'khmer',
-'Khmr',
-'tibetan',
-'Tibt',
-'hiragana',
-'Hira',
-'mongolian',
-'Mong',
-'thai',
-'Thai',
-'yi',
-'Yiii',
-'sylotinagri',
-'Sylo',
-'bopomofo',
-'Bopo',
-'malayalam',
-'Mlym',
-'telugu',
-'Telu',
-'limbu',
-'Limb',
-'oriya',
-'Orya',
-'buhid',
-'Buhd',
-'cypriot',
-'Cprt',
-'bengali',
-'Beng',
-'katakanaorhiragana',
-'Hrkt',
-'oldpersian',
-'Xpeo',
-'tagalog',
-'Tglg',
-'syriac',
-'Syrc',
-'cherokee',
-'Cher',
-'ogham',
-'Ogam',
-'hanunoo',
-'Hano',
-'braille',
-'Brai',
-'tamil',
-'Taml',
-'common',
-'Zyyy',
-'runic',
-'Runr',
-'georgian',
-'Geor',
-'ethiopic',
-'Ethi',
-'glagolitic',
-'Glag',
-'han',
-'Hani',
-'kharoshthi',
-'Khar',
-'kannada',
-'Knda',
-'tagbanwa',
-'Tagb',
-'arabic',
-'Arab',
-'sinhala',
-'Sinh',
-'gothic',
-'Goth',
-'osmanya',
-'Osma',
-'olditalic',
-'Ital',
-'devanagari',
-'Deva',
-'buginese',
-'Bugi',
-'shavian',
-'Shaw',
-},
-'dt',
-{
-'small',
-'sml',
-'none',
-'none',
-'isolated',
-'iso',
-'narrow',
-'nar',
-'square',
-'sqr',
-'nobreak',
-'nb',
-'fraction',
-'fra',
-'font',
-'font',
-'medial',
-'med',
-'wide',
-'wide',
-'canonical',
-'can',
-'circle',
-'enc',
-'super',
-'sup',
-'vertical',
-'vert',
-'final',
-'fin',
-'compat',
-'com',
-'sub',
-'sub',
-'initial',
-'init',
-},
-'nt',
-{
-'none',
-'None',
-'digit',
-'Di',
-'numeric',
-'Nu',
-'decimal',
-'De',
-},
-'ea',
-{
-'halfwidth',
-'H',
-'fullwidth',
-'F',
-'ambiguous',
-'A',
-'narrow',
-'Na',
-'wide',
-'W',
-'neutral',
-'N',
-},
-'NFKC_QC',
-{
-'yes',
-'Y',
-'maybe',
-'M',
-'no',
-'N',
-},
-'bc',
-{
-'nonspacingmark',
-'NSM',
-'whitespace',
-'WS',
-'righttoleft',
-'R',
-'lefttoright',
-'L',
-'boundaryneutral',
-'BN',
-'segmentseparator',
-'S',
-'lefttorightembedding',
-'LRE',
-'europeanterminator',
-'ET',
-'righttoleftembedding',
-'RLE',
-'righttoleftoverride',
-'RLO',
-'lefttorightoverride',
-'LRO',
-'europeanseparator',
-'ES',
-'europeannumber',
-'EN',
-'commonseparator',
-'CS',
-'arabicletter',
-'AL',
-'paragraphseparator',
-'B',
-'otherneutral',
-'ON',
-'popdirectionalformat',
-'PDF',
-'arabicnumber',
-'AN',
-},
-'gc',
-{
-'modifiersymbol',
-'Sk',
-'letternumber',
-'Nl',
-'connectorpunctuation',
-'Pc',
-'spacingmark',
-'Mc',
-'mark',
-'M',
-'unassigned',
-'Cn',
-'enclosingmark',
-'Me',
-'lineseparator',
-'Zl',
-'lowercaseletter',
-'Ll',
-'symbol',
-'S',
-'letter',
-'L',
-'othernumber',
-'No',
-'paragraphseparator',
-'Zp',
-'modifierletter',
-'Lm',
-'titlecaseletter',
-'Lt',
-'decimalnumber',
-'Nd',
-'other',
-'C',
-'mathsymbol',
-'Sm',
-'surrogate',
-'Cs',
-'otherletter',
-'Lo',
-'nonspacingmark',
-'Mn',
-'number',
-'N',
-'uppercaseletter',
-'Lu',
-'spaceseparator',
-'Zs',
-'privateuse',
-'Co',
-'openpunctuation',
-'Ps',
-'punctuation',
-'P',
-'control',
-'Cc',
-'casedletter',
-'LC',
-'closepunctuation',
-'Pe',
-'otherpunctuation',
-'Po',
-'finalpunctuation',
-'Pf',
-'format',
-'Cf',
-'initialpunctuation',
-'Pi',
-'separator',
-'Z',
-'othersymbol',
-'So',
-'dashpunctuation',
-'Pd',
-'currencysymbol',
-'Sc',
-},
-'GCB',
-{
-'extend',
-'EX',
-'v',
-'V',
-'lv',
-'LV',
-'l',
-'L',
-'lvt',
-'LVT',
-'cr',
-'CR',
-'other',
-'XX',
-'lf',
-'LF',
-'control',
-'CN',
-'t',
-'T',
-},
-'lb',
-{
-'carriagereturn',
-'CR',
-'ideographic',
-'ID',
-'hyphen',
-'HY',
-'ambiguous',
-'AI',
-'contingentbreak',
-'CB',
-'complexcontext',
-'SA',
-'prefixnumeric',
-'PR',
-'jl',
-'JL',
-'inseparable',
-'IN',
-'breaksymbols',
-'SY',
-'breakafter',
-'BA',
-'breakbefore',
-'BB',
-'postfixnumeric',
-'PO',
-'glue',
-'GL',
-'wordjoiner',
-'WJ',
-'breakboth',
-'B2',
-'quotation',
-'QU',
-'combiningmark',
-'CM',
-'nonstarter',
-'NS',
-'linefeed',
-'LF',
-'alphabetic',
-'AL',
-'surrogate',
-'SG',
-'mandatorybreak',
-'BK',
-'unknown',
-'XX',
-'exclamation',
-'EX',
-'openpunctuation',
-'OP',
-'jt',
-'JT',
-'closepunctuation',
-'CL',
-'space',
-'SP',
-'zwspace',
-'ZW',
-'h2',
-'H2',
-'infixnumeric',
-'IS',
-'nextline',
-'NL',
-'numeric',
-'NU',
-'h3',
-'H3',
-'jv',
-'JV',
-},
-'jt',
-{
-'leftjoining',
-'L',
-'transparent',
-'T',
-'nonjoining',
-'U',
-'rightjoining',
-'R',
-'dualjoining',
-'D',
-'joincausing',
-'C',
-},
-'NFKD_QC',
-{
-'yes',
-'Y',
-'no',
-'N',
-},
-'NFC_QC',
-{
-'yes',
-'Y',
-'maybe',
-'M',
-'no',
-'N',
-},
-'hst',
-{
-'lvtsyllable',
-'LVT',
-'lvsyllable',
-'LV',
-'leadingjamo',
-'L',
-'notapplicable',
-'NA',
-'voweljamo',
-'V',
-'trailingjamo',
-'T',
-},
-'NFD_QC',
-{
-'yes',
-'Y',
-'no',
-'N',
-},
-'WB',
-{
-'midletter',
-'ML',
-'format',
-'FO',
-'katakana',
-'KA',
-'other',
-'XX',
-'midnum',
-'MN',
-'numeric',
-'NU',
-'extendnumlet',
-'EX',
-'aletter',
-'LE',
-},
-'SB',
-{
-'sp',
-'SP',
-'upper',
-'UP',
-'sterm',
-'ST',
-'aterm',
-'AT',
-'close',
-'CL',
-'oletter',
-'LE',
-'sep',
-'SE',
-'format',
-'FO',
-'other',
-'XX',
-'lower',
-'LO',
-'numeric',
-'NU',
-},
-'ccc',
-{
-'left',
-'L',
-'attachedbelowleft',
-'ATBL',
-'belowleft',
-'BL',
-'aboveright',
-'AR',
-'kanavoicing',
-'KV',
-'above',
-'A',
-'aboveleft',
-'AL',
-'nukta',
-'NK',
-'below',
-'B',
-'doublebelow',
-'DB',
-'virama',
-'VR',
-'belowright',
-'BR',
-'notreordered',
-'NR',
-'attachedbelow',
-'ATB',
-'right',
-'R',
-'iotasubscript',
-'IS',
-'doubleabove',
-'DA',
-'attachedaboveright',
-'ATAR',
-'overlay',
-'OV',
-},
-);
-
-%utf8::PVA_abbr_map = (
-'jt',
-{
-'l',
-'L',
-'u',
-'U',
-'c',
-'C',
-'r',
-'R',
-'d',
-'D',
-'t',
-'T',
-},
-'dt',
-{
-'fra',
-'fra',
-'none',
-'none',
-'sml',
-'sml',
-'enc',
-'enc',
-'font',
-'font',
-'init',
-'init',
-'nb',
-'nb',
-'iso',
-'iso',
-'sup',
-'sup',
-'fin',
-'fin',
-'wide',
-'wide',
-'nar',
-'nar',
-'can',
-'can',
-'med',
-'med',
-'sub',
-'sub',
-'vert',
-'vert',
-'sqr',
-'sqr',
-'com',
-'com',
-},
-'nt',
-{
-'none',
-'None',
-'di',
-'Di',
-'de',
-'De',
-'nu',
-'Nu',
-},
-'NFKD_QC',
-{
-'y',
-'Y',
-'n',
-'N',
-},
-'ea',
-{
-'w',
-'W',
-'n',
-'N',
-'h',
-'H',
-'a',
-'A',
-'f',
-'F',
-'na',
-'Na',
-},
-'gc_sc',
-{
-'runr',
-'Runr',
-'osma',
-'Osma',
-'sc',
-'Sc',
-'mc',
-'Mc',
-'hano',
-'Hano',
-'cans',
-'Cans',
-'lm',
-'Lm',
-'cn',
-'Cn',
-'knda',
-'Knda',
-'orya',
-'Orya',
-'cher',
-'Cher',
-'khmr',
-'Khmr',
-'ogam',
-'Ogam',
-'lo',
-'Lo',
-'po',
-'Po',
-'co',
-'Co',
-'ital',
-'Ital',
-'ll',
-'Ll',
-'tibt',
-'Tibt',
-'kana',
-'Kana',
-'zp',
-'Zp',
-'gujr',
-'Gujr',
-'thaa',
-'Thaa',
-'cs',
-'Cs',
-'copt',
-'Copt',
-'z',
-'Z',
-'ps',
-'Ps',
-'sylo',
-'Sylo',
-'talu',
-'Talu',
-'laoo',
-'Laoo',
-'sinh',
-'Sinh',
-'zl',
-'Zl',
-'pc',
-'Pc',
-'hira',
-'Hira',
-'limb',
-'Limb',
-'mymr',
-'Mymr',
-'yiii',
-'Yiii',
-'arab',
-'Arab',
-'deva',
-'Deva',
-'xpeo',
-'Xpeo',
-'cprt',
-'Cprt',
-'bugi',
-'Bugi',
-'sk',
-'Sk',
-'hebr',
-'Hebr',
-'lu',
-'Lu',
-'pe',
-'Pe',
-'tglg',
-'Tglg',
-'tagb',
-'Tagb',
-'mlym',
-'Mlym',
-'pf',
-'Pf',
-'no',
-'No',
-'grek',
-'Grek',
-'ethi',
-'Ethi',
-'mong',
-'Mong',
-'cc',
-'Cc',
-'hrkt',
-'Hrkt',
-'armn',
-'Armn',
-'zs',
-'Zs',
-'so',
-'So',
-'hani',
-'Hani',
-'shaw',
-'Shaw',
-'taml',
-'Taml',
-'me',
-'Me',
-'cf',
-'Cf',
-'nd',
-'Nd',
-'s',
-'S',
-'guru',
-'Guru',
-'ugar',
-'Ugar',
-'qaai',
-'Qaai',
-'lt',
-'Lt',
-'c',
-'C',
-'pd',
-'Pd',
-'cyrl',
-'Cyrl',
-'l&',
-'LC',
-'thai',
-'Thai',
-'beng',
-'Beng',
-'brai',
-'Brai',
-'telu',
-'Telu',
-'pi',
-'Pi',
-'geor',
-'Geor',
-'glag',
-'Glag',
-'hang',
-'Hang',
-'syrc',
-'Syrc',
-'tfng',
-'Tfng',
-'n',
-'N',
-'dsrt',
-'Dsrt',
-'buhd',
-'Buhd',
-'m',
-'M',
-'khar',
-'Khar',
-'sm',
-'Sm',
-'nl',
-'Nl',
-'bopo',
-'Bopo',
-'linb',
-'Linb',
-'mn',
-'Mn',
-'l',
-'L',
-'p',
-'P',
-'goth',
-'Goth',
-'tale',
-'Tale',
-'lc',
-'LC',
-'zyyy',
-'Zyyy',
-'latn',
-'Latn',
-},
-'NFC_QC',
-{
-'y',
-'Y',
-'n',
-'N',
-'m',
-'M',
-},
-'NFD_QC',
-{
-'y',
-'Y',
-'n',
-'N',
-},
-'hst',
-{
-'l',
-'L',
-'lvt',
-'LVT',
-'v',
-'V',
-'lv',
-'LV',
-'t',
-'T',
-'na',
-'NA',
-},
-'NFKC_QC',
-{
-'y',
-'Y',
-'n',
-'N',
-'m',
-'M',
-},
-'WB',
-{
-'ml',
-'ML',
-'le',
-'LE',
-'ex',
-'EX',
-'xx',
-'XX',
-'nu',
-'NU',
-'fo',
-'FO',
-'mn',
-'MN',
-'ka',
-'KA',
-},
-'SB',
-{
-'sp',
-'SP',
-'cl',
-'CL',
-'le',
-'LE',
-'up',
-'UP',
-'st',
-'ST',
-'xx',
-'XX',
-'nu',
-'NU',
-'fo',
-'FO',
-'se',
-'SE',
-'lo',
-'LO',
-'at',
-'AT',
-},
-'bc',
-{
-'r',
-'R',
-'rlo',
-'RLO',
-'es',
-'ES',
-'ws',
-'WS',
-'rle',
-'RLE',
-'on',
-'ON',
-'bn',
-'BN',
-'et',
-'ET',
-'pdf',
-'PDF',
-'lro',
-'LRO',
-'s',
-'S',
-'al',
-'AL',
-'en',
-'EN',
-'l',
-'L',
-'b',
-'B',
-'lre',
-'LRE',
-'cs',
-'CS',
-'nsm',
-'NSM',
-'an',
-'AN',
-},
-'GCB',
-{
-'cn',
-'CN',
-'ex',
-'EX',
-'v',
-'V',
-'lv',
-'LV',
-'xx',
-'XX',
-'l',
-'L',
-'lvt',
-'LVT',
-'cr',
-'CR',
-'lf',
-'LF',
-'t',
-'T',
-},
-'ccc',
-{
-'atb',
-'ATB',
-'db',
-'DB',
-'a',
-'A',
-'r',
-'R',
-'da',
-'DA',
-'is',
-'IS',
-'nr',
-'NR',
-'ov',
-'OV',
-'br',
-'BR',
-'nk',
-'NK',
-'atbl',
-'ATBL',
-'al',
-'AL',
-'ar',
-'AR',
-'atar',
-'ATAR',
-'l',
-'L',
-'b',
-'B',
-'vr',
-'VR',
-'kv',
-'KV',
-'bl',
-'BL',
-},
-'lb',
-{
-'sp',
-'SP',
-'ba',
-'BA',
-'gl',
-'GL',
-'xx',
-'XX',
-'nu',
-'NU',
-'cb',
-'CB',
-'sy',
-'SY',
-'cr',
-'CR',
-'in',
-'IN',
-'bb',
-'BB',
-'sg',
-'SG',
-'sa',
-'SA',
-'po',
-'PO',
-'jl',
-'JL',
-'id',
-'ID',
-'al',
-'AL',
-'bk',
-'BK',
-'pr',
-'PR',
-'b2',
-'B2',
-'op',
-'OP',
-'cl',
-'CL',
-'is',
-'IS',
-'qu',
-'QU',
-'hy',
-'HY',
-'wj',
-'WJ',
-'zw',
-'ZW',
-'jt',
-'JT',
-'ex',
-'EX',
-'cm',
-'CM',
-'h2',
-'H2',
-'nl',
-'NL',
-'ns',
-'NS',
-'h3',
-'H3',
-'ai',
-'AI',
-'lf',
-'LF',
-'jv',
-'JV',
-},
-);
-1;
diff --git a/Master/tlpkg/installer/perllib/unicore/To/Lower.pl b/Master/tlpkg/installer/perllib/unicore/To/Lower.pl
deleted file mode 100644
index 77a7a7fb0e0..00000000000
--- a/Master/tlpkg/installer/perllib/unicore/To/Lower.pl
+++ /dev/null
@@ -1,905 +0,0 @@
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is built by mktables from e.g. UnicodeData.txt.
-# Any changes made here will be lost!
-
-
-# The key UTF-8 _bytes_, the value UTF-8 (speed hack)
-%utf8::ToSpecLower =
-(
-"\xC4\xB0" => "\x{0069}\x{0307}",
-"\xE1\xBE\x88" => "\x{1F80}",
-"\xE1\xBE\x89" => "\x{1F81}",
-"\xE1\xBE\x8A" => "\x{1F82}",
-"\xE1\xBE\x8B" => "\x{1F83}",
-"\xE1\xBE\x8C" => "\x{1F84}",
-"\xE1\xBE\x8D" => "\x{1F85}",
-"\xE1\xBE\x8E" => "\x{1F86}",
-"\xE1\xBE\x8F" => "\x{1F87}",
-"\xE1\xBE\x98" => "\x{1F90}",
-"\xE1\xBE\x99" => "\x{1F91}",
-"\xE1\xBE\x9A" => "\x{1F92}",
-"\xE1\xBE\x9B" => "\x{1F93}",
-"\xE1\xBE\x9C" => "\x{1F94}",
-"\xE1\xBE\x9D" => "\x{1F95}",
-"\xE1\xBE\x9E" => "\x{1F96}",
-"\xE1\xBE\x9F" => "\x{1F97}",
-"\xE1\xBE\xA8" => "\x{1FA0}",
-"\xE1\xBE\xA9" => "\x{1FA1}",
-"\xE1\xBE\xAA" => "\x{1FA2}",
-"\xE1\xBE\xAB" => "\x{1FA3}",
-"\xE1\xBE\xAC" => "\x{1FA4}",
-"\xE1\xBE\xAD" => "\x{1FA5}",
-"\xE1\xBE\xAE" => "\x{1FA6}",
-"\xE1\xBE\xAF" => "\x{1FA7}",
-"\xE1\xBE\xBC" => "\x{1FB3}",
-"\xE1\xBF\x8C" => "\x{1FC3}",
-"\xE1\xBF\xBC" => "\x{1FF3}",
-);
-
-return <<'END';
-0041 0061
-0042 0062
-0043 0063
-0044 0064
-0045 0065
-0046 0066
-0047 0067
-0048 0068
-0049 0069
-004A 006A
-004B 006B
-004C 006C
-004D 006D
-004E 006E
-004F 006F
-0050 0070
-0051 0071
-0052 0072
-0053 0073
-0054 0074
-0055 0075
-0056 0076
-0057 0077
-0058 0078
-0059 0079
-005A 007A
-00C0 00E0
-00C1 00E1
-00C2 00E2
-00C3 00E3
-00C4 00E4
-00C5 00E5
-00C6 00E6
-00C7 00E7
-00C8 00E8
-00C9 00E9
-00CA 00EA
-00CB 00EB
-00CC 00EC
-00CD 00ED
-00CE 00EE
-00CF 00EF
-00D0 00F0
-00D1 00F1
-00D2 00F2
-00D3 00F3
-00D4 00F4
-00D5 00F5
-00D6 00F6
-00D8 00F8
-00D9 00F9
-00DA 00FA
-00DB 00FB
-00DC 00FC
-00DD 00FD
-00DE 00FE
-0100 0101
-0102 0103
-0104 0105
-0106 0107
-0108 0109
-010A 010B
-010C 010D
-010E 010F
-0110 0111
-0112 0113
-0114 0115
-0116 0117
-0118 0119
-011A 011B
-011C 011D
-011E 011F
-0120 0121
-0122 0123
-0124 0125
-0126 0127
-0128 0129
-012A 012B
-012C 012D
-012E 012F
-0132 0133
-0134 0135
-0136 0137
-0139 013A
-013B 013C
-013D 013E
-013F 0140
-0141 0142
-0143 0144
-0145 0146
-0147 0148
-014A 014B
-014C 014D
-014E 014F
-0150 0151
-0152 0153
-0154 0155
-0156 0157
-0158 0159
-015A 015B
-015C 015D
-015E 015F
-0160 0161
-0162 0163
-0164 0165
-0166 0167
-0168 0169
-016A 016B
-016C 016D
-016E 016F
-0170 0171
-0172 0173
-0174 0175
-0176 0177
-0178 00FF
-0179 017A
-017B 017C
-017D 017E
-0181 0253
-0182 0183
-0184 0185
-0186 0254
-0187 0188
-0189 0256
-018A 0257
-018B 018C
-018E 01DD
-018F 0259
-0190 025B
-0191 0192
-0193 0260
-0194 0263
-0196 0269
-0197 0268
-0198 0199
-019C 026F
-019D 0272
-019F 0275
-01A0 01A1
-01A2 01A3
-01A4 01A5
-01A6 0280
-01A7 01A8
-01A9 0283
-01AC 01AD
-01AE 0288
-01AF 01B0
-01B1 028A
-01B2 028B
-01B3 01B4
-01B5 01B6
-01B7 0292
-01B8 01B9
-01BC 01BD
-01C4 01C6
-01C5 01C6
-01C7 01C9
-01C8 01C9
-01CA 01CC
-01CB 01CC
-01CD 01CE
-01CF 01D0
-01D1 01D2
-01D3 01D4
-01D5 01D6
-01D7 01D8
-01D9 01DA
-01DB 01DC
-01DE 01DF
-01E0 01E1
-01E2 01E3
-01E4 01E5
-01E6 01E7
-01E8 01E9
-01EA 01EB
-01EC 01ED
-01EE 01EF
-01F1 01F3
-01F2 01F3
-01F4 01F5
-01F6 0195
-01F7 01BF
-01F8 01F9
-01FA 01FB
-01FC 01FD
-01FE 01FF
-0200 0201
-0202 0203
-0204 0205
-0206 0207
-0208 0209
-020A 020B
-020C 020D
-020E 020F
-0210 0211
-0212 0213
-0214 0215
-0216 0217
-0218 0219
-021A 021B
-021C 021D
-021E 021F
-0220 019E
-0222 0223
-0224 0225
-0226 0227
-0228 0229
-022A 022B
-022C 022D
-022E 022F
-0230 0231
-0232 0233
-023B 023C
-023D 019A
-0241 0294
-0386 03AC
-0388 03AD
-0389 03AE
-038A 03AF
-038C 03CC
-038E 03CD
-038F 03CE
-0391 03B1
-0392 03B2
-0393 03B3
-0394 03B4
-0395 03B5
-0396 03B6
-0397 03B7
-0398 03B8
-0399 03B9
-039A 03BA
-039B 03BB
-039C 03BC
-039D 03BD
-039E 03BE
-039F 03BF
-03A0 03C0
-03A1 03C1
-03A3 03C3
-03A4 03C4
-03A5 03C5
-03A6 03C6
-03A7 03C7
-03A8 03C8
-03A9 03C9
-03AA 03CA
-03AB 03CB
-03D8 03D9
-03DA 03DB
-03DC 03DD
-03DE 03DF
-03E0 03E1
-03E2 03E3
-03E4 03E5
-03E6 03E7
-03E8 03E9
-03EA 03EB
-03EC 03ED
-03EE 03EF
-03F4 03B8
-03F7 03F8
-03F9 03F2
-03FA 03FB
-0400 0450
-0401 0451
-0402 0452
-0403 0453
-0404 0454
-0405 0455
-0406 0456
-0407 0457
-0408 0458
-0409 0459
-040A 045A
-040B 045B
-040C 045C
-040D 045D
-040E 045E
-040F 045F
-0410 0430
-0411 0431
-0412 0432
-0413 0433
-0414 0434
-0415 0435
-0416 0436
-0417 0437
-0418 0438
-0419 0439
-041A 043A
-041B 043B
-041C 043C
-041D 043D
-041E 043E
-041F 043F
-0420 0440
-0421 0441
-0422 0442
-0423 0443
-0424 0444
-0425 0445
-0426 0446
-0427 0447
-0428 0448
-0429 0449
-042A 044A
-042B 044B
-042C 044C
-042D 044D
-042E 044E
-042F 044F
-0460 0461
-0462 0463
-0464 0465
-0466 0467
-0468 0469
-046A 046B
-046C 046D
-046E 046F
-0470 0471
-0472 0473
-0474 0475
-0476 0477
-0478 0479
-047A 047B
-047C 047D
-047E 047F
-0480 0481
-048A 048B
-048C 048D
-048E 048F
-0490 0491
-0492 0493
-0494 0495
-0496 0497
-0498 0499
-049A 049B
-049C 049D
-049E 049F
-04A0 04A1
-04A2 04A3
-04A4 04A5
-04A6 04A7
-04A8 04A9
-04AA 04AB
-04AC 04AD
-04AE 04AF
-04B0 04B1
-04B2 04B3
-04B4 04B5
-04B6 04B7
-04B8 04B9
-04BA 04BB
-04BC 04BD
-04BE 04BF
-04C1 04C2
-04C3 04C4
-04C5 04C6
-04C7 04C8
-04C9 04CA
-04CB 04CC
-04CD 04CE
-04D0 04D1
-04D2 04D3
-04D4 04D5
-04D6 04D7
-04D8 04D9
-04DA 04DB
-04DC 04DD
-04DE 04DF
-04E0 04E1
-04E2 04E3
-04E4 04E5
-04E6 04E7
-04E8 04E9
-04EA 04EB
-04EC 04ED
-04EE 04EF
-04F0 04F1
-04F2 04F3
-04F4 04F5
-04F6 04F7
-04F8 04F9
-0500 0501
-0502 0503
-0504 0505
-0506 0507
-0508 0509
-050A 050B
-050C 050D
-050E 050F
-0531 0561
-0532 0562
-0533 0563
-0534 0564
-0535 0565
-0536 0566
-0537 0567
-0538 0568
-0539 0569
-053A 056A
-053B 056B
-053C 056C
-053D 056D
-053E 056E
-053F 056F
-0540 0570
-0541 0571
-0542 0572
-0543 0573
-0544 0574
-0545 0575
-0546 0576
-0547 0577
-0548 0578
-0549 0579
-054A 057A
-054B 057B
-054C 057C
-054D 057D
-054E 057E
-054F 057F
-0550 0580
-0551 0581
-0552 0582
-0553 0583
-0554 0584
-0555 0585
-0556 0586
-10A0 2D00
-10A1 2D01
-10A2 2D02
-10A3 2D03
-10A4 2D04
-10A5 2D05
-10A6 2D06
-10A7 2D07
-10A8 2D08
-10A9 2D09
-10AA 2D0A
-10AB 2D0B
-10AC 2D0C
-10AD 2D0D
-10AE 2D0E
-10AF 2D0F
-10B0 2D10
-10B1 2D11
-10B2 2D12
-10B3 2D13
-10B4 2D14
-10B5 2D15
-10B6 2D16
-10B7 2D17
-10B8 2D18
-10B9 2D19
-10BA 2D1A
-10BB 2D1B
-10BC 2D1C
-10BD 2D1D
-10BE 2D1E
-10BF 2D1F
-10C0 2D20
-10C1 2D21
-10C2 2D22
-10C3 2D23
-10C4 2D24
-10C5 2D25
-1E00 1E01
-1E02 1E03
-1E04 1E05
-1E06 1E07
-1E08 1E09
-1E0A 1E0B
-1E0C 1E0D
-1E0E 1E0F
-1E10 1E11
-1E12 1E13
-1E14 1E15
-1E16 1E17
-1E18 1E19
-1E1A 1E1B
-1E1C 1E1D
-1E1E 1E1F
-1E20 1E21
-1E22 1E23
-1E24 1E25
-1E26 1E27
-1E28 1E29
-1E2A 1E2B
-1E2C 1E2D
-1E2E 1E2F
-1E30 1E31
-1E32 1E33
-1E34 1E35
-1E36 1E37
-1E38 1E39
-1E3A 1E3B
-1E3C 1E3D
-1E3E 1E3F
-1E40 1E41
-1E42 1E43
-1E44 1E45
-1E46 1E47
-1E48 1E49
-1E4A 1E4B
-1E4C 1E4D
-1E4E 1E4F
-1E50 1E51
-1E52 1E53
-1E54 1E55
-1E56 1E57
-1E58 1E59
-1E5A 1E5B
-1E5C 1E5D
-1E5E 1E5F
-1E60 1E61
-1E62 1E63
-1E64 1E65
-1E66 1E67
-1E68 1E69
-1E6A 1E6B
-1E6C 1E6D
-1E6E 1E6F
-1E70 1E71
-1E72 1E73
-1E74 1E75
-1E76 1E77
-1E78 1E79
-1E7A 1E7B
-1E7C 1E7D
-1E7E 1E7F
-1E80 1E81
-1E82 1E83
-1E84 1E85
-1E86 1E87
-1E88 1E89
-1E8A 1E8B
-1E8C 1E8D
-1E8E 1E8F
-1E90 1E91
-1E92 1E93
-1E94 1E95
-1EA0 1EA1
-1EA2 1EA3
-1EA4 1EA5
-1EA6 1EA7
-1EA8 1EA9
-1EAA 1EAB
-1EAC 1EAD
-1EAE 1EAF
-1EB0 1EB1
-1EB2 1EB3
-1EB4 1EB5
-1EB6 1EB7
-1EB8 1EB9
-1EBA 1EBB
-1EBC 1EBD
-1EBE 1EBF
-1EC0 1EC1
-1EC2 1EC3
-1EC4 1EC5
-1EC6 1EC7
-1EC8 1EC9
-1ECA 1ECB
-1ECC 1ECD
-1ECE 1ECF
-1ED0 1ED1
-1ED2 1ED3
-1ED4 1ED5
-1ED6 1ED7
-1ED8 1ED9
-1EDA 1EDB
-1EDC 1EDD
-1EDE 1EDF
-1EE0 1EE1
-1EE2 1EE3
-1EE4 1EE5
-1EE6 1EE7
-1EE8 1EE9
-1EEA 1EEB
-1EEC 1EED
-1EEE 1EEF
-1EF0 1EF1
-1EF2 1EF3
-1EF4 1EF5
-1EF6 1EF7
-1EF8 1EF9
-1F08 1F00
-1F09 1F01
-1F0A 1F02
-1F0B 1F03
-1F0C 1F04
-1F0D 1F05
-1F0E 1F06
-1F0F 1F07
-1F18 1F10
-1F19 1F11
-1F1A 1F12
-1F1B 1F13
-1F1C 1F14
-1F1D 1F15
-1F28 1F20
-1F29 1F21
-1F2A 1F22
-1F2B 1F23
-1F2C 1F24
-1F2D 1F25
-1F2E 1F26
-1F2F 1F27
-1F38 1F30
-1F39 1F31
-1F3A 1F32
-1F3B 1F33
-1F3C 1F34
-1F3D 1F35
-1F3E 1F36
-1F3F 1F37
-1F48 1F40
-1F49 1F41
-1F4A 1F42
-1F4B 1F43
-1F4C 1F44
-1F4D 1F45
-1F59 1F51
-1F5B 1F53
-1F5D 1F55
-1F5F 1F57
-1F68 1F60
-1F69 1F61
-1F6A 1F62
-1F6B 1F63
-1F6C 1F64
-1F6D 1F65
-1F6E 1F66
-1F6F 1F67
-1FB8 1FB0
-1FB9 1FB1
-1FBA 1F70
-1FBB 1F71
-1FC8 1F72
-1FC9 1F73
-1FCA 1F74
-1FCB 1F75
-1FD8 1FD0
-1FD9 1FD1
-1FDA 1F76
-1FDB 1F77
-1FE8 1FE0
-1FE9 1FE1
-1FEA 1F7A
-1FEB 1F7B
-1FEC 1FE5
-1FF8 1F78
-1FF9 1F79
-1FFA 1F7C
-1FFB 1F7D
-2126 03C9
-212A 006B
-212B 00E5
-2160 2170
-2161 2171
-2162 2172
-2163 2173
-2164 2174
-2165 2175
-2166 2176
-2167 2177
-2168 2178
-2169 2179
-216A 217A
-216B 217B
-216C 217C
-216D 217D
-216E 217E
-216F 217F
-24B6 24D0
-24B7 24D1
-24B8 24D2
-24B9 24D3
-24BA 24D4
-24BB 24D5
-24BC 24D6
-24BD 24D7
-24BE 24D8
-24BF 24D9
-24C0 24DA
-24C1 24DB
-24C2 24DC
-24C3 24DD
-24C4 24DE
-24C5 24DF
-24C6 24E0
-24C7 24E1
-24C8 24E2
-24C9 24E3
-24CA 24E4
-24CB 24E5
-24CC 24E6
-24CD 24E7
-24CE 24E8
-24CF 24E9
-2C00 2C30
-2C01 2C31
-2C02 2C32
-2C03 2C33
-2C04 2C34
-2C05 2C35
-2C06 2C36
-2C07 2C37
-2C08 2C38
-2C09 2C39
-2C0A 2C3A
-2C0B 2C3B
-2C0C 2C3C
-2C0D 2C3D
-2C0E 2C3E
-2C0F 2C3F
-2C10 2C40
-2C11 2C41
-2C12 2C42
-2C13 2C43
-2C14 2C44
-2C15 2C45
-2C16 2C46
-2C17 2C47
-2C18 2C48
-2C19 2C49
-2C1A 2C4A
-2C1B 2C4B
-2C1C 2C4C
-2C1D 2C4D
-2C1E 2C4E
-2C1F 2C4F
-2C20 2C50
-2C21 2C51
-2C22 2C52
-2C23 2C53
-2C24 2C54
-2C25 2C55
-2C26 2C56
-2C27 2C57
-2C28 2C58
-2C29 2C59
-2C2A 2C5A
-2C2B 2C5B
-2C2C 2C5C
-2C2D 2C5D
-2C2E 2C5E
-2C80 2C81
-2C82 2C83
-2C84 2C85
-2C86 2C87
-2C88 2C89
-2C8A 2C8B
-2C8C 2C8D
-2C8E 2C8F
-2C90 2C91
-2C92 2C93
-2C94 2C95
-2C96 2C97
-2C98 2C99
-2C9A 2C9B
-2C9C 2C9D
-2C9E 2C9F
-2CA0 2CA1
-2CA2 2CA3
-2CA4 2CA5
-2CA6 2CA7
-2CA8 2CA9
-2CAA 2CAB
-2CAC 2CAD
-2CAE 2CAF
-2CB0 2CB1
-2CB2 2CB3
-2CB4 2CB5
-2CB6 2CB7
-2CB8 2CB9
-2CBA 2CBB
-2CBC 2CBD
-2CBE 2CBF
-2CC0 2CC1
-2CC2 2CC3
-2CC4 2CC5
-2CC6 2CC7
-2CC8 2CC9
-2CCA 2CCB
-2CCC 2CCD
-2CCE 2CCF
-2CD0 2CD1
-2CD2 2CD3
-2CD4 2CD5
-2CD6 2CD7
-2CD8 2CD9
-2CDA 2CDB
-2CDC 2CDD
-2CDE 2CDF
-2CE0 2CE1
-2CE2 2CE3
-FF21 FF41
-FF22 FF42
-FF23 FF43
-FF24 FF44
-FF25 FF45
-FF26 FF46
-FF27 FF47
-FF28 FF48
-FF29 FF49
-FF2A FF4A
-FF2B FF4B
-FF2C FF4C
-FF2D FF4D
-FF2E FF4E
-FF2F FF4F
-FF30 FF50
-FF31 FF51
-FF32 FF52
-FF33 FF53
-FF34 FF54
-FF35 FF55
-FF36 FF56
-FF37 FF57
-FF38 FF58
-FF39 FF59
-FF3A FF5A
-10400 10428
-10401 10429
-10402 1042A
-10403 1042B
-10404 1042C
-10405 1042D
-10406 1042E
-10407 1042F
-10408 10430
-10409 10431
-1040A 10432
-1040B 10433
-1040C 10434
-1040D 10435
-1040E 10436
-1040F 10437
-10410 10438
-10411 10439
-10412 1043A
-10413 1043B
-10414 1043C
-10415 1043D
-10416 1043E
-10417 1043F
-10418 10440
-10419 10441
-1041A 10442
-1041B 10443
-1041C 10444
-1041D 10445
-1041E 10446
-1041F 10447
-10420 10448
-10421 10449
-10422 1044A
-10423 1044B
-10424 1044C
-10425 1044D
-10426 1044E
-10427 1044F
-END
diff --git a/Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl b/Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl
deleted file mode 100644
index 4778dc3ab52..00000000000
--- a/Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl
+++ /dev/null
@@ -1,490 +0,0 @@
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is built by mktables from e.g. UnicodeData.txt.
-# Any changes made here will be lost!
-
-#
-# This file supports:
-# \p{Uppercase} (and fuzzy permutations)
-#
-# Meaning: [\p{Lu}\p{Other_Uppercase}]
-#
-return <<'END';
-0041 005A
-00C0 00D6
-00D8 00DE
-0100
-0102
-0104
-0106
-0108
-010A
-010C
-010E
-0110
-0112
-0114
-0116
-0118
-011A
-011C
-011E
-0120
-0122
-0124
-0126
-0128
-012A
-012C
-012E
-0130
-0132
-0134
-0136
-0139
-013B
-013D
-013F
-0141
-0143
-0145
-0147
-014A
-014C
-014E
-0150
-0152
-0154
-0156
-0158
-015A
-015C
-015E
-0160
-0162
-0164
-0166
-0168
-016A
-016C
-016E
-0170
-0172
-0174
-0176
-0178 0179
-017B
-017D
-0181 0182
-0184
-0186 0187
-0189 018B
-018E 0191
-0193 0194
-0196 0198
-019C 019D
-019F 01A0
-01A2
-01A4
-01A6 01A7
-01A9
-01AC
-01AE 01AF
-01B1 01B3
-01B5
-01B7 01B8
-01BC
-01C4
-01C7
-01CA
-01CD
-01CF
-01D1
-01D3
-01D5
-01D7
-01D9
-01DB
-01DE
-01E0
-01E2
-01E4
-01E6
-01E8
-01EA
-01EC
-01EE
-01F1
-01F4
-01F6 01F8
-01FA
-01FC
-01FE
-0200
-0202
-0204
-0206
-0208
-020A
-020C
-020E
-0210
-0212
-0214
-0216
-0218
-021A
-021C
-021E
-0220
-0222
-0224
-0226
-0228
-022A
-022C
-022E
-0230
-0232
-023A 023B
-023D 023E
-0241
-0386
-0388 038A
-038C
-038E 038F
-0391 03A1
-03A3 03AB
-03D2 03D4
-03D8
-03DA
-03DC
-03DE
-03E0
-03E2
-03E4
-03E6
-03E8
-03EA
-03EC
-03EE
-03F4
-03F7
-03F9 03FA
-03FD 042F
-0460
-0462
-0464
-0466
-0468
-046A
-046C
-046E
-0470
-0472
-0474
-0476
-0478
-047A
-047C
-047E
-0480
-048A
-048C
-048E
-0490
-0492
-0494
-0496
-0498
-049A
-049C
-049E
-04A0
-04A2
-04A4
-04A6
-04A8
-04AA
-04AC
-04AE
-04B0
-04B2
-04B4
-04B6
-04B8
-04BA
-04BC
-04BE
-04C0 04C1
-04C3
-04C5
-04C7
-04C9
-04CB
-04CD
-04D0
-04D2
-04D4
-04D6
-04D8
-04DA
-04DC
-04DE
-04E0
-04E2
-04E4
-04E6
-04E8
-04EA
-04EC
-04EE
-04F0
-04F2
-04F4
-04F6
-04F8
-0500
-0502
-0504
-0506
-0508
-050A
-050C
-050E
-0531 0556
-10A0 10C5
-1E00
-1E02
-1E04
-1E06
-1E08
-1E0A
-1E0C
-1E0E
-1E10
-1E12
-1E14
-1E16
-1E18
-1E1A
-1E1C
-1E1E
-1E20
-1E22
-1E24
-1E26
-1E28
-1E2A
-1E2C
-1E2E
-1E30
-1E32
-1E34
-1E36
-1E38
-1E3A
-1E3C
-1E3E
-1E40
-1E42
-1E44
-1E46
-1E48
-1E4A
-1E4C
-1E4E
-1E50
-1E52
-1E54
-1E56
-1E58
-1E5A
-1E5C
-1E5E
-1E60
-1E62
-1E64
-1E66
-1E68
-1E6A
-1E6C
-1E6E
-1E70
-1E72
-1E74
-1E76
-1E78
-1E7A
-1E7C
-1E7E
-1E80
-1E82
-1E84
-1E86
-1E88
-1E8A
-1E8C
-1E8E
-1E90
-1E92
-1E94
-1EA0
-1EA2
-1EA4
-1EA6
-1EA8
-1EAA
-1EAC
-1EAE
-1EB0
-1EB2
-1EB4
-1EB6
-1EB8
-1EBA
-1EBC
-1EBE
-1EC0
-1EC2
-1EC4
-1EC6
-1EC8
-1ECA
-1ECC
-1ECE
-1ED0
-1ED2
-1ED4
-1ED6
-1ED8
-1EDA
-1EDC
-1EDE
-1EE0
-1EE2
-1EE4
-1EE6
-1EE8
-1EEA
-1EEC
-1EEE
-1EF0
-1EF2
-1EF4
-1EF6
-1EF8
-1F08 1F0F
-1F18 1F1D
-1F28 1F2F
-1F38 1F3F
-1F48 1F4D
-1F59
-1F5B
-1F5D
-1F5F
-1F68 1F6F
-1FB8 1FBB
-1FC8 1FCB
-1FD8 1FDB
-1FE8 1FEC
-1FF8 1FFB
-2102
-2107
-210B 210D
-2110 2112
-2115
-2119 211D
-2124
-2126
-2128
-212A 212D
-2130 2131
-2133
-213E 213F
-2145
-2160 216F
-24B6 24CF
-2C00 2C2E
-2C80
-2C82
-2C84
-2C86
-2C88
-2C8A
-2C8C
-2C8E
-2C90
-2C92
-2C94
-2C96
-2C98
-2C9A
-2C9C
-2C9E
-2CA0
-2CA2
-2CA4
-2CA6
-2CA8
-2CAA
-2CAC
-2CAE
-2CB0
-2CB2
-2CB4
-2CB6
-2CB8
-2CBA
-2CBC
-2CBE
-2CC0
-2CC2
-2CC4
-2CC6
-2CC8
-2CCA
-2CCC
-2CCE
-2CD0
-2CD2
-2CD4
-2CD6
-2CD8
-2CDA
-2CDC
-2CDE
-2CE0
-2CE2
-FF21 FF3A
-10400 10427
-1D400 1D419
-1D434 1D44D
-1D468 1D481
-1D49C
-1D49E 1D49F
-1D4A2
-1D4A5 1D4A6
-1D4A9 1D4AC
-1D4AE 1D4B5
-1D4D0 1D4E9
-1D504 1D505
-1D507 1D50A
-1D50D 1D514
-1D516 1D51C
-1D538 1D539
-1D53B 1D53E
-1D540 1D544
-1D546
-1D54A 1D550
-1D56C 1D585
-1D5A0 1D5B9
-1D5D4 1D5ED
-1D608 1D621
-1D63C 1D655
-1D670 1D689
-1D6A8 1D6C0
-1D6E2 1D6FA
-1D71C 1D734
-1D756 1D76E
-1D790 1D7A8
-END
diff --git a/Master/tlpkg/installer/perllib/utf8.pm b/Master/tlpkg/installer/perllib/utf8.pm
deleted file mode 100644
index 56c991bef9a..00000000000
--- a/Master/tlpkg/installer/perllib/utf8.pm
+++ /dev/null
@@ -1,214 +0,0 @@
-package utf8;
-
-$utf8::hint_bits = 0x00800000;
-
-our $VERSION = '1.06';
-
-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.
-
-This pragma is primarily a compatibility device. Perl versions
-earlier than 5.6 allowed arbitrary bytes in source code, whereas
-in future we would like to standardize on the UTF-8 encoding for
-source text.
-
-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
-useful for their own purposes, but they are not really part of the
-"pragmatic" effect.
-
-Until UTF-8 becomes the default format for source text, either this
-pragma or the L<encoding> pragma should be used to recognize UTF-8
-in the source. 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-8 character. 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-8. If you want to have such bytes and use utf8, you can disable
-utf8 until the end the block (or file, if at top level) by C<no utf8;>.
-
-If you want to automatically upgrade your 8-bit legacy bytes to UTF-8,
-use the L<encoding> pragma instead of this pragma. For example, if
-you want to implicitly upgrade your ISO 8859-1 (Latin-1) bytes to UTF-8
-as used in e.g. C<chr()> and C<\x{...}>, try this:
-
- use encoding "latin-1";
- my $c = chr(0xc4);
- my $x = "\x{c5}";
-
-In case you are wondering: yes, C<use encoding 'utf8';> works much
-the same as C<use 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 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 I<Encode.pm> is recommended for the general purposes.
-
-Affected by the encoding pragma.
-
-=item * $success = utf8::downgrade($string[, FAIL_OK])
-
-Converts in-place the character sequence in I<UTF-X>
-to the equivalent octet sequence in the native encoding (Latin-1 or EBCDIC).
-I<$string> already encoded as octets does no harm.
-Returns true on success. On failure dies or, if the value of
-C<FAIL_OK> is true, returns false.
-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.
-
-B<Note that this function does not handle arbitrary encodings.>
-Therefore I<Encode.pm> is recommended for the general purposes.
-
-B<Not> affected by the encoding pragma.
-
-B<NOTE:> this function is experimental and may change
-or be removed without notice.
-
-=item * utf8::encode($string)
-
-Converts in-place the character sequence to the corresponding octet sequence
-in I<UTF-X>. The UTF-8 flag is turned off. Returns nothing.
-
-B<Note that this function does not handle arbitrary encodings.>
-Therefore I<Encode.pm> is recommended for the general purposes.
-
-=item * 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 I<Encode.pm> is recommended for the general purposes.
-
-B<NOTE:> this function is experimental and may change
-or be removed without notice.
-
-=item * $flag = utf8::is_utf8(STRING)
-
-(Since Perl 5.8.1) Test whether STRING is in UTF-8. Functionally
-the same as Encode::is_utf8().
-
-=item * $flag = utf8::valid(STRING)
-
-[INTERNAL] Test whether STRING is in a consistent state regarding
-UTF-8. Will return true is well-formed UTF-8 and has the UTF-8 flag
-on B<or> if string is held as bytes (both these states are 'consistent').
-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>. Note that in the Perl 5.8.0 and 5.8.1 implementation
-the functions utf8::is_utf8, utf8::valid, utf8::encode, utf8::decode,
-utf8::upgrade, and utf8::downgrade are always available, without a
-C<require utf8> statement-- this may change in future releases.
-
-=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<perluniintro>, L<encoding>, L<perlrun>, L<bytes>, L<perlunicode>
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/utf8_heavy.pl b/Master/tlpkg/installer/perllib/utf8_heavy.pl
deleted file mode 100644
index b6fdeb997b3..00000000000
--- a/Master/tlpkg/installer/perllib/utf8_heavy.pl
+++ /dev/null
@@ -1,412 +0,0 @@
-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 utf8.c
- ##
- ## Given a $type, our goal is to fill $list with the set of codepoint
- ## ranges.
- ##
- ## 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 "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 "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 "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
- ## file to load.
- ##
- if ($Cache{$file} and ref($Cache{$file}) eq $class)
- {
- print "Returning cached '$file' for \\p{$type}\n" if DEBUG;
- return $Cache{$class, $file};
- }
-
- $list = do $file;
- }
-
- $ListSorted = 1; ## we know that these lists are sorted
- }
-
- my $extras;
- my $bits = 0;
-
- 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]+)/; [ 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 < 32) {
- my $top = 0;
- while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) {
- my $min = hex $1;
- my $max = defined $2 ? hex $2 : $min;
- my $val = defined $3 ? hex $3 : 0;
- $val += $max - $min if defined $3;
- $top = $val if $val > $top;
- }
- $bits =
- $top > 0xffff ? 32 :
- $top > 0xff ? 16 :
- $top > 1 ? 8 : 1
- }
- $bits = $minbits if $bits < $minbits;
-
- 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, "", 0, 0, 0);
- }
- elsif (exists &$name) {
- $subobj = utf8->SWASHNEW($name, "", 0, 0, 0);
- }
- elsif ($c =~ /^([0-9a-fA-F]+)/) {
- $subobj = utf8->SWASHNEW("", $c, 0, 0, 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;
-}
-
-# NOTE: utf8.c:swash_init() assumes entries are never modified once generated.
-
-sub SWASHGET {
- # See utf8.c:Perl_swash_fetch for problems with this interface.
- my ($self, $start, $len) = @_;
- local $^D = 0 if $^D;
- my $type = $self->{TYPE};
- my $bits = $self->{BITS};
- my $none = $self->{NONE};
- print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if DEBUG;
- my $end = $start + $len;
- my $swatch = "";
- my $key;
- vec($swatch, $len - 1, $bits) = 0; # Extend to correct length.
- if ($none) {
- for $key (0 .. $len - 1) { vec($swatch, $key, $bits) = $none }
- }
-
- for ($self->{LIST}) {
- pos $_ = 0;
- if ($bits > 1) {
- LINE:
- while (/^([0-9a-fA-F]+)(?:[ \t]([0-9a-fA-F]+)?)?(?:[ \t]([0-9a-fA-F]+))?/mg) {
- chomp;
- my ($a, $b, $c) = ($1, $2, $3);
- croak "$type: illegal mapping '$_'"
- if $type =~ /^To/ &&
- !(defined $a && defined $c);
- my $min = hex $a;
- my $max = defined $b ? hex $b : $min;
- my $val = defined $c ? hex $c : 0;
- next if $max < $start;
- print "$min $max $val\n" if DEBUG;
- if ($none) {
- if ($min < $start) {
- $val += $start - $min if $val < $none;
- $min = $start;
- }
- for ($key = $min; $key <= $max; $key++) {
- last LINE if $key >= $end;
- print STDERR "$key => $val\n" if DEBUG;
- vec($swatch, $key - $start, $bits) = $val;
- ++$val if $val < $none;
- }
- }
- else {
- if ($min < $start) {
- $val += $start - $min;
- $min = $start;
- }
- for ($key = $min; $key <= $max; $key++, $val++) {
- last LINE if $key >= $end;
- print STDERR "$key => $val\n" if DEBUG;
- vec($swatch, $key - $start, $bits) = $val;
- }
- }
- }
- }
- else {
- LINE:
- while (/^([0-9a-fA-F]+)(?:[ \t]+([0-9a-fA-F]+))?/mg) {
- chomp;
- my $min = hex $1;
- my $max = defined $2 ? hex $2 : $min;
- next if $max < $start;
- if ($min < $start) {
- $min = $start;
- }
- for ($key = $min; $key <= $max; $key++) {
- last LINE if $key >= $end;
- print STDERR "$key => 1\n" if DEBUG;
- vec($swatch, $key - $start, 1) = 1;
- }
- }
- }
- }
- for my $x ($self->{EXTRAS}) {
- pos $x = 0;
- while ($x =~ /^([-+!&])(.*)/mg) {
- my $char = $1;
- my $name = $2;
- print STDERR "INDIRECT $1 $2\n" if DEBUG;
- my $otherbits = $self->{$name}->{BITS};
- croak("SWASHGET size mismatch") if $bits < $otherbits;
- my $other = $self->{$name}->SWASHGET($start, $len);
- if ($char eq '+') {
- if ($bits == 1 and $otherbits == 1) {
- $swatch |= $other;
- }
- else {
- for ($key = 0; $key < $len; $key++) {
- vec($swatch, $key, $bits) = vec($other, $key, $otherbits);
- }
- }
- }
- elsif ($char eq '!') {
- if ($bits == 1 and $otherbits == 1) {
- $swatch |= ~$other;
- }
- else {
- for ($key = 0; $key < $len; $key++) {
- if (!vec($other, $key, $otherbits)) {
- vec($swatch, $key, $bits) = 1;
- }
- }
- }
- }
- elsif ($char eq '-') {
- if ($bits == 1 and $otherbits == 1) {
- $swatch &= ~$other;
- }
- else {
- for ($key = 0; $key < $len; $key++) {
- if (vec($other, $key, $otherbits)) {
- vec($swatch, $key, $bits) = 0;
- }
- }
- }
- }
- elsif ($char eq '&') {
- if ($bits == 1 and $otherbits == 1) {
- $swatch &= $other;
- }
- else {
- for ($key = 0; $key < $len; $key++) {
- if (!vec($other, $key, $otherbits)) {
- vec($swatch, $key, $bits) = 0;
- }
- }
- }
- }
- }
- }
- if (DEBUG) {
- print STDERR "CELLS ";
- for ($key = 0; $key < $len; $key++) {
- print STDERR vec($swatch, $key, $bits), " ";
- }
- print STDERR "\n";
- }
- $swatch;
-}
-
-1;
diff --git a/Master/tlpkg/installer/perllib/vars.pm b/Master/tlpkg/installer/perllib/vars.pm
deleted file mode 100644
index a0151b84030..00000000000
--- a/Master/tlpkg/installer/perllib/vars.pm
+++ /dev/null
@@ -1,82 +0,0 @@
-package vars;
-
-use 5.006;
-
-our $VERSION = '1.01';
-
-use warnings::register;
-use strict qw(vars subs);
-
-sub import {
- my $callpack = caller;
- my ($pack, @imports) = @_;
- my ($sym, $ch);
- foreach (@imports) {
- if (($ch, $sym) = /^([\$\@\%\*\&])(.+)/) {
- if ($sym =~ /\W/) {
- # time for a more-detailed check-up
- if ($sym =~ /^\w+[[{].*[]}]$/) {
- require Carp;
- Carp::croak("Can't declare individual elements of hash or array");
- } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
- warnings::warn("No need to declare built-in vars");
- } elsif (($^H &= strict::bits('vars'))) {
- require Carp;
- Carp::croak("'$_' is not a valid variable name under strict vars");
- }
- }
- $sym = "${callpack}::$sym" unless $sym =~ /::/;
- *$sym =
- ( $ch eq "\$" ? \$$sym
- : $ch eq "\@" ? \@$sym
- : $ch eq "\%" ? \%$sym
- : $ch eq "\*" ? \*$sym
- : $ch eq "\&" ? \&$sym
- : do {
- require Carp;
- Carp::croak("'$_' is not a valid variable name");
- });
- } else {
- require Carp;
- Carp::croak("'$_' is not a valid variable name");
- }
- }
-};
-
-1;
-__END__
-
-=head1 NAME
-
-vars - Perl pragma to predeclare global variable names (obsolete)
-
-=head1 SYNOPSIS
-
- use vars qw($frob @mung %seen);
-
-=head1 DESCRIPTION
-
-NOTE: For variables in the current package, the functionality provided
-by this pragma has been superseded by C<our> declarations, available
-in Perl v5.6.0 or later. See L<perlfunc/our>.
-
-This will predeclare all the variables whose names are
-in the list, allowing you to use them under "use strict", and
-disabling any typo warnings.
-
-Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
-C<use subs> declarations are not BLOCK-scoped. They are thus effective
-for the entire file in which they appear. You may not rescind such
-declarations with C<no vars> or C<no subs>.
-
-Packages such as the B<AutoLoader> and B<SelfLoader> that delay
-loading of subroutines within packages can create problems with
-package lexicals defined using C<my()>. While the B<vars> pragma
-cannot duplicate the effect of package lexicals (total transparency
-outside of the package), it can act as an acceptable substitute by
-pre-declaring global symbols, ensuring their availability to the
-later-loaded routines.
-
-See L<perlmodlib/Pragmatic Modules>.
-
-=cut
diff --git a/Master/tlpkg/installer/perllib/warnings.pm b/Master/tlpkg/installer/perllib/warnings.pm
deleted file mode 100644
index e43b686c908..00000000000
--- a/Master/tlpkg/installer/perllib/warnings.pm
+++ /dev/null
@@ -1,497 +0,0 @@
-# -*- buffer-read-only: t -*-
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file was created by warnings.pl
-# Any changes made here will be lost.
-#
-
-package warnings;
-
-our $VERSION = '1.05';
-
-=head1 NAME
-
-warnings - Perl pragma to control optional warnings
-
-=head1 SYNOPSIS
-
- use warnings;
- no warnings;
-
- use warnings "all";
- no warnings "all";
-
- use warnings::register;
- if (warnings::enabled()) {
- warnings::warn("some warning");
- }
-
- if (warnings::enabled("void")) {
- warnings::warn("void", "some warning");
- }
-
- if (warnings::enabled($object)) {
- warnings::warn($object, "some warning");
- }
-
- warnings::warnif("some warning");
- warnings::warnif("void", "some warning");
- warnings::warnif($object, "some warning");
-
-=head1 DESCRIPTION
-
-The C<warnings> pragma is a replacement for the command line flag C<-w>,
-but the pragma is limited to the enclosing block, while the flag is global.
-See L<perllexwarn> for more information.
-
-If no import list is supplied, all possible warnings are either enabled
-or disabled.
-
-A number of functions are provided to assist module authors.
-
-=over 4
-
-=item use warnings::register
-
-Creates a new warnings category with the same name as the package where
-the call to the pragma is used.
-
-=item warnings::enabled()
-
-Use the warnings category with the same name as the current package.
-
-Return TRUE if that warnings category is enabled in the calling module.
-Otherwise returns FALSE.
-
-=item warnings::enabled($category)
-
-Return TRUE if the warnings category, C<$category>, is enabled in the
-calling module.
-Otherwise returns FALSE.
-
-=item warnings::enabled($object)
-
-Use the name of the class for the object reference, C<$object>, as the
-warnings category.
-
-Return TRUE if that warnings category is enabled in the first scope
-where the object is used.
-Otherwise returns FALSE.
-
-=item warnings::warn($message)
-
-Print C<$message> to STDERR.
-
-Use the warnings category with the same name as the current package.
-
-If that warnings category has been set to "FATAL" in the calling module
-then die. Otherwise return.
-
-=item warnings::warn($category, $message)
-
-Print C<$message> to STDERR.
-
-If the warnings category, C<$category>, has been set to "FATAL" in the
-calling module then die. Otherwise return.
-
-=item warnings::warn($object, $message)
-
-Print C<$message> to STDERR.
-
-Use the name of the class for the object reference, C<$object>, as the
-warnings category.
-
-If that warnings category has been set to "FATAL" in the scope where C<$object>
-is first used then die. Otherwise return.
-
-
-=item warnings::warnif($message)
-
-Equivalent to:
-
- if (warnings::enabled())
- { warnings::warn($message) }
-
-=item warnings::warnif($category, $message)
-
-Equivalent to:
-
- if (warnings::enabled($category))
- { warnings::warn($category, $message) }
-
-=item warnings::warnif($object, $message)
-
-Equivalent to:
-
- if (warnings::enabled($object))
- { warnings::warn($object, $message) }
-
-=back
-
-See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
-
-=cut
-
-use Carp ();
-
-our %Offsets = (
-
- # Warnings Categories added in Perl 5.008
-
- 'all' => 0,
- 'closure' => 2,
- 'deprecated' => 4,
- 'exiting' => 6,
- 'glob' => 8,
- 'io' => 10,
- 'closed' => 12,
- 'exec' => 14,
- 'layer' => 16,
- 'newline' => 18,
- 'pipe' => 20,
- 'unopened' => 22,
- 'misc' => 24,
- 'numeric' => 26,
- 'once' => 28,
- 'overflow' => 30,
- 'pack' => 32,
- 'portable' => 34,
- 'recursion' => 36,
- 'redefine' => 38,
- 'regexp' => 40,
- 'severe' => 42,
- 'debugging' => 44,
- 'inplace' => 46,
- 'internal' => 48,
- 'malloc' => 50,
- 'signal' => 52,
- 'substr' => 54,
- 'syntax' => 56,
- 'ambiguous' => 58,
- 'bareword' => 60,
- 'digit' => 62,
- 'parenthesis' => 64,
- 'precedence' => 66,
- 'printf' => 68,
- 'prototype' => 70,
- 'qw' => 72,
- 'reserved' => 74,
- 'semicolon' => 76,
- 'taint' => 78,
- 'threads' => 80,
- 'uninitialized' => 82,
- 'unpack' => 84,
- 'untie' => 86,
- 'utf8' => 88,
- 'void' => 90,
- 'y2k' => 92,
- );
-
-our %Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
- 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
- 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
- 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
- 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
- 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
- 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
- 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
- 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
- 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
- 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
- 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
- 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
- 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
- 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
- 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
- );
-
-our %DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
- 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
- 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
- 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
- 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
- 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
- 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
- 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
- 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
- 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
- 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
- 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
- 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
- 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
- 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
- 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
- );
-
-$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
-$LAST_BIT = 94 ;
-$BYTES = 12 ;
-
-$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
-
-sub Croaker
-{
- local $Carp::CarpInternal{'warnings'};
- delete $Carp::CarpInternal{'warnings'};
- Carp::croak(@_);
-}
-
-sub bits
-{
- # called from B::Deparse.pm
-
- push @_, 'all' unless @_;
-
- my $mask;
- my $catmask ;
- my $fatal = 0 ;
- my $no_fatal = 0 ;
-
- foreach my $word ( @_ ) {
- if ($word eq 'FATAL') {
- $fatal = 1;
- $no_fatal = 0;
- }
- elsif ($word eq 'NONFATAL') {
- $fatal = 0;
- $no_fatal = 1;
- }
- elsif ($catmask = $Bits{$word}) {
- $mask |= $catmask ;
- $mask |= $DeadBits{$word} if $fatal ;
- $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
- }
- else
- { Croaker("Unknown warnings category '$word'")}
- }
-
- return $mask ;
-}
-
-sub import
-{
- shift;
-
- my $catmask ;
- my $fatal = 0 ;
- my $no_fatal = 0 ;
-
- my $mask = ${^WARNING_BITS} ;
-
- if (vec($mask, $Offsets{'all'}, 1)) {
- $mask |= $Bits{'all'} ;
- $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
- }
-
- push @_, 'all' unless @_;
-
- foreach my $word ( @_ ) {
- if ($word eq 'FATAL') {
- $fatal = 1;
- $no_fatal = 0;
- }
- elsif ($word eq 'NONFATAL') {
- $fatal = 0;
- $no_fatal = 1;
- }
- elsif ($catmask = $Bits{$word}) {
- $mask |= $catmask ;
- $mask |= $DeadBits{$word} if $fatal ;
- $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
- }
- else
- { Croaker("Unknown warnings category '$word'")}
- }
-
- ${^WARNING_BITS} = $mask ;
-}
-
-sub unimport
-{
- shift;
-
- my $catmask ;
- my $mask = ${^WARNING_BITS} ;
-
- if (vec($mask, $Offsets{'all'}, 1)) {
- $mask |= $Bits{'all'} ;
- $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
- }
-
- push @_, 'all' unless @_;
-
- foreach my $word ( @_ ) {
- if ($word eq 'FATAL') {
- next;
- }
- elsif ($catmask = $Bits{$word}) {
- $mask &= ~($catmask | $DeadBits{$word} | $All);
- }
- else
- { Croaker("Unknown warnings category '$word'")}
- }
-
- ${^WARNING_BITS} = $mask ;
-}
-
-my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
-
-sub __chk
-{
- my $category ;
- my $offset ;
- my $isobj = 0 ;
-
- if (@_) {
- # check the category supplied.
- $category = shift ;
- if (my $type = ref $category) {
- Croaker("not an object")
- if exists $builtin_type{$type};
- $category = $type;
- $isobj = 1 ;
- }
- $offset = $Offsets{$category};
- Croaker("Unknown warnings category '$category'")
- unless defined $offset;
- }
- else {
- $category = (caller(1))[0] ;
- $offset = $Offsets{$category};
- Croaker("package '$category' not registered for warnings")
- unless defined $offset ;
- }
-
- my $this_pkg = (caller(1))[0] ;
- my $i = 2 ;
- my $pkg ;
-
- if ($isobj) {
- while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
- last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
- }
- $i -= 2 ;
- }
- else {
- for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
- last if $pkg ne $this_pkg ;
- }
- $i = 2
- if !$pkg || $pkg eq $this_pkg ;
- }
-
- my $callers_bitmask = (caller($i))[9] ;
- return ($callers_bitmask, $offset, $i) ;
-}
-
-sub enabled
-{
- Croaker("Usage: warnings::enabled([category])")
- unless @_ == 1 || @_ == 0 ;
-
- my ($callers_bitmask, $offset, $i) = __chk(@_) ;
-
- return 0 unless defined $callers_bitmask ;
- return vec($callers_bitmask, $offset, 1) ||
- vec($callers_bitmask, $Offsets{'all'}, 1) ;
-}
-
-
-sub warn
-{
- Croaker("Usage: warnings::warn([category,] 'message')")
- unless @_ == 2 || @_ == 1 ;
-
- my $message = pop ;
- my ($callers_bitmask, $offset, $i) = __chk(@_) ;
- Carp::croak($message)
- if vec($callers_bitmask, $offset+1, 1) ||
- vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
- Carp::carp($message) ;
-}
-
-sub warnif
-{
- Croaker("Usage: warnings::warnif([category,] 'message')")
- unless @_ == 2 || @_ == 1 ;
-
- my $message = pop ;
- my ($callers_bitmask, $offset, $i) = __chk(@_) ;
-
- return
- unless defined $callers_bitmask &&
- (vec($callers_bitmask, $offset, 1) ||
- vec($callers_bitmask, $Offsets{'all'}, 1)) ;
-
- Carp::croak($message)
- if vec($callers_bitmask, $offset+1, 1) ||
- vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
-
- Carp::carp($message) ;
-}
-
-1;
-# ex: set ro:
diff --git a/Master/tlpkg/installer/perllib/warnings/register.pm b/Master/tlpkg/installer/perllib/warnings/register.pm
deleted file mode 100644
index 57c865df522..00000000000
--- a/Master/tlpkg/installer/perllib/warnings/register.pm
+++ /dev/null
@@ -1,51 +0,0 @@
-package warnings::register;
-
-our $VERSION = '1.01';
-
-=pod
-
-=head1 NAME
-
-warnings::register - warnings import function
-
-=head1 SYNOPSIS
-
- use warnings::register;
-
-=head1 DESCRIPTION
-
-Creates a warnings category with the same name as the current package.
-
-See L<warnings> and L<perllexwarn> for more information on this module's
-usage.
-
-=cut
-
-require warnings;
-
-sub mkMask
-{
- my ($bit) = @_;
- my $mask = "";
-
- vec($mask, $bit, 1) = 1;
- return $mask;
-}
-
-sub import
-{
- shift;
- my $package = (caller(0))[0];
- if (! defined $warnings::Bits{$package}) {
- $warnings::Bits{$package} = mkMask($warnings::LAST_BIT);
- vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1;
- $warnings::Offsets{$package} = $warnings::LAST_BIT ++;
- foreach my $k (keys %warnings::Bits) {
- vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0;
- }
- $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT);
- vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1;
- }
-}
-
-1;