From b645030efc22e13c2498a1522083634ab91b2de1 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Wed, 12 May 2010 16:51:27 +0000 Subject: move tlperl to tlperl.old git-svn-id: svn://tug.org/texlive/trunk@18209 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl.old/README.TEXLIVE | 21 + Master/tlpkg/tlperl.old/bin/perl.exe | Bin 0 -> 5632 bytes Master/tlpkg/tlperl.old/bin/perl.exe.manifest | 15 + Master/tlpkg/tlperl.old/bin/perl58.dll | Bin 0 -> 1098752 bytes Master/tlpkg/tlperl.old/lib/AnyDBM_File.pm | 93 + Master/tlpkg/tlperl.old/lib/AutoLoader.pm | 343 + Master/tlpkg/tlperl.old/lib/B.pm | 1111 + Master/tlpkg/tlperl.old/lib/B/Asmdata.pm | 250 + Master/tlpkg/tlperl.old/lib/B/Assembler.pm | 328 + Master/tlpkg/tlperl.old/lib/B/Bblock.pm | 224 + Master/tlpkg/tlperl.old/lib/B/Bytecode.pm | 889 + Master/tlpkg/tlperl.old/lib/B/C.pm | 2272 ++ Master/tlpkg/tlperl.old/lib/B/CC.pm | 2005 ++ Master/tlpkg/tlperl.old/lib/B/Concise.pm | 1628 ++ Master/tlpkg/tlperl.old/lib/B/Debug.pm | 305 + Master/tlpkg/tlperl.old/lib/B/Deparse.pm | 4642 ++++ Master/tlpkg/tlperl.old/lib/B/Disassembler.pm | 233 + Master/tlpkg/tlperl.old/lib/B/Lint.pm | 392 + Master/tlpkg/tlperl.old/lib/B/Showlex.pm | 205 + Master/tlpkg/tlperl.old/lib/B/Stackobj.pm | 349 + Master/tlpkg/tlperl.old/lib/B/Stash.pm | 52 + Master/tlpkg/tlperl.old/lib/B/Terse.pm | 103 + Master/tlpkg/tlperl.old/lib/B/Xref.pm | 430 + Master/tlpkg/tlperl.old/lib/B/assemble | 30 + Master/tlpkg/tlperl.old/lib/B/cc_harness | 12 + Master/tlpkg/tlperl.old/lib/B/disassemble | 22 + Master/tlpkg/tlperl.old/lib/B/makeliblinks | 54 + Master/tlpkg/tlperl.old/lib/Carp.pm | 274 + Master/tlpkg/tlperl.old/lib/Carp/Heavy.pm | 241 + Master/tlpkg/tlperl.old/lib/Class/ISA.pm | 214 + Master/tlpkg/tlperl.old/lib/Class/Struct.pm | 636 + Master/tlpkg/tlperl.old/lib/Config.pm | 95 + Master/tlpkg/tlperl.old/lib/Config_heavy.pl | 1185 + Master/tlpkg/tlperl.old/lib/Cwd.pm | 710 + Master/tlpkg/tlperl.old/lib/Data/Dumper.pm | 1264 + Master/tlpkg/tlperl.old/lib/Digest/MD5.pm | 376 + Master/tlpkg/tlperl.old/lib/Digest/base.pm | 100 + Master/tlpkg/tlperl.old/lib/Digest/file.pm | 85 + Master/tlpkg/tlperl.old/lib/DynaLoader.pm | 833 + Master/tlpkg/tlperl.old/lib/Encode.pm | 851 + Master/tlpkg/tlperl.old/lib/Encode/Alias.pm | 341 + Master/tlpkg/tlperl.old/lib/Encode/Byte.pm | 119 + Master/tlpkg/tlperl.old/lib/Encode/CJKConstants.pm | 66 + Master/tlpkg/tlperl.old/lib/Encode/CN.pm | 76 + Master/tlpkg/tlperl.old/lib/Encode/CN/HZ.pm | 196 + Master/tlpkg/tlperl.old/lib/Encode/Changes.e2x | 7 + Master/tlpkg/tlperl.old/lib/Encode/Config.pm | 166 + .../tlpkg/tlperl.old/lib/Encode/ConfigLocal_PM.e2x | 13 + Master/tlpkg/tlperl.old/lib/Encode/EBCDIC.pm | 43 + Master/tlpkg/tlperl.old/lib/Encode/Encoder.pm | 249 + Master/tlpkg/tlperl.old/lib/Encode/Encoding.pm | 341 + Master/tlpkg/tlperl.old/lib/Encode/Guess.pm | 351 + Master/tlpkg/tlperl.old/lib/Encode/JP.pm | 97 + Master/tlpkg/tlperl.old/lib/Encode/JP/H2Z.pm | 174 + Master/tlpkg/tlperl.old/lib/Encode/JP/JIS7.pm | 165 + Master/tlpkg/tlperl.old/lib/Encode/KR.pm | 72 + Master/tlpkg/tlperl.old/lib/Encode/KR/2022_KR.pm | 79 + Master/tlpkg/tlperl.old/lib/Encode/MIME/Header.pm | 230 + .../lib/Encode/MIME/Header/ISO_2022_JP.pm | 127 + Master/tlpkg/tlperl.old/lib/Encode/Makefile_PL.e2x | 180 + Master/tlpkg/tlperl.old/lib/Encode/PerlIO.pod | 167 + Master/tlpkg/tlperl.old/lib/Encode/README.e2x | 31 + Master/tlpkg/tlperl.old/lib/Encode/Supported.pod | 890 + Master/tlpkg/tlperl.old/lib/Encode/Symbol.pm | 42 + Master/tlpkg/tlperl.old/lib/Encode/TW.pm | 78 + Master/tlpkg/tlperl.old/lib/Encode/Unicode.pm | 268 + Master/tlpkg/tlperl.old/lib/Encode/Unicode/UTF7.pm | 118 + Master/tlpkg/tlperl.old/lib/Encode/_PM.e2x | 23 + Master/tlpkg/tlperl.old/lib/Encode/_T.e2x | 7 + Master/tlpkg/tlperl.old/lib/Encode/encode.h | 111 + Master/tlpkg/tlperl.old/lib/Errno.pm | 227 + Master/tlpkg/tlperl.old/lib/Exporter.pm | 440 + Master/tlpkg/tlperl.old/lib/Exporter/Heavy.pm | 248 + Master/tlpkg/tlperl.old/lib/Fcntl.pm | 236 + Master/tlpkg/tlperl.old/lib/File/Basename.pm | 398 + Master/tlpkg/tlperl.old/lib/File/CheckTree.pm | 229 + Master/tlpkg/tlperl.old/lib/File/Compare.pm | 178 + Master/tlpkg/tlperl.old/lib/File/Copy.pm | 459 + Master/tlpkg/tlperl.old/lib/File/DosGlob.pm | 571 + Master/tlpkg/tlperl.old/lib/File/Find.pm | 1275 + Master/tlpkg/tlperl.old/lib/File/Glob.pm | 496 + Master/tlpkg/tlperl.old/lib/File/Path.pm | 285 + Master/tlpkg/tlperl.old/lib/File/Spec.pm | 322 + Master/tlpkg/tlperl.old/lib/File/Spec/Cygwin.pm | 93 + Master/tlpkg/tlperl.old/lib/File/Spec/Epoc.pm | 77 + Master/tlpkg/tlperl.old/lib/File/Spec/Functions.pm | 109 + Master/tlpkg/tlperl.old/lib/File/Spec/Mac.pm | 780 + Master/tlpkg/tlperl.old/lib/File/Spec/OS2.pm | 272 + Master/tlpkg/tlperl.old/lib/File/Spec/Unix.pm | 510 + Master/tlpkg/tlperl.old/lib/File/Spec/VMS.pm | 521 + Master/tlpkg/tlperl.old/lib/File/Spec/Win32.pm | 369 + Master/tlpkg/tlperl.old/lib/File/Temp.pm | 2244 ++ Master/tlpkg/tlperl.old/lib/File/stat.pm | 139 + Master/tlpkg/tlperl.old/lib/FileHandle.pm | 262 + Master/tlpkg/tlperl.old/lib/Getopt/Long.pm | 2504 ++ Master/tlpkg/tlperl.old/lib/Getopt/Std.pm | 294 + Master/tlpkg/tlperl.old/lib/IO.pm | 68 + Master/tlpkg/tlperl.old/lib/IO/Dir.pm | 246 + Master/tlpkg/tlperl.old/lib/IO/File.pm | 208 + Master/tlpkg/tlperl.old/lib/IO/Handle.pm | 625 + Master/tlpkg/tlperl.old/lib/IO/Pipe.pm | 257 + Master/tlpkg/tlperl.old/lib/IO/Poll.pm | 209 + Master/tlpkg/tlperl.old/lib/IO/Seekable.pm | 128 + Master/tlpkg/tlperl.old/lib/IO/Select.pm | 381 + Master/tlpkg/tlperl.old/lib/IO/Socket.pm | 476 + Master/tlpkg/tlperl.old/lib/IO/Socket/INET.pm | 431 + Master/tlpkg/tlperl.old/lib/IO/Socket/UNIX.pm | 144 + Master/tlpkg/tlperl.old/lib/IO/String.pm | 551 + Master/tlpkg/tlperl.old/lib/List/Util.pm | 277 + Master/tlpkg/tlperl.old/lib/Opcode.pm | 578 + Master/tlpkg/tlperl.old/lib/POSIX.pm | 965 + Master/tlpkg/tlperl.old/lib/Pod/Checker.pm | 1270 + Master/tlpkg/tlperl.old/lib/Pod/Find.pm | 523 + Master/tlpkg/tlperl.old/lib/Pod/Functions.pm | 376 + Master/tlpkg/tlperl.old/lib/Pod/Html.pm | 2123 ++ Master/tlpkg/tlperl.old/lib/Pod/InputObjects.pm | 941 + Master/tlpkg/tlperl.old/lib/Pod/LaTeX.pm | 1876 ++ Master/tlpkg/tlperl.old/lib/Pod/Man.pm | 1413 + Master/tlpkg/tlperl.old/lib/Pod/ParseLink.pm | 184 + Master/tlpkg/tlperl.old/lib/Pod/ParseUtils.pm | 852 + Master/tlpkg/tlperl.old/lib/Pod/Parser.pm | 1799 ++ Master/tlpkg/tlperl.old/lib/Pod/Perldoc.pm | 1762 ++ Master/tlpkg/tlperl.old/lib/Pod/Perldoc/BaseTo.pm | 28 + .../tlpkg/tlperl.old/lib/Pod/Perldoc/GetOptsOO.pm | 106 + .../tlpkg/tlperl.old/lib/Pod/Perldoc/ToChecker.pm | 72 + Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToMan.pm | 187 + Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToNroff.pm | 100 + Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToPod.pm | 90 + Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToRtf.pm | 85 + Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToText.pm | 91 + Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToTk.pm | 129 + Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToXml.pm | 63 + Master/tlpkg/tlperl.old/lib/Pod/PlainText.pm | 705 + Master/tlpkg/tlperl.old/lib/Pod/Plainer.pm | 69 + Master/tlpkg/tlperl.old/lib/Pod/Select.pm | 754 + Master/tlpkg/tlperl.old/lib/Pod/Text.pm | 848 + Master/tlpkg/tlperl.old/lib/Pod/Text/Color.pm | 145 + Master/tlpkg/tlperl.old/lib/Pod/Text/Overstrike.pm | 208 + Master/tlpkg/tlperl.old/lib/Pod/Text/Termcap.pm | 180 + Master/tlpkg/tlperl.old/lib/Pod/Usage.pm | 659 + Master/tlpkg/tlperl.old/lib/Safe.pm | 576 + Master/tlpkg/tlperl.old/lib/Scalar/Util.pm | 147 + Master/tlpkg/tlperl.old/lib/SelectSaver.pm | 54 + Master/tlpkg/tlperl.old/lib/Symbol.pm | 170 + Master/tlpkg/tlperl.old/lib/Term/ANSIColor.pm | 472 + Master/tlpkg/tlperl.old/lib/Term/Cap.pm | 669 + Master/tlpkg/tlperl.old/lib/Term/Complete.pm | 188 + Master/tlpkg/tlperl.old/lib/Term/ReadLine.pm | 399 + Master/tlpkg/tlperl.old/lib/Text/Abbrev.pm | 84 + Master/tlpkg/tlperl.old/lib/Text/Balanced.pm | 2302 ++ Master/tlpkg/tlperl.old/lib/Text/ParseWords.pm | 263 + Master/tlpkg/tlperl.old/lib/Text/Soundex.pm | 150 + Master/tlpkg/tlperl.old/lib/Text/Tabs.pm | 121 + Master/tlpkg/tlperl.old/lib/Text/Wrap.pm | 223 + Master/tlpkg/tlperl.old/lib/Tie/Array.pm | 287 + Master/tlpkg/tlperl.old/lib/Tie/File.pm | 2632 ++ Master/tlpkg/tlperl.old/lib/Tie/Handle.pm | 234 + Master/tlpkg/tlperl.old/lib/Tie/Hash.pm | 257 + Master/tlpkg/tlperl.old/lib/Tie/Memoize.pm | 128 + Master/tlpkg/tlperl.old/lib/Tie/RefHash.pm | 170 + Master/tlpkg/tlperl.old/lib/Tie/Scalar.pm | 140 + Master/tlpkg/tlperl.old/lib/Tie/SubstrHash.pm | 215 + Master/tlpkg/tlperl.old/lib/Tie/Watch.pm | 560 + Master/tlpkg/tlperl.old/lib/Time/HiRes.pm | 500 + Master/tlpkg/tlperl.old/lib/Time/Local.pm | 366 + Master/tlpkg/tlperl.old/lib/Time/gmtime.pm | 90 + Master/tlpkg/tlperl.old/lib/Time/localtime.pm | 86 + Master/tlpkg/tlperl.old/lib/Time/tm.pm | 33 + Master/tlpkg/tlperl.old/lib/Tk.pm | 821 + Master/tlpkg/tlperl.old/lib/Tk/Adjuster.pm | 436 + Master/tlpkg/tlperl.old/lib/Tk/After.pm | 104 + Master/tlpkg/tlperl.old/lib/Tk/Animation.pm | 178 + Master/tlpkg/tlperl.old/lib/Tk/Balloon.pm | 621 + Master/tlpkg/tlperl.old/lib/Tk/Bitmap.pm | 10 + Master/tlpkg/tlperl.old/lib/Tk/BrowseEntry.pm | 510 + Master/tlpkg/tlperl.old/lib/Tk/Button.pm | 148 + Master/tlpkg/tlperl.old/lib/Tk/Camel.xpm | 41 + Master/tlpkg/tlperl.old/lib/Tk/Canvas.pm | 1436 + Master/tlpkg/tlperl.old/lib/Tk/Checkbutton.pm | 42 + Master/tlpkg/tlperl.old/lib/Tk/Clipboard.pm | 122 + Master/tlpkg/tlperl.old/lib/Tk/CmdLine.pm | 954 + Master/tlpkg/tlperl.old/lib/Tk/ColorEdit.xpm | 58 + Master/tlpkg/tlperl.old/lib/Tk/ColorEditor.pm | 761 + Master/tlpkg/tlperl.old/lib/Tk/Compound.pm | 40 + Master/tlpkg/tlperl.old/lib/Tk/Config.pm | 12 + Master/tlpkg/tlperl.old/lib/Tk/Configure.pm | 69 + Master/tlpkg/tlperl.old/lib/Tk/Credits | 7 + Master/tlpkg/tlperl.old/lib/Tk/Derived.pm | 512 + Master/tlpkg/tlperl.old/lib/Tk/Dialog.pm | 70 + Master/tlpkg/tlperl.old/lib/Tk/DialogBox.pm | 135 + Master/tlpkg/tlperl.old/lib/Tk/DirTree.pm | 252 + Master/tlpkg/tlperl.old/lib/Tk/Dirlist.pm | 113 + Master/tlpkg/tlperl.old/lib/Tk/DragDrop.pm | 332 + Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Common.pm | 59 + .../tlpkg/tlperl.old/lib/Tk/DragDrop/LocalDrop.pm | 61 + Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Rect.pm | 110 + .../tlpkg/tlperl.old/lib/Tk/DragDrop/SunConst.pm | 34 + Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunDrop.pm | 200 + Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunSite.pm | 107 + .../tlpkg/tlperl.old/lib/Tk/DragDrop/Win32Drop.pm | 8 + .../tlpkg/tlperl.old/lib/Tk/DragDrop/Win32Site.pm | 50 + .../tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDDrop.pm | 145 + .../tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDSite.pm | 159 + Master/tlpkg/tlperl.old/lib/Tk/DropSite.pm | 257 + Master/tlpkg/tlperl.old/lib/Tk/DummyEncode.pm | 46 + Master/tlpkg/tlperl.old/lib/Tk/English.pm | 307 + Master/tlpkg/tlperl.old/lib/Tk/Entry.pm | 615 + Master/tlpkg/tlperl.old/lib/Tk/ErrorDialog.pm | 125 + Master/tlpkg/tlperl.old/lib/Tk/Event.pm | 13 + Master/tlpkg/tlperl.old/lib/Tk/Event/IO.pm | 132 + Master/tlpkg/tlperl.old/lib/Tk/FBox.pm | 1043 + Master/tlpkg/tlperl.old/lib/Tk/FileSelect.pm | 578 + Master/tlpkg/tlperl.old/lib/Tk/FloatEntry.pm | 109 + Master/tlpkg/tlperl.old/lib/Tk/Font.pm | 163 + Master/tlpkg/tlperl.old/lib/Tk/Frame.pm | 378 + Master/tlpkg/tlperl.old/lib/Tk/HList.pm | 680 + Master/tlpkg/tlperl.old/lib/Tk/IO.pm | 182 + Master/tlpkg/tlperl.old/lib/Tk/IconList.pm | 712 + Master/tlpkg/tlperl.old/lib/Tk/Image.pm | 74 + Master/tlpkg/tlperl.old/lib/Tk/ItemStyle.pm | 38 + Master/tlpkg/tlperl.old/lib/Tk/JPEG.pm | 50 + Master/tlpkg/tlperl.old/lib/Tk/LabEntry.pm | 31 + Master/tlpkg/tlperl.old/lib/Tk/LabFrame.pm | 138 + Master/tlpkg/tlperl.old/lib/Tk/LabRadio.pm | 63 + Master/tlpkg/tlperl.old/lib/Tk/Label.pm | 21 + Master/tlpkg/tlperl.old/lib/Tk/Labelframe.pm | 16 + Master/tlpkg/tlperl.old/lib/Tk/Listbox.pm | 910 + Master/tlpkg/tlperl.old/lib/Tk/MMtry.pm | 54 + Master/tlpkg/tlperl.old/lib/Tk/MMutil.pm | 600 + Master/tlpkg/tlperl.old/lib/Tk/MainWindow.pm | 213 + Master/tlpkg/tlperl.old/lib/Tk/MakeDepend.pm | 292 + Master/tlpkg/tlperl.old/lib/Tk/Menu.pm | 1145 + Master/tlpkg/tlperl.old/lib/Tk/Menu/Item.pm | 180 + Master/tlpkg/tlperl.old/lib/Tk/Menubar.pm | 15 + Master/tlpkg/tlperl.old/lib/Tk/Menubutton.pm | 398 + Master/tlpkg/tlperl.old/lib/Tk/Message.pm | 20 + Master/tlpkg/tlperl.old/lib/Tk/NBFrame.pm | 20 + Master/tlpkg/tlperl.old/lib/Tk/NoteBook.pm | 452 + Master/tlpkg/tlperl.old/lib/Tk/Optionmenu.pm | 130 + Master/tlpkg/tlperl.old/lib/Tk/PNG.pm | 43 + Master/tlpkg/tlperl.old/lib/Tk/Pane.pm | 544 + Master/tlpkg/tlperl.old/lib/Tk/Panedwindow.pm | 221 + Master/tlpkg/tlperl.old/lib/Tk/Photo.pm | 22 + Master/tlpkg/tlperl.old/lib/Tk/Pixmap.pm | 19 + Master/tlpkg/tlperl.old/lib/Tk/Pretty.pm | 93 + Master/tlpkg/tlperl.old/lib/Tk/ProgressBar.pm | 498 + Master/tlpkg/tlperl.old/lib/Tk/README.Adjust | 77 + Master/tlpkg/tlperl.old/lib/Tk/ROText.pm | 43 + Master/tlpkg/tlperl.old/lib/Tk/Radiobutton.pm | 45 + Master/tlpkg/tlperl.old/lib/Tk/Region.pm | 182 + Master/tlpkg/tlperl.old/lib/Tk/Reindex.pm | 225 + Master/tlpkg/tlperl.old/lib/Tk/ReindexedROText.pm | 13 + Master/tlpkg/tlperl.old/lib/Tk/ReindexedText.pm | 13 + Master/tlpkg/tlperl.old/lib/Tk/Scale.pm | 278 + Master/tlpkg/tlperl.old/lib/Tk/Scrollbar.pm | 429 + Master/tlpkg/tlperl.old/lib/Tk/Spinbox.pm | 115 + Master/tlpkg/tlperl.old/lib/Tk/Stats.pm | 26 + Master/tlpkg/tlperl.old/lib/Tk/Submethods.pm | 46 + Master/tlpkg/tlperl.old/lib/Tk/TList.pm | 416 + Master/tlpkg/tlperl.old/lib/Tk/Table.pm | 598 + Master/tlpkg/tlperl.old/lib/Tk/Text.pm | 1653 ++ Master/tlpkg/tlperl.old/lib/Tk/Text/Tag.pm | 46 + Master/tlpkg/tlperl.old/lib/Tk/TextEdit.pm | 509 + Master/tlpkg/tlperl.old/lib/Tk/TextList.pm | 985 + Master/tlpkg/tlperl.old/lib/Tk/TextUndo.pm | 1022 + Master/tlpkg/tlperl.old/lib/Tk/Tiler.pm | 203 + Master/tlpkg/tlperl.old/lib/Tk/TixGrid.pm | 1597 ++ Master/tlpkg/tlperl.old/lib/Tk/Tk.xbm | 44 + Master/tlpkg/tlperl.old/lib/Tk/Tk.xpm | 41 + Master/tlpkg/tlperl.old/lib/Tk/TkXSUB.def | 62 + Master/tlpkg/tlperl.old/lib/Tk/Toplevel.pm | 211 + Master/tlpkg/tlperl.old/lib/Tk/Trace.pm | 405 + Master/tlpkg/tlperl.old/lib/Tk/Tree.pm | 228 + Master/tlpkg/tlperl.old/lib/Tk/Widget.pm | 1510 ++ Master/tlpkg/tlperl.old/lib/Tk/Wm.pm | 174 + Master/tlpkg/tlperl.old/lib/Tk/X.pm | 398 + Master/tlpkg/tlperl.old/lib/Tk/X11/X.h | 677 + Master/tlpkg/tlperl.old/lib/Tk/X11/Xatom.h | 79 + Master/tlpkg/tlperl.old/lib/Tk/X11/Xfuncproto.h | 60 + Master/tlpkg/tlperl.old/lib/Tk/X11/Xlib.h | 1214 + Master/tlpkg/tlperl.old/lib/Tk/X11/Xutil.h | 855 + Master/tlpkg/tlperl.old/lib/Tk/X11/cursorfont.h | 79 + Master/tlpkg/tlperl.old/lib/Tk/X11/keysym.h | 39 + Master/tlpkg/tlperl.old/lib/Tk/X11/keysymdef.h | 1169 + Master/tlpkg/tlperl.old/lib/Tk/X11/license.terms | 39 + Master/tlpkg/tlperl.old/lib/Tk/X11Font.pm | 184 + Master/tlpkg/tlperl.old/lib/Tk/Xcamel.gif | Bin 0 -> 4193 bytes Master/tlpkg/tlperl.old/lib/Tk/Xlib.pm | 15 + Master/tlpkg/tlperl.old/lib/Tk/Xrm.pm | 11 + Master/tlpkg/tlperl.old/lib/Tk/act_folder.xbm | 5 + Master/tlpkg/tlperl.old/lib/Tk/act_folder.xpm | 22 + Master/tlpkg/tlperl.old/lib/Tk/anim.gif | Bin 0 -> 2533 bytes Master/tlpkg/tlperl.old/lib/Tk/arrowdownwin.xbm | 5 + Master/tlpkg/tlperl.old/lib/Tk/balArrow.xbm | 4 + Master/tlpkg/tlperl.old/lib/Tk/cbxarrow.xbm | 6 + Master/tlpkg/tlperl.old/lib/Tk/file.xbm | 5 + Master/tlpkg/tlperl.old/lib/Tk/file.xpm | 18 + Master/tlpkg/tlperl.old/lib/Tk/folder.xbm | 5 + Master/tlpkg/tlperl.old/lib/Tk/folder.xpm | 21 + Master/tlpkg/tlperl.old/lib/Tk/icon.gif | Bin 0 -> 1924 bytes Master/tlpkg/tlperl.old/lib/Tk/install.pm | 37 + Master/tlpkg/tlperl.old/lib/Tk/license.terms | 35 + Master/tlpkg/tlperl.old/lib/Tk/openfile.xbm | 5 + Master/tlpkg/tlperl.old/lib/Tk/openfolder.xbm | 5 + Master/tlpkg/tlperl.old/lib/Tk/openfolder.xpm | 21 + Master/tlpkg/tlperl.old/lib/Tk/prolog.ps | 284 + Master/tlpkg/tlperl.old/lib/Tk/reindex.pl | 33 + Master/tlpkg/tlperl.old/lib/Tk/srcfile.xpm | 18 + Master/tlpkg/tlperl.old/lib/Tk/textfile.xpm | 18 + Master/tlpkg/tlperl.old/lib/Tk/tkGlue.def | 130 + Master/tlpkg/tlperl.old/lib/Tk/tkGlue.h | 79 + Master/tlpkg/tlperl.old/lib/Tk/tkGlue.m | 74 + Master/tlpkg/tlperl.old/lib/Tk/tkGlue.t | 70 + Master/tlpkg/tlperl.old/lib/Tk/tkGlue_f.h | 14 + Master/tlpkg/tlperl.old/lib/Tk/tranicon.gif | Bin 0 -> 1718 bytes Master/tlpkg/tlperl.old/lib/Tk/typemap | 96 + Master/tlpkg/tlperl.old/lib/Tk/vtab.def | 90 + Master/tlpkg/tlperl.old/lib/Tk/widgets.pm | 21 + Master/tlpkg/tlperl.old/lib/Tk/win.xbm | 6 + Master/tlpkg/tlperl.old/lib/Tk/winfolder.xpm | 39 + Master/tlpkg/tlperl.old/lib/Tk/wintext.xpm | 42 + Master/tlpkg/tlperl.old/lib/UNIVERSAL.pm | 147 + Master/tlpkg/tlperl.old/lib/Win32.pm | 712 + Master/tlpkg/tlperl.old/lib/Win32/API.pm | 745 + Master/tlpkg/tlperl.old/lib/Win32/API.pm.orig | 741 + Master/tlpkg/tlperl.old/lib/Win32/API/Callback.pm | 174 + Master/tlpkg/tlperl.old/lib/Win32/API/Struct.pm | 532 + Master/tlpkg/tlperl.old/lib/Win32/API/Test.pm | 120 + Master/tlpkg/tlperl.old/lib/Win32/API/Type.pm | 446 + Master/tlpkg/tlperl.old/lib/Win32/ChangeNotify.pm | 198 + Master/tlpkg/tlperl.old/lib/Win32/Client.pl | 63 + Master/tlpkg/tlperl.old/lib/Win32/Clipboard.pm | 369 + Master/tlpkg/tlperl.old/lib/Win32/Console.pm | 1463 + Master/tlpkg/tlperl.old/lib/Win32/Event.pm | 104 + Master/tlpkg/tlperl.old/lib/Win32/EventLog.pm | 471 + Master/tlpkg/tlperl.old/lib/Win32/File.pm | 118 + Master/tlpkg/tlperl.old/lib/Win32/FileSecurity.pm | 308 + Master/tlpkg/tlperl.old/lib/Win32/IPC.pm | 195 + Master/tlpkg/tlperl.old/lib/Win32/Internet.pm | 3009 +++ Master/tlpkg/tlperl.old/lib/Win32/Job.pm | 370 + Master/tlpkg/tlperl.old/lib/Win32/Mutex.pm | 125 + Master/tlpkg/tlperl.old/lib/Win32/NetAdmin.pm | 419 + Master/tlpkg/tlperl.old/lib/Win32/NetResource.pm | 456 + Master/tlpkg/tlperl.old/lib/Win32/ODBC.pm | 1493 + Master/tlpkg/tlperl.old/lib/Win32/PerfLib.pm | 538 + Master/tlpkg/tlperl.old/lib/Win32/Pipe.pm | 414 + Master/tlpkg/tlperl.old/lib/Win32/Process.pm | 217 + Master/tlpkg/tlperl.old/lib/Win32/Registry.pm | 547 + Master/tlpkg/tlperl.old/lib/Win32/Semaphore.pm | 128 + Master/tlpkg/tlperl.old/lib/Win32/Server.pl | 48 + Master/tlpkg/tlperl.old/lib/Win32/Service.pm | 103 + Master/tlpkg/tlperl.old/lib/Win32/Shortcut.pm | 323 + Master/tlpkg/tlperl.old/lib/Win32/Sound.pm | 582 + Master/tlpkg/tlperl.old/lib/Win32/Test.pl | 477 + Master/tlpkg/tlperl.old/lib/Win32/TieRegistry.pm | 3801 +++ Master/tlpkg/tlperl.old/lib/Win32/WinError.pm | 1017 + Master/tlpkg/tlperl.old/lib/Win32/test-async.pl | 129 + Master/tlpkg/tlperl.old/lib/Win32API/Registry.pm | 1792 ++ .../tlperl.old/lib/Win32API/Registry/cRegistry.pc | 87 + Master/tlpkg/tlperl.old/lib/XSLoader.pm | 356 + Master/tlpkg/tlperl.old/lib/attributes.pm | 418 + Master/tlpkg/tlperl.old/lib/auto/B/B.bs | 0 Master/tlpkg/tlperl.old/lib/auto/B/B.dll | Bin 0 -> 113152 bytes Master/tlpkg/tlperl.old/lib/auto/B/C/C.bs | 0 Master/tlpkg/tlperl.old/lib/auto/B/C/C.dll | Bin 0 -> 8192 bytes Master/tlpkg/tlperl.old/lib/auto/Cwd/Cwd.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Cwd/Cwd.dll | Bin 0 -> 10240 bytes .../tlperl.old/lib/auto/Data/Dumper/Dumper.bs | 0 .../tlperl.old/lib/auto/Data/Dumper/Dumper.dll | Bin 0 -> 30720 bytes Master/tlpkg/tlperl.old/lib/auto/Digest/MD5/MD5.bs | 0 .../tlpkg/tlperl.old/lib/auto/Digest/MD5/MD5.dll | Bin 0 -> 15872 bytes .../tlperl.old/lib/auto/DynaLoader/autosplit.ix | 8 + .../lib/auto/DynaLoader/dl_expandspec.al | 34 + .../lib/auto/DynaLoader/dl_find_symbol_anywhere.al | 19 + .../tlperl.old/lib/auto/DynaLoader/dl_findfile.al | 115 + .../tlpkg/tlperl.old/lib/auto/Encode/Byte/Byte.bs | 0 .../tlpkg/tlperl.old/lib/auto/Encode/Byte/Byte.dll | Bin 0 -> 112640 bytes Master/tlpkg/tlperl.old/lib/auto/Encode/Encode.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Encode/Encode.dll | Bin 0 -> 30208 bytes .../tlperl.old/lib/auto/Encode/Symbol/Symbol.bs | 0 .../tlperl.old/lib/auto/Encode/Symbol/Symbol.dll | Bin 0 -> 20992 bytes .../tlperl.old/lib/auto/Encode/Unicode/Unicode.bs | 0 .../tlperl.old/lib/auto/Encode/Unicode/Unicode.dll | Bin 0 -> 17920 bytes Master/tlpkg/tlperl.old/lib/auto/Fcntl/Fcntl.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Fcntl/Fcntl.dll | Bin 0 -> 14848 bytes Master/tlpkg/tlperl.old/lib/auto/File/Glob/Glob.bs | 0 .../tlpkg/tlperl.old/lib/auto/File/Glob/Glob.dll | Bin 0 -> 16384 bytes Master/tlpkg/tlperl.old/lib/auto/IO/IO.bs | 0 Master/tlpkg/tlperl.old/lib/auto/IO/IO.dll | Bin 0 -> 16896 bytes Master/tlpkg/tlperl.old/lib/auto/List/Util/Util.bs | 0 .../tlpkg/tlperl.old/lib/auto/List/Util/Util.dll | Bin 0 -> 26624 bytes Master/tlpkg/tlperl.old/lib/auto/Opcode/Opcode.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Opcode/Opcode.dll | Bin 0 -> 21504 bytes Master/tlpkg/tlperl.old/lib/auto/POSIX/POSIX.bs | 0 Master/tlpkg/tlperl.old/lib/auto/POSIX/POSIX.dll | Bin 0 -> 97792 bytes .../tlperl.old/lib/auto/POSIX/SigAction/flags.al | 9 + .../tlperl.old/lib/auto/POSIX/SigAction/handler.al | 11 + .../tlperl.old/lib/auto/POSIX/SigAction/mask.al | 9 + .../tlperl.old/lib/auto/POSIX/SigAction/safe.al | 9 + Master/tlpkg/tlperl.old/lib/auto/POSIX/abs.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/alarm.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/assert.al | 15 + Master/tlpkg/tlperl.old/lib/auto/POSIX/atan2.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/atexit.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/atof.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/atoi.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/atol.al | 12 + .../tlpkg/tlperl.old/lib/auto/POSIX/autosplit.ix | 159 + Master/tlpkg/tlperl.old/lib/auto/POSIX/bsearch.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/calloc.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/chdir.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/chmod.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/chown.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/clearerr.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/closedir.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/cos.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/creat.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/div.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/errno.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/execl.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/execle.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/execlp.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/execv.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/execve.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/execvp.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/exit.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/exp.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fabs.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fclose.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fcntl.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fdopen.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/feof.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/ferror.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fflush.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fgetc.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fgetpos.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fgets.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fileno.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fopen.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fork.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fprintf.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fputc.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fputs.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fread.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/free.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/freopen.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fscanf.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fseek.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fsetpos.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fstat.al | 17 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fsync.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/ftell.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/fwrite.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getc.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getchar.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getegid.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getenv.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/geteuid.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getgid.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getgrgid.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getgrnam.al | 13 + .../tlpkg/tlperl.old/lib/auto/POSIX/getgroups.al | 14 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getlogin.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getpgrp.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getpid.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getppid.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getpwnam.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getpwuid.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/gets.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/getuid.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/gmtime.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/isatty.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/kill.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/labs.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/ldiv.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/link.al | 13 + .../tlperl.old/lib/auto/POSIX/load_imports.al | 225 + .../tlpkg/tlperl.old/lib/auto/POSIX/localtime.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/log.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/longjmp.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/malloc.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/memchr.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/memcmp.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/memcpy.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/memmove.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/memset.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/mkdir.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/offsetof.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/opendir.al | 16 + Master/tlpkg/tlperl.old/lib/auto/POSIX/perror.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/pow.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/printf.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/putc.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/putchar.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/puts.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/qsort.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/raise.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/rand.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/readdir.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/realloc.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/redef.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/remove.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/rename.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/rewind.al | 13 + .../tlpkg/tlperl.old/lib/auto/POSIX/rewinddir.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/rmdir.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/scanf.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/setbuf.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/setjmp.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/setvbuf.al | 12 + .../tlpkg/tlperl.old/lib/auto/POSIX/siglongjmp.al | 12 + .../tlpkg/tlperl.old/lib/auto/POSIX/sigsetjmp.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/sin.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/sleep.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/sprintf.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/sqrt.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/srand.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/sscanf.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/stat.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strcat.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strchr.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strcmp.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strcpy.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strcspn.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strerror.al | 14 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strlen.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strncat.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strncmp.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strncpy.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strpbrk.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strrchr.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strspn.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strstr.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/strtok.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/system.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/time.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/tmpfile.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/tolower.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/toupper.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/umask.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/ungetc.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/unimpl.al | 14 + Master/tlpkg/tlperl.old/lib/auto/POSIX/unlink.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/usage.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/utime.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/vfprintf.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/vprintf.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/vsprintf.al | 12 + Master/tlpkg/tlperl.old/lib/auto/POSIX/wait.al | 13 + Master/tlpkg/tlperl.old/lib/auto/POSIX/waitpid.al | 13 + .../tlperl.old/lib/auto/SDBM_File/SDBM_File.bs | 0 .../tlperl.old/lib/auto/SDBM_File/SDBM_File.dll | Bin 0 -> 29696 bytes .../tlpkg/tlperl.old/lib/auto/Time/HiRes/HiRes.bs | 0 .../tlpkg/tlperl.old/lib/auto/Time/HiRes/HiRes.dll | Bin 0 -> 18944 bytes .../tlpkg/tlperl.old/lib/auto/Tk/CancelRepeat.al | 15 + .../tlpkg/tlperl.old/lib/auto/Tk/Canvas/Canvas.bs | 0 .../tlpkg/tlperl.old/lib/auto/Tk/Canvas/Canvas.dll | Bin 0 -> 153600 bytes .../tlperl.old/lib/auto/Tk/Clipboard/autosplit.ix | 6 + .../lib/auto/Tk/Clipboard/getSelected.al | 15 + .../tlperl.old/lib/auto/Tk/Compound/Compound.bs | 0 .../tlperl.old/lib/auto/Tk/Compound/Compound.dll | Bin 0 -> 19968 bytes .../lib/auto/Tk/DragDrop/Win32Site/Win32Site.bs | 0 .../lib/auto/Tk/DragDrop/Win32Site/Win32Site.dll | Bin 0 -> 11264 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/EnterFocus.al | 27 + Master/tlpkg/tlperl.old/lib/auto/Tk/Entry/Entry.bs | 0 .../tlpkg/tlperl.old/lib/auto/Tk/Entry/Entry.dll | Bin 0 -> 41472 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/Error.al | 20 + Master/tlpkg/tlperl.old/lib/auto/Tk/Event/Event.bs | 0 .../tlpkg/tlperl.old/lib/auto/Tk/Event/Event.dll | Bin 0 -> 56832 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/FirstMenu.al | 21 + .../tlpkg/tlperl.old/lib/auto/Tk/FocusChildren.al | 35 + Master/tlpkg/tlperl.old/lib/auto/Tk/FocusOK.al | 36 + .../tlperl.old/lib/auto/Tk/Frame/AddScrollbars.al | 52 + .../tlpkg/tlperl.old/lib/auto/Tk/Frame/FindMenu.al | 22 + .../tlperl.old/lib/auto/Tk/Frame/autosplit.ix | 24 + .../tlperl.old/lib/auto/Tk/Frame/freeze_on_map.al | 18 + Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/label.al | 24 + .../tlperl.old/lib/auto/Tk/Frame/labelPack.al | 50 + .../tlperl.old/lib/auto/Tk/Frame/labelVariable.al | 27 + .../tlperl.old/lib/auto/Tk/Frame/packscrollbars.al | 86 + .../tlperl.old/lib/auto/Tk/Frame/queuePack.al | 18 + Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/sbset.al | 15 + .../tlperl.old/lib/auto/Tk/Frame/scrollbars.al | 24 + Master/tlpkg/tlperl.old/lib/auto/Tk/HList/HList.bs | 0 .../tlpkg/tlperl.old/lib/auto/Tk/HList/HList.dll | Bin 0 -> 51712 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/IO/IO.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Tk/IO/IO.dll | Bin 0 -> 11264 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/ImageNames.al | 13 + Master/tlpkg/tlperl.old/lib/auto/Tk/ImageTypes.al | 13 + Master/tlpkg/tlperl.old/lib/auto/Tk/JPEG/JPEG.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Tk/JPEG/JPEG.dll | Bin 0 -> 118784 bytes .../tlperl.old/lib/auto/Tk/Listbox/AutoScan.al | 49 + .../tlperl.old/lib/auto/Tk/Listbox/BeginExtend.al | 34 + .../tlperl.old/lib/auto/Tk/Listbox/BeginSelect.al | 46 + .../tlperl.old/lib/auto/Tk/Listbox/BeginToggle.al | 40 + .../lib/auto/Tk/Listbox/ButtonRelease_1.al | 16 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/CLEAR.al | 16 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/Cancel.al | 42 + .../tlperl.old/lib/auto/Tk/Listbox/Cntrl_End.al | 19 + .../tlperl.old/lib/auto/Tk/Listbox/Cntrl_Home.al | 19 + .../lib/auto/Tk/Listbox/Cntrl_backslash.al | 19 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/DELETE.al | 19 + .../tlperl.old/lib/auto/Tk/Listbox/DataExtend.al | 39 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/EXISTS.al | 16 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/EXTEND.al | 16 + .../tlperl.old/lib/auto/Tk/Listbox/ExtendUpDown.al | 36 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/FETCH.al | 56 + .../tlperl.old/lib/auto/Tk/Listbox/FETCHSIZE.al | 16 + .../tlperl.old/lib/auto/Tk/Listbox/Listbox.bs | 0 .../tlperl.old/lib/auto/Tk/Listbox/Listbox.dll | Bin 0 -> 31232 bytes .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/Motion.al | 77 + Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/POP.al | 19 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/PUSH.al | 13 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/SHIFT.al | 19 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/SPLICE.al | 84 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/STORE.al | 80 + .../tlperl.old/lib/auto/Tk/Listbox/SelectAll.al | 32 + .../tlperl.old/lib/auto/Tk/Listbox/SetList.al | 16 + .../tlperl.old/lib/auto/Tk/Listbox/TIEARRAY.al | 15 + .../tlperl.old/lib/auto/Tk/Listbox/TIESCALAR.al | 15 + .../tlperl.old/lib/auto/Tk/Listbox/UNSHIFT.al | 16 + .../tlpkg/tlperl.old/lib/auto/Tk/Listbox/UpDown.al | 41 + .../tlperl.old/lib/auto/Tk/Listbox/autosplit.ix | 56 + .../lib/auto/Tk/Listbox/clipboardPaste.al | 21 + .../lib/auto/Tk/Listbox/deleteSelected.al | 18 + .../tlperl.old/lib/auto/Tk/Listbox/getSelected.al | 24 + .../tlperl.old/lib/auto/Tk/Listbox/xyIndex.al | 29 + .../lib/auto/Tk/Menubutton/Menubutton.bs | 0 .../lib/auto/Tk/Menubutton/Menubutton.dll | Bin 0 -> 20992 bytes .../tlperl.old/lib/auto/Tk/NBFrame/NBFrame.bs | 0 .../tlperl.old/lib/auto/Tk/NBFrame/NBFrame.dll | Bin 0 -> 22016 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/PNG/PNG.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Tk/PNG/PNG.dll | Bin 0 -> 168960 bytes .../tlpkg/tlperl.old/lib/auto/Tk/Pixmap/Pixmap.bs | 0 .../tlpkg/tlperl.old/lib/auto/Tk/Pixmap/Pixmap.dll | Bin 0 -> 27136 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/Receive.al | 23 + Master/tlpkg/tlperl.old/lib/auto/Tk/RepeatId.al | 16 + .../tlpkg/tlperl.old/lib/auto/Tk/Scale/Activate.al | 33 + .../tlperl.old/lib/auto/Tk/Scale/ButtonDown.al | 40 + .../tlpkg/tlperl.old/lib/auto/Tk/Scale/ButtonUp.al | 16 + .../tlperl.old/lib/auto/Tk/Scale/ControlPress.al | 31 + Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Drag.al | 29 + .../tlpkg/tlperl.old/lib/auto/Tk/Scale/EndDrag.al | 23 + Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Enter.al | 19 + .../tlperl.old/lib/auto/Tk/Scale/Increment.al | 61 + Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Leave.al | 15 + Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Scale.bs | 0 .../tlpkg/tlperl.old/lib/auto/Tk/Scale/Scale.dll | Bin 0 -> 24576 bytes .../tlperl.old/lib/auto/Tk/Scale/autosplit.ix | 22 + .../tlperl.old/lib/auto/Tk/Scrollbar/ButtonDown.al | 55 + .../tlperl.old/lib/auto/Tk/Scrollbar/ButtonUp.al | 26 + .../tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/Drag.al | 43 + .../tlperl.old/lib/auto/Tk/Scrollbar/EndDrag.al | 28 + .../tlperl.old/lib/auto/Tk/Scrollbar/Enter.al | 21 + .../tlperl.old/lib/auto/Tk/Scrollbar/Leave.al | 18 + .../tlperl.old/lib/auto/Tk/Scrollbar/Motion.al | 15 + .../lib/auto/Tk/Scrollbar/ScrlByPages.al | 38 + .../lib/auto/Tk/Scrollbar/ScrlByUnits.al | 37 + .../tlperl.old/lib/auto/Tk/Scrollbar/ScrlToPos.al | 35 + .../lib/auto/Tk/Scrollbar/ScrlTopBottom.al | 32 + .../tlperl.old/lib/auto/Tk/Scrollbar/Scrollbar.bs | 0 .../tlperl.old/lib/auto/Tk/Scrollbar/Scrollbar.dll | Bin 0 -> 21504 bytes .../tlperl.old/lib/auto/Tk/Scrollbar/Select.al | 59 + .../tlperl.old/lib/auto/Tk/Scrollbar/StartDrag.al | 38 + .../tlperl.old/lib/auto/Tk/Scrollbar/autosplit.ix | 30 + Master/tlpkg/tlperl.old/lib/auto/Tk/Selection.al | 18 + Master/tlpkg/tlperl.old/lib/auto/Tk/TList/TList.bs | 0 .../tlpkg/tlperl.old/lib/auto/Tk/TList/TList.dll | Bin 0 -> 28672 bytes .../tlpkg/tlperl.old/lib/auto/Tk/Table/Create.al | 17 + Master/tlpkg/tlperl.old/lib/auto/Tk/Table/Posn.al | 15 + .../tlperl.old/lib/auto/Tk/Table/autosplit.ix | 14 + Master/tlpkg/tlperl.old/lib/auto/Tk/Table/see.al | 46 + .../tlperl.old/lib/auto/Tk/Table/totalColumns.al | 13 + .../tlperl.old/lib/auto/Tk/Table/totalRows.al | 13 + Master/tlpkg/tlperl.old/lib/auto/Tk/Text/Text.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Tk/Text/Text.dll | Bin 0 -> 114176 bytes .../tlpkg/tlperl.old/lib/auto/Tk/Text/autosplit.ix | 3 + .../tlperl.old/lib/auto/Tk/TextEdit/autosplit.ix | 3 + .../tlperl.old/lib/auto/Tk/TextUndo/autosplit.ix | 3 + .../tlperl.old/lib/auto/Tk/TixGrid/TixGrid.bs | 0 .../tlperl.old/lib/auto/Tk/TixGrid/TixGrid.dll | Bin 0 -> 52224 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/Tk.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Tk/Tk.dll | Bin 0 -> 804864 bytes .../tlperl.old/lib/auto/Tk/Toplevel/FG_BindIn.al | 19 + .../tlperl.old/lib/auto/Tk/Toplevel/FG_BindOut.al | 20 + .../tlperl.old/lib/auto/Tk/Toplevel/FG_Create.al | 56 + .../tlperl.old/lib/auto/Tk/Toplevel/FG_Destroy.al | 29 + .../tlpkg/tlperl.old/lib/auto/Tk/Toplevel/FG_In.al | 24 + .../tlperl.old/lib/auto/Tk/Toplevel/FG_Out.al | 32 + .../tlperl.old/lib/auto/Tk/Toplevel/autosplit.ix | 10 + .../tlpkg/tlperl.old/lib/auto/Tk/TraverseToMenu.al | 27 + .../tlperl.old/lib/auto/Tk/Widget/ASkludge.al | 30 + .../tlperl.old/lib/auto/Tk/Widget/autosplit.ix | 11 + .../tlperl.old/lib/auto/Tk/Widget/bindDump.al | 87 + .../lib/auto/Tk/Widget/clipboardKeysyms.al | 51 + .../tlperl.old/lib/auto/Tk/Widget/pathname.al | 15 + .../tlperl.old/lib/auto/Tk/Wm/AnchorAdjust.al | 17 + .../tlpkg/tlperl.old/lib/auto/Tk/Wm/FullScreen.al | 29 + Master/tlpkg/tlperl.old/lib/auto/Tk/Wm/Popup.al | 50 + Master/tlpkg/tlperl.old/lib/auto/Tk/Wm/Post.al | 20 + .../tlpkg/tlperl.old/lib/auto/Tk/Wm/autosplit.ix | 14 + .../tlperl.old/lib/auto/Tk/Wm/iconposition.al | 24 + Master/tlpkg/tlperl.old/lib/auto/Tk/X/X.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Tk/X/X.dll | Bin 0 -> 25088 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/X/autosplit.ix | 3 + Master/tlpkg/tlperl.old/lib/auto/Tk/Xlib/Xlib.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Tk/Xlib/Xlib.dll | Bin 0 -> 29696 bytes Master/tlpkg/tlperl.old/lib/auto/Tk/autosplit.ix | 45 + Master/tlpkg/tlperl.old/lib/auto/Tk/break.al | 13 + .../tlperl.old/lib/auto/Tk/focusFollowsMouse.al | 14 + Master/tlpkg/tlperl.old/lib/auto/Tk/focusNext.al | 45 + Master/tlpkg/tlperl.old/lib/auto/Tk/focusPrev.al | 65 + Master/tlpkg/tlperl.old/lib/auto/Tk/getEncoding.al | 43 + Master/tlpkg/tlperl.old/lib/auto/Tk/interps.al | 14 + Master/tlpkg/tlperl.old/lib/auto/Tk/lsearch.al | 19 + .../tlpkg/tlperl.old/lib/auto/Tk/pTk/extralibs.ld | 1 + Master/tlpkg/tlperl.old/lib/auto/Tk/tabFocus.al | 13 + .../tlpkg/tlperl.old/lib/auto/Tk/updateWidgets.al | 17 + Master/tlpkg/tlperl.old/lib/auto/Win32/API/API.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Win32/API/API.dll | Bin 0 -> 20480 bytes .../lib/auto/Win32/API/Callback/Callback.bs | 0 .../lib/auto/Win32/API/Callback/Callback.dll | Bin 0 -> 16384 bytes .../lib/auto/Win32/ChangeNotify/ChangeNotify.bs | 0 .../lib/auto/Win32/ChangeNotify/ChangeNotify.dll | Bin 0 -> 11776 bytes .../lib/auto/Win32/Clipboard/Clipboard.bs | 0 .../lib/auto/Win32/Clipboard/Clipboard.dll | Bin 0 -> 20480 bytes .../tlperl.old/lib/auto/Win32/Console/Console.bs | 0 .../tlperl.old/lib/auto/Win32/Console/Console.dll | Bin 0 -> 47104 bytes .../tlpkg/tlperl.old/lib/auto/Win32/Event/Event.bs | 0 .../tlperl.old/lib/auto/Win32/Event/Event.dll | Bin 0 -> 12288 bytes .../tlperl.old/lib/auto/Win32/EventLog/EventLog.bs | 0 .../lib/auto/Win32/EventLog/EventLog.dll | Bin 0 -> 25088 bytes .../tlpkg/tlperl.old/lib/auto/Win32/File/File.bs | 0 .../tlpkg/tlperl.old/lib/auto/Win32/File/File.dll | Bin 0 -> 10240 bytes .../lib/auto/Win32/FileSecurity/FileSecurity.bs | 0 .../lib/auto/Win32/FileSecurity/FileSecurity.dll | Bin 0 -> 16384 bytes Master/tlpkg/tlperl.old/lib/auto/Win32/IPC/IPC.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Win32/IPC/IPC.dll | Bin 0 -> 13312 bytes .../tlperl.old/lib/auto/Win32/Internet/Internet.bs | 0 .../lib/auto/Win32/Internet/Internet.dll | Bin 0 -> 51712 bytes Master/tlpkg/tlperl.old/lib/auto/Win32/Job/Job.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Win32/Job/Job.dll | Bin 0 -> 25088 bytes .../tlpkg/tlperl.old/lib/auto/Win32/Mutex/Mutex.bs | 0 .../tlperl.old/lib/auto/Win32/Mutex/Mutex.dll | Bin 0 -> 10752 bytes .../tlperl.old/lib/auto/Win32/NetAdmin/NetAdmin.bs | 0 .../lib/auto/Win32/NetAdmin/NetAdmin.dll | Bin 0 -> 57344 bytes .../lib/auto/Win32/NetResource/NetResource.bs | 0 .../lib/auto/Win32/NetResource/NetResource.dll | Bin 0 -> 25088 bytes .../lib/auto/Win32/NetResource/autosplit.ix | 3 + .../tlpkg/tlperl.old/lib/auto/Win32/ODBC/ODBC.bs | 0 .../tlpkg/tlperl.old/lib/auto/Win32/ODBC/ODBC.dll | Bin 0 -> 141824 bytes Master/tlpkg/tlperl.old/lib/auto/Win32/OLE/OLE.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Win32/OLE/OLE.dll | Bin 0 -> 139264 bytes .../tlperl.old/lib/auto/Win32/PerfLib/PerfLib.bs | 0 .../tlperl.old/lib/auto/Win32/PerfLib/PerfLib.dll | Bin 0 -> 23040 bytes .../tlperl.old/lib/auto/Win32/PerfLib/autosplit.ix | 3 + .../tlpkg/tlperl.old/lib/auto/Win32/Pipe/Pipe.bs | 0 .../tlpkg/tlperl.old/lib/auto/Win32/Pipe/Pipe.dll | Bin 0 -> 37376 bytes .../tlperl.old/lib/auto/Win32/Process/Process.bs | 0 .../tlperl.old/lib/auto/Win32/Process/Process.dll | Bin 0 -> 39424 bytes .../tlperl.old/lib/auto/Win32/Registry/Registry.bs | 0 .../lib/auto/Win32/Registry/Registry.dll | Bin 0 -> 37376 bytes .../lib/auto/Win32/Semaphore/Semaphore.bs | 0 .../lib/auto/Win32/Semaphore/Semaphore.dll | Bin 0 -> 11264 bytes .../tlperl.old/lib/auto/Win32/Service/Service.bs | 0 .../tlperl.old/lib/auto/Win32/Service/Service.dll | Bin 0 -> 14848 bytes .../tlperl.old/lib/auto/Win32/Shortcut/Shortcut.bs | 0 .../lib/auto/Win32/Shortcut/Shortcut.dll | Bin 0 -> 29184 bytes .../tlpkg/tlperl.old/lib/auto/Win32/Sound/Sound.bs | 0 .../tlperl.old/lib/auto/Win32/Sound/Sound.dll | Bin 0 -> 44544 bytes Master/tlpkg/tlperl.old/lib/auto/Win32/Win32.bs | 0 Master/tlpkg/tlperl.old/lib/auto/Win32/Win32.dll | Bin 0 -> 21504 bytes .../tlperl.old/lib/auto/Win32/WinError/WinError.bs | 0 .../lib/auto/Win32/WinError/WinError.dll | Bin 0 -> 67584 bytes .../lib/auto/Win32API/Registry/Registry.bs | 0 .../lib/auto/Win32API/Registry/Registry.dll | Bin 0 -> 181760 bytes Master/tlpkg/tlperl.old/lib/auto/re/re.bs | 0 Master/tlpkg/tlperl.old/lib/auto/re/re.dll | Bin 0 -> 138240 bytes Master/tlpkg/tlperl.old/lib/base.pm | 226 + Master/tlpkg/tlperl.old/lib/bytes.pm | 88 + Master/tlpkg/tlperl.old/lib/bytes_heavy.pl | 40 + Master/tlpkg/tlperl.old/lib/constant.pm | 340 + Master/tlpkg/tlperl.old/lib/fields.pm | 319 + Master/tlpkg/tlperl.old/lib/lib.pm | 206 + Master/tlpkg/tlperl.old/lib/newgetopt.pl | 75 + Master/tlpkg/tlperl.old/lib/overload.pm | 1434 + Master/tlpkg/tlperl.old/lib/re.pm | 134 + Master/tlpkg/tlperl.old/lib/strict.pm | 136 + Master/tlpkg/tlperl.old/lib/subs.pm | 40 + .../tlpkg/tlperl.old/lib/unicore/ArabicShaping.txt | 299 + .../tlpkg/tlperl.old/lib/unicore/BidiMirroring.txt | 550 + Master/tlpkg/tlperl.old/lib/unicore/Blocks.txt | 172 + Master/tlpkg/tlperl.old/lib/unicore/Canonical.pl | 1042 + .../tlpkg/tlperl.old/lib/unicore/CaseFolding.txt | 1064 + .../tlpkg/tlperl.old/lib/unicore/CombiningClass.pl | 203 + .../lib/unicore/CompositionExclusions.txt | 179 + .../tlpkg/tlperl.old/lib/unicore/Decomposition.pl | 5366 ++++ .../tlperl.old/lib/unicore/EastAsianWidth.txt | 16368 +++++++++++ Master/tlpkg/tlperl.old/lib/unicore/Exact.pl | 73 + .../tlperl.old/lib/unicore/HangulSyllableType.txt | 851 + Master/tlpkg/tlperl.old/lib/unicore/Index.txt | 4307 +++ Master/tlpkg/tlperl.old/lib/unicore/Jamo.txt | 92 + Master/tlpkg/tlperl.old/lib/unicore/LineBreak.txt | 17169 ++++++++++++ Master/tlpkg/tlperl.old/lib/unicore/Name.pl | 16346 +++++++++++ .../tlperl.old/lib/unicore/NamedSequences.txt | 95 + Master/tlpkg/tlperl.old/lib/unicore/NamesList.txt | 27024 +++++++++++++++++++ .../lib/unicore/NormalizationCorrections.txt | 48 + Master/tlpkg/tlperl.old/lib/unicore/PVA.pl | 2044 ++ Master/tlpkg/tlperl.old/lib/unicore/PropList.txt | 1049 + .../tlperl.old/lib/unicore/PropValueAliases.txt | 578 + Master/tlpkg/tlperl.old/lib/unicore/Properties | 350 + .../tlperl.old/lib/unicore/PropertyAliases.txt | 163 + Master/tlpkg/tlperl.old/lib/unicore/ReadMe.txt | 24 + Master/tlpkg/tlperl.old/lib/unicore/Scripts.txt | 1464 + .../tlpkg/tlperl.old/lib/unicore/SpecialCasing.txt | 260 + .../lib/unicore/StandardizedVariants.txt | 122 + Master/tlpkg/tlperl.old/lib/unicore/To/Digit.pl | 276 + Master/tlpkg/tlperl.old/lib/unicore/To/Fold.pl | 993 + Master/tlpkg/tlperl.old/lib/unicore/To/Lower.pl | 905 + Master/tlpkg/tlperl.old/lib/unicore/To/Title.pl | 966 + Master/tlpkg/tlperl.old/lib/unicore/To/Upper.pl | 989 + .../tlpkg/tlperl.old/lib/unicore/UnicodeData.txt | 16351 +++++++++++ Master/tlpkg/tlperl.old/lib/unicore/lib/bc/AL.pl | 34 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/AN.pl | 11 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/B.pl | 14 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/BN.pl | 22 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/CS.pl | 22 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/EN.pl | 19 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/ES.pl | 18 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/ET.pl | 27 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/L.pl | 400 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/LRE.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/LRO.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/NSM.pl | 131 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/ON.pl | 150 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/PDF.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/R.pl | 36 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/RLE.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/RLO.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/S.pl | 12 + Master/tlpkg/tlperl.old/lib/unicore/lib/bc/WS.pl | 17 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/A.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/AL.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/AR.pl | 10 + .../tlpkg/tlperl.old/lib/unicore/lib/ccc/ATAR.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/ATB.pl | 10 + .../tlpkg/tlperl.old/lib/unicore/lib/ccc/ATBL.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/B.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/BL.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/BR.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/DA.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/DB.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/IS.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/KV.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/L.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/NK.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/NR.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/OV.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/R.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/VR.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/can.pl | 222 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/com.pl | 820 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/enc.pl | 14 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/fin.pl | 122 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/font.pl | 43 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/fra.pl | 11 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/init.pl | 84 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/iso.pl | 107 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/med.pl | 63 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/nar.pl | 15 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/nb.pl | 14 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/sml.pl | 12 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/sqr.pl | 14 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/sub.pl | 12 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/sup.pl | 27 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/vert.pl | 14 + Master/tlpkg/tlperl.old/lib/unicore/lib/dt/wide.pl | 12 + Master/tlpkg/tlperl.old/lib/unicore/lib/ea/A.pl | 168 + Master/tlpkg/tlperl.old/lib/unicore/lib/ea/F.pl | 12 + Master/tlpkg/tlperl.old/lib/unicore/lib/ea/H.pl | 16 + Master/tlpkg/tlperl.old/lib/unicore/lib/ea/N.pl | 540 + Master/tlpkg/tlperl.old/lib/unicore/lib/ea/Na.pl | 16 + Master/tlpkg/tlperl.old/lib/unicore/lib/ea/W.pl | 40 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/AHex.pl | 12 + .../tlperl.old/lib/unicore/lib/gc_sc/ASCII.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/Alnum.pl | 448 + .../tlperl.old/lib/unicore/lib/gc_sc/Alpha.pl | 430 + .../tlperl.old/lib/unicore/lib/gc_sc/Alphabet.pl | 415 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Any.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Arab.pl | 29 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Armn.pl | 17 + .../tlperl.old/lib/unicore/lib/gc_sc/AsciiHex.pl | 15 + .../tlperl.old/lib/unicore/lib/gc_sc/Assigned.pl | 432 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Beng.pl | 26 + .../tlperl.old/lib/unicore/lib/gc_sc/BidiC.pl | 11 + .../tlperl.old/lib/unicore/lib/gc_sc/BidiCont.pl | 14 + .../tlperl.old/lib/unicore/lib/gc_sc/Blank.pl | 21 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Bopo.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Brai.pl | 13 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Bugi.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Buhd.pl | 13 + Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/C.pl | 435 + .../tlperl.old/lib/unicore/lib/gc_sc/Canadian.pl | 13 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cc.pl | 15 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cf.pl | 27 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cher.pl | 13 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cn.pl | 433 + .../tlperl.old/lib/unicore/lib/gc_sc/Cntrl.pl | 31 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Co.pl | 16 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Copt.pl | 15 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cprt.pl | 18 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cs.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cyrl.pl | 18 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Dash.pl | 25 + .../tlperl.old/lib/unicore/lib/gc_sc/Dash2.pl | 28 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Dep.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/Deprecat.pl | 16 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Deva.pl | 18 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Dia.pl | 91 + .../tlperl.old/lib/unicore/lib/gc_sc/Diacriti.pl | 94 + .../tlperl.old/lib/unicore/lib/gc_sc/Digit.pl | 35 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Dsrt.pl | 13 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ethi.pl | 39 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ext.pl | 21 + .../tlperl.old/lib/unicore/lib/gc_sc/Extender.pl | 24 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Geor.pl | 16 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Glag.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Goth.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/GrLink.pl | 25 + .../tlperl.old/lib/unicore/lib/gc_sc/Graph.pl | 436 + .../tlperl.old/lib/unicore/lib/gc_sc/Grapheme.pl | 28 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Grek.pl | 43 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Gujr.pl | 26 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Guru.pl | 27 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hang.pl | 24 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hani.pl | 26 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hano.pl | 13 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hebr.pl | 22 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hex.pl | 15 + .../tlperl.old/lib/unicore/lib/gc_sc/HexDigit.pl | 18 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hira.pl | 14 + .../tlperl.old/lib/unicore/lib/gc_sc/Hyphen.pl | 19 + .../tlperl.old/lib/unicore/lib/gc_sc/Hyphen2.pl | 22 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/IDSB.pl | 11 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/IDST.pl | 10 + .../tlperl.old/lib/unicore/lib/gc_sc/IdContin.pl | 460 + .../tlperl.old/lib/unicore/lib/gc_sc/IdStart.pl | 364 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ideo.pl | 18 + .../tlperl.old/lib/unicore/lib/gc_sc/Ideograp.pl | 21 + .../tlperl.old/lib/unicore/lib/gc_sc/IdsBinar.pl | 14 + .../tlperl.old/lib/unicore/lib/gc_sc/IdsTrina.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InAegean.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InAlphab.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InAncie2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InAncien.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InArabi2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InArabi3.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InArabi4.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InArabic.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InArmeni.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InArrows.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InBasicL.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InBengal.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InBlockE.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InBopom2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InBopomo.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InBoxDra.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InBraill.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InBugine.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InBuhid.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InByzant.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCherok.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkCo2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkCo3.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkCo4.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkCom.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkRad.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkStr.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkSym.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkUn2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkUn3.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCjkUni.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCombi2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCombi3.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCombi4.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCombin.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InContro.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCoptic.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCurren.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCyprio.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCyril2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InCyrill.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InDesere.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InDevana.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InDingba.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InEnclo2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InEnclos.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InEthio2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InEthio3.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InEthiop.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGenera.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGeomet.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGeorg2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGeorgi.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGlagol.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGothic.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGreekA.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGreekE.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGujara.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InGurmuk.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InHalfwi.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InHangu2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InHangu3.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InHangul.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InHanuno.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InHebrew.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InHighPr.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InHighSu.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InHiraga.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InIdeogr.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InIpaExt.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InKanbun.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InKangxi.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InKannad.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InKatak2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InKataka.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InKharos.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InKhmer.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InKhmerS.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLao.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLatin1.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLatin2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLatin3.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLatinE.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLetter.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLimbu.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLinea2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLinear.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InLowSur.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMalaya.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMathe2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMathem.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMisce2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMisce3.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMisce4.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMisce5.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMiscel.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InModifi.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMongol.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMusica.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InMyanma.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InNewTai.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InNumber.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InOgham.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InOldIta.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InOldPer.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InOptica.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InOriya.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InOsmany.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InPhone2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InPhonet.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InPrivat.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InRunic.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InShavia.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSinhal.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSmallF.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSpacin.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSpecia.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSupers.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSuppl2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSuppl3.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSuppl4.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSuppl5.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSuppl6.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSupple.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSyloti.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InSyriac.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InTagalo.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InTagban.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InTags.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InTaiLe.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InTaiXua.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InTamil.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InTelugu.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InThaana.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InThai.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InTibeta.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InTifina.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InUgarit.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InUnifie.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InVaria2.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InVariat.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InVertic.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InYiRadi.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InYiSyll.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/InYijing.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/JoinC.pl | 10 + .../tlperl.old/lib/unicore/lib/gc_sc/JoinCont.pl | 13 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Kana.pl | 17 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Khar.pl | 20 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Khmr.pl | 16 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Knda.pl | 25 + Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/L.pl | 360 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/LC.pl | 116 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/LOE.pl | 11 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Laoo.pl | 30 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Latn.pl | 35 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Limb.pl | 17 + .../tlperl.old/lib/unicore/lib/gc_sc/LinearB.pl | 19 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ll.pl | 493 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lm.pl | 39 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lo.pl | 258 + .../tlperl.old/lib/unicore/lib/gc_sc/LogicalO.pl | 14 + .../tlperl.old/lib/unicore/lib/gc_sc/Lower.pl | 492 + .../tlperl.old/lib/unicore/lib/gc_sc/Lowercas.pl | 497 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lt.pl | 23 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lu.pl | 489 + Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/M.pl | 146 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Math.pl | 103 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mc.pl | 76 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Me.pl | 17 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mlym.pl | 23 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mn.pl | 137 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mong.pl | 16 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mymr.pl | 18 + Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/N.pl | 66 + .../tlperl.old/lib/unicore/lib/gc_sc/NChar.pl | 27 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Nd.pl | 36 + .../tlperl.old/lib/unicore/lib/gc_sc/NewTaiLu.pl | 16 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Nl.pl | 21 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/No.pl | 39 + .../tlperl.old/lib/unicore/lib/gc_sc/Nonchara.pl | 30 + .../tlperl.old/lib/unicore/lib/gc_sc/OAlpha.pl | 108 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/ODI.pl | 19 + .../tlperl.old/lib/unicore/lib/gc_sc/OGrExt.pl | 24 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OIDC.pl | 10 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OIDS.pl | 12 + .../tlperl.old/lib/unicore/lib/gc_sc/OLower.pl | 20 + .../tlperl.old/lib/unicore/lib/gc_sc/OMath.pl | 77 + .../tlperl.old/lib/unicore/lib/gc_sc/OUpper.pl | 11 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ogam.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/OldItali.pl | 14 + .../tlperl.old/lib/unicore/lib/gc_sc/OldPersi.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Orya.pl | 26 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Osma.pl | 14 + .../tlperl.old/lib/unicore/lib/gc_sc/OtherAlp.pl | 111 + .../tlperl.old/lib/unicore/lib/gc_sc/OtherDef.pl | 22 + .../tlperl.old/lib/unicore/lib/gc_sc/OtherGra.pl | 27 + .../tlperl.old/lib/unicore/lib/gc_sc/OtherIdC.pl | 13 + .../tlperl.old/lib/unicore/lib/gc_sc/OtherIdS.pl | 15 + .../tlperl.old/lib/unicore/lib/gc_sc/OtherLow.pl | 23 + .../tlperl.old/lib/unicore/lib/gc_sc/OtherMat.pl | 80 + .../tlperl.old/lib/unicore/lib/gc_sc/OtherUpp.pl | 14 + Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/P.pl | 109 + .../tlperl.old/lib/unicore/lib/gc_sc/PatSyn.pl | 37 + .../tlperl.old/lib/unicore/lib/gc_sc/PatWS.pl | 14 + .../tlperl.old/lib/unicore/lib/gc_sc/PatternS.pl | 40 + .../tlperl.old/lib/unicore/lib/gc_sc/PatternW.pl | 17 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pc.pl | 19 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pd.pl | 25 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pe.pl | 78 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pf.pl | 22 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pi.pl | 23 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Po.pl | 101 + .../tlperl.old/lib/unicore/lib/gc_sc/Print.pl | 435 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ps.pl | 80 + .../tlperl.old/lib/unicore/lib/gc_sc/Punct.pl | 108 + .../tlperl.old/lib/unicore/lib/gc_sc/QMark.pl | 21 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Qaai.pl | 27 + .../tlperl.old/lib/unicore/lib/gc_sc/Quotatio.pl | 24 + .../tlperl.old/lib/unicore/lib/gc_sc/Radical.pl | 12 + .../tlperl.old/lib/unicore/lib/gc_sc/Radical2.pl | 15 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Runr.pl | 14 + Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/S.pl | 175 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/SD.pl | 38 + .../tlperl.old/lib/unicore/lib/gc_sc/STerm.pl | 35 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Sc.pl | 27 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Shaw.pl | 13 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Sinh.pl | 23 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Sk.pl | 36 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Sm.pl | 72 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/So.pl | 133 + .../tlperl.old/lib/unicore/lib/gc_sc/SoftDott.pl | 41 + .../tlperl.old/lib/unicore/lib/gc_sc/Space.pl | 23 + .../tlperl.old/lib/unicore/lib/gc_sc/SpacePer.pl | 24 + .../tlperl.old/lib/unicore/lib/gc_sc/Sterm2.pl | 38 + .../tlperl.old/lib/unicore/lib/gc_sc/SylotiNa.pl | 13 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Syrc.pl | 15 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Tagb.pl | 15 + .../tlperl.old/lib/unicore/lib/gc_sc/TaiLe.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Taml.pl | 27 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Telu.pl | 24 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Term.pl | 49 + .../tlperl.old/lib/unicore/lib/gc_sc/Terminal.pl | 52 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Tfng.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Tglg.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Thaa.pl | 13 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Thai.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Tibt.pl | 19 + .../tlperl.old/lib/unicore/lib/gc_sc/Title.pl | 22 + .../tlperl.old/lib/unicore/lib/gc_sc/UIdeo.pl | 19 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ugar.pl | 14 + .../tlperl.old/lib/unicore/lib/gc_sc/UnifiedI.pl | 22 + .../tlperl.old/lib/unicore/lib/gc_sc/Upper.pl | 488 + .../tlperl.old/lib/unicore/lib/gc_sc/Uppercas.pl | 490 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/VS.pl | 12 + .../tlperl.old/lib/unicore/lib/gc_sc/Variatio.pl | 15 + .../tlperl.old/lib/unicore/lib/gc_sc/WSpace.pl | 20 + .../tlperl.old/lib/unicore/lib/gc_sc/WhiteSpa.pl | 23 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Word.pl | 476 + .../tlperl.old/lib/unicore/lib/gc_sc/XDigit.pl | 15 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Yiii.pl | 14 + Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Z.pl | 22 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Zl.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Zp.pl | 14 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Zs.pl | 21 + .../tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Zyyy.pl | 138 + .../tlperl.old/lib/unicore/lib/gc_sc/_CanonDC.pl | 16 + .../tlperl.old/lib/unicore/lib/gc_sc/_CaseIgn.pl | 138 + .../tlperl.old/lib/unicore/lib/gc_sc/_CombAbo.pl | 69 + Master/tlpkg/tlperl.old/lib/unicore/lib/hst/L.pl | 11 + Master/tlpkg/tlperl.old/lib/unicore/lib/hst/LV.pl | 408 + Master/tlpkg/tlperl.old/lib/unicore/lib/hst/LVT.pl | 408 + Master/tlpkg/tlperl.old/lib/unicore/lib/hst/T.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/hst/V.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/jt/C.pl | 11 + Master/tlpkg/tlperl.old/lib/unicore/lib/jt/D.pl | 33 + Master/tlpkg/tlperl.old/lib/unicore/lib/jt/R.pl | 34 + Master/tlpkg/tlperl.old/lib/unicore/lib/jt/U.pl | 15 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/AI.pl | 101 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/AL.pl | 449 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/B2.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/BA.pl | 45 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/BB.pl | 17 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/BK.pl | 11 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/CB.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/CL.pl | 80 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/CM.pl | 155 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/CR.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/EX.pl | 25 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/GL.pl | 19 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/H2.pl | 408 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/H3.pl | 408 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/HY.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/ID.pl | 80 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/IN.pl | 11 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/IS.pl | 18 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/JL.pl | 11 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/JT.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/JV.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/LF.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/NL.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/NS.pl | 46 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/NU.pl | 32 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/OP.pl | 76 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/PO.pl | 21 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/PR.pl | 27 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/QU.pl | 21 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/SA.pl | 34 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/SG.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/SP.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/SY.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/WJ.pl | 11 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/XX.pl | 12 + Master/tlpkg/tlperl.old/lib/unicore/lib/lb/ZW.pl | 10 + Master/tlpkg/tlperl.old/lib/unicore/lib/nt/De.pl | 32 + Master/tlpkg/tlperl.old/lib/unicore/lib/nt/Di.pl | 25 + Master/tlpkg/tlperl.old/lib/unicore/lib/nt/Nu.pl | 42 + Master/tlpkg/tlperl.old/lib/unicore/mktables | 2197 ++ Master/tlpkg/tlperl.old/lib/unicore/mktables.lst | 505 + Master/tlpkg/tlperl.old/lib/unicore/version | 1 + Master/tlpkg/tlperl.old/lib/utf8.pm | 214 + Master/tlpkg/tlperl.old/lib/utf8_heavy.pl | 412 + Master/tlpkg/tlperl.old/lib/vars.pm | 82 + Master/tlpkg/tlperl.old/lib/warnings.pm | 497 + Master/tlpkg/tlperl.old/lib/warnings/register.pm | 51 + Master/tlpkg/tlperl/README.TEXLIVE | 21 - Master/tlpkg/tlperl/bin/perl.exe | Bin 5632 -> 0 bytes Master/tlpkg/tlperl/bin/perl.exe.manifest | 15 - Master/tlpkg/tlperl/bin/perl58.dll | Bin 1098752 -> 0 bytes Master/tlpkg/tlperl/lib/AnyDBM_File.pm | 93 - Master/tlpkg/tlperl/lib/AutoLoader.pm | 343 - Master/tlpkg/tlperl/lib/B.pm | 1111 - Master/tlpkg/tlperl/lib/B/Asmdata.pm | 250 - Master/tlpkg/tlperl/lib/B/Assembler.pm | 328 - Master/tlpkg/tlperl/lib/B/Bblock.pm | 224 - Master/tlpkg/tlperl/lib/B/Bytecode.pm | 889 - Master/tlpkg/tlperl/lib/B/C.pm | 2272 -- Master/tlpkg/tlperl/lib/B/CC.pm | 2005 -- Master/tlpkg/tlperl/lib/B/Concise.pm | 1628 -- Master/tlpkg/tlperl/lib/B/Debug.pm | 305 - Master/tlpkg/tlperl/lib/B/Deparse.pm | 4642 ---- Master/tlpkg/tlperl/lib/B/Disassembler.pm | 233 - Master/tlpkg/tlperl/lib/B/Lint.pm | 392 - Master/tlpkg/tlperl/lib/B/Showlex.pm | 205 - Master/tlpkg/tlperl/lib/B/Stackobj.pm | 349 - Master/tlpkg/tlperl/lib/B/Stash.pm | 52 - Master/tlpkg/tlperl/lib/B/Terse.pm | 103 - Master/tlpkg/tlperl/lib/B/Xref.pm | 430 - Master/tlpkg/tlperl/lib/B/assemble | 30 - Master/tlpkg/tlperl/lib/B/cc_harness | 12 - Master/tlpkg/tlperl/lib/B/disassemble | 22 - Master/tlpkg/tlperl/lib/B/makeliblinks | 54 - Master/tlpkg/tlperl/lib/Carp.pm | 274 - Master/tlpkg/tlperl/lib/Carp/Heavy.pm | 241 - Master/tlpkg/tlperl/lib/Class/ISA.pm | 214 - Master/tlpkg/tlperl/lib/Class/Struct.pm | 636 - Master/tlpkg/tlperl/lib/Config.pm | 95 - Master/tlpkg/tlperl/lib/Config_heavy.pl | 1185 - Master/tlpkg/tlperl/lib/Cwd.pm | 710 - Master/tlpkg/tlperl/lib/Data/Dumper.pm | 1264 - Master/tlpkg/tlperl/lib/Digest/MD5.pm | 376 - Master/tlpkg/tlperl/lib/Digest/base.pm | 100 - Master/tlpkg/tlperl/lib/Digest/file.pm | 85 - Master/tlpkg/tlperl/lib/DynaLoader.pm | 833 - Master/tlpkg/tlperl/lib/Encode.pm | 851 - Master/tlpkg/tlperl/lib/Encode/Alias.pm | 341 - Master/tlpkg/tlperl/lib/Encode/Byte.pm | 119 - Master/tlpkg/tlperl/lib/Encode/CJKConstants.pm | 66 - Master/tlpkg/tlperl/lib/Encode/CN.pm | 76 - Master/tlpkg/tlperl/lib/Encode/CN/HZ.pm | 196 - Master/tlpkg/tlperl/lib/Encode/Changes.e2x | 7 - Master/tlpkg/tlperl/lib/Encode/Config.pm | 166 - Master/tlpkg/tlperl/lib/Encode/ConfigLocal_PM.e2x | 13 - Master/tlpkg/tlperl/lib/Encode/EBCDIC.pm | 43 - Master/tlpkg/tlperl/lib/Encode/Encoder.pm | 249 - Master/tlpkg/tlperl/lib/Encode/Encoding.pm | 341 - Master/tlpkg/tlperl/lib/Encode/Guess.pm | 351 - Master/tlpkg/tlperl/lib/Encode/JP.pm | 97 - Master/tlpkg/tlperl/lib/Encode/JP/H2Z.pm | 174 - Master/tlpkg/tlperl/lib/Encode/JP/JIS7.pm | 165 - Master/tlpkg/tlperl/lib/Encode/KR.pm | 72 - Master/tlpkg/tlperl/lib/Encode/KR/2022_KR.pm | 79 - Master/tlpkg/tlperl/lib/Encode/MIME/Header.pm | 230 - .../tlperl/lib/Encode/MIME/Header/ISO_2022_JP.pm | 127 - Master/tlpkg/tlperl/lib/Encode/Makefile_PL.e2x | 180 - Master/tlpkg/tlperl/lib/Encode/PerlIO.pod | 167 - Master/tlpkg/tlperl/lib/Encode/README.e2x | 31 - Master/tlpkg/tlperl/lib/Encode/Supported.pod | 890 - Master/tlpkg/tlperl/lib/Encode/Symbol.pm | 42 - Master/tlpkg/tlperl/lib/Encode/TW.pm | 78 - Master/tlpkg/tlperl/lib/Encode/Unicode.pm | 268 - Master/tlpkg/tlperl/lib/Encode/Unicode/UTF7.pm | 118 - Master/tlpkg/tlperl/lib/Encode/_PM.e2x | 23 - Master/tlpkg/tlperl/lib/Encode/_T.e2x | 7 - Master/tlpkg/tlperl/lib/Encode/encode.h | 111 - Master/tlpkg/tlperl/lib/Errno.pm | 227 - Master/tlpkg/tlperl/lib/Exporter.pm | 440 - Master/tlpkg/tlperl/lib/Exporter/Heavy.pm | 248 - Master/tlpkg/tlperl/lib/Fcntl.pm | 236 - Master/tlpkg/tlperl/lib/File/Basename.pm | 398 - Master/tlpkg/tlperl/lib/File/CheckTree.pm | 229 - Master/tlpkg/tlperl/lib/File/Compare.pm | 178 - Master/tlpkg/tlperl/lib/File/Copy.pm | 459 - Master/tlpkg/tlperl/lib/File/DosGlob.pm | 571 - Master/tlpkg/tlperl/lib/File/Find.pm | 1275 - Master/tlpkg/tlperl/lib/File/Glob.pm | 496 - Master/tlpkg/tlperl/lib/File/Path.pm | 285 - Master/tlpkg/tlperl/lib/File/Spec.pm | 322 - Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm | 93 - Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm | 77 - Master/tlpkg/tlperl/lib/File/Spec/Functions.pm | 109 - Master/tlpkg/tlperl/lib/File/Spec/Mac.pm | 780 - Master/tlpkg/tlperl/lib/File/Spec/OS2.pm | 272 - Master/tlpkg/tlperl/lib/File/Spec/Unix.pm | 510 - Master/tlpkg/tlperl/lib/File/Spec/VMS.pm | 521 - Master/tlpkg/tlperl/lib/File/Spec/Win32.pm | 369 - Master/tlpkg/tlperl/lib/File/Temp.pm | 2244 -- Master/tlpkg/tlperl/lib/File/stat.pm | 139 - Master/tlpkg/tlperl/lib/FileHandle.pm | 262 - Master/tlpkg/tlperl/lib/Getopt/Long.pm | 2504 -- Master/tlpkg/tlperl/lib/Getopt/Std.pm | 294 - Master/tlpkg/tlperl/lib/IO.pm | 68 - Master/tlpkg/tlperl/lib/IO/Dir.pm | 246 - Master/tlpkg/tlperl/lib/IO/File.pm | 208 - Master/tlpkg/tlperl/lib/IO/Handle.pm | 625 - Master/tlpkg/tlperl/lib/IO/Pipe.pm | 257 - Master/tlpkg/tlperl/lib/IO/Poll.pm | 209 - Master/tlpkg/tlperl/lib/IO/Seekable.pm | 128 - Master/tlpkg/tlperl/lib/IO/Select.pm | 381 - Master/tlpkg/tlperl/lib/IO/Socket.pm | 476 - Master/tlpkg/tlperl/lib/IO/Socket/INET.pm | 431 - Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm | 144 - Master/tlpkg/tlperl/lib/IO/String.pm | 551 - Master/tlpkg/tlperl/lib/List/Util.pm | 277 - Master/tlpkg/tlperl/lib/Opcode.pm | 578 - Master/tlpkg/tlperl/lib/POSIX.pm | 965 - Master/tlpkg/tlperl/lib/Pod/Checker.pm | 1270 - Master/tlpkg/tlperl/lib/Pod/Find.pm | 523 - Master/tlpkg/tlperl/lib/Pod/Functions.pm | 376 - Master/tlpkg/tlperl/lib/Pod/Html.pm | 2123 -- Master/tlpkg/tlperl/lib/Pod/InputObjects.pm | 941 - Master/tlpkg/tlperl/lib/Pod/LaTeX.pm | 1876 -- Master/tlpkg/tlperl/lib/Pod/Man.pm | 1413 - Master/tlpkg/tlperl/lib/Pod/ParseLink.pm | 184 - Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm | 852 - Master/tlpkg/tlperl/lib/Pod/Parser.pm | 1799 -- Master/tlpkg/tlperl/lib/Pod/Perldoc.pm | 1762 -- Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm | 28 - Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm | 106 - Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm | 72 - Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm | 187 - Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm | 100 - Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm | 90 - Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm | 85 - Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm | 91 - Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm | 129 - Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm | 63 - Master/tlpkg/tlperl/lib/Pod/PlainText.pm | 705 - Master/tlpkg/tlperl/lib/Pod/Plainer.pm | 69 - Master/tlpkg/tlperl/lib/Pod/Select.pm | 754 - Master/tlpkg/tlperl/lib/Pod/Text.pm | 848 - Master/tlpkg/tlperl/lib/Pod/Text/Color.pm | 145 - Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm | 208 - Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm | 180 - Master/tlpkg/tlperl/lib/Pod/Usage.pm | 659 - Master/tlpkg/tlperl/lib/Safe.pm | 576 - Master/tlpkg/tlperl/lib/Scalar/Util.pm | 147 - Master/tlpkg/tlperl/lib/SelectSaver.pm | 54 - Master/tlpkg/tlperl/lib/Symbol.pm | 170 - Master/tlpkg/tlperl/lib/Term/ANSIColor.pm | 472 - Master/tlpkg/tlperl/lib/Term/Cap.pm | 669 - Master/tlpkg/tlperl/lib/Term/Complete.pm | 188 - Master/tlpkg/tlperl/lib/Term/ReadLine.pm | 399 - Master/tlpkg/tlperl/lib/Text/Abbrev.pm | 84 - Master/tlpkg/tlperl/lib/Text/Balanced.pm | 2302 -- Master/tlpkg/tlperl/lib/Text/ParseWords.pm | 263 - Master/tlpkg/tlperl/lib/Text/Soundex.pm | 150 - Master/tlpkg/tlperl/lib/Text/Tabs.pm | 121 - Master/tlpkg/tlperl/lib/Text/Wrap.pm | 223 - Master/tlpkg/tlperl/lib/Tie/Array.pm | 287 - Master/tlpkg/tlperl/lib/Tie/File.pm | 2632 -- Master/tlpkg/tlperl/lib/Tie/Handle.pm | 234 - Master/tlpkg/tlperl/lib/Tie/Hash.pm | 257 - Master/tlpkg/tlperl/lib/Tie/Memoize.pm | 128 - Master/tlpkg/tlperl/lib/Tie/RefHash.pm | 170 - Master/tlpkg/tlperl/lib/Tie/Scalar.pm | 140 - Master/tlpkg/tlperl/lib/Tie/SubstrHash.pm | 215 - Master/tlpkg/tlperl/lib/Tie/Watch.pm | 560 - Master/tlpkg/tlperl/lib/Time/HiRes.pm | 500 - Master/tlpkg/tlperl/lib/Time/Local.pm | 366 - Master/tlpkg/tlperl/lib/Time/gmtime.pm | 90 - Master/tlpkg/tlperl/lib/Time/localtime.pm | 86 - Master/tlpkg/tlperl/lib/Time/tm.pm | 33 - Master/tlpkg/tlperl/lib/Tk.pm | 821 - Master/tlpkg/tlperl/lib/Tk/Adjuster.pm | 436 - Master/tlpkg/tlperl/lib/Tk/After.pm | 104 - Master/tlpkg/tlperl/lib/Tk/Animation.pm | 178 - Master/tlpkg/tlperl/lib/Tk/Balloon.pm | 621 - Master/tlpkg/tlperl/lib/Tk/Bitmap.pm | 10 - Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm | 510 - Master/tlpkg/tlperl/lib/Tk/Button.pm | 148 - Master/tlpkg/tlperl/lib/Tk/Camel.xpm | 41 - Master/tlpkg/tlperl/lib/Tk/Canvas.pm | 1436 - Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm | 42 - Master/tlpkg/tlperl/lib/Tk/Clipboard.pm | 122 - Master/tlpkg/tlperl/lib/Tk/CmdLine.pm | 954 - Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm | 58 - Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm | 761 - Master/tlpkg/tlperl/lib/Tk/Compound.pm | 40 - Master/tlpkg/tlperl/lib/Tk/Config.pm | 12 - Master/tlpkg/tlperl/lib/Tk/Configure.pm | 69 - Master/tlpkg/tlperl/lib/Tk/Credits | 7 - Master/tlpkg/tlperl/lib/Tk/Derived.pm | 512 - Master/tlpkg/tlperl/lib/Tk/Dialog.pm | 70 - Master/tlpkg/tlperl/lib/Tk/DialogBox.pm | 135 - Master/tlpkg/tlperl/lib/Tk/DirTree.pm | 252 - Master/tlpkg/tlperl/lib/Tk/Dirlist.pm | 113 - Master/tlpkg/tlperl/lib/Tk/DragDrop.pm | 332 - Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm | 59 - Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm | 61 - Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm | 110 - Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm | 34 - Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm | 200 - Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm | 107 - Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm | 8 - Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm | 50 - Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm | 145 - Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm | 159 - Master/tlpkg/tlperl/lib/Tk/DropSite.pm | 257 - Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm | 46 - Master/tlpkg/tlperl/lib/Tk/English.pm | 307 - Master/tlpkg/tlperl/lib/Tk/Entry.pm | 615 - Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm | 125 - Master/tlpkg/tlperl/lib/Tk/Event.pm | 13 - Master/tlpkg/tlperl/lib/Tk/Event/IO.pm | 132 - Master/tlpkg/tlperl/lib/Tk/FBox.pm | 1043 - Master/tlpkg/tlperl/lib/Tk/FileSelect.pm | 578 - Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm | 109 - Master/tlpkg/tlperl/lib/Tk/Font.pm | 163 - Master/tlpkg/tlperl/lib/Tk/Frame.pm | 378 - Master/tlpkg/tlperl/lib/Tk/HList.pm | 680 - Master/tlpkg/tlperl/lib/Tk/IO.pm | 182 - Master/tlpkg/tlperl/lib/Tk/IconList.pm | 712 - Master/tlpkg/tlperl/lib/Tk/Image.pm | 74 - Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm | 38 - Master/tlpkg/tlperl/lib/Tk/JPEG.pm | 50 - Master/tlpkg/tlperl/lib/Tk/LabEntry.pm | 31 - Master/tlpkg/tlperl/lib/Tk/LabFrame.pm | 138 - Master/tlpkg/tlperl/lib/Tk/LabRadio.pm | 63 - Master/tlpkg/tlperl/lib/Tk/Label.pm | 21 - Master/tlpkg/tlperl/lib/Tk/Labelframe.pm | 16 - Master/tlpkg/tlperl/lib/Tk/Listbox.pm | 910 - Master/tlpkg/tlperl/lib/Tk/MMtry.pm | 54 - Master/tlpkg/tlperl/lib/Tk/MMutil.pm | 600 - Master/tlpkg/tlperl/lib/Tk/MainWindow.pm | 213 - Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm | 292 - Master/tlpkg/tlperl/lib/Tk/Menu.pm | 1145 - Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm | 180 - Master/tlpkg/tlperl/lib/Tk/Menubar.pm | 15 - Master/tlpkg/tlperl/lib/Tk/Menubutton.pm | 398 - Master/tlpkg/tlperl/lib/Tk/Message.pm | 20 - Master/tlpkg/tlperl/lib/Tk/NBFrame.pm | 20 - Master/tlpkg/tlperl/lib/Tk/NoteBook.pm | 452 - Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm | 130 - Master/tlpkg/tlperl/lib/Tk/PNG.pm | 43 - Master/tlpkg/tlperl/lib/Tk/Pane.pm | 544 - Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm | 221 - Master/tlpkg/tlperl/lib/Tk/Photo.pm | 22 - Master/tlpkg/tlperl/lib/Tk/Pixmap.pm | 19 - Master/tlpkg/tlperl/lib/Tk/Pretty.pm | 93 - Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm | 498 - Master/tlpkg/tlperl/lib/Tk/README.Adjust | 77 - Master/tlpkg/tlperl/lib/Tk/ROText.pm | 43 - Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm | 45 - Master/tlpkg/tlperl/lib/Tk/Region.pm | 182 - Master/tlpkg/tlperl/lib/Tk/Reindex.pm | 225 - Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm | 13 - Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm | 13 - Master/tlpkg/tlperl/lib/Tk/Scale.pm | 278 - Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm | 429 - Master/tlpkg/tlperl/lib/Tk/Spinbox.pm | 115 - Master/tlpkg/tlperl/lib/Tk/Stats.pm | 26 - Master/tlpkg/tlperl/lib/Tk/Submethods.pm | 46 - Master/tlpkg/tlperl/lib/Tk/TList.pm | 416 - Master/tlpkg/tlperl/lib/Tk/Table.pm | 598 - Master/tlpkg/tlperl/lib/Tk/Text.pm | 1653 -- Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm | 46 - Master/tlpkg/tlperl/lib/Tk/TextEdit.pm | 509 - Master/tlpkg/tlperl/lib/Tk/TextList.pm | 985 - Master/tlpkg/tlperl/lib/Tk/TextUndo.pm | 1022 - Master/tlpkg/tlperl/lib/Tk/Tiler.pm | 203 - Master/tlpkg/tlperl/lib/Tk/TixGrid.pm | 1597 -- Master/tlpkg/tlperl/lib/Tk/Tk.xbm | 44 - Master/tlpkg/tlperl/lib/Tk/Tk.xpm | 41 - Master/tlpkg/tlperl/lib/Tk/TkXSUB.def | 62 - Master/tlpkg/tlperl/lib/Tk/Toplevel.pm | 211 - Master/tlpkg/tlperl/lib/Tk/Trace.pm | 405 - Master/tlpkg/tlperl/lib/Tk/Tree.pm | 228 - Master/tlpkg/tlperl/lib/Tk/Widget.pm | 1510 -- Master/tlpkg/tlperl/lib/Tk/Wm.pm | 174 - Master/tlpkg/tlperl/lib/Tk/X.pm | 398 - Master/tlpkg/tlperl/lib/Tk/X11/X.h | 677 - Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h | 79 - Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h | 60 - Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h | 1214 - Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h | 855 - Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h | 79 - Master/tlpkg/tlperl/lib/Tk/X11/keysym.h | 39 - Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h | 1169 - Master/tlpkg/tlperl/lib/Tk/X11/license.terms | 39 - Master/tlpkg/tlperl/lib/Tk/X11Font.pm | 184 - Master/tlpkg/tlperl/lib/Tk/Xcamel.gif | Bin 4193 -> 0 bytes Master/tlpkg/tlperl/lib/Tk/Xlib.pm | 15 - Master/tlpkg/tlperl/lib/Tk/Xrm.pm | 11 - Master/tlpkg/tlperl/lib/Tk/act_folder.xbm | 5 - Master/tlpkg/tlperl/lib/Tk/act_folder.xpm | 22 - Master/tlpkg/tlperl/lib/Tk/anim.gif | Bin 2533 -> 0 bytes Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm | 5 - Master/tlpkg/tlperl/lib/Tk/balArrow.xbm | 4 - Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm | 6 - Master/tlpkg/tlperl/lib/Tk/file.xbm | 5 - Master/tlpkg/tlperl/lib/Tk/file.xpm | 18 - Master/tlpkg/tlperl/lib/Tk/folder.xbm | 5 - Master/tlpkg/tlperl/lib/Tk/folder.xpm | 21 - Master/tlpkg/tlperl/lib/Tk/icon.gif | Bin 1924 -> 0 bytes Master/tlpkg/tlperl/lib/Tk/install.pm | 37 - Master/tlpkg/tlperl/lib/Tk/license.terms | 35 - Master/tlpkg/tlperl/lib/Tk/openfile.xbm | 5 - Master/tlpkg/tlperl/lib/Tk/openfolder.xbm | 5 - Master/tlpkg/tlperl/lib/Tk/openfolder.xpm | 21 - Master/tlpkg/tlperl/lib/Tk/prolog.ps | 284 - Master/tlpkg/tlperl/lib/Tk/reindex.pl | 33 - Master/tlpkg/tlperl/lib/Tk/srcfile.xpm | 18 - Master/tlpkg/tlperl/lib/Tk/textfile.xpm | 18 - Master/tlpkg/tlperl/lib/Tk/tkGlue.def | 130 - Master/tlpkg/tlperl/lib/Tk/tkGlue.h | 79 - Master/tlpkg/tlperl/lib/Tk/tkGlue.m | 74 - Master/tlpkg/tlperl/lib/Tk/tkGlue.t | 70 - Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h | 14 - Master/tlpkg/tlperl/lib/Tk/tranicon.gif | Bin 1718 -> 0 bytes Master/tlpkg/tlperl/lib/Tk/typemap | 96 - Master/tlpkg/tlperl/lib/Tk/vtab.def | 90 - Master/tlpkg/tlperl/lib/Tk/widgets.pm | 21 - Master/tlpkg/tlperl/lib/Tk/win.xbm | 6 - Master/tlpkg/tlperl/lib/Tk/winfolder.xpm | 39 - Master/tlpkg/tlperl/lib/Tk/wintext.xpm | 42 - Master/tlpkg/tlperl/lib/UNIVERSAL.pm | 147 - Master/tlpkg/tlperl/lib/Win32.pm | 712 - Master/tlpkg/tlperl/lib/Win32/API.pm | 745 - Master/tlpkg/tlperl/lib/Win32/API.pm.orig | 741 - Master/tlpkg/tlperl/lib/Win32/API/Callback.pm | 174 - Master/tlpkg/tlperl/lib/Win32/API/Struct.pm | 532 - Master/tlpkg/tlperl/lib/Win32/API/Test.pm | 120 - Master/tlpkg/tlperl/lib/Win32/API/Type.pm | 446 - Master/tlpkg/tlperl/lib/Win32/ChangeNotify.pm | 198 - Master/tlpkg/tlperl/lib/Win32/Client.pl | 63 - Master/tlpkg/tlperl/lib/Win32/Clipboard.pm | 369 - Master/tlpkg/tlperl/lib/Win32/Console.pm | 1463 - Master/tlpkg/tlperl/lib/Win32/Event.pm | 104 - Master/tlpkg/tlperl/lib/Win32/EventLog.pm | 471 - Master/tlpkg/tlperl/lib/Win32/File.pm | 118 - Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm | 308 - Master/tlpkg/tlperl/lib/Win32/IPC.pm | 195 - Master/tlpkg/tlperl/lib/Win32/Internet.pm | 3009 --- Master/tlpkg/tlperl/lib/Win32/Job.pm | 370 - Master/tlpkg/tlperl/lib/Win32/Mutex.pm | 125 - Master/tlpkg/tlperl/lib/Win32/NetAdmin.pm | 419 - Master/tlpkg/tlperl/lib/Win32/NetResource.pm | 456 - Master/tlpkg/tlperl/lib/Win32/ODBC.pm | 1493 - Master/tlpkg/tlperl/lib/Win32/PerfLib.pm | 538 - Master/tlpkg/tlperl/lib/Win32/Pipe.pm | 414 - Master/tlpkg/tlperl/lib/Win32/Process.pm | 217 - Master/tlpkg/tlperl/lib/Win32/Registry.pm | 547 - Master/tlpkg/tlperl/lib/Win32/Semaphore.pm | 128 - Master/tlpkg/tlperl/lib/Win32/Server.pl | 48 - Master/tlpkg/tlperl/lib/Win32/Service.pm | 103 - Master/tlpkg/tlperl/lib/Win32/Shortcut.pm | 323 - Master/tlpkg/tlperl/lib/Win32/Sound.pm | 582 - Master/tlpkg/tlperl/lib/Win32/Test.pl | 477 - Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm | 3801 --- Master/tlpkg/tlperl/lib/Win32/WinError.pm | 1017 - Master/tlpkg/tlperl/lib/Win32/test-async.pl | 129 - Master/tlpkg/tlperl/lib/Win32API/Registry.pm | 1792 -- .../tlperl/lib/Win32API/Registry/cRegistry.pc | 87 - Master/tlpkg/tlperl/lib/XSLoader.pm | 356 - Master/tlpkg/tlperl/lib/attributes.pm | 418 - Master/tlpkg/tlperl/lib/auto/B/B.bs | 0 Master/tlpkg/tlperl/lib/auto/B/B.dll | Bin 113152 -> 0 bytes Master/tlpkg/tlperl/lib/auto/B/C/C.bs | 0 Master/tlpkg/tlperl/lib/auto/B/C/C.dll | Bin 8192 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Cwd/Cwd.bs | 0 Master/tlpkg/tlperl/lib/auto/Cwd/Cwd.dll | Bin 10240 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Data/Dumper/Dumper.bs | 0 .../tlpkg/tlperl/lib/auto/Data/Dumper/Dumper.dll | Bin 30720 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Digest/MD5/MD5.bs | 0 Master/tlpkg/tlperl/lib/auto/Digest/MD5/MD5.dll | Bin 15872 -> 0 bytes .../tlpkg/tlperl/lib/auto/DynaLoader/autosplit.ix | 8 - .../tlperl/lib/auto/DynaLoader/dl_expandspec.al | 34 - .../lib/auto/DynaLoader/dl_find_symbol_anywhere.al | 19 - .../tlperl/lib/auto/DynaLoader/dl_findfile.al | 115 - Master/tlpkg/tlperl/lib/auto/Encode/Byte/Byte.bs | 0 Master/tlpkg/tlperl/lib/auto/Encode/Byte/Byte.dll | Bin 112640 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Encode/Encode.bs | 0 Master/tlpkg/tlperl/lib/auto/Encode/Encode.dll | Bin 30208 -> 0 bytes .../tlpkg/tlperl/lib/auto/Encode/Symbol/Symbol.bs | 0 .../tlpkg/tlperl/lib/auto/Encode/Symbol/Symbol.dll | Bin 20992 -> 0 bytes .../tlperl/lib/auto/Encode/Unicode/Unicode.bs | 0 .../tlperl/lib/auto/Encode/Unicode/Unicode.dll | Bin 17920 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Fcntl/Fcntl.bs | 0 Master/tlpkg/tlperl/lib/auto/Fcntl/Fcntl.dll | Bin 14848 -> 0 bytes Master/tlpkg/tlperl/lib/auto/File/Glob/Glob.bs | 0 Master/tlpkg/tlperl/lib/auto/File/Glob/Glob.dll | Bin 16384 -> 0 bytes Master/tlpkg/tlperl/lib/auto/IO/IO.bs | 0 Master/tlpkg/tlperl/lib/auto/IO/IO.dll | Bin 16896 -> 0 bytes Master/tlpkg/tlperl/lib/auto/List/Util/Util.bs | 0 Master/tlpkg/tlperl/lib/auto/List/Util/Util.dll | Bin 26624 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.bs | 0 Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.dll | Bin 21504 -> 0 bytes Master/tlpkg/tlperl/lib/auto/POSIX/POSIX.bs | 0 Master/tlpkg/tlperl/lib/auto/POSIX/POSIX.dll | Bin 97792 -> 0 bytes .../tlpkg/tlperl/lib/auto/POSIX/SigAction/flags.al | 9 - .../tlperl/lib/auto/POSIX/SigAction/handler.al | 11 - .../tlpkg/tlperl/lib/auto/POSIX/SigAction/mask.al | 9 - .../tlpkg/tlperl/lib/auto/POSIX/SigAction/safe.al | 9 - Master/tlpkg/tlperl/lib/auto/POSIX/abs.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/alarm.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/assert.al | 15 - Master/tlpkg/tlperl/lib/auto/POSIX/atan2.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/atexit.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/atof.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/atoi.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/atol.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/autosplit.ix | 159 - Master/tlpkg/tlperl/lib/auto/POSIX/bsearch.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/calloc.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/chdir.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/chmod.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/chown.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/clearerr.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/closedir.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/cos.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/creat.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/div.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/errno.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/execl.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/execle.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/execlp.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/execv.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/execve.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/execvp.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/exit.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/exp.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/fabs.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/fclose.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fcntl.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/fdopen.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/feof.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/ferror.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fflush.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fgetc.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fgetpos.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fgets.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fileno.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fopen.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fork.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/fprintf.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fputc.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fputs.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fread.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/free.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/freopen.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fscanf.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fseek.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fsetpos.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fstat.al | 17 - Master/tlpkg/tlperl/lib/auto/POSIX/fsync.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/ftell.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/fwrite.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/getc.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getchar.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getegid.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getenv.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/geteuid.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getgid.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getgrgid.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getgrnam.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getgroups.al | 14 - Master/tlpkg/tlperl/lib/auto/POSIX/getlogin.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getpgrp.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getpid.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getppid.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getpwnam.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getpwuid.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/gets.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/getuid.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/gmtime.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/isatty.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/kill.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/labs.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/ldiv.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/link.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/load_imports.al | 225 - Master/tlpkg/tlperl/lib/auto/POSIX/localtime.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/log.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/longjmp.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/malloc.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/memchr.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/memcmp.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/memcpy.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/memmove.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/memset.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/mkdir.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/offsetof.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/opendir.al | 16 - Master/tlpkg/tlperl/lib/auto/POSIX/perror.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/pow.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/printf.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/putc.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/putchar.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/puts.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/qsort.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/raise.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/rand.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/readdir.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/realloc.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/redef.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/remove.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/rename.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/rewind.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/rewinddir.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/rmdir.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/scanf.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/setbuf.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/setjmp.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/setvbuf.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/siglongjmp.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/sigsetjmp.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/sin.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/sleep.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/sprintf.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/sqrt.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/srand.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/sscanf.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/stat.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/strcat.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strchr.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strcmp.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strcpy.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strcspn.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strerror.al | 14 - Master/tlpkg/tlperl/lib/auto/POSIX/strlen.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strncat.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strncmp.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strncpy.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strpbrk.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strrchr.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strspn.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/strstr.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/strtok.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/system.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/time.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/tmpfile.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/tolower.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/toupper.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/umask.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/ungetc.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/unimpl.al | 14 - Master/tlpkg/tlperl/lib/auto/POSIX/unlink.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/usage.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/utime.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/vfprintf.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/vprintf.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/vsprintf.al | 12 - Master/tlpkg/tlperl/lib/auto/POSIX/wait.al | 13 - Master/tlpkg/tlperl/lib/auto/POSIX/waitpid.al | 13 - .../tlpkg/tlperl/lib/auto/SDBM_File/SDBM_File.bs | 0 .../tlpkg/tlperl/lib/auto/SDBM_File/SDBM_File.dll | Bin 29696 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Time/HiRes/HiRes.bs | 0 Master/tlpkg/tlperl/lib/auto/Time/HiRes/HiRes.dll | Bin 18944 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/CancelRepeat.al | 15 - Master/tlpkg/tlperl/lib/auto/Tk/Canvas/Canvas.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Canvas/Canvas.dll | Bin 153600 -> 0 bytes .../tlperl/lib/auto/Tk/Clipboard/autosplit.ix | 6 - .../tlperl/lib/auto/Tk/Clipboard/getSelected.al | 15 - .../tlpkg/tlperl/lib/auto/Tk/Compound/Compound.bs | 0 .../tlpkg/tlperl/lib/auto/Tk/Compound/Compound.dll | Bin 19968 -> 0 bytes .../lib/auto/Tk/DragDrop/Win32Site/Win32Site.bs | 0 .../lib/auto/Tk/DragDrop/Win32Site/Win32Site.dll | Bin 11264 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/EnterFocus.al | 27 - Master/tlpkg/tlperl/lib/auto/Tk/Entry/Entry.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Entry/Entry.dll | Bin 41472 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/Error.al | 20 - Master/tlpkg/tlperl/lib/auto/Tk/Event/Event.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Event/Event.dll | Bin 56832 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/FirstMenu.al | 21 - Master/tlpkg/tlperl/lib/auto/Tk/FocusChildren.al | 35 - Master/tlpkg/tlperl/lib/auto/Tk/FocusOK.al | 36 - .../tlperl/lib/auto/Tk/Frame/AddScrollbars.al | 52 - Master/tlpkg/tlperl/lib/auto/Tk/Frame/FindMenu.al | 22 - Master/tlpkg/tlperl/lib/auto/Tk/Frame/autosplit.ix | 24 - .../tlperl/lib/auto/Tk/Frame/freeze_on_map.al | 18 - Master/tlpkg/tlperl/lib/auto/Tk/Frame/label.al | 24 - Master/tlpkg/tlperl/lib/auto/Tk/Frame/labelPack.al | 50 - .../tlperl/lib/auto/Tk/Frame/labelVariable.al | 27 - .../tlperl/lib/auto/Tk/Frame/packscrollbars.al | 86 - Master/tlpkg/tlperl/lib/auto/Tk/Frame/queuePack.al | 18 - Master/tlpkg/tlperl/lib/auto/Tk/Frame/sbset.al | 15 - .../tlpkg/tlperl/lib/auto/Tk/Frame/scrollbars.al | 24 - Master/tlpkg/tlperl/lib/auto/Tk/HList/HList.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/HList/HList.dll | Bin 51712 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/IO/IO.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/IO/IO.dll | Bin 11264 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/ImageNames.al | 13 - Master/tlpkg/tlperl/lib/auto/Tk/ImageTypes.al | 13 - Master/tlpkg/tlperl/lib/auto/Tk/JPEG/JPEG.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/JPEG/JPEG.dll | Bin 118784 -> 0 bytes .../tlpkg/tlperl/lib/auto/Tk/Listbox/AutoScan.al | 49 - .../tlperl/lib/auto/Tk/Listbox/BeginExtend.al | 34 - .../tlperl/lib/auto/Tk/Listbox/BeginSelect.al | 46 - .../tlperl/lib/auto/Tk/Listbox/BeginToggle.al | 40 - .../tlperl/lib/auto/Tk/Listbox/ButtonRelease_1.al | 16 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/CLEAR.al | 16 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Cancel.al | 42 - .../tlpkg/tlperl/lib/auto/Tk/Listbox/Cntrl_End.al | 19 - .../tlpkg/tlperl/lib/auto/Tk/Listbox/Cntrl_Home.al | 19 - .../tlperl/lib/auto/Tk/Listbox/Cntrl_backslash.al | 19 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/DELETE.al | 19 - .../tlpkg/tlperl/lib/auto/Tk/Listbox/DataExtend.al | 39 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/EXISTS.al | 16 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/EXTEND.al | 16 - .../tlperl/lib/auto/Tk/Listbox/ExtendUpDown.al | 36 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/FETCH.al | 56 - .../tlpkg/tlperl/lib/auto/Tk/Listbox/FETCHSIZE.al | 16 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Listbox.bs | 0 .../tlpkg/tlperl/lib/auto/Tk/Listbox/Listbox.dll | Bin 31232 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Motion.al | 77 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/POP.al | 19 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/PUSH.al | 13 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SHIFT.al | 19 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SPLICE.al | 84 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/STORE.al | 80 - .../tlpkg/tlperl/lib/auto/Tk/Listbox/SelectAll.al | 32 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SetList.al | 16 - .../tlpkg/tlperl/lib/auto/Tk/Listbox/TIEARRAY.al | 15 - .../tlpkg/tlperl/lib/auto/Tk/Listbox/TIESCALAR.al | 15 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/UNSHIFT.al | 16 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/UpDown.al | 41 - .../tlpkg/tlperl/lib/auto/Tk/Listbox/autosplit.ix | 56 - .../tlperl/lib/auto/Tk/Listbox/clipboardPaste.al | 21 - .../tlperl/lib/auto/Tk/Listbox/deleteSelected.al | 18 - .../tlperl/lib/auto/Tk/Listbox/getSelected.al | 24 - Master/tlpkg/tlperl/lib/auto/Tk/Listbox/xyIndex.al | 29 - .../tlperl/lib/auto/Tk/Menubutton/Menubutton.bs | 0 .../tlperl/lib/auto/Tk/Menubutton/Menubutton.dll | Bin 20992 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/NBFrame/NBFrame.bs | 0 .../tlpkg/tlperl/lib/auto/Tk/NBFrame/NBFrame.dll | Bin 22016 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/PNG/PNG.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/PNG/PNG.dll | Bin 168960 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/Pixmap/Pixmap.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Pixmap/Pixmap.dll | Bin 27136 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/Receive.al | 23 - Master/tlpkg/tlperl/lib/auto/Tk/RepeatId.al | 16 - Master/tlpkg/tlperl/lib/auto/Tk/Scale/Activate.al | 33 - .../tlpkg/tlperl/lib/auto/Tk/Scale/ButtonDown.al | 40 - Master/tlpkg/tlperl/lib/auto/Tk/Scale/ButtonUp.al | 16 - .../tlpkg/tlperl/lib/auto/Tk/Scale/ControlPress.al | 31 - Master/tlpkg/tlperl/lib/auto/Tk/Scale/Drag.al | 29 - Master/tlpkg/tlperl/lib/auto/Tk/Scale/EndDrag.al | 23 - Master/tlpkg/tlperl/lib/auto/Tk/Scale/Enter.al | 19 - Master/tlpkg/tlperl/lib/auto/Tk/Scale/Increment.al | 61 - Master/tlpkg/tlperl/lib/auto/Tk/Scale/Leave.al | 15 - Master/tlpkg/tlperl/lib/auto/Tk/Scale/Scale.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Scale.dll | Bin 24576 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/Scale/autosplit.ix | 22 - .../tlperl/lib/auto/Tk/Scrollbar/ButtonDown.al | 55 - .../tlpkg/tlperl/lib/auto/Tk/Scrollbar/ButtonUp.al | 26 - Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Drag.al | 43 - .../tlpkg/tlperl/lib/auto/Tk/Scrollbar/EndDrag.al | 28 - Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Enter.al | 21 - Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Leave.al | 18 - .../tlpkg/tlperl/lib/auto/Tk/Scrollbar/Motion.al | 15 - .../tlperl/lib/auto/Tk/Scrollbar/ScrlByPages.al | 38 - .../tlperl/lib/auto/Tk/Scrollbar/ScrlByUnits.al | 37 - .../tlperl/lib/auto/Tk/Scrollbar/ScrlToPos.al | 35 - .../tlperl/lib/auto/Tk/Scrollbar/ScrlTopBottom.al | 32 - .../tlperl/lib/auto/Tk/Scrollbar/Scrollbar.bs | 0 .../tlperl/lib/auto/Tk/Scrollbar/Scrollbar.dll | Bin 21504 -> 0 bytes .../tlpkg/tlperl/lib/auto/Tk/Scrollbar/Select.al | 59 - .../tlperl/lib/auto/Tk/Scrollbar/StartDrag.al | 38 - .../tlperl/lib/auto/Tk/Scrollbar/autosplit.ix | 30 - Master/tlpkg/tlperl/lib/auto/Tk/Selection.al | 18 - Master/tlpkg/tlperl/lib/auto/Tk/TList/TList.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/TList/TList.dll | Bin 28672 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/Table/Create.al | 17 - Master/tlpkg/tlperl/lib/auto/Tk/Table/Posn.al | 15 - Master/tlpkg/tlperl/lib/auto/Tk/Table/autosplit.ix | 14 - Master/tlpkg/tlperl/lib/auto/Tk/Table/see.al | 46 - .../tlpkg/tlperl/lib/auto/Tk/Table/totalColumns.al | 13 - Master/tlpkg/tlperl/lib/auto/Tk/Table/totalRows.al | 13 - Master/tlpkg/tlperl/lib/auto/Tk/Text/Text.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Text/Text.dll | Bin 114176 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/Text/autosplit.ix | 3 - .../tlpkg/tlperl/lib/auto/Tk/TextEdit/autosplit.ix | 3 - .../tlpkg/tlperl/lib/auto/Tk/TextUndo/autosplit.ix | 3 - Master/tlpkg/tlperl/lib/auto/Tk/TixGrid/TixGrid.bs | 0 .../tlpkg/tlperl/lib/auto/Tk/TixGrid/TixGrid.dll | Bin 52224 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/Tk.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Tk.dll | Bin 804864 -> 0 bytes .../tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_BindIn.al | 19 - .../tlperl/lib/auto/Tk/Toplevel/FG_BindOut.al | 20 - .../tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_Create.al | 56 - .../tlperl/lib/auto/Tk/Toplevel/FG_Destroy.al | 29 - Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_In.al | 24 - Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_Out.al | 32 - .../tlpkg/tlperl/lib/auto/Tk/Toplevel/autosplit.ix | 10 - Master/tlpkg/tlperl/lib/auto/Tk/TraverseToMenu.al | 27 - Master/tlpkg/tlperl/lib/auto/Tk/Widget/ASkludge.al | 30 - .../tlpkg/tlperl/lib/auto/Tk/Widget/autosplit.ix | 11 - Master/tlpkg/tlperl/lib/auto/Tk/Widget/bindDump.al | 87 - .../tlperl/lib/auto/Tk/Widget/clipboardKeysyms.al | 51 - Master/tlpkg/tlperl/lib/auto/Tk/Widget/pathname.al | 15 - Master/tlpkg/tlperl/lib/auto/Tk/Wm/AnchorAdjust.al | 17 - Master/tlpkg/tlperl/lib/auto/Tk/Wm/FullScreen.al | 29 - Master/tlpkg/tlperl/lib/auto/Tk/Wm/Popup.al | 50 - Master/tlpkg/tlperl/lib/auto/Tk/Wm/Post.al | 20 - Master/tlpkg/tlperl/lib/auto/Tk/Wm/autosplit.ix | 14 - Master/tlpkg/tlperl/lib/auto/Tk/Wm/iconposition.al | 24 - Master/tlpkg/tlperl/lib/auto/Tk/X/X.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/X/X.dll | Bin 25088 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/X/autosplit.ix | 3 - Master/tlpkg/tlperl/lib/auto/Tk/Xlib/Xlib.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Xlib/Xlib.dll | Bin 29696 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Tk/autosplit.ix | 45 - Master/tlpkg/tlperl/lib/auto/Tk/break.al | 13 - .../tlpkg/tlperl/lib/auto/Tk/focusFollowsMouse.al | 14 - Master/tlpkg/tlperl/lib/auto/Tk/focusNext.al | 45 - Master/tlpkg/tlperl/lib/auto/Tk/focusPrev.al | 65 - Master/tlpkg/tlperl/lib/auto/Tk/getEncoding.al | 43 - Master/tlpkg/tlperl/lib/auto/Tk/interps.al | 14 - Master/tlpkg/tlperl/lib/auto/Tk/lsearch.al | 19 - Master/tlpkg/tlperl/lib/auto/Tk/pTk/extralibs.ld | 1 - Master/tlpkg/tlperl/lib/auto/Tk/tabFocus.al | 13 - Master/tlpkg/tlperl/lib/auto/Tk/updateWidgets.al | 17 - Master/tlpkg/tlperl/lib/auto/Win32/API/API.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/API/API.dll | Bin 20480 -> 0 bytes .../tlperl/lib/auto/Win32/API/Callback/Callback.bs | 0 .../lib/auto/Win32/API/Callback/Callback.dll | Bin 16384 -> 0 bytes .../lib/auto/Win32/ChangeNotify/ChangeNotify.bs | 0 .../lib/auto/Win32/ChangeNotify/ChangeNotify.dll | Bin 11776 -> 0 bytes .../tlperl/lib/auto/Win32/Clipboard/Clipboard.bs | 0 .../tlperl/lib/auto/Win32/Clipboard/Clipboard.dll | Bin 20480 -> 0 bytes .../tlpkg/tlperl/lib/auto/Win32/Console/Console.bs | 0 .../tlperl/lib/auto/Win32/Console/Console.dll | Bin 47104 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Win32/Event/Event.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Event/Event.dll | Bin 12288 -> 0 bytes .../tlperl/lib/auto/Win32/EventLog/EventLog.bs | 0 .../tlperl/lib/auto/Win32/EventLog/EventLog.dll | Bin 25088 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Win32/File/File.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/File/File.dll | Bin 10240 -> 0 bytes .../lib/auto/Win32/FileSecurity/FileSecurity.bs | 0 .../lib/auto/Win32/FileSecurity/FileSecurity.dll | Bin 16384 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Win32/IPC/IPC.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/IPC/IPC.dll | Bin 13312 -> 0 bytes .../tlperl/lib/auto/Win32/Internet/Internet.bs | 0 .../tlperl/lib/auto/Win32/Internet/Internet.dll | Bin 51712 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Win32/Job/Job.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Job/Job.dll | Bin 25088 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Win32/Mutex/Mutex.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Mutex/Mutex.dll | Bin 10752 -> 0 bytes .../tlperl/lib/auto/Win32/NetAdmin/NetAdmin.bs | 0 .../tlperl/lib/auto/Win32/NetAdmin/NetAdmin.dll | Bin 57344 -> 0 bytes .../lib/auto/Win32/NetResource/NetResource.bs | 0 .../lib/auto/Win32/NetResource/NetResource.dll | Bin 25088 -> 0 bytes .../tlperl/lib/auto/Win32/NetResource/autosplit.ix | 3 - Master/tlpkg/tlperl/lib/auto/Win32/ODBC/ODBC.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/ODBC/ODBC.dll | Bin 141824 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Win32/OLE/OLE.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/OLE/OLE.dll | Bin 139264 -> 0 bytes .../tlpkg/tlperl/lib/auto/Win32/PerfLib/PerfLib.bs | 0 .../tlperl/lib/auto/Win32/PerfLib/PerfLib.dll | Bin 23040 -> 0 bytes .../tlperl/lib/auto/Win32/PerfLib/autosplit.ix | 3 - Master/tlpkg/tlperl/lib/auto/Win32/Pipe/Pipe.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Pipe/Pipe.dll | Bin 37376 -> 0 bytes .../tlpkg/tlperl/lib/auto/Win32/Process/Process.bs | 0 .../tlperl/lib/auto/Win32/Process/Process.dll | Bin 39424 -> 0 bytes .../tlperl/lib/auto/Win32/Registry/Registry.bs | 0 .../tlperl/lib/auto/Win32/Registry/Registry.dll | Bin 37376 -> 0 bytes .../tlperl/lib/auto/Win32/Semaphore/Semaphore.bs | 0 .../tlperl/lib/auto/Win32/Semaphore/Semaphore.dll | Bin 11264 -> 0 bytes .../tlpkg/tlperl/lib/auto/Win32/Service/Service.bs | 0 .../tlperl/lib/auto/Win32/Service/Service.dll | Bin 14848 -> 0 bytes .../tlperl/lib/auto/Win32/Shortcut/Shortcut.bs | 0 .../tlperl/lib/auto/Win32/Shortcut/Shortcut.dll | Bin 29184 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Win32/Sound/Sound.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Sound/Sound.dll | Bin 44544 -> 0 bytes Master/tlpkg/tlperl/lib/auto/Win32/Win32.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Win32.dll | Bin 21504 -> 0 bytes .../tlperl/lib/auto/Win32/WinError/WinError.bs | 0 .../tlperl/lib/auto/Win32/WinError/WinError.dll | Bin 67584 -> 0 bytes .../tlperl/lib/auto/Win32API/Registry/Registry.bs | 0 .../tlperl/lib/auto/Win32API/Registry/Registry.dll | Bin 181760 -> 0 bytes Master/tlpkg/tlperl/lib/auto/re/re.bs | 0 Master/tlpkg/tlperl/lib/auto/re/re.dll | Bin 138240 -> 0 bytes Master/tlpkg/tlperl/lib/base.pm | 226 - Master/tlpkg/tlperl/lib/bytes.pm | 88 - Master/tlpkg/tlperl/lib/bytes_heavy.pl | 40 - Master/tlpkg/tlperl/lib/constant.pm | 340 - Master/tlpkg/tlperl/lib/fields.pm | 319 - Master/tlpkg/tlperl/lib/lib.pm | 206 - Master/tlpkg/tlperl/lib/newgetopt.pl | 75 - Master/tlpkg/tlperl/lib/overload.pm | 1434 - Master/tlpkg/tlperl/lib/re.pm | 134 - Master/tlpkg/tlperl/lib/strict.pm | 136 - Master/tlpkg/tlperl/lib/subs.pm | 40 - Master/tlpkg/tlperl/lib/unicore/ArabicShaping.txt | 299 - Master/tlpkg/tlperl/lib/unicore/BidiMirroring.txt | 550 - Master/tlpkg/tlperl/lib/unicore/Blocks.txt | 172 - Master/tlpkg/tlperl/lib/unicore/Canonical.pl | 1042 - Master/tlpkg/tlperl/lib/unicore/CaseFolding.txt | 1064 - Master/tlpkg/tlperl/lib/unicore/CombiningClass.pl | 203 - .../tlperl/lib/unicore/CompositionExclusions.txt | 179 - Master/tlpkg/tlperl/lib/unicore/Decomposition.pl | 5366 ---- Master/tlpkg/tlperl/lib/unicore/EastAsianWidth.txt | 16368 ----------- Master/tlpkg/tlperl/lib/unicore/Exact.pl | 73 - .../tlperl/lib/unicore/HangulSyllableType.txt | 851 - Master/tlpkg/tlperl/lib/unicore/Index.txt | 4307 --- Master/tlpkg/tlperl/lib/unicore/Jamo.txt | 92 - Master/tlpkg/tlperl/lib/unicore/LineBreak.txt | 17169 ------------ Master/tlpkg/tlperl/lib/unicore/Name.pl | 16346 ----------- Master/tlpkg/tlperl/lib/unicore/NamedSequences.txt | 95 - Master/tlpkg/tlperl/lib/unicore/NamesList.txt | 27024 ------------------- .../lib/unicore/NormalizationCorrections.txt | 48 - Master/tlpkg/tlperl/lib/unicore/PVA.pl | 2044 -- Master/tlpkg/tlperl/lib/unicore/PropList.txt | 1049 - .../tlpkg/tlperl/lib/unicore/PropValueAliases.txt | 578 - Master/tlpkg/tlperl/lib/unicore/Properties | 350 - .../tlpkg/tlperl/lib/unicore/PropertyAliases.txt | 163 - Master/tlpkg/tlperl/lib/unicore/ReadMe.txt | 24 - Master/tlpkg/tlperl/lib/unicore/Scripts.txt | 1464 - Master/tlpkg/tlperl/lib/unicore/SpecialCasing.txt | 260 - .../tlperl/lib/unicore/StandardizedVariants.txt | 122 - Master/tlpkg/tlperl/lib/unicore/To/Digit.pl | 276 - Master/tlpkg/tlperl/lib/unicore/To/Fold.pl | 993 - Master/tlpkg/tlperl/lib/unicore/To/Lower.pl | 905 - Master/tlpkg/tlperl/lib/unicore/To/Title.pl | 966 - Master/tlpkg/tlperl/lib/unicore/To/Upper.pl | 989 - Master/tlpkg/tlperl/lib/unicore/UnicodeData.txt | 16351 ----------- Master/tlpkg/tlperl/lib/unicore/lib/bc/AL.pl | 34 - Master/tlpkg/tlperl/lib/unicore/lib/bc/AN.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/bc/B.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/bc/BN.pl | 22 - Master/tlpkg/tlperl/lib/unicore/lib/bc/CS.pl | 22 - Master/tlpkg/tlperl/lib/unicore/lib/bc/EN.pl | 19 - Master/tlpkg/tlperl/lib/unicore/lib/bc/ES.pl | 18 - Master/tlpkg/tlperl/lib/unicore/lib/bc/ET.pl | 27 - Master/tlpkg/tlperl/lib/unicore/lib/bc/L.pl | 400 - Master/tlpkg/tlperl/lib/unicore/lib/bc/LRE.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/bc/LRO.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/bc/NSM.pl | 131 - Master/tlpkg/tlperl/lib/unicore/lib/bc/ON.pl | 150 - Master/tlpkg/tlperl/lib/unicore/lib/bc/PDF.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/bc/R.pl | 36 - Master/tlpkg/tlperl/lib/unicore/lib/bc/RLE.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/bc/RLO.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/bc/S.pl | 12 - Master/tlpkg/tlperl/lib/unicore/lib/bc/WS.pl | 17 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/A.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/AL.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/AR.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/ATAR.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/ATB.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/ATBL.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/B.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/BL.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/BR.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/DA.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/DB.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/IS.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/KV.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/L.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/NK.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/NR.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/OV.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/R.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/ccc/VR.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/dt/can.pl | 222 - Master/tlpkg/tlperl/lib/unicore/lib/dt/com.pl | 820 - Master/tlpkg/tlperl/lib/unicore/lib/dt/enc.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/dt/fin.pl | 122 - Master/tlpkg/tlperl/lib/unicore/lib/dt/font.pl | 43 - Master/tlpkg/tlperl/lib/unicore/lib/dt/fra.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/dt/init.pl | 84 - Master/tlpkg/tlperl/lib/unicore/lib/dt/iso.pl | 107 - Master/tlpkg/tlperl/lib/unicore/lib/dt/med.pl | 63 - Master/tlpkg/tlperl/lib/unicore/lib/dt/nar.pl | 15 - Master/tlpkg/tlperl/lib/unicore/lib/dt/nb.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/dt/sml.pl | 12 - Master/tlpkg/tlperl/lib/unicore/lib/dt/sqr.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/dt/sub.pl | 12 - Master/tlpkg/tlperl/lib/unicore/lib/dt/sup.pl | 27 - Master/tlpkg/tlperl/lib/unicore/lib/dt/vert.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/dt/wide.pl | 12 - Master/tlpkg/tlperl/lib/unicore/lib/ea/A.pl | 168 - Master/tlpkg/tlperl/lib/unicore/lib/ea/F.pl | 12 - Master/tlpkg/tlperl/lib/unicore/lib/ea/H.pl | 16 - Master/tlpkg/tlperl/lib/unicore/lib/ea/N.pl | 540 - Master/tlpkg/tlperl/lib/unicore/lib/ea/Na.pl | 16 - Master/tlpkg/tlperl/lib/unicore/lib/ea/W.pl | 40 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/AHex.pl | 12 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/ASCII.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Alnum.pl | 448 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Alpha.pl | 430 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Alphabet.pl | 415 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Any.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Arab.pl | 29 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Armn.pl | 17 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/AsciiHex.pl | 15 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Assigned.pl | 432 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Beng.pl | 26 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/BidiC.pl | 11 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/BidiCont.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Blank.pl | 21 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Bopo.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Brai.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Bugi.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Buhd.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/C.pl | 435 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Canadian.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cc.pl | 15 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cf.pl | 27 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cher.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cn.pl | 433 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cntrl.pl | 31 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Co.pl | 16 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Copt.pl | 15 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cprt.pl | 18 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cs.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cyrl.pl | 18 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dash.pl | 25 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dash2.pl | 28 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dep.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Deprecat.pl | 16 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Deva.pl | 18 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dia.pl | 91 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Diacriti.pl | 94 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Digit.pl | 35 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dsrt.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ethi.pl | 39 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ext.pl | 21 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Extender.pl | 24 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Geor.pl | 16 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Glag.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Goth.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/GrLink.pl | 25 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Graph.pl | 436 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Grapheme.pl | 28 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Grek.pl | 43 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Gujr.pl | 26 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Guru.pl | 27 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hang.pl | 24 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hani.pl | 26 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hano.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hebr.pl | 22 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hex.pl | 15 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/HexDigit.pl | 18 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hira.pl | 14 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Hyphen.pl | 19 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Hyphen2.pl | 22 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IDSB.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IDST.pl | 10 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/IdContin.pl | 460 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/IdStart.pl | 364 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ideo.pl | 18 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Ideograp.pl | 21 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/IdsBinar.pl | 14 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/IdsTrina.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InAegean.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InAlphab.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InAncie2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InAncien.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabi2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabi3.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabi4.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabic.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InArmeni.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InArrows.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InBasicL.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InBengal.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InBlockE.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InBopom2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InBopomo.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InBoxDra.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InBraill.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InBugine.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InBuhid.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InByzant.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCherok.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCo2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCo3.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCo4.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCom.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkRad.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkStr.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkSym.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkUn2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkUn3.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkUni.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombi2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombi3.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombi4.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombin.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InContro.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCoptic.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCurren.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCyprio.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCyril2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InCyrill.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InDesere.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InDevana.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InDingba.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InEnclo2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InEnclos.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InEthio2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InEthio3.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InEthiop.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGenera.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGeomet.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGeorg2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGeorgi.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGlagol.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGothic.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGreekA.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGreekE.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGujara.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InGurmuk.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InHalfwi.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InHangu2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InHangu3.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InHangul.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InHanuno.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InHebrew.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InHighPr.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InHighSu.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InHiraga.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InIdeogr.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InIpaExt.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InKanbun.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InKangxi.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InKannad.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InKatak2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InKataka.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InKharos.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InKhmer.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InKhmerS.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLao.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatin1.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatin2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatin3.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatinE.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InLetter.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InLimbu.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InLinea2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InLinear.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InLowSur.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMalaya.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMathe2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMathem.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce3.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce4.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce5.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMiscel.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InModifi.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMongol.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMusica.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InMyanma.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InNewTai.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InNumber.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InOgham.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InOldIta.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InOldPer.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InOptica.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InOriya.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InOsmany.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InPhone2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InPhonet.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InPrivat.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InRunic.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InShavia.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSinhal.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSmallF.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSpacin.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSpecia.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSupers.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl3.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl4.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl5.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl6.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSupple.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSyloti.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InSyriac.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InTagalo.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InTagban.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InTags.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InTaiLe.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InTaiXua.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InTamil.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InTelugu.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InThaana.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InThai.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InTibeta.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InTifina.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InUgarit.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InUnifie.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InVaria2.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InVariat.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InVertic.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InYiRadi.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InYiSyll.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/InYijing.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/JoinC.pl | 10 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/JoinCont.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Kana.pl | 17 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Khar.pl | 20 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Khmr.pl | 16 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Knda.pl | 25 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/L.pl | 360 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LC.pl | 116 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LOE.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Laoo.pl | 30 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Latn.pl | 35 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Limb.pl | 17 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/LinearB.pl | 19 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ll.pl | 493 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lm.pl | 39 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lo.pl | 258 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/LogicalO.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lower.pl | 492 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Lowercas.pl | 497 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lt.pl | 23 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lu.pl | 489 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/M.pl | 146 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Math.pl | 103 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mc.pl | 76 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Me.pl | 17 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mlym.pl | 23 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mn.pl | 137 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mong.pl | 16 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mymr.pl | 18 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/N.pl | 66 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/NChar.pl | 27 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Nd.pl | 36 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/NewTaiLu.pl | 16 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Nl.pl | 21 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/No.pl | 39 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Nonchara.pl | 30 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OAlpha.pl | 108 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/ODI.pl | 19 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OGrExt.pl | 24 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OIDC.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OIDS.pl | 12 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OLower.pl | 20 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OMath.pl | 77 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OUpper.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ogam.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OldItali.pl | 14 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OldPersi.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Orya.pl | 26 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Osma.pl | 14 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherAlp.pl | 111 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherDef.pl | 22 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherGra.pl | 27 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherIdC.pl | 13 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherIdS.pl | 15 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherLow.pl | 23 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherMat.pl | 80 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherUpp.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/P.pl | 109 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/PatSyn.pl | 37 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/PatWS.pl | 14 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/PatternS.pl | 40 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/PatternW.pl | 17 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pc.pl | 19 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pd.pl | 25 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pe.pl | 78 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pf.pl | 22 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pi.pl | 23 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Po.pl | 101 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Print.pl | 435 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ps.pl | 80 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Punct.pl | 108 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/QMark.pl | 21 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Qaai.pl | 27 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Quotatio.pl | 24 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Radical.pl | 12 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Radical2.pl | 15 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Runr.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/S.pl | 175 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/SD.pl | 38 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/STerm.pl | 35 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sc.pl | 27 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Shaw.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sinh.pl | 23 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sk.pl | 36 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sm.pl | 72 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/So.pl | 133 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/SoftDott.pl | 41 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Space.pl | 23 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/SpacePer.pl | 24 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Sterm2.pl | 38 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/SylotiNa.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Syrc.pl | 15 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tagb.pl | 15 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/TaiLe.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Taml.pl | 27 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Telu.pl | 24 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Term.pl | 49 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Terminal.pl | 52 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tfng.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tglg.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Thaa.pl | 13 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Thai.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tibt.pl | 19 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Title.pl | 22 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/UIdeo.pl | 19 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ugar.pl | 14 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/UnifiedI.pl | 22 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Upper.pl | 488 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Uppercas.pl | 490 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/VS.pl | 12 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/Variatio.pl | 15 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/WSpace.pl | 20 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/WhiteSpa.pl | 23 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Word.pl | 476 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/XDigit.pl | 15 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Yiii.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Z.pl | 22 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zl.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zp.pl | 14 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zs.pl | 21 - Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zyyy.pl | 138 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/_CanonDC.pl | 16 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/_CaseIgn.pl | 138 - .../tlpkg/tlperl/lib/unicore/lib/gc_sc/_CombAbo.pl | 69 - Master/tlpkg/tlperl/lib/unicore/lib/hst/L.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/hst/LV.pl | 408 - Master/tlpkg/tlperl/lib/unicore/lib/hst/LVT.pl | 408 - Master/tlpkg/tlperl/lib/unicore/lib/hst/T.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/hst/V.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/jt/C.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/jt/D.pl | 33 - Master/tlpkg/tlperl/lib/unicore/lib/jt/R.pl | 34 - Master/tlpkg/tlperl/lib/unicore/lib/jt/U.pl | 15 - Master/tlpkg/tlperl/lib/unicore/lib/lb/AI.pl | 101 - Master/tlpkg/tlperl/lib/unicore/lib/lb/AL.pl | 449 - Master/tlpkg/tlperl/lib/unicore/lib/lb/B2.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/BA.pl | 45 - Master/tlpkg/tlperl/lib/unicore/lib/lb/BB.pl | 17 - Master/tlpkg/tlperl/lib/unicore/lib/lb/BK.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/lb/CB.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/CL.pl | 80 - Master/tlpkg/tlperl/lib/unicore/lib/lb/CM.pl | 155 - Master/tlpkg/tlperl/lib/unicore/lib/lb/CR.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/EX.pl | 25 - Master/tlpkg/tlperl/lib/unicore/lib/lb/GL.pl | 19 - Master/tlpkg/tlperl/lib/unicore/lib/lb/H2.pl | 408 - Master/tlpkg/tlperl/lib/unicore/lib/lb/H3.pl | 408 - Master/tlpkg/tlperl/lib/unicore/lib/lb/HY.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/ID.pl | 80 - Master/tlpkg/tlperl/lib/unicore/lib/lb/IN.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/lb/IS.pl | 18 - Master/tlpkg/tlperl/lib/unicore/lib/lb/JL.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/lb/JT.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/JV.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/LF.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/NL.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/NS.pl | 46 - Master/tlpkg/tlperl/lib/unicore/lib/lb/NU.pl | 32 - Master/tlpkg/tlperl/lib/unicore/lib/lb/OP.pl | 76 - Master/tlpkg/tlperl/lib/unicore/lib/lb/PO.pl | 21 - Master/tlpkg/tlperl/lib/unicore/lib/lb/PR.pl | 27 - Master/tlpkg/tlperl/lib/unicore/lib/lb/QU.pl | 21 - Master/tlpkg/tlperl/lib/unicore/lib/lb/SA.pl | 34 - Master/tlpkg/tlperl/lib/unicore/lib/lb/SG.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/SP.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/SY.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/lb/WJ.pl | 11 - Master/tlpkg/tlperl/lib/unicore/lib/lb/XX.pl | 12 - Master/tlpkg/tlperl/lib/unicore/lib/lb/ZW.pl | 10 - Master/tlpkg/tlperl/lib/unicore/lib/nt/De.pl | 32 - Master/tlpkg/tlperl/lib/unicore/lib/nt/Di.pl | 25 - Master/tlpkg/tlperl/lib/unicore/lib/nt/Nu.pl | 42 - Master/tlpkg/tlperl/lib/unicore/mktables | 2197 -- Master/tlpkg/tlperl/lib/unicore/mktables.lst | 505 - Master/tlpkg/tlperl/lib/unicore/version | 1 - Master/tlpkg/tlperl/lib/utf8.pm | 214 - Master/tlpkg/tlperl/lib/utf8_heavy.pl | 412 - Master/tlpkg/tlperl/lib/vars.pm | 82 - Master/tlpkg/tlperl/lib/warnings.pm | 497 - Master/tlpkg/tlperl/lib/warnings/register.pm | 51 - 2552 files changed, 290480 insertions(+), 290480 deletions(-) create mode 100644 Master/tlpkg/tlperl.old/README.TEXLIVE create mode 100755 Master/tlpkg/tlperl.old/bin/perl.exe create mode 100755 Master/tlpkg/tlperl.old/bin/perl.exe.manifest create mode 100755 Master/tlpkg/tlperl.old/bin/perl58.dll create mode 100644 Master/tlpkg/tlperl.old/lib/AnyDBM_File.pm create mode 100644 Master/tlpkg/tlperl.old/lib/AutoLoader.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Asmdata.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Assembler.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Bblock.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Bytecode.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/C.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/CC.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Concise.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Debug.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Deparse.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Disassembler.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Lint.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Showlex.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Stackobj.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Stash.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Terse.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/Xref.pm create mode 100644 Master/tlpkg/tlperl.old/lib/B/assemble create mode 100644 Master/tlpkg/tlperl.old/lib/B/cc_harness create mode 100644 Master/tlpkg/tlperl.old/lib/B/disassemble create mode 100644 Master/tlpkg/tlperl.old/lib/B/makeliblinks create mode 100644 Master/tlpkg/tlperl.old/lib/Carp.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Carp/Heavy.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Class/ISA.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Class/Struct.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Config.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Config_heavy.pl create mode 100644 Master/tlpkg/tlperl.old/lib/Cwd.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Data/Dumper.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Digest/MD5.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Digest/base.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Digest/file.pm create mode 100644 Master/tlpkg/tlperl.old/lib/DynaLoader.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Alias.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Byte.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/CJKConstants.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/CN.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/CN/HZ.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Changes.e2x create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Config.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/ConfigLocal_PM.e2x create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/EBCDIC.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Encoder.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Encoding.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Guess.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/JP.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/JP/H2Z.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/JP/JIS7.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/KR.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/KR/2022_KR.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/MIME/Header.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/MIME/Header/ISO_2022_JP.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Makefile_PL.e2x create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/PerlIO.pod create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/README.e2x create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Supported.pod create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Symbol.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/TW.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Unicode.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/Unicode/UTF7.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/_PM.e2x create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/_T.e2x create mode 100644 Master/tlpkg/tlperl.old/lib/Encode/encode.h create mode 100644 Master/tlpkg/tlperl.old/lib/Errno.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Exporter.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Exporter/Heavy.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Fcntl.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Basename.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/CheckTree.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Compare.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Copy.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/DosGlob.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Find.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Glob.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Path.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Spec.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Spec/Cygwin.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Spec/Epoc.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Spec/Functions.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Spec/Mac.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Spec/OS2.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Spec/Unix.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Spec/VMS.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Spec/Win32.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/Temp.pm create mode 100644 Master/tlpkg/tlperl.old/lib/File/stat.pm create mode 100644 Master/tlpkg/tlperl.old/lib/FileHandle.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Getopt/Long.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Getopt/Std.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/Dir.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/File.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/Handle.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/Pipe.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/Poll.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/Seekable.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/Select.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/Socket.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/Socket/INET.pm create mode 100644 Master/tlpkg/tlperl.old/lib/IO/Socket/UNIX.pm create mode 100755 Master/tlpkg/tlperl.old/lib/IO/String.pm create mode 100644 Master/tlpkg/tlperl.old/lib/List/Util.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Opcode.pm create mode 100644 Master/tlpkg/tlperl.old/lib/POSIX.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Checker.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Find.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Functions.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Html.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/InputObjects.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/LaTeX.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Man.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/ParseLink.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/ParseUtils.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Parser.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/BaseTo.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/GetOptsOO.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToChecker.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToMan.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToNroff.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToPod.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToRtf.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToText.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToTk.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Perldoc/ToXml.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/PlainText.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Plainer.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Select.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Text.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Text/Color.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Text/Overstrike.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Text/Termcap.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Pod/Usage.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Safe.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Scalar/Util.pm create mode 100644 Master/tlpkg/tlperl.old/lib/SelectSaver.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Symbol.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Term/ANSIColor.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Term/Cap.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Term/Complete.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Term/ReadLine.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Text/Abbrev.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Text/Balanced.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Text/ParseWords.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Text/Soundex.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Text/Tabs.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Text/Wrap.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tie/Array.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tie/File.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tie/Handle.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tie/Hash.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tie/Memoize.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tie/RefHash.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tie/Scalar.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tie/SubstrHash.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tie/Watch.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Time/HiRes.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Time/Local.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Time/gmtime.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Time/localtime.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Time/tm.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Adjuster.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/After.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Animation.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Balloon.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Bitmap.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/BrowseEntry.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Button.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Camel.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Canvas.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Checkbutton.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Clipboard.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/CmdLine.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/ColorEdit.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/ColorEditor.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Compound.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Config.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Configure.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Credits create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Derived.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Dialog.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DialogBox.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DirTree.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Dirlist.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Common.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/LocalDrop.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Rect.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunConst.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunDrop.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunSite.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Win32Drop.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Win32Site.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDDrop.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDSite.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DropSite.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/DummyEncode.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/English.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Entry.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/ErrorDialog.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Event.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Event/IO.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/FBox.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/FileSelect.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/FloatEntry.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Font.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Frame.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/HList.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/IO.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/IconList.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Image.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/ItemStyle.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/JPEG.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/LabEntry.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/LabFrame.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/LabRadio.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Label.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Labelframe.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Listbox.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/MMtry.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/MMutil.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/MainWindow.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/MakeDepend.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Menu.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Menu/Item.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Menubar.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Menubutton.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Message.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/NBFrame.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/NoteBook.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Optionmenu.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/PNG.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Pane.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Panedwindow.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Photo.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Pixmap.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Pretty.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/ProgressBar.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/README.Adjust create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/ROText.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Radiobutton.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Region.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Reindex.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/ReindexedROText.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/ReindexedText.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Scale.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Scrollbar.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Spinbox.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Stats.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Submethods.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/TList.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Table.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Text.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Text/Tag.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/TextEdit.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/TextList.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/TextUndo.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Tiler.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/TixGrid.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Tk.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Tk.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/TkXSUB.def create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Toplevel.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Trace.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Tree.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Widget.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Wm.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11/X.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11/Xatom.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11/Xfuncproto.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11/Xlib.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11/Xutil.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11/cursorfont.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11/keysym.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11/keysymdef.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11/license.terms create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/X11Font.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Xcamel.gif create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Xlib.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/Xrm.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/act_folder.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/act_folder.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/anim.gif create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/arrowdownwin.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/balArrow.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/cbxarrow.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/file.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/file.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/folder.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/folder.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/icon.gif create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/install.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/license.terms create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/openfile.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/openfolder.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/openfolder.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/prolog.ps create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/reindex.pl create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/srcfile.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/textfile.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/tkGlue.def create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/tkGlue.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/tkGlue.m create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/tkGlue.t create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/tkGlue_f.h create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/tranicon.gif create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/typemap create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/vtab.def create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/widgets.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/win.xbm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/winfolder.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/Tk/wintext.xpm create mode 100644 Master/tlpkg/tlperl.old/lib/UNIVERSAL.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/API.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/API.pm.orig create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/API/Callback.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/API/Struct.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/API/Test.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/API/Type.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/ChangeNotify.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Client.pl create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Clipboard.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Console.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Event.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/EventLog.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/File.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/FileSecurity.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/IPC.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Internet.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Job.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Mutex.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/NetAdmin.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/NetResource.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/ODBC.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/PerfLib.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Pipe.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Process.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Registry.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Semaphore.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Server.pl create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Service.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Shortcut.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Sound.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/Test.pl create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/TieRegistry.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/WinError.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32/test-async.pl create mode 100644 Master/tlpkg/tlperl.old/lib/Win32API/Registry.pm create mode 100644 Master/tlpkg/tlperl.old/lib/Win32API/Registry/cRegistry.pc create mode 100644 Master/tlpkg/tlperl.old/lib/XSLoader.pm create mode 100644 Master/tlpkg/tlperl.old/lib/attributes.pm create mode 100644 Master/tlpkg/tlperl.old/lib/auto/B/B.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/B/B.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/B/C/C.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/B/C/C.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Cwd/Cwd.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Cwd/Cwd.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Data/Dumper/Dumper.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Data/Dumper/Dumper.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Digest/MD5/MD5.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Digest/MD5/MD5.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/DynaLoader/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/DynaLoader/dl_expandspec.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/DynaLoader/dl_find_symbol_anywhere.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/DynaLoader/dl_findfile.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Encode/Byte/Byte.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Encode/Byte/Byte.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Encode/Encode.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Encode/Encode.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Encode/Symbol/Symbol.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Encode/Symbol/Symbol.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Encode/Unicode/Unicode.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Encode/Unicode/Unicode.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Fcntl/Fcntl.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Fcntl/Fcntl.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/File/Glob/Glob.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/File/Glob/Glob.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/IO/IO.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/IO/IO.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/List/Util/Util.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/List/Util/Util.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Opcode/Opcode.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Opcode/Opcode.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/POSIX.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/POSIX/POSIX.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/SigAction/flags.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/SigAction/handler.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/SigAction/mask.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/SigAction/safe.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/abs.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/alarm.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/assert.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/atan2.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/atexit.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/atof.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/atoi.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/atol.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/bsearch.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/calloc.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/chdir.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/chmod.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/chown.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/clearerr.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/closedir.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/cos.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/creat.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/div.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/errno.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/execl.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/execle.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/execlp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/execv.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/execve.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/execvp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/exit.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/exp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fabs.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fclose.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fcntl.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fdopen.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/feof.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/ferror.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fflush.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fgetc.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fgetpos.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fgets.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fileno.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fopen.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fork.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fprintf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fputc.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fputs.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fread.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/free.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/freopen.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fscanf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fseek.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fsetpos.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fstat.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fsync.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/ftell.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/fwrite.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getc.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getchar.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getegid.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getenv.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/geteuid.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getgid.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getgrgid.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getgrnam.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getgroups.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getlogin.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getpgrp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getpid.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getppid.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getpwnam.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getpwuid.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/gets.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/getuid.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/gmtime.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/isatty.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/kill.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/labs.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/ldiv.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/link.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/load_imports.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/localtime.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/log.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/longjmp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/malloc.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/memchr.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/memcmp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/memcpy.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/memmove.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/memset.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/mkdir.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/offsetof.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/opendir.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/perror.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/pow.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/printf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/putc.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/putchar.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/puts.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/qsort.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/raise.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/rand.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/readdir.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/realloc.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/redef.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/remove.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/rename.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/rewind.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/rewinddir.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/rmdir.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/scanf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/setbuf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/setjmp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/setvbuf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/siglongjmp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/sigsetjmp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/sin.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/sleep.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/sprintf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/sqrt.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/srand.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/sscanf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/stat.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strcat.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strchr.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strcmp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strcpy.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strcspn.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strerror.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strlen.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strncat.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strncmp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strncpy.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strpbrk.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strrchr.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strspn.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strstr.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/strtok.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/system.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/time.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/tmpfile.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/tolower.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/toupper.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/umask.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/ungetc.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/unimpl.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/unlink.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/usage.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/utime.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/vfprintf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/vprintf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/vsprintf.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/wait.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/POSIX/waitpid.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/SDBM_File/SDBM_File.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/SDBM_File/SDBM_File.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Time/HiRes/HiRes.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Time/HiRes/HiRes.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/CancelRepeat.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Canvas/Canvas.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Canvas/Canvas.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Clipboard/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Clipboard/getSelected.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Compound/Compound.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Compound/Compound.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/DragDrop/Win32Site/Win32Site.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/DragDrop/Win32Site/Win32Site.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/EnterFocus.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Entry/Entry.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Entry/Entry.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Error.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Event/Event.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Event/Event.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/FirstMenu.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/FocusChildren.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/FocusOK.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/AddScrollbars.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/FindMenu.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/freeze_on_map.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/label.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/labelPack.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/labelVariable.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/packscrollbars.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/queuePack.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/sbset.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Frame/scrollbars.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/HList/HList.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/HList/HList.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/IO/IO.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/IO/IO.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/ImageNames.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/ImageTypes.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/JPEG/JPEG.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/JPEG/JPEG.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/AutoScan.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/BeginExtend.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/BeginSelect.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/BeginToggle.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/ButtonRelease_1.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/CLEAR.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/Cancel.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/Cntrl_End.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/Cntrl_Home.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/Cntrl_backslash.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/DELETE.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/DataExtend.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/EXISTS.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/EXTEND.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/ExtendUpDown.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/FETCH.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/FETCHSIZE.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/Listbox.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/Listbox.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/Motion.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/POP.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/PUSH.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/SHIFT.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/SPLICE.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/STORE.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/SelectAll.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/SetList.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/TIEARRAY.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/TIESCALAR.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/UNSHIFT.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/UpDown.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/clipboardPaste.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/deleteSelected.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/getSelected.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Listbox/xyIndex.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Menubutton/Menubutton.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Menubutton/Menubutton.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/NBFrame/NBFrame.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/NBFrame/NBFrame.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/PNG/PNG.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/PNG/PNG.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Pixmap/Pixmap.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Pixmap/Pixmap.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Receive.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/RepeatId.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Activate.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/ButtonDown.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/ButtonUp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/ControlPress.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Drag.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/EndDrag.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Enter.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Increment.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Leave.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Scale.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/Scale.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scale/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/ButtonDown.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/ButtonUp.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/Drag.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/EndDrag.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/Enter.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/Leave.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/Motion.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/ScrlByPages.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/ScrlByUnits.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/ScrlToPos.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/ScrlTopBottom.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/Scrollbar.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/Scrollbar.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/Select.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/StartDrag.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Scrollbar/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Selection.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/TList/TList.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/TList/TList.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Table/Create.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Table/Posn.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Table/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Table/see.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Table/totalColumns.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Table/totalRows.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Text/Text.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Text/Text.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Text/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/TextEdit/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/TextUndo/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/TixGrid/TixGrid.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/TixGrid/TixGrid.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Tk.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Tk.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Toplevel/FG_BindIn.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Toplevel/FG_BindOut.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Toplevel/FG_Create.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Toplevel/FG_Destroy.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Toplevel/FG_In.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Toplevel/FG_Out.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Toplevel/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/TraverseToMenu.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Widget/ASkludge.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Widget/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Widget/bindDump.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Widget/clipboardKeysyms.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Widget/pathname.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Wm/AnchorAdjust.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Wm/FullScreen.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Wm/Popup.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Wm/Post.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Wm/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Wm/iconposition.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/X/X.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/X/X.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/X/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/Xlib/Xlib.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Tk/Xlib/Xlib.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/break.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/focusFollowsMouse.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/focusNext.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/focusPrev.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/getEncoding.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/interps.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/lsearch.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/pTk/extralibs.ld create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/tabFocus.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Tk/updateWidgets.al create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/API/API.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/API/API.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/API/Callback/Callback.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/API/Callback/Callback.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/ChangeNotify/ChangeNotify.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/ChangeNotify/ChangeNotify.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Clipboard/Clipboard.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Clipboard/Clipboard.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Console/Console.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Console/Console.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Event/Event.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Event/Event.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/EventLog/EventLog.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/EventLog/EventLog.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/File/File.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/File/File.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/FileSecurity/FileSecurity.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/FileSecurity/FileSecurity.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/IPC/IPC.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/IPC/IPC.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Internet/Internet.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Internet/Internet.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Job/Job.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Job/Job.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Mutex/Mutex.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Mutex/Mutex.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/NetAdmin/NetAdmin.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/NetAdmin/NetAdmin.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/NetResource/NetResource.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/NetResource/NetResource.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/NetResource/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/ODBC/ODBC.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/ODBC/ODBC.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/OLE/OLE.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/OLE/OLE.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/PerfLib/PerfLib.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/PerfLib/PerfLib.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/PerfLib/autosplit.ix create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Pipe/Pipe.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Pipe/Pipe.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Process/Process.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Process/Process.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Registry/Registry.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Registry/Registry.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Semaphore/Semaphore.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Semaphore/Semaphore.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Service/Service.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Service/Service.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Shortcut/Shortcut.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Shortcut/Shortcut.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Sound/Sound.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Sound/Sound.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/Win32.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/Win32.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32/WinError/WinError.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32/WinError/WinError.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/Win32API/Registry/Registry.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/Win32API/Registry/Registry.dll create mode 100644 Master/tlpkg/tlperl.old/lib/auto/re/re.bs create mode 100755 Master/tlpkg/tlperl.old/lib/auto/re/re.dll create mode 100644 Master/tlpkg/tlperl.old/lib/base.pm create mode 100644 Master/tlpkg/tlperl.old/lib/bytes.pm create mode 100644 Master/tlpkg/tlperl.old/lib/bytes_heavy.pl create mode 100644 Master/tlpkg/tlperl.old/lib/constant.pm create mode 100644 Master/tlpkg/tlperl.old/lib/fields.pm create mode 100644 Master/tlpkg/tlperl.old/lib/lib.pm create mode 100644 Master/tlpkg/tlperl.old/lib/newgetopt.pl create mode 100644 Master/tlpkg/tlperl.old/lib/overload.pm create mode 100644 Master/tlpkg/tlperl.old/lib/re.pm create mode 100644 Master/tlpkg/tlperl.old/lib/strict.pm create mode 100644 Master/tlpkg/tlperl.old/lib/subs.pm create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/ArabicShaping.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/BidiMirroring.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/Blocks.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/Canonical.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/CaseFolding.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/CombiningClass.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/CompositionExclusions.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/Decomposition.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/EastAsianWidth.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/Exact.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/HangulSyllableType.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/Index.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/Jamo.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/LineBreak.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/Name.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/NamedSequences.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/NamesList.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/NormalizationCorrections.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/PVA.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/PropList.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/PropValueAliases.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/Properties create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/PropertyAliases.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/ReadMe.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/Scripts.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/SpecialCasing.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/StandardizedVariants.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/To/Digit.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/To/Fold.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/To/Lower.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/To/Title.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/To/Upper.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/UnicodeData.txt create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/AL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/AN.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/B.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/BN.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/CS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/EN.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/ES.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/ET.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/L.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/LRE.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/LRO.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/NSM.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/ON.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/PDF.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/R.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/RLE.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/RLO.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/S.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/bc/WS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/A.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/AL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/AR.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/ATAR.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/ATB.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/ATBL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/B.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/BL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/BR.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/DA.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/DB.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/IS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/KV.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/L.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/NK.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/NR.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/OV.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/R.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ccc/VR.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/can.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/com.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/enc.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/fin.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/font.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/fra.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/init.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/iso.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/med.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/nar.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/nb.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/sml.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/sqr.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/sub.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/sup.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/vert.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/dt/wide.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ea/A.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ea/F.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ea/H.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ea/N.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ea/Na.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/ea/W.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/AHex.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/ASCII.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Alnum.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Alpha.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Alphabet.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Any.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Arab.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Armn.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/AsciiHex.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Assigned.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Beng.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/BidiC.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/BidiCont.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Blank.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Bopo.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Brai.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Bugi.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Buhd.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/C.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Canadian.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cc.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cf.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cher.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cn.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cntrl.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Co.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Copt.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cprt.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cs.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Cyrl.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Dash.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Dash2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Dep.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Deprecat.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Deva.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Dia.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Diacriti.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Digit.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Dsrt.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ethi.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ext.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Extender.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Geor.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Glag.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Goth.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/GrLink.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Graph.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Grapheme.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Grek.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Gujr.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Guru.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hang.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hani.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hano.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hebr.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hex.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/HexDigit.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hira.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hyphen.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Hyphen2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/IDSB.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/IDST.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/IdContin.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/IdStart.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ideo.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ideograp.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/IdsBinar.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/IdsTrina.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InAegean.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InAlphab.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InAncie2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InAncien.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InArabi2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InArabi3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InArabi4.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InArabic.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InArmeni.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InArrows.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InBasicL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InBengal.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InBlockE.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InBopom2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InBopomo.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InBoxDra.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InBraill.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InBugine.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InBuhid.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InByzant.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCherok.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkCo2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkCo3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkCo4.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkCom.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkRad.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkStr.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkSym.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkUn2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkUn3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCjkUni.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCombi2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCombi3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCombi4.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCombin.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InContro.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCoptic.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCurren.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCyprio.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCyril2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InCyrill.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InDesere.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InDevana.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InDingba.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InEnclo2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InEnclos.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InEthio2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InEthio3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InEthiop.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGenera.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGeomet.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGeorg2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGeorgi.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGlagol.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGothic.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGreekA.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGreekE.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGujara.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InGurmuk.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InHalfwi.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InHangu2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InHangu3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InHangul.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InHanuno.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InHebrew.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InHighPr.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InHighSu.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InHiraga.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InIdeogr.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InIpaExt.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InKanbun.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InKangxi.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InKannad.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InKatak2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InKataka.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InKharos.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InKhmer.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InKhmerS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLao.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLatin1.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLatin2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLatin3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLatinE.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLetter.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLimbu.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLinea2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLinear.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InLowSur.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMalaya.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMathe2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMathem.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMisce2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMisce3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMisce4.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMisce5.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMiscel.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InModifi.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMongol.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMusica.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InMyanma.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InNewTai.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InNumber.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InOgham.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InOldIta.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InOldPer.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InOptica.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InOriya.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InOsmany.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InPhone2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InPhonet.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InPrivat.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InRunic.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InShavia.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSinhal.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSmallF.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSpacin.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSpecia.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSupers.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSuppl2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSuppl3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSuppl4.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSuppl5.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSuppl6.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSupple.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSyloti.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InSyriac.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InTagalo.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InTagban.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InTags.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InTaiLe.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InTaiXua.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InTamil.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InTelugu.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InThaana.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InThai.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InTibeta.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InTifina.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InUgarit.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InUnifie.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InVaria2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InVariat.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InVertic.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InYiRadi.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InYiSyll.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/InYijing.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/JoinC.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/JoinCont.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Kana.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Khar.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Khmr.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Knda.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/L.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/LC.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/LOE.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Laoo.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Latn.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Limb.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/LinearB.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ll.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lm.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lo.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/LogicalO.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lower.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lowercas.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lt.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Lu.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/M.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Math.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mc.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Me.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mlym.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mn.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mong.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Mymr.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/N.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/NChar.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Nd.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/NewTaiLu.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Nl.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/No.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Nonchara.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OAlpha.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/ODI.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OGrExt.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OIDC.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OIDS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OLower.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OMath.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OUpper.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ogam.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OldItali.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OldPersi.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Orya.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Osma.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OtherAlp.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OtherDef.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OtherGra.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OtherIdC.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OtherIdS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OtherLow.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OtherMat.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/OtherUpp.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/P.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/PatSyn.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/PatWS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/PatternS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/PatternW.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pc.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pd.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pe.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pf.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Pi.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Po.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Print.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ps.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Punct.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/QMark.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Qaai.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Quotatio.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Radical.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Radical2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Runr.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/S.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/SD.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/STerm.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Sc.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Shaw.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Sinh.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Sk.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Sm.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/So.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/SoftDott.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Space.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/SpacePer.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Sterm2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/SylotiNa.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Syrc.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Tagb.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/TaiLe.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Taml.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Telu.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Term.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Terminal.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Tfng.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Tglg.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Thaa.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Thai.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Tibt.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Title.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/UIdeo.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Ugar.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/UnifiedI.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Upper.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Uppercas.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/VS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Variatio.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/WSpace.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/WhiteSpa.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Word.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/XDigit.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Yiii.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Z.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Zl.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Zp.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Zs.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/Zyyy.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/_CanonDC.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/_CaseIgn.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/gc_sc/_CombAbo.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/hst/L.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/hst/LV.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/hst/LVT.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/hst/T.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/hst/V.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/jt/C.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/jt/D.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/jt/R.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/jt/U.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/AI.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/AL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/B2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/BA.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/BB.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/BK.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/CB.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/CL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/CM.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/CR.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/EX.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/GL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/H2.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/H3.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/HY.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/ID.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/IN.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/IS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/JL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/JT.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/JV.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/LF.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/NL.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/NS.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/NU.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/OP.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/PO.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/PR.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/QU.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/SA.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/SG.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/SP.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/SY.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/WJ.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/XX.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/lb/ZW.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/nt/De.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/nt/Di.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/lib/nt/Nu.pl create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/mktables create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/mktables.lst create mode 100644 Master/tlpkg/tlperl.old/lib/unicore/version create mode 100644 Master/tlpkg/tlperl.old/lib/utf8.pm create mode 100644 Master/tlpkg/tlperl.old/lib/utf8_heavy.pl create mode 100644 Master/tlpkg/tlperl.old/lib/vars.pm create mode 100644 Master/tlpkg/tlperl.old/lib/warnings.pm create mode 100644 Master/tlpkg/tlperl.old/lib/warnings/register.pm delete mode 100644 Master/tlpkg/tlperl/README.TEXLIVE delete mode 100755 Master/tlpkg/tlperl/bin/perl.exe delete mode 100755 Master/tlpkg/tlperl/bin/perl.exe.manifest delete mode 100755 Master/tlpkg/tlperl/bin/perl58.dll delete mode 100644 Master/tlpkg/tlperl/lib/AnyDBM_File.pm delete mode 100644 Master/tlpkg/tlperl/lib/AutoLoader.pm delete mode 100644 Master/tlpkg/tlperl/lib/B.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Asmdata.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Assembler.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Bblock.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Bytecode.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/C.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/CC.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Concise.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Debug.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Deparse.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Disassembler.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Lint.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Showlex.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Stackobj.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Stash.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Terse.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/Xref.pm delete mode 100644 Master/tlpkg/tlperl/lib/B/assemble delete mode 100644 Master/tlpkg/tlperl/lib/B/cc_harness delete mode 100644 Master/tlpkg/tlperl/lib/B/disassemble delete mode 100644 Master/tlpkg/tlperl/lib/B/makeliblinks delete mode 100644 Master/tlpkg/tlperl/lib/Carp.pm delete mode 100644 Master/tlpkg/tlperl/lib/Carp/Heavy.pm delete mode 100644 Master/tlpkg/tlperl/lib/Class/ISA.pm delete mode 100644 Master/tlpkg/tlperl/lib/Class/Struct.pm delete mode 100644 Master/tlpkg/tlperl/lib/Config.pm delete mode 100644 Master/tlpkg/tlperl/lib/Config_heavy.pl delete mode 100644 Master/tlpkg/tlperl/lib/Cwd.pm delete mode 100644 Master/tlpkg/tlperl/lib/Data/Dumper.pm delete mode 100644 Master/tlpkg/tlperl/lib/Digest/MD5.pm delete mode 100644 Master/tlpkg/tlperl/lib/Digest/base.pm delete mode 100644 Master/tlpkg/tlperl/lib/Digest/file.pm delete mode 100644 Master/tlpkg/tlperl/lib/DynaLoader.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Alias.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Byte.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/CJKConstants.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/CN.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/CN/HZ.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Changes.e2x delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Config.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/ConfigLocal_PM.e2x delete mode 100644 Master/tlpkg/tlperl/lib/Encode/EBCDIC.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Encoder.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Encoding.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Guess.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/JP.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/JP/H2Z.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/JP/JIS7.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/KR.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/KR/2022_KR.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/MIME/Header.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/MIME/Header/ISO_2022_JP.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Makefile_PL.e2x delete mode 100644 Master/tlpkg/tlperl/lib/Encode/PerlIO.pod delete mode 100644 Master/tlpkg/tlperl/lib/Encode/README.e2x delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Supported.pod delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Symbol.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/TW.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Unicode.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/Unicode/UTF7.pm delete mode 100644 Master/tlpkg/tlperl/lib/Encode/_PM.e2x delete mode 100644 Master/tlpkg/tlperl/lib/Encode/_T.e2x delete mode 100644 Master/tlpkg/tlperl/lib/Encode/encode.h delete mode 100644 Master/tlpkg/tlperl/lib/Errno.pm delete mode 100644 Master/tlpkg/tlperl/lib/Exporter.pm delete mode 100644 Master/tlpkg/tlperl/lib/Exporter/Heavy.pm delete mode 100644 Master/tlpkg/tlperl/lib/Fcntl.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Basename.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/CheckTree.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Compare.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Copy.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/DosGlob.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Find.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Glob.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Path.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Spec.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Functions.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Mac.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Spec/OS2.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Unix.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Spec/VMS.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Win32.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/Temp.pm delete mode 100644 Master/tlpkg/tlperl/lib/File/stat.pm delete mode 100644 Master/tlpkg/tlperl/lib/FileHandle.pm delete mode 100644 Master/tlpkg/tlperl/lib/Getopt/Long.pm delete mode 100644 Master/tlpkg/tlperl/lib/Getopt/Std.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/Dir.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/File.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/Handle.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/Pipe.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/Poll.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/Seekable.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/Select.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/Socket.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/Socket/INET.pm delete mode 100644 Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm delete mode 100755 Master/tlpkg/tlperl/lib/IO/String.pm delete mode 100644 Master/tlpkg/tlperl/lib/List/Util.pm delete mode 100644 Master/tlpkg/tlperl/lib/Opcode.pm delete mode 100644 Master/tlpkg/tlperl/lib/POSIX.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Checker.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Find.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Functions.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Html.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/InputObjects.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/LaTeX.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Man.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/ParseLink.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Parser.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/PlainText.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Plainer.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Select.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Text.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Text/Color.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm delete mode 100644 Master/tlpkg/tlperl/lib/Pod/Usage.pm delete mode 100644 Master/tlpkg/tlperl/lib/Safe.pm delete mode 100644 Master/tlpkg/tlperl/lib/Scalar/Util.pm delete mode 100644 Master/tlpkg/tlperl/lib/SelectSaver.pm delete mode 100644 Master/tlpkg/tlperl/lib/Symbol.pm delete mode 100644 Master/tlpkg/tlperl/lib/Term/ANSIColor.pm delete mode 100644 Master/tlpkg/tlperl/lib/Term/Cap.pm delete mode 100644 Master/tlpkg/tlperl/lib/Term/Complete.pm delete mode 100644 Master/tlpkg/tlperl/lib/Term/ReadLine.pm delete mode 100644 Master/tlpkg/tlperl/lib/Text/Abbrev.pm delete mode 100644 Master/tlpkg/tlperl/lib/Text/Balanced.pm delete mode 100644 Master/tlpkg/tlperl/lib/Text/ParseWords.pm delete mode 100644 Master/tlpkg/tlperl/lib/Text/Soundex.pm delete mode 100644 Master/tlpkg/tlperl/lib/Text/Tabs.pm delete mode 100644 Master/tlpkg/tlperl/lib/Text/Wrap.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tie/Array.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tie/File.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tie/Handle.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tie/Hash.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tie/Memoize.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tie/RefHash.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tie/Scalar.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tie/SubstrHash.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tie/Watch.pm delete mode 100644 Master/tlpkg/tlperl/lib/Time/HiRes.pm delete mode 100644 Master/tlpkg/tlperl/lib/Time/Local.pm delete mode 100644 Master/tlpkg/tlperl/lib/Time/gmtime.pm delete mode 100644 Master/tlpkg/tlperl/lib/Time/localtime.pm delete mode 100644 Master/tlpkg/tlperl/lib/Time/tm.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Adjuster.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/After.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Animation.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Balloon.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Bitmap.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Button.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Camel.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Canvas.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Clipboard.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/CmdLine.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Compound.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Config.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Configure.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Credits delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Derived.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Dialog.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DialogBox.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DirTree.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Dirlist.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DropSite.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/English.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Entry.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Event.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Event/IO.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/FBox.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/FileSelect.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Font.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Frame.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/HList.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/IO.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/IconList.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Image.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/JPEG.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/LabEntry.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/LabFrame.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/LabRadio.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Label.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Labelframe.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Listbox.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/MMtry.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/MMutil.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/MainWindow.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Menu.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Menubar.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Menubutton.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Message.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/NBFrame.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/NoteBook.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/PNG.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Pane.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Photo.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Pixmap.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Pretty.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/README.Adjust delete mode 100644 Master/tlpkg/tlperl/lib/Tk/ROText.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Region.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Reindex.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Scale.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Spinbox.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Stats.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Submethods.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/TList.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Table.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Text.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/TextEdit.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/TextList.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/TextUndo.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Tiler.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/TixGrid.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Tk.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Tk.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/TkXSUB.def delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Toplevel.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Trace.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Tree.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Widget.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Wm.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/X.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/keysym.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/license.terms delete mode 100644 Master/tlpkg/tlperl/lib/Tk/X11Font.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Xcamel.gif delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Xlib.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/Xrm.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/act_folder.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/act_folder.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/anim.gif delete mode 100644 Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/balArrow.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/file.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/file.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/folder.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/folder.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/icon.gif delete mode 100644 Master/tlpkg/tlperl/lib/Tk/install.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/license.terms delete mode 100644 Master/tlpkg/tlperl/lib/Tk/openfile.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/openfolder.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/openfolder.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/prolog.ps delete mode 100644 Master/tlpkg/tlperl/lib/Tk/reindex.pl delete mode 100644 Master/tlpkg/tlperl/lib/Tk/srcfile.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/textfile.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue.def delete mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue.m delete mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue.t delete mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h delete mode 100644 Master/tlpkg/tlperl/lib/Tk/tranicon.gif delete mode 100644 Master/tlpkg/tlperl/lib/Tk/typemap delete mode 100644 Master/tlpkg/tlperl/lib/Tk/vtab.def delete mode 100644 Master/tlpkg/tlperl/lib/Tk/widgets.pm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/win.xbm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/winfolder.xpm delete mode 100644 Master/tlpkg/tlperl/lib/Tk/wintext.xpm delete mode 100644 Master/tlpkg/tlperl/lib/UNIVERSAL.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/API.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/API.pm.orig delete mode 100644 Master/tlpkg/tlperl/lib/Win32/API/Callback.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/API/Struct.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/API/Test.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/API/Type.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/ChangeNotify.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Client.pl delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Clipboard.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Console.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Event.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/EventLog.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/File.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/IPC.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Internet.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Job.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Mutex.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/NetAdmin.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/NetResource.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/ODBC.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/PerfLib.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Pipe.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Process.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Registry.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Semaphore.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Server.pl delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Service.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Shortcut.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Sound.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/Test.pl delete mode 100644 Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/WinError.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32/test-async.pl delete mode 100644 Master/tlpkg/tlperl/lib/Win32API/Registry.pm delete mode 100644 Master/tlpkg/tlperl/lib/Win32API/Registry/cRegistry.pc delete mode 100644 Master/tlpkg/tlperl/lib/XSLoader.pm delete mode 100644 Master/tlpkg/tlperl/lib/attributes.pm delete mode 100644 Master/tlpkg/tlperl/lib/auto/B/B.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/B/B.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/B/C/C.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/B/C/C.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Cwd/Cwd.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Cwd/Cwd.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Data/Dumper/Dumper.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Data/Dumper/Dumper.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Digest/MD5/MD5.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Digest/MD5/MD5.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/DynaLoader/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/DynaLoader/dl_expandspec.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/DynaLoader/dl_find_symbol_anywhere.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/DynaLoader/dl_findfile.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Encode/Byte/Byte.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Encode/Byte/Byte.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Encode/Encode.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Encode/Encode.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Encode/Symbol/Symbol.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Encode/Symbol/Symbol.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Encode/Unicode/Unicode.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Encode/Unicode/Unicode.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Fcntl/Fcntl.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Fcntl/Fcntl.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/File/Glob/Glob.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/File/Glob/Glob.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/IO/IO.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/IO/IO.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/List/Util/Util.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/List/Util/Util.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Opcode/Opcode.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/POSIX.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/POSIX/POSIX.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/SigAction/flags.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/SigAction/handler.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/SigAction/mask.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/SigAction/safe.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/abs.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/alarm.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/assert.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atan2.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atexit.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atof.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atoi.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atol.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/bsearch.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/calloc.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/chdir.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/chmod.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/chown.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/clearerr.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/closedir.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/cos.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/creat.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/div.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/errno.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execl.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execle.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execlp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execv.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execve.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execvp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/exit.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/exp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fabs.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fclose.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fcntl.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fdopen.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/feof.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/ferror.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fflush.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fgetc.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fgetpos.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fgets.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fileno.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fopen.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fork.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fprintf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fputc.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fputs.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fread.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/free.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/freopen.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fscanf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fseek.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fsetpos.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fstat.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fsync.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/ftell.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fwrite.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getc.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getchar.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getegid.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getenv.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/geteuid.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getgid.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getgrgid.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getgrnam.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getgroups.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getlogin.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getpgrp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getpid.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getppid.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getpwnam.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getpwuid.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/gets.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getuid.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/gmtime.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/isatty.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/kill.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/labs.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/ldiv.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/link.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/load_imports.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/localtime.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/log.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/longjmp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/malloc.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memchr.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memcmp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memcpy.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memmove.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memset.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/mkdir.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/offsetof.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/opendir.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/perror.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/pow.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/printf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/putc.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/putchar.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/puts.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/qsort.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/raise.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rand.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/readdir.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/realloc.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/redef.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/remove.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rename.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rewind.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rewinddir.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rmdir.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/scanf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/setbuf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/setjmp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/setvbuf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/siglongjmp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sigsetjmp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sin.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sleep.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sprintf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sqrt.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/srand.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sscanf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/stat.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strcat.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strchr.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strcmp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strcpy.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strcspn.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strerror.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strlen.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strncat.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strncmp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strncpy.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strpbrk.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strrchr.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strspn.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strstr.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strtok.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/system.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/time.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/tmpfile.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/tolower.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/toupper.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/umask.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/ungetc.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/unimpl.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/unlink.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/usage.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/utime.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/vfprintf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/vprintf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/vsprintf.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/wait.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/waitpid.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/SDBM_File/SDBM_File.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/SDBM_File/SDBM_File.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Time/HiRes/HiRes.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Time/HiRes/HiRes.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/CancelRepeat.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Canvas/Canvas.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Canvas/Canvas.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Clipboard/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Clipboard/getSelected.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Compound/Compound.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Compound/Compound.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/DragDrop/Win32Site/Win32Site.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/DragDrop/Win32Site/Win32Site.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/EnterFocus.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Entry/Entry.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Entry/Entry.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Error.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Event/Event.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Event/Event.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/FirstMenu.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/FocusChildren.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/FocusOK.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/AddScrollbars.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/FindMenu.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/freeze_on_map.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/label.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/labelPack.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/labelVariable.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/packscrollbars.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/queuePack.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/sbset.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/scrollbars.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/HList/HList.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/HList/HList.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/IO/IO.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/IO/IO.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/ImageNames.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/ImageTypes.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/JPEG/JPEG.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/JPEG/JPEG.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/AutoScan.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/BeginExtend.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/BeginSelect.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/BeginToggle.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/ButtonRelease_1.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/CLEAR.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Cancel.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Cntrl_End.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Cntrl_Home.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Cntrl_backslash.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/DELETE.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/DataExtend.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/EXISTS.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/EXTEND.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/ExtendUpDown.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/FETCH.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/FETCHSIZE.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Listbox.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Listbox.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Motion.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/POP.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/PUSH.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SHIFT.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SPLICE.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/STORE.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SelectAll.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SetList.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/TIEARRAY.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/TIESCALAR.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/UNSHIFT.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/UpDown.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/clipboardPaste.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/deleteSelected.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/getSelected.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/xyIndex.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Menubutton/Menubutton.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Menubutton/Menubutton.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/NBFrame/NBFrame.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/NBFrame/NBFrame.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/PNG/PNG.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/PNG/PNG.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Pixmap/Pixmap.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Pixmap/Pixmap.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Receive.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/RepeatId.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Activate.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/ButtonDown.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/ButtonUp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/ControlPress.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Drag.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/EndDrag.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Enter.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Increment.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Leave.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Scale.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Scale.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ButtonDown.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ButtonUp.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Drag.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/EndDrag.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Enter.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Leave.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Motion.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ScrlByPages.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ScrlByUnits.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ScrlToPos.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ScrlTopBottom.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Scrollbar.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Scrollbar.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Select.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/StartDrag.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Selection.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TList/TList.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/TList/TList.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/Create.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/Posn.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/see.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/totalColumns.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/totalRows.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Text/Text.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Text/Text.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Text/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TextEdit/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TextUndo/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TixGrid/TixGrid.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/TixGrid/TixGrid.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Tk.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Tk.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_BindIn.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_BindOut.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_Create.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_Destroy.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_In.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_Out.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TraverseToMenu.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/ASkludge.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/bindDump.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/clipboardKeysyms.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/pathname.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/AnchorAdjust.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/FullScreen.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/Popup.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/Post.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/iconposition.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/X/X.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/X/X.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/X/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Xlib/Xlib.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Xlib/Xlib.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/break.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/focusFollowsMouse.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/focusNext.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/focusPrev.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/getEncoding.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/interps.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/lsearch.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/pTk/extralibs.ld delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/tabFocus.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/updateWidgets.al delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/API/API.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/API/API.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/API/Callback/Callback.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/API/Callback/Callback.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/ChangeNotify/ChangeNotify.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/ChangeNotify/ChangeNotify.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Clipboard/Clipboard.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Clipboard/Clipboard.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Console/Console.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Console/Console.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Event/Event.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Event/Event.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/EventLog/EventLog.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/EventLog/EventLog.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/File/File.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/File/File.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/FileSecurity/FileSecurity.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/FileSecurity/FileSecurity.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/IPC/IPC.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/IPC/IPC.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Internet/Internet.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Internet/Internet.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Job/Job.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Job/Job.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Mutex/Mutex.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Mutex/Mutex.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/NetAdmin/NetAdmin.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/NetAdmin/NetAdmin.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/NetResource/NetResource.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/NetResource/NetResource.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/NetResource/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/ODBC/ODBC.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/ODBC/ODBC.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/OLE/OLE.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/OLE/OLE.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/PerfLib/PerfLib.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/PerfLib/PerfLib.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/PerfLib/autosplit.ix delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Pipe/Pipe.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Pipe/Pipe.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Process/Process.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Process/Process.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Registry/Registry.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Registry/Registry.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Semaphore/Semaphore.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Semaphore/Semaphore.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Service/Service.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Service/Service.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Shortcut/Shortcut.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Shortcut/Shortcut.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Sound/Sound.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Sound/Sound.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Win32.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Win32.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/WinError/WinError.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/WinError/WinError.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/Win32API/Registry/Registry.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/Win32API/Registry/Registry.dll delete mode 100644 Master/tlpkg/tlperl/lib/auto/re/re.bs delete mode 100755 Master/tlpkg/tlperl/lib/auto/re/re.dll delete mode 100644 Master/tlpkg/tlperl/lib/base.pm delete mode 100644 Master/tlpkg/tlperl/lib/bytes.pm delete mode 100644 Master/tlpkg/tlperl/lib/bytes_heavy.pl delete mode 100644 Master/tlpkg/tlperl/lib/constant.pm delete mode 100644 Master/tlpkg/tlperl/lib/fields.pm delete mode 100644 Master/tlpkg/tlperl/lib/lib.pm delete mode 100644 Master/tlpkg/tlperl/lib/newgetopt.pl delete mode 100644 Master/tlpkg/tlperl/lib/overload.pm delete mode 100644 Master/tlpkg/tlperl/lib/re.pm delete mode 100644 Master/tlpkg/tlperl/lib/strict.pm delete mode 100644 Master/tlpkg/tlperl/lib/subs.pm delete mode 100644 Master/tlpkg/tlperl/lib/unicore/ArabicShaping.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/BidiMirroring.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/Blocks.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/Canonical.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/CaseFolding.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/CombiningClass.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/CompositionExclusions.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/Decomposition.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/EastAsianWidth.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/Exact.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/HangulSyllableType.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/Index.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/Jamo.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/LineBreak.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/Name.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/NamedSequences.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/NamesList.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/NormalizationCorrections.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/PVA.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/PropList.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/PropValueAliases.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/Properties delete mode 100644 Master/tlpkg/tlperl/lib/unicore/PropertyAliases.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/ReadMe.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/Scripts.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/SpecialCasing.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/StandardizedVariants.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Digit.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Fold.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Lower.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Title.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Upper.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/UnicodeData.txt delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/AL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/AN.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/B.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/BN.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/CS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/EN.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/ES.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/ET.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/L.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/LRE.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/LRO.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/NSM.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/ON.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/PDF.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/R.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/RLE.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/RLO.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/S.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/WS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/A.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/AL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/AR.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/ATAR.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/ATB.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/ATBL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/B.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/BL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/BR.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/DA.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/DB.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/IS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/KV.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/L.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/NK.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/NR.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/OV.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/R.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/VR.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/can.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/com.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/enc.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/fin.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/font.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/fra.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/init.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/iso.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/med.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/nar.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/nb.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/sml.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/sqr.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/sub.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/sup.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/vert.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/wide.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/A.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/F.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/H.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/N.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/Na.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/W.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/AHex.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/ASCII.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Alnum.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Alpha.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Alphabet.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Any.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Arab.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Armn.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/AsciiHex.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Assigned.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Beng.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/BidiC.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/BidiCont.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Blank.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Bopo.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Brai.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Bugi.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Buhd.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/C.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Canadian.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cc.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cf.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cher.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cn.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cntrl.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Co.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Copt.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cprt.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cs.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cyrl.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dash.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dash2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dep.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Deprecat.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Deva.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dia.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Diacriti.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Digit.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dsrt.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ethi.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ext.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Extender.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Geor.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Glag.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Goth.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/GrLink.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Graph.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Grapheme.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Grek.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Gujr.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Guru.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hang.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hani.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hano.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hebr.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hex.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/HexDigit.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hira.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hyphen.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hyphen2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IDSB.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IDST.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IdContin.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IdStart.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ideo.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ideograp.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IdsBinar.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IdsTrina.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InAegean.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InAlphab.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InAncie2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InAncien.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabi2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabi3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabi4.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabic.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArmeni.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArrows.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBasicL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBengal.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBlockE.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBopom2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBopomo.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBoxDra.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBraill.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBugine.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBuhid.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InByzant.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCherok.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCo2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCo3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCo4.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCom.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkRad.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkStr.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkSym.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkUn2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkUn3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkUni.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombi2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombi3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombi4.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombin.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InContro.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCoptic.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCurren.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCyprio.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCyril2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCyrill.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InDesere.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InDevana.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InDingba.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEnclo2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEnclos.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEthio2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEthio3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEthiop.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGenera.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGeomet.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGeorg2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGeorgi.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGlagol.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGothic.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGreekA.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGreekE.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGujara.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGurmuk.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHalfwi.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHangu2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHangu3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHangul.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHanuno.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHebrew.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHighPr.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHighSu.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHiraga.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InIdeogr.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InIpaExt.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKanbun.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKangxi.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKannad.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKatak2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKataka.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKharos.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKhmer.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKhmerS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLao.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatin1.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatin2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatin3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatinE.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLetter.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLimbu.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLinea2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLinear.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLowSur.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMalaya.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMathe2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMathem.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce4.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce5.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMiscel.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InModifi.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMongol.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMusica.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMyanma.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InNewTai.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InNumber.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOgham.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOldIta.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOldPer.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOptica.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOriya.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOsmany.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InPhone2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InPhonet.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InPrivat.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InRunic.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InShavia.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSinhal.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSmallF.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSpacin.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSpecia.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSupers.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl4.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl5.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl6.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSupple.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSyloti.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSyriac.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTagalo.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTagban.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTags.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTaiLe.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTaiXua.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTamil.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTelugu.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InThaana.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InThai.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTibeta.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTifina.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InUgarit.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InUnifie.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InVaria2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InVariat.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InVertic.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InYiRadi.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InYiSyll.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InYijing.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/JoinC.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/JoinCont.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Kana.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Khar.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Khmr.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Knda.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/L.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LC.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LOE.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Laoo.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Latn.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Limb.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LinearB.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ll.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lm.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lo.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LogicalO.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lower.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lowercas.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lt.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lu.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/M.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Math.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mc.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Me.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mlym.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mn.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mong.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mymr.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/N.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/NChar.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Nd.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/NewTaiLu.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Nl.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/No.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Nonchara.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OAlpha.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/ODI.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OGrExt.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OIDC.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OIDS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OLower.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OMath.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OUpper.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ogam.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OldItali.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OldPersi.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Orya.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Osma.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherAlp.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherDef.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherGra.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherIdC.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherIdS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherLow.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherMat.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherUpp.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/P.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/PatSyn.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/PatWS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/PatternS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/PatternW.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pc.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pd.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pe.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pf.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pi.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Po.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Print.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ps.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Punct.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/QMark.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Qaai.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Quotatio.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Radical.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Radical2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Runr.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/S.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/SD.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/STerm.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sc.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Shaw.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sinh.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sk.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sm.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/So.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/SoftDott.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Space.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/SpacePer.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sterm2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/SylotiNa.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Syrc.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tagb.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/TaiLe.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Taml.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Telu.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Term.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Terminal.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tfng.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tglg.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Thaa.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Thai.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tibt.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Title.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/UIdeo.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ugar.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/UnifiedI.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Upper.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Uppercas.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/VS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Variatio.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/WSpace.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/WhiteSpa.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Word.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/XDigit.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Yiii.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Z.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zl.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zp.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zs.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zyyy.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/_CanonDC.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/_CaseIgn.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/_CombAbo.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/L.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/LV.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/LVT.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/T.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/V.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/jt/C.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/jt/D.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/jt/R.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/jt/U.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/AI.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/AL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/B2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/BA.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/BB.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/BK.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/CB.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/CL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/CM.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/CR.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/EX.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/GL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/H2.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/H3.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/HY.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/ID.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/IN.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/IS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/JL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/JT.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/JV.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/LF.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/NL.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/NS.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/NU.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/OP.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/PO.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/PR.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/QU.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/SA.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/SG.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/SP.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/SY.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/WJ.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/XX.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/ZW.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/nt/De.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/nt/Di.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/nt/Nu.pl delete mode 100644 Master/tlpkg/tlperl/lib/unicore/mktables delete mode 100644 Master/tlpkg/tlperl/lib/unicore/mktables.lst delete mode 100644 Master/tlpkg/tlperl/lib/unicore/version delete mode 100644 Master/tlpkg/tlperl/lib/utf8.pm delete mode 100644 Master/tlpkg/tlperl/lib/utf8_heavy.pl delete mode 100644 Master/tlpkg/tlperl/lib/vars.pm delete mode 100644 Master/tlpkg/tlperl/lib/warnings.pm delete mode 100644 Master/tlpkg/tlperl/lib/warnings/register.pm diff --git a/Master/tlpkg/tlperl.old/README.TEXLIVE b/Master/tlpkg/tlperl.old/README.TEXLIVE new file mode 100644 index 00000000000..1671e7674d5 --- /dev/null +++ b/Master/tlpkg/tlperl.old/README.TEXLIVE @@ -0,0 +1,21 @@ + +This directory contains a subset of the Perl 5.8.8 distribution +for Windows. The only purpose of this package is to support programs +shipped with TeX Live. It's not intended for general use. + +The executable files were compiled by Siep Kroonenberg with MinGW. + +Changes: + + * The documentation and many modules have been removed. + + * Some Windows specific modules have been added. + +This version of Perl will not be installed on your system and will not +interfere with other versions of Perl which might be installed already. + +If you need Perl for any other purpose than running the programs +provided by TeX Live, we recommand to install the full version which +can be downloaded from: + + http://www.perl.org diff --git a/Master/tlpkg/tlperl.old/bin/perl.exe b/Master/tlpkg/tlperl.old/bin/perl.exe new file mode 100755 index 00000000000..30108d9a8cc Binary files /dev/null and b/Master/tlpkg/tlperl.old/bin/perl.exe differ diff --git a/Master/tlpkg/tlperl.old/bin/perl.exe.manifest b/Master/tlpkg/tlperl.old/bin/perl.exe.manifest new file mode 100755 index 00000000000..c97b607769a --- /dev/null +++ b/Master/tlpkg/tlperl.old/bin/perl.exe.manifest @@ -0,0 +1,15 @@ + + + + + + + + + + + diff --git a/Master/tlpkg/tlperl.old/bin/perl58.dll b/Master/tlpkg/tlperl.old/bin/perl58.dll new file mode 100755 index 00000000000..d783261a862 Binary files /dev/null and b/Master/tlpkg/tlperl.old/bin/perl58.dll differ diff --git a/Master/tlpkg/tlperl.old/lib/AnyDBM_File.pm b/Master/tlpkg/tlperl.old/lib/AnyDBM_File.pm new file mode 100644 index 00000000000..d73abab0f9e --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/AnyDBM_File.pm @@ -0,0 +1,93 @@ +package AnyDBM_File; + +use 5.006_001; +our $VERSION = '1.00'; +our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; + +my $mod; +for $mod (@ISA) { + if (eval "require $mod") { + @ISA = ($mod); # if we leave @ISA alone, warnings abound + return 1; + } +} + +die "No DBM package was successfully found or installed"; +#return 0; + +=head1 NAME + +AnyDBM_File - provide framework for multiple DBMs + +NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations + +=head1 SYNOPSIS + + use AnyDBM_File; + +=head1 DESCRIPTION + +This module is a "pure virtual base class"--it has nothing of its own. +It's just there to inherit from one of the various DBM packages. It +prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See +L), 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. +Requires symbolic links. + +=item [3] + +By default, but can be redefined. + +=back + +=head1 SEE ALSO + +dbm(3), ndbm(3), DB_File(3), L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/AutoLoader.pm b/Master/tlpkg/tlperl.old/lib/AutoLoader.pm new file mode 100644 index 00000000000..4352d8b1fbe --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/AutoLoader.pm @@ -0,0 +1,343 @@ +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 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 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 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 module works with the B 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, the author of a module has to place the +definitions of subroutines to be autoloaded after an C<__END__> token. +(See L.) The B module can then be run manually to +extract the definitions into individual files F. + +B implements an AUTOLOAD subroutine. When an undefined +subroutine in is called in a client module of B, +B'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 is located in +F, B will look for perl +subroutines B in F, 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 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). See +L. Such forward declaration creates "subroutine +stubs", which are place holders with no code. + +The AutoSplit and B 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 is always +Cd and not Cd. + +=head2 Using B's AUTOLOAD Subroutine + +In order to use B's AUTOLOAD subroutine you I +explicitly import it: + + use AutoLoader 'AUTOLOAD'; + +=head2 Overriding B'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's AUTOLOAD for the rest. + +Such modules should I import B'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 at all. + +=head2 Package Lexicals + +Package lexicals declared with C in the main block of a package +using B 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. + +The C pragma (see L) 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 vs. B + +The B is similar in purpose to B: both delay the +loading of subroutines. + +B 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 suffers a +startup speed disadvantage in the one-time parsing of the lines after +C<__DATA__>, after which routines are cached. B can also +handle multiple packages in a file. + +B only reads code as it is requested, and in many cases +should be faster, but requires a mechanism like B be used to +create the individual files. L will invoke +B automatically if B 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 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 +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 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 the program +does C. + +=head1 SEE ALSO + +L - an autoloader that doesn't use external files. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B.pm b/Master/tlpkg/tlperl.old/lib/B.pm new file mode 100644 index 00000000000..12917347cd0 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B.pm @@ -0,0 +1,1111 @@ +# 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 "::" && &$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 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 module for the +user-visible part. The C 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 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 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, C, C, and C 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. + +=item sv_yes + +Returns the SV object corresponding to the C variable C. + +=item sv_no + +Returns the SV object corresponding to the C variable C. + +=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, 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. + +=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 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 (see below) has been called to turn debugging on then +the method C is called on each op before METHOD is +called. + +=item walkoptree_debug(DEBUG) + +Returns the current debugging flag for C. If the optional +DEBUG argument is non-zero, it sets the debugging flag to that. See +the description of C 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 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 +module as Perl objects of the appropriate class. + +The bulk of the C 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 stays +as-is since its abbreviation would clash with the "superclass" method +C (corresponding to the C function C). + +=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. This will be misleading +if C. Perhaps you want the +C method instead? + +=item IVX + +=item UVX + +=item int_value + +This method returns the value of the IV as an integer. +It differs from C 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, 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, C, C, C, C, C, +C, C, C, C, C. + +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 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 + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Asmdata.pm b/Master/tlpkg/tlperl.old/lib/B/Asmdata.pm new file mode 100644 index 00000000000..9e41d6dd757 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Asmdata.pm @@ -0,0 +1,250 @@ +# -#- 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 + +=cut + +# ex: set ro: diff --git a/Master/tlpkg/tlperl.old/lib/B/Assembler.pm b/Master/tlpkg/tlperl.old/lib/B/Assembler.pm new file mode 100644 index 00000000000..f312273ce36 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Assembler.pm @@ -0,0 +1,328 @@ +# 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 <(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. + +=head1 AUTHORS + +Malcolm Beattie, C +Per-statement interface by Benjamin Stuhl, C + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Bblock.pm b/Master/tlpkg/tlperl.old/lib/B/Bblock.pm new file mode 100644 index 00000000000..9566d125aaa --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Bblock.pm @@ -0,0 +1,224 @@ +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 + + 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 + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Bytecode.pm b/Master/tlpkg/tlperl.old/lib/B/Bytecode.pm new file mode 100644 index 00000000000..250569ae57b --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Bytecode.pm @@ -0,0 +1,889 @@ +# 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 ""; + 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[B<,-H>][B<,-o>I] I + +=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 +other files (ex. C) are saved. + +=item B<-H> + +prepend a C line to the produced bytecode. + +=item B<-k> + +keep the syntax tree - it is stripped by default. + +=item B<-o>I + +put the bytecode in instead of dumping it to STDOUT. + +=item B<-s> + +scan the script for C<# line ..> directives and for +expressions. When gotos are found keep the syntax tree. + +=back + +=head1 KNOWN BUGS + +=over 4 + +=item * + +C won't even compile. + +=item * + +C and C 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 and +modified by Benjamin Stuhl . + +Rewritten by Enache Adrian , 2003 a.d. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/C.pm b/Master/tlpkg/tlperl.old/lib/B/C.pm new file mode 100644 index 00000000000..cebf4132ffd --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/C.pm @@ -0,0 +1,2272 @@ +# 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 <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/, <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/, <add( split /\n/, <FILL + 1 - 1; # first is an avref + + print < $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 "::" && &$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) where package C does not contain any subs. + +=item B<-D> + +Debug options (concatenated or separate flags like C). + +=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. + +=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 lives in the C subdirectory of your perl +library directory. The utility called C 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 + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/CC.pm b/Master/tlpkg/tlperl.old/lib/B/CC.pm new file mode 100644 index 00000000000..079313a0a4e --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/CC.pm @@ -0,0 +1,2005 @@ +# 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 compiler backend--see F) 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) where package C 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). + +=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). + +=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 lives in the C subdirectory of your perl +library directory. The utility called C 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 + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Concise.pm b/Master/tlpkg/tlperl.old/lib/B/Concise.pm new file mode 100644 index 00000000000..c84578e44c4 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Concise.pm @@ -0,0 +1,1628 @@ +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 is displayed +my $big_endian = 1; # more 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! 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", "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 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). + +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). + + % 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, where I 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, +C, C, or C 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. The +basic mode is almost indistinguishable from the real B, and the +exec mode looks very similar, but is in a more logical order and lacks +curly brackets. B doesn't have a tree mode, so the tree mode +is only vaguely reminiscent of B. + +=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; these aren't +very concise at all. + +=item B<-env> + +Use formatting conventions read from the environment variables +C, C, and C. + +=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 + +Print OP sequence numbers in base I. If I is greater than 10, the +digit for 11 will be 'a', and so on. If I 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 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(>IB<;>IB<)x)> + +Generates I in exec mode, or I in basic mode. + +=item B<(*(>IB<)*)> + +Generates one copy of I for each indentation level. + +=item B<(*(>IB<;>IB<)*)> + +Generates one fewer copies of I than the indentation level, followed +by one copy of I if the indentation level is more than 0. + +=item B<(?(>IB<#>IIB<)?)> + +If the value of I is true (not empty or zero), generates the +value of I surrounded by I and I, 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 + +A property named 'var' is assumed to exist for the opcodes, and is +interpolated into the rendering. + +=item B<#>II + +Generates the value of I, left justified to fill I 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 + +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 below) that uses them. You can +also add new ones using L. + +=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 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 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 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, C, +C, C, C, 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 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 accepts options as described above in L, 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 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, altering style or mode/order + 2. call C + 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, Esmcc@CSUA.Berkeley.EDUE. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Debug.pm b/Master/tlpkg/tlperl.old/lib/B/Debug.pm new file mode 100644 index 00000000000..cb369682d66 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Debug.pm @@ -0,0 +1,305 @@ +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. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Deparse.pm b/Master/tlpkg/tlperl.old/lib/B/Deparse.pm new file mode 100644 index 00000000000..3db6fbe6e1f --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Deparse.pm @@ -0,0 +1,4642 @@ +# 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 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/(?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\\)(?'], ['{','}']) { + ($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 B<-MO=Deparse>[B<,-d>][B<,-f>I][B<,-p>][B<,-q>][B<,-l>] + [B<,-s>I][B<,-x>I] I + +=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 + +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 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. + +=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 + +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 + +Cuddle C, C, and C blocks. For example, print + + if (...) { + ... + } else { + ... + } + +instead of + + if (...) { + ... + } + else { + ... + } + +The default is not to cuddle. + +=item BI + +Indent lines by multiples of I columns. The default is 4 columns. + +=item B + +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 BIB<.> + +Print I 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 Boid 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 + +Expand conventional syntax constructions into equivalent ones that expose +their internal operation. I 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 is at least 3, C 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 is at least 5, C declarations will be translated into +C blocks containing calls to C and C; for +instance, + + use strict 'refs'; + +turns into + + sub BEGIN { + require strict; + do { + 'strict'->import('refs') + }; + } + +If I is at least 7, C statements will be translated into +equivalent expressions using C<&&>, C and C; 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 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. 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 method to describe the +assumptions you wish to make. + +Not all of the options currently have any useful effect. See +L 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 +pragma itself. Should you need to specify that some warnings are +fatal, and others are merely enabled, you can pass the B +parameter twice: + + $deparser->ambient_pragmas( + warnings => 'all', + warnings => [FATAL => qw/void io/], + ); + +See L 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, +C, C, and C. (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 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 print keyword calls as C.) + +=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 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 , based on an earlier version +by Malcolm Beattie , with contributions from +Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell, +Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael +Garcia-Suarez. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Disassembler.pm b/Master/tlpkg/tlperl.old/lib/B/Disassembler.pm new file mode 100644 index 00000000000..e1993aa9537 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Disassembler.pm @@ -0,0 +1,233 @@ +# 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. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Lint.pm b/Master/tlpkg/tlperl.old/lib/B/Lint.pm new file mode 100644 index 00000000000..3475bd2596e --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Lint.pm @@ -0,0 +1,392 @@ +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. It is named after the program F 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 and B options) is a +word representing one possible lint check (turning on that check) or +is B (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 + +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 silences the +warning. For example, + + $foo = scalar(@bar); + +=item B and B + +These options produce a warning whenever an operation implicitly +reads or (respectively) writes to one of Perl's special variables. +For example, B will warn about these: + + /foo/; + +and B will warn about these: + + s/foo/bar/; + +Both B and B warn about this: + + for (@a) { ... } + +=item B + +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 + +This option warns whenever C<$_> is used either explicitly anywhere or +as the implicit argument of a B statement. + +=item B + +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 + +This option warns whenever an undefined subroutine is invoked. +This option will only catch explicitly invoked subroutines such +as C and not indirect invocations such as C<&$subref()> +or C<$obj-Emeth()>. Note that some programs or modules delay +definition of subs until runtime by means of the AUTOLOAD +mechanism. + +=item B + +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 for +details. + +=item B + +Turn all warnings on. + +=item B + +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/tlperl.old/lib/B/Showlex.pm b/Master/tlpkg/tlperl.old/lib/B/Showlex.pm new file mode 100644 index 00000000000..3b261a337df --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Showlex.pm @@ -0,0 +1,205 @@ +package B::Showlex; + +our $VERSION = '1.02'; + +use strict; +use B qw(svref_2object comppadlist class); +use B::Terse (); +use B::Concise (); + +# +# Invoke as +# perl -MO=Showlex,foo bar.pl +# to see the names of lexical variables used by &foo +# or as +# perl -MO=Showlex bar.pl +# to see the names of file scope lexicals used by bar.pl +# + + +# borrowed from B::Concise +our $walkHandle = \*STDOUT; + +sub walk_output { # updates $walkHandle + $walkHandle = B::Concise::walk_output(@_); + #print "got $walkHandle"; + #print $walkHandle "using it"; + $walkHandle; +} + +sub shownamearray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print $walkHandle "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + my $sv = $els[$i]; + if (class($sv) ne "SPECIAL") { + printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + } else { + printf $walkHandle "$i: %s\n", $sv->terse; + #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); + } + } +} + +sub showvaluearray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print $walkHandle "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + printf $walkHandle "$i: %s\n", $els[$i]->terse; + #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]); + } +} + +sub showlex { + my ($objname, $namesav, $valsav) = @_; + shownamearray("Pad of lexical names for $objname", $namesav); + showvaluearray("Pad of lexical values for $objname", $valsav); +} + +my ($newlex, $nosp1); # rendering state vars + +sub newlex { # drop-in for showlex + my ($objname, $names, $vals) = @_; + my @names = $names->ARRAY; + my @vals = $vals->ARRAY; + my $count = @names; + print $walkHandle "$objname Pad has $count entries\n"; + printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1; + for (my $i = 1; $i < $count; $i++) { + printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse + unless $nosp1 and $names[$i]->terse =~ /SPECIAL/; + } +} + +sub showlex_obj { + my ($objname, $obj) = @_; + $objname =~ s/^&main::/&/; + showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex; + newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex; +} + +sub showlex_main { + showlex("comppadlist", comppadlist->ARRAY) if !$newlex; + newlex ("main", comppadlist->ARRAY) if $newlex; +} + +sub compile { + my @options = grep(/^-/, @_); + my @args = grep(!/^-/, @_); + for my $o (@options) { + $newlex = 1 if $o eq "-newlex"; + $nosp1 = 1 if $o eq "-nosp"; + } + + return \&showlex_main unless @args; + return sub { + my $objref; + foreach my $objname (@args) { + next unless $objname; # skip nulls w/o carping + + if (ref $objname) { + print $walkHandle "B::Showlex::compile($objname)\n"; + $objref = $objname; + } else { + $objname = "main::$objname" unless $objname =~ /::/; + print $walkHandle "$objname:\n"; + no strict 'refs'; + die "err: unknown function ($objname)\n" + unless *{$objname}{CODE}; + $objref = \&$objname; + } + showlex_obj($objname, $objref); + } + } +} + +1; + +__END__ + +=head1 NAME + +B::Showlex - Show lexical variables used in functions or files + +=head1 SYNOPSIS + + perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl + +=head1 DESCRIPTION + +When a comma-separated list of subroutine names is given as options, Showlex +prints the lexical variables used in those subroutines. Otherwise, it prints +the file-scope lexicals in the file. + +=head1 EXAMPLES + +Traditional form: + + $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")' + Pad of lexical names for comppadlist has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0x9db0fb0) $i + 2: PVNV (0x9db0f38) $j + 3: PVNV (0x9db0f50) $k + Pad of lexical values for comppadlist has 5 entries + 0: SPECIAL #1 &PL_sv_undef + 1: NULL (0x9da4234) + 2: NULL (0x9db0f2c) + 3: NULL (0x9db0f44) + 4: NULL (0x9da4264) + -e syntax OK + +New-style form: + + $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")' + main Pad has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234) + 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34) + 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c) + -e syntax OK + +New form, no specials, outside O framework: + + $ perl -MB::Showlex -e \ + 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()' + main Pad has 4 entries + 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1 + 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo" + 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74) + +Note that this example shows the values of the lexicals, whereas the other +examples did not (as they're compile-time only). + +=head2 OPTIONS + +The C<-newlex> option produces a more readable C<< name => value >> format, +and is shown in the second example above. + +The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL +#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm +your declared lexicals. + +=head1 SEE ALSO + +C can also be used outside of the O framework, as in the third +example. See C 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 + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Stackobj.pm b/Master/tlpkg/tlperl.old/lib/B/Stackobj.pm new file mode 100644 index 00000000000..b17dfb8173a --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Stackobj.pm @@ -0,0 +1,349 @@ +# 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. + +=head1 AUTHOR + +Malcolm Beattie, C + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Stash.pm b/Master/tlpkg/tlperl.old/lib/B/Stash.pm new file mode 100644 index 00000000000..5e60868a28e --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Stash.pm @@ -0,0 +1,52 @@ +# 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 ""?():$_;} @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/tlperl.old/lib/B/Terse.pm b/Master/tlpkg/tlperl.old/lib/B/Terse.pm new file mode 100644 index 00000000000..1d53950ad3b --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Terse.pm @@ -0,0 +1,103 @@ +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 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 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 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, +Embeattie@sable.ox.ac.ukE. This wrapper was written by Stephen +McCamant, Esmcc@MIT.EDUE. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/B/Xref.pm b/Master/tlpkg/tlperl.old/lib/B/Xref.pm new file mode 100644 index 00000000000..f727dc766b5 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/Xref.pm @@ -0,0 +1,430 @@ +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 section reports on a single file. Each B 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 of each variable, +subroutine or format with the special case "(lexicals)" meaning +lexical variables. Each B name (implicitly qualified by its +containing B) 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 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) 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 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 option prints the object on the top of the stack as it's +being tracked. The C 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/tlperl.old/lib/B/assemble b/Master/tlpkg/tlperl.old/lib/B/assemble new file mode 100644 index 00000000000..43cc5bc4b33 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/assemble @@ -0,0 +1,30 @@ +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/tlperl.old/lib/B/cc_harness b/Master/tlpkg/tlperl.old/lib/B/cc_harness new file mode 100644 index 00000000000..79f8727a8f0 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/cc_harness @@ -0,0 +1,12 @@ +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/tlperl.old/lib/B/disassemble b/Master/tlpkg/tlperl.old/lib/B/disassemble new file mode 100644 index 00000000000..6530b809502 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/disassemble @@ -0,0 +1,22 @@ +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/tlperl.old/lib/B/makeliblinks b/Master/tlpkg/tlperl.old/lib/B/makeliblinks new file mode 100644 index 00000000000..82560783c01 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/B/makeliblinks @@ -0,0 +1,54 @@ +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/tlperl.old/lib/Carp.pm b/Master/tlpkg/tlperl.old/lib/Carp.pm new file mode 100644 index 00000000000..1a814ead34f --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Carp.pm @@ -0,0 +1,274 @@ +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 works, by +changing some global variables in the C namespace. See the +section on C 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 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 in the PERL5OPT +environment variable. + +Alternately, you can set the global variable C<$Carp::Verbose> to true. +See the C section below. + +=cut + +# This package is heavily used. Be small. Be fast. Be good. + +# Comments added by Andy Wardley 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 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'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'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 use the C function at all times. +This effectively means that all calls to C become C and +all calls to C become C. + +Note, this is analogous to using C. + +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/tlperl.old/lib/Carp/Heavy.pm b/Master/tlpkg/tlperl.old/lib/Carp/Heavy.pm new file mode 100644 index 00000000000..55bca2b421a --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Carp/Heavy.pm @@ -0,0 +1,241 @@ +# 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/tlperl.old/lib/Class/ISA.pm b/Master/tlpkg/tlperl.old/lib/Class/ISA.pm new file mode 100644 index 00000000000..e1371912e2c --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Class/ISA.pm @@ -0,0 +1,214 @@ +#!/usr/local/bin/perl +# Time-stamp: "2004-12-29 20:01:02 AST" -*-Perl-*- + +package Class::ISA; +require 5; +use strict; +use vars qw($Debug $VERSION); +$VERSION = '0.33'; +$Debug = 0 unless defined $Debug; + +=head1 NAME + +Class::ISA -- report the search path for a class's ISA tree + +=head1 SYNOPSIS + + # Suppose you go: use Food::Fishstick, and that uses and + # inherits from other things, which in turn use and inherit + # from other things. And suppose, for sake of brevity of + # example, that their ISA tree is the same as: + + @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals); + @Food::Fish::ISA = qw(Food); + @Food::ISA = qw(Matter); + @Life::Fungus::ISA = qw(Life); + @Chemicals::ISA = qw(Matter); + @Life::ISA = qw(Matter); + @Matter::ISA = qw(); + + use Class::ISA; + print "Food::Fishstick path is:\n ", + join(", ", Class::ISA::super_path('Food::Fishstick')), + "\n"; + +That prints: + + Food::Fishstick path is: + Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals + +=head1 DESCRIPTION + +Suppose you have a class (like Food::Fish::Fishstick) that is derived, +via its @ISA, from one or more superclasses (as Food::Fish::Fishstick +is from Food::Fish, Life::Fungus, and Chemicals), and some of those +superclasses may themselves each be derived, via its @ISA, from one or +more superclasses (as above). + +When, then, you call a method in that class ($fishstick->calories), +Perl first searches there for that method, but if it's not there, it +goes searching in its superclasses, and so on, in a depth-first (or +maybe "height-first" is the word) search. In the above example, it'd +first look in Food::Fish, then Food, then Matter, then Life::Fungus, +then Life, then Chemicals. + +This library, Class::ISA, provides functions that return that list -- +the list (in order) of names of classes Perl would search to find a +method, with no duplicates. + +=head1 FUNCTIONS + +=over + +=item the function Class::ISA::super_path($CLASS) + +This returns the ordered list of names of classes that Perl would +search thru in order to find a method, with no duplicates in the list. +$CLASS is not included in the list. UNIVERSAL is not included -- if +you need to consider it, add it to the end. + + +=item the function Class::ISA::self_and_super_path($CLASS) + +Just like C, 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 + +=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/tlperl.old/lib/Class/Struct.pm b/Master/tlpkg/tlperl.old/lib/Class/Struct.pm new file mode 100644 index 00000000000..7a9af54faf8 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Class/Struct.pm @@ -0,0 +1,636 @@ +package Class::Struct; + +## See POD after __END__ + +use 5.006_001; + +use strict; +use warnings::register; +our(@ISA, @EXPORT, $VERSION); + +use Carp; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(struct); + +$VERSION = '0.63'; + +## Tested on 5.002 and 5.003 without class membership tests: +my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95); + +my $print = 0; +sub printem { + if (@_) { $print = shift } + else { $print++ } +} + +{ + package Class::Struct::Tie_ISA; + + sub TIEARRAY { + my $class = shift; + return bless [], $class; + } + + sub STORE { + my ($self, $index, $value) = @_; + Class::Struct::_subclass_error(); + } + + sub FETCH { + my ($self, $index) = @_; + $self->[$index]; + } + + sub FETCHSIZE { + my $self = shift; + return scalar(@$self); + } + + sub DESTROY { } +} + +sub import { + my $self = shift; + + if ( @_ == 0 ) { + $self->export_to_level( 1, $self, @EXPORT ); + } elsif ( @_ == 1 ) { + # This is admittedly a little bit silly: + # do we ever export anything else than 'struct'...? + $self->export_to_level( 1, $self, @_ ); + } else { + goto &struct; + } +} + +sub struct { + + # Determine parameter list structure, one of: + # struct( class => [ element-list ]) + # struct( class => { element-list }) + # struct( element-list ) + # Latter form assumes current package name as struct name. + + my ($class, @decls); + my $base_type = ref $_[1]; + if ( $base_type eq 'HASH' ) { + $class = shift; + @decls = %{shift()}; + _usage_error() if @_; + } + elsif ( $base_type eq 'ARRAY' ) { + $class = shift; + @decls = @{shift()}; + _usage_error() if @_; + } + else { + $base_type = 'ARRAY'; + $class = (caller())[0]; + @decls = @_; + } + + _usage_error() if @decls % 2 == 1; + + # Ensure we are not, and will not be, a subclass. + + my $isa = do { + no strict 'refs'; + \@{$class . '::ISA'}; + }; + _subclass_error() if @$isa; + tie @$isa, 'Class::Struct::Tie_ISA'; + + # Create constructor. + + croak "function 'new' already defined in package $class" + if do { no strict 'refs'; defined &{$class . "::new"} }; + + my @methods = (); + my %refs = (); + my %arrays = (); + my %hashes = (); + my %classes = (); + my $got_class = 0; + my $out = ''; + + $out = "{\n package $class;\n use Carp;\n sub new {\n"; + $out .= " my (\$class, \%init) = \@_;\n"; + $out .= " \$class = __PACKAGE__ unless \@_;\n"; + + my $cnt = 0; + my $idx = 0; + my( $cmt, $name, $type, $elem ); + + if( $base_type eq 'HASH' ){ + $out .= " my(\$r) = {};\n"; + $cmt = ''; + } + elsif( $base_type eq 'ARRAY' ){ + $out .= " my(\$r) = [];\n"; + } + while( $idx < @decls ){ + $name = $decls[$idx]; + $type = $decls[$idx+1]; + push( @methods, $name ); + if( $base_type eq 'HASH' ){ + $elem = "{'${class}::$name'}"; + } + elsif( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + $cmt = " # $name"; + } + if( $type =~ /^\*(.)/ ){ + $refs{$name}++; + $type = $1; + } + my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :"; + if( $type eq '@' ){ + $out .= " croak 'Initializer for $name must be array reference'\n"; + $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n"; + $out .= " \$r->$elem = $init [];$cmt\n"; + $arrays{$name}++; + } + elsif( $type eq '%' ){ + $out .= " croak 'Initializer for $name must be hash reference'\n"; + $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n"; + $out .= " \$r->$elem = $init {};$cmt\n"; + $hashes{$name}++; + } + elsif ( $type eq '$') { + $out .= " \$r->$elem = $init undef;$cmt\n"; + } + elsif( $type =~ /^\w+(?:::\w+)*$/ ){ + $out .= " if (defined(\$init{'$name'})) {\n"; + $out .= " if (ref \$init{'$name'} eq 'HASH')\n"; + $out .= " { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n"; + $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n"; + $out .= " { \$r->$elem = \$init{'$name'} } $cmt\n"; + $out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n"; + $out .= " }\n"; + $classes{$name} = $type; + $got_class = 1; + } + else{ + croak "'$type' is not a valid struct element type"; + } + $idx += 2; + } + $out .= " bless \$r, \$class;\n }\n"; + + # Create accessor methods. + + my( $pre, $pst, $sel ); + $cnt = 0; + foreach $name (@methods){ + if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { + warnings::warnif("function '$name' already defined, overrides struct accessor method"); + } + else { + $pre = $pst = $cmt = $sel = ''; + if( defined $refs{$name} ){ + $pre = "\\("; + $pst = ")"; + $cmt = " # returns ref"; + } + $out .= " sub $name {$cmt\n my \$r = shift;\n"; + if( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + } + elsif( $base_type eq 'HASH' ){ + $elem = "{'${class}::$name'}"; + } + if( defined $arrays{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n"; + $sel = "->[\$i]"; + } + elsif( defined $hashes{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n"; + $sel = "->{\$i}"; + } + elsif( defined $classes{$name} ){ + if ( $CHECK_CLASS_MEMBERSHIP ) { + $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; + } + } + $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; + $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n"; + $out .= " }\n"; + } + } + $out .= "}\n1;\n"; + + print $out if $print; + my $result = eval $out; + carp $@ if $@; +} + +sub _usage_error { + confess "struct usage error"; +} + +sub _subclass_error { + croak 'struct class cannot be a subclass (@ISA not allowed)'; +} + +1; # for require + + +__END__ + +=head1 NAME + +Class::Struct - declare struct-like datatypes as Perl classes + +=head1 SYNOPSIS + + use Class::Struct; + # declare struct, based on array: + struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]); + # declare struct, based on hash: + struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }); + + package CLASS_NAME; + use Class::Struct; + # declare struct, based on array, implicit class name: + struct( ELEMENT_NAME => ELEMENT_TYPE, ... ); + + # Declare struct at compile time + use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]; + use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }; + + # declare struct at compile time, based on array, implicit class name: + package CLASS_NAME; + use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ; + + package Myobj; + use Class::Struct; + # declare struct with four types of elements: + struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' ); + + $obj = new Myobj; # constructor + + # scalar type accessor: + $element_value = $obj->s; # element value + $obj->s('new value'); # assign to element + + # array type accessor: + $ary_ref = $obj->a; # reference to whole array + $ary_element_value = $obj->a(2); # array element value + $obj->a(2, 'new value'); # assign to array element + + # hash type accessor: + $hash_ref = $obj->h; # reference to whole hash + $hash_element_value = $obj->h('x'); # hash element value + $obj->h('x', 'new value'); # assign to hash element + + # class type accessor: + $element_value = $obj->c; # object reference + $obj->c->method(...); # call method of object + $obj->c(new My_Other_Class); # assign a new object + +=head1 DESCRIPTION + +C exports a single function, C. +Given a list of element names and types, and optionally +a class name, C creates a Perl 5 class that implements +a "struct-like" data structure. + +The new class is given a constructor method, C, 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 of the +same name in the package. (See Example 2.) + +Each element's type can be scalar, array, hash, or class. + +=head2 The C function + +The C 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 must not be a subclass of another +class other than C. + +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, Recipe 13.12). + +A function named C must not be explicitly defined in a class +created by C. + +The I 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 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 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 +(but see L). + +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 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 + +C always creates a constructor called C. That constructor +may take a list of initializers for the various elements of the new +struct. + +Each initializer is a pair of values: IC< =E >I. +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 represents a time (seconds and +microseconds), and C has two elements, each of which is of +type C. + + 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 +element always to be nonnegative, so we redefine the C +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=>I 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 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 by Dean Roehrich. + + # Template.pm --- struct/member template builder + # 12mar95 + # Dean Roehrich + # + # changes/bugs fixed since 28nov94 version: + # - podified + # changes/bugs fixed since 21nov94 version: + # - Fixed examples. + # changes/bugs fixed since 02sep94 version: + # - Moved to Class::Template. + # changes/bugs fixed since 20feb94 version: + # - Updated to be a more proper module. + # - Added "use strict". + # - Bug in build_methods, was using @var when @$var needed. + # - Now using my() rather than local(). + # + # Uses perl5 classes to create nested data types. + # This is offered as one implementation of Tom Christiansen's "structs.pl" + # idea. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Config.pm b/Master/tlpkg/tlperl.old/lib/Config.pm new file mode 100644 index 00000000000..7e5ad77b30a --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Config.pm @@ -0,0 +1,95 @@ +# 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/tlperl.old/lib/Config_heavy.pl b/Master/tlpkg/tlperl.old/lib/Config_heavy.pl new file mode 100644 index 00000000000..919d4637cf2 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Config_heavy.pl @@ -0,0 +1,1185 @@ +# 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<{$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/tlperl.old/lib/Cwd.pm b/Master/tlpkg/tlperl.old/lib/Cwd.pm new file mode 100644 index 00000000000..8d25af9f7cd --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Cwd.pm @@ -0,0 +1,710 @@ +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 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 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, C and C +functions are all aliases for the C function, which, on Mac OS, +calls `pwd`. Likewise, the C function is an alias for +C. + +=back + +=head1 AUTHOR + +Originally by the perl5-porters. + +Maintained by Ken Williams + +=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 for the +details. + +=head1 SEE ALSO + +L + +=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 = ; + 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/tlperl.old/lib/Data/Dumper.pm b/Master/tlpkg/tlperl.old/lib/Data/Dumper.pm new file mode 100644 index 00000000000..b7fe1d61e77 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Data/Dumper.pm @@ -0,0 +1,1264 @@ +# +# 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 + +=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 Ced 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 (where I is a numeric suffix), and other duplicate references +to substructures within C<$VAR>I will be appropriately labeled using arrow +notation. You can specify names for individual values to be dumped if you +use the C 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 Ced, but the +nested references to C<$VAR>I will be undefined, since a recursive +structure cannot be constructed using one Perl statement. You should set the +C flag to 1 to get additional statements that will correctly fill in +these references. Moreover, if Ced 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 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 flag. See L below +for details. + + +=head2 Methods + +=over 4 + +=item I->new(I, I) + +Returns a newly created C 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 I->Dump(I, I) + +Returns the stringified form of the values stored in the object (preserving +the order in which they were supplied to C), 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 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 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. 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) + +Returns the stringified form of the values in the list, subject to the +configuration options below. The values will be named C<$VAR>I in the +output, where I 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 +Cized 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 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 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 I<$OBJ>->Purity(I<[NEWVAL]>) + +Controls the degree to which the output can be Ced 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 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 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 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 will run slower if this flag is set, +since the fast XSUB implementation doesn't support it yet. + +=item * + +$Data::Dumper::Terse I 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 names +will be avoided where possible, but be advised that such output may not +always be parseable by C. + +=item * + +$Data::Dumper::Freezer I $I->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 $I->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 CMETHOD()>. 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 $I->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 $I->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 $I->Bless(I<[NEWVAL]>) + +Can be set to a string that specifies an alternative to the C +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. + +=item * + +$Data::Dumper::Pair I $I->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 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 >. + +=item * + +$Data::Dumper::Maxdepth I $I->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 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 $I->Useperl(I<[NEWVAL]>) + +Can be set to a boolean value which controls whether the pure Perl +implementation of C is used. The C 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 $I->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 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 $I->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 +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. + +=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 cheats with CODE references. If a code reference is +encountered in the structure being processed (and if you haven't set +the C flag), an anonymous subroutine that +contains the string '"DUMMY"' will be inserted in its place, and a warning +will be printed if C is set. You can C 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 method to pre-seed the internal reference +table and make the dumped output point to them, instead. See L +above. + +The C and C flags makes Dump() run slower, since the +XSUB implementation does not support them. + +SCALAR objects have the weirdest looking C workaround. + +Pure Perl version of C 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. 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. Using this restores +the old (platform-specific) ordering: an even prettier solution might +be to use the C 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/tlperl.old/lib/Digest/MD5.pm b/Master/tlpkg/tlperl.old/lib/Digest/MD5.pm new file mode 100644 index 00000000000..17fb11d678a --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Digest/MD5.pm @@ -0,0 +1,376 @@ +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 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 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 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 is described in this +section. After a C 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 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 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 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 operation is effectively a destructive, +read-once operation. Once it has been performed, the C +object is automatically C 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 () { + $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, +L, +L, +L + +L + +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 interface was written by Neil Winton +(C). + +The C module is written by Gisle Aas . + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Digest/base.pm b/Master/tlpkg/tlperl.old/lib/Digest/base.pm new file mode 100644 index 00000000000..cb336c2cf61 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Digest/base.pm @@ -0,0 +1,100 @@ +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 class provide implementations of the methods +C and C in terms of C, and of the methods +C and C in terms of C. + +Digest implementations might want to inherit from this class to get +this implementations of the alternative I and I 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. + +=head1 SEE ALSO + +L diff --git a/Master/tlpkg/tlperl.old/lib/Digest/file.pm b/Master/tlpkg/tlperl.old/lib/Digest/file.pm new file mode 100644 index 00000000000..67985fd7599 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Digest/file.pm @@ -0,0 +1,85 @@ +package Digest::file; + +use strict; + +use Exporter (); +use Carp qw(croak); +use Digest (); + +use vars qw($VERSION @ISA @EXPORT_OK); + +$VERSION = "1.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 diff --git a/Master/tlpkg/tlperl.old/lib/DynaLoader.pm b/Master/tlpkg/tlperl.old/lib/DynaLoader.pm new file mode 100644 index 00000000000..178e9b2616c --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/DynaLoader.pm @@ -0,0 +1,833 @@ + +# 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 ) +# 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 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, etc) determined by B (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) 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). 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, 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 file or code can be added to the autoloadable +dl_expandspec() function in F. See F 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 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 file if it exists +(typically used to add to @dl_resolve_using any files which +are required to load the module on the current platform) + +=item * + +calls dl_load_flags() to determine how to load the file. + +=item * + +calls dl_load_file() to load the file + +=item * + +calls dl_undef_symbols() and warns if any symbols are undefined + +=item * + +calls dl_find_symbol() for "boot_$module" + +=item * + +calls dl_install_xsub() to install it as "${module}::bootstrap" + +=item * + +calls &{"${module}::bootstrap"} to bootstrap the module (actually +it uses the function reference returned by dl_install_xsub for speed) + +=back + +=back + + +=head1 AUTHOR + +Tim Bunce, 11 August 1994. + +This interface is based on the work and comments of (in no particular +order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno +Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others. + +Larry Wall designed the elegant inherited bootstrap mechanism and +implemented the first Perl 5 dynamic loader using it. + +Solaris global loading added by Nick Ing-Simmons with design/coding +assistance from Tim Bunce, January 1996. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode.pm b/Master/tlpkg/tlperl.old/lib/Encode.pm new file mode 100644 index 00000000000..ac0123c89ec --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode.pm @@ -0,0 +1,851 @@ +# +# $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 module provides the interfaces between Perl's strings +and the rest of the system. Perl strings are sequences of +B. + +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) 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). + +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: a character in the range 0..(2**32-1) (or more). +(What Perl's strings are made of.) + +=item * + +I: a character in the range 0..255 +(A special case of a Perl character.) + +=item * + +I: 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 and returns +a sequence of octets. ENCODING can be either a canonical name or +an alias. For encoding names and aliases, see L. +For CHECK, see L. + +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: When you run C<$octets = encode("utf8", $string)>, then $octets +B $string. Though they both contain the same data, the utf8 flag +for $octets is B off. When you encode anything, utf8 flag of +the result is always off, even when it contains completely valid utf8 +string. See L below. + +If the $string is C then C is returned. + +=item $string = decode(ENCODING, $octets [, CHECK]) + +Decodes a sequence of octets assumed to be in I 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. For CHECK, see +L. + +For example, to convert ISO-8859-1 data to a string in Perl's internal format: + + $string = decode("iso-8859-1", $octets); + +B: When you run C<$string = decode("utf8", $octets)>, then $string +B $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 +below. + +If the $string is C then C is returned. + +=item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK]) + +Converts B 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 on error. + +B: 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 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. + +=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. + +=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 + +But before you do so, make sure the alias is nonexistent with +C, 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; it can be +exported via C. + +See L for details. + +=head1 Encoding via PerlIO + +If your perl supports I (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 +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 and L. + +=head1 Handling Malformed Data + +The optional I 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 Not all encoding support this feature + +Some encodings ignore I argument. For example, +L ignores I and it always croaks on error. + +=back + +Now here is the list of I values available + +=over 2 + +=item I = Encode::FB_DEFAULT ( == 0) + +If I is 0, (en|de)code will put a I in +place of a malformed character. When you encode, EsubcharE +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 = Encode::FB_CROAK ( == 1) + +If I is 1, methods will die on error immediately with an error +message. Therefore, when I is set to 1, you should trap the +error with eval{} unless you really want to let it die. + +=item I = Encode::FB_QUIET + +If I 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 = 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 = Encode::FB_PERLQQ) + +=item HTML charref mode (I = Encode::FB_HTMLCREF) + +=item XML charref mode (I = Encode::FB_XMLCREF) + +For encodings that are implemented by Encode::XS, CHECK == +Encode::FB_PERLQQ turns (en|de)code into C fallback mode. + +When you decode, C<\xI> will be inserted for a malformed character, +where I is the hex representation of the octet that could not be +decoded to utf8. And when you encode, C<\x{I}> will be inserted, +where I 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}>, HTML uses C<&#I;> where I is a decimal number and +XML uses C<&#xI;> where I is the hexadecimal number. + +In Encode 2.10 or later, C 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; you can import the generic bitmask +constants via C. + + 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 "", shift }); + +Acts like FB_PERLQQ but EU+IE is used instead of +\x{I}. + +=head1 Defining Encodings + +To define a new encoding, use: + + use Encode qw(define_encoding); + define_encoding($object, 'canonicalName' [, alias...]); + +I will be associated with I<$object>. The object +should provide the interface described in L. +If more than two arguments are provided then additional +arguments are taken as aliases for I<$object>. + +See L for more details. + +=head1 The UTF-8 flag + +Before the introduction of utf8 support in perl, The C operator +just compared the strings represented by two scalars. Beginning with +perl 5.8, C compares two strings with simultaneous consideration +of I. To explain why we made it so, I will quote page +402 of C + +=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 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 paragraphs. + +This utf8 flag is not visible in perl scripts, exactly for the same +reason you cannot (or you I) 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 also has utf8::is_utf8(). + +=item _utf8_on(STRING) + +[INTERNAL] Turns on the UTF-8 flag in STRING. The data in STRING is +B checked for being well-formed UTF-8. Do not use unless you +B 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 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 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 + 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 means strict, official UTF-8 +while B means liberal, lax, version thereof. And Encode version +2.10 or later thus groks the difference between C and C"utf8". + + encode("utf8", "\x{FFFF_FFFF}", 1); # okay + encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks + +C in Encode is actually a canonical name for C. +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, +L, +L, +L, +L, +L, +L, +L, +the Perl Unicode Mailing List Eperl-unicode@perl.orgE + +=head1 MAINTAINER + +This project was originated by Nick Ing-Simmons and later maintained +by Dan Kogai Edankogai@dan.co.jpE. See AUTHORS for a full +list of people involved. For any questions, use +Eperl-unicode@perl.orgE so we can all share. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/Alias.pm b/Master/tlpkg/tlperl.old/lib/Encode/Alias.pm new file mode 100644 index 00000000000..c0bbf69f469 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Alias.pm @@ -0,0 +1,341 @@ +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). + +Currently I 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 is not a reference, it is C-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, L + +=cut + diff --git a/Master/tlpkg/tlperl.old/lib/Encode/Byte.pm b/Master/tlpkg/tlperl.old/lib/Encode/Byte.pm new file mode 100644 index 00000000000..d40c1c3d9d1 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Byte.pm @@ -0,0 +1,119 @@ +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 + + 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 + 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. + +=head1 SEE ALSO + +L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/CJKConstants.pm b/Master/tlpkg/tlperl.old/lib/Encode/CJKConstants.pm new file mode 100644 index 00000000000..4ab40e72ef2 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/CJKConstants.pm @@ -0,0 +1,66 @@ +# +# $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/tlperl.old/lib/Encode/CN.pm b/Master/tlpkg/tlperl.old/lib/Encode/CN.pm new file mode 100644 index 00000000000..be5a830fc51 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/CN.pm @@ -0,0 +1,76 @@ +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. + +=head1 NOTES + +Due to size concerns, C (an extension to C) is distributed +separately on CPAN, under the name L. That module +also contains extra Taiwan-based encodings. + +=head1 BUGS + +When you see C on mails and web pages, they really +mean C encodings. To fix that, C is aliased to C. +Use C 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 + +to find out why it is implemented that way. + +=head1 SEE ALSO + +L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/CN/HZ.pm b/Master/tlpkg/tlperl.old/lib/Encode/CN/HZ.pm new file mode 100644 index 00000000000..fbc6ba60ced --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/CN/HZ.pm @@ -0,0 +1,196 @@ +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/tlperl.old/lib/Encode/Changes.e2x b/Master/tlpkg/tlperl.old/lib/Encode/Changes.e2x new file mode 100644 index 00000000000..5c67c55cb93 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Changes.e2x @@ -0,0 +1,7 @@ +# +# $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/tlperl.old/lib/Encode/Config.pm b/Master/tlpkg/tlperl.old/lib/Encode/Config.pm new file mode 100644 index 00000000000..d69b92d8248 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Config.pm @@ -0,0 +1,166 @@ +# +# 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/tlperl.old/lib/Encode/ConfigLocal_PM.e2x b/Master/tlpkg/tlperl.old/lib/Encode/ConfigLocal_PM.e2x new file mode 100644 index 00000000000..e203dfded50 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/ConfigLocal_PM.e2x @@ -0,0 +1,13 @@ +# +# 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/tlperl.old/lib/Encode/EBCDIC.pm b/Master/tlpkg/tlperl.old/lib/Encode/EBCDIC.pm new file mode 100644 index 00000000000..200a82fea46 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/EBCDIC.pm @@ -0,0 +1,43 @@ +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. + +=head1 SEE ALSO + +L, L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/Encoder.pm b/Master/tlpkg/tlperl.old/lib/Encode/Encoder.pm new file mode 100644 index 00000000000..fe2a2b90ff6 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Encoder.pm @@ -0,0 +1,249 @@ +# +# $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 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 with I. If successful, +the instance I is set accordingly. + +=item * + +You can retrieve the result via -Edata 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-Enew([$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-Enew(). This one is exported on demand. + +=item $e-Edata([$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-Eencoding([$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-Ebytes([$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 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. +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, +L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/Encoding.pm b/Master/tlpkg/tlperl.old/lib/Encode/Encoding.pm new file mode 100644 index 00000000000..06af9fb6994 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Encoding.pm @@ -0,0 +1,341 @@ +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, 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 -Eencode($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 MUST make a "best effort" to +convert the string - for example, by using a replacement character. + +=back + +=item -Edecode($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 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 pragma, you should +also implement the method below. + +=over 4 + +=item -Ecat_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 -Ename + +Predefined As: + + sub name { return shift->{'Name'} } + +MUST return the string representing the canonical name of the encoding. + +=item -Erenew + +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 -Erenewed + +Predefined As: + + sub renewed { $_[0]->{renewed} || 0 } + +Tells whether the object is renewed (and how many times). Some +modules emit C warning +unless the value is numeric so return 0 for false. + +=item -Eperlio_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 -Eneeds_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 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 method from +C. + +=head2 Compiled Encodings + +For the sake of speed and efficiency, most of the encodings are now +supported via a I: XS modules generated from UCM +files. Encode provides the enc2xs tool to achieve that. Please see +L for more details. + +=head1 SEE ALSO + +L, L + +=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 allowing C. + +=back + +=end future + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/Guess.pm b/Master/tlpkg/tlperl.old/lib/Encode/Guess.pm new file mode 100644 index 00000000000..5692cee9a4a --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Guess.pm @@ -0,0 +1,351 @@ +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 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. + +=over 4 + +=item Encode::Guess->set_suspects + +You can also change the internal suspects list via C +method. + + use Encode::Guess; + Encode::Guess->set_suspects(qw/euc-jp shiftjis 7bit-jis/); + +=item Encode::Guess->add_suspects + +Or you can use C method. The difference is that +C flushes the current suspects list while +C 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. 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]) + +You can also try C 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 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, L + +=cut + diff --git a/Master/tlpkg/tlperl.old/lib/Encode/JP.pm b/Master/tlpkg/tlperl.old/lib/Encode/JP.pm new file mode 100644 index 00000000000..01ad37f30db --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/JP.pm @@ -0,0 +1,97 @@ +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. + +=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 + +to find out why it is implemented that way. + +=head1 SEE ALSO + +L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/JP/H2Z.pm b/Master/tlpkg/tlperl.old/lib/Encode/JP/H2Z.pm new file mode 100644 index 00000000000..0c84c62fda6 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/JP/H2Z.pm @@ -0,0 +1,174 @@ +# +# $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/tlperl.old/lib/Encode/JP/JIS7.pm b/Master/tlpkg/tlperl.old/lib/Encode/JP/JIS7.pm new file mode 100644 index 00000000000..28503ec760c --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/JP/JIS7.pm @@ -0,0 +1,165 @@ +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/tlperl.old/lib/Encode/KR.pm b/Master/tlpkg/tlperl.old/lib/Encode/KR.pm new file mode 100644 index 00000000000..e9d4073b7b4 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/KR.pm @@ -0,0 +1,72 @@ +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. + +=head1 BUGS + +When you see C 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 + +to find out why it is implemented that way. + +=head1 SEE ALSO + +L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/KR/2022_KR.pm b/Master/tlpkg/tlperl.old/lib/Encode/KR/2022_KR.pm new file mode 100644 index 00000000000..8b4052be570 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/KR/2022_KR.pm @@ -0,0 +1,79 @@ +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/tlperl.old/lib/Encode/MIME/Header.pm b/Master/tlpkg/tlperl.old/lib/Encode/MIME/Header.pm new file mode 100644 index 00000000000..f4e2ad6e2b5 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/MIME/Header.pm @@ -0,0 +1,230 @@ +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, C and C. 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?I?I?=), I +is extracted and decoded for I encoding (B for Base64, Q for +Quoted-Printable). Then the decoded chunk is fed to +decode(I). So long as I is supported by Encode, +any source encoding is fine. + +When you encode, it just encodes UTF-8 string with I encoding then +quoted with =?UTF-8?I?....?= . 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 + +RFC 2047, L and many other +locations. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/MIME/Header/ISO_2022_JP.pm b/Master/tlpkg/tlperl.old/lib/Encode/MIME/Header/ISO_2022_JP.pm new file mode 100644 index 00000000000..5f637a32472 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/MIME/Header/ISO_2022_JP.pm @@ -0,0 +1,127 @@ +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/tlperl.old/lib/Encode/Makefile_PL.e2x b/Master/tlpkg/tlperl.old/lib/Encode/Makefile_PL.e2x new file mode 100644 index 00000000000..3bca0bff52b --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Makefile_PL.e2x @@ -0,0 +1,180 @@ +# +# 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 +#include +#include +#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/tlperl.old/lib/Encode/PerlIO.pod b/Master/tlpkg/tlperl.old/lib/Encode/PerlIO.pod new file mode 100644 index 00000000000..abd1f2d10a1 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/PerlIO.pod @@ -0,0 +1,167 @@ +=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 provides a "layer" (see L) 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 pragma. See L. + +Once a handle is open, its layers can be altered using C. + +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 and will C 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, C, ...). + +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 () { print G } + + # Could also do "print G " 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 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 -Eneeds_lines method +for your encoding object. See L 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 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 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, +L, +L, +L, +L, +L, +L, +L, +the Perl Unicode Mailing List Eperl-unicode@perl.orgE + +=cut + diff --git a/Master/tlpkg/tlperl.old/lib/Encode/README.e2x b/Master/tlpkg/tlperl.old/lib/Encode/README.e2x new file mode 100644 index 00000000000..28a31a655c2 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/README.e2x @@ -0,0 +1,31 @@ +Encode::$_Name_ version 0.1 +======== + +NAME + Encode::$_Name_ - + +SYNOPSIS + use Encode::$_Name_; + # +ABSTRACT + +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 + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + diff --git a/Master/tlpkg/tlperl.old/lib/Encode/Supported.pod b/Master/tlpkg/tlperl.old/lib/Encode/Supported.pod new file mode 100644 index 00000000000..651f7e6ed4f --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Supported.pod @@ -0,0 +1,890 @@ +=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 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 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 and I 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. + +=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. + +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 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. + +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 +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 comes with the following KOI charsets. +For gory details, see L + + ---------------------------------------------------------------- + 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 + [2] gbk is aliased to this. See L + +=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 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. See +L 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). 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 +and +L +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 . + +=item (Mac) Indic encodings + +The maps for the following are available at L +but remain unsupport because those encodings need algorithmical +approach, currently unsupported by F: + + MacDevanagari + MacGurmukhi + MacGujarati + +For details, please see C at +L . + +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 . + +=back + +=head1 Encoding vs. Charset -- terminology + +We are used to using the term (character) I and I 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 and I. + +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. + +=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. + +=item * + +If your computer can grow the character set without further +processing, you can go ahead and use it. This is called a I (CCS) or I. 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 the character set to use it. + +A I (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. + +=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 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, 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 has been officialized by JIS X 0208:1997. +L gives details. + +C is the IANA name for C. +See L for details. + +C I encoding is available as C +with Encode. See L 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 is C. + + KS_C_5601-1987 + +is heavily misused. +See L for details. + +C I encoding is available as C +with Encode. See L for details. + + UTF-16 UTF-16BE UTF-16LE + +are IANA-registered Cs. 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 support in any software you're going to be +using/interoperating with has probably been less tested +then C support + +=item * + +C coded data seamlessly passes traditional +command piping (C, C, etc.) while C 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 form data. To get a general impression, visit +L. +While encoding of form data has stabilized for C 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 encoded +pages! + +=back + +The rule of thumb is to use C unless you know what +you're doing and unless you really benefit from using C. + + 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. + +Proper names: C, C, C (as used by Mozilla). + +See L +for details. + +Encode aliases C to C to reflect this common +misusage. I C encoding is available as +C. + +See L for details. + +=item GB2312 + +Microsoft extension to C. + +Proper names: C, C. + +C has been registered in the C meaning at +IANA. This has partially repaired the situation: Microsoft's +C has become a superset of the official C. + +Encode aliases C to C in full agreement with +IANA registration. C is supported separately. +I C encoding is available as C. + +See L for details. + +=item Big5 + +Microsoft extension to C. + +Proper name: C. + +Encode separately supports C and C. + +=item Shift_JIS + +Microsoft's understanding of C. + +JIS has not endorsed the full Microsoft standard however. +The official C includes only JIS X 0201 and JIS X 0208 +character sets, while Microsoft has always used C +to encode a wider character repertoire. See C registration for +C. + +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. C name (also used by Mozilla, and +provided as an alias by Encode): C. + +Encode separately supports C and C. + +=back + +=head1 Glossary + +=over 4 + +=item character repertoire + +A collection of unique characters. A I 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, CES. + +While the word combination C has lost this meaning +in MIME context since [RFC 2130], the C abbreviation has +retained it. This is how [RFC 2277] and [RFC 2278] bless C: + + 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 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. When you say just UCS, it means +I. + +=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. 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, +L, +L, L, L, L, +L, L +L, L + +=head1 References + +=over 4 + +=item ECMA + +European Computer Manufacturers Association +L + +=over 4 + +=item ECMA-035 (eq C) + +L + +The specification of ISO-2022 is available from the link above. + +=back + +=item IANA + +Internet Assigned Numbers Authority +L + +=over 4 + +=item Assigned Charset Names by IANA + +L + +Most of the C 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 + +=item RFC + +Request For Comments -- need I say more? +L, L, +L + +=item UC + +Unicode Consortium +L + +=over 4 + +=item Unicode Glossary + +L + +The glossary of this document is based upon this site. + +=back + +=back + +=head2 Other Notable Sites + +=over 4 + +=item czyborra.com + +L + +Contains a lot of useful information, especially gory details of ISO +vs. vendor mappings. + +=item CJK.inf + +L + +Somewhat obsolete (last update in 1996), but still useful. Also try + +L + +You will find brief info on C, C and mostly on C. + +=item Jungshik Shin's Hangul FAQ + +L + +And especially its subject 8. + +L + +A comprehensive overview of the Korean (C) standards. + +=item debian.org: "Introduction to i18n" + +A brief description for most of the mentioned CJK encodings is +contained in +L + +=back + +=head2 Offline sources + +=over 4 + +=item C by Ken Lunde + +CJKV Information Processing +1999 O'Reilly & Associates, ISBN : 1-56592-224-7 + +The modern successor of C. + +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 +or your favourite bookstore. + +=back + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/Symbol.pm b/Master/tlpkg/tlperl.old/lib/Encode/Symbol.pm new file mode 100644 index 00000000000..7ad8ca92c7d --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Symbol.pm @@ -0,0 +1,42 @@ +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. + +=head1 SEE ALSO + +L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/TW.pm b/Master/tlpkg/tlperl.old/lib/Encode/TW.pm new file mode 100644 index 00000000000..2e1abc0c7f9 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/TW.pm @@ -0,0 +1,78 @@ +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. + +=head1 NOTES + +Due to size concerns, C (Extended Unix Character), C +(Chinese Character Code for Information Interchange), C +(CMEX's Big5+) and C (CMEX's Big5e) are distributed separately +on CPAN, under the name L. That module also contains +extra China-based encodings. + +=head1 BUGS + +Since the original C encoding (1984) is not supported anywhere +(glibc and DOS-based systems uses C to mean C; Microsoft +uses C to mean C), a conscious decision was made to alias +C to C, which is the de facto superset of the original +big5. + +The C encoding files are not complete. For common C +manipulation, please use C in L, 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 + +to find out why it is implemented that way. + +=head1 SEE ALSO + +L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/Unicode.pm b/Master/tlpkg/tlperl.old/lib/Encode/Unicode.pm new file mode 100644 index 00000000000..4d0c31d82d3 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Unicode.pm @@ -0,0 +1,268 @@ +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 says: + +I 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. + +=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 support I. When a surrogate pair +is encountered during decode(), its place is filled with \x{FFFD} +if I is 0, or the routine croaks if I is 1. When a +character whose ord value is larger than 0xFFFF is encountered, +its place is filled with \x{FFFD} if I is 0, or the routine +croaks if I is 1. + +UTF-16 is almost the same as UCS-2 but it supports I. +When it encounters a high surrogate (0xD800-0xDBFF), it fetches the +following low surrogate (0xDC00-0xDFFF) and Cs them to +form a character. Bogus surrogates result in death. When \x{10000} +or above is encountered during encode(), it Cs 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. + +=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 or I 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 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 Trilogy, C. 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 and the second half to represent the C. 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 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. + + (*) 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, L, L, +L, + +RFC 2781 L, + +The whole Unicode standard L + +Ch. 15, pp. 403 of C +by Larry Wall, Tom Christiansen, Jon Orwant; +O'Reilly & Associates; ISBN 0-596-00027-8 + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/Unicode/UTF7.pm b/Master/tlpkg/tlperl.old/lib/Encode/Unicode/UTF7.pm new file mode 100644 index 00000000000..dc75ce37816 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/Unicode/UTF7.pm @@ -0,0 +1,118 @@ +# +# $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, L, L + +RFC 2781 L + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/_PM.e2x b/Master/tlpkg/tlperl.old/lib/Encode/_PM.e2x new file mode 100644 index 00000000000..eb59cd1b520 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/_PM.e2x @@ -0,0 +1,23 @@ +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 + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Encode/_T.e2x b/Master/tlpkg/tlperl.old/lib/Encode/_T.e2x new file mode 100644 index 00000000000..6cf5f293d54 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/_T.e2x @@ -0,0 +1,7 @@ +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/tlperl.old/lib/Encode/encode.h b/Master/tlpkg/tlperl.old/lib/Encode/encode.h new file mode 100644 index 00000000000..94764a6a14c --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Encode/encode.h @@ -0,0 +1,111 @@ +#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/tlperl.old/lib/Errno.pm b/Master/tlpkg/tlperl.old/lib/Errno.pm new file mode 100644 index 00000000000..23c07ea0482 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Errno.pm @@ -0,0 +1,227 @@ +# +# 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/tlperl.old/lib/Exporter.pm b/Master/tlpkg/tlperl.old/lib/Exporter.pm new file mode 100644 index 00000000000..d9c22049776 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Exporter.pm @@ -0,0 +1,440 @@ +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 method which allows a module +to export functions and variables to its users' namespaces. Many modules +use Exporter rather than implementing their own C method because +Exporter provides a highly flexible interface, with an implementation optimised +for the common case. + +Perl automatically calls the C method when processing a +C statement for a module. Modules and C are documented +in L and L. Understanding the concept of +modules and how the C 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 export method names! + +Do B 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-Emethod) +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. + +=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 + +This imports all the symbols from ModuleName's @EXPORT into the namespace +of the C statement. + +=item C + +This causes perl to load your module but does not import any symbols. + +=item C + +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 rather than C. + +You can say C 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-Erequire_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 Ced Constants + +Many modules make use of Cing for constant subroutines to +avoid having to compile and waste memory on rarely used values (see +L 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 Ced 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 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 for C to take place before +SO_LINGER is encountered later in C package. + +If you are writing a package that Cs, consider forcing +an C for any constants explicitly imported by other packages +or which are usually used when your package is Cd. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Exporter/Heavy.pm b/Master/tlpkg/tlperl.old/lib/Exporter/Heavy.pm new file mode 100644 index 00000000000..2cc792288f0 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Exporter/Heavy.pm @@ -0,0 +1,248 @@ +package Exporter::Heavy; + +use strict; +no strict 'refs'; + +# On one line so MakeMaker will see it. +require Exporter; our $VERSION = $Exporter::VERSION; +$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/tlperl.old/lib/Fcntl.pm b/Master/tlpkg/tlperl.old/lib/Fcntl.pm new file mode 100644 index 00000000000..7ef0038bd18 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Fcntl.pm @@ -0,0 +1,236 @@ +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 file. +Unlike the old mechanism of requiring a translated F +file, this uses the B 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. + +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 to learn about the uses of the O_* constants +with sysopen(). + +See L and L about the SEEK_* constants. + +See L 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/tlperl.old/lib/File/Basename.pm b/Master/tlpkg/tlperl.old/lib/File/Basename.pm new file mode 100644 index 00000000000..837b753972a --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Basename.pm @@ -0,0 +1,398 @@ +=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: C and C 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's C and +C 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 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 + + my($filename, $directories, $suffix) = fileparse($path); + my($filename, $directories, $suffix) = fileparse($path, @suffixes); + my $filename = fileparse($path, @suffixes); + +The C 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) 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) 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 + + my $filename = basename($path); + my $filename = basename($path, @suffixes); + +This function is provided for compatibility with the Unix shell command +C. It does B 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. + +C returns the last level of a filepath even if the last +level is clearly directory. In effect, it is acting like C for +paths. This differs from C's behaviour. + + # Both return "bar" + basename("/foo/bar"); + basename("/foo/bar/"); + +@suffixes work as in C 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 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 + +This function is provided for compatibility with the Unix shell +command C and has inherited some of its quirks. In spite of +its name it does B always return the directory name as you might +expect. To be safe, if you want the directory name of a path use +C. + +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 work like C, returning just the +$directories. + + # On VMS and AmigaOS + my $directories = dirname($path); + +When using Unix or MSDOS syntax this emulates the C shell function +which is subtly different from how C 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 for file paths. + +Also unlike C, C 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 + + 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, L, L diff --git a/Master/tlpkg/tlperl.old/lib/File/CheckTree.pm b/Master/tlpkg/tlperl.old/lib/File/CheckTree.pm new file mode 100644 index 00000000000..20ffd68124d --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/CheckTree.pm @@ -0,0 +1,229 @@ +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 > 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/tlperl.old/lib/File/Compare.pm b/Master/tlpkg/tlperl.old/lib/File/Compare.pm new file mode 100644 index 00000000000..0b73d7c7657 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Compare.pm @@ -0,0 +1,178 @@ +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 = )) { + goto fail_inner unless defined($tline = ); + 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 = ); + } + else { + unless (defined($size) && $size > 0) { + $size = $fromsize || -s TO || 0; + $size = 1024 if $size < 512; + $size = $Too_Big if $size > $Too_Big; + } + + my ($fr,$tr,$fbuf,$tbuf); + $fbuf = $tbuf = ''; + while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { + unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) { + goto fail_inner; + } + } + goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0; + } + + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 0; + + # All of these contortions try to preserve error messages... + fail_inner: + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 1; + + fail_open2: + if ($closefrom) { + my $status = $!; + $! = 0; + close FROM; + $! = $status unless $!; + } + fail_open1: + return -1; +} + +sub cmp; +*cmp = \&compare; + +sub compare_text { + my ($from,$to,$cmp) = @_; + croak("Usage: compare_text( file1, file2 [, cmp-function])") + unless @_ == 2 || @_ == 3; + croak("Third arg to compare_text() function must be a code reference") + if @_ == 3 && ref($cmp) ne 'CODE'; + + # Using a negative buffer size puts compare into text_mode too + $cmp = -1 unless defined $cmp; + compare($from, $to, $cmp); +} + +1; + +__END__ + +=head1 NAME + +File::Compare - Compare files or filehandles + +=head1 SYNOPSIS + + use File::Compare; + + if (compare("file1","file2") == 0) { + print "They're equal\n"; + } + +=head1 DESCRIPTION + +The File::Compare::compare function compares the contents of two +sources, each of which can be a file or a file handle. It is exported +from File::Compare by default. + +File::Compare::cmp is a synonym for File::Compare::compare. It is +exported from File::Compare only by request. + +File::Compare::compare_text does a line by line comparison of the two +files. It stops as soon as a difference is detected. compare_text() +accepts an optional third argument: This must be a CODE reference to +a line comparison function, which returns 0 when both lines are considered +equal. For example: + + compare_text($file1, $file2) + +is basically equivalent to + + compare_text($file1, $file2, sub {$_[0] ne $_[1]} ) + +=head1 RETURN + +File::Compare::compare and its sibling functions return 0 if the files +are equal, 1 if the files are unequal, or -1 if an error was encountered. + +=head1 AUTHOR + +File::Compare was written by Nick Ing-Simmons. +Its original documentation was written by Chip Salzenberg. + +=cut + diff --git a/Master/tlpkg/tlperl.old/lib/File/Copy.pm b/Master/tlpkg/tlperl.old/lib/File/Copy.pm new file mode 100644 index 00000000000..52ba7c6d81a --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Copy.pm @@ -0,0 +1,459 @@ +# File/Copy.pm. Written in 1994 by Aaron Sherman . 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 = \© +*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 = \© + } +} + +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 and +C, which are useful for getting the contents of a file from +one place to another. + +=over 4 + +=item * + +The C 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 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 Files are opened in binary mode where +applicable. To get a consistent behaviour when copying from a +filehandle to a file, use C 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 to get at the +"cp" alias for this function. The syntax is I the same. + +=item * + +The C 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. + +=back + +File::Copy also provides the C 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 routine, which doesn't preserve OS-specific attributes. For +VMS systems, this calls the C routine (see below). For OS/2 +systems, this calls the C XSUB directly. For Win32 systems, +this calls C. + +On Mac OS (Classic), C calls C, +if available. + +=head2 Special behaviour if C is defined (OS/2, VMS and Win32) + +If both arguments to C are not file handles, +then C will perform a "system copy" of +the input file to a new output file, in order to preserve file +attributes, indexed file structure, I The buffer size +parameter is ignored. If either argument to C 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 (or under VMS as C, 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 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 +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 +returns, not the newly created version.) + +The third parameter is an integer flag, which tells C +how to handle timestamps. If it is E 0, none of the input file's +timestamps are propagated to the output file. If it is E 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 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, C 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 Iajs@ajs.comE> in 1995, +and updated by Charles Bailey Ibailey@newman.upenn.eduE> in 1996. + +=cut + diff --git a/Master/tlpkg/tlperl.old/lib/File/DosGlob.pm b/Master/tlpkg/tlperl.old/lib/File/DosGlob.pm new file mode 100644 index 00000000000..a1c27d5c32a --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/DosGlob.pm @@ -0,0 +1,571 @@ +#!perl -w + +# use strict fails +#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. + +# +# Documentation at the __END__ +# + +package File::DosGlob; + +our $VERSION = '1.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 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 ( /^(.*)(?; + + # 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 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, or +C. The argument is tokenized using +C, so see L 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*:E will find all +mounted volumes, while a glob like E*E or E:*E 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 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 + +=head1 HISTORY + +=over 4 + +=item * + +Support for globally overriding glob() (GSAR 3-JUN-98) + +=item * + +Scalar context, independent iterator context fixes (GSAR 15-SEP-97) + +=item * + +A few dir-vs-file optimizations result in glob importation being +10 times faster than using perlglob.exe, and using perlglob.bat is +only twice as slow as perlglob.exe (GSAR 28-MAY-97) + +=item * + +Several cleanups prompted by lack of compatible perlglob.exe +under Borland (GSAR 27-MAY-97) + +=item * + +Initial version (GSAR 20-FEB-97) + +=back + +=head1 SEE ALSO + +perl + +perlglob.bat + +Text::ParseWords + +=cut + diff --git a/Master/tlpkg/tlperl.old/lib/File/Find.pm b/Master/tlpkg/tlperl.old/lib/File/Find.pm new file mode 100644 index 00000000000..497051e0635 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Find.pm @@ -0,0 +1,1275 @@ +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 command. File::Find +exports two functions, C and C. They work similarly +but have subtle differences. + +=over 4 + +=item B + + find(\&wanted, @directories); + find(\%options, @directories); + +C 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 into that directory and continue the search, invoking the +C<&wanted> function on each file or subdirectory in the directory. + +=item B + + finddepth(\&wanted, @directories); + finddepth(\%options, @directories); + +C works just like C except that is invokes the +C<&wanted> function for a directory I 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 works from the top of the tree down. + +=back + +=head2 %options + +The first argument to C 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 below. + +Here are the possible keys for the hash: + +=over 3 + +=item C + +The value should be a code reference. This code reference is +described in L below. + +=item C + +Reports the name of a directory only AFTER all its entries +have been reported. Entry point C is a shortcut for +specifying C<<{ bydepth => 1 }>> in the first argument of C. + +=item C + +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, but before the loop that calls the C +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 or I are in effect, C is a no-op. + +=item C + +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 or I are in effect, C is a +no-op. + +=item C + +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 and I below. +If either I or I is in effect: + +=over 6 + +=item * + +It is guaranteed that an I has been called before the user's +C function is called. This enables fast file checks involving S<_>. +Note that this guarantee no longer holds if I or I +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. + +=back + +This is a no-op on Win32. + +=item C + +This is similar to I 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 function) +is worse than just taking time, the option I should be used. + +This is also a no-op on Win32. + +=item C + +C, 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 causes File::Find to die if any file is about to be +processed a second time. + +C causes File::Find to ignore any duplicate files and +directories but to proceed normally otherwise. + +=item C + +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 + +Does not C to each directory as it recurses. The C +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 + +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. Note that all names passed to the user's +I function are still tainted. If this option is used while +not in taint-mode, C is a no-op. + +=item C + +See above. This should be set using the C quoting operator. +The default is set to C. +Note that the parentheses are vital. + +=item C + +If set, a directory which fails the I is skipped, +including all its sub-directories. The default is to 'die' in such a case. + +=back + +=head2 The wanted function + +The C function does whatever verifications you want on +each file and directory. Note that despite its name, the C +function is a generic callback function, and does B 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 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 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 or 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 was +specified. Unless C or C 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 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: the C<_> is a magical +filehandle that caches the information from the preceding +C, C, 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 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 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 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 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 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 (see above) on Mac OS is set to +C. 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 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 and B +file attributes. The MacPerl built-in functions C and +C 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 function, both C and +C 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/tlperl.old/lib/File/Glob.pm b/Master/tlpkg/tlperl.old/lib/File/Glob.pm new file mode 100644 index 00000000000..133c650529b --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Glob.pm @@ -0,0 +1,496 @@ +package File::Glob; + +use strict; +our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, + $AUTOLOAD, $DEFAULT_FLAGS); + +use XSLoader (); + +@ISA = qw(Exporter); + +# NOTE: The glob() export is only here for compatibility with 5.6.0. +# csh_glob() should not be used directly, unless you know what you're doing. + +@EXPORT_OK = qw( + csh_glob + bsd_glob + glob + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE +); + +%EXPORT_TAGS = ( + 'glob' => [ qw( + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE + glob + bsd_glob + ) ], +); + +$VERSION = '1.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 argument, and an optional +C argument, and returns a list of filenames matching the +pattern, with interpretation of the pattern modified by the C +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 is a shorthand for C. 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 + +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 + +Make bsd_glob() return an error (GLOB_NOSPACE) when the pattern expands +to a size bigger than the system constant C (usually found in +limits.h). If your system does not define this constant, bsd_glob() uses +C or C<_POSIX_ARG_MAX> where available (in that +order). You can inspect these values using the standard C +extension. + +=item C + +Each pathname that is a directory that matches the pattern has a slash +appended. + +=item C + +By default, file names are assumed to be case sensitive; this flag +makes bsd_glob() treat case differences as not significant. + +=item C + +If the pattern does not match any pathname, then bsd_glob() returns a list +consisting of only the pattern. If C is set, its effect +is present in the pattern returned. + +=item C + +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 + +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 + +Same as C but it only returns the pattern if it does not +contain any of the special characters "*", "?" or "[". C is +provided to simplify implementing the historic csh(1) globbing +behaviour and should probably not be used anywhere else. + +=item C + +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 + +Expand patterns that start with '~' to user name home directories. + +=item C + +For convenience, C is a synonym for +C. + +=back + +The POSIX provided C, C, and the FreeBSD +extensions C, and C 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 + +If C 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 + +An attempt to allocate memory failed. + +=item C + +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 +set &File::Glob::ERROR. + +Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour +by not considering C and C as errors - bsd_glob() will +continue processing despite those errors, unless the C 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, you should +probably throw them in a set as in C. 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 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 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*:E will find all +mounted volumes, while a glob like E*E or E:*E 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:*:E will find both +directories I files (and not, as one might expect, only directories). +You can, however, use the C flag to distinguish (without a file +test) directory names from file names. + +If the C flag is set, all directory paths will have a ':' appended. +Since a directory like 'lib:' is I a valid I 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, glob(3) + +=head1 AUTHOR + +The Perl interface was written by Nathan Torkington Egnat@frii.comE, +and is released under the artistic license. Further modifications were +made by Greg Bacon Egbacon@cs.uah.eduE, Gurusamy Sarathy +Egsar@activestate.comE, and Thomas Wegner +Ewegner_thomas@yahoo.comE. The C glob code has the +following copyright: + + Copyright (c) 1989, 1993 The Regents of the University of California. + All rights reserved. + + This code is derived from software contributed to Berkeley by + Guido van Rossum. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/File/Path.pm b/Master/tlpkg/tlperl.old/lib/File/Path.pm new file mode 100644 index 00000000000..2e41ff3f77f --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Path.pm @@ -0,0 +1,285 @@ +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 function provides a convenient way to create directories, even +if your C kernel call won't create more than one level of directory at +a time. C 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 +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 function throws a fatal error with C. This error +can be trapped with an C block: + + eval { mkpath($dir) }; + if ($@) { + print "Couldn't create $dir: $@"; + } + +Similarly, the C function provides a convenient way to delete a +subtree from the directory structure, much like the Unix command C. +C 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 to +print a message each time it examines a file, giving the +name of the file, and indicating whether it's using C +or C to remove it, or that it's skipping it. +(defaults to FALSE) + +=item * + +a boolean value, which if TRUE will cause C 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 There are race conditions internal to the implementation of +C making it unsafe to use on directory trees which may be +altered or moved while C 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 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 can be determined I +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 gives you the warning: B, this may mean that you've exceeded your filesystem's +maximum path length. + +=back + +=head1 AUTHORS + +Tim Bunce > and +Charles Bailey > + +=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/tlperl.old/lib/File/Spec.pm b/Master/tlpkg/tlperl.old/lib/File/Spec.pm new file mode 100644 index 00000000000..0c8cd21e057 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Spec.pm @@ -0,0 +1,322 @@ +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 KEnig, 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 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 sections into F. This +is by design. If F on your system is a symlink to F, +then F is actually F, not F as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C's C 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. + + $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). + +=item path + +Takes no argument. Returns the environment variable C (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 to get back a path equivalent to +(usually identical to) the original path. + +=item splitdir + +The opposite of L. + + @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 is used. If C<$base> is +relative, then it is converted to absolute form using +L. This means that it is taken to be relative to +L. + +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. +This means that it is taken to be relative to L. + +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 is used. If C<$base> is relative, +then it is converted to absolute form using L. This means that it +is taken to be relative to L. + +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. + +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, +L, L, L, or +L. + +=head1 SEE ALSO + +L, L, L, +L, L, L, +L + +=head1 AUTHOR + +Currently maintained by Ken Williams C<< >>. + +The vast majority of the code was written by +Kenneth Albanowski C<< >>, +Andy Dougherty C<< >>, +Andreas KEnig C<< >>, +Tim Bunce C<< >>. +VMS support by Charles Bailey C<< >>. +OS/2 support by Ilya Zakharevich C<< >>. +Mac support by Paul Schinder C<< >>, and +Thomas Wegner C<< >>. +abs2rel() and rel2abs() written by Shigio Yamaguchi C<< >>, +modified by Barrie Slaymaker C<< >>. +splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/File/Spec/Cygwin.pm b/Master/tlpkg/tlperl.old/lib/File/Spec/Cygwin.pm new file mode 100644 index 00000000000..19a2937c6b9 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Spec/Cygwin.pm @@ -0,0 +1,93 @@ +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 and L. 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, +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/tlperl.old/lib/File/Spec/Epoc.pm b/Master/tlpkg/tlperl.old/lib/File/Spec/Epoc.pm new file mode 100644 index 00000000000..a7168f9e494 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Spec/Epoc.pm @@ -0,0 +1,77 @@ +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 and L. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/Master/tlpkg/tlperl.old/lib/File/Spec/Functions.pm b/Master/tlpkg/tlperl.old/lib/File/Spec/Functions.pm new file mode 100644 index 00000000000..38c898c5d8f --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Spec/Functions.pm @@ -0,0 +1,109 @@ +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, +which contains the entire set, and which is inherited by the modules for +other platforms. For further information, please see L, +L, L, or L. + +=head2 Exports + +The following functions are exported by default. + + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path + + +The following functions are exported only by request. + + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs + case_tolerant + +All the functions may be imported using the C<:ALL> tag. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, +File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker + +=cut + diff --git a/Master/tlpkg/tlperl.old/lib/File/Spec/Mac.pm b/Master/tlpkg/tlperl.old/lib/File/Spec/Mac.pm new file mode 100644 index 00000000000..8b51bd6c249 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Spec/Mac.pm @@ -0,0 +1,780 @@ +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 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 Beginning with version 1.3 of this module, the resulting +path is relative by default and I absolute. This decision was made due +to portability reasons. Since Ccatdir()> 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. +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 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; 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 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 +Ccanonpath()> ). 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. + +=item 7. + +Passing an empty string "" as the first argument to C is +like passingCrootdir()> as the first argument, i.e. + + catdir("","a","b") is the same as + + catdir(rootdir(),"a","b"). + +This is true on Unix, where C yields "/a/b" and +C is "/". Note that C 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 Ccanonpath()> ). 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 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 (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 is still suitable for the +concatenation of I, you are encouraged to use +C to concatenate I and I. 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 +by default, but can be forced to be absolute (but avoid this). + +B Beginning with version 1.3 of this module, the +resulting path is relative by default and I absolute. This +decision was made due to portability reasons. Since +Ccatfile()> 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 uses C (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 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, I and I, +you are encouraged to use C (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 a leading ":". +Empty portions are returned as empty string ''. + +The results can be passed to C 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. + + @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 otherwise. + +Unlike just splitting the directories on the separator, empty directory names +(C<"">) can be returned. Since C 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. +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. +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. 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. Mac OS support by Paul Schinder + and Thomas Wegner . + +=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 and L. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/Master/tlpkg/tlperl.old/lib/File/Spec/OS2.pm b/Master/tlpkg/tlperl.old/lib/File/Spec/OS2.pm new file mode 100644 index 00000000000..ec308f3b6f3 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Spec/OS2.pm @@ -0,0 +1,272 @@ +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 and L. This package overrides the +implementation of these methods, not the semantics. + +Amongst the changes made for OS/2 are... + +=over 4 + +=item tmpdir + +Modifies the list of places temp directory information is looked for. + + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + /tmp + / + +=item splitpath + +Volumes can be drive letters or UNC sharenames (\\server\share). + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/File/Spec/Unix.pm b/Master/tlpkg/tlperl.old/lib/File/Spec/Unix.pm new file mode 100644 index 00000000000..4a25fe632f2 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Spec/Unix.pm @@ -0,0 +1,510 @@ +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 sections into F. This +is by design. If F on your system is a symlink to F, +then F is actually F, not F as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C's C 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). + +=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 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. + + @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 is used. If $base is +relative, then it is converted to absolute form using +L. This means that it is taken to be relative to +L. + +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. +This means that it is taken to be relative to L. + +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 is used. If $base is +relative, then it is converted to absolute form using +L. This means that it is taken to be relative to +L. + +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. + +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 + +=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/tlperl.old/lib/File/Spec/VMS.pm b/Master/tlpkg/tlperl.old/lib/File/Spec/VMS.pm new file mode 100644 index 00000000000..f8923f25fb2 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Spec/VMS.pm @@ -0,0 +1,521 @@ +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 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 and L. This package overrides the +implementation of these methods, not the semantics. + +An explanation of VMS file specs can be found at +L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">. + +=cut + +1; diff --git a/Master/tlpkg/tlperl.old/lib/File/Spec/Win32.pm b/Master/tlpkg/tlperl.old/lib/File/Spec/Win32.pm new file mode 100644 index 00000000000..a324306a74b --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Spec/Win32.pm @@ -0,0 +1,369 @@ +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 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. + + @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 and L. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/Master/tlpkg/tlperl.old/lib/File/Temp.pm b/Master/tlpkg/tlperl.old/lib/File/Temp.pm new file mode 100644 index 00000000000..6ddcb3619a7 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/Temp.pm @@ -0,0 +1,2244 @@ +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 reliable? By default all the +return values from C 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 fails +then the C 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 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 +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. 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 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 + +Create a temporary file object. + + my $tmp = new File::Temp(); + +by default the object is constructed as if C +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: 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 + +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 + +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 + +When the object goes out of scope, the destructor is called. This +destructor will attempt to unlink the file (using C) +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 + +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. + + ($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) 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 flag) the file is marked for deletion when +the program ends (equivalent to setting UNLINK to 1). The C +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 + +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). + + $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 option is ignored if C is set +explicitly. Additionally, C 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 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 + +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. 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 + +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 and suffix of C<.dat> +would generate a file similar to F. + +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 + +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 + +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 +using the mkstemp() from this module. + +Unlike the L implementations, the directory used +for the temporary file is not specified in a system include +file (C) but simply depends on the choice of tmpdir() +returned by L. On some implementations this +location can be set using the C environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B + +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 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 + +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 + +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 +with C 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 + +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 and C fields seem to be +different. Also, it seems that the size of the file returned by stat() +does not always agree, with C being more accurate than +C, 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 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 + +Compare C of filehandle with C 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 and C 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 being more +accurate than C, 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 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 + +Similar to C 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 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 + +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 + +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 +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 +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 +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 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. + + $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, C, C etc) rather than +simply by root. + +This is required since on many unix systems C 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 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 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, L, L, L + +See L and L, L for +different implementations of temporary file handling. + +=head1 AUTHOR + +Tim Jenness Etjenness@cpan.orgE + +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/tlperl.old/lib/File/stat.pm b/Master/tlpkg/tlperl.old/lib/File/stat.pm new file mode 100644 index 00000000000..132cbee27ad --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/File/stat.pm @@ -0,0 +1,139 @@ +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 in front their method names. +Thus, C<$stat_obj-Edev()> corresponds to $st_dev if you import +the fields. + +To access this functionality without the core overrides, +pass the C 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 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/tlperl.old/lib/FileHandle.pm b/Master/tlpkg/tlperl.old/lib/FileHandle.pm new file mode 100644 index 00000000000..6be22429440 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/FileHandle.pm @@ -0,0 +1,262 @@ +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 creates a C, which is a reference to a +newly created symbol (see the C package). If it receives any +parameters, they are passed to C; if the open fails, +the C object is destroyed. Otherwise, it is returned to +the caller. + +C creates a C like C does. +It requires two parameters, which are passed to C; +if the fdopen fails, the C object is destroyed. +Otherwise, it is returned to the caller. + +C accepts one parameter or two. With one parameter, +it is just a front end for the built-in C 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 receives a Perl mode string (">", "+<", etc.) +or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C operator. + +If C is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C operator. +For convenience, C 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 is like C 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 returns an opaque value that represents the +current position of the FileHandle, and C uses +that value to return to a previously visited position. + +If the C function setvbuf() is available, then C +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 must not be +modified in any way until the FileHandle is closed or until +C is called again, or memory corruption may +result! + +See L for complete descriptions of each of the following +supported C methods, which are just front ends for the +corresponding built-in functions: + + close + fileno + getc + gets + eof + clearerr + seek + tell + +See L for complete descriptions of each of the following +supported C 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. + +=item $fh->printf + +See L. + +=item $fh->getline + +This works like <$fh> described in L +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 extension, +L, +L. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Getopt/Long.pm b/Master/tlpkg/tlperl.old/lib/Getopt/Long.pm new file mode 100644 index 00000000000..04038db58e3 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Getopt/Long.pm @@ -0,0 +1,2504 @@ +# 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($_) ? ($_) : ("") } @$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 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. 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 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 the option. + +The option name as specified to the GetOptions() function is called +the option I. 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. + +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 options and I 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 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. The equals sign indicates that this +option requires a value. The letter C indicates that this value is +an arbitrary string. Other possible value types are C for integer +values, and C 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 indicates an option that +takes at least two and at most 4 arguments. C indicates one +or more values; C 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 IC<=>I. 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 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 name, the other names are +called I. 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 [ I ] [ I ] + +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 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 specifies the number of values this option takes per +occurrence on the command line. It has the format C<{> [ I ] [ C<,> [ I ] ] C<}>. + +I 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 overrules the C<=> / C<:> semantics. + +I denotes the maximum number of arguments. It must be at least +I. If I is omitted, I, there is no +upper bound to the number of argument values taken. + +=item : I [ I ] + +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 [ I ] + +Like C<:i>, but if the value is omitted, the I will be assigned. + +=item : + [ I ] + +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 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 will read the given input file(s) and do something + useful with the contents thereof. + + =cut + +See L 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 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 (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 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, C and C 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 always start with a double dash C<--> to avoid +ambiguity. For example, when C, C, C and C are all valid +options, + + -vax + +would set C, C and C, but + + --vax + +would set C. + +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. + +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 while C<$width> is C<80>, +C while C<$width> is C<72>, and +C while C<$width> is C<60>. + +This feature requires configuration option B, see section +L. + +=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, or disabled, e.g. C. 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 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 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 is disabled. + +=item gnu_compat + +C controls whether C<--opt=> is allowed, and what it should +do. Without C, C<--opt=> gives an error. With C, +C<--opt=> will give option C and empty value. +This is the way GNU getopt_long() does it. + +=item gnu_getopt + +This is a short way of setting C C C +C. With C, 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 is enabled. + +See also C, which is the opposite of C. + +=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 is disabled. +Note that C is the opposite of C. + +If C 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 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 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 be introduced with C<--> and bundles with C<->. + +Note that, if you have options C, C and C, 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 (due to auto +completion), not C. + +Note: disabling C also disables C. + +=item bundling_override (default: disabled) + +If C is enabled, bundling is enabled as with +C but now long option names override option bundles. + +Note: disabling C also disables C. + +B 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, option specifications for options that only +differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as +duplicates. + +Note: disabling C also disables C. + +=item ignore_case_always (default: disabled) + +When bundling is in effect, case is ignored on single-character +options also. + +Note: disabling C also disables C. + +=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 will be enabled if the calling program explicitly +specified a version number higher than 2.32 in the C or +C 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. The +message, derived from the SYNOPSIS POD section, will be written to +standard output and processing will terminate. + +C will be enabled if the calling program explicitly +specified a version number higher than 2.32 in the C or +C 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 is enabled, options processing will terminate at +the first unrecognized option, or non-option, whichever comes first. +However, if C 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. + +=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 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 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. 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, 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 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 CI, where +I is the primary name of this option. When a progam executes +under C (recommended), these variables must be +pre-declared with our() or C. + + 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
. 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 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 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 + +=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/tlperl.old/lib/Getopt/Std.pm b/Master/tlpkg/tlperl.old/lib/Getopt/Std.pm new file mode 100644 index 00000000000..99f93590622 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Getopt/Std.pm @@ -0,0 +1,294 @@ +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 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 and/or +C 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) 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 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()} <= 5.006; + print $h <) { + $has_pod = 1, last if /^=(pod|head1)/; + } + } + print $h <= 0) { + if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { + shift(@ARGV); + if ($rest eq '') { + ++$errs unless @ARGV; + $rest = shift(@ARGV); + } + if (ref $hash) { + $$hash{$first} = $rest; + } + else { + ${"opt_$first"} = $rest; + push( @EXPORT, "\$opt_$first" ); + } + } + else { + if (ref $hash) { + $$hash{$first} = 1; + } + else { + ${"opt_$first"} = 1; + push( @EXPORT, "\$opt_$first" ); + } + if ($rest eq '') { + shift(@ARGV); + } + else { + $ARGV[0] = "-$rest"; + } + } + } + else { + if ($first eq '-' and $rest eq 'help') { + version_mess($argumentative, 'main'); + help_mess($argumentative, 'main'); + try_exit(); + shift(@ARGV); + next; + } elsif ($first eq '-' and $rest eq 'version') { + version_mess($argumentative, 'main'); + try_exit(); + shift(@ARGV); + next; + } + warn "Unknown option: $first\n"; + ++$errs; + if ($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift(@ARGV); + } + } + } + unless (ref $hash) { + local $Exporter::ExportLevel = 1; + import Getopt::Std; + } + $errs == 0; +} + +1; diff --git a/Master/tlpkg/tlperl.old/lib/IO.pm b/Master/tlpkg/tlperl.old/lib/IO.pm new file mode 100644 index 00000000000..9fccc3a7356 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/IO.pm @@ -0,0 +1,68 @@ +# + +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 provides a simple mechanism to load several of the IO modules +in one go. The IO modules belonging to the core are: + + IO::Handle + IO::Seekable + IO::File + IO::Pipe + IO::Socket + IO::Dir + IO::Select + IO::Poll + +Some other IO modules don't belong to the perl core but can be loaded +as well if they have been installed from CPAN. You can discover which +ones exist by searching for "^IO::" on http://search.cpan.org. + +For more information on any of these modules, please see its respective +documentation. + +=head1 DEPRECATED + + use IO; # loads all the modules listed below + +The loaded modules are IO::Handle, IO::Seekable, IO::File, IO::Pipe, +IO::Socket, IO::Dir. You should instead explicitly import the IO +modules you want. + +=cut + diff --git a/Master/tlpkg/tlperl.old/lib/IO/Dir.pm b/Master/tlpkg/tlperl.old/lib/IO/Dir.pm new file mode 100644 index 00000000000..fccd02c088a --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/IO/Dir.pm @@ -0,0 +1,246 @@ +# IO::Dir.pm +# +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +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 package provides two interfaces to perl's directory reading +routines. + +The first interface is an object approach. C provides an object +constructor and methods, which are just wrappers around perl's built in +directory reading routines. + +=over 4 + +=item new ( [ DIRNAME ] ) + +C is the constructor for C objects. It accepts one optional +argument which, if given, C will pass to C + +=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 +for details of these functions. + +=over 4 + +=item open ( DIRNAME ) + +=item read () + +=item seek ( POS ) + +=item tell () + +=item rewind () + +=item close () + +=back + +C 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, from the C package, +C, C and C. + +=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. Deleting an element from the hash will +delete the corresponding file or subdirectory, +provided that C is included in the C. + +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 + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to . + +=head1 COPYRIGHT + +Copyright (c) 1997-2003 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/IO/File.pm b/Master/tlpkg/tlperl.old/lib/IO/File.pm new file mode 100644 index 00000000000..e7cdbbed6d7 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/IO/File.pm @@ -0,0 +1,208 @@ +# + +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 inherits from C and C. It extends +these classes with methods that are specific to file handles. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( FILENAME [,MODE [,PERMS]] ) + +Creates an C. If it receives any parameters, they are passed to +the method C; if the open fails, the object is destroyed. Otherwise, +it is returned to the caller. + +=item new_tmpfile + +Creates an C 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 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 accepts one, two or three parameters. With one parameter, +it is just a front end for the built-in C 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 receives a Perl mode string ("E", "+E", etc.) +or an ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C operator (but protects any special characters). + +If C is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C operator. +The permissions default to 0666. + +If C is given a mode that includes the C<:> character, +it passes all the three arguments to the three-argument C operator. + +For convenience, C exports the O_XXX constants from the +Fcntl module, if this module is available. + +=item binmode( [LAYER] ) + +C sets C on the underlying C object, as documented +in C. + +C accepts one optional parameter, which is the layer to be +passed on to the C call. + +=back + +=head1 NOTE + +Some operating systems may perform C or C +on a directory without errors. This behavior is not portable and not +suggested for use. Using C and C or C are +suggested instead. + +=head1 SEE ALSO + +L, +L, +L, +L, +L + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr EFE. + +=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/tlperl.old/lib/IO/Handle.pm b/Master/tlpkg/tlperl.old/lib/IO/Handle.pm new file mode 100644 index 00000000000..329d26ad198 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/IO/Handle.pm @@ -0,0 +1,625 @@ +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 is the base class for all other IO handle classes. It is +not intended that objects of C would be created directly, +but instead C is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C package, then I suggest you read the documentation +for C too. + +=head1 CONSTRUCTOR + +=over 4 + +=item new () + +Creates a new C object. + +=item new_from_fd ( FD, MODE ) + +Creates an C like C does. +It requires two parameters, which are passed to the method C; +if the fdopen fails, the object is destroyed. Otherwise, it is returned +to the caller. + +=back + +=head1 METHODS + +See L for complete descriptions of each of the following +supported C 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 for complete descriptions of each of the following +supported C 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 is like an ordinary C 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 +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 or C-style C 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 is like C found in C, that is it is the +opposite of read. The wrapper for the perl C function is +called C. + +=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, 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 synchronizes a file's in-memory state with that on the +physical medium. C 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 is not implemented on all +platforms. Returns "0 but true" on success, C on error, C +for an invalid handle. See L. + +=item $io->flush + +C 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 on error. + +=item $io->printflush ( ARGS ) + +Turns on autoflush, print ARGS and then restores the autoflush status of the +C object. Returns the return value from print. + +=item $io->blocking ( [ BOOL ] ) + +If called with an argument C will turn on non-blocking IO if +C is false, and turn it off if C is true. + +C will return the value of the previous setting, or the +current setting if C is not given. + +If an error occurs C will return undef and C<$!> will be set. + +=back + + +If the C functions setbuf() and/or setvbuf() are available, then +C and C 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 or C B in any way until the IO::Handle is closed or C or +C 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 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 object is a reference to a symbol/GLOB reference (see +the C package). Some modules that +inherit from C 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 variable in 'io_socket_timeout'. + +=head1 SEE ALSO + +L, +L, +L + +=head1 BUGS + +Due to backwards compatibility, all filehandles resemble objects +of class C, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C and inherit those methods. + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr EFE + +=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/^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/tlperl.old/lib/IO/Pipe.pm b/Master/tlpkg/tlperl.old/lib/IO/Pipe.pm new file mode 100644 index 00000000000..827cc48bfcd --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/IO/Pipe.pm @@ -0,0 +1,257 @@ +# IO::Pipe.pm +# +# Copyright (c) 1996-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +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 provides an interface to creating pipes between +processes. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [READER, WRITER] ) + +Creates an C, which is a reference to a newly created symbol +(see the C package). C optionally takes two +arguments, which should be objects blessed into C, or a +subclass thereof. These two objects will be used for the system call +to C. If no arguments are given then method C is called +on the new C object. + +These two handles are held in the array part of the GLOB until either +C or C is called. + +=back + +=head1 METHODS + +=over 4 + +=item reader ([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the reading end of the pipe. If C are given then C +is called and C are passed to exec. + +=item writer ([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the writing end of the pipe. If C are given then C +is called and C are passed to exec. + +=item handles () + +This method is called during construction by C +on the newly created C object. It returns an array of two objects +blessed into C, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to . + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/IO/Poll.pm b/Master/tlpkg/tlperl.old/lib/IO/Poll.pm new file mode 100644 index 00000000000..e7fb0135069 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/IO/Poll.pm @@ -0,0 +1,209 @@ + +# IO::Poll.pm +# +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +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 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. + +=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 + +=back + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to . + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/IO/Seekable.pm b/Master/tlpkg/tlperl.old/lib/IO/Seekable.pm new file mode 100644 index 00000000000..db1effda287 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/IO/Seekable.pm @@ -0,0 +1,128 @@ +# + +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 does not have a constructor of its own as it is intended to +be inherited by other C 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 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 on failure. + +=back + +See L for complete descriptions of each of the following +supported C 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 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 for full details) + +Returns the new position, or C 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, +L, +L +L + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr Egbarr@pobox.comE + +=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 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/tlperl.old/lib/IO/Select.pm b/Master/tlpkg/tlperl.old/lib/IO/Select.pm new file mode 100644 index 00000000000..fc05fe70e9c --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/IO/Select.pm @@ -0,0 +1,381 @@ +# IO::Select.pm +# +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +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 package implements an object approach to the system C static method. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] ) + +C method. + +Some HTML escapes are missing and many have not been tested. + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHORS + +Tim Jenness Etjenness@cpan.orgE + +Bug fixes and improvements have been received from: Simon Cozens +Esimon@cozens.netE, Mark A. Hershberger +Emah@everybody.orgE, Marcel Grunauer +Emarcel@codewerk.comE, Hugh S Myers +Ehsmyers@sdragons.comE, Peter J Acklam +Ejacklam@math.uio.noE, Sudhi Herle Esudhi@herle.netE, +Ariel Scolnicov Eariels@compugen.co.ilE, +Adriano Rodrigues Ferreira Eferreira@triang.com.brE and +R. de Vries Er.de.vries@dutchspace.nlE. + + +=head1 COPYRIGHT + +Copyright (C) 2000-2004 Tim Jenness. All Rights Reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=begin __PRIVATE__ + +=head1 REVISION + +$Id: LaTeX.pm,v 1.19 2004/12/30 01:40:44 timj Exp $ + +=end __PRIVATE__ + +=cut + +1; diff --git a/Master/tlpkg/tlperl.old/lib/Pod/Man.pm b/Master/tlpkg/tlperl.old/lib/Pod/Man.pm new file mode 100644 index 00000000000..693e4c46896 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Pod/Man.pm @@ -0,0 +1,1413 @@ +# 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 +# +# 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\@//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([SE] +# where is one of B, I, or F. Turn those into the right font start or +# end codes. The old pod2man didn't get B 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, normally via L, or printing using L. +It is conventionally invoked using the driver script B, but it can +also be used directly. + +As a derived class from Pod::Parser, Pod::Man supports the same methods and +interfaces. See L 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 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, 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 output. + +=item fixedbold + +Bold version of the fixed-width font. Defaults to CB. Only matters for +B 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 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 +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. This option, if given, overrides any automatic +determination of the name. + +=item quotes + +Sets the quote marks used to surround CE> 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, in which case no quote +marks are added around CE> 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 to +the last modified date and C 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 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, C, 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 and B don't either). + +=item Invalid link %s + +(W) The POD source contained a CE> 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%sE + +(W) The POD source contained an CE> escape that Pod::Man didn't +know about. C%sE> 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 CE>) 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 EEE 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 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 EEE 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 output. + +When and whether to use small caps is somewhat tricky, and Pod::Man doesn't +necessarily get it right. + +=head1 SEE ALSO + +L, L, L, L, L, +L, L + +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 and B. At the time of +this writing, it's available at +L. + +The man page documenting the man macro set may be L instead of +L on your system. Also, please see L 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. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Russ Allbery , based I heavily on the original +B by Tom Christiansen . + +=head1 COPYRIGHT AND LICENSE + +Copyright 1999, 2000, 2001, 2002, 2003 by Russ Allbery . + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Pod/ParseLink.pm b/Master/tlpkg/tlperl.old/lib/Pod/ParseLink.pm new file mode 100644 index 00000000000..7e4153da3d0 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Pod/ParseLink.pm @@ -0,0 +1,184 @@ +# 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 +# +# 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 LEE 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 LEE 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. 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/sectionE). + +The inferred anchor text is implemented per L: + + L => L + L => L<"section"|/section> + L => L<"section" in name|name/section> + +The name may contain embedded EEE and ZEE 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 LEE 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 EEE 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: + + LbarEslash> + +which should be interpreted as a link to the C POD page +and not as a link to the C section of the C POD page with an +anchor text of C. 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 EEE and ZEE 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 for more information. + +=head1 SEE ALSO + +L + +The current version of this module is always available from its web site at +L. + +=head1 AUTHOR + +Russ Allbery . + +=head1 COPYRIGHT AND LICENSE + +Copyright 2001 by Russ Allbery . + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl.old/lib/Pod/ParseUtils.pm b/Master/tlpkg/tlperl.old/lib/Pod/ParseUtils.pm new file mode 100644 index 00000000000..878860121d3 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Pod/ParseUtils.pm @@ -0,0 +1,852 @@ +############################################################################# +# 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 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 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-Enew() + +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-Efile() + +Without argument, retrieves the file name the list is in. This must +have been set before by either specifying B<-file> in the B +method or by calling the B 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-Estart() + +Without argument, retrieves the line number where the list started. +This must have been set before by either specifying B<-start> in the +B method or by calling the B 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-Eindent() + +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 method or by calling the B method +with a scalar argument. + +=cut + +# indent level +sub indent { + return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; +} + +=item $list-Etype() + +Without argument, retrieves the list type, which can be an arbitrary value, +e.g. C
    , C