From 61700e8be90ff6f495c0b1a9835fe07e9848de8d Mon Sep 17 00:00:00 2001 From: Reinhard Kotucha Date: Sat, 5 Jan 2008 21:23:03 +0000 Subject: tlperl: Perl for scripts provided by TeX Live. git-svn-id: svn://tug.org/texlive/trunk@6046 c570f23f-e606-0410-a88d-b1316a301751 --- .../auto/Win32API/Registry/Registry.dll | Bin Master/tlpkg/tlperl/README.txt | 12 + Master/tlpkg/tlperl/bin/perl.exe | Bin 0 -> 5632 bytes Master/tlpkg/tlperl/bin/perl58.dll | Bin 0 -> 1098752 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/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/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/List/Util.pm | 277 + 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/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 0 -> 4193 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 0 -> 2533 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 0 -> 1924 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 0 -> 1718 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/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 0 -> 113152 bytes Master/tlpkg/tlperl/lib/auto/B/C/C.bs | 0 Master/tlpkg/tlperl/lib/auto/B/C/C.dll | Bin 0 -> 8192 bytes Master/tlpkg/tlperl/lib/auto/Cwd/Cwd.bs | 0 Master/tlpkg/tlperl/lib/auto/Cwd/Cwd.dll | Bin 0 -> 10240 bytes Master/tlpkg/tlperl/lib/auto/Data/Dumper/Dumper.bs | 0 .../tlpkg/tlperl/lib/auto/Data/Dumper/Dumper.dll | Bin 0 -> 30720 bytes Master/tlpkg/tlperl/lib/auto/Digest/MD5/MD5.bs | 0 Master/tlpkg/tlperl/lib/auto/Digest/MD5/MD5.dll | Bin 0 -> 15872 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/Fcntl/Fcntl.bs | 0 Master/tlpkg/tlperl/lib/auto/Fcntl/Fcntl.dll | Bin 0 -> 14848 bytes Master/tlpkg/tlperl/lib/auto/File/Glob/Glob.bs | 0 Master/tlpkg/tlperl/lib/auto/File/Glob/Glob.dll | Bin 0 -> 16384 bytes Master/tlpkg/tlperl/lib/auto/IO/IO.bs | 0 Master/tlpkg/tlperl/lib/auto/IO/IO.dll | Bin 0 -> 16896 bytes Master/tlpkg/tlperl/lib/auto/List/Util/Util.bs | 0 Master/tlpkg/tlperl/lib/auto/List/Util/Util.dll | Bin 0 -> 26624 bytes Master/tlpkg/tlperl/lib/auto/POSIX/POSIX.bs | 0 Master/tlpkg/tlperl/lib/auto/POSIX/POSIX.dll | Bin 0 -> 97792 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 0 -> 29696 bytes Master/tlpkg/tlperl/lib/auto/Time/HiRes/HiRes.bs | 0 Master/tlpkg/tlperl/lib/auto/Time/HiRes/HiRes.dll | Bin 0 -> 18944 bytes Master/tlpkg/tlperl/lib/auto/Tk/.packlist | 650 + 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 0 -> 153600 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 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/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 0 -> 41472 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 0 -> 56832 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 0 -> 51712 bytes Master/tlpkg/tlperl/lib/auto/Tk/IO/IO.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/IO/IO.dll | Bin 0 -> 11264 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 0 -> 118784 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 0 -> 31232 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 0 -> 20992 bytes Master/tlpkg/tlperl/lib/auto/Tk/NBFrame/NBFrame.bs | 0 .../tlpkg/tlperl/lib/auto/Tk/NBFrame/NBFrame.dll | Bin 0 -> 22016 bytes Master/tlpkg/tlperl/lib/auto/Tk/PNG/PNG.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/PNG/PNG.dll | Bin 0 -> 168960 bytes Master/tlpkg/tlperl/lib/auto/Tk/Pixmap/Pixmap.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Pixmap/Pixmap.dll | Bin 0 -> 27136 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 0 -> 24576 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 0 -> 21504 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 0 -> 28672 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 0 -> 114176 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 0 -> 52224 bytes Master/tlpkg/tlperl/lib/auto/Tk/Tk.bs | 0 Master/tlpkg/tlperl/lib/auto/Tk/Tk.dll | Bin 0 -> 804864 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 0 -> 25088 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 0 -> 29696 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 + .../lib/auto/Win32/ChangeNotify/ChangeNotify.bs | 0 .../lib/auto/Win32/ChangeNotify/ChangeNotify.dll | Bin 0 -> 11776 bytes .../tlperl/lib/auto/Win32/Clipboard/Clipboard.bs | 0 .../tlperl/lib/auto/Win32/Clipboard/Clipboard.dll | Bin 0 -> 20480 bytes .../tlpkg/tlperl/lib/auto/Win32/Console/Console.bs | 0 .../tlperl/lib/auto/Win32/Console/Console.dll | Bin 0 -> 47104 bytes Master/tlpkg/tlperl/lib/auto/Win32/Event/Event.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Event/Event.dll | Bin 0 -> 12288 bytes .../tlperl/lib/auto/Win32/EventLog/EventLog.bs | 0 .../tlperl/lib/auto/Win32/EventLog/EventLog.dll | Bin 0 -> 25088 bytes Master/tlpkg/tlperl/lib/auto/Win32/File/File.bs | 0 Master/tlpkg/tlperl/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/lib/auto/Win32/IPC/IPC.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/IPC/IPC.dll | Bin 0 -> 13312 bytes .../tlperl/lib/auto/Win32/Internet/Internet.bs | 0 .../tlperl/lib/auto/Win32/Internet/Internet.dll | Bin 0 -> 51712 bytes Master/tlpkg/tlperl/lib/auto/Win32/Job/Job.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Job/Job.dll | Bin 0 -> 25088 bytes Master/tlpkg/tlperl/lib/auto/Win32/Mutex/Mutex.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Mutex/Mutex.dll | Bin 0 -> 10752 bytes .../tlperl/lib/auto/Win32/NetAdmin/NetAdmin.bs | 0 .../tlperl/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 .../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 0 -> 141824 bytes Master/tlpkg/tlperl/lib/auto/Win32/OLE/OLE.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/OLE/OLE.dll | Bin 0 -> 139264 bytes .../tlpkg/tlperl/lib/auto/Win32/PerfLib/PerfLib.bs | 0 .../tlperl/lib/auto/Win32/PerfLib/PerfLib.dll | Bin 0 -> 23040 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 0 -> 37376 bytes .../tlpkg/tlperl/lib/auto/Win32/Process/Process.bs | 0 .../tlperl/lib/auto/Win32/Process/Process.dll | Bin 0 -> 39424 bytes .../tlperl/lib/auto/Win32/Registry/Registry.bs | 0 .../tlperl/lib/auto/Win32/Registry/Registry.dll | Bin 0 -> 37376 bytes .../tlperl/lib/auto/Win32/Semaphore/Semaphore.bs | 0 .../tlperl/lib/auto/Win32/Semaphore/Semaphore.dll | Bin 0 -> 11264 bytes .../tlpkg/tlperl/lib/auto/Win32/Service/Service.bs | 0 .../tlperl/lib/auto/Win32/Service/Service.dll | Bin 0 -> 14848 bytes .../tlperl/lib/auto/Win32/Shortcut/Shortcut.bs | 0 .../tlperl/lib/auto/Win32/Shortcut/Shortcut.dll | Bin 0 -> 29184 bytes Master/tlpkg/tlperl/lib/auto/Win32/Sound/Sound.bs | 0 Master/tlpkg/tlperl/lib/auto/Win32/Sound/Sound.dll | Bin 0 -> 44544 bytes .../tlperl/lib/auto/Win32/WinError/WinError.bs | 0 .../tlperl/lib/auto/Win32/WinError/WinError.dll | Bin 0 -> 67584 bytes .../tlperl/lib/auto/Win32API/Registry/Registry.bs | 0 .../tlperl/lib/auto/Win32API/Registry/Registry.dll | Bin 0 -> 181760 bytes Master/tlpkg/tlperl/lib/auto/re/re.bs | 0 Master/tlpkg/tlperl/lib/auto/re/re.dll | Bin 0 -> 138240 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/lib/Win32/API.pm | 719 + Master/tlpkg/tlperl/lib/lib/Win32/API/Struct.pm | 528 + Master/tlpkg/tlperl/lib/lib/Win32/API/Type.pm | 440 + Master/tlpkg/tlperl/lib/lib/auto/Win32/API/API.dll | Bin 0 -> 20480 bytes 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 + 1222 files changed, 267608 insertions(+) mode change 100644 => 100755 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32API/Registry/Registry.dll create mode 100644 Master/tlpkg/tlperl/README.txt create mode 100755 Master/tlpkg/tlperl/bin/perl.exe create mode 100755 Master/tlpkg/tlperl/bin/perl58.dll create mode 100644 Master/tlpkg/tlperl/lib/AnyDBM_File.pm create mode 100644 Master/tlpkg/tlperl/lib/AutoLoader.pm create mode 100644 Master/tlpkg/tlperl/lib/B.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Asmdata.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Assembler.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Bblock.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Bytecode.pm create mode 100644 Master/tlpkg/tlperl/lib/B/C.pm create mode 100644 Master/tlpkg/tlperl/lib/B/CC.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Concise.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Debug.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Deparse.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Disassembler.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Lint.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Showlex.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Stackobj.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Stash.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Terse.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Xref.pm create mode 100644 Master/tlpkg/tlperl/lib/B/assemble create mode 100644 Master/tlpkg/tlperl/lib/B/cc_harness create mode 100644 Master/tlpkg/tlperl/lib/B/disassemble create mode 100644 Master/tlpkg/tlperl/lib/B/makeliblinks create mode 100644 Master/tlpkg/tlperl/lib/Carp.pm create mode 100644 Master/tlpkg/tlperl/lib/Carp/Heavy.pm create mode 100644 Master/tlpkg/tlperl/lib/Class/ISA.pm create mode 100644 Master/tlpkg/tlperl/lib/Class/Struct.pm create mode 100644 Master/tlpkg/tlperl/lib/Config.pm create mode 100644 Master/tlpkg/tlperl/lib/Cwd.pm create mode 100644 Master/tlpkg/tlperl/lib/Data/Dumper.pm create mode 100644 Master/tlpkg/tlperl/lib/Digest/MD5.pm create mode 100644 Master/tlpkg/tlperl/lib/Digest/base.pm create mode 100644 Master/tlpkg/tlperl/lib/Digest/file.pm create mode 100644 Master/tlpkg/tlperl/lib/DynaLoader.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/Alias.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/Byte.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/CJKConstants.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/CN.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/CN/HZ.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/Changes.e2x create mode 100644 Master/tlpkg/tlperl/lib/Encode/Config.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/ConfigLocal_PM.e2x create mode 100644 Master/tlpkg/tlperl/lib/Encode/EBCDIC.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/Encoder.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/Encoding.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/Guess.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/JP.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/JP/H2Z.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/JP/JIS7.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/KR.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/KR/2022_KR.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/MIME/Header.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/MIME/Header/ISO_2022_JP.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/Makefile_PL.e2x create mode 100644 Master/tlpkg/tlperl/lib/Encode/PerlIO.pod create mode 100644 Master/tlpkg/tlperl/lib/Encode/README.e2x create mode 100644 Master/tlpkg/tlperl/lib/Encode/Supported.pod create mode 100644 Master/tlpkg/tlperl/lib/Encode/Symbol.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/TW.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/Unicode.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/Unicode/UTF7.pm create mode 100644 Master/tlpkg/tlperl/lib/Encode/_PM.e2x create mode 100644 Master/tlpkg/tlperl/lib/Encode/_T.e2x create mode 100644 Master/tlpkg/tlperl/lib/Encode/encode.h create mode 100644 Master/tlpkg/tlperl/lib/Exporter.pm create mode 100644 Master/tlpkg/tlperl/lib/Exporter/Heavy.pm create mode 100644 Master/tlpkg/tlperl/lib/Fcntl.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Basename.pm create mode 100644 Master/tlpkg/tlperl/lib/File/CheckTree.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Compare.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Copy.pm create mode 100644 Master/tlpkg/tlperl/lib/File/DosGlob.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Find.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Glob.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Path.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Functions.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Mac.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/OS2.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Unix.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/VMS.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Win32.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Temp.pm create mode 100644 Master/tlpkg/tlperl/lib/File/stat.pm create mode 100644 Master/tlpkg/tlperl/lib/FileHandle.pm create mode 100644 Master/tlpkg/tlperl/lib/Getopt/Long.pm create mode 100644 Master/tlpkg/tlperl/lib/Getopt/Std.pm create mode 100644 Master/tlpkg/tlperl/lib/IO.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/Dir.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/File.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/Handle.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/Pipe.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/Poll.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/Seekable.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/Select.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/Socket.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/Socket/INET.pm create mode 100644 Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm create mode 100644 Master/tlpkg/tlperl/lib/List/Util.pm create mode 100644 Master/tlpkg/tlperl/lib/SelectSaver.pm create mode 100644 Master/tlpkg/tlperl/lib/Symbol.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/ANSIColor.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/Cap.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/Complete.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/ReadLine.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/Abbrev.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/Balanced.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/ParseWords.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/Soundex.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/Tabs.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/Wrap.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Array.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/File.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Handle.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Hash.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Memoize.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/RefHash.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Scalar.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/SubstrHash.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/HiRes.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/Local.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/gmtime.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/localtime.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/tm.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Adjuster.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/After.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Animation.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Balloon.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Bitmap.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Button.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Camel.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Canvas.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Clipboard.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/CmdLine.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Compound.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Config.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Configure.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Credits create mode 100644 Master/tlpkg/tlperl/lib/Tk/Derived.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Dialog.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DialogBox.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DirTree.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Dirlist.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DropSite.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/English.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Entry.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Event.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Event/IO.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/FBox.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/FileSelect.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Font.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Frame.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/HList.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/IO.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/IconList.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Image.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/JPEG.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/LabEntry.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/LabFrame.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/LabRadio.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Label.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Labelframe.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Listbox.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/MMtry.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/MMutil.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/MainWindow.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Menu.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Menubar.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Menubutton.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Message.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/NBFrame.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/NoteBook.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/PNG.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Pane.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Photo.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Pixmap.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Pretty.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/README.Adjust create mode 100644 Master/tlpkg/tlperl/lib/Tk/ROText.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Region.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Reindex.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Scale.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Spinbox.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Stats.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Submethods.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/TList.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Table.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Text.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/TextEdit.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/TextList.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/TextUndo.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Tiler.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/TixGrid.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Tk.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Tk.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/TkXSUB.def create mode 100644 Master/tlpkg/tlperl/lib/Tk/Toplevel.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Trace.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Tree.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Widget.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Wm.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/X.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/X.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/keysym.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11/license.terms create mode 100644 Master/tlpkg/tlperl/lib/Tk/X11Font.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Xcamel.gif create mode 100644 Master/tlpkg/tlperl/lib/Tk/Xlib.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/Xrm.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/act_folder.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/act_folder.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/anim.gif create mode 100644 Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/balArrow.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/file.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/file.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/folder.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/folder.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/icon.gif create mode 100644 Master/tlpkg/tlperl/lib/Tk/install.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/license.terms create mode 100644 Master/tlpkg/tlperl/lib/Tk/openfile.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/openfolder.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/openfolder.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/prolog.ps create mode 100644 Master/tlpkg/tlperl/lib/Tk/reindex.pl create mode 100644 Master/tlpkg/tlperl/lib/Tk/srcfile.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/textfile.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue.def create mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue.m create mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue.t create mode 100644 Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h create mode 100644 Master/tlpkg/tlperl/lib/Tk/tranicon.gif create mode 100644 Master/tlpkg/tlperl/lib/Tk/typemap create mode 100644 Master/tlpkg/tlperl/lib/Tk/vtab.def create mode 100644 Master/tlpkg/tlperl/lib/Tk/widgets.pm create mode 100644 Master/tlpkg/tlperl/lib/Tk/win.xbm create mode 100644 Master/tlpkg/tlperl/lib/Tk/winfolder.xpm create mode 100644 Master/tlpkg/tlperl/lib/Tk/wintext.xpm create mode 100644 Master/tlpkg/tlperl/lib/UNIVERSAL.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/ChangeNotify.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Client.pl create mode 100644 Master/tlpkg/tlperl/lib/Win32/Clipboard.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Console.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Event.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/EventLog.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/File.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/IPC.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Internet.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Job.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Mutex.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/NetAdmin.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/NetResource.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/ODBC.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/PerfLib.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Pipe.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Process.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Registry.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Semaphore.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Server.pl create mode 100644 Master/tlpkg/tlperl/lib/Win32/Service.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Shortcut.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Sound.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Test.pl create mode 100644 Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/WinError.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/test-async.pl create mode 100644 Master/tlpkg/tlperl/lib/Win32API/Registry.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32API/Registry/cRegistry.pc create mode 100644 Master/tlpkg/tlperl/lib/XSLoader.pm create mode 100644 Master/tlpkg/tlperl/lib/attributes.pm create mode 100644 Master/tlpkg/tlperl/lib/auto/B/B.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/B/B.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/B/C/C.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/B/C/C.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Cwd/Cwd.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Cwd/Cwd.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Data/Dumper/Dumper.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Data/Dumper/Dumper.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Digest/MD5/MD5.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Digest/MD5/MD5.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/DynaLoader/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/DynaLoader/dl_expandspec.al create mode 100644 Master/tlpkg/tlperl/lib/auto/DynaLoader/dl_find_symbol_anywhere.al create mode 100644 Master/tlpkg/tlperl/lib/auto/DynaLoader/dl_findfile.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Fcntl/Fcntl.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Fcntl/Fcntl.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/File/Glob/Glob.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/File/Glob/Glob.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/IO/IO.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/IO/IO.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/List/Util/Util.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/List/Util/Util.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/POSIX.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/POSIX/POSIX.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/SigAction/flags.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/SigAction/handler.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/SigAction/mask.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/SigAction/safe.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/abs.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/alarm.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/assert.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atan2.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atexit.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atof.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atoi.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/atol.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/bsearch.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/calloc.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/chdir.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/chmod.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/chown.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/clearerr.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/closedir.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/cos.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/creat.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/div.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/errno.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execl.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execle.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execlp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execv.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execve.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/execvp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/exit.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/exp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fabs.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fclose.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fcntl.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fdopen.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/feof.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/ferror.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fflush.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fgetc.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fgetpos.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fgets.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fileno.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fopen.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fork.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fprintf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fputc.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fputs.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fread.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/free.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/freopen.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fscanf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fseek.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fsetpos.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fstat.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fsync.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/ftell.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/fwrite.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getc.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getchar.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getegid.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getenv.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/geteuid.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getgid.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getgrgid.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getgrnam.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getgroups.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getlogin.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getpgrp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getpid.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getppid.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getpwnam.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getpwuid.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/gets.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/getuid.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/gmtime.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/isatty.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/kill.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/labs.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/ldiv.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/link.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/load_imports.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/localtime.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/log.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/longjmp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/malloc.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memchr.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memcmp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memcpy.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memmove.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/memset.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/mkdir.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/offsetof.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/opendir.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/perror.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/pow.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/printf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/putc.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/putchar.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/puts.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/qsort.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/raise.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rand.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/readdir.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/realloc.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/redef.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/remove.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rename.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rewind.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rewinddir.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/rmdir.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/scanf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/setbuf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/setjmp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/setvbuf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/siglongjmp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sigsetjmp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sin.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sleep.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sprintf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sqrt.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/srand.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/sscanf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/stat.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strcat.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strchr.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strcmp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strcpy.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strcspn.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strerror.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strlen.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strncat.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strncmp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strncpy.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strpbrk.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strrchr.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strspn.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strstr.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/strtok.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/system.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/time.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/tmpfile.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/tolower.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/toupper.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/umask.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/ungetc.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/unimpl.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/unlink.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/usage.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/utime.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/vfprintf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/vprintf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/vsprintf.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/wait.al create mode 100644 Master/tlpkg/tlperl/lib/auto/POSIX/waitpid.al create mode 100644 Master/tlpkg/tlperl/lib/auto/SDBM_File/SDBM_File.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/SDBM_File/SDBM_File.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Time/HiRes/HiRes.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Time/HiRes/HiRes.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/.packlist create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/CancelRepeat.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Canvas/Canvas.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Canvas/Canvas.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Clipboard/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Clipboard/getSelected.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Compound/Compound.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Compound/Compound.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/DragDrop/Win32Site/Win32Site.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/DragDrop/Win32Site/Win32Site.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/EnterFocus.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Entry/Entry.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Entry/Entry.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Error.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Event/Event.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Event/Event.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/FirstMenu.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/FocusChildren.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/FocusOK.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/AddScrollbars.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/FindMenu.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/freeze_on_map.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/label.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/labelPack.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/labelVariable.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/packscrollbars.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/queuePack.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/sbset.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Frame/scrollbars.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/HList/HList.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/HList/HList.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/IO/IO.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/IO/IO.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/ImageNames.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/ImageTypes.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/JPEG/JPEG.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/JPEG/JPEG.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/AutoScan.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/BeginExtend.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/BeginSelect.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/BeginToggle.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/ButtonRelease_1.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/CLEAR.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Cancel.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Cntrl_End.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Cntrl_Home.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Cntrl_backslash.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/DELETE.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/DataExtend.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/EXISTS.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/EXTEND.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/ExtendUpDown.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/FETCH.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/FETCHSIZE.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Listbox.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Listbox.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/Motion.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/POP.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/PUSH.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SHIFT.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SPLICE.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/STORE.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SelectAll.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/SetList.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/TIEARRAY.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/TIESCALAR.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/UNSHIFT.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/UpDown.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/clipboardPaste.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/deleteSelected.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/getSelected.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Listbox/xyIndex.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Menubutton/Menubutton.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Menubutton/Menubutton.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/NBFrame/NBFrame.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/NBFrame/NBFrame.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/PNG/PNG.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/PNG/PNG.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Pixmap/Pixmap.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Pixmap/Pixmap.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Receive.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/RepeatId.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Activate.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/ButtonDown.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/ButtonUp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/ControlPress.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Drag.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/EndDrag.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Enter.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Increment.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Leave.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Scale.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Scale/Scale.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scale/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ButtonDown.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ButtonUp.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Drag.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/EndDrag.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Enter.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Leave.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Motion.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ScrlByPages.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ScrlByUnits.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ScrlToPos.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/ScrlTopBottom.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Scrollbar.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Scrollbar.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/Select.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/StartDrag.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Scrollbar/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Selection.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TList/TList.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/TList/TList.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/Create.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/Posn.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/see.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/totalColumns.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Table/totalRows.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Text/Text.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Text/Text.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Text/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TextEdit/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TextUndo/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TixGrid/TixGrid.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/TixGrid/TixGrid.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Tk.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Tk.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_BindIn.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_BindOut.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_Create.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_Destroy.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_In.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/FG_Out.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Toplevel/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/TraverseToMenu.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/ASkludge.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/bindDump.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/clipboardKeysyms.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Widget/pathname.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/AnchorAdjust.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/FullScreen.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/Popup.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/Post.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Wm/iconposition.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/X/X.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/X/X.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/X/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/Xlib/Xlib.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Tk/Xlib/Xlib.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/break.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/focusFollowsMouse.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/focusNext.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/focusPrev.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/getEncoding.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/interps.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/lsearch.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/pTk/extralibs.ld create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/tabFocus.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Tk/updateWidgets.al create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/ChangeNotify/ChangeNotify.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/ChangeNotify/ChangeNotify.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Clipboard/Clipboard.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Clipboard/Clipboard.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Console/Console.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Console/Console.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Event/Event.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Event/Event.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/EventLog/EventLog.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/EventLog/EventLog.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/File/File.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/File/File.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/FileSecurity/FileSecurity.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/FileSecurity/FileSecurity.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/IPC/IPC.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/IPC/IPC.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Internet/Internet.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Internet/Internet.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Job/Job.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Job/Job.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Mutex/Mutex.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Mutex/Mutex.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/NetAdmin/NetAdmin.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/NetAdmin/NetAdmin.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/NetResource/NetResource.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/NetResource/NetResource.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/NetResource/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/ODBC/ODBC.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/ODBC/ODBC.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/OLE/OLE.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/OLE/OLE.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/PerfLib/PerfLib.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/PerfLib/PerfLib.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/PerfLib/autosplit.ix create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Pipe/Pipe.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Pipe/Pipe.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Process/Process.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Process/Process.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Registry/Registry.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Registry/Registry.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Semaphore/Semaphore.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Semaphore/Semaphore.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Service/Service.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Service/Service.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Shortcut/Shortcut.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Shortcut/Shortcut.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/Sound/Sound.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/Sound/Sound.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32/WinError/WinError.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32/WinError/WinError.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/Win32API/Registry/Registry.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/Win32API/Registry/Registry.dll create mode 100644 Master/tlpkg/tlperl/lib/auto/re/re.bs create mode 100755 Master/tlpkg/tlperl/lib/auto/re/re.dll create mode 100644 Master/tlpkg/tlperl/lib/base.pm create mode 100644 Master/tlpkg/tlperl/lib/bytes.pm create mode 100644 Master/tlpkg/tlperl/lib/bytes_heavy.pl create mode 100644 Master/tlpkg/tlperl/lib/constant.pm create mode 100644 Master/tlpkg/tlperl/lib/fields.pm create mode 100644 Master/tlpkg/tlperl/lib/lib.pm create mode 100644 Master/tlpkg/tlperl/lib/lib/Win32/API.pm create mode 100644 Master/tlpkg/tlperl/lib/lib/Win32/API/Struct.pm create mode 100644 Master/tlpkg/tlperl/lib/lib/Win32/API/Type.pm create mode 100755 Master/tlpkg/tlperl/lib/lib/auto/Win32/API/API.dll create mode 100644 Master/tlpkg/tlperl/lib/newgetopt.pl create mode 100644 Master/tlpkg/tlperl/lib/overload.pm create mode 100644 Master/tlpkg/tlperl/lib/re.pm create mode 100644 Master/tlpkg/tlperl/lib/strict.pm create mode 100644 Master/tlpkg/tlperl/lib/subs.pm create mode 100644 Master/tlpkg/tlperl/lib/unicore/ArabicShaping.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/BidiMirroring.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/Blocks.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/Canonical.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/CaseFolding.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/CombiningClass.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/CompositionExclusions.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/Decomposition.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/EastAsianWidth.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/Exact.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/HangulSyllableType.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/Index.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/Jamo.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/LineBreak.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/Name.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/NamedSequences.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/NamesList.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/NormalizationCorrections.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/PVA.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/PropList.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/PropValueAliases.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/Properties create mode 100644 Master/tlpkg/tlperl/lib/unicore/PropertyAliases.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/ReadMe.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/Scripts.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/SpecialCasing.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/StandardizedVariants.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Digit.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Fold.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Lower.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Title.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/To/Upper.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/UnicodeData.txt create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/AL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/AN.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/B.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/BN.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/CS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/EN.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/ES.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/ET.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/L.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/LRE.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/LRO.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/NSM.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/ON.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/PDF.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/R.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/RLE.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/RLO.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/S.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/bc/WS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/A.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/AL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/AR.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/ATAR.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/ATB.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/ATBL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/B.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/BL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/BR.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/DA.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/DB.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/IS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/KV.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/L.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/NK.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/NR.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/OV.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/R.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ccc/VR.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/can.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/com.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/enc.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/fin.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/font.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/fra.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/init.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/iso.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/med.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/nar.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/nb.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/sml.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/sqr.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/sub.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/sup.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/vert.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/dt/wide.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/A.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/F.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/H.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/N.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/Na.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/ea/W.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/AHex.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/ASCII.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Alnum.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Alpha.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Alphabet.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Any.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Arab.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Armn.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/AsciiHex.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Assigned.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Beng.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/BidiC.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/BidiCont.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Blank.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Bopo.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Brai.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Bugi.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Buhd.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/C.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Canadian.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cc.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cf.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cher.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cn.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cntrl.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Co.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Copt.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cprt.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cs.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Cyrl.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dash.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dash2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dep.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Deprecat.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Deva.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dia.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Diacriti.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Digit.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Dsrt.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ethi.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ext.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Extender.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Geor.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Glag.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Goth.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/GrLink.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Graph.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Grapheme.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Grek.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Gujr.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Guru.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hang.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hani.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hano.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hebr.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hex.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/HexDigit.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hira.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hyphen.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Hyphen2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IDSB.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IDST.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IdContin.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IdStart.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ideo.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ideograp.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IdsBinar.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/IdsTrina.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InAegean.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InAlphab.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InAncie2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InAncien.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabi2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabi3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabi4.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArabic.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArmeni.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InArrows.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBasicL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBengal.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBlockE.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBopom2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBopomo.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBoxDra.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBraill.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBugine.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InBuhid.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InByzant.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCherok.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCo2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCo3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCo4.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkCom.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkRad.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkStr.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkSym.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkUn2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkUn3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCjkUni.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombi2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombi3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombi4.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCombin.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InContro.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCoptic.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCurren.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCyprio.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCyril2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InCyrill.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InDesere.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InDevana.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InDingba.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEnclo2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEnclos.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEthio2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEthio3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InEthiop.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGenera.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGeomet.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGeorg2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGeorgi.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGlagol.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGothic.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGreekA.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGreekE.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGujara.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InGurmuk.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHalfwi.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHangu2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHangu3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHangul.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHanuno.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHebrew.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHighPr.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHighSu.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InHiraga.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InIdeogr.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InIpaExt.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKanbun.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKangxi.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKannad.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKatak2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKataka.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKharos.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKhmer.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InKhmerS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLao.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatin1.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatin2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatin3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLatinE.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLetter.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLimbu.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLinea2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLinear.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InLowSur.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMalaya.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMathe2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMathem.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce4.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMisce5.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMiscel.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InModifi.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMongol.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMusica.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InMyanma.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InNewTai.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InNumber.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOgham.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOldIta.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOldPer.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOptica.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOriya.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InOsmany.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InPhone2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InPhonet.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InPrivat.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InRunic.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InShavia.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSinhal.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSmallF.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSpacin.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSpecia.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSupers.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl4.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl5.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSuppl6.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSupple.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSyloti.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InSyriac.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTagalo.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTagban.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTags.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTaiLe.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTaiXua.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTamil.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTelugu.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InThaana.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InThai.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTibeta.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InTifina.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InUgarit.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InUnifie.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InVaria2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InVariat.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InVertic.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InYiRadi.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InYiSyll.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/InYijing.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/JoinC.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/JoinCont.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Kana.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Khar.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Khmr.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Knda.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/L.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LC.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LOE.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Laoo.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Latn.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Limb.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LinearB.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ll.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lm.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lo.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/LogicalO.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lower.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lowercas.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lt.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Lu.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/M.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Math.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mc.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Me.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mlym.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mn.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mong.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Mymr.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/N.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/NChar.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Nd.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/NewTaiLu.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Nl.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/No.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Nonchara.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OAlpha.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/ODI.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OGrExt.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OIDC.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OIDS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OLower.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OMath.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OUpper.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ogam.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OldItali.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OldPersi.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Orya.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Osma.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherAlp.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherDef.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherGra.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherIdC.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherIdS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherLow.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherMat.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/OtherUpp.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/P.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/PatSyn.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/PatWS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/PatternS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/PatternW.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pc.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pd.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pe.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pf.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Pi.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Po.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Print.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ps.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Punct.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/QMark.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Qaai.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Quotatio.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Radical.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Radical2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Runr.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/S.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/SD.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/STerm.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sc.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Shaw.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sinh.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sk.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sm.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/So.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/SoftDott.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Space.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/SpacePer.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Sterm2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/SylotiNa.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Syrc.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tagb.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/TaiLe.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Taml.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Telu.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Term.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Terminal.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tfng.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tglg.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Thaa.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Thai.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Tibt.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Title.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/UIdeo.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Ugar.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/UnifiedI.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Upper.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Uppercas.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/VS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Variatio.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/WSpace.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/WhiteSpa.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Word.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/XDigit.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Yiii.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Z.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zl.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zp.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zs.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/Zyyy.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/_CanonDC.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/_CaseIgn.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/gc_sc/_CombAbo.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/L.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/LV.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/LVT.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/T.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/hst/V.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/jt/C.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/jt/D.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/jt/R.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/jt/U.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/AI.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/AL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/B2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/BA.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/BB.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/BK.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/CB.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/CL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/CM.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/CR.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/EX.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/GL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/H2.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/H3.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/HY.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/ID.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/IN.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/IS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/JL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/JT.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/JV.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/LF.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/NL.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/NS.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/NU.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/OP.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/PO.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/PR.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/QU.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/SA.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/SG.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/SP.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/SY.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/WJ.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/XX.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/lb/ZW.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/nt/De.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/nt/Di.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/lib/nt/Nu.pl create mode 100644 Master/tlpkg/tlperl/lib/unicore/mktables create mode 100644 Master/tlpkg/tlperl/lib/unicore/mktables.lst create mode 100644 Master/tlpkg/tlperl/lib/unicore/version create mode 100644 Master/tlpkg/tlperl/lib/utf8.pm create mode 100644 Master/tlpkg/tlperl/lib/utf8_heavy.pl create mode 100644 Master/tlpkg/tlperl/lib/vars.pm create mode 100644 Master/tlpkg/tlperl/lib/warnings.pm create mode 100644 Master/tlpkg/tlperl/lib/warnings/register.pm diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32API/Registry/Registry.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32API/Registry/Registry.dll old mode 100644 new mode 100755 diff --git a/Master/tlpkg/tlperl/README.txt b/Master/tlpkg/tlperl/README.txt new file mode 100644 index 00000000000..47b7a03d1ac --- /dev/null +++ b/Master/tlpkg/tlperl/README.txt @@ -0,0 +1,12 @@ +$ Id: $ + +This directory contains a subset of the Perl distribution which is +supposed to be used by the Perl scripts shipped with TeX Live only. + +The files had been compiled by Siep Kroonenberg with MinGW. + +If you want to run any other Perl scripts, please install a complete +Perl system. A complete Perl system for Windows can be obtained from: + + http://www.activestate.com + diff --git a/Master/tlpkg/tlperl/bin/perl.exe b/Master/tlpkg/tlperl/bin/perl.exe new file mode 100755 index 00000000000..30108d9a8cc Binary files /dev/null and b/Master/tlpkg/tlperl/bin/perl.exe differ diff --git a/Master/tlpkg/tlperl/bin/perl58.dll b/Master/tlpkg/tlperl/bin/perl58.dll new file mode 100755 index 00000000000..d783261a862 Binary files /dev/null and b/Master/tlpkg/tlperl/bin/perl58.dll differ diff --git a/Master/tlpkg/tlperl/lib/AnyDBM_File.pm b/Master/tlpkg/tlperl/lib/AnyDBM_File.pm new file mode 100644 index 00000000000..d73abab0f9e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/AnyDBM_File.pm @@ -0,0 +1,93 @@ +package AnyDBM_File; + +use 5.006_001; +our $VERSION = '1.00'; +our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; + +my $mod; +for $mod (@ISA) { + if (eval "require $mod") { + @ISA = ($mod); # if we leave @ISA alone, warnings abound + return 1; + } +} + +die "No DBM package was successfully found or installed"; +#return 0; + +=head1 NAME + +AnyDBM_File - provide framework for multiple DBMs + +NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations + +=head1 SYNOPSIS + + use AnyDBM_File; + +=head1 DESCRIPTION + +This module is a "pure virtual base class"--it has nothing of its own. +It's just there to inherit from one of the various DBM packages. It +prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See +L), 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/lib/AutoLoader.pm b/Master/tlpkg/tlperl/lib/AutoLoader.pm new file mode 100644 index 00000000000..4352d8b1fbe --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B.pm b/Master/tlpkg/tlperl/lib/B.pm new file mode 100644 index 00000000000..12917347cd0 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Asmdata.pm b/Master/tlpkg/tlperl/lib/B/Asmdata.pm new file mode 100644 index 00000000000..9e41d6dd757 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Assembler.pm b/Master/tlpkg/tlperl/lib/B/Assembler.pm new file mode 100644 index 00000000000..f312273ce36 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Bblock.pm b/Master/tlpkg/tlperl/lib/B/Bblock.pm new file mode 100644 index 00000000000..9566d125aaa --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Bytecode.pm b/Master/tlpkg/tlperl/lib/B/Bytecode.pm new file mode 100644 index 00000000000..250569ae57b --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/C.pm b/Master/tlpkg/tlperl/lib/B/C.pm new file mode 100644 index 00000000000..cebf4132ffd --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/CC.pm b/Master/tlpkg/tlperl/lib/B/CC.pm new file mode 100644 index 00000000000..079313a0a4e --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Concise.pm b/Master/tlpkg/tlperl/lib/B/Concise.pm new file mode 100644 index 00000000000..c84578e44c4 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Debug.pm b/Master/tlpkg/tlperl/lib/B/Debug.pm new file mode 100644 index 00000000000..cb369682d66 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm new file mode 100644 index 00000000000..3db6fbe6e1f --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Disassembler.pm b/Master/tlpkg/tlperl/lib/B/Disassembler.pm new file mode 100644 index 00000000000..e1993aa9537 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Lint.pm b/Master/tlpkg/tlperl/lib/B/Lint.pm new file mode 100644 index 00000000000..3475bd2596e --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Showlex.pm b/Master/tlpkg/tlperl/lib/B/Showlex.pm new file mode 100644 index 00000000000..3b261a337df --- /dev/null +++ b/Master/tlpkg/tlperl/lib/B/Showlex.pm @@ -0,0 +1,205 @@ +package B::Showlex; + +our $VERSION = '1.02'; + +use strict; +use B qw(svref_2object comppadlist class); +use B::Terse (); +use B::Concise (); + +# +# Invoke as +# perl -MO=Showlex,foo bar.pl +# to see the names of lexical variables used by &foo +# or as +# perl -MO=Showlex bar.pl +# to see the names of file scope lexicals used by bar.pl +# + + +# borrowed from B::Concise +our $walkHandle = \*STDOUT; + +sub walk_output { # updates $walkHandle + $walkHandle = B::Concise::walk_output(@_); + #print "got $walkHandle"; + #print $walkHandle "using it"; + $walkHandle; +} + +sub shownamearray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print $walkHandle "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + my $sv = $els[$i]; + if (class($sv) ne "SPECIAL") { + printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + } else { + printf $walkHandle "$i: %s\n", $sv->terse; + #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); + } + } +} + +sub showvaluearray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print $walkHandle "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + printf $walkHandle "$i: %s\n", $els[$i]->terse; + #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]); + } +} + +sub showlex { + my ($objname, $namesav, $valsav) = @_; + shownamearray("Pad of lexical names for $objname", $namesav); + showvaluearray("Pad of lexical values for $objname", $valsav); +} + +my ($newlex, $nosp1); # rendering state vars + +sub newlex { # drop-in for showlex + my ($objname, $names, $vals) = @_; + my @names = $names->ARRAY; + my @vals = $vals->ARRAY; + my $count = @names; + print $walkHandle "$objname Pad has $count entries\n"; + printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1; + for (my $i = 1; $i < $count; $i++) { + printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse + unless $nosp1 and $names[$i]->terse =~ /SPECIAL/; + } +} + +sub showlex_obj { + my ($objname, $obj) = @_; + $objname =~ s/^&main::/&/; + showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex; + newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex; +} + +sub showlex_main { + showlex("comppadlist", comppadlist->ARRAY) if !$newlex; + newlex ("main", comppadlist->ARRAY) if $newlex; +} + +sub compile { + my @options = grep(/^-/, @_); + my @args = grep(!/^-/, @_); + for my $o (@options) { + $newlex = 1 if $o eq "-newlex"; + $nosp1 = 1 if $o eq "-nosp"; + } + + return \&showlex_main unless @args; + return sub { + my $objref; + foreach my $objname (@args) { + next unless $objname; # skip nulls w/o carping + + if (ref $objname) { + print $walkHandle "B::Showlex::compile($objname)\n"; + $objref = $objname; + } else { + $objname = "main::$objname" unless $objname =~ /::/; + print $walkHandle "$objname:\n"; + no strict 'refs'; + die "err: unknown function ($objname)\n" + unless *{$objname}{CODE}; + $objref = \&$objname; + } + showlex_obj($objname, $objref); + } + } +} + +1; + +__END__ + +=head1 NAME + +B::Showlex - Show lexical variables used in functions or files + +=head1 SYNOPSIS + + perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl + +=head1 DESCRIPTION + +When a comma-separated list of subroutine names is given as options, Showlex +prints the lexical variables used in those subroutines. Otherwise, it prints +the file-scope lexicals in the file. + +=head1 EXAMPLES + +Traditional form: + + $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")' + Pad of lexical names for comppadlist has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0x9db0fb0) $i + 2: PVNV (0x9db0f38) $j + 3: PVNV (0x9db0f50) $k + Pad of lexical values for comppadlist has 5 entries + 0: SPECIAL #1 &PL_sv_undef + 1: NULL (0x9da4234) + 2: NULL (0x9db0f2c) + 3: NULL (0x9db0f44) + 4: NULL (0x9da4264) + -e syntax OK + +New-style form: + + $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")' + main Pad has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234) + 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34) + 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c) + -e syntax OK + +New form, no specials, outside O framework: + + $ perl -MB::Showlex -e \ + 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()' + main Pad has 4 entries + 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1 + 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo" + 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74) + +Note that this example shows the values of the lexicals, whereas the other +examples did not (as they're compile-time only). + +=head2 OPTIONS + +The C<-newlex> option produces a more readable C<< name => value >> format, +and is shown in the second example above. + +The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL +#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm +your declared lexicals. + +=head1 SEE ALSO + +C 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/lib/B/Stackobj.pm b/Master/tlpkg/tlperl/lib/B/Stackobj.pm new file mode 100644 index 00000000000..b17dfb8173a --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Stash.pm b/Master/tlpkg/tlperl/lib/B/Stash.pm new file mode 100644 index 00000000000..5e60868a28e --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Terse.pm b/Master/tlpkg/tlperl/lib/B/Terse.pm new file mode 100644 index 00000000000..1d53950ad3b --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/Xref.pm b/Master/tlpkg/tlperl/lib/B/Xref.pm new file mode 100644 index 00000000000..f727dc766b5 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/assemble b/Master/tlpkg/tlperl/lib/B/assemble new file mode 100644 index 00000000000..43cc5bc4b33 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/cc_harness b/Master/tlpkg/tlperl/lib/B/cc_harness new file mode 100644 index 00000000000..79f8727a8f0 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/disassemble b/Master/tlpkg/tlperl/lib/B/disassemble new file mode 100644 index 00000000000..6530b809502 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/B/makeliblinks b/Master/tlpkg/tlperl/lib/B/makeliblinks new file mode 100644 index 00000000000..82560783c01 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Carp.pm b/Master/tlpkg/tlperl/lib/Carp.pm new file mode 100644 index 00000000000..1a814ead34f --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Carp/Heavy.pm b/Master/tlpkg/tlperl/lib/Carp/Heavy.pm new file mode 100644 index 00000000000..55bca2b421a --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Class/ISA.pm b/Master/tlpkg/tlperl/lib/Class/ISA.pm new file mode 100644 index 00000000000..e1371912e2c --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Class/Struct.pm b/Master/tlpkg/tlperl/lib/Class/Struct.pm new file mode 100644 index 00000000000..7a9af54faf8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Class/Struct.pm @@ -0,0 +1,636 @@ +package Class::Struct; + +## See POD after __END__ + +use 5.006_001; + +use strict; +use warnings::register; +our(@ISA, @EXPORT, $VERSION); + +use Carp; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(struct); + +$VERSION = '0.63'; + +## Tested on 5.002 and 5.003 without class membership tests: +my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95); + +my $print = 0; +sub printem { + if (@_) { $print = shift } + else { $print++ } +} + +{ + package Class::Struct::Tie_ISA; + + sub TIEARRAY { + my $class = shift; + return bless [], $class; + } + + sub STORE { + my ($self, $index, $value) = @_; + Class::Struct::_subclass_error(); + } + + sub FETCH { + my ($self, $index) = @_; + $self->[$index]; + } + + sub FETCHSIZE { + my $self = shift; + return scalar(@$self); + } + + sub DESTROY { } +} + +sub import { + my $self = shift; + + if ( @_ == 0 ) { + $self->export_to_level( 1, $self, @EXPORT ); + } elsif ( @_ == 1 ) { + # This is admittedly a little bit silly: + # do we ever export anything else than 'struct'...? + $self->export_to_level( 1, $self, @_ ); + } else { + goto &struct; + } +} + +sub struct { + + # Determine parameter list structure, one of: + # struct( class => [ element-list ]) + # struct( class => { element-list }) + # struct( element-list ) + # Latter form assumes current package name as struct name. + + my ($class, @decls); + my $base_type = ref $_[1]; + if ( $base_type eq 'HASH' ) { + $class = shift; + @decls = %{shift()}; + _usage_error() if @_; + } + elsif ( $base_type eq 'ARRAY' ) { + $class = shift; + @decls = @{shift()}; + _usage_error() if @_; + } + else { + $base_type = 'ARRAY'; + $class = (caller())[0]; + @decls = @_; + } + + _usage_error() if @decls % 2 == 1; + + # Ensure we are not, and will not be, a subclass. + + my $isa = do { + no strict 'refs'; + \@{$class . '::ISA'}; + }; + _subclass_error() if @$isa; + tie @$isa, 'Class::Struct::Tie_ISA'; + + # Create constructor. + + croak "function 'new' already defined in package $class" + if do { no strict 'refs'; defined &{$class . "::new"} }; + + my @methods = (); + my %refs = (); + my %arrays = (); + my %hashes = (); + my %classes = (); + my $got_class = 0; + my $out = ''; + + $out = "{\n package $class;\n use Carp;\n sub new {\n"; + $out .= " my (\$class, \%init) = \@_;\n"; + $out .= " \$class = __PACKAGE__ unless \@_;\n"; + + my $cnt = 0; + my $idx = 0; + my( $cmt, $name, $type, $elem ); + + if( $base_type eq 'HASH' ){ + $out .= " my(\$r) = {};\n"; + $cmt = ''; + } + elsif( $base_type eq 'ARRAY' ){ + $out .= " my(\$r) = [];\n"; + } + while( $idx < @decls ){ + $name = $decls[$idx]; + $type = $decls[$idx+1]; + push( @methods, $name ); + if( $base_type eq 'HASH' ){ + $elem = "{'${class}::$name'}"; + } + elsif( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + $cmt = " # $name"; + } + if( $type =~ /^\*(.)/ ){ + $refs{$name}++; + $type = $1; + } + my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :"; + if( $type eq '@' ){ + $out .= " croak 'Initializer for $name must be array reference'\n"; + $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n"; + $out .= " \$r->$elem = $init [];$cmt\n"; + $arrays{$name}++; + } + elsif( $type eq '%' ){ + $out .= " croak 'Initializer for $name must be hash reference'\n"; + $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n"; + $out .= " \$r->$elem = $init {};$cmt\n"; + $hashes{$name}++; + } + elsif ( $type eq '$') { + $out .= " \$r->$elem = $init undef;$cmt\n"; + } + elsif( $type =~ /^\w+(?:::\w+)*$/ ){ + $out .= " if (defined(\$init{'$name'})) {\n"; + $out .= " if (ref \$init{'$name'} eq 'HASH')\n"; + $out .= " { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n"; + $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n"; + $out .= " { \$r->$elem = \$init{'$name'} } $cmt\n"; + $out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n"; + $out .= " }\n"; + $classes{$name} = $type; + $got_class = 1; + } + else{ + croak "'$type' is not a valid struct element type"; + } + $idx += 2; + } + $out .= " bless \$r, \$class;\n }\n"; + + # Create accessor methods. + + my( $pre, $pst, $sel ); + $cnt = 0; + foreach $name (@methods){ + if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { + warnings::warnif("function '$name' already defined, overrides struct accessor method"); + } + else { + $pre = $pst = $cmt = $sel = ''; + if( defined $refs{$name} ){ + $pre = "\\("; + $pst = ")"; + $cmt = " # returns ref"; + } + $out .= " sub $name {$cmt\n my \$r = shift;\n"; + if( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + } + elsif( $base_type eq 'HASH' ){ + $elem = "{'${class}::$name'}"; + } + if( defined $arrays{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n"; + $sel = "->[\$i]"; + } + elsif( defined $hashes{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n"; + $sel = "->{\$i}"; + } + elsif( defined $classes{$name} ){ + if ( $CHECK_CLASS_MEMBERSHIP ) { + $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; + } + } + $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; + $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n"; + $out .= " }\n"; + } + } + $out .= "}\n1;\n"; + + print $out if $print; + my $result = eval $out; + carp $@ if $@; +} + +sub _usage_error { + confess "struct usage error"; +} + +sub _subclass_error { + croak 'struct class cannot be a subclass (@ISA not allowed)'; +} + +1; # for require + + +__END__ + +=head1 NAME + +Class::Struct - declare struct-like datatypes as Perl classes + +=head1 SYNOPSIS + + use Class::Struct; + # declare struct, based on array: + struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]); + # declare struct, based on hash: + struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }); + + package CLASS_NAME; + use Class::Struct; + # declare struct, based on array, implicit class name: + struct( ELEMENT_NAME => ELEMENT_TYPE, ... ); + + # Declare struct at compile time + use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]; + use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }; + + # declare struct at compile time, based on array, implicit class name: + package CLASS_NAME; + use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ; + + package Myobj; + use Class::Struct; + # declare struct with four types of elements: + struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' ); + + $obj = new Myobj; # constructor + + # scalar type accessor: + $element_value = $obj->s; # element value + $obj->s('new value'); # assign to element + + # array type accessor: + $ary_ref = $obj->a; # reference to whole array + $ary_element_value = $obj->a(2); # array element value + $obj->a(2, 'new value'); # assign to array element + + # hash type accessor: + $hash_ref = $obj->h; # reference to whole hash + $hash_element_value = $obj->h('x'); # hash element value + $obj->h('x', 'new value'); # assign to hash element + + # class type accessor: + $element_value = $obj->c; # object reference + $obj->c->method(...); # call method of object + $obj->c(new My_Other_Class); # assign a new object + +=head1 DESCRIPTION + +C 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/lib/Config.pm b/Master/tlpkg/tlperl/lib/Config.pm new file mode 100644 index 00000000000..7e5ad77b30a --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Cwd.pm b/Master/tlpkg/tlperl/lib/Cwd.pm new file mode 100644 index 00000000000..8d25af9f7cd --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Data/Dumper.pm b/Master/tlpkg/tlperl/lib/Data/Dumper.pm new file mode 100644 index 00000000000..b7fe1d61e77 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Digest/MD5.pm b/Master/tlpkg/tlperl/lib/Digest/MD5.pm new file mode 100644 index 00000000000..17fb11d678a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Digest/MD5.pm @@ -0,0 +1,376 @@ +package Digest::MD5; + +use strict; +use vars qw($VERSION @ISA @EXPORT_OK); + +$VERSION = '2.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/lib/Digest/base.pm b/Master/tlpkg/tlperl/lib/Digest/base.pm new file mode 100644 index 00000000000..cb336c2cf61 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Digest/base.pm @@ -0,0 +1,100 @@ +package Digest::base; + +use strict; +use vars qw($VERSION); +$VERSION = "1.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/lib/Digest/file.pm b/Master/tlpkg/tlperl/lib/Digest/file.pm new file mode 100644 index 00000000000..67985fd7599 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Digest/file.pm @@ -0,0 +1,85 @@ +package Digest::file; + +use strict; + +use Exporter (); +use Carp qw(croak); +use Digest (); + +use vars qw($VERSION @ISA @EXPORT_OK); + +$VERSION = "1.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/lib/DynaLoader.pm b/Master/tlpkg/tlperl/lib/DynaLoader.pm new file mode 100644 index 00000000000..178e9b2616c --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode.pm b/Master/tlpkg/tlperl/lib/Encode.pm new file mode 100644 index 00000000000..ac0123c89ec --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Alias.pm b/Master/tlpkg/tlperl/lib/Encode/Alias.pm new file mode 100644 index 00000000000..c0bbf69f469 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Byte.pm b/Master/tlpkg/tlperl/lib/Encode/Byte.pm new file mode 100644 index 00000000000..d40c1c3d9d1 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/CJKConstants.pm b/Master/tlpkg/tlperl/lib/Encode/CJKConstants.pm new file mode 100644 index 00000000000..4ab40e72ef2 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/CN.pm b/Master/tlpkg/tlperl/lib/Encode/CN.pm new file mode 100644 index 00000000000..be5a830fc51 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/CN/HZ.pm b/Master/tlpkg/tlperl/lib/Encode/CN/HZ.pm new file mode 100644 index 00000000000..fbc6ba60ced --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Changes.e2x b/Master/tlpkg/tlperl/lib/Encode/Changes.e2x new file mode 100644 index 00000000000..5c67c55cb93 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Config.pm b/Master/tlpkg/tlperl/lib/Encode/Config.pm new file mode 100644 index 00000000000..d69b92d8248 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/ConfigLocal_PM.e2x b/Master/tlpkg/tlperl/lib/Encode/ConfigLocal_PM.e2x new file mode 100644 index 00000000000..e203dfded50 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/EBCDIC.pm b/Master/tlpkg/tlperl/lib/Encode/EBCDIC.pm new file mode 100644 index 00000000000..200a82fea46 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Encoder.pm b/Master/tlpkg/tlperl/lib/Encode/Encoder.pm new file mode 100644 index 00000000000..fe2a2b90ff6 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Encoding.pm b/Master/tlpkg/tlperl/lib/Encode/Encoding.pm new file mode 100644 index 00000000000..06af9fb6994 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Guess.pm b/Master/tlpkg/tlperl/lib/Encode/Guess.pm new file mode 100644 index 00000000000..5692cee9a4a --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/JP.pm b/Master/tlpkg/tlperl/lib/Encode/JP.pm new file mode 100644 index 00000000000..01ad37f30db --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/JP/H2Z.pm b/Master/tlpkg/tlperl/lib/Encode/JP/H2Z.pm new file mode 100644 index 00000000000..0c84c62fda6 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/JP/JIS7.pm b/Master/tlpkg/tlperl/lib/Encode/JP/JIS7.pm new file mode 100644 index 00000000000..28503ec760c --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/KR.pm b/Master/tlpkg/tlperl/lib/Encode/KR.pm new file mode 100644 index 00000000000..e9d4073b7b4 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/KR/2022_KR.pm b/Master/tlpkg/tlperl/lib/Encode/KR/2022_KR.pm new file mode 100644 index 00000000000..8b4052be570 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/MIME/Header.pm b/Master/tlpkg/tlperl/lib/Encode/MIME/Header.pm new file mode 100644 index 00000000000..f4e2ad6e2b5 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/MIME/Header/ISO_2022_JP.pm b/Master/tlpkg/tlperl/lib/Encode/MIME/Header/ISO_2022_JP.pm new file mode 100644 index 00000000000..5f637a32472 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Makefile_PL.e2x b/Master/tlpkg/tlperl/lib/Encode/Makefile_PL.e2x new file mode 100644 index 00000000000..3bca0bff52b --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/PerlIO.pod b/Master/tlpkg/tlperl/lib/Encode/PerlIO.pod new file mode 100644 index 00000000000..abd1f2d10a1 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/README.e2x b/Master/tlpkg/tlperl/lib/Encode/README.e2x new file mode 100644 index 00000000000..28a31a655c2 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Supported.pod b/Master/tlpkg/tlperl/lib/Encode/Supported.pod new file mode 100644 index 00000000000..651f7e6ed4f --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Symbol.pm b/Master/tlpkg/tlperl/lib/Encode/Symbol.pm new file mode 100644 index 00000000000..7ad8ca92c7d --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/TW.pm b/Master/tlpkg/tlperl/lib/Encode/TW.pm new file mode 100644 index 00000000000..2e1abc0c7f9 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Unicode.pm b/Master/tlpkg/tlperl/lib/Encode/Unicode.pm new file mode 100644 index 00000000000..4d0c31d82d3 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/Unicode/UTF7.pm b/Master/tlpkg/tlperl/lib/Encode/Unicode/UTF7.pm new file mode 100644 index 00000000000..dc75ce37816 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/_PM.e2x b/Master/tlpkg/tlperl/lib/Encode/_PM.e2x new file mode 100644 index 00000000000..eb59cd1b520 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/_T.e2x b/Master/tlpkg/tlperl/lib/Encode/_T.e2x new file mode 100644 index 00000000000..6cf5f293d54 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Encode/encode.h b/Master/tlpkg/tlperl/lib/Encode/encode.h new file mode 100644 index 00000000000..94764a6a14c --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Exporter.pm b/Master/tlpkg/tlperl/lib/Exporter.pm new file mode 100644 index 00000000000..d9c22049776 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Exporter/Heavy.pm b/Master/tlpkg/tlperl/lib/Exporter/Heavy.pm new file mode 100644 index 00000000000..2cc792288f0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Exporter/Heavy.pm @@ -0,0 +1,248 @@ +package Exporter::Heavy; + +use strict; +no strict 'refs'; + +# On one line so MakeMaker will see it. +require Exporter; our $VERSION = $Exporter::VERSION; +$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/lib/Fcntl.pm b/Master/tlpkg/tlperl/lib/Fcntl.pm new file mode 100644 index 00000000000..7ef0038bd18 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Basename.pm b/Master/tlpkg/tlperl/lib/File/Basename.pm new file mode 100644 index 00000000000..837b753972a --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/CheckTree.pm b/Master/tlpkg/tlperl/lib/File/CheckTree.pm new file mode 100644 index 00000000000..20ffd68124d --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Compare.pm b/Master/tlpkg/tlperl/lib/File/Compare.pm new file mode 100644 index 00000000000..0b73d7c7657 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Copy.pm b/Master/tlpkg/tlperl/lib/File/Copy.pm new file mode 100644 index 00000000000..52ba7c6d81a --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/DosGlob.pm b/Master/tlpkg/tlperl/lib/File/DosGlob.pm new file mode 100644 index 00000000000..a1c27d5c32a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/DosGlob.pm @@ -0,0 +1,571 @@ +#!perl -w + +# use strict fails +#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. + +# +# Documentation at the __END__ +# + +package File::DosGlob; + +our $VERSION = '1.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/lib/File/Find.pm b/Master/tlpkg/tlperl/lib/File/Find.pm new file mode 100644 index 00000000000..497051e0635 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Glob.pm b/Master/tlpkg/tlperl/lib/File/Glob.pm new file mode 100644 index 00000000000..133c650529b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Glob.pm @@ -0,0 +1,496 @@ +package File::Glob; + +use strict; +our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, + $AUTOLOAD, $DEFAULT_FLAGS); + +use XSLoader (); + +@ISA = qw(Exporter); + +# NOTE: The glob() export is only here for compatibility with 5.6.0. +# csh_glob() should not be used directly, unless you know what you're doing. + +@EXPORT_OK = qw( + csh_glob + bsd_glob + glob + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE +); + +%EXPORT_TAGS = ( + 'glob' => [ qw( + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE + glob + bsd_glob + ) ], +); + +$VERSION = '1.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/lib/File/Path.pm b/Master/tlpkg/tlperl/lib/File/Path.pm new file mode 100644 index 00000000000..2e41ff3f77f --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Spec.pm b/Master/tlpkg/tlperl/lib/File/Spec.pm new file mode 100644 index 00000000000..0c8cd21e057 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Spec/Cygwin.pm b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm new file mode 100644 index 00000000000..19a2937c6b9 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Spec/Epoc.pm b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm new file mode 100644 index 00000000000..a7168f9e494 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Spec/Functions.pm b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm new file mode 100644 index 00000000000..38c898c5d8f --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Spec/Mac.pm b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm new file mode 100644 index 00000000000..8b51bd6c249 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Spec/OS2.pm b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm new file mode 100644 index 00000000000..ec308f3b6f3 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Spec/Unix.pm b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm new file mode 100644 index 00000000000..4a25fe632f2 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Spec/VMS.pm b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm new file mode 100644 index 00000000000..f8923f25fb2 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Spec/Win32.pm b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm new file mode 100644 index 00000000000..a324306a74b --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/Temp.pm b/Master/tlpkg/tlperl/lib/File/Temp.pm new file mode 100644 index 00000000000..6ddcb3619a7 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/File/stat.pm b/Master/tlpkg/tlperl/lib/File/stat.pm new file mode 100644 index 00000000000..132cbee27ad --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/FileHandle.pm b/Master/tlpkg/tlperl/lib/FileHandle.pm new file mode 100644 index 00000000000..6be22429440 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/FileHandle.pm @@ -0,0 +1,262 @@ +package FileHandle; + +use 5.006; +use strict; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK); + +$VERSION = "2.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/lib/Getopt/Long.pm b/Master/tlpkg/tlperl/lib/Getopt/Long.pm new file mode 100644 index 00000000000..04038db58e3 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/Getopt/Std.pm b/Master/tlpkg/tlperl/lib/Getopt/Std.pm new file mode 100644 index 00000000000..99f93590622 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/IO.pm b/Master/tlpkg/tlperl/lib/IO.pm new file mode 100644 index 00000000000..9fccc3a7356 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO.pm @@ -0,0 +1,68 @@ +# + +package IO; + +use XSLoader (); +use Carp; +use strict; +use warnings; + +our $VERSION = "1.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/lib/IO/Dir.pm b/Master/tlpkg/tlperl/lib/IO/Dir.pm new file mode 100644 index 00000000000..fccd02c088a --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/IO/File.pm b/Master/tlpkg/tlperl/lib/IO/File.pm new file mode 100644 index 00000000000..e7cdbbed6d7 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/IO/Handle.pm b/Master/tlpkg/tlperl/lib/IO/Handle.pm new file mode 100644 index 00000000000..329d26ad198 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/IO/Pipe.pm b/Master/tlpkg/tlperl/lib/IO/Pipe.pm new file mode 100644 index 00000000000..827cc48bfcd --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/IO/Poll.pm b/Master/tlpkg/tlperl/lib/IO/Poll.pm new file mode 100644 index 00000000000..e7fb0135069 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/IO/Seekable.pm b/Master/tlpkg/tlperl/lib/IO/Seekable.pm new file mode 100644 index 00000000000..db1effda287 --- /dev/null +++ b/Master/tlpkg/tlperl/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/lib/IO/Select.pm b/Master/tlpkg/tlperl/lib/IO/Select.pm new file mode 100644 index 00000000000..fc05fe70e9c --- /dev/null +++ b/Master/tlpkg/tlperl/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',['selectionFrom','insert']); + $mw->bind($class,'',['selectionAdjust','insert']); + $mw->bind($class,'',['selectionAdjust','insert']); + + $mw->bind($class,'',['selectionRange',0,'end']); + $mw->bind($class,'','selectionClear'); + + # $class->clipboardOperations($mw,qw[Copy Cut Paste]); + + $mw->bind($class,'', ['Insert',Ev('A')]); + + # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. + # Otherwise, if a widget binding for one of these is defined, the + # class binding will also fire and insert the character, + # which is wrong. Ditto for Return, and Tab. + + $mw->bind($class,'' ,'NoOp'); + $mw->bind($class,'' ,'NoOp'); + $mw->bind($class,'' ,'NoOp'); + $mw->bind($class,'' ,'NoOp'); + $mw->bind($class,'' ,'NoOp'); + $mw->bind($class,'' ,'NoOp'); + if ($mw->windowingsystem =~ /^(?:classic|aqua)$/) + { + $mw->bind($class,'', 'NoOp'); + } + + # On Windows, paste is done using Shift-Insert. Shift-Insert already + # generates the <> event, so we don't need to do anything here. + if ($Tk::platform ne 'MSWin32') + { + $mw->bind($class,'','InsertSelection'); + } + + if (!$Tk::strictMotif) + { + # Additional emacs-like bindings: + $mw->bind($class,'',['SetCursor',0]); + $mw->bind($class,'',['SetCursor',Ev('deltainsert',-1)]); + $mw->bind($class,'',['delete','insert']); + $mw->bind($class,'',['SetCursor','end']); + $mw->bind($class,'',['SetCursor',Ev('deltainsert',1)]); + $mw->bind($class,'','Backspace'); + $mw->bind($class,'',['delete','insert','end']); + + $mw->bind($class,'','Transpose'); + + # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead + $mw->bind($class,'',['SetCursor',Ev(['wordstart'])]); + $mw->bind($class,'',['delete','insert',Ev(['wordend'])]); + $mw->bind($class,'',['SetCursor',Ev(['wordend'])]); + $mw->bind($class,'',['delete',Ev(['wordstart']),'insert']); + $mw->bind($class,'',['delete',Ev(['wordstart']),'insert']); + + # A few additional bindings from John Ousterhout. +# XXX conflicts with <>: $mw->bind($class,'',['delete',Ev(['wordstart']),'insert']); + $mw->bind($class,'<2>','Button_2'); + $mw->bind($class,'','B2_Motion'); +# XXX superseded by <>: $mw->bind($class,'','ButtonRelease_2'); + } + return $class; +} + + +sub Shift_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $Tk::selectMode = 'char'; + $w->selectionAdjust('@' . $Ev->x) +} + + +sub Control_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->icursor('@' . $Ev->x) +} + + +sub Delete +{ + my $w = shift; + if ($w->selectionPresent) + { + $w->deleteSelected + } + else + { + $w->delete('insert') + } +} + + +sub InsertSelection +{ + my $w = shift; + eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)} +} + + +# Original is ::tk::EntryScanMark +sub Button_2 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->scan('mark',$Ev->x); + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $Tk::mouseMoved = 0 +} + + +# Original is ::tk::EntryScanDrag +sub B2_Motion +{ + my $w = shift; + my $Ev = $w->XEvent; + # Make sure these exist, as some weird situations can trigger the + # motion binding without the initial press. [Tcl/Tk Bug #220269] + if (!defined $Tk::x) { $Tk::x = $Ev->x } + if (abs(($Ev->x-$Tk::x)) > 2) + { + $Tk::mouseMoved = 1 + } + $w->scan('dragto',$Ev->x) +} + + +# XXX Not needed anymore +sub ButtonRelease_2 +{ + my $w = shift; + my $Ev = $w->XEvent; + if (!$Tk::mouseMoved) + { + eval + {local $SIG{__DIE__}; + $w->insert('insert',$w->SelectionGet); + $w->SeeInsert; + } + } +} + +sub Button1Release +{ + shift->CancelRepeat; +} + +# ::tk::EntryClosestGap -- +# Given x and y coordinates, this procedure finds the closest boundary +# between characters to the given coordinates and returns the index +# of the character just after the boundary. +# +# Arguments: +# w - The entry window. +# x - X-coordinate within the window. +sub ClosestGap +{ + my($w, $x) = @_; + my $pos = $w->index('@'.$x); + my @bbox = $w->bbox($pos); + if ($x - $bbox[0] < $bbox[2] / 2) + { + return $pos; + } + $pos + 1; +} + +# Button1 -- +# This procedure is invoked to handle button-1 presses in entry +# widgets. It moves the insertion cursor, sets the selection anchor, +# and claims the input focus. +# +# Arguments: +# w - The entry window in which the button was pressed. +# x - The x-coordinate of the button press. +sub Button1 +{ + my $w = shift; + my $x = shift; + $Tk::selectMode = 'char'; + $Tk::mouseMoved = 0; + $Tk::pressX = $x; + $w->icursor($w->ClosestGap($x)); + $w->selectionFrom('insert'); + $w->selectionClear; + if ($w->cget('-state') ne 'disabled') + { + $w->focus() + } +} + +sub Motion +{ + my ($w,$x,$y) = @_; + $Tk::x = $x; # XXX ? + $w->MouseSelect($x); +} + +# MouseSelect -- +# This procedure is invoked when dragging out a selection with +# the mouse. Depending on the selection mode (character, word, +# line) it selects in different-sized units. This procedure +# ignores mouse motions initially until the mouse has moved from +# one character to another or until there have been multiple clicks. +# +# Arguments: +# w - The entry window in which the button was pressed. +# x - The x-coordinate of the mouse. +sub MouseSelect +{ + + my $w = shift; + my $x = shift; + return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry'; + $Tk::selectMode = shift if (@_); + my $cur = $w->index($w->ClosestGap($x)); + return unless defined $cur; + my $anchor = $w->index('anchor'); + return unless defined $anchor; + $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"? + if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3)) + { + $Tk::mouseMoved = 1 + } + my $mode = $Tk::selectMode; + return unless $mode; + if ($mode eq 'char') + { + # The Tcl version uses selectionRange here XXX + if ($Tk::mouseMoved) + { + if ($cur < $anchor) + { + $w->selectionTo($cur) + } + else + { + $w->selectionTo($cur+1) + } + } + } + elsif ($mode eq 'word') + { + # The Tcl version uses tcl_wordBreakBefore/After here XXX + if ($cur < $w->index('anchor')) + { + $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1)) + } + else + { + $w->selectionRange($w->wordstart($anchor),$w->wordend($cur)) + } + } + elsif ($mode eq 'line') + { + $w->selectionRange(0,'end') + } + if (@_) + { + my $ipos = shift; + eval {local $SIG{__DIE__}; $w->icursor($ipos) }; + } + $w->idletasks; +} +# ::tk::EntryPaste -- +# This procedure sets the insertion cursor to the current mouse position, +# pastes the selection there, and sets the focus to the window. +# +# Arguments: +# w - The entry window. +# x - X position of the mouse. +sub Paste +{ + my($w, $x) = @_; + $w->icursor($w->ClosestGap($x)); + eval { local $SIG{__DIE__}; + $w->insert("insert", $w->GetSelection); + $w->SeeInsert; # Perl/Tk extension + }; + if ($w->cget(-state) ne 'disabled') + { + $w->focus; + } +} +# AutoScan -- +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window left or right, +# depending on where the mouse is, and reschedules itself as an +# 'after' command so that the window continues to scroll until the +# mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The entry window. +# x - The x-coordinate of the mouse when it left the window. +sub AutoScan +{ + my $w = shift; + my $x = shift; + return if !Tk::Exists($w); + if ($x >= $w->width) + { + $w->xview('scroll',2,'units') + } + elsif ($x < 0) + { + $w->xview('scroll',-2,'units') + } + else + { + return; + } + $w->MouseSelect($x); + $w->RepeatId($w->after(50,['AutoScan',$w,$x])) +} +# KeySelect +# This procedure is invoked when stroking out selections using the +# keyboard. It moves the cursor to a new position, then extends +# the selection to that position. +# +# Arguments: +# w - The entry window. +# new - A new position for the insertion cursor (the cursor hasn't +# actually been moved to this position yet). +sub KeySelect +{ + my $w = shift; + my $new = shift; + if (!$w->selectionPresent) + { + $w->selectionFrom('insert'); + $w->selectionTo($new) + } + else + { + $w->selectionAdjust($new) + } + $w->icursor($new); + $w->SeeInsert; +} +# Insert -- +# Insert a string into an entry at the point of the insertion cursor. +# If there is a selection in the entry, and it covers the point of the +# insertion cursor, then delete the selection before inserting. +# +# Arguments: +# w - The entry window in which to insert the string +# s - The string to insert (usually just a single character) +sub Insert +{ + my $w = shift; + my $s = shift; + return unless (defined $s && $s ne ''); + eval + {local $SIG{__DIE__}; + my $insert = $w->index('insert'); + if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert) + { + $w->deleteSelected + } + }; + $w->insert('insert',$s); + $w->SeeInsert +} +# Backspace -- +# Backspace over the character just before the insertion cursor. +# +# Arguments: +# w - The entry window in which to backspace. +sub Backspace +{ + my $w = shift; + if ($w->selectionPresent) + { + $w->deleteSelected + } + else + { + my $x = $w->index('insert')-1; + $w->delete($x) if ($x >= 0); + # XXX Missing repositioning part from Tcl/Tk source + } +} +# SeeInsert +# Make sure that the insertion cursor is visible in the entry window. +# If not, adjust the view so that it is. +# +# Arguments: +# w - The entry window. +sub SeeInsert +{ + my $w = shift; + my $c = $w->index('insert'); +# +# Probably a bug in your version of tcl/tk (I've not this problem +# when I test Entry in the widget demo for tcl/tk) +# index('\@0') give always 0. Consequence : +# if you make or view is adapted +# but with or view is not adapted +# + my $left = $w->index('@0'); + if ($left > $c) + { + $w->xview($c); + return; + } + my $x = $w->width; + while ($w->index('@' . $x) <= $c && $left < $c) + { + $left += 1; + $w->xview($left) + } +} +# SetCursor +# Move the insertion cursor to a given position in an entry. Also +# clears the selection, if there is one in the entry, and makes sure +# that the insertion cursor is visible. +# +# Arguments: +# w - The entry window. +# pos - The desired new position for the cursor in the window. +sub SetCursor +{ + my $w = shift; + my $pos = shift; + $w->icursor($pos); + $w->selectionClear; + $w->SeeInsert; +} +# Transpose +# This procedure implements the 'transpose' function for entry widgets. +# It tranposes the characters on either side of the insertion cursor, +# unless the cursor is at the end of the line. In this case it +# transposes the two characters to the left of the cursor. In either +# case, the cursor ends up to the right of the transposed characters. +# +# Arguments: +# w - The entry window. +sub Transpose +{ + my $w = shift; + my $i = $w->index('insert'); + $i++ if ($i < $w->index('end')); + my $first = $i-2; + return if ($first < 0); + my $str = $w->get; + my $new = substr($str,$i-1,1) . substr($str,$first,1); + $w->delete($first,$i); + $w->insert('insert',$new); + $w->SeeInsert; +} + +sub tabFocus +{ + my $w = shift; + $w->selectionRange(0,'end'); + $w->icursor('end'); + $w->SUPER::tabFocus; +} + +# ::tk::EntryGetSelection -- +# +# Returns the selected text of the entry with respect to the -show option. +# +# Arguments: +# w - The entry window from which the text to get +sub getSelected +{ + my $w = shift; + return undef unless $w->selectionPresent; + my $str = $w->get; + my $show = $w->cget('-show'); + $str = $show x length($str) if (defined $show); + my $s = $w->index('sel.first'); + my $e = $w->index('sel.last'); + return substr($str,$s,$e-$s); +} + + +1; + +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm b/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm new file mode 100644 index 00000000000..19377eaeca4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm @@ -0,0 +1,125 @@ +package Tk::ErrorDialog; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; + +use Tk (); +require Tk::Dialog; +use base qw(Tk::Toplevel); + + +# ErrorDialog - a translation of bgerror() from Tcl/Tk to Perl/Tk. +# +# Currently TkPerl background errors are sent to stdout/stderr; use this +# module if you want them in a window. You can also "roll your own" by +# supplying the routine Tk::Error. + +use strict; + +Construct Tk::Widget 'ErrorDialog'; + +my %options = ( -buttons => ['OK', 'Skip Messages', 'Stack trace'], + -bitmap => 'error' + ); +my $ED_OBJECT; + +sub import +{ + my $class = shift; + while (@_) + { + my $key = shift; + my $val = shift; + $options{$key} = $val; + } +} + +sub Populate { + + # ErrorDialog constructor. Uses `new' method from base class + # to create object container then creates the dialog toplevel and the + # traceback toplevel. + + my($cw, $args) = @_; + + my $dr = $cw->Dialog( + -title => 'Error in '.$cw->MainWindow->name, + -text => 'on-the-fly-text', + -bitmap => $options{'-bitmap'}, + -buttons => $options{'-buttons'}, + ); + $cw->minsize(1, 1); + $cw->title('Stack Trace for Error'); + $cw->iconname('Stack Trace'); + my $t_ok = $cw->Button( + -text => 'OK', + -command => [ + sub { + shift->withdraw; + }, $cw, + ] + ); + my $t_text = $cw->Text( + -relief => 'sunken', + -bd => 2, + -setgrid => 'true', + -width => 60, + -height => 20, + ); + my $t_scroll = $cw->Scrollbar( + -relief => 'sunken', + -command => ['yview', $t_text], + ); + $t_text->configure(-yscrollcommand => ['set', $t_scroll]); + $t_ok->pack(-side => 'bottom', -padx => '3m', -pady => '2m'); + $t_scroll->pack(-side => 'right', -fill => 'y'); + $t_text->pack(-side => 'left', -expand => 'yes', -fill => 'both'); + $cw->withdraw; + + $cw->Advertise(error_dialog => $dr); # advertise dialog widget + $cw->Advertise(text => $t_text); # advertise text widget + $cw->ConfigSpecs(-cleanupcode => [PASSIVE => undef, undef, undef], + -appendtraceback => [ PASSIVE => undef, undef, 1 ]); + $ED_OBJECT = $cw; + $cw->protocol('WM_DELETE_WINDOW' => sub {$cw->withdraw}); + return $cw; + +} # end Populate + +sub Tk::Error { + + # Post a dialog box with the error message and give the user a chance + # to see a more detailed stack trace. + + my($w, $error, @msgs) = @_; + + my $grab = $w->grab('current'); + $grab->Unbusy if (defined $grab); + + $w->ErrorDialog if not defined $ED_OBJECT; + + my($d, $t) = ($ED_OBJECT->Subwidget('error_dialog'), $ED_OBJECT->Subwidget('text')); +# chop $error; + $d->configure(-text => "Error: $error"); + $d->bell; + my $ans = $d->Show; + + $t->delete('0.0', 'end') if not $ED_OBJECT->{'-appendtraceback'}; + $t->insert('end', "\n"); + $t->mark('set', 'ltb', 'end'); + $t->insert('end', "--- Begin Traceback ---\n$error\n"); + my $msg; + for $msg (@msgs) { + $t->insert('end', "$msg\n"); + } + $t->yview('ltb'); + + $ED_OBJECT->deiconify if ($ans =~ /trace/i); + + my $c = $ED_OBJECT->{Configure}{'-cleanupcode'}; + &$c if defined $c; # execute any cleanup code if it was defined + $w->break if ($ans =~ /skip/i); + +} # end Tk::Error + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Event.pm b/Master/tlpkg/tlperl/lib/Tk/Event.pm new file mode 100644 index 00000000000..cecd57c54ae --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Event.pm @@ -0,0 +1,13 @@ +package Tk::Event; +use vars qw($VERSION $XS_VERSION @EXPORT_OK); +END { CleanupGlue() } +$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/; +$XS_VERSION = '804.027'; +use base qw(Exporter); +use XSLoader; +@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS + TIMER_EVENTS IDLE_EVENTS ALL_EVENTS); +XSLoader::load 'Tk::Event',$XS_VERSION; +require Tk::Event::IO; +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm b/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm new file mode 100644 index 00000000000..10b47e246ff --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm @@ -0,0 +1,132 @@ +package Tk::Event::IO; +use strict; +use Carp; + +use vars qw($VERSION @EXPORT_OK); +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use base qw(Exporter); +use Symbol (); + +@EXPORT_OK = qw(READABLE WRITABLE); + +sub PrintArgs +{ + my $func = (caller(1))[3]; + print "$func(",join(',',@_),")\n"; +} + +sub PRINT +{ + my $obj = shift; + $obj->wait(WRITABLE); + my $h = $obj->handle; + return print $h @_; +} + +sub PRINTF +{ + my $obj = shift; + $obj->wait(WRITABLE); + my $h = $obj->handle; + return printf $h @_; +} + +sub WRITE +{ + my $obj = $_[0]; + $obj->wait(WRITABLE); + return syswrite($obj->handle,$_[1],$_[2]); +} + +my $depth = 0; +sub READLINE +{ + my $obj = shift; + $obj->wait(READABLE); + my $h = $obj->handle; + my $w = <$h>; + return $w; +} + +sub READ +{ + my $obj = $_[0]; + $obj->wait(READABLE); + my $h = $obj->handle; + return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0); +} + +sub GETC +{ + my $obj = $_[0]; + $obj->wait(READABLE); + my $h = $obj->handle; + return getc($h); +} + +sub CLOSE +{ + my $obj = shift; + $obj->unwatch; + my $h = $obj->handle; + return close($h); +} + +sub EOF +{ + my $obj = shift; + my $h = $obj->handle; + return eof($h); +} + +sub FILENO +{ + my $obj = shift; + my $h = $obj->handle; + return fileno($h); +} + +sub imode +{ + my $mode = shift; + my $imode = ${{'readable' => READABLE(), + 'writable' => WRITABLE()}}{$mode}; + croak("Invalid handler type '$mode'") unless (defined $imode); + return $imode; +} + +sub fileevent +{ + my ($widget,$file,$mode,$cb) = @_; + my $imode = imode($mode); + unless (ref $file) + { + no strict 'refs'; + $file = Symbol::qualify($file,(caller)[0]); + $file = \*{$file}; + } + my $obj = tied(*$file); + unless ($obj && $obj->isa('Tk::Event::IO')) + { + $obj = tie *$file,'Tk::Event::IO', $file; + } + if (@_ == 3) + { + # query return the handler + return $obj->handler($imode); + } + else + { + # set the handler + my $h = $obj->handler($imode,$cb); + undef $obj; # Prevent warnings about untie with ref to object + unless ($h) + { + untie *$file; + } + } +} + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/FBox.pm b/Master/tlpkg/tlperl/lib/Tk/FBox.pm new file mode 100644 index 00000000000..fed7501aea4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/FBox.pm @@ -0,0 +1,1043 @@ +# -*- perl -*- +# +# tkfbox.tcl -- +# +# Implements the "TK" standard file selection dialog box. This +# dialog box is used on the Unix platforms whenever the tk_strictMotif +# flag is not set. +# +# The "TK" standard file selection dialog box is similar to the +# file selection dialog box on Win95(TM). The user can navigate +# the directories by clicking on the folder icons or by +# selecting the "Directory" option menu. The user can select +# files by clicking on the file icons or by entering a filename +# in the "Filename:" entry. +# +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Translated to perl/Tk by Slaven Rezic . +# + +#---------------------------------------------------------------------- +# +# F I L E D I A L O G +# +#---------------------------------------------------------------------- +# tkFDialog -- +# +# Implements the TK file selection dialog. This dialog is used when +# the tk_strictMotif flag is set to false. This procedure shouldn't +# be called directly. Call tk_getOpenFile or tk_getSaveFile instead. +# + +package Tk::FBox; +require Tk::Toplevel; + +use strict; +use vars qw($VERSION $updirImage $folderImage $fileImage); + +$VERSION = sprintf '4.%03d', q$Revision: #18 $ =~ /\D(\d+)\s*$/; + +use base qw(Tk::Toplevel); + +Construct Tk::Widget 'FBox'; + +sub import { + if (defined $_[1] and $_[1] eq 'as_default') { + local $^W = 0; + package Tk; + if ($Tk::VERSION < 804) { + *FDialog = \&Tk::FBox::FDialog; + *MotifFDialog = \&Tk::FBox::FDialog; + } else { + *tk_getOpenFile = sub { + Tk::FBox::FDialog("tk_getOpenFile", @_); + }; + *tk_getSaveFile = sub { + Tk::FBox::FDialog("tk_getSaveFile", @_); + }; + } + } +} + +# Note that -sortcmd is experimental and the interface is likely to change. +# Using -sortcmd is really strange :-( +# $top->getOpenFile(-sortcmd => sub { package Tk::FBox; uc $b cmp uc $a}); +# or, un-perlish, but useable (now activated in code): +# $top->getOpenFile(-sortcmd => sub { uc $_[1] cmp uc $_[0]}); + +sub Populate { + my($w, $args) = @_; + + require Tk::IconList; + require File::Basename; + require Cwd; + + $w->SUPER::Populate($args); + + # f1: the frame with the directory option menu + my $f1 = $w->Frame; + my $lab = $f1->Label(-text => 'Directory:', -underline => 0); + $w->{'dirMenu'} = my $dirMenu = + $f1->Optionmenu(-variable => \$w->{'selectPath'}, + -textvariable => \$w->{'selectPath'}, + -command => ['SetPath', $w]); + my $upBtn = $f1->Button; + if (!defined $updirImage->{$w->MainWindow}) { + $updirImage->{$w->MainWindow} = $w->Bitmap(-data => <configure(-image => $updirImage->{$w->MainWindow}); + $dirMenu->configure(-takefocus => 1, -highlightthickness => 2); + $upBtn->pack(-side => 'right', -padx => 4, -fill => 'both'); + $lab->pack(-side => 'left', -padx => 4, -fill => 'both'); + $dirMenu->pack(-expand => 'yes', -fill => 'both', -padx => 4); + + $w->{'icons'} = my $icons = + $w->IconList(-command => ['OkCmd', $w, 'iconlist'], + ); + $icons->bind('<>' => [$w, 'ListBrowse']); + + # f2: the frame with the OK button and the "file name" field + my $f2 = $w->Frame(-bd => 0); +#XXX File name => File names if multiple + my $f2_lab = $f2->Label(-text => 'File name:', -anchor => 'e', + -width => 14, -underline => 5, -pady => 0); + $w->{'ent'} = my $ent = $f2->Entry; + + # The font to use for the icons. The default Canvas font on Unix + # is just deviant. +# $w->{'icons'}{'font'} = $ent->cget(-font); + $w->{'icons'}->configure(-font => $ent->cget(-font)); + + # f3: the frame with the cancel button and the file types field + my $f3 = $w->Frame(-bd => 0); + + # The "File of types:" label needs to be grayed-out when + # -filetypes are not specified. The label widget does not support + # grayed-out text on monochrome displays. Therefore, we have to + # use a button widget to emulate a label widget (by setting its + # bindtags) + $w->{'typeMenuLab'} = my $typeMenuLab = $f3->Button + (-text => 'Files of type:', + -anchor => 'e', + -width => 14, + -underline => 9, + -bd => $f2_lab->cget(-bd), + -highlightthickness => $f2_lab->cget(-highlightthickness), + -relief => $f2_lab->cget(-relief), + -padx => $f2_lab->cget(-padx), + -pady => $f2_lab->cget(-pady), + -takefocus => 0, + ); + $typeMenuLab->bindtags([$typeMenuLab, 'Label', + $typeMenuLab->toplevel, 'all']); + $w->{'typeMenuBtn'} = my $typeMenuBtn = + $f3->Menubutton(-indicatoron => 1, -tearoff => 0); + $typeMenuBtn->configure(-takefocus => 1, + -highlightthickness => 2, + -relief => 'raised', + -bd => 2, + -anchor => 'w', + ); + + # the okBtn is created after the typeMenu so that the keyboard traversal + # is in the right order + $w->{'okBtn'} = my $okBtn = $f2->Button + (-text => 'OK', + -underline => 0, + -width => 6, + -default => 'active', + -pady => 3, + ); + my $cancelBtn = $f3->Button + (-text => 'Cancel', + -underline => 0, + -width => 6, + -default => 'normal', + -pady => 3, + ); + + # pack the widgets in f2 and f3 + $okBtn->pack(-side => 'right', -padx => 4, -anchor => 'e'); + $f2_lab->pack(-side => 'left', -padx => 4); + $ent->pack(-expand => 'yes', -fill => 'x', -padx => 2, -pady => 0); + $cancelBtn->pack(-side => 'right', -padx => 4, -anchor => 'w'); + $typeMenuLab->pack(-side => 'left', -padx => 4); + $typeMenuBtn->pack(-expand => 'yes', -fill => 'x', -side => 'right'); + + # Pack all the frames together. We are done with widget construction. + $f1->pack(-side => 'top', -fill => 'x', -pady => 4); + $f3->pack(-side => 'bottom', -fill => 'x'); + $f2->pack(-side => 'bottom', -fill => 'x'); + $icons->pack(-expand => 'yes', -fill => 'both', -padx => 4, -pady => 1); + + # Set up the event handlers + $ent->bind('',[$w,'ActivateEnt']); + $upBtn->configure(-command => ['UpDirCmd', $w]); + $okBtn->configure(-command => ['OkCmd', $w]); + $cancelBtn->configure(-command, ['CancelCmd', $w]); + + $w->bind('',[$dirMenu,'focus']); + $w->bind('',sub { + if ($typeMenuBtn->cget(-state) eq 'normal') { + $typeMenuBtn->focus; + } }); + $w->bind('',[$ent,'focus']); + $w->bind('',[$cancelBtn,'invoke']); + $w->bind('',[$cancelBtn,'invoke']); + $w->bind('',['InvokeBtn','Open']); + $w->bind('',['InvokeBtn','Save']); + $w->protocol('WM_DELETE_WINDOW', ['CancelCmd', $w]); + $w->OnDestroy(['CancelCmd', $w]); + + # Build the focus group for all the entries + $w->FG_Create; + $w->FG_BindIn($ent, ['EntFocusIn', $w]); + $w->FG_BindOut($ent, ['EntFocusOut', $w]); + + $w->SetPath(_cwd()); + + $w->ConfigSpecs(-defaultextension => ['PASSIVE', undef, undef, undef], + -filetypes => ['PASSIVE', undef, undef, undef], + -initialdir => ['PASSIVE', undef, undef, undef], + -initialfile => ['PASSIVE', undef, undef, undef], +# -sortcmd => ['PASSIVE', undef, undef, sub { lc($a) cmp lc($b) }], + -sortcmd => ['PASSIVE', undef, undef, sub { lc($_[0]) cmp lc($_[1]) }], + -title => ['PASSIVE', undef, undef, undef], + -type => ['PASSIVE', undef, undef, 'open'], + -filter => ['PASSIVE', undef, undef, '*'], + -force => ['PASSIVE', undef, undef, 0], + -multiple => ['PASSIVE', undef, undef, 0], + 'DEFAULT' => [$icons], + ); + # So-far-failed attempt to break reference loops ... + $w->_OnDestroy(qw(dirMenu icons typeMenuLab typeMenuBtn okBtn ent updateId)); + $w; +} + +# -initialdir fix with ResolveFile +sub Show { + my $w = shift; + + $w->configure(@_); + + # Dialog boxes should be transient with respect to their parent, + # so that they will always stay on top of their parent window. However, + # some window managers will create the window as withdrawn if the parent + # window is withdrawn or iconified. Combined with the grab we put on the + # window, this can hang the entire application. Therefore we only make + # the dialog transient if the parent is viewable. + + if (Tk::Exists($w->Parent) && $w->Parent->viewable) { + $w->transient($w->Parent); + } + + # set the default directory and selection according to the -initial + # settings + { + my $initialdir = $w->cget(-initialdir); + if (defined $initialdir) { + my ($flag, $path, $file) = ResolveFile($initialdir, 'junk'); + if ($flag eq 'OK' or $flag eq 'FILE') { + $w->{'selectPath'} = $path; + } else { + $w->Error("\"$initialdir\" is not a valid directory"); + } + } + $w->{'selectFile'} = $w->cget(-initialfile); + } + + # Set -multiple to a one or zero value (not other boolean types + # like "yes") so we can use it in tests more easily. + if ($w->cget('-type') ne 'open') { + $w->configure(-multiple => 0); + } else { + $w->configure(-multiple => !!$w->cget('-multiple')); + } + $w->{'icons'}->configure(-multiple => $w->cget('-multiple')); + + # Initialize the file types menu + my $typeMenuBtn = $w->{'typeMenuBtn'}; + my $typeMenuLab = $w->{'typeMenuLab'}; + if (defined $w->cget('-filetypes')) { + my(@filetypes) = GetFileTypes($w->cget('-filetypes')); + my $typeMenu = $typeMenuBtn->cget(-menu); + $typeMenu->delete(0, 'end'); + foreach my $ft (@filetypes) { + my $title = $ft->[0]; + my $filter = join(' ', @{ $ft->[1] }); + $typeMenuBtn->command + (-label => $title, + -command => ['SetFilter', $w, $title, $filter], + ); + } + $w->SetFilter($filetypes[0]->[0], join(' ', @{ $filetypes[0]->[1] })); + $typeMenuBtn->configure(-state => 'normal'); + $typeMenuLab->configure(-state => 'normal'); + } else { +#XXX $w->configure(-filter => '*'); + $typeMenuBtn->configure(-state => 'disabled', + -takefocus => 0); + $typeMenuLab->configure(-state => 'disabled'); + } + $w->UpdateWhenIdle; + + { + my $title = $w->cget(-title); + if (!defined $title) { + my $type = $w->cget(-type); + $title = ($type eq 'dir') ? 'Choose Directory' + : ($type eq 'save') ? 'Save As' : 'Open'; + } + $w->title($title); + } + + # Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display and de-iconify it. + $w->withdraw; + $w->idletasks; + if (0) + { + #XXX use Tk::Wm::Popup? or Tk::PlaceWindow? + my $x = int($w->screenwidth / 2 - $w->reqwidth / 2 - $w->parent->vrootx); + my $y = int($w->screenheight / 2 - $w->reqheight / 2 - $w->parent->vrooty); + $w->geometry("+$x+$y"); + $w->deiconify; + } + else + { + $w->Popup; + } + + # Set a grab and claim the focus too. +#XXX use Tk::setFocusGrab when it's available + my $oldFocus = $w->focusCurrent; + my $oldGrab = $w->grabCurrent; + my $grabStatus = $oldGrab->grabStatus if ($oldGrab); + $w->grab; + my $ent = $w->{'ent'}; + $ent->focus; + $ent->delete(0, 'end'); + if (defined $w->{'selectFile'} && $w->{'selectFile'} ne '') { + $ent->insert(0, $w->{'selectFile'}); + $ent->selectionRange(0,'end'); + $ent->icursor('end'); + } + + # 8. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + $w->waitVariable(\$w->{'selectFilePath'}); + eval { + $oldFocus->focus if $oldFocus; + }; + if (Tk::Exists($w)) { # widget still exists + $w->grabRelease; + $w->withdraw; + } + if (Tk::Exists($oldGrab) && $oldGrab->viewable) { + if ($grabStatus eq 'global') { + $oldGrab->grabGlobal; + } else { + $oldGrab->grab; + } + } + return $w->{'selectFilePath'}; +} + +# tkFDialog_UpdateWhenIdle -- +# +# Creates an idle event handler which updates the dialog in idle +# time. This is important because loading the directory may take a long +# time and we don't want to load the same directory for multiple times +# due to multiple concurrent events. +# +sub UpdateWhenIdle { + my $w = shift; + if (exists $w->{'updateId'}) { + return; + } else { + $w->{'updateId'} = $w->after('idle', [$w, 'Update']); + } +} + +# tkFDialog_Update -- +# +# Loads the files and directories into the IconList widget. Also +# sets up the directory option menu for quick access to parent +# directories. +# +sub Update { + my $w = shift; + my $dataName = $w->name; + + # This proc may be called within an idle handler. Make sure that the + # window has not been destroyed before this proc is called + if (!Tk::Exists($w) || $w->class ne 'FBox') { + return; + } else { + delete $w->{'updateId'}; + } + unless (defined $folderImage->{$w->MainWindow}) { + require Tk::Pixmap; + $folderImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('folder.xpm')); + $fileImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('file.xpm')); + } + my $folder = $folderImage->{$w->MainWindow}; + my $file = $fileImage->{$w->MainWindow}; + my $appPWD = _cwd(); + if (!ext_chdir($w->{'selectPath'})) { + # We cannot change directory to $data(selectPath). $data(selectPath) + # should have been checked before tkFDialog_Update is called, so + # we normally won't come to here. Anyways, give an error and abort + # action. + $w->messageBox(-type => 'OK', + -message => 'Cannot change to the directory "' . + $w->{'selectPath'} . "\".\nPermission denied.", + -icon => 'warning', + ); + ext_chdir($appPWD); + return; + } + + # Turn on the busy cursor. BUG?? We haven't disabled X events, though, + # so the user may still click and cause havoc ... + my $ent = $w->{'ent'}; + my $entCursor = $ent->cget(-cursor); + my $dlgCursor = $w->cget(-cursor); + $ent->configure(-cursor => 'watch'); + $w->configure(-cursor => 'watch'); + $w->idletasks; + my $icons = $w->{'icons'}; + $icons->DeleteAll; + + # Make the dir & file list + my $cwd = _cwd(); + local *FDIR; + if (opendir(FDIR, $cwd)) { + my @files; +# my $sortcmd = $w->cget(-sortcmd); + my $sortcmd = sub { $w->cget(-sortcmd)->($a,$b) }; + my $flt = $w->cget(-filter); + my $fltcb; + if (ref $flt eq 'CODE') { + $fltcb = $flt; + } else { + $flt = _rx_to_glob($flt); + } + my $type_dir = $w->cget(-type) eq 'dir'; + foreach my $f (sort $sortcmd readdir(FDIR)) { + next if $f eq '.' or $f eq '..'; + next if $type_dir && ! -d "$cwd/$f"; # XXX use File::Spec? + if ($fltcb) { + next if !$fltcb->($w, $f, $cwd); + } else { + next if -f $f && $f !~ m!$flt!; + } + if (-d $f) { + $icons->Add($folder, $f); + } else { + push @files, $f; + } + } + closedir(FDIR); + $icons->Add($file, @files); + } + + $icons->Arrange; + + # Update the Directory: option menu + my @list; + my $dir = ''; + foreach my $subdir (TclFileSplit($w->{'selectPath'})) { + $dir = TclFileJoin($dir, $subdir); + push @list, $dir; + } + my $dirMenu = $w->{'dirMenu'}; + $dirMenu->configure(-options => \@list); + + # Restore the PWD to the application's PWD + ext_chdir($appPWD); + + # Restore the Save label + if ($w->cget(-type) eq 'save') { + $w->{'okBtn'}->configure(-text => 'Save'); + } + + # turn off the busy cursor. + $ent->configure(-cursor => $entCursor); + $w->configure(-cursor => $dlgCursor); +} + +# tkFDialog_SetPathSilently -- +# +# Sets data(selectPath) without invoking the trace procedure +# +sub SetPathSilently { + my($w, $path) = @_; + + $w->{'selectPath'} = $path; +} + +# This proc gets called whenever data(selectPath) is set +# +sub SetPath { + my $w = shift; + $w->{'selectPath'} = $_[0] if @_; + $w->UpdateWhenIdle; +} + +# This proc gets called whenever data(filter) is set +# +#XXX here's much more code in the tcl version ... check it out +sub SetFilter { + my($w, $title, $filter) = @_; + $w->configure(-filter => $filter); + $w->{'typeMenuBtn'}->configure(-text => $title, + -indicatoron => 1); + $w->{'icons'}->Subwidget('sbar')->set(0.0, 0.0); + $w->UpdateWhenIdle; +} + +# tkFDialogResolveFile -- +# +# Interpret the user's text input in a file selection dialog. +# Performs: +# +# (1) ~ substitution +# (2) resolve all instances of . and .. +# (3) check for non-existent files/directories +# (4) check for chdir permissions +# +# Arguments: +# context: the current directory you are in +# text: the text entered by the user +# defaultext: the default extension to add to files with no extension +# +# Return value: +# [list $flag $directory $file] +# +# flag = OK : valid input +# = PATTERN : valid directory/pattern +# = PATH : the directory does not exist +# = FILE : the directory exists but the file doesn't +# exist +# = CHDIR : Cannot change to the directory +# = ERROR : Invalid entry +# +# directory : valid only if flag = OK or PATTERN or FILE +# file : valid only if flag = OK or PATTERN +# +# directory may not be the same as context, because text may contain +# a subdirectory name +# +sub ResolveFile { + my($context, $text, $defaultext) = @_; + my $appPWD = _cwd(); + my $path = JoinFile($context, $text); + # If the file has no extension, append the default. Be careful not + # to do this for directories, otherwise typing a dirname in the box + # will give back "dirname.extension" instead of trying to change dir. + if (!-d $path && $path !~ /\..+$/ && defined $defaultext) { + $path = "$path$defaultext"; + } + # Cannot just test for existance here as non-existing files are + # not an error for getSaveFile type dialogs. + # return ('ERROR', $path, "") if (!-e $path); + my($directory, $file, $flag); + if (-e $path) { + if (-d $path) { + if (!ext_chdir($path)) { + return ('CHDIR', $path, ''); + } + $directory = _cwd(); + $file = ''; + $flag = 'OK'; + ext_chdir($appPWD); + } else { + my $dirname = File::Basename::dirname($path); + if (!ext_chdir($dirname)) { + return ('CHDIR', $dirname, ''); + } + $directory = _cwd(); + $file = File::Basename::basename($path); + $flag = 'OK'; + ext_chdir($appPWD); + } + } else { + my $dirname = File::Basename::dirname($path); + if (-e $dirname) { + if (!ext_chdir($dirname)) { + return ('CHDIR', $dirname, ''); + } + $directory = _cwd(); + $file = File::Basename::basename($path); + if ($file =~ /[*?]/) { + $flag = 'PATTERN'; + } else { + $flag = 'FILE'; + } + ext_chdir($appPWD); + } else { + $directory = $dirname; + $file = File::Basename::basename($path); + $flag = 'PATH'; + } + } + return ($flag,$directory,$file); +} + +# Gets called when the entry box gets keyboard focus. We clear the selection +# from the icon list . This way the user can be certain that the input in the +# entry box is the selection. +# +sub EntFocusIn { + my $w = shift; + my $ent = $w->{'ent'}; + if ($ent->get ne '') { + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } else { + $ent->selectionClear; + } +#XXX is this missing in the tcl version, too??? $w->{'icons'}->Selection('clear'); + my $okBtn = $w->{'okBtn'}; + if ($w->cget(-type) ne 'save') { + $okBtn->configure(-text => 'Open'); + } else { + $okBtn->configure(-text => 'Save'); + } +} + +sub EntFocusOut { + my $w = shift; + $w->{'ent'}->selectionClear; +} + +# Gets called when user presses Return in the "File name" entry. +# +sub ActivateEnt { + my $w = shift; + my $ent = $w->{'ent'}; + my $text = $ent->get; + if ($w->cget(-multiple)) { + # For the multiple case we have to be careful to get the file + # names as a true list, watching out for a single file with a + # space in the name. Thus we query the IconList directly. + + $w->{'selectFile'} = []; + for my $item ($w->{'icons'}->Curselection) { + $w->VerifyFileName($w->{'icons'}->Get($item)); + } + } else { + $w->VerifyFileName($text); + } +} + +# Verification procedure +# +sub VerifyFileName { + my($w, $text) = @_; +#XXX leave this here? +# $text =~ s/^\s+//; +# $text =~ s/\s+$//; + my($flag, $path, $file) = ResolveFile($w->{'selectPath'}, $text, + $w->cget(-defaultextension)); + my $ent = $w->{'ent'}; + if ($flag eq 'OK') { + if ($file eq '') { + # user has entered an existing (sub)directory + $w->SetPath($path); + $ent->delete(0, 'end'); + } else { + $w->SetPathSilently($path); + if ($w->cget(-multiple)) { + push @{ $w->{'selectFile'} }, $file; + } else { + $w->{'selectFile'} = $file; + } + $w->Done; + } + } elsif ($flag eq 'PATTERN') { + $w->SetPath($path); + $w->configure(-filter => $file); + } elsif ($flag eq 'FILE') { + if ($w->cget(-type) eq 'open') { + $w->messageBox(-icon => 'warning', + -type => 'OK', + -message => 'File "' . TclFileJoin($path, $file) + . '" does not exist.'); + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } elsif ($w->cget(-type) eq 'save') { + $w->SetPathSilently($path); + if ($w->cget(-multiple)) { + push @{ $w->{'selectFile'} }, $file; + } else { + $w->{'selectFile'} = $file; + } + $w->Done; + } + } elsif ($flag eq 'PATH') { + $w->messageBox(-icon => 'warning', + -type => 'OK', + -message => "Directory \'$path\' does not exist."); + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } elsif ($flag eq 'CHDIR') { + $w->messageBox(-type => 'OK', + -message => "Cannot change to the directory \"$path\".\nPermission denied.", + -icon => 'warning'); + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } elsif ($flag eq 'ERROR') { + $w->messageBox(-type => 'OK', + -message => "Invalid file name \"$path\".", + -icon => 'warning'); + $ent->selectionRange(0, 'end'); + $ent->icursor('end'); + } +} + +# Gets called when user presses the Alt-s or Alt-o keys. +# +sub InvokeBtn { + my($w, $key) = @_; + my $okBtn = $w->{'okBtn'}; + $okBtn->invoke if ($okBtn->cget(-text) eq $key); +} + +# Gets called when user presses the "parent directory" button +# +sub UpDirCmd { + my $w = shift; + $w->SetPath(File::Basename::dirname($w->{'selectPath'})) + unless ($w->{'selectPath'} eq '/'); +} + +# Join a file name to a path name. The "file join" command will break +# if the filename begins with ~ +sub JoinFile { + my($path, $file) = @_; + if ($file =~ /^~/ && -e "$path/$file") { + TclFileJoin($path, "./$file"); + } else { + TclFileJoin($path, $file); + } +} + +# XXX replace with File::Spec when perl/Tk depends on 5.005 +sub TclFileJoin { + my $path = ''; + foreach (@_) { + if (m|^/|) { + $path = $_; + } + elsif (m|^[a-z]:/|i) { # DOS-ish + $path = $_; + } elsif ($_ eq '~') { + $path = _get_homedir(); + } elsif (m|^~/(.*)|) { + $path = _get_homedir() . "/" . $1; + } elsif (m|^~([^/]+)(.*)|) { + my($user, $p) = ($1, $2); + my $dir = _get_homedir($user); + if (!defined $dir) { + $path = "~$user$p"; + } else { + $path = $dir . $p; + } + } elsif ($path eq '/' or $path eq '') { + $path .= $_; + } else { + $path .= "/$_"; + } + } + $path; +} + +sub TclFileSplit { + my $path = shift; + my @comp; + $path =~ s|/+|/|g; # strip multiple slashes + if ($path =~ m|^/|) { + push @comp, '/'; + $path = substr($path, 1); + } + push @comp, split /\//, $path; + @comp; +} + +# Gets called when user presses the "OK" button +# +sub OkCmd { + my $w = shift; + my $from = shift || "button"; + + my $filenames = []; + for my $item ($w->{'icons'}->Curselection) { + push @$filenames, $w->{'icons'}->Get($item); + } + + my $filename = $filenames->[0]; + if ($w->cget('-type') eq 'dir' && $from ne "iconlist") { + my $file = $filename eq '' ? $w->{'selectPath'} : JoinFile($w->{'selectPath'}, $filename); + $w->Done($file); + } elsif ((@$filenames && !$w->cget('-multiple')) || + ($w->cget('-multiple') && @$filenames == 1)) { + my $file = JoinFile($w->{'selectPath'}, $filename); + if (-d $file) { + $w->ListInvoke($filename); + return; + } + } + + $w->ActivateEnt; +} + +# Gets called when user presses the "Cancel" button +# +sub CancelCmd { + my $w = shift; + undef $w->{'selectFilePath'}; +} + +# Gets called when user browses the IconList widget (dragging mouse, arrow +# keys, etc) +# +sub ListBrowse { + my($w) = @_; + + my $text = []; + for my $item ($w->{'icons'}->Curselection) { + push @$text, $w->{'icons'}->Get($item); + } + return if @$text == 0; + my $isDir; + if (@$text > 1) { + my $newtext = []; + for my $file (@$text) { + my $fullfile = JoinFile($w->{'selectPath'}, $file); + if (!-d $fullfile) { + push @$newtext, $file; + } + } + $text = $newtext; + $isDir = 0; + } else { + my $file = JoinFile($w->{'selectPath'}, $text->[0]); + $isDir = -d $file; + } + my $ent = $w->{'ent'}; + my $okBtn = $w->{'okBtn'}; + if (!$isDir) { + $ent->delete(qw(0 end)); + $ent->insert(0, "@$text"); # XXX quote! + + if ($w->cget('-type') ne 'save') { + $okBtn->configure(-text => 'Open'); + } else { + $okBtn->configure(-text => 'Save'); + } + } else { + $okBtn->configure(-text => 'Open'); + } +} + +# Gets called when user invokes the IconList widget (double-click, +# Return key, etc) +# +sub ListInvoke { + my($w, @filenames) = @_; + return if !@filenames; + my $file = JoinFile($w->{'selectPath'}, $filenames[0]); + if (-d $file) { + my $appPWD = _cwd(); + if (!ext_chdir($file)) { + $w->messageBox(-type => 'OK', + -message => "Cannot change to the directory \"$file\".\nPermission denied.", + -icon => 'warning'); + } else { + ext_chdir($appPWD); + $w->SetPath($file); + } + } else { + if ($w->cget('-multiple')) { + $w->{'selectFile'} = [@filenames]; + } else { + $w->{'selectFile'} = $file; + } + $w->Done; + } +} + +# tkFDialog_Done -- +# +# Gets called when user has input a valid filename. Pops up a +# dialog box to confirm selection when necessary. Sets the +# tkPriv(selectFilePath) variable, which will break the "tkwait" +# loop in tkFDialog and return the selected filename to the +# script that calls tk_getOpenFile or tk_getSaveFile +# +sub Done { + my $w = shift; + my $selectFilePath = (@_) ? shift : ''; + if ($selectFilePath eq '') { + if ($w->cget('-multiple')) { + $selectFilePath = []; + for my $f (@{ $w->{'selectFile'} }) { + push @$selectFilePath, JoinFile($w->{'selectPath'}, $f); + } + } else { + $selectFilePath = JoinFile($w->{'selectPath'}, + $w->{'selectFile'}); + } + if ($w->cget(-type) eq 'save' and + -e $selectFilePath and + !$w->cget(-force)) { + my $reply = $w->messageBox + (-icon => 'warning', + -type => 'YesNo', + -message => "File \"$selectFilePath\" already exists.\nDo you want to overwrite it?"); + return unless (lc($reply) eq 'yes'); + } + } + $w->{'selectFilePath'} = ($selectFilePath ne '' ? $selectFilePath : undef); +} + +sub FDialog { + my $cmd = shift; + if ($cmd =~ /Save/) { + push @_, -type => 'save'; + } elsif ($cmd =~ /Directory/) { + push @_, -type => 'dir'; + } + Tk::DialogWrapper('FBox', $cmd, @_); +} + +# tkFDGetFileTypes -- +# +# Process the string given by the -filetypes option of the file +# dialogs. Similar to the C function TkGetFileFilters() on the Mac +# and Windows platform. +# +sub GetFileTypes { + my $in = shift; + my %fileTypes; + foreach my $t (@$in) { + if (@$t < 2 || @$t > 3) { + require Carp; + Carp::croak("bad file type \"$t\", should be \"typeName [extension ?extensions ...?] ?[macType ?macTypes ...?]?\""); + } + push @{ $fileTypes{$t->[0]} }, (ref $t->[1] eq 'ARRAY' + ? @{ $t->[1] } + : $t->[1]); + } + + my @types; + my %hasDoneType; + my %hasGotExt; + foreach my $t (@$in) { + my $label = $t->[0]; + my @exts; + + next if (exists $hasDoneType{$label}); + + my $name = "$label ("; + my $sep = ''; + foreach my $ext (@{ $fileTypes{$label} }) { + next if ($ext eq ''); + $ext =~ s/^\./*./; + if (!exists $hasGotExt{$label}->{$ext}) { + $name .= "$sep$ext"; + push @exts, $ext; + $hasGotExt{$label}->{$ext}++; + } + $sep = ','; + } + $name .= ')'; + push @types, [$name, \@exts]; + + $hasDoneType{$label}++; + } + + return @types; +} + +# ext_chdir -- +# +# Change directory with tilde substitution +# +sub ext_chdir { + my $dir = shift; + if ($dir eq '~') { + chdir _get_homedir(); + } elsif ($dir =~ m|^~/(.*)|) { + chdir _get_homedir() . "/" . $1; + } elsif ($dir =~ m|^~([^/]+(.*))|) { + chdir _get_homedir($1) . $2; + } else { + chdir $dir; + } +} + +# _get_homedir -- +# +# Get home directory of the current user +# +sub _get_homedir { + my($user) = @_; + if (!defined $user) { + eval { + local $SIG{__DIE__}; + (getpwuid($<))[7]; + } || $ENV{HOME} || undef; # chdir undef changes to home directory, too + } else { + eval { + local $SIG{__DIE__}; + (getpwnam($user))[7]; + }; + } +} + +sub _cwd { + #Cwd::cwd(); + Cwd::fastcwd(); # this is taint-safe +} + +sub _untaint { + my $s = shift; + $s =~ /^(.*)$/; + $1; +} + +sub _rx_to_glob { + my $arg = shift; + $arg = join('|', split(' ', $arg)); + $arg =~ s!([\.\+])!\\$1!g; + $arg =~ s!\*!.*!g; + $arg = "^" . $arg . "\$"; + if ($] >= 5.005) { + $arg = qr/$arg/; + } + $arg; +} + +1; + diff --git a/Master/tlpkg/tlperl/lib/Tk/FileSelect.pm b/Master/tlpkg/tlperl/lib/Tk/FileSelect.pm new file mode 100644 index 00000000000..d2070049d82 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/FileSelect.pm @@ -0,0 +1,578 @@ +package Tk::FileSelect; + +use vars qw($VERSION @EXPORT_OK); +$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/; +@EXPORT_OK = qw(glob_to_re); + +use Tk qw(Ev); +use strict; +use Carp; +use base qw(Tk::Toplevel); +use Tk::widgets qw(LabEntry Button Frame Listbox Scrollbar); +use File::Basename; + +Construct Tk::Widget 'FileSelect'; + +use vars qw(%error_text); +%error_text = ( + '-r' => 'is not readable by effective uid/gid', + '-w' => 'is not writeable by effective uid/gid', + '-x' => 'is not executable by effective uid/gid', + '-R' => 'is not readable by real uid/gid', + '-W' => 'is not writeable by real uid/gid', + '-X' => 'is not executable by real uid/gid', + '-o' => 'is not owned by effective uid/gid', + '-O' => 'is not owned by real uid/gid', + '-e' => 'does not exist', + '-z' => 'is not of size zero', + '-s' => 'does not exists or is of size zero', + '-f' => 'is not a file', + '-d' => 'is not a directory', + '-l' => 'is not a link', + '-S' => 'is not a socket', + '-p' => 'is not a named pipe', + '-b' => 'is not a block special file', + '-c' => 'is not a character special file', + '-u' => 'is not setuid', + '-g' => 'is not setgid', + '-k' => 'is not sticky', + '-t' => 'is not a terminal file', + '-T' => 'is not a text file', + '-B' => 'is not a binary file', + '-M' => 'has no modification date/time', + '-A' => 'has no access date/time', + '-C' => 'has no inode change date/time', + ); + +# Documentation after __END__ + +sub import { + if (defined $_[1] and $_[1] eq 'as_default') { + local $^W = 0; + package Tk; + if ($Tk::VERSION < 804) { + *FDialog = \&Tk::FileSelect::FDialog; + *MotifFDialog = \&Tk::FileSelect::FDialog; + } else { + *tk_getOpenFile = sub { + Tk::FileSelect::FDialog("tk_getOpenFile", @_); + }; + *tk_getSaveFile = sub { + Tk::FileSelect::FDialog("tk_getSaveFile", @_); + }; + } + } +} + +sub Cancel +{ + my ($cw) = @_; + $cw->{Selected} = undef; + $cw->withdraw unless $cw->cget('-transient'); +} + +sub Accept { + + # Accept the file or directory name if possible. + + my ($cw) = @_; + + my($path, $so) = ($cw->cget('-directory'), $cw->SelectionOwner); + my $leaf = undef; + my $leaves; + + if (defined $so and + $so == $cw->Subwidget('dir_list')->Subwidget('listbox')) { + $leaves = [$cw->Subwidget('dir_list')->getSelected]; + $leaves = [$cw->Subwidget('dir_entry')->get] if !scalar(@$leaves); + } else { + $leaves = [$cw->Subwidget('file_list')->getSelected]; + $leaves = [$cw->Subwidget('file_entry')->get] if !scalar(@$leaves); + } + + foreach $leaf (@$leaves) + { + if (defined $leaf and $leaf ne '') { + if (!$cw->cget('-create') || -e "$path/$leaf") + { + foreach (@{$cw->cget('-verify')}) { + my $r = ref $_; + if (defined $r and $r eq 'ARRAY') { + #local $_ = $leaf; # use strict var problem here + return if not &{$_->[0]}($cw, $path, $leaf, @{$_}[1..$#{$_}]); + } else { + my $s = eval "$_ '$path/$leaf'"; + print $@ if $@; + if (not $s) { + my $err; + if (substr($_,0,1) eq '!') + { + my $t = substr($_,1); + if (exists $error_text{$t}) + { + $err = $error_text{$t}; + $err =~ s/\b(?:no|not) //; + } + } + $err = $error_text{$_} unless defined $err; + $err = "failed '$_' test" unless defined $err; + $cw->Error("'$leaf' $err."); + return; + } + } + } # forend + } + else + { + unless (-w $path) + { + $cw->Error("Cannot write to $path"); + return; + } + } + $leaf = $path . '/' . $leaf; + } else { + $leaf = undef; + } + } + if (scalar(@$leaves)) + { + my $sm = $cw->Subwidget('file_list')->cget(-selectmode); + $cw->{Selected} = $leaves; + my $command = $cw->cget('-command'); + $command->Call(@{$cw->{Selected}}) if defined $command; + } + +} # end Accept + +sub Accept_dir +{ + my ($cw,$new) = @_; + my $dir = $cw->cget('-directory'); + $cw->configure(-directory => "$dir/$new"); +} + +sub Populate { + + my ($w, $args) = @_; + + require Tk::Listbox; + require Tk::Button; + require Tk::Dialog; + require Tk::Toplevel; + require Tk::LabEntry; + require Cwd; + + $w->SUPER::Populate($args); + $w->protocol('WM_DELETE_WINDOW' => ['Cancel', $w ]); + + $w->{'reread'} = 0; + $w->withdraw; + + # Create directory/filter entry, place at the top. + my $e = $w->Component( + LabEntry => 'dir_entry', + -textvariable => \$w->{DirectoryString}, + -labelVariable => \$w->{Configure}{-dirlabel}, + ); + $e->pack(-side => 'top', -expand => 0, -fill => 'x'); + $e->bind('' => [$w => 'validateDir', Ev(['get'])]); + + # Create file entry, place at the bottom. + $e = $w->Component( + LabEntry => 'file_entry', + -textvariable => \$w->{Configure}{-initialfile}, + -labelVariable => \$w->{Configure}{-filelabel}, + ); + $e->pack(-side => 'bottom', -expand => 0, -fill => 'x'); + $e->bind('' => [$w => 'validateFile', Ev(['get'])]); + $e->bind('' => [$w => 'SelectionClear']); + + # Create directory scrollbox, place at the left-middle. + my $b = $w->Component( + ScrlListbox => 'dir_list', + -labelVariable => \$w->{Configure}{-dirlistlabel}, + -scrollbars => 'se', + ); + $b->pack(-side => 'left', -expand => 1, -fill => 'both'); + $b->bind('' => [$w => 'Accept_dir', Ev(['getSelected'])]); + + # Add a label. + + my $f = $w->Frame(); + $f->pack(-side => 'right', -fill => 'y', -expand => 0); + $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-acceptlabel'}, + -command => [ 'Accept', $w ], + ); + $b->pack(-side => 'top', -fill => 'x', -expand => 1); + $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-cancellabel'}, + -command => [ 'Cancel', $w ], + ); + $b->pack(-side => 'top', -fill => 'x', -expand => 1); + $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-resetlabel'}, + -command => [$w => 'configure','-directory','.'], + ); + $b->pack(-side => 'top', -fill => 'x', -expand => 1); + $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-homelabel'}, + -command => [$w => 'configure','-directory',$ENV{'HOME'}], + ); + $b->pack(-side => 'top', -fill => 'x', -expand => 1); + + # Create file scrollbox, place at the right-middle. + + $b = $w->Component( + ScrlListbox => 'file_list', + -labelVariable => \$w->{Configure}{-filelistlabel}, + -scrollbars => 'se', + ); + $b->pack(-side => 'right', -expand => 1, -fill => 'both'); + $b->bind('' => [$w => 'Accept']); + + # Create -very dialog. + + my $v = $w->Component( + Dialog => 'dialog', + -title => 'Verify Error', + -bitmap => 'error', + -buttons => ['Dismiss'], + ); + + $w->ConfigSpecs( + -width => [ ['file_list','dir_list'], undef, undef, 14 ], + -height => [ ['file_list','dir_list'], undef, undef, 14 ], + -directory => [ 'METHOD', undef, undef, '.' ], + -initialdir => '-directory', + -filelabel => [ 'PASSIVE', 'fileLabel', 'FileLabel', 'File' ], + -initialfile => [ 'PASSIVE', undef, undef, '' ], + -filelistlabel => [ 'PASSIVE', undef, undef, 'Files' ], + -filter => [ 'METHOD', undef, undef, undef ], + -defaultextension => [ 'METHOD', undef, undef, undef ], + -regexp => [ 'METHOD', undef, undef, undef ], + -dirlistlabel => [ 'PASSIVE', undef, undef, 'Directories'], + -dirlabel => [ 'PASSIVE', undef, undef, 'Directory'], + '-accept' => [ 'CALLBACK',undef,undef, undef ], + -command => [ 'CALLBACK',undef,undef, undef ], + -transient => [ 'PASSIVE', undef, undef, 1 ], + -verify => [ 'PASSIVE', undef, undef, ['!-d'] ], + -create => [ 'PASSIVE', undef, undef, 0 ], + -acceptlabel => [ 'PASSIVE', undef, undef, 'Accept'], + -cancellabel => [ 'PASSIVE', undef, undef, 'Cancel'], + -resetlabel => [ 'PASSIVE', undef, undef, 'Reset'], + -homelabel => [ 'PASSIVE', undef, undef, 'Home'], + DEFAULT => [ 'file_list' ], + ); + $w->Delegates(DEFAULT => 'file_list'); + + return $w; + +} # end Populate + +sub translate + { + my ($bs,$ch) = @_; + return "\\$ch" if (length $bs); + return '.*' if ($ch eq '*'); + return '.' if ($ch eq '?'); + return "\\." if ($ch eq '.'); + return "\\/" if ($ch eq '/'); + return "\\\\" if ($ch eq '\\'); + return $ch; +} + +sub glob_to_re +{ + my $regex = shift; + $regex =~ s/(\\?)(.)/&translate($1,$2)/ge; + return sub { shift =~ /^${regex}$/ }; +} + +sub filter +{ + my ($cw,$val) = @_; + my $var = \$cw->{Configure}{'-filter'}; + if (@_ > 1 || !defined($$var)) + { + $val = '*' unless defined $val; + $$var = $val; + $cw->{'match'} = glob_to_re($val) unless defined $cw->{'match'}; + unless ($cw->{'reread'}++) + { + $cw->Busy; + $cw->afterIdle(['reread',$cw,$cw->cget('-directory')]) + } + } + return $$var; +} + +sub regexp +{ + my ($cw,$val) = @_; + my $var = \$cw->{Configure}{'-regexp'}; + if (@_ > 1) + { + $$var = $val; + $cw->{'match'} = (defined $val) ? sub { shift =~ m|^${val}$| } : sub { 1 }; + unless ($cw->{'reread'}++) + { + $cw->Busy; + $cw->afterIdle(['reread',$cw]) + } + } + return $$var; +} + +sub defaultextension +{ + my ($cw,$val) = @_; + if (@_ > 1) + { + $val = '' unless defined $val; + $val = ".$val" if ($val !~ /^\./); + $cw->filter("*$val"); + } + else + { + $val = $cw->filter; + my ($ext) = $val =~ /(\.[^\.]*)$/; + return $ext; + } +} + +sub directory +{ + my ($cw,$dir) = @_; + my $var = \$cw->{Configure}{'-directory'}; + if (@_ > 1 && defined $dir) + { + if (substr($dir,0,1) eq '~') + { + if (substr($dir,1,1) eq '/') + { + $dir = (defined $ENV{'HOME'} ? $ENV{'HOME'} : '') . substr($dir,1); + } + else + {my ($uid,$rest) = ($dir =~ m#^~([^/]+)(/.*$)#); + $dir = (getpwnam($uid))[7] . $rest; + } + } + my $revert_dir = sub + { + my $message = shift; + $$var = $cw->{OldDirectory}; + $cw->messageBox(-message => $message, -icon => 'error'); + if (!defined $$var) + { + # OldDirectory was never set, so force reread... + $$var = $cw->{OldDirectory} = Cwd::getcwd(); # XXX maybe use check like code below... + unless ($cw->{'reread'}++) + { + $cw->Busy; + $cw->afterIdle(['reread',$cw]) + } + } + $$var; + }; + $dir =~ s#([^/\\])[\\/]+$#$1#; + if (-d $dir) + { + unless (Tk::tainting()) + { + my $pwd = Cwd::getcwd(); + if (chdir( (defined($dir) ? $dir : '') ) ) + { + my $new = Cwd::getcwd(); + if ($new) + { + $dir = $new; + } + else + { + return $revert_dir->("Cannot getcwd in '$dir'"); + } + if (!chdir($pwd)) + { + return $revert_dir->("Cannot change directory to $pwd:\n$!"); + } + $$var = $dir; + } + else + { + return $revert_dir->("Cannot change directory to $dir:\n$!"); + } + $$var = $cw->{OldDirectory} = $dir; + } + unless ($cw->{'reread'}++) + { + $cw->Busy; + $cw->afterIdle(['reread',$cw]) + } + } + } + return $$var; +} + +sub reread +{ + my ($w) = @_; + my $dir = $w->cget('-directory'); + if (defined $dir) + { + if (!defined $w->cget('-filter') or $w->cget('-filter') eq '') + { + $w->configure('-filter', '*'); + } + my $dl = $w->Subwidget('dir_list'); + $dl->delete(0, 'end'); + $dl->selectionClear(0,'end'); + my $fl = $w->Subwidget('file_list'); + $fl->delete(0, 'end'); + local *DIR; + if (opendir(DIR, $dir)) + { + my $file = $w->cget('-initialfile'); + my $seen = 0; + my $accept = $w->cget('-accept'); + foreach my $f (sort(readdir(DIR))) + { + next if ($f eq '.'); + my $path = "$dir/$f"; + if (-d $path) + { + $dl->insert('end', $f); + } + else + { + if (&{$w->{match}}($f)) + { + if (!defined($accept) || $accept->Call($path)) + { + $seen = $fl->index('end') if ($file && $f eq $file); + $fl->insert('end', $f) + } + } + } + } + closedir(DIR); + if ($seen) + { + $fl->selectionSet($seen); + $fl->see($seen); + } + else + { + $w->configure(-initialfile => undef) unless $w->cget('-create'); + } + } + $w->{DirectoryString} = $dir . ($dir ne '/' ? '/' : '') . $w->cget('-filter'); + } + $w->{'reread'} = 0; + $w->Unbusy if $w->{'Busy'}; +} + +sub validateDir +{ + my ($cw,$name) = @_; + my ($leaf,$base) = fileparse($name); + if ($leaf =~ /[*?]/) + { + $cw->configure('-directory' => $base,'-filter' => $leaf); + } + else + { + $cw->configure('-directory' => $name); + } +} + +sub validateFile +{ + my ($cw,$name) = @_; + my $i = 0; + my $n = $cw->index('end'); + # See if it is an existing file + for ($i= 0; $i < $n; $i++) + { + my $f = $cw->get($i); + if ($f eq $name) + { + $cw->selection('set',$i); + $cw->Accept; + } + } + # otherwise allow if -create is set, directory is writable + # and it passes filter and accept criteria + if ($cw->cget('-create')) + { + my $path = $cw->cget('-directory'); + if (-w $path) + { + if (&{$cw->{match}}($name)) + { + my $accept = $cw->cget('-accept'); + my $full = "$path/$name"; + if (!defined($accept) || $accept->Call($full)) + { + $cw->{Selected} = [$full]; + $cw->Callback(-command => @{$cw->{Selected}}); + } + else + { + $cw->Error("$name is not 'acceptable'"); + } + } + else + { + $cw->Error("$name does not match '".$cw->cget('-filter').'\''); + } + } + else + { + $cw->Error("Directory '$path' is not writable"); + return; + } + } +} + +sub Error +{ + my $cw = shift; + my $msg = shift; + my $dlg = $cw->Subwidget('dialog'); + $dlg->configure(-text => $msg); + $dlg->Show; +} + +sub Show +{ + my ($cw,@args) = @_; + if ($cw->cget('-transient')) { + $cw->Popup(@args); + $cw->focus; + $cw->waitVariable(\$cw->{Selected}); + $cw->withdraw; + return defined($cw->{Selected}) + ? (wantarray) ? @{$cw->{Selected}} : $cw->{Selected}[0] + : undef; + } else { + $cw->Popup(@args); + } +} + +sub FDialog +{ + my($cmd, %args) = @_; + if ($cmd =~ /Save/) + { + $args{-create} = 1; + $args{-verify} = [qw(!-d -w)]; + } + delete $args{-filetypes}; + delete $args{-force}; + Tk::DialogWrapper('FileSelect',$cmd, %args); +} + +1; + +__END__ + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm b/Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm new file mode 100644 index 00000000000..eb6465dbe61 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm @@ -0,0 +1,109 @@ +# Tranlation of FloatEnt.tcl in Tix4.1 + +# TODO/IDEA: +# o extract a widget (SimpleEntry?) without post/unpost methods +# and derive FloatEntry fron this widget. + +package Tk::FloatEntry; +use strict; + +BEGIN + { + use vars '$DEBUG'; + $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'achx') ? 1 : 0; + print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG; + } + +require Tk; +require Tk::Widget; +require Tk::Derived; +require Tk::Entry; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/TixGrid/FloatEntry.pm#4 $ + +use base qw(Tk::Derived Tk::Entry); + +Construct Tk::Widget 'FloatEntry'; + +sub ClassInit + { + my ($class, $mw) = @_; + $class->SUPER::ClassInit($mw); + $mw->bind($class, '', 'invoke'); + $mw->bind($class, '', 'FocusIn'); + $class; + } + +sub Populate + { + my ($e, $args) = @_; + $e->ConfigSpecs( + -value => ['METHOD', 'value', 'Value', undef], + -highlightthickness => [$e, 'highlightThickness', 'HighlightThickness', 0 ], + -command => ['CALLBACK', 'command', 'Command', undef], + ); + print "FloatEntry Init: $e\n" if $DEBUG; + $e; + } + +## option method + +sub value + { + my $e = shift; + unless (@_) + { + return $e->get + } + $e->delete(0,'end'); + $e->insert(0,$_[0]); + $e->selection('from', 0); + $e->selection('to', 'end'); + + } + +## public methods + +sub invoke + { + my ($e) = @_; + $e->Callback('-command', $e->get); + } + +sub post + { + my ($e, $x, $y, $dx, $dy) = @_; + + $dx = $e->reqwidth unless defined $dx; + $dy = $e->reqheight unless defined $dy; + + $e->place('-x'=>$x, '-y'=>$y, -width=>$dx, -height=>$dy, -bordermode=>'ignore'); + $e->raise; + $e->focus; + } + +sub unpost + { + my ($e) = @_; + $e->place('forget'); + } + +## bindings + +sub FocusIn + { + my ($e) = @_; + + # FIX: xxx only if entry has not already focus + { + $e->focus; + $e->selection('from', 0); + $e->selection('to', 'end'); + $e->icursor('end'); + } + } + +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/Font.pm b/Master/tlpkg/tlperl/lib/Tk/Font.pm new file mode 100644 index 00000000000..bb1b52cc7c5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Font.pm @@ -0,0 +1,163 @@ +package Tk::Font; +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Font.pm#4 $ +require Tk::Widget; +use strict; +use Carp; +use overload '""' => 'as_string'; +sub as_string { return ${$_[0]} } + +*MainWindow = \&Tk::Widget::MainWindow; + +foreach my $key (qw(actual metrics measure configure)) + { + no strict 'refs'; + *{$key} = sub { shift->Tk::font($key,@_) }; + } + +Construct Tk::Widget 'Font'; + +my @xfield = qw(foundry family weight slant swidth adstyle pixel + point xres yres space avgwidth registry encoding); +my @tkfield = qw(family size weight slant underline overstrike); +my %tkfield = map { $_ => "-$_" } @tkfield; + +sub _xonly { my $old = '*'; return $old } + +sub Pixel +{ + my $me = shift; + my $old = $me->configure('-size'); + $old = '*' if ($old > 0); + if (@_) + { + $me->configure(-size => -$_[0]); + } + return $old; +} + +sub Point +{ + my $me = shift; + my $old = 10*$me->configure('-size'); + $old = '*' if ($old < 0); + if (@_) + { + $me->configure(-size => int($_[0]/10)); + } + return $old; +} + +foreach my $f (@tkfield,@xfield) + { + no strict 'refs'; + my $sub = "\u$f"; + unless (defined &{$sub}) + { + my $key = $tkfield{$f}; + if (defined $key) + { + *{$sub} = sub { shift->configure($key,@_) }; + } + else + { + *{$sub} = \&_xonly; + } + } + } + +sub new +{ + my $pkg = shift; + my $w = shift; + my $me; + if (scalar(@_) == 1) + { + $me = $w->Tk::font('create',@_); + } + else + { + croak 'Odd number of args' if @_ & 1; + my %attr; + while (@_) + { + my $k = shift; + my $v = shift; + my $t = (substr($k,0,1) eq '-') ? $k : $tkfield{$k}; + if (defined $t) + { + $attr{$t} = $v; + } + elsif ($k eq 'point') + { + $attr{'-size'} = -int($v/10+0.5); + } + elsif ($k eq 'pixel') + { + $attr{'-size'} = -$v; + } + else + { + carp "$k ignored" if $^W; + } + } + $me = $w->Tk::font('create',%attr); + } + return bless $me,$pkg; +} + +sub Pattern +{ + my $me = shift; + my @str; + foreach my $f (@xfield) + { + my $meth = "\u$f"; + my $str = $me->$meth(); + if ($f eq 'family') + { + $str =~ s/(?:Times\s+New\s+Roman|New York)/Times/i; + $str =~ s/(?:Courier\s+New|Monaco)/Courier/i; + $str =~ s/(?:Arial|Geneva)/Helvetica/i; + } + elsif ($f eq 'slant') + { + $str = substr($str,0,1); + } + elsif ($f eq 'weight') + { + $str = 'medium' if ($str eq 'normal'); + } + push(@str,$str); + } + return join('-', '', @str); +} + +sub Name +{ + my $me = shift; + return $$me if (!wantarray || ($^O eq 'MSWin32')); + my $max = shift || 128; + my $w = $me->MainWindow; + my $d = $w->Display; + return $d->XListFonts($me->Pattern,$max); +} + +sub Clone +{ + my $me = shift; + return ref($me)->new($me,$me->actual,@_); +} + +sub ascent +{ + return shift->metrics('-ascent'); +} + +sub descent +{ + return shift->metrics('-descent'); +} + +1; + diff --git a/Master/tlpkg/tlperl/lib/Tk/Frame.pm b/Master/tlpkg/tlperl/lib/Tk/Frame.pm new file mode 100644 index 00000000000..a5716cdf9bd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Frame.pm @@ -0,0 +1,378 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Frame; +require Tk::Widget; +require Tk::Derived; +use AutoLoader; +use strict qw(vars); +use Carp; + +use base qw(Tk::Derived Tk::Widget); + +Construct Tk::Widget 'Frame'; + +use vars qw($VERSION); +$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Frame.pm#10 $ + +sub Tk_cmd { \&Tk::frame } + +sub CreateOptions +{ + return (shift->SUPER::CreateOptions,'-colormap','-visual','-container') +} + +sub Default +{ + my ($cw,$name,$widget) = @_; + confess 'No name' unless (defined $name); + croak 'No widget' unless (defined $widget); + $cw->Delegates(DEFAULT => $widget); + $cw->ConfigSpecs(DEFAULT => [$widget]); + $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect + $cw->Advertise($name,$widget); +} + +sub ConfigDelegate +{ + my ($cw,$name,@skip) = @_; + my $sw = $cw->Subwidget($name); + my $sc; + my %skip = (); + foreach $sc (@skip) + { + $skip{$sc} = 1; + } + foreach $sc ($sw->configure) + { + my (@info) = @$sc; + next if (@info == 2); + my $option = $info[0]; + unless ($skip{$option}) + { + $option =~ s/^-(.*)/-$name\u$1/; + $info[0] = Tk::Configure->new($sw,$info[0]); + pop(@info); + $cw->ConfigSpecs($option => \@info); + } + } +} + +sub bind +{my ($cw,@args) = @_; + $cw->Delegate('bind',@args); +} + +sub menu +{my ($cw,@args) = @_; + $cw->Delegate('menu',@args); +} + +sub focus +{my ($cw,@args) = @_; + $cw->Delegate('focus',@args); +} + +#sub bindtags +#{my ($cw,@args) = @_; +# $cw->Delegate('bindtags',@args); +#} + +sub selection +{my ($cw,@args) = @_; + $cw->Delegate('selection',@args); +} + +sub autoLabel { 1 } + +sub Populate +{ + my ($cw,$args) = @_; + if ($cw->autoLabel) + { + $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]); + $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]); + $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]); + $cw->labelPack([]) if grep /^-label\w+/, keys %$args; + } +} + +sub Menubar +{ + my $frame = shift; + my $menu = $frame->cget('-menu'); + if (defined $menu) + { + $menu->configure(@_) if @_; + } + else + { + $menu = $frame->Menu(-type => 'menubar',@_); + $frame->configure('-menu' => $menu); + } + $frame->Advertise('menubar' => $menu); + return $menu; +} + +1; + +__END__ + +sub labelPack +{ + my ($cw,$val) = @_; + my $w = $cw->Subwidget('label'); + my @result = (); + if (@_ > 1) + { + if (defined($w) && !defined($val)) + { + $w->packForget; + } + elsif (defined($val) && !defined ($w)) + { + require Tk::Label; + $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable); + $cw->Advertise('label' => $w); + $cw->ConfigDelegate('label',qw(-text -textvariable)); + } + if (defined($val) && defined($w)) + { + my %pack = @$val; + unless (exists $pack{-side}) + { + $pack{-side} = 'top' unless (exists $pack{-side}); + } + unless (exists $pack{-fill}) + { + $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/); + $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/); + } + unless (exists($pack{'-before'}) || exists($pack{'-after'})) + { + my $before = ($cw->packSlaves)[0]; + $pack{'-before'} = $before if (defined $before); + } + $w->pack(%pack); + } + } + @result = $w->packInfo if (defined $w); + return (wantarray) ? @result : \@result; +} + +sub labelVariable +{ + my ($cw,$val) = @_; + my $var = \$cw->{Configure}{'-labelVariable'}; + if (@_ > 1 && defined $val) + { + $$var = $val; + $$val = '' unless (defined $$val); + my $w = $cw->Subwidget('label'); + unless (defined $w) + { + $cw->labelPack([]); + $w = $cw->Subwidget('label'); + } + $w->configure(-textvariable => $val); + } + return $$var; +} + +sub label +{ + my ($cw,$val) = @_; + my $var = $cw->cget('-labelVariable'); + if (@_ > 1 && defined $val) + { + if (!defined $var) + { + $var = \$cw->{Configure}{'-label'}; + $cw->labelVariable($var); + } + $$var = $val; + } + return (defined $var) ? $$var : undef;; +} + +sub queuePack +{ + my ($cw) = @_; + unless ($cw->{'pack_pending'}) + { + $cw->{'pack_pending'} = 1; + $cw->afterIdle([$cw,'packscrollbars']); + } +} + +sub sbset +{ + my ($cw,$sb,$ref,@args) = @_; + $sb->set(@args); + $cw->queuePack if (@args == 2 && $sb->Needed != $$ref); +} + +sub freeze_on_map +{ + my ($w) = @_; + unless ($w->Tk::bind('Freeze','')) + { + $w->Tk::bind('Freeze','',['packPropagate' => 0]) + } + $w->AddBindTag('Freeze'); +} + +sub AddScrollbars +{ + require Tk::Scrollbar; + my ($cw,$w) = @_; + my $def = ''; + my ($x,$y) = ('',''); + my $s = 0; + my $c; + $cw->freeze_on_map; + foreach $c ($w->configure) + { + my $opt = $c->[0]; + if ($opt eq '-yscrollcommand') + { + my $slice = Tk::Frame->new($cw,Name => 'ysbslice'); + my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]); + my $size = $ysb->cget('-width'); + my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised', + '-width' => $size, '-height' => $size); + $ysb->pack(-side => 'left', -fill => 'y'); + $cw->Advertise('yscrollbar' => $ysb); + $cw->Advertise('corner' => $corner); + $cw->Advertise('ysbslice' => $slice); + $corner->{'before'} = $ysb->PathName; + $slice->{'before'} = $w->PathName; + $y = 'w'; + $s = 1; + } + elsif ($opt eq '-xscrollcommand') + { + my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]); + $cw->Advertise('xscrollbar' => $xsb); + $xsb->{'before'} = $w->PathName; + $x = 's'; + $s = 1; + } + } + if ($s) + { + $cw->Advertise('scrolled' => $w); + $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]); + } +} + +sub packscrollbars +{ + my ($cw) = @_; + my $opt = $cw->cget('-scrollbars'); + my $slice = $cw->Subwidget('ysbslice'); + my $xsb = $cw->Subwidget('xscrollbar'); + my $corner = $cw->Subwidget('corner'); + my $w = $cw->Subwidget('scrolled'); + my $xside = (($opt =~ /n/) ? 'top' : 'bottom'); + my $havex = 0; + my $havey = 0; + $opt =~ s/r//; + $cw->{'pack_pending'} = 0; + if (defined $slice) + { + my $reqy; + my $ysb = $cw->Subwidget('yscrollbar'); + if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed)) + { + my $yside = (($opt =~ /w/) ? 'left' : 'right'); + $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'}); + $havey = 1; + if ($reqy) + { + $w->configure(-yscrollcommand => ['set', $ysb]); + } + else + { + $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]); + } + } + else + { + $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//; + $slice->packForget; + } + $cw->{'packysb'} = $havey; + } + if (defined $xsb) + { + my $reqx; + if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed)) + { + $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'}); + $havex = 1; + if ($reqx) + { + $w->configure(-xscrollcommand => ['set', $xsb]); + } + else + { + $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]); + } + } + else + { + $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//; + $xsb->packForget; + } + $cw->{'packxsb'} = $havex; + } + if (defined $corner) + { + if ($havex && $havey && defined $corner->{'before'}) + { + my $anchor = $opt; + $anchor =~ s/o//g; + $corner->configure(-height => $xsb->ReqHeight); + $corner->pack(-before => $corner->{'before'}, -side => $xside, + -anchor => $anchor, -fill => 'x'); + } + else + { + $corner->packForget; + } + } +} + +sub scrollbars +{ + my ($cw,$opt) = @_; + my $var = \$cw->{'-scrollbars'}; + if (@_ > 1) + { + my $old = $$var; + if (!defined $old || $old ne $opt) + { + $$var = $opt; + $cw->queuePack; + } + } + return $$var; +} + +sub FindMenu +{ + my ($w,$char) = @_; + my $child; + my $match; + foreach $child ($w->children) + { + next unless (ref $child); + $match = $child->FindMenu($char); + return $match if (defined $match); + } + return undef; +} + + + diff --git a/Master/tlpkg/tlperl/lib/Tk/HList.pm b/Master/tlpkg/tlperl/lib/Tk/HList.pm new file mode 100644 index 00000000000..02792208243 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/HList.pm @@ -0,0 +1,680 @@ +package Tk::HList; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev $XS_VERSION); + +use base qw(Tk::Widget); + +Construct Tk::Widget 'HList'; +sub Tk::Widget::ScrlHList { shift->Scrolled('HList'=>@_) } + +bootstrap Tk::HList; + +sub Tk_cmd { \&Tk::hlist } + +sub CreateArgs +{ + my ($package,$parent,$args) = @_; + my @result = $package->SUPER::CreateArgs($parent,$args); + my $columns = delete $args->{-columns}; + push(@result, '-columns' => $columns) if (defined $columns); + return @result; +} + +Tk::Methods qw(add addchild anchor column + delete dragsite dropsite entrycget + entryconfigure geometryinfo indicator header hide item info + nearest see select selection show xview yview); + +use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)], + 'header' => [qw(configure cget create delete exists size)], + 'indicator' => [qw(configure cget create delete exists size)], + 'info' => [qw(anchor bbox children data dragsite + dropsite exists hidden item next parent prev + selection)], + 'item' => [qw(configure cget create delete exists)], + 'selection' => [qw(clear get includes set)], + 'anchor' => [qw(clear set)], + 'column' => [qw(width)], + 'hide' => [qw(entry)], + ); + + +sub ClassInit +{ + my ($class,$mw) = @_; + + $mw->bind($class,'',[ 'Button1' ] ); + $mw->bind($class,'',[ 'ShiftButton1' ] ); + $mw->bind($class,'','Control_ButtonRelease_1'); + $mw->bind($class,'','ButtonRelease_1'); + $mw->bind($class,'','NoOp'); + $mw->bind($class,'',[ 'Button1Motion' ] ); + $mw->bind($class,'',[ 'AutoScan' ] ); + + $mw->bind($class,'',['Double1']); + + $mw->bind($class,'','Control_B1_Motion'); + $mw->bind($class,'',['CtrlButton1']); + $mw->bind($class,'',['CtrlButton1']); + + $mw->bind($class,'','B1_Enter'); + + $mw->bind($class,'',['UpDown', 'prev']); + $mw->bind($class,'',['UpDown', 'next']); + + $mw->bind($class,'',['ShiftUpDown', 'prev']); + $mw->bind($class,'',['ShiftUpDown', 'next']); + + $mw->bind($class,'', ['LeftRight', 'left']); + $mw->bind($class,'',['LeftRight', 'right']); + + $mw->PriorNextBind($class); + $mw->MouseWheelBind($class); + + $mw->bind($class,'', ['KeyboardActivate']); + $mw->bind($class,'', ['KeyboardBrowse']); + $mw->bind($class,'', ['KeyboardHome']); + $mw->bind($class,'', ['KeyboardEnd']); + + $mw->YMouseWheelBind($class); + $mw->XMouseWheelBind($class); + + return $class; +} + +sub Control_ButtonRelease_1 +{ +} + +sub ButtonRelease_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->CancelRepeat + if($w->cget('-selectmode') ne 'dragdrop'); + $w->ButtonRelease1($Ev); +} + +sub Control_B1_Motion +{ +} + +sub B1_Enter +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->CancelRepeat + if($w->cget('-selectmode') ne 'dragdrop'); +} + +sub Button1 +{ + my $w = shift; + my $Ev = $w->XEvent; + + delete $w->{'shiftanchor'}; + delete $w->{tixindicator}; + + $w->focus() if($w->cget('-takefocus')); + + my $mode = $w->cget('-selectmode'); + + if ($mode eq 'dragdrop') + { + # $w->Send_WaitDrag($Ev->y); + return; + } + + my $ent = $w->GetNearest($Ev->y, 1); + + if (!defined($ent) || !length($ent)) + { + $w->selectionClear; + $w->anchorClear; + return; + } + + my @info = $w->info('item',$Ev->x, $Ev->y); + if (@info) + { + die 'Assert' unless $info[0] eq $ent; + } + else + { + @info = $ent; + } + + if (defined($info[1]) && $info[1] eq 'indicator') + { + $w->{tixindicator} = $ent; + $w->Callback(-indicatorcmd => $ent, ''); + } + else + { + my $browse = 0; + + if ($mode eq 'single') + { + $w->anchorSet($ent); + } + elsif ($mode eq 'browse') + { + $w->anchorSet($ent); + $w->selectionClear; + $w->selectionSet($ent); + $browse = 1; + } + elsif ($mode eq 'multiple') + { + $w->selectionClear; + $w->anchorSet($ent); + $w->selectionSet($ent); + $browse = 1; + } + elsif ($mode eq 'extended') + { + $w->anchorSet($ent); + $w->selectionClear; + $w->selectionSet($ent); + $browse = 1; + } + + if ($browse) + { + $w->Callback(-browsecmd => @info); + } + } +} + +sub ShiftButton1 +{ + my $w = shift; + my $Ev = $w->XEvent; + + my $to = $w->GetNearest($Ev->y, 1); + + delete $w->{'shiftanchor'}; + delete $w->{tixindicator}; + + return unless (defined($to) and length($to)); + + my $mode = $w->cget('-selectmode'); + + if($mode eq 'extended' or $mode eq 'multiple') + { + my $from = $w->info('anchor'); + if(defined $from) + { + $w->selectionClear; + $w->selectionSet($from, $to); + } + else + { + $w->anchorSet($to); + $w->selectionClear; + $w->selectionSet($to); + } + } +} + +sub GetNearest +{ + my ($w,$y,$undefafterend) = @_; + my $ent = $w->nearest($y); + if (defined $ent) + { + if ($undefafterend) + { + my $borderwidth = $w->cget('-borderwidth'); + my $highlightthickness = $w->cget('-highlightthickness'); + my $bottomy = ($w->infoBbox($ent))[3]; + $bottomy += $borderwidth + $highlightthickness; + if ($w->header('exist', 0)) + { + $bottomy += $w->header('height'); + } + if ($y > $bottomy) + { + #print "$y > $bottomy\n"; + return undef; + } + } + my $state = $w->entrycget($ent, '-state'); + return $ent if (!defined($state) || $state ne 'disabled'); + } + return undef; +} + +sub ButtonRelease1 +{ + my ($w, $Ev) = @_; + + delete $w->{'shiftanchor'}; + + my $mode = $w->cget('-selectmode'); + + if($mode eq 'dragdrop') + { +# $w->Send_DoneDrag(); + return; + } + + my ($x, $y) = ($Ev->x, $Ev->y); + my $ent = $w->GetNearest($y, 1); + + if (!defined($ent) and $mode eq 'single') + { + my $ent = $w->info('selection'); + if (defined $ent) + { + $w->anchorSet($ent); + } + } + return unless (defined($ent) and length($ent)); + + if (exists $w->{tixindicator}) + { + return unless delete($w->{tixindicator}) eq $ent; + my @info = $w->info('item',$Ev->x, $Ev->y); + if(defined($info[1]) && $info[1] eq 'indicator') + { + $w->Callback(-indicatorcmd => $ent, ''); + } + else + { + $w->Callback(-indicatorcmd => $ent, ''); + } + return; + } + + if($mode eq 'single' || $mode eq 'browse') + { + $w->anchorSet($ent); + $w->selectionClear; + $w->selectionSet($ent); + + } + elsif($mode eq 'multiple') + { + $w->selectionSet($ent); + } + elsif($mode eq 'extended') + { + $w->selectionSet($ent); + } + + $w->Callback(-browsecmd =>$ent); +} + +sub Button1Motion +{ + my $w = shift; + my $Ev = $w->XEvent; + return unless defined $Ev; + + delete $w->{'shiftanchor'}; + + my $mode = $w->cget('-selectmode'); + + if ($mode eq 'dragdrop') + { +# $w->Send_StartDrag(); + return; + } + + my $ent; + if (defined $w->info('anchor')) + { + $ent = $w->GetNearest($Ev->y); + } + else + { + $ent = $w->GetNearest($Ev->y, 1); + } + return unless (defined($ent) and length($ent)); + + if(exists $w->{tixindicator}) + { + my $event_type = $w->{tixindicator} eq $ent ? '' : ''; + $w->Callback(-indicatorcmd => $w->{tixindicator}, $event_type ); + return; + } + + if ($mode eq 'single') + { + $w->anchorSet($ent); + } + elsif ($mode eq 'multiple' || $mode eq 'extended') + { + my $from = $w->info('anchor'); + if(defined $from) + { + $w->selectionClear; + $w->selectionSet($from, $ent); + } + else + { + $w->anchorSet($ent); + $w->selectionClear; + $w->selectionSet($ent); + } + } + + if ($mode ne 'single') + { + $w->Callback(-browsecmd =>$ent); + } +} + +sub Double1 +{ + my $w = shift; + my $Ev = $w->XEvent; + + delete $w->{'shiftanchor'}; + + my $ent = $w->GetNearest($Ev->y, 1); + + return unless (defined($ent) and length($ent)); + + $w->anchorSet($ent) + unless(defined $w->info('anchor')); + + $w->selectionSet($ent); + + $w->Callback(-command => $ent); +} + +sub CtrlButton1 +{ + my $w = shift; + my $Ev = $w->XEvent; + + delete $w->{'shiftanchor'}; + + my $ent = $w->GetNearest($Ev->y, 1); + + return unless (defined($ent) and length($ent)); + + my $mode = $w->cget('-selectmode'); + + if($mode eq 'extended') + { + $w->anchorSet($ent) unless( defined $w->info('anchor') ); + + if($w->select('includes', $ent)) + { + $w->select('clear', $ent); + } + else + { + $w->selectionSet($ent); + } + $w->Callback(-browsecmd =>$ent); + } +} + +sub UpDown +{ + my $w = shift; + my $spec = shift; + + my $done = 0; + my $anchor = $w->info('anchor'); + + delete $w->{'shiftanchor'}; + + unless( defined $anchor ) + { + $anchor = ($w->info('children'))[0] || ''; + + return unless (defined($anchor) and length($anchor)); + + if($w->entrycget($anchor, '-state') ne 'disabled') + { + # That's a good anchor + $done = 1; + } + else + { + # We search for the first non-disabled entry (downward) + $spec = 'next'; + } + } + + my $ent = $anchor; + + # Find the prev/next non-disabled entry + # + while(!$done) + { + $ent = $w->info($spec, $ent); + last unless( defined $ent ); + next if( $w->entrycget($ent, '-state') eq 'disabled' ); + next if( $w->info('hidden', $ent) ); + last; + } + + unless( defined $ent ) + { + $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit'); + return; + } + + $w->anchorSet($ent); + $w->see($ent); + + if($w->cget('-selectmode') ne 'single') + { + $w->selectionClear; + $w->selection('set', $ent); + $w->Callback(-browsecmd =>$ent); + } +} + +sub ShiftUpDown +{ + my $w = shift; + my $spec = shift; + + my $mode = $w->cget('-selectmode'); + + return $w->UpDown($spec) + if($mode eq 'single' || $mode eq 'browse'); + + my $anchor = $w->info('anchor'); + + return $w->UpDown($spec) unless (defined($anchor) and length($anchor)); + + my $done = 0; + + $w->{'shiftanchor'} = $anchor unless( $w->{'shiftanchor'} ); + + my $ent = $w->{'shiftanchor'}; + + while( !$done ) + { + $ent = $w->info($spec, $ent); + last unless( defined $ent ); + next if( $w->entrycget($ent, '-state') eq 'disabled' ); + next if( $w->info('hidden', $ent) ); + last; + } + + unless( $ent ) + { + $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit'); + return; + } + + $w->selectionClear; + $w->selection('set', $anchor, $ent); + $w->see($ent); + + $w->{'shiftanchor'} = $ent; + + $w->Callback(-browsecmd =>$ent); +} + +sub LeftRight +{ + my $w = shift; + my $spec = shift; + + delete $w->{'shiftanchor'}; + + my $anchor = $w->info('anchor'); + + unless(defined $anchor) + { + $anchor = ($w->info('children'))[0] || ''; + } + + my $done = 0; + my $ent = $anchor; + + while(!$done) + { + my $e = $ent; + + if($spec eq 'left') + { + $ent = $w->info('parent', $e); + + $ent = $w->info('prev', $e) + unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled') + } + else + { + $ent = ($w->info('children', $e))[0]; + + $ent = $w->info('next', $e) + unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled') + } + + last unless( defined $ent ); + last if($w->entrycget($ent, '-state') ne 'disabled'); + } + + unless( defined $ent ) + { + $w->xview('scroll', $spec eq 'left' ? -1 : 1, 'unit'); + return; + } + + $w->anchorSet($ent); + $w->see($ent); + + if($w->cget('-selectmode') ne 'single') + { + $w->selectionClear; + $w->selectionSet($ent); + + $w->Callback(-browsecmd =>$ent); + } +} + +sub KeyboardHome +{ + my $w = shift; + $w->yview('moveto' => 0); + $w->xview('moveto' => 0); +} + +sub KeyboardEnd +{ + my $w = shift; + $w->yview('moveto' => 1); + $w->xview('moveto' => 0); +} + +sub KeyboardActivate +{ + my $w = shift; + + my $anchor = $w->info('anchor'); + + return unless (defined($anchor) and length($anchor)); + + if($w->cget('-selectmode')) + { + $w->selectionClear; + $w->selectionSet($anchor); + } + + $w->Callback(-command => $anchor); +} + +sub KeyboardBrowse +{ + my $w = shift; + + my $anchor = $w->info('anchor'); + + return unless (defined($anchor) and length($anchor)); + + if ($w->indicatorExists($anchor)) + { + $w->Callback(-indicatorcmd => $anchor); + } + + if($w->cget('-selectmode')) + { + $w->selectionClear; + $w->selectionSet($anchor); + } + $w->Callback(-browsecmd =>$anchor); +} + +sub AutoScan +{ + my ($w,$x,$y) = @_; + + return if ($w->cget('-selectmode') eq 'dragdrop'); + if (@_ < 3) + { + my $Ev = $w->XEvent; + return unless defined $Ev; + $y = $Ev->y; + $x = $Ev->x; + } + + if($y >= $w->height) + { + $w->yview('scroll', 1, 'units'); + } + elsif($y < 0) + { + $w->yview('scroll', -1, 'units'); + } + elsif($x >= $w->width) + { + $w->xview('scroll', 2, 'units'); + } + elsif($x < 0) + { + $w->xview('scroll', -2, 'units'); + } + else + { + return; + } + $w->RepeatId($w->SUPER::after(50,[ AutoScan => $w, $x, $y ])); + $w->Button1Motion; +} + +sub children +{ + # Tix has core-tk window(s) which are not a widget(s) + # the generic code returns these as an "undef" + my $w = shift; + my @info = grep(defined($_),$w->winfo('children')); + @info; +} + +1; + + diff --git a/Master/tlpkg/tlperl/lib/Tk/IO.pm b/Master/tlpkg/tlperl/lib/Tk/IO.pm new file mode 100644 index 00000000000..771e9f7103a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/IO.pm @@ -0,0 +1,182 @@ +package Tk::IO; +use strict; +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/IO/IO.pm#4 $ + +require 5.002; +use Tk::Event qw($XS_VERSION); + +use Carp; +use base qw(DynaLoader IO::Handle); + +bootstrap Tk::IO; + +my %fh2obj; +my %obj2fh; + +sub new +{ + my ($package,%args) = @_; + # Do whatever IO::Handle does + my $fh = $package->SUPER::new; + %{*$fh} = (); # The hash is used for configure options + ${*$fh} = ''; # The scalar is used as the 'readable' buffer + @{*$fh} = (); # The array + $fh->configure(%args); + return $fh; +} + +sub pending +{ + my $fh = shift; + return ${*$fh}; +} + +sub cget +{ + my ($fh,$key) = @_; + return ${*$fh}{$key}; +} + +sub configure +{ + my ($fh,%args) = @_; + my $key; + foreach $key (keys %args) + { + my $val = $args{$key}; + $val = Tk::Callback->new($val) if ($key =~ /command$/); + ${*$fh}{$key} = $val; + } +} + +sub killpg +{ + my ($fh,$sig) = @_; + my $pid = $fh->pid; + croak 'No child' unless (defined $pid); + kill($sig,-$pid); +} + +sub kill +{ + my ($fh,$sig) = @_; + my $pid = $fh->pid; + croak 'No child' unless (defined $pid); + kill($sig,$pid) || croak "Cannot kill($sig,$pid):$!"; +} + +sub readable +{ + my $fh = shift; + my $count = sysread($fh,${*$fh},1,length(${*$fh})); + if ($count < 0) + { + if (exists ${*$fh}{-errorcommand}) + { + ${*$fh}{-errorcommand}->Call($!); + } + else + { + warn "Cannot read $fh:$!"; + $fh->close; + } + } + elsif ($count) + { + if (exists ${*$fh}{-linecommand}) + { + my $eol = index(${*$fh},"\n"); + if ($eol >= 0) + { + my $line = substr(${*$fh},0,++$eol); + substr(${*$fh},0,$eol) = ''; + ${*$fh}{-linecommand}->Call($line); + } + } + } + else + { + $fh->close; + } +} + +sub pid +{ + my $fh = shift; + return ${*$fh}{-pid}; +} + +sub command +{ + my $fh = shift; + my $cmd = ${*$fh}{'-exec'}; + return (wantarray) ? @$cmd : $cmd; +} + +sub exec +{ + my $fh = shift; + my $pid = open($fh,'-|'); + if ($pid) + { + ${*$fh} = '' unless (defined ${*$fh}); + ${*$fh}{'-exec'} = [@_]; + ${*$fh}{'-pid'} = $pid; + if (exists ${*$fh}{-linecommand}) + { + my $w = ${*$fh}{-widget}; + $w = 'Tk' unless (defined $w); + $w->fileevent($fh,'readable',[$fh,'readable']); + ${*$fh}{_readable} = $w; + } + else + { + croak Tk::Pretty::Pretty(\%{*$fh}); + } + return $pid; + } + else + { + # make STDERR same as STDOUT here + setpgrp; + exec(@_) || die 'Cannot exec ',join(' ',@_),":$!"; + } +} + +sub wait +{ + my $fh = shift; + my $code; + my $ch = delete ${*$fh}{-childcommand}; + ${*$fh}{-childcommand} = Tk::Callback->new(sub { $code = shift }); + Tk::Event::DoOneEvent(0) until (defined $code); + if (defined $ch) + { + ${*$fh}{-childcommand} = $ch; + $ch->Call($code,$fh) + } + return $code; +} + +sub close +{ + my $fh = shift; + my $code; + if (defined fileno($fh)) + { + my $w = delete ${*$fh}{_readable}; + $w->fileevent($fh,'readable','') if (defined $w); + $code = close($fh); + if (exists ${*$fh}{-childcommand}) + { + ${*$fh}{-childcommand}->Call($?,$fh); + } + } + return $code; +} + +1; +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Tk/IconList.pm b/Master/tlpkg/tlperl/lib/Tk/IconList.pm new file mode 100644 index 00000000000..1972809ea2a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/IconList.pm @@ -0,0 +1,712 @@ +# -*- perl -*- +# +# tkfbox.tcl -- +# +# Implements the "TK" standard file selection dialog box. This +# dialog box is used on the Unix platforms whenever the tk_strictMotif +# flag is not set. +# +# The "TK" standard file selection dialog box is similar to the +# file selection dialog box on Win95(TM). The user can navigate +# the directories by clicking on the folder icons or by +# selectinf the "Directory" option menu. The user can select +# files by clicking on the file icons or by entering a filename +# in the "Filename:" entry. +# +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Translated to perk/Tk and modified by Slaven Rezic . +# + +#---------------------------------------------------------------------- +# +# I C O N L I S T +# +# This is a pseudo-widget that implements the icon list inside the +# tkFDialog dialog box. +# +#---------------------------------------------------------------------- +# tkIconList -- +# +# Creates an IconList widget. +# + +package Tk::IconList; +require Tk::Frame; + +use vars qw($VERSION); +$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/IconList.pm#7 $ + +use Tk qw(Ev); +use strict; +use Carp; + +use base 'Tk::Frame'; + +Construct Tk::Widget 'IconList'; + +# tkIconList_Create -- +# +# Creates an IconList widget by assembling a canvas widget and a +# scrollbar widget. Sets all the bindings necessary for the IconList's +# operations. +# +sub Populate { + my($w, $args) = @_; + $w->SUPER::Populate($args); + + my $sbar = $w->Component('Scrollbar' => 'sbar', + -orient => 'horizontal', + -highlightthickness => 0, + -takefocus => 0, + ); + # make sure that the size does not exceed handhelds' dimensions + my($sw,$sh) = ($w->screenwidth, $w->screenheight); + my $canvas = $w->Component('Canvas' => 'canvas', + -bd => 2, + -relief => 'sunken', + -width => ($sw > 420 ? 400 : $sw-20), + -height => ($sh > 160 ? 120 : $sh-40), + -takefocus => 1, + ); + $sbar->pack(-side => 'bottom', -fill => 'x', -padx => 2); + $canvas->pack(-expand => 'yes', -fill => 'both'); + $sbar->configure(-command => ['xview', $canvas]); + $canvas->configure(-xscrollcommand => ['set', $sbar]); + + # Initializes the max icon/text width and height and other variables + $w->{'maxIW'} = 1; + $w->{'maxIH'} = 1; + $w->{'maxTW'} = 1; + $w->{'maxTH'} = 1; + $w->{'numItems'} = 0; +#XXX curItem never used delete $w->{'curItem'}; + $w->{'noScroll'} = 1; + $w->{'selection'} = []; + $w->{'index,anchor'} = ''; + + # Creates the event bindings. + $canvas->Tk::bind('', sub { $w->Arrange } ); + $canvas->Tk::bind('<1>', [$w,'Btn1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('', [$w,'Motion1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('', 'NoOp'); + $canvas->Tk::bind('', 'NoOp'); + $canvas->Tk::bind('', [$w,'CtrlBtn1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('', [$w,'ShiftBtn1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('', [$w,'Double1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('', 'NoOp'); + $canvas->Tk::bind('', 'NoOp'); + $canvas->Tk::bind('', [$w,'CancelRepeat']); + $canvas->Tk::bind('', [$w,'Leave1',Ev('x'),Ev('y')]); + $canvas->Tk::bind('', [$w,'CancelRepeat']); + $canvas->Tk::bind('', [$w,'UpDown', -1]); + $canvas->Tk::bind('', [$w,'UpDown', 1]); + $canvas->Tk::bind('', [$w,'LeftRight',-1]); + $canvas->Tk::bind('', [$w,'LeftRight', 1]); + $canvas->Tk::bind('', [$w,'ReturnKey']); + $canvas->Tk::bind('', [$w,'KeyPress',Ev('A')]); + $canvas->Tk::bind('', 'NoOp'); + $canvas->Tk::bind('', 'NoOp'); + $canvas->Tk::bind('', 'NoOp'); +#XXX bad.... +# $canvas->Tk::bind('', sub { $w->FocusIn }); +# $canvas->Tk::bind('', sub { $w->FocusOut }); + + # additional bindings not in tkfbox.tcl + $canvas->Tk::bind('<2>',['scan','mark',Ev('x'),Ev('y')]); + $canvas->Tk::bind('',['scan','dragto',Ev('x'),Ev('y')]); + # Remove the standard Canvas bindings + $canvas->bindtags([$canvas, $canvas->toplevel, 'all']); + # ... and define some again + $canvas->Tk::bind('', ['xview','moveto',0]); + $canvas->Tk::bind('', ['xview','moveto',1]); + + $w->ConfigSpecs(-browsecmd => + ['METHOD', 'browseCommand', 'BrowseCommand', undef], + -command => + ['CALLBACK', 'command', 'Command', undef], + -font => + ['PASSIVE', 'font', 'Font', undef], + -foreground => + ['PASSIVE', 'foreground', 'Foreground', undef], + -fg => '-foreground', + -multiple => + ['PASSIVE', 'multiple', 'Multiple', 0], + -selectmode => + ['PASSIVE', 'selectMode', 'SelectMode', 'browse'], + -selectbackground => + ['PASSIVE', 'selectBackground', 'Foreground', '#a0a0ff'], + ); + + $w; +} + +# compatibility for old -browsecmd options +sub browsecmd { + my $w = shift; + if (@_) { + $w->{Configure}{'-browsecmd'} = $_[0]; + $w->bind('<>' => $_[0]); + } + $w->{Configure}{'-browsecmd'}; +} + +sub Index { + my($w, $i) = @_; + if (!$w->{'list'}) { $w->{'list'} = [] } + if ($i =~ /^-?[0-9]+$/) { + if ($i < 0) { + $i = 0; + } + if ($i > @{ $w->{'list'} }) { + $i = @{ $w->{'list'} } - 1; + } + return $i; + } elsif ($i eq 'active') { + return $w->{'index,active'}; + } elsif ($i eq 'anchor') { + return $w->{'index,anchor'}; + } elsif ($i eq 'end') { + return @{ $w->{'list'} }; + } elsif ($i =~ /@(-?[0-9]+),(-?[0-9]+)/) { + my($x, $y) = ($1, $2); + my $canvas = $w->Subwidget('canvas'); + my $item = $canvas->find('closest', $x, $y); + if (defined $item) { + return $canvas->itemcget($item, '-tags')->[1]; + } else { + return ""; + } + } else { + croak "Unrecognized Index parameter `$i', use active, anchor, end, \@x,y, or x"; + } +} + +sub Selection { + my($w, $op, @args) = @_; + if ($op eq 'anchor') { + if (@args == 1) { + $w->{'index,anchor'} = $w->Index($args[0]); + } else { + return $w->{'index,anchor'}; + } + } elsif ($op eq 'clear') { + my($first, $last); + if (@args == 2) { + ($first, $last) = @args; + } elsif (@args == 1) { + $first = $last = $args[0]; + } else { + croak "wrong # args: should be Selection('clear', first, ?last?)" + } + $first = $w->Index($first); + $last = $w->Index($last); + if ($first > $last) { + ($first, $last) = ($last, $first); + } + my $ind = 0; + for my $item (@{ $w->{'selection'} }) { + if ($item >= $first) { + $first = $ind; + last; + } + $ind++; # XXX seems to be missing in the Tcl version + } + $ind = @{ $w->{'selection'} } - 1; + for(; $ind >= 0; $ind--) { + my $item = $w->{'selection'}->[$ind]; + if ($item <= $last) { + $last = $ind; + last; + } + } + if ($first > $last) { + return; + } + splice @{ $w->{'selection'} }, $first, $last-$first+1; + $w->event('generate', '<>'); + $w->DrawSelection; + } elsif ($op eq 'includes') { + my $index; + for (@{ $w->{'selection'} }) { + if ($args[0] eq $_) { + return 1; + } + } + return 0; + } elsif ($op eq 'set') { + my($first, $last); + if (@args == 2) { + ($first, $last) = @args; + } elsif (@args == 1) { + $first = $last = $args[0]; + } else { + croak "wrong # args: should be Selection('set', first, ?last?)"; + } + + $first = $w->Index($first); + $last = $w->Index($last); + if ($first > $last) { + ($first, $last) = ($last, $first); + } + for(my $i = $first; $i <= $last; $i++) { + push @{ $w->{'selection'} }, $i; + } + # lsort -integer -unique + my %sel = map { ($_ => 1) } @{ $w->{'selection'} }; + @{ $w->{'selection'} } = sort { $a <=> $b } keys %sel; + $w->event('generate', '<>'); + $w->DrawSelection; + } else { + croak "Unrecognized Selection parameter `$op', use anchor, clear, includes, or set"; + } +} + +# XXX why lower case 's' here and upper in DrawSelection? +sub Curselection { + my $w = shift; + @{ $w->{'selection'} }; +} + +sub DrawSelection { + my $w = shift; + my $canvas = $w->Subwidget('canvas'); + $canvas->delete('selection'); + my $selBg = $w->cget('-selectbackground'); + for my $item (@{ $w->{'selection'} }) { + my $rTag = $w->{'list'}->[$item][2]; + my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} }; + my @bbox = $canvas->bbox($tTag); + # XXX don't hardcode colors + $canvas->createRectangle + (@bbox, -fill => $selBg, -outline => $selBg, -tags => 'selection'); + } + $canvas->lower('selection'); +} + +# Returns the selected item +# +sub Get { + my($w, $item) = @_; + my $rTag = $w->{'list'}->[$item][2]; + my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} }; + $text; +} + + +# tkIconList_AutoScan -- +# +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window up, down, left, or +# right, depending on where the mouse left the window, and reschedules +# itself as an "after" command so that the window continues to scroll until +# the mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The IconList window. +# +sub AutoScan { + my $w = shift; + return unless ($w->exists); + return if ($w->{'noScroll'}); + my($x, $y); + $x = $Tk::x; + $y = $Tk::y; + my $canvas = $w->Subwidget('canvas'); + if ($x >= $canvas->width) { + $canvas->xview('scroll', 1, 'units'); + } elsif ($x < 0) { + $canvas->xview('scroll', -1, 'units'); + } elsif ($y >= $canvas->height) { + # do nothing + } elsif ($y < 0) { + # do nothing + } else { + return; + } + $w->Motion1($x, $y); + $w->RepeatId($w->after(50, ['AutoScan', $w])); +} + +# Deletes all the items inside the canvas subwidget and reset the IconList's +# state. +# +sub DeleteAll { + my $w = shift; + my $canvas = $w->Subwidget('canvas'); + $canvas->delete('all'); + delete $w->{'selected'}; + delete $w->{'rect'}; + delete $w->{'list'}; + delete $w->{'itemList'}; + $w->{'maxIW'} = 1; + $w->{'maxIH'} = 1; + $w->{'maxTW'} = 1; + $w->{'maxTH'} = 1; + $w->{'numItems'} = 0; +#XXX curItem never used delete $w->{'curItem'}; + $w->{'noScroll'} = 1; + $w->{'selection'} = []; + $w->{'index,anchor'} = ''; + $w->Subwidget('sbar')->set(0.0, 1.0); + $canvas->xview('moveto', 0); +} + +# Adds an icon into the IconList with the designated image and items +# +sub Add { + my($w, $image, @items) = @_; + my $canvas = $w->Subwidget('canvas'); + my $font = $w->cget(-font); + my $fg = $w->cget(-foreground); + foreach my $text (@items) { + my $iTag = $canvas->createImage + (0, 0, -image => $image, -anchor => 'nw', + -tags => ['icon', $w->{numItems}, 'item'.$w->{numItems}], + ); + my $tTag = $canvas->createText + (0, 0, -text => $text, -anchor => 'nw', + (defined $fg ? (-fill => $fg) : ()), + (defined $font ? (-font => $font) : ()), + -tags => ['text', $w->{numItems}, 'item'.$w->{numItems}], + ); + my $rTag = $canvas->createRectangle + (0, 0, 0, 0, + -fill => undef, + -outline => undef, + -tags => ['rect', $w->{numItems}, 'item'.$w->{numItems}], + ); + my(@b) = $canvas->bbox($iTag); + my $iW = $b[2] - $b[0]; + my $iH = $b[3] - $b[1]; + $w->{'maxIW'} = $iW if ($w->{'maxIW'} < $iW); + $w->{'maxIH'} = $iH if ($w->{'maxIH'} < $iH); + @b = $canvas->bbox($tTag); + my $tW = $b[2] - $b[0]; + my $tH = $b[3] - $b[1]; + $w->{'maxTW'} = $tW if ($w->{'maxTW'} < $tW); + $w->{'maxTH'} = $tH if ($w->{'maxTH'} < $tH); + push @{ $w->{'list'} }, [$iTag, $tTag, $rTag, $iW, $iH, $tW, $tH, + $w->{'numItems'}]; + $w->{'itemList'}{$rTag} = [$iTag, $tTag, $text, $w->{'numItems'}]; + $w->{'textList'}{$w->{'numItems'}} = lc($text); + ++$w->{'numItems'}; + } +} + +# Places the icons in a column-major arrangement. +# +sub Arrange { + my $w = shift; + my $canvas = $w->Subwidget('canvas'); + my $sbar = $w->Subwidget('sbar'); + unless (exists $w->{'list'}) { + if (defined $canvas && Tk::Exists($canvas)) { + $w->{'noScroll'} = 1; + $sbar->configure(-command => sub { }); + } + return; + } + + my $W = $canvas->width; + my $H = $canvas->height; + my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd); + $pad = 2 if ($pad < 2); + $W -= $pad*2; + $H -= $pad*2; + my $dx = $w->{'maxIW'} + $w->{'maxTW'} + 8; + my $dy; + if ($w->{'maxTH'} > $w->{'maxIH'}) { + $dy = $w->{'maxTH'}; + } else { + $dy = $w->{'maxIH'}; + } + $dy += 2; + my $shift = $w->{'maxIW'} + 4; + my $x = $pad * 2; + my $y = $pad; + my $usedColumn = 0; + foreach my $sublist (@{ $w->{'list'} }) { + $usedColumn = 1; + my($iTag, $tTag, $rTag, $iW, $iH, $tW, $tH) = @$sublist; + my $i_dy = ($dy - $iH) / 2; + my $t_dy = ($dy - $tH) / 2; + $canvas->coords($iTag, $x, $y + $i_dy); + $canvas->coords($tTag, $x + $shift, $y + $t_dy); + $canvas->coords($rTag, $x, $y, $x + $dx, $y + $dy); + $y += $dy; + if ($y + $dy > $H) { + $y = $pad; + $x += $dx; + $usedColumn = 0; + } + } + my $sW; + if ($usedColumn) { + $sW = $x + $dx; + } else { + $sW = $x; + } + if ($sW < $W) { + $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]); + $sbar->configure(-command => sub { }); + $canvas->xview(moveto => 0); + $w->{'noScroll'} = 1; + } else { + $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]); + $sbar->configure(-command => ['xview', $canvas]); + $w->{'noScroll'} = 0; + } + $w->{'itemsPerColumn'} = int(($H - $pad) / $dy); + $w->{'itemsPerColumn'} = 1 if ($w->{'itemsPerColumn'} < 1); +#XXX $w->Select($w->{'list'}[$w->{'curItem'}][2], 0) +# if (exists $w->{'curItem'}); + $w->DrawSelection; # missing in Tcl XXX +} + +# Gets called when the user invokes the IconList (usually by double-clicking +# or pressing the Return key). +# +sub Invoke { + my $w = shift; + $w->Callback(-command => $w->{'selected'}) if (@{ $w->{'selection'} }); +} + +# tkIconList_See -- +# +# If the item is not (completely) visible, scroll the canvas so that +# it becomes visible. +sub See { + my($w, $rTag) = @_; + return if ($w->{'noScroll'}); + return if ($rTag < 0 || $rTag >= @{ $w->{'list'} }); + my $canvas = $w->Subwidget('canvas'); + my(@sRegion) = @{ $canvas->cget('-scrollregion') }; + return unless (@sRegion); + my(@bbox) = $canvas->bbox('item'.$rTag); + my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd); + my $x1 = $bbox[0]; + my $x2 = $bbox[2]; + $x1 -= $pad * 2; + $x2 -= $pad; + my $cW = $canvas->width - $pad * 2; + my $scrollW = $sRegion[2] - $sRegion[0] + 1; + my $dispX = int(($canvas->xview)[0] * $scrollW); + my $oldDispX = $dispX; + # check if out of the right edge + $dispX = $x2 - $cW if ($x2 - $dispX >= $cW); + # check if out of the left edge + $dispX = $x1 if ($x1 - $dispX < 0); + if ($oldDispX != $dispX) { + my $fraction = $dispX / $scrollW; + $canvas->xview('moveto', $fraction); + } +} + +sub Btn1 { + my($w, $x, $y) = @_; + + my $canvas = $w->Subwidget('canvas'); + $canvas->CanvasFocus; + $x = int($canvas->canvasx($x)); + $y = int($canvas->canvasy($y)); + my $i = $w->Index('@'.$x.','.$y); + return if ($i eq ''); + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $i); + $w->Selection('anchor', $i); +} + +sub CtrlBtn1 { + my($w, $x, $y) = @_; + + if ($w->cget(-multiple)) { + my $canvas = $w->Subwidget('canvas'); + $canvas->CanvasFocus; + my $x = int($canvas->canvasx($x)); + my $y = int($canvas->canvasy($y)); + my $i = $w->Index('@'.$x.','.$y); + return if ($i eq ''); + if ($w->Selection('includes', $i)) { + $w->Selection('clear', $i); + } else { + $w->Selection('set', $i); + $w->Selection('anchor', $i); + } + } +} + +sub ShiftBtn1 { + my($w, $x, $y) = @_; + + if ($w->cget(-multiple)) { + my $canvas = $w->Subwidget('canvas'); + $canvas->CanvasFocus; + my $x = int($canvas->canvasx($x)); + my $y = int($canvas->canvasy($y)); + my $i = $w->Index('@'.$x.','.$y); + return if ($i eq ''); + my $a = $w->Index('anchor'); + if ($a eq '') { + $a = $i; + } + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $a, $i); + } +} + +# Gets called on button-1 motions +# +sub Motion1 { + my($w, $x, $y) = @_; + $Tk::x = $x; + $Tk::y = $y; + my $canvas = $w->Subwidget('canvas'); + $canvas->CanvasFocus; + $x = int($canvas->canvasx($x)); + $y = int($canvas->canvasy($y)); + my $i = $w->Index('@'.$x.','.$y); + return if ($i eq ''); + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $i); +} + +sub Double1 { + my($w, $x, $y) = @_; + $w->Invoke if (@{ $w->{'selection'} }); +} + +sub ReturnKey { + my $w = shift; + $w->Invoke; +} + +sub Leave1 { + my($w, $x, $y) = @_; + $Tk::x = $x; + $Tk::y = $y; + $w->AutoScan; +} + +sub FocusIn { + my $w = shift; + return unless (exists $w->{'list'}); + if (@{ $w->{'selection'} }) { + $w->DrawSelection; + } +} + +sub FocusOut { + my $w = shift; + $w->Selection('clear', 0, 'end'); +} + +# tkIconList_UpDown -- +# +# Moves the active element up or down by one element +# +# Arguments: +# w - The IconList widget. +# amount - +1 to move down one item, -1 to move back one item. +# +sub UpDown { + my($w, $amount) = @_; + return unless (exists $w->{'list'}); + my $i; + my(@curr) = $w->Curselection; + if (!@curr) { + $i = 0; + } else { + $i = $w->Index('anchor'); + return if ($i eq ''); + $i += $amount; + } + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $i); + $w->Selection('anchor', $i); + $w->See($i); +} + +# tkIconList_LeftRight -- +# +# Moves the active element left or right by one column +# +# Arguments: +# w - The IconList widget. +# amount - +1 to move right one column, -1 to move left one column. +# +sub LeftRight { + my($w, $amount) = @_; + return unless (exists $w->{'list'}); + my $i; + my(@curr) = $w->Curselection; + if (!@curr) { + $i = 0; + } else { + $i = $w->Index('anchor'); + return if ($i eq ''); + $i += $amount*$w->{'itemsPerColumn'}; + } + $w->Selection('clear', 0, 'end'); + $w->Selection('set', $i); + $w->Selection('anchor', $i); + $w->See($i); +} + +#---------------------------------------------------------------------- +# Accelerator key bindings +#---------------------------------------------------------------------- +# tkIconList_KeyPress -- +# +# Gets called when user enters an arbitrary key in the listbox. +# +sub KeyPress { + my($w, $key) = @_; + $w->{'_ILAccel'} .= $key; + $w->Goto($w->{'_ILAccel'}); + eval { + $w->afterCancel($w->{'_ILAccel_afterid'}); + }; + $w->{'_ILAccel_afterid'} = $w->after(500, ['Reset', $w]); +} + +sub Goto { + my($w, $text) = @_; + return unless (exists $w->{'list'}); + return if (not defined $text or $text eq ''); +#XXX curItem never used my $start = (!exists $w->{'curItem'} ? 0 : $w->{'curItem'}); + my $start = 0; + $text = lc($text); + my $theIndex = -1; + my $less = 0; + my $len = length($text); + my $i = $start; + # Search forward until we find a filename whose prefix is an exact match + # with $text + while (1) { + my $sub = substr($w->{'textList'}{$i}, 0, $len); + if ($text eq $sub) { + $theIndex = $i; + last; + } + ++$i; + $i = 0 if ($i == $w->{'numItems'}); + last if ($i == $start); + } + if ($theIndex > -1) { + $w->Selection(qw(clear 0 end)); + $w->Selection('set', $theIndex); + $w->Selection('anchor', $theIndex); + $w->See($theIndex); + } +} + +sub Reset { + my $w = shift; + undef $w->{'_ILAccel'}; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Image.pm b/Master/tlpkg/tlperl/lib/Tk/Image.pm new file mode 100644 index 00000000000..0f41c387fc2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Image.pm @@ -0,0 +1,74 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Image; + +# This module does for images what Tk::Widget does for widgets: +# provides a base class for them to inherit from. +require DynaLoader; + +use base qw(DynaLoader Tk); # but are they ? + +use vars qw($VERSION); +$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $ + +sub new +{ + my $package = shift; + my $widget = shift; + $package->InitClass($widget); + my $leaf = $package->Tk_image; + my $obj = $widget->Tk::image('create',$leaf,@_); + $obj = $widget->_object($obj) unless (ref $obj); + return bless $obj,$package; +} + +sub Install +{ + # Dynamically loaded image types can install standard images here + my ($class,$mw) = @_; +} + +sub ClassInit +{ + # Carry out class bindings (or whatever) + my ($package,$mw) = @_; + return $package; +} + +require Tk::Submethods; + +Direct Tk::Submethods ('image' => [qw(delete width height type)]); + +sub Tk::Widget::imageNames +{ + my $w = shift; + $w->image('names',@_); +} + +sub Tk::Widget::imageTypes +{ + my $w = shift; + map("\u$_",$w->image('types',@_)); +} + +sub Construct +{ + my ($base,$name) = @_; + my $class = (caller(0))[0]; + + # Hack for broken ->isa in perl5.6.0 + delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; + + *{"Tk::Widget::$name"} = sub { $class->new(@_) }; +} + +# This is here to prevent AUTOLOAD trying to find it. +sub DESTROY +{ + my $i = shift; + # maybe do image delete ??? +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm b/Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm new file mode 100644 index 00000000000..85c6c11a76c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm @@ -0,0 +1,38 @@ +package Tk::ItemStyle; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/ItemStyle.pm#4 $ + +require Tk; +use base qw(Tk); +require Tk::Widget; +Construct Tk::Widget 'ItemStyle'; + +Tk::Methods ('delete'); + +sub new +{ + my $package = shift; + my $widget = shift; + my $type = shift; + my %args = @_; + $args{'-refwindow'} = $widget unless exists $args{'-refwindow'}; + $package->InitClass($widget); + my $obj = $widget->itemstyle($type, %args); + return bless $obj,$package; +} + +sub Install +{ + # Dynamically loaded image types can install standard images here + my ($class,$mw) = @_; +} + +sub ClassInit +{ + # Carry out class bindings (or whatever) + my ($package,$mw) = @_; + return $package; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/JPEG.pm b/Master/tlpkg/tlperl/lib/Tk/JPEG.pm new file mode 100644 index 00000000000..9e0ef771f77 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/JPEG.pm @@ -0,0 +1,50 @@ +package Tk::JPEG; +require DynaLoader; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #2$ =~ /\D(\d+)\s*$/; +use Tk 800.015; +require Tk::Image; +require Tk::Photo; +require DynaLoader; + +use vars qw($VERSION $XS_VERSION); + +@ISA = qw(DynaLoader); + +$XS_VERSION = $Tk::VERSION; +bootstrap Tk::JPEG; + +1; + +__END__ + +=head1 NAME + +Tk::JPEG - JPEG loader for Tk::Photo + +=head1 SYNOPSIS + + use Tk; + use Tk::JPEG; + + my $image = $widget->Photo('-format' => 'jpeg', -file => 'something.jpg'); + + +=head1 DESCRIPTION + +This is an extension for Tk800.015 and later which supplies +JPEG format loader for Photo image type. + +This version also works with Tk804 series. + +JPEG access is via release 5 of the The Independent JPEG Group's (IJG) +free JPEG software. + +=head1 AUTHOR + +Nick Ing-Simmons Enick@ing-simmons.netE + +=cut + + diff --git a/Master/tlpkg/tlperl/lib/Tk/LabEntry.pm b/Master/tlpkg/tlperl/lib/Tk/LabEntry.pm new file mode 100644 index 00000000000..64cb392fa8c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/LabEntry.pm @@ -0,0 +1,31 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Tk::LabEntry; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/LabEntry.pm#6 $ + +use base qw(Tk::Frame); +use Tk::widgets qw(Frame Label Entry); + +Construct Tk::Widget 'LabEntry'; + +sub Populate +{ + require Tk::Entry; + # LabeledEntry constructor. + # + my($cw, $args) = @_; + $cw->SUPER::Populate($args); + # Advertised subwidgets: entry. + my $e = $cw->Entry(); + $e->pack('-expand' => 1, '-fill' => 'both'); + $cw->Advertise('entry' => $e ); + $cw->ConfigSpecs(DEFAULT => [$e]); + $cw->Delegates(DEFAULT => $e); + $cw->AddScrollbars($e) if (exists $args->{-scrollbars}); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/LabFrame.pm b/Master/tlpkg/tlperl/lib/Tk/LabFrame.pm new file mode 100644 index 00000000000..6fcab1acc56 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/LabFrame.pm @@ -0,0 +1,138 @@ +# +# Labeled frame. Derives from Tk::Frame, but intercepts the labeling +# part. + +package Tk::LabFrame; + +use vars qw($VERSION); +$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tixish/LabFrame.pm#11 $ + +use Tk; +use base qw(Tk::Frame); +Tk::Widget->Construct('LabFrame'); + +sub autoLabel { 0 } + +sub Populate { + my ($cw, $args) = @_; + + $cw->{m_geoMgr} = ""; + + my $border = $cw->Component( + Frame => 'border', + -relief => 'groove', + -bd => 2, + ); + + my $pad = $border->Frame; + $cw->Advertise(pad => $pad); + + my $frame = $border->Frame; + $cw->Advertise(frame => $frame); + + my $label = $cw->Component(Label => 'label'); + + $cw->SUPER::Populate($args); + + $cw->Delegates(DEFAULT => $frame); + $cw->ConfigSpecs( + -background => [[qw/SELF ADVERTISED/], + qw/background Background/], + -borderwidth => [$border, qw/borderWidth Border 2/], + -font => [$label, qw/font Font/], + -foreground => [$label, qw/foreground Foreground black/], + -label => [{-text => $label}, qw/label Label/], + -labelside => [qw/METHOD labelSide LabelSide acrosstop/], + -labelvariable => [{-textvariable => $label}], + -relief => [$border, qw/relief Relief groove/], + DEFAULT => [$frame] + ); + return $cw; +} + +use Tk::Submethods( + form => [qw/check forget grid info slaves/], + grid => [qw/bbox columnconfigure configure forget info location + propagate rowconfigure remove size slaves/], + pack => [qw/forget info propagate slaves/], + place => [qw/forget info slaves/] +); + +sub labelside { + my ($cw, $side) = @_; + return $cw->{Configure}{-labelside} unless $side; + + my $border = $cw->Subwidget('border'); + my $pad = $cw->Subwidget('pad'); + my $frame = $cw->Subwidget('frame'); + my $label = $cw->Subwidget('label'); + + ## packForget/formForget as appropriate + foreach ($border, $label, $pad, $frame) { + $_->formForget if $cw->{m_geoMgr} eq "form"; + $_->packForget if ($cw->{m_geoMgr} eq "pack" && $_->ismapped); + } + + if ($side eq "acrosstop") { + + my $y = $label->reqheight / 2; + my $ph = $y - ($border->cget(-bd)); + $ph = 0 if $ph < 0; + + $label->form(qw/-top 0 -left 4 -padx 6 -pady 2/); + $border->form(-top => $y, + qw/-bottom -1 -left 0 -right -1 -padx 2 -pady 2/); + $pad->form(-bottom => $ph, + qw/-top 0 -left 0 -right -1/); + $frame->form(-top => $pad, + qw/-bottom -1 -left 0 -right -1 -fill both/); + $cw->{m_geoMgr} = "form"; + + } else { + + $label->pack(-side => $side); + $frame->pack(-expand => 1, -fill => 'both'); + $border->pack(-side => $side, -expand => 1, -fill => 'both'); + $cw->{m_geoMgr} = "pack"; + } +} + +sub form { + my $cw = shift; + $cw = $cw->Subwidget('frame') + if (@_ && $_[0] =~ /^(?:slaves)$/); + $cw->SUPER::form(@_); +} + +sub grid { + my $cw = shift; + $cw = $cw->Subwidget('frame') if (@_ && $_[0] =~ + /^(?:bbox + |columnconfigure + |location + |propagate + |rowconfigure + |size + |slaves) + $/x); + $cw->SUPER::grid(@_); +} + + +sub pack { + my $cw = shift; + $cw = $cw->Subwidget('frame') + if (@_ && $_[0] =~ /^(?:propagate|slaves)$/); + $cw->SUPER::pack(@_); +} + +sub place { + my $cw = shift; + $cw = $cw->Subwidget('frame') + if (@_ && $_[0] =~ /^(?:slaves)$/); + $cw->SUPER::place(@_); +} + +1; + + diff --git a/Master/tlpkg/tlperl/lib/Tk/LabRadio.pm b/Master/tlpkg/tlperl/lib/Tk/LabRadio.pm new file mode 100644 index 00000000000..69e07b12f01 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/LabRadio.pm @@ -0,0 +1,63 @@ +# Class LabeledRadiobutton + +package Tk::LabRadiobutton; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/LabRadio.pm#4 $ + +require Tk::Frame; +use base qw(Tk::Frame); + +Construct Tk::Widget 'LabRadiobutton'; + + +# Although there is no fundamental reason why -radiobuttons +# should be fixed at create time converting to METHOD form +# is extra work an this can serve as an example of CreateArgs +# checking. + +sub CreateArgs +{ + my ($package,$parent,$args) = @_; + $parent->BackTrace("Must specify -radiobuttons for $package") + unless (defined $args->{'-radiobuttons'}); + return $package->SUPER::CreateArgs($parent,$args); +} + +sub Populate +{ + require Tk::Radiobutton; + + my ($cw,$args) = @_; + $cw->SUPER::Populate($args); + + # LabeledRadiobutton(s) constructor. + # + # Advertised subwidgets: the name(s) of your radiobutton(s). + + + + my (@widgets) = (); + + my $rl; + foreach $rl (@{$args->{'-radiobuttons'}}) + { + my $r = $cw->Component( Radiobutton => $rl, + -text => $rl, + -value => $rl ); + $r->pack(-side => 'left', -expand => 1, -fill => 'both'); + push(@widgets,$r); + $cw->{Configure}{-value} = $rl; + } + + $cw->BackTrace('No buttons') unless (@widgets); + + $cw->ConfigSpecs('-variable' => [ \@widgets, undef, undef, \$cw->{Configure}{-value} ], + '-radiobuttons' => [ 'PASSIVE', undef, undef, undef ], + '-value' => [ 'PASSIVE', undef, undef, $cw->{Configure}{-value} ], + 'DEFAULT' => [ \@widgets ] + ); +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/Label.pm b/Master/tlpkg/tlperl/lib/Tk/Label.pm new file mode 100644 index 00000000000..ebea1741c2f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Label.pm @@ -0,0 +1,21 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Tk::Label; +require Tk; + + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Label.pm#6 $ + +use base qw(Tk::Widget); + +Construct Tk::Widget 'Label'; + +sub Tk_cmd { \&Tk::label } + +1; + + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Labelframe.pm b/Master/tlpkg/tlperl/lib/Tk/Labelframe.pm new file mode 100644 index 00000000000..14c577b5e35 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Labelframe.pm @@ -0,0 +1,16 @@ +package Tk::Labelframe; +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #2 $ =~ /#(\d+)/; + +# New widget which is a kind of Frame with a label ... + +use base qw(Tk::Frame); + +Construct Tk::Widget 'Labelframe'; + +sub Tk_cmd { \&Tk::labelframe } + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/Listbox.pm b/Master/tlpkg/tlperl/lib/Tk/Listbox.pm new file mode 100644 index 00000000000..249a8eed7f4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Listbox.pm @@ -0,0 +1,910 @@ +# Converted from listbox.tcl -- +# +# This file defines the default bindings for Tk listbox widgets. +# +# @(#) listbox.tcl 1.7 94/12/17 16:05:18 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# Modifications from standard Listbox.pm +# -------------------------------------- +# 27-JAN-2001 Alasdair Allan +# Modified for local use by adding tied scalar and arrays +# Implemented TIESCALAR, TIEARRAY, FETCH, FETCHSIZE, STORE, CLEAR & EXTEND +# 31-JAN-2001 Alasdair Allan +# Made changes suggested by Tim Jenness +# 03-FEB-2001 Alasdair Allan +# Modified STORE for tied scalars to clear and select elements +# 06-FEB-2001 Alasdair Allan +# Added POD documentation for tied listbox +# 13-FEB-2001 Alasdair Allan +# Implemented EXISTS, DELETE, PUSH, POP, SHIFT & UNSHIFT for tied arrays +# 14-FEB-2001 Alasdair Allan +# Implemented SPLICE for tied arrays, all tied functionality in place +# 16-FEB-2001 Alasdair Allan +# Tweak to STORE interface for tied scalars +# 23-FEB-2001 Alasdair Allan +# Added flag to FETCH for tied scalars, modified to return hashes +# 24-FEB-2001 Alasdair Allan +# Updated Pod documentation +# + +package Tk::Listbox; + +use vars qw($VERSION @Selection $Prev); +use strict; +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev $XS_VERSION); +use Tk::Clipboard (); +use AutoLoader; + +use base qw(Tk::Clipboard Tk::Widget); + +Construct Tk::Widget 'Listbox'; + +bootstrap Tk::Listbox; + +sub Tk_cmd { \&Tk::listbox } + +Tk::Methods('activate','bbox','curselection','delete','get','index', + 'insert','itemcget','itemconfigure','nearest','scan','see', + 'selection','size','xview','yview'); + +use Tk::Submethods ( 'selection' => [qw(anchor clear includes set)], + 'scan' => [qw(mark dragto)], + 'xview' => [qw(moveto scroll)], + 'yview' => [qw(moveto scroll)], + ); + +*Getselected = \&getSelected; + +sub clipEvents +{ + return qw[Copy]; +} + +sub BalloonInfo +{ + my ($listbox,$balloon,$X,$Y,@opt) = @_; + my $e = $listbox->XEvent; + return if !$e; + my $index = $listbox->index('@' . $e->x . ',' . $e->y); + foreach my $opt (@opt) + { + my $info = $balloon->GetOption($opt,$listbox); + if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY')) + { + $balloon->Subclient($index); + if (defined $info->[$index]) + { + return $info->[$index]; + } + return ''; + } + return $info; + } +} + +sub ClassInit +{ + my ($class,$mw) = @_; + $class->SUPER::ClassInit($mw); + # Standard Motif bindings: + $mw->bind($class,'<1>',[sub { + my $w = shift; + if (Tk::Exists($w)) { + $w->BeginSelect(@_); + } + }, Ev('index',Ev('@'))]); + $mw->bind($class, '' => \&Tk::NoOp); + $mw->bind($class,'',['Motion',Ev('index',Ev('@'))]); + $mw->bind($class,'','ButtonRelease_1'); + ; + $mw->bind($class,'',['BeginExtend',Ev('index',Ev('@'))]); + $mw->bind($class,'',['BeginToggle',Ev('index',Ev('@'))]); + + $mw->bind($class,'',['AutoScan',Ev('x'),Ev('y')]); + $mw->bind($class,'','CancelRepeat'); + $mw->bind($class,'',['UpDown',-1]); + $mw->bind($class,'',['ExtendUpDown',-1]); + $mw->bind($class,'',['UpDown',1]); + $mw->bind($class,'',['ExtendUpDown',1]); + + $mw->XscrollBind($class); + $mw->bind($class,'', sub { + my $w = shift; + $w->yview('scroll',-1,'pages'); + $w->activate('@0,0'); + }); + $mw->bind($class,'', sub { + my $w = shift; + $w->yview('scroll',1,'pages'); + $w->activate('@0,0'); + }); + $mw->bind($class,'', ['xview', 'scroll', -1, 'pages']); + $mw->bind($class,'', ['xview', 'scroll', 1, 'pages']); + # and defined in XscrollBind + $mw->bind($class,'','Cntrl_Home'); + ; + $mw->bind($class,'',['DataExtend',0]); + $mw->bind($class,'','Cntrl_End'); + ; + $mw->bind($class,'',['DataExtend','end']); + # XXX What about <>? Already handled in Tk::Clipboard? + # $class->clipboardOperations($mw,'Copy'); + $mw->bind($class,'',['BeginSelect',Ev('index','active')]); + $mw->bind($class,'',['markSet','anchor','insert']); + $mw->bind($class,'',['SelectTo','insert','char']); + $mw->bind($class,'',['SelectTo','insert','char']); + $mw->bind($class,'','selectAll'); + $mw->bind($class,'','unselectAll'); + + if (!$Tk::strictMotif) + { + $mw->bind($class,'', ['SetCursor','insert linestart']); + $mw->bind($class,'', ['SetCursor','insert-1c']); + $mw->bind($class,'', ['SetCursor','insert lineend']); + $mw->bind($class,'', ['SetCursor','insert+1c']); + $mw->bind($class,'', ['SetCursor','insert-1c wordstart']); + $mw->bind($class,'', ['SetCursor','insert wordend']); + $mw->bind($class,'', ['SetCursor','1.0']); + $mw->bind($class,'', ['SetCursor','end-1c']); + + $mw->bind($class,'', ['SetCursor',Ev('UpDownLine',1)]); + $mw->bind($class,'', ['SetCursor',Ev('UpDownLine',-1)]); + + $mw->bind($class,'<2>',['Button2',Ev('x'),Ev('y')]); + $mw->bind($class,'',['Motion2',Ev('x'),Ev('y')]); + } + $mw->bind($class,'','Destroy'); + $mw->bind($class, '<3>', ['PostPopupMenu', Ev('X'), Ev('Y')] ); + $mw->YMouseWheelBind($class); + $mw->XMouseWheelBind($class); + + $mw->MouseWheelBind($class); + + return $class; +} + +sub selectAll +{ + my ($w) = @_; + $w->tagAdd('sel','1.0','end'); +} + +sub unselectAll +{ + my ($w) = @_; + $w->tagRemove('sel','1.0','end'); +} + +sub adjustSelect +{ + my ($w) = @_; + my $Ev = $w->XEvent; + $w->ResetAnchor($Ev->xy); + $w->SelectTo($Ev->xy,'char') +} + +sub selectLine +{ + my ($w) = @_; + my $Ev = $w->XEvent; + $w->SelectTo($Ev->xy,'line'); + Tk::catch { $w->markSet('insert','sel.first') }; +} + +sub selectWord +{ + my ($w) = @_; + my $Ev = $w->XEvent; + $w->SelectTo($Ev->xy,'word'); + Tk::catch { $w->markSet('insert','sel.first') } +} + +sub ClassInit +{ + my ($class,$mw) = @_; + $class->SUPER::ClassInit($mw); + + $class->bindRdOnly($mw); + + $mw->bind($class,'', 'insertTab'); + $mw->bind($class,'', ['Insert',"\t"]); + $mw->bind($class,'', ['Insert',"\n"]); + $mw->bind($class,'','Delete'); + $mw->bind($class,'','Backspace'); + $mw->bind($class,'', \&ToggleInsertMode ) ; + $mw->bind($class,'',['InsertKeypress',Ev('A')]); + + $mw->bind($class,'', 'clipboardColumnCopy'); + $mw->bind($class,'', 'clipboardColumnCut'); + $mw->bind($class,'', 'clipboardColumnPaste'); + + # Additional emacs-like bindings: + + if (!$Tk::strictMotif) + { + $mw->bind($class,'',['delete','insert']); + $mw->bind($class,'','deleteToEndofLine') ; + $mw->bind($class,'','openLine'); + $mw->bind($class,'','Transpose'); + $mw->bind($class,'',['delete','insert','insert wordend']); + $mw->bind($class,'',['delete','insert-1c wordstart','insert']); + + # A few additional bindings of my own. + $mw->bind($class,'','deleteBefore'); + $mw->bind($class,'','ButtonRelease2'); + } +#JD# $Tk::prevPos = undef; + return $class; +} + +sub insertTab +{ + my ($w) = @_; + $w->Insert("\t"); + $w->focus; + $w->break +} + +sub deleteToEndofLine +{ + my ($w) = @_; + if ($w->compare('insert','==','insert lineend')) + { + $w->delete('insert') + } + else + { + $w->delete('insert','insert lineend') + } +} + +sub openLine +{ + my ($w) = @_; + $w->insert('insert',"\n"); + $w->markSet('insert','insert-1c') +} + +sub Button2 +{ + my ($w,$x,$y) = @_; + $w->scan('mark',$x,$y); + $Tk::x = $x; + $Tk::y = $y; + $Tk::mouseMoved = 0; +} + +sub Motion2 +{ + my ($w,$x,$y) = @_; + $Tk::mouseMoved = 1 if ($x != $Tk::x || $y != $Tk::y); + $w->scan('dragto',$x,$y) if ($Tk::mouseMoved); +} + +sub ButtonRelease2 +{ + my ($w) = @_; + my $Ev = $w->XEvent; + if (!$Tk::mouseMoved) + { + Tk::catch { $w->insert($Ev->xy,$w->SelectionGet) } + } +} + +sub InsertSelection +{ + my ($w) = @_; + Tk::catch { $w->Insert($w->SelectionGet) } +} + +sub Backspace +{ + my ($w) = @_; + my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') }; + if (defined $sel) + { + $w->delete('sel.first','sel.last'); + return; + } + $w->deleteBefore; +} + +sub deleteBefore +{ + my ($w) = @_; + if ($w->compare('insert','!=','1.0')) + { + $w->delete('insert-1c'); + $w->see('insert') + } +} + +sub Delete +{ + my ($w) = @_; + my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') }; + if (defined $sel) + { + $w->delete('sel.first','sel.last') + } + else + { + $w->delete('insert'); + $w->see('insert') + } +} + +# Button1 -- +# This procedure is invoked to handle button-1 presses in text +# widgets. It moves the insertion cursor, sets the selection anchor, +# and claims the input focus. +# +# Arguments: +# w - The text window in which the button was pressed. +# x - The x-coordinate of the button press. +# y - The x-coordinate of the button press. +sub Button1 +{ + my ($w,$x,$y) = @_; + $Tk::selectMode = 'char'; + $Tk::mouseMoved = 0; + $w->SetCursor('@'.$x.','.$y); + $w->markSet('anchor','insert'); + $w->focus() if ($w->cget('-state') eq 'normal'); +} + +sub B1_Motion +{ + my ($w) = @_; + return unless defined $Tk::mouseMoved; + my $Ev = $w->XEvent; + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $w->SelectTo($Ev->xy) +} + +sub B1_Leave +{ + my ($w) = @_; + my $Ev = $w->XEvent; + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $w->AutoScan; +} + +# SelectTo -- +# This procedure is invoked to extend the selection, typically when +# dragging it with the mouse. Depending on the selection mode (character, +# word, line) it selects in different-sized units. This procedure +# ignores mouse motions initially until the mouse has moved from +# one character to another or until there have been multiple clicks. +# +# Arguments: +# w - The text window in which the button was pressed. +# index - Index of character at which the mouse button was pressed. +sub SelectTo +{ + my ($w, $index, $mode)= @_; + $Tk::selectMode = $mode if defined ($mode); + my $cur = $w->index($index); + my $anchor = Tk::catch { $w->index('anchor') }; + if (!defined $anchor) + { + $w->markSet('anchor',$anchor = $cur); + $Tk::mouseMoved = 0; + } + elsif ($w->compare($cur,'!=',$anchor)) + { + $Tk::mouseMoved = 1; + } + $Tk::selectMode = 'char' unless (defined $Tk::selectMode); + $mode = $Tk::selectMode; + my ($first,$last); + if ($mode eq 'char') + { + if ($w->compare($cur,'<','anchor')) + { + $first = $cur; + $last = 'anchor'; + } + else + { + $first = 'anchor'; + $last = $cur + } + } + elsif ($mode eq 'word') + { + if ($w->compare($cur,'<','anchor')) + { + $first = $w->index("$cur wordstart"); + $last = $w->index('anchor - 1c wordend') + } + else + { + $first = $w->index('anchor wordstart'); + $last = $w->index("$cur wordend") + } + } + elsif ($mode eq 'line') + { + if ($w->compare($cur,'<','anchor')) + { + $first = $w->index("$cur linestart"); + $last = $w->index('anchor - 1c lineend + 1c') + } + else + { + $first = $w->index('anchor linestart'); + $last = $w->index("$cur lineend + 1c") + } + } + if ($Tk::mouseMoved || $Tk::selectMode ne 'char') + { + $w->tagRemove('sel','1.0',$first); + $w->tagAdd('sel',$first,$last); + $w->tagRemove('sel',$last,'end'); + $w->idletasks; + } +} +# AutoScan -- +# This procedure is invoked when the mouse leaves a text window +# with button 1 down. It scrolls the window up, down, left, or right, +# depending on where the mouse is (this information was saved in +# tkPriv(x) and tkPriv(y)), and reschedules itself as an 'after' +# command so that the window continues to scroll until the mouse +# moves back into the window or the mouse button is released. +# +# Arguments: +# w - The text window. +sub AutoScan +{ + my ($w) = @_; + if ($Tk::y >= $w->height) + { + $w->yview('scroll',2,'units') + } + elsif ($Tk::y < 0) + { + $w->yview('scroll',-2,'units') + } + elsif ($Tk::x >= $w->width) + { + $w->xview('scroll',2,'units') + } + elsif ($Tk::x < 0) + { + $w->xview('scroll',-2,'units') + } + else + { + return; + } + $w->SelectTo('@' . $Tk::x . ','. $Tk::y); + $w->RepeatId($w->after(50,['AutoScan',$w])); +} +# SetCursor +# Move the insertion cursor to a given position in a text. Also +# clears the selection, if there is one in the text, and makes sure +# that the insertion cursor is visible. +# +# Arguments: +# w - The text window. +# pos - The desired new position for the cursor in the window. +sub SetCursor +{ + my ($w,$pos) = @_; + $pos = 'end - 1 chars' if $w->compare($pos,'==','end'); + $w->markSet('insert',$pos); + $w->unselectAll; + $w->see('insert'); +} +# KeySelect +# This procedure is invoked when stroking out selections using the +# keyboard. It moves the cursor to a new position, then extends +# the selection to that position. +# +# Arguments: +# w - The text window. +# new - A new position for the insertion cursor (the cursor has not +# actually been moved to this position yet). +sub KeySelect +{ + my ($w,$new) = @_; + my ($first,$last); + if (!defined $w->tag('ranges','sel')) + { + # No selection yet + $w->markSet('anchor','insert'); + if ($w->compare($new,'<','insert')) + { + $w->tagAdd('sel',$new,'insert') + } + else + { + $w->tagAdd('sel','insert',$new) + } + } + else + { + # Selection exists + if ($w->compare($new,'<','anchor')) + { + $first = $new; + $last = 'anchor' + } + else + { + $first = 'anchor'; + $last = $new + } + $w->tagRemove('sel','1.0',$first); + $w->tagAdd('sel',$first,$last); + $w->tagRemove('sel',$last,'end') + } + $w->markSet('insert',$new); + $w->see('insert'); + $w->idletasks; +} +# ResetAnchor -- +# Set the selection anchor to whichever end is farthest from the +# index argument. One special trick: if the selection has two or +# fewer characters, just leave the anchor where it is. In this +# case it does not matter which point gets chosen for the anchor, +# and for the things like Shift-Left and Shift-Right this produces +# better behavior when the cursor moves back and forth across the +# anchor. +# +# Arguments: +# w - The text widget. +# index - Position at which mouse button was pressed, which determines +# which end of selection should be used as anchor point. +sub ResetAnchor +{ + my ($w,$index) = @_; + if (!defined $w->tag('ranges','sel')) + { + $w->markSet('anchor',$index); + return; + } + my $a = $w->index($index); + my $b = $w->index('sel.first'); + my $c = $w->index('sel.last'); + if ($w->compare($a,'<',$b)) + { + $w->markSet('anchor','sel.last'); + return; + } + if ($w->compare($a,'>',$c)) + { + $w->markSet('anchor','sel.first'); + return; + } + my ($lineA,$chA) = split(/\./,$a); + my ($lineB,$chB) = split(/\./,$b); + my ($lineC,$chC) = split(/\./,$c); + if ($lineB < $lineC+2) + { + my $total = length($w->get($b,$c)); + if ($total <= 2) + { + return; + } + if (length($w->get($b,$a)) < $total/2) + { + $w->markSet('anchor','sel.last') + } + else + { + $w->markSet('anchor','sel.first') + } + return; + } + if ($lineA-$lineB < $lineC-$lineA) + { + $w->markSet('anchor','sel.last') + } + else + { + $w->markSet('anchor','sel.first') + } +} + +######################################################################## +sub markExists +{ + my ($w, $markname)=@_; + my $mark_exists=0; + my @markNames_list = $w->markNames; + foreach my $mark (@markNames_list) + { if ($markname eq $mark) {$mark_exists=1;last;} } + return $mark_exists; +} + +######################################################################## +sub OverstrikeMode +{ + my ($w,$mode) = @_; + + $w->{'OVERSTRIKE_MODE'} =0 unless exists($w->{'OVERSTRIKE_MODE'}); + + $w->{'OVERSTRIKE_MODE'}=$mode if (@_ > 1); + + return $w->{'OVERSTRIKE_MODE'}; +} + +######################################################################## +# pressed the key, just above 'Del' key. +# this toggles between insert mode and overstrike mode. +sub ToggleInsertMode +{ + my ($w)=@_; + $w->OverstrikeMode(!$w->OverstrikeMode); +} + +######################################################################## +sub InsertKeypress +{ + my ($w,$char)=@_; + return unless length($char); + if ($w->OverstrikeMode) + { + my $current=$w->get('insert'); + $w->delete('insert') unless($current eq "\n"); + } + $w->Insert($char); +} + +######################################################################## +sub GotoLineNumber +{ + my ($w,$line_number) = @_; + $line_number=~ s/^\s+|\s+$//g; + return if $line_number =~ m/\D/; + my ($last_line,$junk) = split(/\./, $w->index('end')); + if ($line_number > $last_line) {$line_number = $last_line; } + $w->{'LAST_GOTO_LINE'} = $line_number; + $w->markSet('insert', $line_number.'.0'); + $w->see('insert'); +} + +######################################################################## +sub GotoLineNumberPopUp +{ + my ($w)=@_; + my $popup = $w->{'GOTO_LINE_NUMBER_POPUP'}; + + unless (defined($w->{'LAST_GOTO_LINE'})) + { + my ($line,$col) = split(/\./, $w->index('insert')); + $w->{'LAST_GOTO_LINE'} = $line; + } + + ## if anything is selected when bring up the pop-up, put it in entry window. + my $selected; + eval { $selected = $w->SelectionGet(-selection => "PRIMARY"); }; + unless ($@) + { + if (defined($selected) and length($selected)) + { + unless ($selected =~ /\D/) + { + $w->{'LAST_GOTO_LINE'} = $selected; + } + } + } + unless (defined($popup)) + { + require Tk::DialogBox; + $popup = $w->DialogBox(-buttons => [qw[Ok Cancel]],-title => "Goto Line Number", -popover => $w, + -command => sub { $w->GotoLineNumber($w->{'LAST_GOTO_LINE'}) if $_[0] eq 'Ok'}); + $w->{'GOTO_LINE_NUMBER_POPUP'}=$popup; + $popup->resizable('no','no'); + my $frame = $popup->Frame->pack(-fill => 'x'); + $frame->Label(-text=>'Enter line number: ')->pack(-side => 'left'); + my $entry = $frame->Entry(-background=>'white', -width=>25, + -textvariable => \$w->{'LAST_GOTO_LINE'})->pack(-side =>'left',-fill => 'x'); + $popup->Advertise(entry => $entry); + } + $popup->Popup; + $popup->Subwidget('entry')->focus; + $popup->Wait; +} + +######################################################################## + +sub getSelected +{ + shift->GetTextTaggedWith('sel'); +} + +sub deleteSelected +{ + shift->DeleteTextTaggedWith('sel'); +} + +sub GetTextTaggedWith +{ + my ($w,$tag) = @_; + + my @ranges = $w->tagRanges($tag); + my $range_total = @ranges; + my $return_text=''; + + # if nothing selected, then ignore + if ($range_total == 0) {return $return_text;} + + # for every range-pair, get selected text + while(@ranges) + { + my $first = shift(@ranges); + my $last = shift(@ranges); + my $text = $w->get($first , $last); + if(defined($text)) + {$return_text = $return_text . $text;} + # if there is more tagged text, separate with an end of line character + if(@ranges) + {$return_text = $return_text . "\n";} + } + return $return_text; +} + +######################################################################## +sub DeleteTextTaggedWith +{ + my ($w,$tag) = @_; + my @ranges = $w->tagRanges($tag); + my $range_total = @ranges; + + # if nothing tagged with that tag, then ignore + if ($range_total == 0) {return;} + + # insert marks where selections are located + # marks will move with text even as text is inserted and deleted + # in a previous selection. + for (my $i=0; $i<$range_total; $i++) + { $w->markSet('mark_tag_'.$i => $ranges[$i]); } + + # for every selected mark pair, insert new text and delete old text + for (my $i=0; $i<$range_total; $i=$i+2) + { + my $first = $w->index('mark_tag_'.$i); + my $last = $w->index('mark_tag_'.($i+1)); + + my $text = $w->delete($first , $last); + } + + # delete the marks + for (my $i=0; $i<$range_total; $i++) + { $w->markUnset('mark_tag_'.$i); } +} + + +######################################################################## +sub FindAll +{ + my ($w,$mode, $case, $pattern ) = @_; + ### 'sel' tags accumulate, need to remove any previous existing + $w->unselectAll; + + my $match_length=0; + my $start_index; + my $end_index = '1.0'; + + while(defined($end_index)) + { + if ($case eq '-nocase') + { + $start_index = $w->search( + $mode, + $case, + -count => \$match_length, + "--", + $pattern , + $end_index, + 'end'); + } + else + { + $start_index = $w->search( + $mode, + -count => \$match_length, + "--", + $pattern , + $end_index, + 'end'); + } + + unless(defined($start_index) && $start_index) {last;} + + my ($line,$col) = split(/\./, $start_index); + $col = $col + $match_length; + $end_index = $line.'.'.$col; + $w->tagAdd('sel', $start_index, $end_index); + } +} + +######################################################################## +# get current selected text and search for the next occurrence +sub FindSelectionNext +{ + my ($w) = @_; + my $selected; + eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); }; + return if($@); + return unless (defined($selected) and length($selected)); + + $w->FindNext('-forward', '-exact', '-case', $selected); +} + +######################################################################## +# get current selected text and search for the previous occurrence +sub FindSelectionPrevious +{ + my ($w) = @_; + my $selected; + eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); }; + return if($@); + return unless (defined($selected) and length($selected)); + + $w->FindNext('-backward', '-exact', '-case', $selected); +} + + + +######################################################################## +sub FindNext +{ + my ($w,$direction, $mode, $case, $pattern ) = @_; + + ## if searching forward, start search at end of selected block + ## if backward, start search from start of selected block. + ## dont want search to find currently selected text. + ## tag 'sel' may not be defined, use eval loop to trap error + eval { + if ($direction eq '-forward') + { + $w->markSet('insert', 'sel.last'); + $w->markSet('current', 'sel.last'); + } + else + { + $w->markSet('insert', 'sel.first'); + $w->markSet('current', 'sel.first'); + } + }; + + my $saved_index=$w->index('insert'); + + # remove any previous existing tags + $w->unselectAll; + + my $match_length=0; + my $start_index; + + if ($case eq '-nocase') + { + $start_index = $w->search( + $direction, + $mode, + $case, + -count => \$match_length, + "--", + $pattern , + 'insert'); + } + else + { + $start_index = $w->search( + $direction, + $mode, + -count => \$match_length, + "--", + $pattern , + 'insert'); + } + + unless(defined($start_index)) { return 0; } + if(length($start_index) == 0) { return 0; } + + my ($line,$col) = split(/\./, $start_index); + $col = $col + $match_length; + my $end_index = $line.'.'.$col; + $w->tagAdd('sel', $start_index, $end_index); + + $w->see($start_index); + + if ($direction eq '-forward') + { + $w->markSet('insert', $end_index); + $w->markSet('current', $end_index); + } + else + { + $w->markSet('insert', $start_index); + $w->markSet('current', $start_index); + } + + my $compared_index = $w->index('insert'); + + my $ret_val; + if ($compared_index eq $saved_index) + {$ret_val=0;} + else + {$ret_val=1;} + return $ret_val; +} + +######################################################################## +sub FindAndReplaceAll +{ + my ($w,$mode, $case, $find, $replace ) = @_; + $w->markSet('insert', '1.0'); + $w->unselectAll; + while($w->FindNext('-forward', $mode, $case, $find)) + { + $w->ReplaceSelectionsWith($replace); + } +} + +######################################################################## +sub ReplaceSelectionsWith +{ + my ($w,$new_text ) = @_; + + my @ranges = $w->tagRanges('sel'); + my $range_total = @ranges; + + # if nothing selected, then ignore + if ($range_total == 0) {return}; + + # insert marks where selections are located + # marks will move with text even as text is inserted and deleted + # in a previous selection. + for (my $i=0; $i<$range_total; $i++) + {$w->markSet('mark_sel_'.$i => $ranges[$i]); } + + # for every selected mark pair, insert new text and delete old text + my ($first, $last); + for (my $i=0; $i<$range_total; $i=$i+2) + { + $first = $w->index('mark_sel_'.$i); + $last = $w->index('mark_sel_'.($i+1)); + + ########################################################################## + # eventually, want to be able to get selected text, + # support regular expression matching, determine replace_text + # $replace_text = $selected_text=~m/$new_text/ (or whatever would work) + # will have to pass in mode and case flags. + # this would allow a regular expression search and replace to be performed + # example, look for "line (\d+):" and replace with "$1 >" or similar + ########################################################################## + + $w->insert($last, $new_text); + $w->delete($first, $last); + + } + ############################################################ + # set the insert cursor to the end of the last insertion mark + $w->markSet('insert',$w->index('mark_sel_'.($range_total-1))); + + # delete the marks + for (my $i=0; $i<$range_total; $i++) + { $w->markUnset('mark_sel_'.$i); } +} +######################################################################## +sub FindAndReplacePopUp +{ + my ($w)=@_; + $w->findandreplacepopup(0); +} + +######################################################################## +sub FindPopUp +{ + my ($w)=@_; + $w->findandreplacepopup(1); +} + +######################################################################## + +sub findandreplacepopup +{ + my ($w,$find_only)=@_; + + my $pop = $w->Toplevel; + $pop->transient($w->toplevel); + if ($find_only) + { $pop->title("Find"); } + else + { $pop->title("Find and/or Replace"); } + my $frame = $pop->Frame->pack(-anchor=>'nw'); + + $frame->Label(-text=>"Direction:") + ->grid(-row=> 1, -column=>1, -padx=> 20, -sticky => 'nw'); + my $direction = '-forward'; + $frame->Radiobutton( + -variable => \$direction, + -text => 'forward',-value => '-forward' ) + ->grid(-row=> 2, -column=>1, -padx=> 20, -sticky => 'nw'); + $frame->Radiobutton( + -variable => \$direction, + -text => 'backward',-value => '-backward' ) + ->grid(-row=> 3, -column=>1, -padx=> 20, -sticky => 'nw'); + + $frame->Label(-text=>"Mode:") + ->grid(-row=> 1, -column=>2, -padx=> 20, -sticky => 'nw'); + my $mode = '-exact'; + $frame->Radiobutton( + -variable => \$mode, -text => 'exact',-value => '-exact' ) + ->grid(-row=> 2, -column=>2, -padx=> 20, -sticky => 'nw'); + $frame->Radiobutton( + -variable => \$mode, -text => 'regexp',-value => '-regexp' ) + ->grid(-row=> 3, -column=>2, -padx=> 20, -sticky => 'nw'); + + $frame->Label(-text=>"Case:") + ->grid(-row=> 1, -column=>3, -padx=> 20, -sticky => 'nw'); + my $case = '-case'; + $frame->Radiobutton( + -variable => \$case, -text => 'case',-value => '-case' ) + ->grid(-row=> 2, -column=>3, -padx=> 20, -sticky => 'nw'); + $frame->Radiobutton( + -variable => \$case, -text => 'nocase',-value => '-nocase' ) + ->grid(-row=> 3, -column=>3, -padx=> 20, -sticky => 'nw'); + + ###################################################### + my $find_entry = $pop->Entry(-width=>25); + $find_entry->focus; + + my $donext = sub {$w->FindNext ($direction,$mode,$case,$find_entry->get())}; + + $find_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); # autosizing + + ###### if any $w text is selected, put it in the find entry + ###### could be more than one text block selected, get first selection + my @ranges = $w->tagRanges('sel'); + if (@ranges) + { + my $first = shift(@ranges); + my $last = shift(@ranges); + + # limit to one line + my ($first_line, $first_col) = split(/\./,$first); + my ($last_line, $last_col) = split(/\./,$last); + unless($first_line == $last_line) + {$last = $first. ' lineend';} + + $find_entry->insert('insert', $w->get($first , $last)); + } + else + { + my $selected; + eval {$selected=$w->SelectionGet(-selection => "PRIMARY"); }; + if($@) {} + elsif (defined($selected)) + {$find_entry->insert('insert', $selected);} + } + + $find_entry->icursor(0); + + my ($replace_entry,$button_replace,$button_replace_all); + unless ($find_only) + { + $replace_entry = $pop->Entry(-width=>25); + + $replace_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); + } + + + my $button_find = $pop->Button(-text=>'Find', -command => $donext, -default => 'active') + -> pack(-side => 'left'); + + my $button_find_all = $pop->Button(-text=>'Find All', + -command => sub {$w->FindAll($mode,$case,$find_entry->get());} ) + ->pack(-side => 'left'); + + unless ($find_only) + { + $button_replace = $pop->Button(-text=>'Replace', -default => 'normal', + -command => sub {$w->ReplaceSelectionsWith($replace_entry->get());} ) + -> pack(-side =>'left'); + $button_replace_all = $pop->Button(-text=>'Replace All', + -command => sub {$w->FindAndReplaceAll + ($mode,$case,$find_entry->get(),$replace_entry->get());} ) + ->pack(-side => 'left'); + } + + + my $button_cancel = $pop->Button(-text=>'Cancel', + -command => sub {$pop->destroy()} ) + ->pack(-side => 'left'); + + $find_entry->bind("" => [$button_find, 'invoke']); + $find_entry->bind("" => [$button_cancel, 'invoke']); + + $find_entry->bind("" => [$button_find, 'invoke']); + $find_entry->bind("" => [$button_cancel, 'invoke']); + + $pop->resizable('yes','no'); + return $pop; +} + +# paste clipboard into current location +sub clipboardPaste +{ + my ($w) = @_; + local $@; + Tk::catch { $w->Insert($w->clipboardGet) }; +} + +######################################################################## +# Insert -- +# Insert a string into a text at the point of the insertion cursor. +# If there is a selection in the text, and it covers the point of the +# insertion cursor, then delete the selection before inserting. +# +# Arguments: +# w - The text window in which to insert the string +# string - The string to insert (usually just a single character) +sub Insert +{ + my ($w,$string) = @_; + return unless (defined $string && $string ne ''); + #figure out if cursor is inside a selection + my @ranges = $w->tagRanges('sel'); + if (@ranges) + { + while (@ranges) + { + my ($first,$last) = splice(@ranges,0,2); + if ($w->compare($first,'<=','insert') && $w->compare($last,'>=','insert')) + { + $w->ReplaceSelectionsWith($string); + return; + } + } + } + # paste it at the current cursor location + $w->insert('insert',$string); + $w->see('insert'); +} + +# UpDownLine -- +# Returns the index of the character one *display* line above or below the +# insertion cursor. There are two tricky things here. First, +# we want to maintain the original column across repeated operations, +# even though some lines that will get passed through do not have +# enough characters to cover the original column. Second, do not +# try to scroll past the beginning or end of the text. +# +# This may have some weirdness associated with a proportional font. Ie. +# the insertion cursor will zigzag up or down according to the width of +# the character at destination. +# +# Arguments: +# w - The text window in which the cursor is to move. +# n - The number of lines to move: -1 for up one line, +# +1 for down one line. +sub UpDownLine +{ +my ($w,$n) = @_; +$w->see('insert'); +my $i = $w->index('insert'); + +my ($line,$char) = split(/\./,$i); + +my $testX; #used to check the "new" position +my $testY; #used to check the "new" position + +(my $bx, my $by, my $bw, my $bh) = $w->bbox($i); +(my $lx, my $ly, my $lw, my $lh) = $w->dlineinfo($i); + +if ( ($n == -1) and ($by <= $bh) ) + { + #On first display line.. so scroll up and recalculate.. + $w->yview('scroll', -1, 'units'); + unless (($w->yview)[0]) { + #first line of entire text - keep same position. + return $i; + } + ($bx, $by, $bw, $bh) = $w->bbox($i); + ($lx, $ly, $lw, $lh) = $w->dlineinfo($i); + } +elsif ( ($n == 1) and + ($ly + $lh) > ( $w->height - 2*$w->cget(-bd) - 2*$w->cget(-highlightthickness) ) ) + { + #On last display line.. so scroll down and recalculate.. + $w->yview('scroll', 1, 'units'); + ($bx, $by, $bw, $bh) = $w->bbox($i); + ($lx, $ly, $lw, $lh) = $w->dlineinfo($i); + } + +# Calculate the vertical position of the next display line +my $Yoffset = 0; +$Yoffset = $by - $ly + 1 if ($n== -1); +$Yoffset = $ly + $lh + 1 - $by if ($n == 1); +$Yoffset*=$n; +$testY = $by + $Yoffset; + +# Save the original 'x' position of the insert cursor if: +# 1. This is the first time through -- or -- +# 2. The insert cursor position has changed from the previous +# time the up or down key was pressed -- or -- +# 3. The cursor has reached the beginning or end of the widget. + +if (not defined $w->{'origx'} or ($w->{'lastindex'} != $i) ) + { + $w->{'origx'} = $bx; + } + +# Try to keep the same column if possible +$testX = $w->{'origx'}; + +# Get the coordinates of the possible new position +my $testindex = $w->index('@'.$testX.','.$testY ); +$w->see($testindex); +my ($nx,$ny,$nw,$nh) = $w->bbox($testindex); + +# Which side of the character should we position the cursor - +# mainly for a proportional font +if ($testX > $nx+$nw/2) + { + $testX = $nx+$nw+1; + } + +my $newindex = $w->index('@'.$testX.','.$testY ); + +if ( $w->compare($newindex,'==','end - 1 char') and ($ny == $ly ) ) + { + # Then we are trying to the 'end' of the text from + # the same display line - don't do that + return $i; + } + +$w->{'lastindex'} = $newindex; +$w->see($newindex); +return $newindex; +} + +# PrevPara -- +# Returns the index of the beginning of the paragraph just before a given +# position in the text (the beginning of a paragraph is the first non-blank +# character after a blank line). +# +# Arguments: +# w - The text window in which the cursor is to move. +# pos - Position at which to start search. +sub PrevPara +{ + my ($w,$pos) = @_; + $pos = $w->index("$pos linestart"); + while (1) + { + if ($w->get("$pos - 1 line") eq "\n" && $w->get($pos) ne "\n" || $pos eq '1.0' ) + { + my $string = $w->get($pos,"$pos lineend"); + if ($string =~ /^(\s)+/) + { + my $off = length($1); + $pos = $w->index("$pos + $off chars") + } + if ($w->compare($pos,'!=','insert') || $pos eq '1.0') + { + return $pos; + } + } + $pos = $w->index("$pos - 1 line") + } +} +# NextPara -- +# Returns the index of the beginning of the paragraph just after a given +# position in the text (the beginning of a paragraph is the first non-blank +# character after a blank line). +# +# Arguments: +# w - The text window in which the cursor is to move. +# start - Position at which to start search. +sub NextPara +{ + my ($w,$start) = @_; + my $pos = $w->index("$start linestart + 1 line"); + while ($w->get($pos) ne "\n") + { + if ($w->compare($pos,'==','end')) + { + return $w->index('end - 1c'); + } + $pos = $w->index("$pos + 1 line") + } + while ($w->get($pos) eq "\n" ) + { + $pos = $w->index("$pos + 1 line"); + if ($w->compare($pos,'==','end')) + { + return $w->index('end - 1c'); + } + } + my $string = $w->get($pos,"$pos lineend"); + if ($string =~ /^(\s+)/) + { + my $off = length($1); + return $w->index("$pos + $off chars"); + } + return $pos; +} +# ScrollPages -- +# This is a utility procedure used in bindings for moving up and down +# pages and possibly extending the selection along the way. It scrolls +# the view in the widget by the number of pages, and it returns the +# index of the character that is at the same position in the new view +# as the insertion cursor used to be in the old view. +# +# Arguments: +# w - The text window in which the cursor is to move. +# count - Number of pages forward to scroll; may be negative +# to scroll backwards. +sub ScrollPages +{ + my ($w,$count) = @_; + my @bbox = $w->bbox('insert'); + $w->yview('scroll',$count,'pages'); + if (!@bbox) + { + return $w->index('@' . int($w->height/2) . ',' . 0); + } + my $x = int($bbox[0]+$bbox[2]/2); + my $y = int($bbox[1]+$bbox[3]/2); + return $w->index('@' . $x . ',' . $y); +} + +sub Contents +{ + my $w = shift; + if (@_) + { + $w->delete('1.0','end'); + $w->insert('end',shift) while (@_); + } + else + { + return $w->get('1.0','end'); + } +} + +sub Destroy +{ + my ($w) = @_; + delete $w->{_Tags_}; +} + +sub Transpose +{ + my ($w) = @_; + my $pos = 'insert'; + $pos = $w->index("$pos + 1 char") if ($w->compare($pos,'!=',"$pos lineend")); + return if ($w->compare("$pos - 1 char",'==','1.0')); + my $new = $w->get("$pos - 1 char").$w->get("$pos - 2 char"); + $w->delete("$pos - 2 char",$pos); + $w->insert('insert',$new); + $w->see('insert'); +} + +sub Tag +{ + my $w = shift; + my $name = shift; + Carp::confess('No args') unless (ref $w and defined $name); + $w->{_Tags_} = {} unless (exists $w->{_Tags_}); + unless (exists $w->{_Tags_}{$name}) + { + require Tk::Text::Tag; + $w->{_Tags_}{$name} = 'Tk::Text::Tag'->new($w,$name); + } + $w->{_Tags_}{$name}->configure(@_) if (@_); + return $w->{_Tags_}{$name}; +} + +sub Tags +{ + my ($w,$name) = @_; + my @result = (); + foreach $name ($w->tagNames(@_)) + { + push(@result,$w->Tag($name)); + } + return @result; +} + +sub TIEHANDLE +{ + my ($class,$obj) = @_; + return $obj; +} + +sub PRINT +{ + my $w = shift; + # Find out whether 'end' is displayed at the moment + # Retrieve the position of the bottom of the window as + # a fraction of the entire contents of the Text widget + my $yview = ($w->yview)[1]; + + # If $yview is 1.0 this means that 'end' is visible in the window + my $update = 0; + $update = 1 if $yview == 1.0; + + # Loop over all input strings + while (@_) + { + $w->insert('end',shift); + } + # Move the window to see the end of the text if required + $w->see('end') if $update; +} + +sub PRINTF +{ + my $w = shift; + $w->PRINT(sprintf(shift,@_)); +} + +sub WhatLineNumberPopUp +{ + my ($w)=@_; + my ($line,$col) = split(/\./,$w->index('insert')); + $w->messageBox(-type => 'Ok', -title => "What Line Number", + -message => "The cursor is on line $line (column is $col)"); +} + +sub MenuLabels +{ + return qw[~File ~Edit ~Search ~View]; +} + +sub SearchMenuItems +{ + my ($w) = @_; + return [ + ['command'=>'~Find', -command => [$w => 'FindPopUp']], + ['command'=>'Find ~Next', -command => [$w => 'FindSelectionNext']], + ['command'=>'Find ~Previous', -command => [$w => 'FindSelectionPrevious']], + ['command'=>'~Replace', -command => [$w => 'FindAndReplacePopUp']] + ]; +} + +sub EditMenuItems +{ + my ($w) = @_; + my @items = (); + foreach my $op ($w->clipEvents) + { + push(@items,['command' => "~$op", -command => [ $w => "clipboard$op"]]); + } + push(@items, + '-', + ['command'=>'Select All', -command => [$w => 'selectAll']], + ['command'=>'Unselect All', -command => [$w => 'unselectAll']], + ); + return \@items; +} + +sub ViewMenuItems +{ + my ($w) = @_; + my $v; + tie $v,'Tk::Configure',$w,'-wrap'; + return [ + ['command'=>'Goto ~Line...', -command => [$w => 'GotoLineNumberPopUp']], + ['command'=>'~Which Line?', -command => [$w => 'WhatLineNumberPopUp']], + ['cascade'=> 'Wrap', -tearoff => 0, -menuitems => [ + [radiobutton => 'Word', -variable => \$v, -value => 'word'], + [radiobutton => 'Character', -variable => \$v, -value => 'char'], + [radiobutton => 'None', -variable => \$v, -value => 'none'], + ]], + ]; +} + +######################################################################## +sub clipboardColumnCopy +{ + my ($w) = @_; + $w->Column_Copy_or_Cut(0); +} + +sub clipboardColumnCut +{ + my ($w) = @_; + $w->Column_Copy_or_Cut(1); +} + +######################################################################## +sub Column_Copy_or_Cut +{ + my ($w, $cut) = @_; + my @ranges = $w->tagRanges('sel'); + my $range_total = @ranges; + # this only makes sense if there is one selected block + unless ($range_total==2) + { + $w->bell; + return; + } + + my $selection_start_index = shift(@ranges); + my $selection_end_index = shift(@ranges); + + my ($start_line, $start_column) = split(/\./, $selection_start_index); + my ($end_line, $end_column) = split(/\./, $selection_end_index); + + # correct indices for tabs + my $string; + $string = $w->get($start_line.'.0', $start_line.'.0 lineend'); + $string = substr($string, 0, $start_column); + $string = expand($string); + my $tab_start_column = length($string); + + $string = $w->get($end_line.'.0', $end_line.'.0 lineend'); + $string = substr($string, 0, $end_column); + $string = expand($string); + my $tab_end_column = length($string); + + my $length = $tab_end_column - $tab_start_column; + + $selection_start_index = $start_line . '.' . $tab_start_column; + $selection_end_index = $end_line . '.' . $tab_end_column; + + # clear the clipboard + $w->clipboardClear; + my ($clipstring, $startstring, $endstring); + my $padded_string = ' 'x$tab_end_column; + for(my $line = $start_line; $line <= $end_line; $line++) + { + $string = $w->get($line.'.0', $line.'.0 lineend'); + $string = expand($string) . $padded_string; + $clipstring = substr($string, $tab_start_column, $length); + #$clipstring = unexpand($clipstring); + $w->clipboardAppend($clipstring."\n"); + + if ($cut) + { + $startstring = substr($string, 0, $tab_start_column); + $startstring = unexpand($startstring); + $start_column = length($startstring); + + $endstring = substr($string, 0, $tab_end_column ); + $endstring = unexpand($endstring); + $end_column = length($endstring); + + $w->delete($line.'.'.$start_column, $line.'.'.$end_column); + } + } +} + +######################################################################## + +sub clipboardColumnPaste +{ + my ($w) = @_; + my @ranges = $w->tagRanges('sel'); + my $range_total = @ranges; + if ($range_total) + { + warn " there cannot be any selections during clipboardColumnPaste. \n"; + $w->bell; + return; + } + + my $clipboard_text; + eval + { + $clipboard_text = $w->SelectionGet(-selection => "CLIPBOARD"); + }; + + return unless (defined($clipboard_text)); + return unless (length($clipboard_text)); + my $string; + + my $current_index = $w->index('insert'); + my ($current_line, $current_column) = split(/\./,$current_index); + $string = $w->get($current_line.'.0', $current_line.'.'.$current_column); + $string = expand($string); + $current_column = length($string); + + my @clipboard_lines = split(/\n/,$clipboard_text); + my $length; + my $end_index; + my ($delete_start_column, $delete_end_column, $insert_column_index); + foreach my $line (@clipboard_lines) + { + if ($w->OverstrikeMode) + { + #figure out start and end indexes to delete, compensating for tabs. + $string = $w->get($current_line.'.0', $current_line.'.0 lineend'); + $string = expand($string); + $string = substr($string, 0, $current_column); + $string = unexpand($string); + $delete_start_column = length($string); + + $string = $w->get($current_line.'.0', $current_line.'.0 lineend'); + $string = expand($string); + $string = substr($string, 0, $current_column + length($line)); + chomp($string); # dont delete a "\n" on end of line. + $string = unexpand($string); + $delete_end_column = length($string); + + + + $w->delete( + $current_line.'.'.$delete_start_column , + $current_line.'.'.$delete_end_column + ); + } + + $string = $w->get($current_line.'.0', $current_line.'.0 lineend'); + $string = expand($string); + $string = substr($string, 0, $current_column); + $string = unexpand($string); + $insert_column_index = length($string); + + $w->insert($current_line.'.'.$insert_column_index, unexpand($line)); + $current_line++; + } + +} + +# Backward compatibility +sub GetMenu +{ + carp((caller(0))[3]." is deprecated") if $^W; + shift->menu +} + +1; +__END__ + + diff --git a/Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm b/Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm new file mode 100644 index 00000000000..827278eb88c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm @@ -0,0 +1,46 @@ +package Tk::Text::Tag; +require Tk::Text; + +use overload '""' => \&name; + + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Text/Text/Tag.pm#4 $ + +sub _apply +{ + my $self = shift; + my $meth = shift; + $self->widget->tag($meth => $self->name,@_); +} + +sub name +{ + return shift->[0]; +} + +sub widget +{ + return shift->[1]; +} + +BEGIN +{ + my $meth; + foreach $meth (qw(cget configure bind add)) + { + *{$meth} = sub { shift->_apply($meth,@_) } + } +} + +sub new +{ + my $class = shift; + my $widget = shift; + my $name = shift; + my $obj = bless [$name,$widget],$class; + $obj->configure(@_) if (@_); + return $obj; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm b/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm new file mode 100644 index 00000000000..e1ff20b6149 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm @@ -0,0 +1,509 @@ +# Copyright (c) 1999 Greg Bartels. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +# Special thanks to Nick Ing-Simmons for pushing a lot of +# my text edit functionality into Text.pm and TextUndo.pm +# otherwise, this module would have been monstrous. + +# Andy Worhal had it wrong, its "fifteen megabytes of fame" +# -Greg Bartels + +package Tk::TextEdit; + + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/TextEdit.pm#4 $ + +use Tk qw (Ev); +use AutoLoader; + +use Text::Tabs; + +use base qw(Tk::TextUndo); + +Construct Tk::Widget 'TextEdit'; + +####################################################################### +####################################################################### +sub ClassInit +{ + my ($class,$mw) = @_; + $class->SUPER::ClassInit($mw); + + $mw->bind($class,'', 'IndentSelectedLines'); + $mw->bind($class,'', 'UnindentSelectedLines'); + + $mw->bind($class,'', 'CommentSelectedLines'); + $mw->bind($class,'', 'UncommentSelectedLines'); + + return $class; +} + +# 8 horizontal pixels in the "space" character in default font. +my $tab_multiplier = 8; + +sub debug_code_f1 +{ + my $w=shift; +} + +sub debug_code_f2 +{ + my $w=shift; +} + +####################################################################### +####################################################################### +sub InitObject +{ + my ($w) = @_; + $w->SUPER::InitObject; + + $w->{'INDENT_STRING'} = "\t"; # Greg mode=>"\t", Nick mode=>" " + $w->{'LINE_COMMENT_STRING'} = "#"; # assuming perl comments + + my %pair_descriptor_hash = + ( + 'PARENS' => [ 'multiline', '(', ')', "[()]" ], + 'CURLIES' => [ 'multiline', '{', '}', "[{}]" ], + 'BRACES' => [ 'multiline', '[', ']', "[][]" ], + 'DOUBLEQUOTE' => [ 'singleline', "\"","\"" ], + 'SINGLEQUOTE' => [ 'singleline', "'","'" ], + ); + + $w->{'HIGHLIGHT_PAIR_DESCRIPTOR_HASH_REF'}=\%pair_descriptor_hash; + + $w->tagConfigure + ('CURSOR_HIGHLIGHT_PARENS', -foreground=>'white', -background=>'violet'); + $w->tagConfigure + ('CURSOR_HIGHLIGHT_CURLIES', -foreground=>'white', -background=>'blue'); + $w->tagConfigure + ('CURSOR_HIGHLIGHT_BRACES', -foreground=>'white', -background=>'purple'); + $w->tagConfigure + ('CURSOR_HIGHLIGHT_DOUBLEQUOTE', -foreground=>'black', -background=>'green'); + $w->tagConfigure + ('CURSOR_HIGHLIGHT_SINGLEQUOTE', -foreground=>'black', -background=>'grey'); + + $w->tagConfigure('BLOCK_HIGHLIGHT_PARENS', -background=>'red'); + $w->tagConfigure('BLOCK_HIGHLIGHT_CURLIES', -background=>'orange'); + $w->tagConfigure('BLOCK_HIGHLIGHT_BRACES', -background=>'red'); + $w->tagConfigure('BLOCK_HIGHLIGHT_DOUBLEQUOTE', -background=>'red'); + $w->tagConfigure('BLOCK_HIGHLIGHT_SINGLEQUOTE', -background=>'red'); + + $w->tagRaise('BLOCK_HIGHLIGHT_PARENS','CURSOR_HIGHLIGHT_PARENS'); + $w->tagRaise('BLOCK_HIGHLIGHT_CURLIES','CURSOR_HIGHLIGHT_CURLIES'); + $w->tagRaise('BLOCK_HIGHLIGHT_BRACES','CURSOR_HIGHLIGHT_BRACES'); + $w->tagRaise('BLOCK_HIGHLIGHT_DOUBLEQUOTE','CURSOR_HIGHLIGHT_DOUBLEQUOTE'); + $w->tagRaise('BLOCK_HIGHLIGHT_SINGLEQUOTE','CURSOR_HIGHLIGHT_SINGLEQUOTE'); + + $w->{'UPDATE_WIDGET_PERIOD'}=300; # how much time between each call. + $w->{'WINDOW_PLUS_AND_MINUS_VALUE'}=80; + $w->SetGUICallbackIndex(0); + $w->schedule_next_callback; + +} + +####################################################################### + +sub cancel_current_gui_callback_and_restart_from_beginning +{ + my ($w)=@_; + if(defined($w->{'UPDATE_WIDGET_AFTER_REFERENCE'})) + {$w->{'UPDATE_WIDGET_AFTER_REFERENCE'}->cancel();} + $w->SetGUICallbackIndex(0); + + $w->schedule_next_callback; +} + +sub schedule_next_callback +{ + my ($w)=@_; + return if $w->NoMoreGUICallbacksToCall; #stops infinite recursive call. + $w->{'UPDATE_WIDGET_AFTER_REFERENCE'} = $w->after + ($w->{'UPDATE_WIDGET_PERIOD'}, + sub + { + $w->CallNextGUICallback; + $w->schedule_next_callback; + } + ); + +} + + +####################################################################### +# use these methods to pass the TextEdit widget an anonymous array +# of code references. +# any time the widget changes that requires the display to be updated, +# then these code references will be scheduled in sequence for calling. +# splitting them up allows them to be prioritized by order, +# and prevents the widget from "freezing" too long if they were +# one large callback. scheduling them apart allows the widget time +# to respond to user inputs. +####################################################################### +sub SetGUICallbacks +{ + my ($w,$callback_array_ref) = @_; + $w->{GUI_CALLBACK_ARRAY_REF}=$callback_array_ref; + $w->SetGUICallbackIndex(0); +} + +sub GetGUICallbacks +{ + return shift->{GUI_CALLBACK_ARRAY_REF}; +} + +sub SetGUICallbackIndex +{ + my ($w, $val)=@_; + $w->{GUI_CALLBACK_ARRAY_INDEX}=$val; +} + +sub GetGUICallbackIndex +{ + return shift->{GUI_CALLBACK_ARRAY_INDEX}; +} + +sub IncrementGUICallbackIndex +{ + shift->{GUI_CALLBACK_ARRAY_INDEX} += 1; +} + +sub NoMoreGUICallbacksToCall +{ + my ($w) = @_; + return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_REF}); + return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_INDEX}); + my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF}; + my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX}; + return $arr_ind >= @$arr_ref; +} + +sub CallNextGUICallback +{ + my ($w) = @_; + return if $w->NoMoreGUICallbacksToCall; + my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF}; + my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX}; + &{$arr_ref->[$arr_ind]}; + $w->IncrementGUICallbackIndex; +} + + +####################################################################### +####################################################################### + +sub insert +{ + my $w = shift; + $w->SUPER::insert(@_); + $w->cancel_current_gui_callback_and_restart_from_beginning; +} + +sub delete +{ + my $w = shift; + $w->SUPER::delete(@_); + $w->cancel_current_gui_callback_and_restart_from_beginning; +} + +sub SetCursor +{ + my $w = shift; + $w->SUPER::SetCursor(@_); + $w->cancel_current_gui_callback_and_restart_from_beginning; +} + +sub OverstrikeMode +{ + my ($w,$mode) = @_; + if (defined($mode)) + { + $w->SUPER::OverstrikeMode($mode); + $w->cancel_current_gui_callback_and_restart_from_beginning; + } + return $w->SUPER::OverstrikeMode; +} + + +####################################################################### +# use yview on scrollbar to get fractional coordinates. +# scale this by the total length of the text to find the +# approximate start line of widget and end line of widget. +####################################################################### +sub GetScreenWindowCoordinates +{ + my $w = shift; + my ($top_frac, $bot_frac) = $w->yview; + my $end_index = $w->index('end'); + my ($lines,$columns) = split (/\./,$end_index); + my $window = $w->{'WINDOW_PLUS_AND_MINUS_VALUE'}; + my $top_line = int(($top_frac * $lines) - $window); + $top_line = 0 if ($top_line < 0); + my $bot_line = int(($bot_frac * $lines) + $window); + $bot_line = $lines if ($bot_line > $lines); + my $top_index = $top_line . '.0'; + my $bot_index = $bot_line . '.0'; + + $_[0] = $top_index; + $_[1] = $bot_index; +} + +######################################################################## +# take two indices as inputs. +# if they are on the same line or same column (accounting for tabs) +# then return 1 +# else return 0 +# (assume indices passed in are in line.column format) +######################################################################## +sub IndicesLookGood +{ + my ($w, $start, $end, $singleline) = @_; + + return 0 unless ( (defined($start)) and (defined($end))); + + my ($start_line, $start_column) = split (/\./,$start); + my ($end_line, $end_column) = split (/\./,$end); + + ########################## + # good if on the same line + ########################## + return 1 if ($start_line == $end_line); + + ########################## + # if not on same line and its a singleline, its bad + ########################## + return 0 if $singleline; + + + # get both lines, convert the tabs to spaces, and get the new column. + # see if they line up or not. + my $string; + $string = $w->get($start_line.'.0', $start_line.'.0 lineend'); + $string = substr($string, 0, $start_column+1); + $string = expand($string); + $start_column = length($string); + + $string = $w->get($end_line.'.0', $end_line.'.0 lineend'); + $string = substr($string, 0, $end_column +1); + $string = expand($string); + $end_column = length($string); + + ########################## + # good if on the same column (adjusting for tabs) + ########################## + return 1 if ($start_column == $end_column); + + # otherwise its bad + return 0; +} + +######################################################################## +# if searching backward, count paranthesis until find a start parenthesis +# which does not have a forward match. +# +# (<= search backward will return this index +# () +# START X HERE +# ( ( ) () ) +# )<== search forward will return this index +# +# if searching forward, count paranthesis until find a end parenthesis +# which does not have a rearward match. +######################################################################## +sub searchForBaseCharacterInPair +{ + my + ( + $w, $top_index, $searchfromindex, $bot_index, + $direction, $startchar, $endchar, $charpair + )=@_; + my ($plus_one_char, $search_end_index, $index_offset, $done_index); + if ($direction eq '-forward') + { + $plus_one_char = $endchar; + $search_end_index = $bot_index; + $index_offset = ' +1c'; + $done_index = $w->index('end'); + } + else + { + $plus_one_char = $startchar; + $search_end_index = $top_index; + $index_offset = ''; + $done_index = '1.0'; + } + + my $at_done_index = 0; + my $count = 0; + my $char; + while(1) + { + $searchfromindex = $w->search + ($direction, '-regexp', $charpair, $searchfromindex, $search_end_index ); + + last unless(defined($searchfromindex)); + $char = $w->get($searchfromindex, $w->index($searchfromindex.' +1c')); + if ($char eq $plus_one_char) + {$count += 1;} + else + {$count -= 1;} + last if ($count==1); + # boundary condition exists when first char in widget is the match char + # need to be able to determine if search tried to go past index '1.0' + # if so, set index to undef and return. + if ( $at_done_index ) + { + $searchfromindex = undef; + last; + } + $at_done_index = 1 if ($searchfromindex eq $done_index); + $searchfromindex=$w->index($searchfromindex . $index_offset); + } + return $searchfromindex; +} + +######################################################################## +# highlight a character pair that most closely brackets the cursor. +# allows you to pick and choose which ones you want to do. +######################################################################## + +sub HighlightParenthesisAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( '(', ')', '[()]', 'CURSOR_HIGHLIGHT_PARENS','BLOCK_HIGHLIGHT_PARENS',0); +} + +sub HighlightCurlyBracesAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( '{', '}', '[{}]', 'CURSOR_HIGHLIGHT_CURLIES','BLOCK_HIGHLIGHT_CURLIES',0); +} + +sub HighlightBracesAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( '[', ']','[][]', 'CURSOR_HIGHLIGHT_BRACES','BLOCK_HIGHLIGHT_BRACES',0); +} + +sub HighlightDoubleQuotesAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( "\"", "\"", "\"", 'CURSOR_HIGHLIGHT_DOUBLEQUOTE','BLOCK_HIGHLIGHT_DOUBLEQUOTE',1); +} + +sub HighlightSingleQuotesAroundCursor +{ + my ($w)=@_; + $w->HighlightSinglePairBracketingCursor + ( "'", "'", "'", 'CURSOR_HIGHLIGHT_SINGLEQUOTE','BLOCK_HIGHLIGHT_SINGLEQUOTE',1); +} + +######################################################################## +# highlight all the character pairs that most closely bracket the cursor. +######################################################################## +sub HighlightAllPairsBracketingCursor +{ + my ($w)=@_; + $w->HighlightParenthesisAroundCursor; + $w->HighlightCurlyBracesAroundCursor; + $w->HighlightBracesAroundCursor; + $w->HighlightDoubleQuotesAroundCursor; + $w->HighlightSingleQuotesAroundCursor; +} + +######################################################################## +# search for a pair of matching characters that bracket the +# cursor and tag them with the given tagname. +# startchar might be '[' +# endchar would then be ']' +# tagname is a name of a tag, which has already been +# configured to highlight however the user wants them to behave. +# error tagname is the tag to highlight the chars with if there +# is a problem of some kind. +# singleline indicates whether the character pairs must occur +# on a single line. quotation marks are single line characters usually. +######################################################################## +sub HighlightSinglePairBracketingCursor +{ + my + ( + $w, $startchar, $endchar, $charpair, + $good_tagname, $bad_tagname, $single_line + ) = @_; + $single_line=0 unless defined($single_line); + $w->tagRemove($good_tagname, '1.0','end'); + $w->tagRemove($bad_tagname, '1.0','end'); + my $top_index; my $bot_index; + my $cursor = $w->index('insert'); + if ($single_line) + { + $top_index = $w->index($cursor.' linestart'); + $bot_index = $w->index($cursor.' lineend'); + } + else + { + $w->GetScreenWindowCoordinates($top_index, $bot_index); + } + + # search backward for the startchar + # $top_index, $searchfromindex, $bot_index, + # $direction, $startchar, $endchar, $charpair + + my $startindex = $w->searchForBaseCharacterInPair + ( + $top_index, $cursor, $bot_index, + '-backward', $startchar, $endchar, $charpair + ); + + # search forward for the endchar + my $endindex = $w->searchForBaseCharacterInPair + ( + $top_index, $cursor, $bot_index, + '-forward', $startchar, $endchar, $charpair + ); + return unless ((defined $startindex) and (defined $endindex)); + + my $final_tag = $bad_tagname; + if ($w->IndicesLookGood( $startindex, $endindex, $single_line)) + { + $final_tag = $good_tagname; + } + + $w->tagAdd($final_tag, $startindex, $w->index($startindex.'+1c') ); + $w->tagAdd($final_tag, $endindex, $w->index( $endindex.'+1c') ); +} + +#################################################################### +sub IndentSelectedLines +{ + my($w)=@_; + $w->insertStringAtStartOfSelectedLines($w->{'INDENT_STRING'}); +} + +sub UnindentSelectedLines +{ + my($w)=@_; + $w->deleteStringAtStartOfSelectedLines($w->{'INDENT_STRING'}); +} + +sub CommentSelectedLines +{ + my($w)=@_; + $w->insertStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'}); +} + +sub UncommentSelectedLines +{ + my($w)=@_; + $w->deleteStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'}); +} + + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Tk/TextList.pm b/Master/tlpkg/tlperl/lib/Tk/TextList.pm new file mode 100644 index 00000000000..77a48fdf8ce --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/TextList.pm @@ -0,0 +1,985 @@ +# Copyright (c) 1999 Greg London. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +# code for bindings taken from Listbox.pm + +# comments specifying method functionality taken from +# "Perl/Tk Pocket Reference" by Stephen Lidie. + +####################################################################### +# this module uses a text module as its base class to create a list box. +# this will allow list box functionality to also have all the functionality +# of the Text widget. +# +# note that most methods use an element number to indicate which +# element in the list to work on. +# the exception to this is the tag and mark methods which +# are dual natured. These methods may accept either the +# normal element number, or they will also take a element.char index, +# which would be useful for applying tags to part of a line in the list. +# +####################################################################### + +package Tk::TextList; + +use strict; +use vars qw($VERSION); +$VERSION = '4.005'; # $Id: //depot/Tkutf8/TextList/TextList.pm#5 $ + +#XXXdel: use Tk::Reindex qw(Tk::ROText); #XXXdel: ReindexedROText); + +use base qw(Tk::Derived Tk::ReindexedROText ); + +use Tk qw (Ev); + +#XXX del: use base qw(Tk::ReindexedROText); + +Construct Tk::Widget 'TextList'; + +####################################################################### +# the following line causes Populate to get called +# @ISA = qw(Tk::Derived ... ); +####################################################################### +sub Populate +{ + my ($w,$args)=@_; + my $option=delete $args->{'-selectmode'}; + $w->SUPER::Populate($args); + $w->ConfigSpecs( -selectmode => ['PASSIVE','selectMode','SelectMode','browse'], + -takefocus => ['PASSIVE','takeFocus','TakeFocus',1], + -spacing3 => ['SELF', undef, undef, 3], + -insertwidth => ['SELF', undef, undef, 0], + ); + +} + +####################################################################### +####################################################################### +sub ClassInit +{ + my ($class,$mw) = @_; + + # Standard Motif bindings: + $mw->bind($class,'<1>',['BeginSelect',Ev('index',Ev('@'))]); + $mw->bind($class,'',['Motion',Ev('index',Ev('@'))]); + $mw->bind($class,'','ButtonRelease_1'); + + $mw->bind($class,'',['BeginExtend',Ev('index',Ev('@'))]); + $mw->bind($class,'',['BeginToggle',Ev('index',Ev('@'))]); + + $mw->bind($class,'',['AutoScan',Ev('x'),Ev('y')]); + $mw->bind($class,'','CancelRepeat'); + $mw->bind($class,'',['UpDown',-1]); + $mw->bind($class,'',['ExtendUpDown',-1]); + $mw->bind($class,'',['UpDown',1]); + $mw->bind($class,'',['ExtendUpDown',1]); + + $mw->XscrollBind($class); + $mw->PriorNextBind($class); + + $mw->bind($class,'','Cntrl_Home'); + + $mw->bind($class,'',['DataExtend',0]); + $mw->bind($class,'','Cntrl_End'); + + $mw->bind($class,'',['DataExtend','end']); + $class->clipboardOperations($mw,'Copy'); + $mw->bind($class,'',['BeginSelect',Ev('index','active')]); + $mw->bind($class,', C, +C, C. + +Example: + + $events = $CONSOLE->GetEvents(); + +=item Info + +Returns an array of informations about the console (or C on +errors), which contains: + +=over + +=item * + +columns (X size) of the console buffer. + +=item * + +rows (Y size) of the console buffer. + +=item * + +current column (X position) of the cursor. + +=item * + +current row (Y position) of the cursor. + +=item * + +current attribute used for C. + +=item * + +left column (X of the starting point) of the current console window. + +=item * + +top row (Y of the starting point) of the current console window. + +=item * + +right column (X of the final point) of the current console window. + +=item * + +bottom row (Y of the final point) of the current console window. + +=item * + +maximum number of columns for the console window, given the current +buffer size, font and the screen size. + +=item * + +maximum number of rows for the console window, given the current +buffer size, font and the screen size. + +=back + +See also: C, C, C, C, C. + +Example: + + @info = $CONSOLE->Info(); + print "Cursor at $info[3], $info[4].\n"; + +=item Input + +Reads an event from the input buffer. Returns a list of values, which +depending on the event's nature are: + +=over + +=item keyboard event + +The list will contain: + +=over + +=item * + +event type: 1 for keyboard + +=item * + +key down: TRUE if the key is being pressed, FALSE if the key is being released + +=item * + +repeat count: the number of times the key is being held down + +=item * + +virtual keycode: the virtual key code of the key + +=item * + +virtual scancode: the virtual scan code of the key + +=item * + +char: the ASCII code of the character (if the key is a character key, 0 otherwise) + +=item * + +control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.) + +=back + +=item mouse event + +The list will contain: + +=over + +=item * + +event type: 2 for mouse + +=item * + +mouse pos. X: X coordinate (column) of the mouse location + +=item * + +mouse pos. Y: Y coordinate (row) of the mouse location + +=item * + +button state: the mouse button(s) which are pressed + +=item * + +control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.) + +=item * + +event flags: the type of the mouse event + +=back + +=back + +This method will return C on errors. Note that the events +returned are depending on the input C of the console; for example, +mouse events are not intercepted unless ENABLE_MOUSE_INPUT is +specified. See also: C, C, C, +C, C. + +Example: + + @event = $CONSOLE->Input(); + +=item InputChar number + +Reads and returns I characters from the console input buffer, +or C on errors. See also: C, C. + +Example: + + $key = $CONSOLE->InputChar(1); + +=item InputCP [codepage] + +Gets or sets the input code page used by the console. Note that this +doesn't apply to a console object, but to the standard input +console. This attribute is used by the Write method. See also: +C. + +Example: + + $codepage = $CONSOLE->InputCP(); + $CONSOLE->InputCP(437); + + # you may want to use the non-instanciated form to avoid confuzion :) + $codepage = Win32::Console::InputCP(); + Win32::Console::InputCP(437); + +=item MaxWindow + +Returns the size of the largest possible console window, based on the +current font and the size of the display. The result is C on +errors, otherwise a 2-element list containing col, row. + +Example: + + ($maxCol, $maxRow) = $CONSOLE->MaxWindow(); + +=item Mode [flags] + +Gets or sets the input or output mode of a console. I can be a +combination of the following constants: + + ENABLE_LINE_INPUT + ENABLE_ECHO_INPUT + ENABLE_PROCESSED_INPUT + ENABLE_WINDOW_INPUT + ENABLE_MOUSE_INPUT + ENABLE_PROCESSED_OUTPUT + ENABLE_WRAP_AT_EOL_OUTPUT + +For more informations on the meaning of those flags, please refer to +the L<"Microsoft's Documentation">. + +Example: + + $mode = $CONSOLE->Mode(); + $CONSOLE->Mode(ENABLE_MOUSE_INPUT | ENABLE_PROCESSED_INPUT); + +=item MouseButtons + +Returns the number of the buttons on your mouse, or C on errors. + +Example: + + print "Your mouse has ", $CONSOLE->MouseButtons(), " buttons.\n"; + +=item new Win32::Console standard_handle + +=item new Win32::Console [accessmode, sharemode] + +Creates a new console object. The first form creates a handle to a +standard channel, I can be one of the following: + + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + STD_INPUT_HANDLE + +The second form, instead, creates a console screen buffer in memory, +which you can access for reading and writing as a normal console, and +then redirect on the standard output (the screen) with C. In +this case, you can specify one or both of the following values for +I: + + GENERIC_READ + GENERIC_WRITE + +which are the permissions you will have on the created buffer, and one +or both of the following values for I: + + FILE_SHARE_READ + FILE_SHARE_WRITE + +which affect the way the console can be shared. If you don't specify +any of those parameters, all 4 flags will be used. + +Example: + + $STDOUT = new Win32::Console(STD_OUTPUT_HANDLE); + $STDERR = new Win32::Console(STD_ERROR_HANDLE); + $STDIN = new Win32::Console(STD_INPUT_HANDLE); + + $BUFFER = new Win32::Console(); + $BUFFER = new Win32::Console(GENERIC_READ | GENERIC_WRITE); + +=item OutputCP [codepage] + +Gets or sets the output code page used by the console. Note that this +doesn't apply to a console object, but to the standard output console. +See also: C. + +Example: + + $codepage = $CONSOLE->OutputCP(); + $CONSOLE->OutputCP(437); + + # you may want to use the non-instanciated form to avoid confuzion :) + $codepage = Win32::Console::OutputCP(); + Win32::Console::OutputCP(437); + +=item PeekInput + +Does exactly the same as C, except that the event read is not +removed from the input buffer. See also: C, C, +C, C, C. + +Example: + + @event = $CONSOLE->PeekInput(); + +=item ReadAttr [number, col, row] + +Reads the specified I of consecutive attributes, beginning at +I, I, from the console. Returns the attributes read (a +variable containing one character for each attribute), or C on +errors. You can then pass the returned variable to C to +restore the saved attributes on screen. See also: C, +C. + +Example: + + $colors = $CONSOLE->ReadAttr(80*25, 0, 0); + +=item ReadChar [number, col, row] + +Reads the specified I of consecutive characters, beginning at +I, I, from the console. Returns a string containing the +characters read, or C on errors. You can then pass the +returned variable to C to restore the saved characters on +screen. See also: C, C. + +Example: + + $chars = $CONSOLE->ReadChar(80*25, 0, 0); + +=item ReadRect left, top, right, bottom + +Reads the content (characters and attributes) of the rectangle +specified by I, I, I, I from the console. +Returns a string containing the rectangle read, or C on errors. +You can then pass the returned variable to C to restore the +saved rectangle on screen (or on another console). See also: +C, C. + +Example: + + $rect = $CONSOLE->ReadRect(0, 0, 80, 25); + +=item Scroll left, top, right, bottom, col, row, char, attr, + [cleft, ctop, cright, cbottom] + +Moves a block of data in a console buffer; the block is identified by +I, I, I, I, while I, I identify +the new location of the block. The cells left empty as a result of +the move are filled with the character I and attribute I. +Optionally you can specify a clipping region with I, I, +I, I, so that the content of the console outside this +rectangle are unchanged. Returns C on errors, a nonzero value +on success. + +Example: + + # scrolls the screen 10 lines down, filling with black spaces + $CONSOLE->Scroll(0, 0, 80, 25, 0, 10, " ", $FG_BLACK | $BG_BLACK); + +=item Select standard_handle + +Redirects a standard handle to the specified console. +I can have one of the following values: + + STD_INPUT_HANDLE + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + +Returns C on errors, a nonzero value on success. + +Example: + + $CONSOLE->Select(STD_OUTPUT_HANDLE); + +=item SetIcon icon_file + +Sets the icon in the title bar of the current console window. + +Example: + + $CONSOLE->SetIcon("C:/My/Path/To/Custom.ico"); + +=item Size [col, row] + +Gets or sets the console buffer size. + +Example: + + ($x, $y) = $CONSOLE->Size(); + $CONSOLE->Size(80, 25); + +=item Title [title] + +Gets or sets the title of the current console window. + +Example: + + $title = $CONSOLE->Title(); + $CONSOLE->Title("This is a title"); + +=item Window [flag, left, top, right, bottom] + +Gets or sets the current console window size. If called without +arguments, returns a 4-element list containing the current window +coordinates in the form of I, I, I, I. To +set the window size, you have to specify an additional I +parameter: if it is 0 (zero), coordinates are considered relative to +the current coordinates; if it is non-zero, coordinates are absolute. + +Example: + + ($left, $top, $right, $bottom) = $CONSOLE->Window(); + $CONSOLE->Window(1, 0, 0, 80, 50); + +=item Write string + +Writes I on the console, using the current attribute, that you +can set with C, and advancing the cursor as needed. This isn't +so different from Perl's "print" statement. Returns the number of +characters written or C on errors. See also: C, +C, C. + +Example: + + $CONSOLE->Write("Hello, world!"); + +=item WriteAttr attrs, col, row + +Writes the attributes in the string I, beginning at I, +I, without affecting the characters that are on screen. The +string attrs can be the result of a C function, or you can +build your own attribute string; in this case, keep in mind that every +attribute is treated as a character, not a number (see example). +Returns the number of attributes written or C on errors. See +also: C, C, C. + +Example: + + $CONSOLE->WriteAttr($attrs, 0, 0); + + # note the use of chr()... + $attrs = chr($FG_BLACK | $BG_WHITE) x 80; + $CONSOLE->WriteAttr($attrs, 0, 0); + +=item WriteChar chars, col, row + +Writes the characters in the string I, beginning at I, I, +without affecting the attributes that are on screen. The string I +can be the result of a C function, or a normal string. Returns +the number of characters written or C on errors. See also: +C, C, C. + +Example: + + $CONSOLE->WriteChar("Hello, worlds!", 0, 0); + +=item WriteInput (event) + +Pushes data in the console input buffer. I<(event)> is a list of values, +for more information see C. The string chars can be the result of +a C function, or a normal string. Returns the number of +characters written or C on errors. See also: C, +C, C. + +Example: + + $CONSOLE->WriteInput(@event); + +=item WriteRect rect, left, top, right, bottom + +Writes a rectangle of characters and attributes (contained in I) +on the console at the coordinates specified by I, I, +I, I. I can be the result of a C +function. Returns C on errors, otherwise a 4-element list +containing the coordinates of the affected rectangle, in the format +I, I, I, I. See also: C, +C, C. + +Example: + + $CONSOLE->WriteRect($rect, 0, 0, 80, 25); + +=back + + +=head2 Constants + +The following constants are exported in the main namespace of your +script using Win32::Console: + + BACKGROUND_BLUE + BACKGROUND_GREEN + BACKGROUND_INTENSITY + BACKGROUND_RED + CAPSLOCK_ON + CONSOLE_TEXTMODE_BUFFER + ENABLE_ECHO_INPUT + ENABLE_LINE_INPUT + ENABLE_MOUSE_INPUT + ENABLE_PROCESSED_INPUT + ENABLE_PROCESSED_OUTPUT + ENABLE_WINDOW_INPUT + ENABLE_WRAP_AT_EOL_OUTPUT + ENHANCED_KEY + FILE_SHARE_READ + FILE_SHARE_WRITE + FOREGROUND_BLUE + FOREGROUND_GREEN + FOREGROUND_INTENSITY + FOREGROUND_RED + LEFT_ALT_PRESSED + LEFT_CTRL_PRESSED + NUMLOCK_ON + GENERIC_READ + GENERIC_WRITE + RIGHT_ALT_PRESSED + RIGHT_CTRL_PRESSED + SCROLLLOCK_ON + SHIFT_PRESSED + STD_INPUT_HANDLE + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + +Additionally, the following variables can be used: + + $FG_BLACK + $FG_GRAY + $FG_BLUE + $FG_LIGHTBLUE + $FG_RED + $FG_LIGHTRED + $FG_GREEN + $FG_LIGHTGREEN + $FG_MAGENTA + $FG_LIGHTMAGENTA + $FG_CYAN + $FG_LIGHTCYAN + $FG_BROWN + $FG_YELLOW + $FG_LIGHTGRAY + $FG_WHITE + + $BG_BLACK + $BG_GRAY + $BG_BLUE + $BG_LIGHTBLUE + $BG_RED + $BG_LIGHTRED + $BG_GREEN + $BG_LIGHTGREEN + $BG_MAGENTA + $BG_LIGHTMAGENTA + $BG_CYAN + $BG_LIGHTCYAN + $BG_BROWN + $BG_YELLOW + $BG_LIGHTGRAY + $BG_WHITE + + $ATTR_NORMAL + $ATTR_INVERSE + +ATTR_NORMAL is set to gray foreground on black background (DOS's +standard colors). + + +=head2 Microsoft's Documentation + +Documentation for the Win32 Console and Character mode Functions can +be found on Microsoft's site at this URL: + +http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar.htm + +A reference of the available functions is at: + +http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar_34.htm + + +=head1 AUTHOR + +Aldo Calpini + +=head1 CREDITS + +Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the +Perl-Win32-Users community. + +=head1 DISCLAIMER + +This program is FREE; you can redistribute, modify, disassemble, or +even reverse engineer this software at your will. Keep in mind, +however, that NOTHING IS GUARANTEED to work and everything you do is +AT YOUR OWN RISK - I will not take responsibility for any damage, loss +of money and/or health that may arise from the use of this program! + +This is distributed under the terms of Larry Wall's Artistic License. diff --git a/Master/tlpkg/tlperl/lib/Win32/Event.pm b/Master/tlpkg/tlperl/lib/Win32/Event.pm new file mode 100644 index 00000000000..5faddf5a76e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Event.pm @@ -0,0 +1,104 @@ +#--------------------------------------------------------------------- +package Win32::Event; +# +# Copyright 1998 Christopher J. Madsen +# +# Author: Christopher J. Madsen +# Created: 3 Feb 1998 from the ActiveWare version +# Version: 1.00 (6-Feb-1998) +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# Use Win32 event objects for synchronization +#--------------------------------------------------------------------- + +$VERSION = '1.01'; + +use Win32::IPC 1.00 '/./'; # Import everything +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader Win32::IPC); +@EXPORT_OK = qw( + wait_all wait_any INFINITE +); + +bootstrap Win32::Event; + +1; +__END__ + +=head1 NAME + +Win32::Event - Use Win32 event objects from Perl + +=head1 SYNOPSIS + + use Win32::Event; + + $event = Win32::Event->new($manual,$initial,$name); + $event->wait(); + +=head1 DESCRIPTION + +This module allows access to the Win32 event objects. The C +method and C & C functions are inherited from the +L<"Win32::IPC"> module. + +=head2 Methods + +=over 4 + +=item $event = Win32::Event->new([$manual, [$initial, [$name]]]) + +Constructor for a new event object. If C<$manual> is true, you must +manually reset the event after it is signalled (the default is false). +If C<$initial> is true, the initial state of the object is signalled +(default false). If C<$name> is omitted, creates an unnamed event +object. + +If C<$name> signifies an existing event object, then C<$manual> and +C<$initial> are ignored and the object is opened. If this happens, +C<$^E> will be set to 183 (ERROR_ALREADY_EXISTS). + +=item $event = Win32::Event->open($name) + +Constructor for opening an existing event object. + +=item $event->pulse + +Signal the C<$event> and then immediately reset it. If C<$event> is a +manual-reset event, releases all threads currently blocking on it. If +it's an auto-reset event, releases just one thread. + +If no threads are waiting, just resets the event. + +=item $event->reset + +Reset the C<$event> to nonsignalled. + +=item $event->set + +Set the C<$event> to signalled. + +=item $event->wait([$timeout]) + +Wait for C<$event> to be signalled. See L<"Win32::IPC">. + +=back + +=head1 AUTHOR + +Christopher J. Madsen EFE + +=cut + +# Local Variables: +# tmtrack-file-task: "Win32::Event" +# End: diff --git a/Master/tlpkg/tlperl/lib/Win32/EventLog.pm b/Master/tlpkg/tlperl/lib/Win32/EventLog.pm new file mode 100644 index 00000000000..141821556e7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/EventLog.pm @@ -0,0 +1,471 @@ +# +# EventLog.pm +# +# Creates an object oriented interface to the Windows NT Evenlog +# Written by Jesse Dougherty +# + +package Win32::EventLog; + +use strict; +use vars qw($VERSION $AUTOLOAD @ISA @EXPORT $GetMessageText); +$VERSION = '0.074'; + +require Exporter; +require DynaLoader; + +die "The Win32::Eventlog module works only on Windows NT" + unless Win32::IsWinNT(); + +@ISA= qw(Exporter DynaLoader); +@EXPORT = qw( + EVENTLOG_AUDIT_FAILURE + EVENTLOG_AUDIT_SUCCESS + EVENTLOG_BACKWARDS_READ + EVENTLOG_END_ALL_PAIRED_EVENTS + EVENTLOG_END_PAIRED_EVENT + EVENTLOG_ERROR_TYPE + EVENTLOG_FORWARDS_READ + EVENTLOG_INFORMATION_TYPE + EVENTLOG_PAIRED_EVENT_ACTIVE + EVENTLOG_PAIRED_EVENT_INACTIVE + EVENTLOG_SEEK_READ + EVENTLOG_SEQUENTIAL_READ + EVENTLOG_START_PAIRED_EVENT + EVENTLOG_SUCCESS + EVENTLOG_WARNING_TYPE +); + +$GetMessageText=0; + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + # reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($!) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + my ($pack,$file,$line) = caller; + die "Unknown Win32::EventLog macro $constname, at $file line $line.\n"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +# +# new() +# +# Win32::EventLog->new("source name", "ServerName"); +# +sub new { + die "usage: PACKAGE->new(SOURCENAME[, SERVERNAME])\n" unless @_ > 1; + my ($class,$source,$server) = @_; + my $handle; + + # Create new handle + if ($source !~ /\\/) { + OpenEventLog($handle, $server, $source); + } + else { + OpenBackupEventLog($handle, $server, $source); + } + return bless {handle => $handle, + Source => $source, + Computer => $server} => $class; +} + +sub DESTROY {shift->Close} + +# +# Open (the rather braindead old way) +# A variable initialized to empty must be supplied as the first +# arg, followed by whatever new() takes +# +sub Open { + $_[0] = Win32::EventLog->new($_[1],$_[2]); +} + +sub OpenBackup { + my ($class,$source,$server) = @_; + OpenBackupEventLog(my $handle, $server, $source); + return bless {handle => $handle, + Source => $source, + Computer => $server} => $class; +} + +sub Backup { + die " usage: OBJECT->Backup(FILENAME)\n" unless @_ == 2; + my ($self,$file) = @_; + return BackupEventLog($self->{handle}, $file); +} + +sub Close { + my $self = shift; + CloseEventLog($self->{handle}); + $self->{handle} = 0; +} + +# Read +# Note: the EventInfo arguement requires a hash reference. +sub Read { + my $self = shift; + + die "usage: OBJECT->Read(FLAGS, RECORDOFFSET, HASHREF)\n" unless @_ == 3; + + my ($readflags,$recordoffset) = @_; + # The following is stolen shamelessly from Wyt's tests for the registry. + my $result = ReadEventLog($self->{handle}, $readflags, $recordoffset, + my $header, my $source, my $computer, my $sid, + my $data, my $strings); + my ($length, + $reserved, + $recordnumber, + $timegenerated, + $timewritten, + $eventid, + $eventtype, + $numstrings, + $eventcategory, + $reservedflags, + $closingrecordnumber, + $stringoffset, + $usersidlength, + $usersidoffset, + $datalength, + $dataoffset) = unpack('l6s4l6', $header); + + # make a hash out of the values returned from ReadEventLog. + my %h = ( Source => $source, + Computer => $computer, + Length => $datalength, + Category => $eventcategory, + RecordNumber => $recordnumber, + TimeGenerated => $timegenerated, + Timewritten => $timewritten, + EventID => $eventid, + EventType => $eventtype, + ClosingRecordNumber => $closingrecordnumber, + User => $sid, + Strings => $strings, + Data => $data, + ); + + # get the text message here + if ($result and $GetMessageText) { + GetEventLogText($source, $eventid, $strings, $numstrings, my $message); + $h{Message} = $message; + } + + if (ref($_[2]) eq 'HASH') { + %{$_[2]} = %h; # this needed for Read(...,\%foo) case + } + else { + $_[2] = \%h; + } + return $result; +} + +sub GetMessageText { + my $self = shift; + local $^W; + GetEventLogText($self->{Source}, + $self->{EventID}, + $self->{Strings}, + $self->{Strings} =~ tr/\0/\0/, + my $message); + + $self->{Message} = $message; + return $message; +} + +sub Report { + die "usage: OBJECT->Report( HASHREF )\n" unless @_ == 2; + my ($self,$EventInfo) = @_; + + die "Win32::EventLog::Report requires a hash reference as arg 2\n" + unless ref($EventInfo) eq "HASH"; + + my $computer = $EventInfo->{Computer} ? $EventInfo->{Computer} + : $self->{Computer}; + my $source = exists($EventInfo->{Source}) ? $EventInfo->{Source} + : $self->{Source}; + + return WriteEventLog($computer, $source, $EventInfo->{EventType}, + $EventInfo->{Category}, $EventInfo->{EventID}, 0, + $EventInfo->{Data}, split(/\0/, $EventInfo->{Strings})); + +} + +sub GetOldest { + my $self = shift; + die "usage: OBJECT->GetOldest( SCALAREF )\n" unless @_ == 1; + return GetOldestEventLogRecord($self->{handle},$_[0]); +} + +sub GetNumber { + my $self = shift; + die "usage: OBJECT->GetNumber( SCALARREF )\n" unless @_ == 1; + return GetNumberOfEventLogRecords($self->{handle}, $_[0]); +} + +sub Clear { + my ($self,$file) = @_; + die "usage: OBJECT->Clear( FILENAME )\n" unless @_ == 2; + return ClearEventLog($self->{handle}, $file); +} + +bootstrap Win32::EventLog; + +1; +__END__ + +=head1 NAME + +Win32::EventLog - Process Win32 Event Logs from Perl + +=head1 SYNOPSIS + + use Win32::EventLog + $handle=Win32::EventLog->new("Application"); + +=head1 DESCRIPTION + +This module implements most of the functionality available from the +Win32 API for accessing and manipulating Win32 Event Logs. The access +to the EventLog routines is divided into those that relate to an +EventLog object and its associated methods and those that relate other +EventLog tasks (like adding an EventLog record). + +=head1 The EventLog Object and its Methods + +The following methods are available to open, read, close and backup +EventLogs. + +=over 4 + +=item Win32::EventLog->new(SOURCENAME [,SERVERNAME]); + +The new() method creates a new EventLog object and returns a handle +to it. This hande is then used to call the methods below. + +The method is overloaded in that if the supplied SOURCENAME +argument contains one or more literal '\' characters (an illegal +character in a SOURCENAME), it assumes that you are trying to open +a backup eventlog and uses SOURCENAME as the backup eventlog to +open. Note that when opening a backup eventlog, the SERVERNAME +argument is ignored (as it is in the underlying Win32 API). For +EventLogs on remote machines, the SOURCENAME parameter must +therefore be specified as a UNC path. + +=item $handle->Backup(FILENAME); + +The Backup() method backs up the EventLog represented by $handle. It +takes a single arguemt, FILENAME. When $handle represents an +EventLog on a remote machine, FILENAME is filename on the remote +machine and cannot be a UNC path (i.e you must use F). +The method will fail if the log file already exists. + +=item $handle->Read(FLAGS, OFFSET, HASHREF); + +The Read() method read an EventLog entry from the EventLog represented +by $handle. + +=item $handle->Close(); + +The Close() method closes the EventLog represented by $handle. After +Close() has been called, any further attempt to use the EventLog +represented by $handle will fail. + +=item $handle->GetOldest(SCALARREF); + +The GetOldest() method number of the the oldest EventLog record in +the EventLog represented by $handle. This is required to correctly +compute the OFFSET required by the Read() method. + +=item $handle->GetNumber(SCALARREF); + +The GetNumber() method returns the number of EventLog records in +the EventLog represented by $handle. The number of the most recent +record in the EventLog is therefore computed by + + $handle->GetOldest($oldest); + $handle->GetNumber($lastRec); + $lastRecOffset=$oldest+$lastRec; + +=item $handle->Clear(FILENAME); + +The Clear() method clears the EventLog represented by $handle. If +you provide a non-null FILENAME, the EventLog will be backed up +into FILENAME before the EventLog is cleared. The method will fail +if FILENAME is specified and the file refered to exists. Note also +that FILENAME specifies a file local to the machine on which the +EventLog resides and cannot be specified as a UNC name. + +=item $handle->Report(HASHREF); + +The Report() method generates an EventLog entry. The HASHREF should +contain the following keys: + +=over 4 + +=item C + +The C field specfies which computer you want the EventLog +entry recorded. If this key doesn't exist, the server name used to +create the $handle is used. + +=item C + +The C field specifies the source that generated the EventLog +entry. If this key doesn't exist, the source name used to create the +$handle is used. + +=item C + +The C field should be one of the constants + +=over 4 + +=item C + +An Error event is being logged. + +=item C + +A Warning event is being logged. + +=item C + +An Information event is being logged. + +=item C + +A Success Audit event is being logged (typically in the Security +EventLog). + +=item C + +A Failure Audit event is being logged (typically in the Security +EventLog). + +=back + +These constants are exported into the main namespace by default. + +=item C + +The C field can have any value you want. It is specific to +the particular Source. + +=item C + +The C field should contain the ID of the message that this +event pertains too. This assumes that you have an associated message +file (indirectly referenced by the field C). + +=item C + +The C field contains raw data associated with this event. + +=item C + +The C field contains the single string that itself contains +NUL terminated sub-strings. This are used with the EventID to generate +the message as seen from (for example) the Event Viewer application. + +=back + +=back + +=head1 Other Win32::EventLog functions. + +The following functions are part of the Win32::EventLog package but +are not callable from an EventLog object. + +=over 4 + +=item GetMessageText(HASHREF); + +The GetMessageText() function assumes that HASHREF was obtained by +a call to C<$handle-ERead()>. It returns the formatted string that +represents the fully resolved text of the EventLog message (such as +would be seen in the Windows NT Event Viewer). For convenience, the +key 'Message' in the supplied HASHREF is also set to the return value +of this function. + +If you set the variable $Win32::EventLog::GetMessageText to 1 then +each call to C<$handle-ERead()> will call this function automatically. + +=back + +=head1 Example 1 + +The following example illustrates the way in which the EventLog module +can be used. It opens the System EventLog and reads through it from +oldest to newest records. For each record from the B EventLog +it extracts the full text of the Entry and prints the EventLog message +text out. + + use Win32::EventLog; + + $handle=Win32::EventLog->new("System", $ENV{ComputerName}) + or die "Can't open Application EventLog\n"; + $handle->GetNumber($recs) + or die "Can't get number of EventLog records\n"; + $handle->GetOldest($base) + or die "Can't get number of oldest EventLog record\n"; + + while ($x < $recs) { + $handle->Read(EVENTLOG_FORWARDS_READ|EVENTLOG_SEEK_READ, + $base+$x, + $hashRef) + or die "Can't read EventLog entry #$x\n"; + if ($hashRef->{Source} eq "EventLog") { + Win32::EventLog::GetMessageText($hashRef); + print "Entry $x: $hashRef->{Message}\n"; + } + $x++; + } + +=head1 Example 2 + +To backup and clear the EventLogs on a remote machine, do the following :- + + use Win32::EventLog; + + $myServer="\\\\my-server"; # your servername here. + my($date)=join("-", ((split(/\s+/, scalar(localtime)))[0,1,2,4])); + my($dest); + + for my $eventLog ("Application", "System", "Security") { + $handle=Win32::EventLog->new($eventLog, $myServer) + or die "Can't open Application EventLog on $myServer\n"; + + $dest="C:\\BackupEventLogs\\$eventLog\\$date.evt"; + $handle->Backup($dest) + or warn "Could not backup and clear the $eventLog EventLog on $myServer ($^E)\n"; + + $handle->Close; + } + +Note that only the Clear method is required. Note also that if the +file $dest exists, the function will fail. + +=head1 BUGS + +None currently known. + +The test script for 'make test' should be re-written to use the +EventLog object. + +=head1 AUTHOR + +Original code by Jesse Dougherty for HiP Communications. Additional +fixes and updates attributed to Martin Pauley +) and Bret Giddings (bret@essex.ac.uk). diff --git a/Master/tlpkg/tlperl/lib/Win32/File.pm b/Master/tlpkg/tlperl/lib/Win32/File.pm new file mode 100644 index 00000000000..d67a25448c8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/File.pm @@ -0,0 +1,118 @@ +package Win32::File; + +# +# File.pm +# Written by Douglas_Lankshear@ActiveWare.com +# +# subsequent hacks: +# Gurusamy Sarathy +# + +$VERSION = '0.05'; + +require Exporter; +require DynaLoader; + +@ISA= qw( Exporter DynaLoader ); +@EXPORT = qw( + ARCHIVE + COMPRESSED + DIRECTORY + HIDDEN + NORMAL + OFFLINE + READONLY + SYSTEM + TEMPORARY + ); +@EXPORT_OK = qw(GetAttributes SetAttributes); + +=head1 NAME + +Win32::File - manage file attributes in perl + +=head1 SYNOPSIS + + use Win32::File; + +=head1 DESCRIPTION + +This module offers the retrieval and setting of file attributes. + +=head1 Functions + +=head2 NOTE + +All of the functions return FALSE (0) if they fail, unless otherwise noted. +The function names are exported into the caller's namespace by request. + +=over 10 + +=item GetAttributes(filename, returnedAttributes) + +Gets the attributes of a file or directory. returnedAttributes will be set +to the OR-ed combination of the filename attributes. + +=item SetAttributes(filename, newAttributes) + +Sets the attributes of a file or directory. newAttributes must be an OR-ed +combination of the attributes. + +=back + +=head1 Constants + +The following constants are exported by default. + +=over 10 + +=item ARCHIVE + +=item COMPRESSED + +=item DIRECTORY + +=item HIDDEN + +=item NORMAL + +=item OFFLINE + +=item READONLY + +=item SYSTEM + +=item TEMPORARY + +=back + +=cut + +sub AUTOLOAD +{ + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname); + if($! != 0) + { + if($! =~ /Invalid/) + { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else + { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::File macro $constname, used in $file at line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::File; + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm b/Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm new file mode 100644 index 00000000000..6c6e5865336 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm @@ -0,0 +1,308 @@ +package Win32::FileSecurity; + +# +# FileSecurity.pm +# By Monte Mitzelfelt, monte@conchas.nm.org +# Larry Wall's Artistic License applies to all related Perl +# and C code for this module +# Thanks to the guys at ActiveWare! +# ver 0.67 ALPHA 1997.07.07 +# + +require Exporter; +require DynaLoader; +use Carp ; + +$VERSION = '1.04'; + +require Win32 unless defined &Win32::IsWinNT; +croak "The Win32::FileSecurity module works only on Windows NT" unless Win32::IsWinNT(); + +@ISA= qw( Exporter DynaLoader ); + +require Exporter ; +require DynaLoader ; + +@ISA = qw(Exporter DynaLoader) ; +@EXPORT_OK = qw( + Get + Set + EnumerateRights + MakeMask + DELETE + READ_CONTROL + WRITE_DAC + WRITE_OWNER + SYNCHRONIZE + STANDARD_RIGHTS_REQUIRED + STANDARD_RIGHTS_READ + STANDARD_RIGHTS_WRITE + STANDARD_RIGHTS_EXECUTE + STANDARD_RIGHTS_ALL + SPECIFIC_RIGHTS_ALL + ACCESS_SYSTEM_SECURITY + MAXIMUM_ALLOWED + GENERIC_READ + GENERIC_WRITE + GENERIC_EXECUTE + GENERIC_ALL + F + FULL + R + READ + C + CHANGE + A + ADD + ) ; + +sub AUTOLOAD { + local($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + $val = constant($constname); + if($! != 0) { + if($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::FileSecurity macro " + ."$constname, used in $file at line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::FileSecurity; + +1; + +__END__ + +=head1 NAME + +Win32::FileSecurity - manage FileSecurity Discretionary Access Control Lists in perl + +=head1 SYNOPSIS + + use Win32::FileSecurity; + +=head1 DESCRIPTION + +This module offers control over the administration of system FileSecurity DACLs. +You may want to use Get and EnumerateRights to get an idea of what mask values +correspond to what rights as viewed from File Manager. + +=head1 CONSTANTS + + DELETE, READ_CONTROL, WRITE_DAC, WRITE_OWNER, + SYNCHRONIZE, STANDARD_RIGHTS_REQUIRED, + STANDARD_RIGHTS_READ, STANDARD_RIGHTS_WRITE, + STANDARD_RIGHTS_EXECUTE, STANDARD_RIGHTS_ALL, + SPECIFIC_RIGHTS_ALL, ACCESS_SYSTEM_SECURITY, + MAXIMUM_ALLOWED, GENERIC_READ, GENERIC_WRITE, + GENERIC_EXECUTE, GENERIC_ALL, F, FULL, R, READ, + C, CHANGE + +=head1 FUNCTIONS + +=head2 NOTE: + +All of the functions return false if they fail, unless otherwise noted. +Errors returned via $! containing both Win32 GetLastError() and a text message +indicating Win32 function that failed. + +=over 10 + +=item constant( $name, $set ) + +Stores the value of named constant $name into $set. +Same as C<$set = Win32::FileSecurity::NAME_OF_CONSTANT();>. + +=item Get( $filename, \%permisshash ) + +Gets the DACLs of a file or directory. + +=item Set( $filename, \%permisshash ) + +Sets the DACL for a file or directory. + +=item EnumerateRights( $mask, \@rightslist ) + +Turns the bitmask in $mask into a list of strings in @rightslist. + +=item MakeMask( qw( DELETE READ_CONTROL ) ) + +Takes a list of strings representing constants and returns a bitmasked +integer value. + +=back + +=head2 %permisshash + +Entries take the form $permisshash{USERNAME} = $mask ; + +=head1 EXAMPLE1 + + # Gets the rights for all files listed on the command line. + use Win32::FileSecurity qw(Get EnumerateRights); + + foreach( @ARGV ) { + next unless -e $_ ; + if ( Get( $_, \%hash ) ) { + while( ($name, $mask) = each %hash ) { + print "$name:\n\t"; + EnumerateRights( $mask, \@happy ) ; + print join( "\n\t", @happy ), "\n"; + } + } + else { + print( "Error #", int( $! ), ": $!" ) ; + } + } + +=head1 EXAMPLE2 + + # Gets existing DACL and modifies Administrator rights + use Win32::FileSecurity qw(MakeMask Get Set); + + # These masks show up as Full Control in File Manager + $file = MakeMask( qw( FULL ) ); + + $dir = MakeMask( qw( + FULL + GENERIC_ALL + ) ); + + foreach( @ARGV ) { + s/\\$//; + next unless -e; + Get( $_, \%hash ) ; + $hash{Administrator} = ( -d ) ? $dir : $file ; + Set( $_, \%hash ) ; + } + +=head1 COMMON MASKS FROM CACLS AND WINFILE + +=head2 READ + + MakeMask( qw( FULL ) ); # for files + MakeMask( qw( READ GENERIC_READ GENERIC_EXECUTE ) ); # for directories + +=head2 CHANGE + + MakeMask( qw( CHANGE ) ); # for files + MakeMask( qw( CHANGE GENERIC_WRITE GENERIC_READ GENERIC_EXECUTE ) ); # for directories + +=head2 ADD & READ + + MakeMask( qw( ADD GENERIC_READ GENERIC_EXECUTE ) ); # for directories only! + +=head2 FULL + + MakeMask( qw( FULL ) ); # for files + MakeMask( qw( FULL GENERIC_ALL ) ); # for directories + +=head1 RESOURCES + +From Microsoft: check_sd + http://premium.microsoft.com/download/msdn/samples/2760.exe + +(thanks to Guert Schimmel at Sybase for turning me on to this one) + +=head1 VERSION + +1.03 ALPHA 97-12-14 + +=head1 REVISION NOTES + +=over 10 + +=item 1.03 ALPHA 1998.01.11 + +Imported diffs from 0.67 (parent) version + +=item 1.02 ALPHA 1997.12.14 + +Pod fixes, @EXPORT list additions + +Fix unitialized vars on unknown ACLs + +=item 1.01 ALPHA 1997.04.25 + +CORE Win32 version imported from 0.66 + +=item 0.67 ALPHA 1997.07.07 + +Kludged bug in mapping bits to separate ACE's. Notably, this screwed +up CHANGE access by leaving out a delete bit in the +C Access Control Entry. + +May need to rethink... + +=item 0.66 ALPHA 1997.03.13 + +Fixed bug in memory allocation check + +=item 0.65 ALPHA 1997.02.25 + +Tested with 5.003 build 303 + +Added ISA exporter, and @EXPORT_OK + +Added F, FULL, R, READ, C, CHANGE as composite pre-built mask names. + +Added server\ to keys returned in hash from Get + +Made constants and MakeMask case insensitive (I don't know why I did that) + +Fixed mask comparison in ListDacl and Enumerate Rights from simple & mask +to exact bit match ! ( ( x & y ) ^ x ) makes sure all bits in x +are set in y + +Fixed some "wild" pointers + +=item 0.60 ALPHA 1996.07.31 + +Now suitable for file and directory permissions + +Included ListDacl.exe in bundle for debugging + +Added "intuitive" inheritance for directories, basically functions like FM +triggered by presence of GENERIC_ rights this may need to change + +see EXAMPLE2 + +Changed from AddAccessAllowedAce to AddAce for control over inheritance + +=item 0.51 ALPHA 1996.07.20 + +Fixed memory allocation bug + +=item 0.50 ALPHA 1996.07.29 + +Base functionality + +Using AddAccessAllowedAce + +Suitable for file permissions + +=back + +=head1 KNOWN ISSUES / BUGS + +=over 10 + +=item 1 + +May not work on remote drives. + +=item 2 + +Errors croak, don't return via $! as documented. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/IPC.pm b/Master/tlpkg/tlperl/lib/Win32/IPC.pm new file mode 100644 index 00000000000..c97279b24c5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/IPC.pm @@ -0,0 +1,195 @@ +#--------------------------------------------------------------------- +package Win32::IPC; +# +# Copyright 1998 Christopher J. Madsen +# +# Created: 3 Feb 1998 from the ActiveWare version +# (c) 1995 Microsoft Corporation. All rights reserved. +# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com +# +# Other modifications (c) 1997 by Gurusamy Sarathy +# +# Author: Christopher J. Madsen +# Version: 1.03 (11-Jul-2003) +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# Base class for Win32 synchronization objects +#--------------------------------------------------------------------- + +$VERSION = '1.03'; + +require Exporter; +require DynaLoader; +use strict; +use vars qw($AUTOLOAD $VERSION @ISA @EXPORT @EXPORT_OK); + +@ISA = qw(Exporter DynaLoader); +@EXPORT = qw( + INFINITE + WaitForMultipleObjects +); +@EXPORT_OK = qw( + wait_any wait_all +); + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + local $! = 0; + my $val = constant($constname); + if ($! != 0) { + my ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::IPC macro $constname, used at $file line $line."; + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} # end AUTOLOAD + +bootstrap Win32::IPC; + +# How's this for cryptic? Use wait_any or wait_all! +sub WaitForMultipleObjects +{ + my $result = (($_[1] ? wait_all($_[0], $_[2]) + : wait_any($_[0], $_[2])) + ? 1 + : 0); + @{$_[0]} = (); # Bug for bug compatibility! Use wait_any or wait_all! + $result; +} # end WaitForMultipleObjects + +1; +__END__ + +=head1 NAME + +Win32::IPC - Base class for Win32 synchronization objects + +=head1 SYNOPSIS + + use Win32::Event 1.00 qw(wait_any); + #Create objects. + + wait_any(@ListOfObjects,$timeout); + +=head1 DESCRIPTION + +This module is loaded by the other Win32 synchronization modules. You +shouldn't need to load it yourself. It supplies the wait functions to +those modules. + +The synchronization modules are L<"Win32::ChangeNotify">, +L<"Win32::Event">, L<"Win32::Mutex">, & L<"Win32::Semaphore">. + +In addition, you can use C and C with +L<"Win32::Console"> and L<"Win32::Process"> objects. (However, those +modules do not export the wait functions; you must load one of the +synchronization modules (or just Win32::IPC)). + +=head2 Methods + +B supplies one method to all synchronization objects. + +=over 4 + +=item $obj->wait([$timeout]) + +Waits for C<$obj> to become signalled. C<$timeout> is the maximum time +to wait (in milliseconds). If C<$timeout> is omitted, waits forever. +If C<$timeout> is 0, returns immediately. + +Returns: + + +1 The object is signalled + -1 The object is an abandoned mutex + 0 Timed out + undef An error occurred + +=back + +=head2 Functions + +=over 4 + +=item wait_any(@objects, [$timeout]) + +Waits for at least one of the C<@objects> to become signalled. +C<$timeout> is the maximum time to wait (in milliseconds). If +C<$timeout> is omitted, waits forever. If C<$timeout> is 0, returns +immediately. + +The return value indicates which object ended the wait: + + +N $object[N-1] is signalled + -N $object[N-1] is an abandoned mutex + 0 Timed out + undef An error occurred + +If more than one object became signalled, the one with the lowest +index is used. + +=item wait_all(@objects, [$timeout]) + +This is the same as C, but it waits for all the C<@objects> +to become signalled. The return value indicates the last object to +become signalled, and is negative if at least one of the C<@objects> +is an abandoned mutex. + +=back + +=head2 Deprecated Functions and Methods + +B still supports the ActiveWare syntax, but its use is +deprecated. + +=over 4 + +=item INFINITE + +Constant value for an infinite timeout. Omit the C<$timeout> argument +instead. + +=item WaitForMultipleObjects(\@objects, $wait_all, $timeout) + +Warning: C erases C<@objects>! +Use C or C instead. + +=item $obj->Wait($timeout) + +Similar to Cwait($timeout)>. + +=back + +=head1 INTERNALS + +The C and C functions support two kinds of +objects. Objects derived from C are expected to consist +of a reference to a scalar containing the Win32 HANDLE as an IV. + +Other objects (for which C is +false), are expected to implement a C method. +When called in scalar context with no arguments, this method should +return a Win32 HANDLE (as an IV) suitable for passing to the Win32 +WaitForMultipleObjects API function. + +=head1 AUTHOR + +Christopher J. Madsen EFE + +Loosely based on the original module by ActiveWare Internet Corp., +F + +=cut + +# Local Variables: +# tmtrack-file-task: "Win32::IPC" +# End: diff --git a/Master/tlpkg/tlperl/lib/Win32/Internet.pm b/Master/tlpkg/tlperl/lib/Win32/Internet.pm new file mode 100644 index 00000000000..f6dac3130af --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Internet.pm @@ -0,0 +1,3009 @@ +####################################################################### +# +# Win32::Internet - Perl Module for Internet Extensions +# ^^^^^^^^^^^^^^^ +# This module creates an object oriented interface to the Win32 +# Internet Functions (WININET.DLL). +# +# Version: 0.08 (14 Feb 1997) +# Version: 0.081 (25 Sep 1999) +# Version: 0.082 (04 Sep 2001) +# +####################################################################### + +# changes: +# - fixed 2 bugs in Option(s) related subs +# - works with build 30x also + +package Win32::Internet; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. + +# use Win32::WinError; # for windows constants. + +@ISA= qw( Exporter DynaLoader ); +@EXPORT = qw( + HTTP_ADDREQ_FLAG_ADD + HTTP_ADDREQ_FLAG_REPLACE + HTTP_QUERY_ALLOW + HTTP_QUERY_CONTENT_DESCRIPTION + HTTP_QUERY_CONTENT_ID + HTTP_QUERY_CONTENT_LENGTH + HTTP_QUERY_CONTENT_TRANSFER_ENCODING + HTTP_QUERY_CONTENT_TYPE + HTTP_QUERY_COST + HTTP_QUERY_CUSTOM + HTTP_QUERY_DATE + HTTP_QUERY_DERIVED_FROM + HTTP_QUERY_EXPIRES + HTTP_QUERY_FLAG_REQUEST_HEADERS + HTTP_QUERY_FLAG_SYSTEMTIME + HTTP_QUERY_LANGUAGE + HTTP_QUERY_LAST_MODIFIED + HTTP_QUERY_MESSAGE_ID + HTTP_QUERY_MIME_VERSION + HTTP_QUERY_PRAGMA + HTTP_QUERY_PUBLIC + HTTP_QUERY_RAW_HEADERS + HTTP_QUERY_RAW_HEADERS_CRLF + HTTP_QUERY_REQUEST_METHOD + HTTP_QUERY_SERVER + HTTP_QUERY_STATUS_CODE + HTTP_QUERY_STATUS_TEXT + HTTP_QUERY_URI + HTTP_QUERY_USER_AGENT + HTTP_QUERY_VERSION + HTTP_QUERY_WWW_LINK + ICU_BROWSER_MODE + ICU_DECODE + ICU_ENCODE_SPACES_ONLY + ICU_ESCAPE + ICU_NO_ENCODE + ICU_NO_META + ICU_USERNAME + INTERNET_FLAG_PASSIVE + INTERNET_FLAG_ASYNC + INTERNET_HYPERLINK + INTERNET_FLAG_KEEP_CONNECTION + INTERNET_FLAG_MAKE_PERSISTENT + INTERNET_FLAG_NO_AUTH + INTERNET_FLAG_NO_AUTO_REDIRECT + INTERNET_FLAG_NO_CACHE_WRITE + INTERNET_FLAG_NO_COOKIES + INTERNET_FLAG_READ_PREFETCH + INTERNET_FLAG_RELOAD + INTERNET_FLAG_RESYNCHRONIZE + INTERNET_FLAG_TRANSFER_ASCII + INTERNET_FLAG_TRANSFER_BINARY + INTERNET_INVALID_PORT_NUMBER + INTERNET_INVALID_STATUS_CALLBACK + INTERNET_OPEN_TYPE_DIRECT + INTERNET_OPEN_TYPE_PROXY + INTERNET_OPEN_TYPE_PROXY_PRECONFIG + INTERNET_OPTION_CONNECT_BACKOFF + INTERNET_OPTION_CONNECT_RETRIES + INTERNET_OPTION_CONNECT_TIMEOUT + INTERNET_OPTION_CONTROL_SEND_TIMEOUT + INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT + INTERNET_OPTION_DATA_SEND_TIMEOUT + INTERNET_OPTION_DATA_RECEIVE_TIMEOUT + INTERNET_OPTION_HANDLE_SIZE + INTERNET_OPTION_LISTEN_TIMEOUT + INTERNET_OPTION_PASSWORD + INTERNET_OPTION_READ_BUFFER_SIZE + INTERNET_OPTION_USER_AGENT + INTERNET_OPTION_USERNAME + INTERNET_OPTION_VERSION + INTERNET_OPTION_WRITE_BUFFER_SIZE + INTERNET_SERVICE_FTP + INTERNET_SERVICE_GOPHER + INTERNET_SERVICE_HTTP + INTERNET_STATUS_CLOSING_CONNECTION + INTERNET_STATUS_CONNECTED_TO_SERVER + INTERNET_STATUS_CONNECTING_TO_SERVER + INTERNET_STATUS_CONNECTION_CLOSED + INTERNET_STATUS_HANDLE_CLOSING + INTERNET_STATUS_HANDLE_CREATED + INTERNET_STATUS_NAME_RESOLVED + INTERNET_STATUS_RECEIVING_RESPONSE + INTERNET_STATUS_REDIRECT + INTERNET_STATUS_REQUEST_COMPLETE + INTERNET_STATUS_REQUEST_SENT + INTERNET_STATUS_RESOLVING_NAME + INTERNET_STATUS_RESPONSE_RECEIVED + INTERNET_STATUS_SENDING_REQUEST +); + + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + + # [dada] This results in an ugly Autoloader error + #if ($! =~ /Invalid/) { + # $AutoLoader::AUTOLOAD = $AUTOLOAD; + # goto &AutoLoader::AUTOLOAD; + #} else { + + # [dada] ... I prefer this one :) + + ($pack,$file,$line) = caller; undef $pack; + die "Win32::Internet::$constname is not defined, used at $file line $line."; + + #} + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# STATIC OBJECT PROPERTIES +# +$VERSION = "0.082"; + +%callback_code = (); +%callback_info = (); + + +####################################################################### +# PUBLIC METHODS +# + +#======== ### CLASS CONSTRUCTOR +sub new { +#======== + my($class, $useragent, $opentype, $proxy, $proxybypass, $flags) = @_; + my $self = {}; + + if(ref($useragent) and ref($useragent) eq "HASH") { + $opentype = $useragent->{'opentype'}; + $proxy = $useragent->{'proxy'}; + $proxybypass = $useragent->{'proxybypass'}; + $flags = $useragent->{'flags'}; + my $myuseragent = $useragent->{'useragent'}; + undef $useragent; + $useragent = $myuseragent; + } + + $useragent = "Perl-Win32::Internet/".$VERSION unless defined($useragent); + $opentype = constant("INTERNET_OPEN_TYPE_DIRECT",0) unless defined($opentype); + $proxy = "" unless defined($proxy); + $proxybypass = "" unless defined($proxybypass); + $flags = 0 unless defined($flags); + + + my $handle = InternetOpen($useragent, $opentype, $proxy, $proxybypass, $flags); + if ($handle) { + $self->{'connections'} = 0; + $self->{'pasv'} = 0; + $self->{'handle'} = $handle; + $self->{'useragent'} = $useragent; + $self->{'proxy'} = $proxy; + $self->{'proxybypass'} = $proxybypass; + $self->{'flags'} = $flags; + $self->{'Type'} = "Internet"; + + # [dada] I think it's better to call SetStatusCallback explicitly... + #if($flags & constant("INTERNET_FLAG_ASYNC",0)) { + # my $callbackresult=InternetSetStatusCallback($handle); + # if($callbackresult==&constant("INTERNET_INVALID_STATUS_CALLBACK",0)) { + # $self->{'Error'} = -2; + # } + #} + + bless $self; + } else { + $self->{'handle'} = undef; + bless $self; + } + $self; +} + + +#============ +sub OpenURL { +#============ + my($self,$new,$URL) = @_; + return undef unless ref($self); + + my $newhandle=InternetOpenUrl($self->{'handle'},$URL,"",0,0,0); + if(!$newhandle) { + $self->{'Error'} = "Cannot open URL."; + return undef; + } else { + $self->{'connections'}++; + $_[1] = _new($newhandle); + $_[1]->{'Type'} = "URL"; + $_[1]->{'URL'} = $URL; + return $newhandle; + } +} + + +#================ +sub TimeConvert { +#================ + my($self, $sec, $min, $hour, $day, $mon, $year, $wday, $rfc) = @_; + return undef unless ref($self); + + if(!defined($rfc)) { + return InternetTimeToSystemTime($sec); + } else { + return InternetTimeFromSystemTime($sec, $min, $hour, + $day, $mon, $year, + $wday, $rfc); + } +} + + +#======================= +sub QueryDataAvailable { +#======================= + my($self) = @_; + return undef unless ref($self); + + return InternetQueryDataAvailable($self->{'handle'}); +} + + +#============= +sub ReadFile { +#============= + my($self, $buffersize) = @_; + return undef unless ref($self); + + my $howmuch = InternetQueryDataAvailable($self->{'handle'}); + $buffersize = $howmuch unless defined($buffersize); + return InternetReadFile($self->{'handle'}, ($howmuch<$buffersize) ? $howmuch + : $buffersize); +} + + +#=================== +sub ReadEntireFile { +#=================== + my($handle) = @_; + my $content = ""; + my $buffersize = 16000; + my $howmuch = 0; + my $buffer = ""; + + $handle = $handle->{'handle'} if defined($handle) and ref($handle); + + $howmuch = InternetQueryDataAvailable($handle); + # print "\nReadEntireFile: $howmuch bytes to read...\n"; + + while($howmuch>0) { + $buffer = InternetReadFile($handle, ($howmuch<$buffersize) ? $howmuch + : $buffersize); + # print "\nReadEntireFile: ", length($buffer), " bytes read...\n"; + + if(!defined($buffer)) { + return undef; + } else { + $content .= $buffer; + } + $howmuch = InternetQueryDataAvailable($handle); + # print "\nReadEntireFile: still $howmuch bytes to read...\n"; + + } + return $content; +} + + +#============= +sub FetchURL { +#============= + # (OpenURL+Read+Close)... + my($self, $URL) = @_; + return undef unless ref($self); + + my $newhandle = InternetOpenUrl($self->{'handle'}, $URL, "", 0, 0, 0); + if(!$newhandle) { + $self->{'Error'} = "Cannot open URL."; + return undef; + } else { + my $content = ReadEntireFile($newhandle); + InternetCloseHandle($newhandle); + return $content; + } +} + + +#================ +sub Connections { +#================ + my($self) = @_; + return undef unless ref($self); + + return $self->{'connections'} if $self->{'Type'} eq "Internet"; + return undef; +} + + +#================ +sub GetResponse { +#================ + my($num, $text) = InternetGetLastResponseInfo(); + return $text; +} + +#=========== +sub Option { +#=========== + my($self, $option, $value) = @_; + return undef unless ref($self); + + my $retval = 0; + + $option = constant("INTERNET_OPTION_USER_AGENT", 0) unless defined($option); + + if(!defined($value)) { + $retval = InternetQueryOption($self->{'handle'}, $option); + } else { + $retval = InternetSetOption($self->{'handle'}, $option, $value); + } + return $retval; +} + + +#============== +sub UserAgent { +#============== + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_USER_AGENT", 0), $value); +} + + +#============= +sub Username { +#============= + my($self, $value) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") { + $self->{'Error'} = "Username() only on FTP or HTTP sessions."; + return undef; + } + + return Option($self, constant("INTERNET_OPTION_USERNAME", 0), $value); +} + + +#============= +sub Password { +#============= + my($self, $value)=@_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") { + $self->{'Error'} = "Password() only on FTP or HTTP sessions."; + return undef; + } + + return Option($self, constant("INTERNET_OPTION_PASSWORD", 0), $value); +} + + +#=================== +sub ConnectTimeout { +#=================== + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONNECT_TIMEOUT", 0), $value); +} + + +#=================== +sub ConnectRetries { +#=================== + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONNECT_RETRIES", 0), $value); +} + + +#=================== +sub ConnectBackoff { +#=================== + my($self,$value)=@_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONNECT_BACKOFF", 0), $value); +} + + +#==================== +sub DataSendTimeout { +#==================== + my($self,$value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_DATA_SEND_TIMEOUT", 0), $value); +} + + +#======================= +sub DataReceiveTimeout { +#======================= + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_DATA_RECEIVE_TIMEOUT", 0), $value); +} + + +#========================== +sub ControlReceiveTimeout { +#========================== + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT", 0), $value); +} + + +#======================= +sub ControlSendTimeout { +#======================= + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONTROL_SEND_TIMEOUT", 0), $value); +} + + +#================ +sub QueryOption { +#================ + my($self, $option) = @_; + return undef unless ref($self); + + return InternetQueryOption($self->{'handle'}, $option); +} + + +#============== +sub SetOption { +#============== + my($self, $option, $value) = @_; + return undef unless ref($self); + + return InternetSetOption($self->{'handle'}, $option, $value); +} + + +#============= +sub CrackURL { +#============= + my($self, $URL, $flags) = @_; + return undef unless ref($self); + + $flags = constant("ICU_ESCAPE", 0) unless defined($flags); + + my @newurl = InternetCrackUrl($URL, $flags); + + if(!defined($newurl[0])) { + $self->{'Error'} = "Cannot crack URL."; + return undef; + } else { + return @newurl; + } +} + + +#============== +sub CreateURL { +#============== + my($self, $scheme, $hostname, $port, + $username, $password, + $path, $extrainfo, $flags) = @_; + return undef unless ref($self); + + if(ref($scheme) and ref($scheme) eq "HASH") { + $flags = $hostname; + $hostname = $scheme->{'hostname'}; + $port = $scheme->{'port'}; + $username = $scheme->{'username'}; + $password = $scheme->{'password'}; + $path = $scheme->{'path'}; + $extrainfo = $scheme->{'extrainfo'}; + my $myscheme = $scheme->{'scheme'}; + undef $scheme; + $scheme = $myscheme; + } + + $hostname = "" unless defined($hostname); + $port = 0 unless defined($port); + $username = "" unless defined($username); + $password = "" unless defined($password); + $path = "" unless defined($path); + $extrainfo = "" unless defined($extrainfo); + $flags = constant("ICU_ESCAPE", 0) unless defined($flags); + + my $newurl = InternetCreateUrl($scheme, $hostname, $port, + $username, $password, + $path, $extrainfo, $flags); + if(!defined($newurl)) { + $self->{'Error'} = "Cannot create URL."; + return undef; + } else { + return $newurl; + } +} + + +#==================== +sub CanonicalizeURL { +#==================== + my($self, $URL, $flags) = @_; + return undef unless ref($self); + + my $newurl = InternetCanonicalizeUrl($URL, $flags); + if(!defined($newurl)) { + $self->{'Error'} = "Cannot canonicalize URL."; + return undef; + } else { + return $newurl; + } +} + + +#=============== +sub CombineURL { +#=============== + my($self, $baseURL, $relativeURL, $flags) = @_; + return undef unless ref($self); + + my $newurl = InternetCombineUrl($baseURL, $relativeURL, $flags); + if(!defined($newurl)) { + $self->{'Error'} = "Cannot combine URL(s)."; + return undef; + } else { + return $newurl; + } +} + + +#====================== +sub SetStatusCallback { +#====================== + my($self) = @_; + return undef unless ref($self); + + my $callback = InternetSetStatusCallback($self->{'handle'}); + print "callback=$callback, constant=",constant("INTERNET_INVALID_STATUS_CALLBACK", 0), "\n"; + if($callback == constant("INTERNET_INVALID_STATUS_CALLBACK", 0)) { + return undef; + } else { + return $callback; + } +} + + +#====================== +sub GetStatusCallback { +#====================== + my($self, $context) = @_; + $context = $self if not defined $context; + return($callback_code{$context}, $callback_info{$context}); +} + + +#========== +sub Error { +#========== + my($self) = @_; + return undef unless ref($self); + + require Win32 unless defined &Win32::GetLastError; + my $errtext = ""; + my $tmp = ""; + my $errnum = Win32::GetLastError(); + + if($errnum < 12000) { + $errtext = Win32::FormatMessage($errnum); + $errtext =~ s/[\r\n]//g; + } elsif($errnum == 12003) { + ($tmp, $errtext) = InternetGetLastResponseInfo(); + chomp $errtext; + 1 while($errtext =~ s/(.*)\n//); # the last line should be significative... + # otherwise call GetResponse() to get it whole + } elsif($errnum >= 12000) { + $errtext = FormatMessage($errnum); + $errtext =~ s/[\r\n]//g; + } else { + $errtext="Error"; + } + if($errnum == 0 and defined($self->{'Error'})) { + if($self->{'Error'} == -2) { + $errnum = -2; + $errtext = "Asynchronous operations not available."; + } else { + $errnum = -1; + $errtext = $self->{'Error'}; + } + } + return (wantarray)? ($errnum, $errtext) : "\[".$errnum."\] ".$errtext; +} + + +#============ +sub Version { +#============ + my $dll = InternetDllVersion(); + $dll =~ s/\0//g; + return (wantarray)? ($Win32::Internet::VERSION, $dll) + : $Win32::Internet::VERSION."/".$dll; +} + + +#========== +sub Close { +#========== + my($self, $handle) = @_; + if(!defined($handle)) { + return undef unless ref($self); + $handle = $self->{'handle'}; + } + InternetCloseHandle($handle); +} + + + +####################################################################### +# FTP CLASS METHODS +# + +#======== ### FTP CONSTRUCTOR +sub FTP { +#======== + my($self, $new, $server, $username, $password, $port, $pasv, $context) = @_; + return undef unless ref($self); + + if(ref($server) and ref($server) eq "HASH") { + $port = $server->{'port'}; + $username = $server->{'username'}; + $password = $password->{'host'}; + my $myserver = $server->{'server'}; + $pasv = $server->{'pasv'}; + $context = $server->{'context'}; + undef $server; + $server = $myserver; + } + + $server = "" unless defined($server); + $username = "anonymous" unless defined($username); + $password = "" unless defined($password); + $port = 21 unless defined($port); + $context = 0 unless defined($context); + + $pasv = $self->{'pasv'} unless defined $pasv; + $pasv = $pasv ? constant("INTERNET_FLAG_PASSIVE",0) : 0; + + my $newhandle = InternetConnect($self->{'handle'}, $server, $port, + $username, $password, + constant("INTERNET_SERVICE_FTP", 0), + $pasv, $context); + if($newhandle) { + $self->{'connections'}++; + $_[1] = _new($newhandle); + $_[1]->{'Type'} = "FTP"; + $_[1]->{'Mode'} = "bin"; + $_[1]->{'pasv'} = $pasv; + $_[1]->{'username'} = $username; + $_[1]->{'password'} = $password; + $_[1]->{'server'} = $server; + return $newhandle; + } else { + return undef; + } +} + +#======== +sub Pwd { +#======== + my($self) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { + $self->{'Error'} = "Pwd() only on FTP sessions."; + return undef; + } + + return FtpGetCurrentDirectory($self->{'handle'}); +} + + +#======= +sub Cd { +#======= + my($self, $path) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" || !defined($self->{'handle'})) { + $self->{'Error'} = "Cd() only on FTP sessions."; + return undef; + } + + my $retval = FtpSetCurrentDirectory($self->{'handle'}, $path); + if(!defined($retval)) { + return undef; + } else { + return $path; + } +} +#==================== +sub Cwd { Cd(@_); } +sub Chdir { Cd(@_); } +#==================== + + +#========== +sub Mkdir { +#========== + my($self, $path) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { + $self->{'Error'} = "Mkdir() only on FTP sessions."; + return undef; + } + + my $retval = FtpCreateDirectory($self->{'handle'}, $path); + $self->{'Error'} = "Can't create directory." unless defined($retval); + return $retval; +} +#==================== +sub Md { Mkdir(@_); } +#==================== + + +#========= +sub Mode { +#========= + my($self, $value) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { + $self->{'Error'} = "Mode() only on FTP sessions."; + return undef; + } + + if(!defined($value)) { + return $self->{'Mode'}; + } else { + my $modesub = ($value =~ /^a/i) ? "Ascii" : "Binary"; + $self->$modesub($_[0]); + } + return $self->{'Mode'}; +} + + +#========== +sub Rmdir { +#========== + my($self, $path) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { + $self->{'Error'} = "Rmdir() only on FTP sessions."; + return undef; + } + my $retval = FtpRemoveDirectory($self->{'handle'}, $path); + $self->{'Error'} = "Can't remove directory." unless defined($retval); + return $retval; +} +#==================== +sub Rd { Rmdir(@_); } +#==================== + + +#========= +sub Pasv { +#========= + my($self, $value) = @_; + return undef unless ref($self); + + if(defined($value) and $self->{'Type'} eq "Internet") { + if($value == 0) { + $self->{'pasv'} = 0; + } else { + $self->{'pasv'} = 1; + } + } + return $self->{'pasv'}; +} + +#========= +sub List { +#========= + my($self, $pattern, $retmode) = @_; + return undef unless ref($self); + + my $retval = ""; + my $size = ""; + my $attr = ""; + my $ctime = ""; + my $atime = ""; + my $mtime = ""; + my $csec = 0; my $cmin = 0; my $chou = 0; my $cday = 0; my $cmon = 0; my $cyea = 0; + my $asec = 0; my $amin = 0; my $ahou = 0; my $aday = 0; my $amon = 0; my $ayea = 0; + my $msec = 0; my $mmin = 0; my $mhou = 0; my $mday = 0; my $mmon = 0; my $myea = 0; + my $newhandle = 0; + my $nextfile = 1; + my @results = (); + my ($filename, $altname, $file); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "List() only on FTP sessions."; + return undef; + } + + $pattern = "" unless defined($pattern); + $retmode = 1 unless defined($retmode); + + if($retmode == 2) { + + ( $newhandle,$filename, $altname, $size, $attr, + $csec, $cmin, $chou, $cday, $cmon, $cyea, + $asec, $amin, $ahou, $aday, $amon, $ayea, + $msec, $mmin, $mhou, $mday, $mmon, $myea + ) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0); + + if(!$newhandle) { + $self->{'Error'} = "Can't read FTP directory."; + return undef; + } else { + + while($nextfile) { + $ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea)); + $atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea)); + $mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea)); + push(@results, $filename, $altname, $size, $attr, $ctime, $atime, $mtime); + + ( $nextfile, $filename, $altname, $size, $attr, + $csec, $cmin, $chou, $cday, $cmon, $cyea, + $asec, $amin, $ahou, $aday, $amon, $ayea, + $msec, $mmin, $mhou, $mday, $mmon, $myea + ) = InternetFindNextFile($newhandle); + + } + InternetCloseHandle($newhandle); + return @results; + + } + + } elsif($retmode == 3) { + + ( $newhandle,$filename, $altname, $size, $attr, + $csec, $cmin, $chou, $cday, $cmon, $cyea, + $asec, $amin, $ahou, $aday, $amon, $ayea, + $msec, $mmin, $mhou, $mday, $mmon, $myea + ) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0); + + if(!$newhandle) { + $self->{'Error'} = "Can't read FTP directory."; + return undef; + + } else { + + while($nextfile) { + $ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea)); + $atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea)); + $mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea)); + $file = { "name" => $filename, + "altname" => $altname, + "size" => $size, + "attr" => $attr, + "ctime" => $ctime, + "atime" => $atime, + "mtime" => $mtime, + }; + push(@results, $file); + + ( $nextfile, $filename, $altname, $size, $attr, + $csec, $cmin, $chou, $cday, $cmon, $cyea, + $asec, $amin, $ahou, $aday, $amon, $ayea, + $msec, $mmin, $mhou, $mday, $mmon, $myea + ) = InternetFindNextFile($newhandle); + + } + InternetCloseHandle($newhandle); + return @results; + } + + } else { + + ($newhandle, $filename) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0); + + if(!$newhandle) { + $self->{'Error'} = "Can't read FTP directory."; + return undef; + + } else { + + while($nextfile) { + push(@results, $filename); + + ($nextfile, $filename) = InternetFindNextFile($newhandle); + # print "List.no more files\n" if !$nextfile; + + } + InternetCloseHandle($newhandle); + return @results; + } + } +} +#==================== +sub Ls { List(@_); } +sub Dir { List(@_); } +#==================== + + +#================= +sub FileAttrInfo { +#================= + my($self,$attr) = @_; + my @attrinfo = (); + push(@attrinfo, "READONLY") if $attr & 1; + push(@attrinfo, "HIDDEN") if $attr & 2; + push(@attrinfo, "SYSTEM") if $attr & 4; + push(@attrinfo, "DIRECTORY") if $attr & 16; + push(@attrinfo, "ARCHIVE") if $attr & 32; + push(@attrinfo, "NORMAL") if $attr & 128; + push(@attrinfo, "TEMPORARY") if $attr & 256; + push(@attrinfo, "COMPRESSED") if $attr & 2048; + return (wantarray)? @attrinfo : join(" ", @attrinfo); +} + + +#=========== +sub Binary { +#=========== + my($self) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Binary() only on FTP sessions."; + return undef; + } + $self->{'Mode'} = "bin"; + return undef; +} +#====================== +sub Bin { Binary(@_); } +#====================== + + +#========== +sub Ascii { +#========== + my($self) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Ascii() only on FTP sessions."; + return undef; + } + $self->{'Mode'} = "asc"; + return undef; +} +#===================== +sub Asc { Ascii(@_); } +#===================== + + +#======== +sub Get { +#======== + my($self, $remote, $local, $overwrite, $flags, $context) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Get() only on FTP sessions."; + return undef; + } + my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2); + + $remote = "" unless defined($remote); + $local = $remote unless defined($local); + $overwrite = 0 unless defined($overwrite); + $flags = 0 unless defined($flags); + $context = 0 unless defined($context); + + my $retval = FtpGetFile($self->{'handle'}, + $remote, + $local, + $overwrite, + $flags, + $mode, + $context); + $self->{'Error'} = "Can't get file." unless defined($retval); + return $retval; +} + + +#=========== +sub Rename { +#=========== + my($self, $oldname, $newname) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Rename() only on FTP sessions."; + return undef; + } + + my $retval = FtpRenameFile($self->{'handle'}, $oldname, $newname); + $self->{'Error'} = "Can't rename file." unless defined($retval); + return $retval; +} +#====================== +sub Ren { Rename(@_); } +#====================== + + +#=========== +sub Delete { +#=========== + my($self, $filename) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Delete() only on FTP sessions."; + return undef; + } + my $retval = FtpDeleteFile($self->{'handle'}, $filename); + $self->{'Error'} = "Can't delete file." unless defined($retval); + return $retval; +} +#====================== +sub Del { Delete(@_); } +#====================== + + +#======== +sub Put { +#======== + my($self, $local, $remote, $context) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Put() only on FTP sessions."; + return undef; + } + my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2); + + $context = 0 unless defined($context); + + my $retval = FtpPutFile($self->{'handle'}, $local, $remote, $mode, $context); + $self->{'Error'} = "Can't put file." unless defined($retval); + return $retval; +} + + +####################################################################### +# HTTP CLASS METHODS +# + +#========= ### HTTP CONSTRUCTOR +sub HTTP { +#========= + my($self, $new, $server, $username, $password, $port, $flags, $context) = @_; + return undef unless ref($self); + + if(ref($server) and ref($server) eq "HASH") { + my $myserver = $server->{'server'}; + $username = $server->{'username'}; + $password = $password->{'host'}; + $port = $server->{'port'}; + $flags = $server->{'flags'}; + $context = $server->{'context'}; + undef $server; + $server = $myserver; + } + + $server = "" unless defined($server); + $username = "anonymous" unless defined($username); + $password = "" unless defined($password); + $port = 80 unless defined($port); + $flags = 0 unless defined($flags); + $context = 0 unless defined($context); + + my $newhandle = InternetConnect($self->{'handle'}, $server, $port, + $username, $password, + constant("INTERNET_SERVICE_HTTP", 0), + $flags, $context); + if($newhandle) { + $self->{'connections'}++; + $_[1] = _new($newhandle); + $_[1]->{'Type'} = "HTTP"; + $_[1]->{'username'} = $username; + $_[1]->{'password'} = $password; + $_[1]->{'server'} = $server; + $_[1]->{'accept'} = "text/*\0image/gif\0image/jpeg\0\0"; + return $newhandle; + } else { + return undef; + } +} + + +#================ +sub OpenRequest { +#================ + # alternatively to Request: + # it creates a new HTTP_Request object + # you can act upon it with AddHeader, SendRequest, ReadFile, QueryInfo, Close, ... + + my($self, $new, $path, $method, $version, $referer, $accept, $flags, $context) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP") { + $self->{'Error'} = "OpenRequest() only on HTTP sessions."; + return undef; + } + + if(ref($path) and ref($path) eq "HASH") { + $method = $path->{'method'}; + $version = $path->{'version'}; + $referer = $path->{'referer'}; + $accept = $path->{'accept'}; + $flags = $path->{'flags'}; + $context = $path->{'context'}; + my $mypath = $path->{'path'}; + undef $path; + $path = $mypath; + } + + $method = "GET" unless defined($method); + $path = "/" unless defined($path); + $version = "HTTP/1.0" unless defined($version); + $referer = "" unless defined($referer); + $accept = $self->{'accept'} unless defined($accept); + $flags = 0 unless defined($flags); + $context = 0 unless defined($context); + + $path = "/".$path if substr($path,0,1) ne "/"; + # accept string list needs to be terminated by double-NULL + $accept .= "\0\0" unless $accept =~ /\0\0\z/; + + my $newhandle = HttpOpenRequest($self->{'handle'}, + $method, + $path, + $version, + $referer, + $accept, + $flags, + $context); + if($newhandle) { + $_[1] = _new($newhandle); + $_[1]->{'Type'} = "HTTP_Request"; + $_[1]->{'method'} = $method; + $_[1]->{'request'} = $path; + $_[1]->{'accept'} = $accept; + return $newhandle; + } else { + return undef; + } +} + +#================ +sub SendRequest { +#================ + my($self, $postdata) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP_Request") { + $self->{'Error'} = "SendRequest() only on HTTP requests."; + return undef; + } + + $postdata = "" unless defined($postdata); + + return HttpSendRequest($self->{'handle'}, "", $postdata); +} + + +#============== +sub AddHeader { +#============== + my($self, $header, $flags) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP_Request") { + $self->{'Error'} = "AddHeader() only on HTTP requests."; + return undef; + } + + $flags = constant("HTTP_ADDREQ_FLAG_ADD", 0) if (!defined($flags) or $flags == 0); + + return HttpAddRequestHeaders($self->{'handle'}, $header, $flags); +} + + +#============== +sub QueryInfo { +#============== + my($self, $header, $flags) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP_Request") { + $self->{'Error'}="QueryInfo() only on HTTP requests."; + return undef; + } + + $flags = constant("HTTP_QUERY_CUSTOM", 0) if (!defined($flags) and defined($header)); + my @queryresult = HttpQueryInfo($self->{'handle'}, $flags, $header); + return (wantarray)? @queryresult : join(" ", @queryresult); +} + + +#============ +sub Request { +#============ + # HttpOpenRequest+HttpAddHeaders+HttpSendRequest+InternetReadFile+HttpQueryInfo + my($self, $path, $method, $version, $referer, $accept, $flags, $postdata) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP") { + $self->{'Error'} = "Request() only on HTTP sessions."; + return undef; + } + + if(ref($path) and ref($path) eq "HASH") { + $method = $path->{'method'}; + $version = $path->{'version'}; + $referer = $path->{'referer'}; + $accept = $path->{'accept'}; + $flags = $path->{'flags'}; + $postdata = $path->{'postdata'}; + my $mypath = $path->{'path'}; + undef $path; + $path = $mypath; + } + + my $content = ""; + my $result = ""; + my @queryresult = (); + my $statuscode = ""; + my $headers = ""; + + $path = "/" unless defined($path); + $method = "GET" unless defined($method); + $version = "HTTP/1.0" unless defined($version); + $referer = "" unless defined($referer); + $accept = $self->{'accept'} unless defined($accept); + $flags = 0 unless defined($flags); + $postdata = "" unless defined($postdata); + + $path = "/".$path if substr($path,0,1) ne "/"; + # accept string list needs to be terminated by double-NULL + $accept .= "\0\0" unless $accept =~ /\0\0\z/; + + my $newhandle = HttpOpenRequest($self->{'handle'}, + $method, + $path, + $version, + $referer, + $accept, + $flags, + 0); + + if($newhandle) { + + $result = HttpSendRequest($newhandle, "", $postdata); + + if(defined($result)) { + $statuscode = HttpQueryInfo($newhandle, + constant("HTTP_QUERY_STATUS_CODE", 0), ""); + $headers = HttpQueryInfo($newhandle, + constant("HTTP_QUERY_RAW_HEADERS_CRLF", 0), ""); + $content = ReadEntireFile($newhandle); + + InternetCloseHandle($newhandle); + + return($statuscode, $headers, $content); + } else { + return undef; + } + } else { + return undef; + } +} + + +####################################################################### +# END OF THE PUBLIC METHODS +# + + +#========= ### SUB-CLASSES CONSTRUCTOR +sub _new { +#========= + my $self = {}; + if ($_[0]) { + $self->{'handle'} = $_[0]; + bless $self; + } else { + undef($self); + } + $self; +} + + +#============ ### CLASS DESTRUCTOR +sub DESTROY { +#============ + my($self) = @_; + # print "Closing handle $self->{'handle'}...\n"; + InternetCloseHandle($self->{'handle'}); + # [dada] rest in peace +} + + +#============= +sub callback { +#============= + my($name, $status, $info) = @_; + $callback_code{$name} = $status; + $callback_info{$name} = $info; +} + +####################################################################### +# dynamically load in the Internet.pll module. +# + +bootstrap Win32::Internet; + +# Preloaded methods go here. + +#Currently Autoloading is not implemented in Perl for win32 +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ + +=head1 NAME + +Win32::Internet - Access to WININET.DLL functions + +=head1 INTRODUCTION + +This extension to Perl implements the Win32 Internet APIs (found in +F). They give a complete support for HTTP, FTP and GOPHER +connections. + +See the L<"Version History"> and the L<"Functions Table"> for a list +of the currently supported features. You should also get a copy of the +L<"Microsoft Win32 Internet Functions"> documentation. + +=head1 REFERENCE + +To use this module, first add the following line at the beginning of +your script: + + use Win32::Internet; + +Then you have to open an Internet connection with this command: + + $Connection = new Win32::Internet(); + +This is required to use any of the function of this module. It will +create an Internet object in Perl on which you can act upon with the +L<"General Internet Functions"> explained later. + +The objects available are: + +=over + +=item * + +Internet connections (the main object, see C) + +=item * + +URLs (see C) + +=item * + +FTP sessions (see C) + +=item * + +HTTP sessions (see C) + +=item * + +HTTP requests (see C) + +=back + +As in the good Perl tradition, there are in this extension different +ways to do the same thing; there are, in fact, different levels of +implementation of the Win32 Internet Functions. Some routines use +several Win32 API functions to perform a complex task in a single +call; they are simpler to use, but of course less powerful. + +There are then other functions that implement nothing more and nothing +less than the corresponding API function, so you can use all of their +power, but with some additional programming steps. + +To make an example, there is a function called C that you +can use to fetch the content of any HTTP, FTP or GOPHER URL with this +simple commands: + + $INET = new Win32::Internet(); + $file = $INET->FetchURL("http://www.yahoo.com"); + +You can have the same result (and this is actually what is done by +C) this way: + + $INET = new Win32::Internet(); + $URL = $INET->OpenURL("http://www.yahoo.com"); + $file = $URL->ReadFile(); + $URL->Close(); + +Or, you can open a complete HTTP session: + + $INET = new Win32::Internet(); + $HTTP = $INET->HTTP("www.yahoo.com", "anonymous", "dada@divinf.it"); + ($statuscode, $headers, $file) = $HTTP->Request("/"); + $HTTP->Close(); + +Finally, you can choose to manage even the HTTP request: + + $INET = new Win32::Internet(); + $HTTP = $INET->HTTP("www.yahoo.com", "anonymous", "dada@divinf.it"); + $HTTP->OpenRequest($REQ, "/"); + $REQ->AddHeader("If-Modified-Since: Saturday, 16-Nov-96 15:58:50 GMT"); + $REQ->SendRequest(); + $statuscode = $REQ->QueryInfo("",HTTP_QUERY_STATUS_CODE); + $lastmodified = $REQ->QueryInfo("Last-Modified"); + $file = $REQ->ReadEntireFile(); + $REQ->Close(); + $HTTP->Close(); + +To open and control a complete FTP session, type: + + $Connection->FTP($Session, "ftp://ftp.activeware.com", "anonymous", "dada\@divinf.it"); + +This will create an FTP object in Perl to which you can apply the L<"FTP +functions"> provided by the package: + + $Session->Cd("/ntperl/perl5.001m/CurrentBuild"); + $Session->Ascii(); + $Session->Get("110-i86.zip"); + $Session->Close(); + +For a more complete example, see the TEST.PL file that comes with the +package. + +=head2 General Internet Functions + +B + +All methods assume that you have the line: + + use Win32::Internet; + +somewhere before the method calls, and that you have an Internet +object called $INET which was created using this call: + + $INET = new Win32::Internet(); + +See C for more information. + +B + +=over + +=item CanonicalizeURL URL, [flags] + +Converts a URL to a canonical format, which includes converting unsafe +characters to escape sequences. Returns the canonicalized URL or +C on errors. For the possible values of I, refer to the +L<"Microsoft Win32 Internet Functions"> document. See also +C and C. + +Example: + + $cURL = $INET->CanonicalizeURL($URL); + $URL = $INET->CanonicalizeURL($cURL, ICU_DECODE); + +=item Close + +=item Close object + +Closes an Internet connection. This can be applied to any +Win32::Internet object (Internet connections, URLs, FTP sessions, +etc.). Note that it is not "strictly" required to close the +connections you create, since the Win32::Internet objects are +automatically closed when the program ends (or when you elsehow +destroy such an object). + +Example: + + $INET->Close(); + $FTP->Close(); + $INET->Close($FTP); # same as above... + +=item CombineURL baseURL, relativeURL, [flags] + +Combines a base and relative URL into a single URL. Returns the +(canonicalized) combined URL or C on errors. For the possible +values of I, refer to the L<"Microsoft Win32 Internet +Functions"> document. See also C and C. + +Example: + + $URL = $INET->CombineURL("http://www.divinf.it/dada/perl/internet", ".."); + +=item ConnectBackoff [value] + +Reads or sets the delay value, in milliseconds, to wait between +connection retries. If no I parameter is specified, the +current value is returned; otherwise, the delay between retries is set +to I. See also C, C, +C and C. + +Example: + + $HTTP->ConnectBackoff(2000); + $backoff = $HTTP->ConnectBackoff(); + +=item ConnectRetries [value] + +Reads or sets the number of times a connection is retried before +considering it failed. If no I parameter is specified, the +current value is returned; otherwise, the number of retries is set to +I. The default value for C is 5. See also +C, C, C and C. + +Example: + + $HTTP->ConnectRetries(20); + $retries = $HTTP->ConnectRetries(); + +=item ConnectTimeout [value] + +Reads or sets the timeout value (in milliseconds) before a connection +is considered failed. If no I parameter is specified, the +current value is returned; otherwise, the timeout is set to I. +The default value for C is infinite. See also +C, C, C and C. + +Example: + + $HTTP->ConnectTimeout(10000); + $timeout = $HTTP->ConnectTimeout(); + +=item ControlReceiveTimeout [value] + +Reads or sets the timeout value (in milliseconds) to use for non-data +(control) receive requests before they are canceled. Currently, this +value has meaning only for C sessions. If no I parameter +is specified, the current value is returned; otherwise, the timeout is +set to I. The default value for C is +infinite. See also C, C and +C. + +Example: + + $HTTP->ControlReceiveTimeout(10000); + $timeout = $HTTP->ControlReceiveTimeout(); + +=item ControlSendTimeout [value] + +Reads or sets the timeout value (in milliseconds) to use for non-data +(control) send requests before they are canceled. Currently, this +value has meaning only for C sessions. If no I parameter +is specified, the current value is returned; otherwise, the timeout is +set to I. The default value for C is +infinite. See also C, C and +C. + +Example: + + $HTTP->ControlSendTimeout(10000); + $timeout = $HTTP->ControlSendTimeout(); + +=item CrackURL URL, [flags] + +Splits an URL into its component parts and returns them in an array. +Returns C on errors, otherwise the array will contain the +following values: I. + +For example, the URL "http://www.divinf.it/index.html#top" can be +splitted in: + + http, www.divinf.it, 80, anonymous, dada@divinf.it, /index.html, #top + +If you don't specify a I parameter, ICU_ESCAPE will be used by +default; for the possible values of I refer to the L<"Microsoft +Win32 Internet Functions"> documentation. See also C. + +Example: + + @parts=$INET->CrackURL("http://www.activeware.com"); + ($scheme, $host, $port, $user, $pass, $path, $extra) = + $INET->CrackURL("http://www.divinf.it:80/perl-win32/index.sht#feedback"); + +=item CreateURL scheme, hostname, port, username, password, path, extrainfo, [flags] + +=item CreateURL hashref, [flags] + +Creates a URL from its component parts. Returns C on errors, +otherwise the created URL. + +If you pass I (a reference to an hash array), the following +values are taken from the array: + + %hash=( + "scheme" => "scheme", + "hostname" => "hostname", + "port" => port, + "username" => "username", + "password" => "password", + "path" => "path", + "extrainfo" => "extrainfo", + ); + +If you don't specify a I parameter, ICU_ESCAPE will be used by +default; for the other possible values of I refer to the +L<"Microsoft Win32 Internet Functions"> documentation. See also +C. + +Example: + + $URL=$I->CreateURL("http", "www.divinf.it", 80, "", "", "/perl-win32/index.sht", "#feedback"); + $URL=$I->CreateURL(\%params); + +=item DataReceiveTimeout [value] + +Reads or sets the timeout value (in milliseconds) to use for data +receive requests before they are canceled. If no I parameter +is specified, the current value is returned; otherwise, the timeout is +set to I. The default value for DataReceiveTimeout is +infinite. See also C, C and +C. + +Example: + + $HTTP->DataReceiveTimeout(10000); + $timeout = $HTTP->DataReceiveTimeout(); + +=item DataSendTimeout [value] + +Reads or sets the timeout value (in milliseconds) to use for data send +requests before they are canceled. If no I parameter is +specified, the current value is returned; otherwise, the timeout is +set to I. The default value for DataSendTimeout is infinite. +See also C, C and C. + +Example: + + $HTTP->DataSendTimeout(10000); + $timeout = $HTTP->DataSendTimeout(); + +=item Error + +Returns the last recorded error in the form of an array or string +(depending upon the context) containing the error number and an error +description. Can be applied on any Win32::Internet object (FTP +sessions, etc.). There are 3 types of error you can encounter; they +are recognizable by the error number returned: + +=over + +=item * -1 + +A "trivial" error has occurred in the package. For example, you tried +to use a method on the wrong type of object. + +=item * 1 .. 11999 + +A generic error has occurred and the Win32::GetLastError error message +is returned. + +=item * 12000 and higher + +An Internet error has occurred; the extended Win32 Internet API error +message is returned. + +=back + +See also C. + +Example: + + die $INET->Error(), qq(\n); + ($ErrNum, $ErrText) = $INET->Error(); + +=item FetchURL URL + +Fetch the content of an HTTP, FTP or GOPHER URL. Returns the content +of the file read (or C if there was an error and nothing was +read). See also C and C. + +Example: + + $file = $INET->FetchURL("http://www.yahoo.com/"); + $file = $INET->FetchURL("ftp://www.activeware.com/contrib/internet.zip"); + +=item FTP ftpobject, server, username, password, [port, pasv, context] + +=item FTP ftpobject, hashref + +Opens an FTP connection to server logging in with the given +I and I. + +The parameters and their values are: + +=over + +=item * server + +The server to connect to. Default: I. + +=item * username + +The username used to login to the server. Default: anonymous. + +=item * password + +The password used to login to the server. Default: I. + +=item * port + +The port of the FTP service on the server. Default: 21. + +=item * pasv + +If it is a value other than 0, use passive transfer mode. Default is +taken from the parent Internet connection object; you can set this +value with the C method. + +=item * context + +A number to identify this operation if it is asynchronous. See +C and C for more info on +asynchronous operations. Default: I. + +=back + +If you pass I (a reference to an hash array), the following +values are taken from the array: + + %hash=( + "server" => "server", + "username" => "username", + "password" => "password", + "port" => port, + "pasv" => pasv, + "context" => context, + ); + +This method returns C if the connection failed, a number +otherwise. You can then call any of the L<"FTP functions"> as methods +of the newly created I. + +Example: + + $result = $INET->FTP($FTP, "ftp.activeware.com", "anonymous", "dada\@divinf.it"); + # and then for example... + $FTP->Cd("/ntperl/perl5.001m/CurrentBuild"); + + $params{"server"} = "ftp.activeware.com"; + $params{"password"} = "dada\@divinf.it"; + $params{"pasv"} = 0; + $result = $INET->FTP($FTP,\%params); + +=item GetResponse + +Returns the text sent by a remote server in response to the last +function executed. It applies on any Win32::Internet object, +particularly of course on L. See also +the C function. + +Example: + + print $INET->GetResponse(); + $INET->FTP($FTP, "ftp.activeware.com", "anonymous", "dada\@divinf.it"); + print $FTP->GetResponse(); + +=item GetStatusCallback context + +Returns information about the progress of the asynchronous operation +identified by I; those informations consist of two values: a +status code (one of the INTERNET_STATUS_* L<"Constants">) and an +additional value depending on the status code; for example, if the +status code returned is INTERNET_STATUS_HANDLE_CREATED, the second +value will hold the handle just created. For more informations on +those values, please refer to the L<"Microsoft Win32 Internet +Functions"> documentation. See also C. + +Example: + + ($status, $info) = $INET->GetStatusCallback(1); + +=item HTTP httpobject, server, username, password, [port, flags, context] + +=item HTTP httpobject, hashref + +Opens an HTTP connection to I logging in with the given +I and I. + +The parameters and their values are: + +=over + +=item * server + +The server to connect to. Default: I. + +=item * username + +The username used to login to the server. Default: anonymous. + +=item * password + +The password used to login to the server. Default: I. + +=item * port + +The port of the HTTP service on the server. Default: 80. + +=item * flags + +Additional flags affecting the behavior of the function. Default: +I. + +=item * context + +A number to identify this operation if it is asynchronous. See +C and C for more info on +asynchronous operations. Default: I. + +=back + +Refer to the L<"Microsoft Win32 Internet Functions"> documentation for +more details on those parameters. + +If you pass I (a reference to an hash array), the following +values are taken from the array: + + %hash=( + "server" => "server", + "username" => "username", + "password" => "password", + "port" => port, + "flags" => flags, + "context" => context, + ); + +This method returns C if the connection failed, a number +otherwise. You can then call any of the L<"HTTP functions"> as +methods of the newly created I. + +Example: + + $result = $INET->HTTP($HTTP,"www.activeware.com","anonymous","dada\@divinf.it"); + # and then for example... + ($statuscode, $headers, $file) = $HTTP->Request("/gifs/camel.gif"); + + $params{"server"} = "www.activeware.com"; + $params{"password"} = "dada\@divinf.it"; + $params{"flags"} = INTERNET_FLAG_RELOAD; + $result = $INET->HTTP($HTTP,\%params); + +=item new Win32::Internet [useragent, opentype, proxy, proxybypass, flags] + +=item new Win32::Internet [hashref] + +Creates a new Internet object and initializes the use of the Internet +functions; this is required before any of the functions of this +package can be used. Returns C if the connection fails, a number +otherwise. The parameters and their values are: + +=over + +=item * useragent + +The user agent passed to HTTP requests. See C. Default: +Perl-Win32::Internet/I. + +=item * opentype + +How to access to the Internet (eg. directly or using a proxy). +Default: INTERNET_OPEN_TYPE_DIRECT. + +=item * proxy + +Name of the proxy server (or servers) to use. Default: I. + +=item * proxybypass + +Optional list of host names or IP addresses, or both, that are known +locally. Default: I. + +=item * flags + +Additional flags affecting the behavior of the function. Default: +I. + +=back + +Refer to the L<"Microsoft Win32 Internet Functions"> documentation for +more details on those parameters. If you pass I (a reference to +an hash array), the following values are taken from the array: + + %hash=( + "useragent" => "useragent", + "opentype" => "opentype", + "proxy" => "proxy", + "proxybypass" => "proxybypass", + "flags" => flags, + ); + +Example: + + $INET = new Win32::Internet(); + die qq(Cannot connect to Internet...\n) if ! $INET; + + $INET = new Win32::Internet("Mozilla/3.0", INTERNET_OPEN_TYPE_PROXY, "www.microsoft.com", ""); + + $params{"flags"} = INTERNET_FLAG_ASYNC; + $INET = new Win32::Internet(\%params); + +=item OpenURL urlobject, URL + +Opens a connection to an HTTP, FTP or GOPHER Uniform Resource Location +(URL). Returns C on errors or a number if the connection was +succesful. You can then retrieve the URL content by applying the +methods C and C on the newly created +I. See also C. + +Example: + + $INET->OpenURL($URL, "http://www.yahoo.com/"); + $bytes = $URL->QueryDataAvailable(); + $file = $URL->ReadEntireFile(); + $URL->Close(); + +=item Password [password] + +Reads or sets the password used for an C or C connection. +If no I parameter is specified, the current value is +returned; otherwise, the password is set to I. See also +C, C and C. + +Example: + + $HTTP->Password("splurfgnagbxam"); + $password = $HTTP->Password(); + +=item QueryDataAvailable + +Returns the number of bytes of data that are available to be read +immediately by a subsequent call to C (or C on +errors). Can be applied to URL or HTTP request objects. See +C or C. + +Example: + + $INET->OpenURL($URL, "http://www.yahoo.com/"); + $bytes = $URL->QueryDataAvailable(); + +=item QueryOption option + +Queries an Internet option. For the possible values of I