From 05222148264f62f02f26d3c065cc70570e9989d1 Mon Sep 17 00:00:00 2001 From: Piotr Strzelczyk Date: Sun, 21 Jun 2009 11:13:20 +0000 Subject: remove the other perl, installer uses tlperl now git-svn-id: svn://tug.org/texlive/trunk@13854 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/installer/perl.exe | Bin 5632 -> 0 bytes Master/tlpkg/installer/perl58.dll | Bin 1098752 -> 0 bytes Master/tlpkg/installer/perllib/AnyDBM_File.pm | 93 - Master/tlpkg/installer/perllib/AutoLoader.pm | 343 -- Master/tlpkg/installer/perllib/B.pm | 1111 ----- Master/tlpkg/installer/perllib/B/Asmdata.pm | 250 -- Master/tlpkg/installer/perllib/B/Assembler.pm | 328 -- Master/tlpkg/installer/perllib/B/Bblock.pm | 224 - Master/tlpkg/installer/perllib/B/Bytecode.pm | 889 ---- Master/tlpkg/installer/perllib/B/C.pm | 2272 ---------- Master/tlpkg/installer/perllib/B/CC.pm | 2005 --------- Master/tlpkg/installer/perllib/B/Concise.pm | 1628 ------- Master/tlpkg/installer/perllib/B/Debug.pm | 305 -- Master/tlpkg/installer/perllib/B/Deparse.pm | 4642 -------------------- Master/tlpkg/installer/perllib/B/Disassembler.pm | 233 - Master/tlpkg/installer/perllib/B/Lint.pm | 392 -- Master/tlpkg/installer/perllib/B/Showlex.pm | 205 - Master/tlpkg/installer/perllib/B/Stackobj.pm | 349 -- Master/tlpkg/installer/perllib/B/Stash.pm | 52 - Master/tlpkg/installer/perllib/B/Terse.pm | 103 - Master/tlpkg/installer/perllib/B/Xref.pm | 430 -- Master/tlpkg/installer/perllib/B/assemble | 30 - Master/tlpkg/installer/perllib/B/cc_harness | 12 - Master/tlpkg/installer/perllib/B/disassemble | 22 - Master/tlpkg/installer/perllib/B/makeliblinks | 54 - Master/tlpkg/installer/perllib/Carp.pm | 274 -- Master/tlpkg/installer/perllib/Carp/Heavy.pm | 241 - Master/tlpkg/installer/perllib/Class/ISA.pm | 214 - Master/tlpkg/installer/perllib/Class/Struct.pm | 636 --- Master/tlpkg/installer/perllib/Config.pm | 95 - Master/tlpkg/installer/perllib/Config_heavy.pl | 1185 ----- Master/tlpkg/installer/perllib/Cwd.pm | 710 --- Master/tlpkg/installer/perllib/Data/Dumper.pm | 1264 ------ Master/tlpkg/installer/perllib/Digest/MD5.pm | 376 -- Master/tlpkg/installer/perllib/Digest/base.pm | 100 - Master/tlpkg/installer/perllib/Digest/file.pm | 85 - Master/tlpkg/installer/perllib/DynaLoader.pm | 833 ---- Master/tlpkg/installer/perllib/Encode.pm | 851 ---- Master/tlpkg/installer/perllib/Encode/Alias.pm | 341 -- Master/tlpkg/installer/perllib/Encode/Byte.pm | 119 - .../tlpkg/installer/perllib/Encode/CJKConstants.pm | 66 - Master/tlpkg/installer/perllib/Encode/CN.pm | 76 - Master/tlpkg/installer/perllib/Encode/CN/HZ.pm | 196 - Master/tlpkg/installer/perllib/Encode/Changes.e2x | 7 - Master/tlpkg/installer/perllib/Encode/Config.pm | 166 - .../installer/perllib/Encode/ConfigLocal_PM.e2x | 13 - Master/tlpkg/installer/perllib/Encode/EBCDIC.pm | 43 - Master/tlpkg/installer/perllib/Encode/Encoder.pm | 249 -- Master/tlpkg/installer/perllib/Encode/Encoding.pm | 341 -- Master/tlpkg/installer/perllib/Encode/Guess.pm | 351 -- Master/tlpkg/installer/perllib/Encode/JP.pm | 97 - Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm | 174 - Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm | 165 - Master/tlpkg/installer/perllib/Encode/KR.pm | 72 - .../tlpkg/installer/perllib/Encode/KR/2022_KR.pm | 79 - .../tlpkg/installer/perllib/Encode/MIME/Header.pm | 230 - .../perllib/Encode/MIME/Header/ISO_2022_JP.pm | 127 - .../tlpkg/installer/perllib/Encode/Makefile_PL.e2x | 180 - Master/tlpkg/installer/perllib/Encode/PerlIO.pod | 167 - Master/tlpkg/installer/perllib/Encode/README.e2x | 31 - .../tlpkg/installer/perllib/Encode/Supported.pod | 890 ---- Master/tlpkg/installer/perllib/Encode/Symbol.pm | 42 - Master/tlpkg/installer/perllib/Encode/TW.pm | 78 - Master/tlpkg/installer/perllib/Encode/Unicode.pm | 268 -- .../tlpkg/installer/perllib/Encode/Unicode/UTF7.pm | 118 - Master/tlpkg/installer/perllib/Encode/_PM.e2x | 23 - Master/tlpkg/installer/perllib/Encode/_T.e2x | 7 - Master/tlpkg/installer/perllib/Encode/encode.h | 111 - Master/tlpkg/installer/perllib/Errno.pm | 227 - Master/tlpkg/installer/perllib/Exporter.pm | 440 -- Master/tlpkg/installer/perllib/Exporter/Heavy.pm | 248 -- Master/tlpkg/installer/perllib/Fcntl.pm | 236 - Master/tlpkg/installer/perllib/File/Basename.pm | 398 -- Master/tlpkg/installer/perllib/File/CheckTree.pm | 229 - Master/tlpkg/installer/perllib/File/Compare.pm | 178 - Master/tlpkg/installer/perllib/File/Copy.pm | 459 -- Master/tlpkg/installer/perllib/File/DosGlob.pm | 571 --- Master/tlpkg/installer/perllib/File/Find.pm | 1275 ------ Master/tlpkg/installer/perllib/File/Glob.pm | 496 --- Master/tlpkg/installer/perllib/File/Path.pm | 285 -- Master/tlpkg/installer/perllib/File/Spec.pm | 322 -- Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm | 93 - Master/tlpkg/installer/perllib/File/Spec/Epoc.pm | 77 - .../tlpkg/installer/perllib/File/Spec/Functions.pm | 109 - Master/tlpkg/installer/perllib/File/Spec/Mac.pm | 780 ---- Master/tlpkg/installer/perllib/File/Spec/OS2.pm | 272 -- Master/tlpkg/installer/perllib/File/Spec/Unix.pm | 510 --- Master/tlpkg/installer/perllib/File/Spec/VMS.pm | 521 --- Master/tlpkg/installer/perllib/File/Spec/Win32.pm | 369 -- Master/tlpkg/installer/perllib/File/Temp.pm | 2244 ---------- Master/tlpkg/installer/perllib/File/stat.pm | 139 - Master/tlpkg/installer/perllib/FileHandle.pm | 262 -- Master/tlpkg/installer/perllib/Getopt/Long.pm | 2504 ----------- Master/tlpkg/installer/perllib/Getopt/Std.pm | 294 -- Master/tlpkg/installer/perllib/IO.pm | 68 - Master/tlpkg/installer/perllib/IO/Dir.pm | 246 -- Master/tlpkg/installer/perllib/IO/File.pm | 208 - Master/tlpkg/installer/perllib/IO/Handle.pm | 625 --- Master/tlpkg/installer/perllib/IO/Pipe.pm | 257 -- Master/tlpkg/installer/perllib/IO/Poll.pm | 209 - Master/tlpkg/installer/perllib/IO/Seekable.pm | 128 - Master/tlpkg/installer/perllib/IO/Select.pm | 381 -- Master/tlpkg/installer/perllib/IO/Socket.pm | 476 -- Master/tlpkg/installer/perllib/IO/Socket/INET.pm | 431 -- Master/tlpkg/installer/perllib/IO/Socket/UNIX.pm | 144 - Master/tlpkg/installer/perllib/List/Util.pm | 277 -- Master/tlpkg/installer/perllib/Opcode.pm | 578 --- Master/tlpkg/installer/perllib/POSIX.pm | 965 ---- Master/tlpkg/installer/perllib/Pod/Checker.pm | 1270 ------ Master/tlpkg/installer/perllib/Pod/Find.pm | 523 --- Master/tlpkg/installer/perllib/Pod/Functions.pm | 376 -- Master/tlpkg/installer/perllib/Pod/Html.pm | 2123 --------- Master/tlpkg/installer/perllib/Pod/InputObjects.pm | 941 ---- Master/tlpkg/installer/perllib/Pod/LaTeX.pm | 1876 -------- Master/tlpkg/installer/perllib/Pod/Man.pm | 1413 ------ Master/tlpkg/installer/perllib/Pod/ParseLink.pm | 184 - Master/tlpkg/installer/perllib/Pod/ParseUtils.pm | 852 ---- Master/tlpkg/installer/perllib/Pod/Parser.pm | 1799 -------- Master/tlpkg/installer/perllib/Pod/Perldoc.pm | 1762 -------- .../tlpkg/installer/perllib/Pod/Perldoc/BaseTo.pm | 28 - .../installer/perllib/Pod/Perldoc/GetOptsOO.pm | 106 - .../installer/perllib/Pod/Perldoc/ToChecker.pm | 72 - .../tlpkg/installer/perllib/Pod/Perldoc/ToMan.pm | 187 - .../tlpkg/installer/perllib/Pod/Perldoc/ToNroff.pm | 100 - .../tlpkg/installer/perllib/Pod/Perldoc/ToPod.pm | 90 - .../tlpkg/installer/perllib/Pod/Perldoc/ToRtf.pm | 85 - .../tlpkg/installer/perllib/Pod/Perldoc/ToText.pm | 91 - Master/tlpkg/installer/perllib/Pod/Perldoc/ToTk.pm | 129 - .../tlpkg/installer/perllib/Pod/Perldoc/ToXml.pm | 63 - Master/tlpkg/installer/perllib/Pod/PlainText.pm | 705 --- Master/tlpkg/installer/perllib/Pod/Plainer.pm | 69 - Master/tlpkg/installer/perllib/Pod/Select.pm | 754 ---- Master/tlpkg/installer/perllib/Pod/Text.pm | 848 ---- Master/tlpkg/installer/perllib/Pod/Text/Color.pm | 145 - .../tlpkg/installer/perllib/Pod/Text/Overstrike.pm | 208 - Master/tlpkg/installer/perllib/Pod/Text/Termcap.pm | 180 - Master/tlpkg/installer/perllib/Pod/Usage.pm | 659 --- Master/tlpkg/installer/perllib/Safe.pm | 576 --- Master/tlpkg/installer/perllib/Scalar/Util.pm | 147 - Master/tlpkg/installer/perllib/SelectSaver.pm | 54 - Master/tlpkg/installer/perllib/Symbol.pm | 170 - Master/tlpkg/installer/perllib/Term/ANSIColor.pm | 472 -- Master/tlpkg/installer/perllib/Term/Cap.pm | 669 --- Master/tlpkg/installer/perllib/Term/Complete.pm | 188 - Master/tlpkg/installer/perllib/Term/ReadLine.pm | 399 -- Master/tlpkg/installer/perllib/Text/Abbrev.pm | 84 - Master/tlpkg/installer/perllib/Text/Balanced.pm | 2302 ---------- Master/tlpkg/installer/perllib/Text/ParseWords.pm | 263 -- Master/tlpkg/installer/perllib/Text/Soundex.pm | 150 - Master/tlpkg/installer/perllib/Text/Tabs.pm | 121 - Master/tlpkg/installer/perllib/Text/Wrap.pm | 223 - Master/tlpkg/installer/perllib/Tie/Array.pm | 287 -- Master/tlpkg/installer/perllib/Tie/File.pm | 2632 ----------- Master/tlpkg/installer/perllib/Tie/Handle.pm | 234 - Master/tlpkg/installer/perllib/Tie/Hash.pm | 257 -- Master/tlpkg/installer/perllib/Tie/Memoize.pm | 128 - Master/tlpkg/installer/perllib/Tie/RefHash.pm | 170 - Master/tlpkg/installer/perllib/Tie/Scalar.pm | 140 - Master/tlpkg/installer/perllib/Tie/SubstrHash.pm | 215 - Master/tlpkg/installer/perllib/Tie/Watch.pm | 560 --- Master/tlpkg/installer/perllib/Time/HiRes.pm | 500 --- Master/tlpkg/installer/perllib/Time/Local.pm | 366 -- Master/tlpkg/installer/perllib/Time/gmtime.pm | 90 - Master/tlpkg/installer/perllib/Time/localtime.pm | 86 - Master/tlpkg/installer/perllib/Time/tm.pm | 33 - Master/tlpkg/installer/perllib/Tk.pm | 821 ---- Master/tlpkg/installer/perllib/Tk/After.pm | 104 - Master/tlpkg/installer/perllib/Tk/Button.pm | 148 - Master/tlpkg/installer/perllib/Tk/Canvas.pm | 1436 ------ Master/tlpkg/installer/perllib/Tk/Checkbutton.pm | 42 - Master/tlpkg/installer/perllib/Tk/Clipboard.pm | 122 - Master/tlpkg/installer/perllib/Tk/CmdLine.pm | 954 ---- Master/tlpkg/installer/perllib/Tk/Configure.pm | 69 - Master/tlpkg/installer/perllib/Tk/Derived.pm | 512 --- Master/tlpkg/installer/perllib/Tk/Dialog.pm | 70 - Master/tlpkg/installer/perllib/Tk/DialogBox.pm | 135 - Master/tlpkg/installer/perllib/Tk/DummyEncode.pm | 46 - Master/tlpkg/installer/perllib/Tk/Entry.pm | 615 --- Master/tlpkg/installer/perllib/Tk/Event.pm | 13 - Master/tlpkg/installer/perllib/Tk/Event/IO.pm | 132 - Master/tlpkg/installer/perllib/Tk/Font.pm | 163 - Master/tlpkg/installer/perllib/Tk/Frame.pm | 378 -- Master/tlpkg/installer/perllib/Tk/Image.pm | 74 - Master/tlpkg/installer/perllib/Tk/Label.pm | 21 - Master/tlpkg/installer/perllib/Tk/Labelframe.pm | 16 - Master/tlpkg/installer/perllib/Tk/MainWindow.pm | 213 - Master/tlpkg/installer/perllib/Tk/Menu.pm | 1145 ----- Master/tlpkg/installer/perllib/Tk/Menu/Item.pm | 180 - Master/tlpkg/installer/perllib/Tk/PNG.pm | 43 - Master/tlpkg/installer/perllib/Tk/Photo.pm | 22 - Master/tlpkg/installer/perllib/Tk/Pretty.pm | 93 - Master/tlpkg/installer/perllib/Tk/ProgressBar.pm | 498 --- Master/tlpkg/installer/perllib/Tk/ROText.pm | 43 - Master/tlpkg/installer/perllib/Tk/Radiobutton.pm | 45 - Master/tlpkg/installer/perllib/Tk/Scrollbar.pm | 429 -- Master/tlpkg/installer/perllib/Tk/Submethods.pm | 46 - Master/tlpkg/installer/perllib/Tk/Text.pm | 1653 ------- Master/tlpkg/installer/perllib/Tk/Toplevel.pm | 211 - Master/tlpkg/installer/perllib/Tk/Trace.pm | 405 -- Master/tlpkg/installer/perllib/Tk/Widget.pm | 1510 ------- Master/tlpkg/installer/perllib/Tk/Wm.pm | 174 - Master/tlpkg/installer/perllib/UNIVERSAL.pm | 147 - Master/tlpkg/installer/perllib/Win32.pm | 712 --- Master/tlpkg/installer/perllib/Win32/API.pm | 745 ---- Master/tlpkg/installer/perllib/Win32/API.pm.orig | 741 ---- .../tlpkg/installer/perllib/Win32/API/Callback.pm | 174 - Master/tlpkg/installer/perllib/Win32/API/Struct.pm | 532 --- Master/tlpkg/installer/perllib/Win32/API/Test.pm | 120 - Master/tlpkg/installer/perllib/Win32/API/Type.pm | 446 -- .../tlpkg/installer/perllib/Win32/ChangeNotify.pm | 198 - Master/tlpkg/installer/perllib/Win32/Client.pl | 63 - Master/tlpkg/installer/perllib/Win32/Clipboard.pm | 369 -- Master/tlpkg/installer/perllib/Win32/Console.pm | 1463 ------ Master/tlpkg/installer/perllib/Win32/Event.pm | 104 - Master/tlpkg/installer/perllib/Win32/EventLog.pm | 471 -- Master/tlpkg/installer/perllib/Win32/File.pm | 118 - .../tlpkg/installer/perllib/Win32/FileSecurity.pm | 308 -- Master/tlpkg/installer/perllib/Win32/IPC.pm | 195 - Master/tlpkg/installer/perllib/Win32/Internet.pm | 3009 ------------- Master/tlpkg/installer/perllib/Win32/Job.pm | 370 -- Master/tlpkg/installer/perllib/Win32/Mutex.pm | 125 - Master/tlpkg/installer/perllib/Win32/NetAdmin.pm | 419 -- .../tlpkg/installer/perllib/Win32/NetResource.pm | 456 -- Master/tlpkg/installer/perllib/Win32/ODBC.pm | 1493 ------- Master/tlpkg/installer/perllib/Win32/PerfLib.pm | 538 --- Master/tlpkg/installer/perllib/Win32/Pipe.pm | 414 -- Master/tlpkg/installer/perllib/Win32/Process.pm | 217 - Master/tlpkg/installer/perllib/Win32/Registry.pm | 547 --- Master/tlpkg/installer/perllib/Win32/Semaphore.pm | 128 - Master/tlpkg/installer/perllib/Win32/Server.pl | 48 - Master/tlpkg/installer/perllib/Win32/Service.pm | 103 - Master/tlpkg/installer/perllib/Win32/Shortcut.pm | 323 -- Master/tlpkg/installer/perllib/Win32/Sound.pm | 582 --- Master/tlpkg/installer/perllib/Win32/Test.pl | 477 -- .../tlpkg/installer/perllib/Win32/TieRegistry.pm | 3801 ---------------- Master/tlpkg/installer/perllib/Win32/WinError.pm | 1017 ----- Master/tlpkg/installer/perllib/Win32/test-async.pl | 129 - .../tlpkg/installer/perllib/Win32API/Registry.pm | 1792 -------- .../perllib/Win32API/Registry/cRegistry.pc | 87 - Master/tlpkg/installer/perllib/XSLoader.pm | 356 -- Master/tlpkg/installer/perllib/attributes.pm | 418 -- Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs | 0 Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll | Bin 10240 -> 0 bytes .../tlpkg/installer/perllib/auto/Digest/MD5/MD5.bs | 0 .../installer/perllib/auto/Digest/MD5/MD5.dll | Bin 15872 -> 0 bytes .../installer/perllib/auto/DynaLoader/autosplit.ix | 8 - .../perllib/auto/DynaLoader/dl_expandspec.al | 34 - .../auto/DynaLoader/dl_find_symbol_anywhere.al | 19 - .../perllib/auto/DynaLoader/dl_findfile.al | 115 - .../installer/perllib/auto/Encode/Byte/Byte.bs | 0 .../installer/perllib/auto/Encode/Byte/Byte.dll | Bin 112640 -> 0 bytes .../tlpkg/installer/perllib/auto/Encode/Encode.bs | 0 .../tlpkg/installer/perllib/auto/Encode/Encode.dll | Bin 30208 -> 0 bytes .../perllib/auto/Encode/Unicode/Unicode.bs | 0 .../perllib/auto/Encode/Unicode/Unicode.dll | Bin 17920 -> 0 bytes Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.bs | 0 .../tlpkg/installer/perllib/auto/Fcntl/Fcntl.dll | Bin 14848 -> 0 bytes Master/tlpkg/installer/perllib/auto/IO/IO.bs | 0 Master/tlpkg/installer/perllib/auto/IO/IO.dll | Bin 16896 -> 0 bytes .../tlpkg/installer/perllib/auto/List/Util/Util.bs | 0 .../installer/perllib/auto/List/Util/Util.dll | Bin 26624 -> 0 bytes Master/tlpkg/installer/perllib/auto/POSIX/POSIX.bs | 0 .../tlpkg/installer/perllib/auto/POSIX/POSIX.dll | Bin 97792 -> 0 bytes Master/tlpkg/installer/perllib/auto/POSIX/abs.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/alarm.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/assert.al | 15 - Master/tlpkg/installer/perllib/auto/POSIX/atan2.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/atexit.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/atof.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/atoi.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/atol.al | 12 - .../installer/perllib/auto/POSIX/autosplit.ix | 159 - .../tlpkg/installer/perllib/auto/POSIX/bsearch.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/calloc.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/chdir.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/chmod.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/chown.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/clearerr.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/closedir.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/cos.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/creat.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/div.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/errno.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/execl.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/execle.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/execlp.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/execv.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/execve.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/execvp.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/exit.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/exp.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/fabs.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/fclose.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fcntl.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/fdopen.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/feof.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/ferror.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/fflush.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fgetc.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/fgetpos.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fgets.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/fileno.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fopen.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fork.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/fprintf.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fputc.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fputs.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fread.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/free.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/freopen.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/fscanf.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fseek.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/fsetpos.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/fstat.al | 17 - Master/tlpkg/installer/perllib/auto/POSIX/fsync.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/ftell.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/fwrite.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/getc.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getchar.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getegid.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getenv.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/geteuid.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getgid.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getgrgid.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getgrnam.al | 13 - .../installer/perllib/auto/POSIX/getgroups.al | 14 - .../tlpkg/installer/perllib/auto/POSIX/getlogin.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getpgrp.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getpid.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getppid.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getpwnam.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getpwuid.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/gets.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/getuid.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/gmtime.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/isatty.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/kill.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/labs.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/ldiv.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/link.al | 13 - .../installer/perllib/auto/POSIX/load_imports.al | 225 - .../installer/perllib/auto/POSIX/localtime.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/log.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/longjmp.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/malloc.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/memchr.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/memcmp.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/memcpy.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/memmove.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/memset.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/mkdir.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/offsetof.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/opendir.al | 16 - .../tlpkg/installer/perllib/auto/POSIX/perror.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/pow.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/printf.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/putc.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/putchar.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/puts.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/qsort.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/raise.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/rand.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/readdir.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/realloc.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/redef.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/remove.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/rename.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/rewind.al | 13 - .../installer/perllib/auto/POSIX/rewinddir.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/rmdir.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/scanf.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/setbuf.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/setjmp.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/setvbuf.al | 12 - .../installer/perllib/auto/POSIX/siglongjmp.al | 12 - .../installer/perllib/auto/POSIX/sigsetjmp.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/sin.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/sleep.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/sprintf.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/sqrt.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/srand.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/sscanf.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/stat.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/strcat.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strchr.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strcmp.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strcpy.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strcspn.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strerror.al | 14 - .../tlpkg/installer/perllib/auto/POSIX/strlen.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strncat.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strncmp.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strncpy.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strpbrk.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strrchr.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strspn.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/strstr.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/strtok.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/system.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/time.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/tmpfile.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/tolower.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/toupper.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/umask.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/ungetc.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/unimpl.al | 14 - .../tlpkg/installer/perllib/auto/POSIX/unlink.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/usage.al | 13 - Master/tlpkg/installer/perllib/auto/POSIX/utime.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/vfprintf.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/vprintf.al | 12 - .../tlpkg/installer/perllib/auto/POSIX/vsprintf.al | 12 - Master/tlpkg/installer/perllib/auto/POSIX/wait.al | 13 - .../tlpkg/installer/perllib/auto/POSIX/waitpid.al | 13 - .../installer/perllib/auto/Tk/CancelRepeat.al | 15 - .../installer/perllib/auto/Tk/Canvas/Canvas.bs | 0 .../installer/perllib/auto/Tk/Canvas/Canvas.dll | Bin 153600 -> 0 bytes .../perllib/auto/Tk/Clipboard/autosplit.ix | 6 - .../perllib/auto/Tk/Clipboard/getSelected.al | 15 - .../tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs | 0 .../installer/perllib/auto/Tk/Entry/Entry.dll | Bin 41472 -> 0 bytes Master/tlpkg/installer/perllib/auto/Tk/Error.al | 20 - .../tlpkg/installer/perllib/auto/Tk/Event/Event.bs | 0 .../installer/perllib/auto/Tk/Event/Event.dll | Bin 56832 -> 0 bytes .../perllib/auto/Tk/Frame/AddScrollbars.al | 52 - .../installer/perllib/auto/Tk/Frame/FindMenu.al | 22 - .../installer/perllib/auto/Tk/Frame/autosplit.ix | 24 - .../perllib/auto/Tk/Frame/freeze_on_map.al | 18 - .../tlpkg/installer/perllib/auto/Tk/Frame/label.al | 24 - .../installer/perllib/auto/Tk/Frame/labelPack.al | 50 - .../perllib/auto/Tk/Frame/labelVariable.al | 27 - .../perllib/auto/Tk/Frame/packscrollbars.al | 86 - .../installer/perllib/auto/Tk/Frame/queuePack.al | 18 - .../tlpkg/installer/perllib/auto/Tk/Frame/sbset.al | 15 - .../installer/perllib/auto/Tk/Frame/scrollbars.al | 24 - Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs | 0 Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll | Bin 168960 -> 0 bytes Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al | 16 - .../perllib/auto/Tk/Scrollbar/ButtonDown.al | 55 - .../perllib/auto/Tk/Scrollbar/ButtonUp.al | 26 - .../installer/perllib/auto/Tk/Scrollbar/Drag.al | 43 - .../installer/perllib/auto/Tk/Scrollbar/EndDrag.al | 28 - .../installer/perllib/auto/Tk/Scrollbar/Enter.al | 21 - .../installer/perllib/auto/Tk/Scrollbar/Leave.al | 18 - .../installer/perllib/auto/Tk/Scrollbar/Motion.al | 15 - .../perllib/auto/Tk/Scrollbar/ScrlByPages.al | 38 - .../perllib/auto/Tk/Scrollbar/ScrlByUnits.al | 37 - .../perllib/auto/Tk/Scrollbar/ScrlToPos.al | 35 - .../perllib/auto/Tk/Scrollbar/ScrlTopBottom.al | 32 - .../perllib/auto/Tk/Scrollbar/Scrollbar.bs | 0 .../perllib/auto/Tk/Scrollbar/Scrollbar.dll | Bin 21504 -> 0 bytes .../installer/perllib/auto/Tk/Scrollbar/Select.al | 59 - .../perllib/auto/Tk/Scrollbar/StartDrag.al | 38 - .../perllib/auto/Tk/Scrollbar/autosplit.ix | 30 - .../tlpkg/installer/perllib/auto/Tk/Text/Text.bs | 0 .../tlpkg/installer/perllib/auto/Tk/Text/Text.dll | Bin 114176 -> 0 bytes .../installer/perllib/auto/Tk/Text/autosplit.ix | 3 - Master/tlpkg/installer/perllib/auto/Tk/Tk.bs | 0 Master/tlpkg/installer/perllib/auto/Tk/Tk.dll | Bin 804864 -> 0 bytes .../perllib/auto/Tk/Toplevel/autosplit.ix | 10 - .../installer/perllib/auto/Tk/Widget/autosplit.ix | 11 - .../installer/perllib/auto/Tk/Wm/AnchorAdjust.al | 17 - .../installer/perllib/auto/Tk/Wm/FullScreen.al | 29 - Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al | 50 - Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al | 20 - .../installer/perllib/auto/Tk/Wm/autosplit.ix | 14 - .../installer/perllib/auto/Tk/Wm/iconposition.al | 24 - .../tlpkg/installer/perllib/auto/Tk/autosplit.ix | 45 - .../tlpkg/installer/perllib/auto/Tk/getEncoding.al | 43 - .../tlpkg/installer/perllib/auto/Win32/API/API.bs | 0 .../tlpkg/installer/perllib/auto/Win32/API/API.dll | Bin 20480 -> 0 bytes .../perllib/auto/Win32/API/Callback/Callback.bs | 0 .../perllib/auto/Win32/API/Callback/Callback.dll | Bin 16384 -> 0 bytes .../perllib/auto/Win32/Shortcut/Shortcut.bs | 0 .../perllib/auto/Win32/Shortcut/Shortcut.dll | Bin 29184 -> 0 bytes .../perllib/auto/Win32API/Registry/Registry.bs | 0 .../perllib/auto/Win32API/Registry/Registry.dll | Bin 181760 -> 0 bytes Master/tlpkg/installer/perllib/base.pm | 226 - Master/tlpkg/installer/perllib/bytes.pm | 88 - Master/tlpkg/installer/perllib/bytes_heavy.pl | 40 - Master/tlpkg/installer/perllib/constant.pm | 340 -- Master/tlpkg/installer/perllib/fields.pm | 319 -- Master/tlpkg/installer/perllib/lib.pm | 206 - Master/tlpkg/installer/perllib/newgetopt.pl | 75 - Master/tlpkg/installer/perllib/overload.pm | 1434 ------ Master/tlpkg/installer/perllib/re.pm | 134 - Master/tlpkg/installer/perllib/strict.pm | 136 - Master/tlpkg/installer/perllib/subs.pm | 40 - .../tlpkg/installer/perllib/unicore/Canonical.pl | 1042 ----- Master/tlpkg/installer/perllib/unicore/Exact.pl | 73 - Master/tlpkg/installer/perllib/unicore/PVA.pl | 2044 --------- Master/tlpkg/installer/perllib/unicore/To/Lower.pl | 905 ---- .../perllib/unicore/lib/gc_sc/Uppercas.pl | 490 --- Master/tlpkg/installer/perllib/utf8.pm | 214 - Master/tlpkg/installer/perllib/utf8_heavy.pl | 412 -- Master/tlpkg/installer/perllib/vars.pm | 82 - Master/tlpkg/installer/perllib/warnings.pm | 497 --- .../tlpkg/installer/perllib/warnings/register.pm | 51 - 498 files changed, 124136 deletions(-) delete mode 100755 Master/tlpkg/installer/perl.exe delete mode 100755 Master/tlpkg/installer/perl58.dll delete mode 100644 Master/tlpkg/installer/perllib/AnyDBM_File.pm delete mode 100644 Master/tlpkg/installer/perllib/AutoLoader.pm delete mode 100644 Master/tlpkg/installer/perllib/B.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Asmdata.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Assembler.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Bblock.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Bytecode.pm delete mode 100644 Master/tlpkg/installer/perllib/B/C.pm delete mode 100644 Master/tlpkg/installer/perllib/B/CC.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Concise.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Debug.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Deparse.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Disassembler.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Lint.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Showlex.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Stackobj.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Stash.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Terse.pm delete mode 100644 Master/tlpkg/installer/perllib/B/Xref.pm delete mode 100644 Master/tlpkg/installer/perllib/B/assemble delete mode 100644 Master/tlpkg/installer/perllib/B/cc_harness delete mode 100644 Master/tlpkg/installer/perllib/B/disassemble delete mode 100644 Master/tlpkg/installer/perllib/B/makeliblinks delete mode 100644 Master/tlpkg/installer/perllib/Carp.pm delete mode 100644 Master/tlpkg/installer/perllib/Carp/Heavy.pm delete mode 100644 Master/tlpkg/installer/perllib/Class/ISA.pm delete mode 100644 Master/tlpkg/installer/perllib/Class/Struct.pm delete mode 100644 Master/tlpkg/installer/perllib/Config.pm delete mode 100644 Master/tlpkg/installer/perllib/Config_heavy.pl delete mode 100644 Master/tlpkg/installer/perllib/Cwd.pm delete mode 100644 Master/tlpkg/installer/perllib/Data/Dumper.pm delete mode 100644 Master/tlpkg/installer/perllib/Digest/MD5.pm delete mode 100644 Master/tlpkg/installer/perllib/Digest/base.pm delete mode 100644 Master/tlpkg/installer/perllib/Digest/file.pm delete mode 100644 Master/tlpkg/installer/perllib/DynaLoader.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/Alias.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/Byte.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/CJKConstants.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/CN.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/CN/HZ.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/Changes.e2x delete mode 100644 Master/tlpkg/installer/perllib/Encode/Config.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x delete mode 100644 Master/tlpkg/installer/perllib/Encode/EBCDIC.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/Encoder.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/Encoding.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/Guess.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/JP.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/KR.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/MIME/Header.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x delete mode 100644 Master/tlpkg/installer/perllib/Encode/PerlIO.pod delete mode 100644 Master/tlpkg/installer/perllib/Encode/README.e2x delete mode 100644 Master/tlpkg/installer/perllib/Encode/Supported.pod delete mode 100644 Master/tlpkg/installer/perllib/Encode/Symbol.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/TW.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/Unicode.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/Unicode/UTF7.pm delete mode 100644 Master/tlpkg/installer/perllib/Encode/_PM.e2x delete mode 100644 Master/tlpkg/installer/perllib/Encode/_T.e2x delete mode 100644 Master/tlpkg/installer/perllib/Encode/encode.h delete mode 100644 Master/tlpkg/installer/perllib/Errno.pm delete mode 100644 Master/tlpkg/installer/perllib/Exporter.pm delete mode 100644 Master/tlpkg/installer/perllib/Exporter/Heavy.pm delete mode 100644 Master/tlpkg/installer/perllib/Fcntl.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Basename.pm delete mode 100644 Master/tlpkg/installer/perllib/File/CheckTree.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Compare.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Copy.pm delete mode 100644 Master/tlpkg/installer/perllib/File/DosGlob.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Find.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Glob.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Path.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Spec.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Spec/Epoc.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Spec/Functions.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Spec/Mac.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Spec/OS2.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Spec/Unix.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Spec/VMS.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Spec/Win32.pm delete mode 100644 Master/tlpkg/installer/perllib/File/Temp.pm delete mode 100644 Master/tlpkg/installer/perllib/File/stat.pm delete mode 100644 Master/tlpkg/installer/perllib/FileHandle.pm delete mode 100644 Master/tlpkg/installer/perllib/Getopt/Long.pm delete mode 100644 Master/tlpkg/installer/perllib/Getopt/Std.pm delete mode 100644 Master/tlpkg/installer/perllib/IO.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/Dir.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/File.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/Handle.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/Pipe.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/Poll.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/Seekable.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/Select.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/Socket.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/Socket/INET.pm delete mode 100644 Master/tlpkg/installer/perllib/IO/Socket/UNIX.pm delete mode 100644 Master/tlpkg/installer/perllib/List/Util.pm delete mode 100644 Master/tlpkg/installer/perllib/Opcode.pm delete mode 100644 Master/tlpkg/installer/perllib/POSIX.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Checker.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Find.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Functions.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Html.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/InputObjects.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/LaTeX.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Man.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/ParseLink.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/ParseUtils.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Parser.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/BaseTo.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/GetOptsOO.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/ToChecker.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/ToMan.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/ToNroff.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/ToPod.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/ToRtf.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/ToText.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/ToTk.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Perldoc/ToXml.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/PlainText.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Plainer.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Select.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Text.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Text/Color.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Text/Overstrike.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Text/Termcap.pm delete mode 100644 Master/tlpkg/installer/perllib/Pod/Usage.pm delete mode 100644 Master/tlpkg/installer/perllib/Safe.pm delete mode 100644 Master/tlpkg/installer/perllib/Scalar/Util.pm delete mode 100644 Master/tlpkg/installer/perllib/SelectSaver.pm delete mode 100644 Master/tlpkg/installer/perllib/Symbol.pm delete mode 100644 Master/tlpkg/installer/perllib/Term/ANSIColor.pm delete mode 100644 Master/tlpkg/installer/perllib/Term/Cap.pm delete mode 100644 Master/tlpkg/installer/perllib/Term/Complete.pm delete mode 100644 Master/tlpkg/installer/perllib/Term/ReadLine.pm delete mode 100644 Master/tlpkg/installer/perllib/Text/Abbrev.pm delete mode 100644 Master/tlpkg/installer/perllib/Text/Balanced.pm delete mode 100644 Master/tlpkg/installer/perllib/Text/ParseWords.pm delete mode 100644 Master/tlpkg/installer/perllib/Text/Soundex.pm delete mode 100644 Master/tlpkg/installer/perllib/Text/Tabs.pm delete mode 100644 Master/tlpkg/installer/perllib/Text/Wrap.pm delete mode 100644 Master/tlpkg/installer/perllib/Tie/Array.pm delete mode 100644 Master/tlpkg/installer/perllib/Tie/File.pm delete mode 100644 Master/tlpkg/installer/perllib/Tie/Handle.pm delete mode 100644 Master/tlpkg/installer/perllib/Tie/Hash.pm delete mode 100644 Master/tlpkg/installer/perllib/Tie/Memoize.pm delete mode 100644 Master/tlpkg/installer/perllib/Tie/RefHash.pm delete mode 100644 Master/tlpkg/installer/perllib/Tie/Scalar.pm delete mode 100644 Master/tlpkg/installer/perllib/Tie/SubstrHash.pm delete mode 100644 Master/tlpkg/installer/perllib/Tie/Watch.pm delete mode 100644 Master/tlpkg/installer/perllib/Time/HiRes.pm delete mode 100644 Master/tlpkg/installer/perllib/Time/Local.pm delete mode 100644 Master/tlpkg/installer/perllib/Time/gmtime.pm delete mode 100644 Master/tlpkg/installer/perllib/Time/localtime.pm delete mode 100644 Master/tlpkg/installer/perllib/Time/tm.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/After.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Button.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Canvas.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Checkbutton.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Clipboard.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/CmdLine.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Configure.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Derived.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Dialog.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/DialogBox.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/DummyEncode.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Entry.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Event.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Event/IO.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Font.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Frame.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Image.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Label.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Labelframe.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/MainWindow.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Menu.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Menu/Item.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/PNG.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Photo.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Pretty.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/ProgressBar.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/ROText.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Radiobutton.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Scrollbar.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Submethods.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Text.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Toplevel.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Trace.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Widget.pm delete mode 100644 Master/tlpkg/installer/perllib/Tk/Wm.pm delete mode 100644 Master/tlpkg/installer/perllib/UNIVERSAL.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/API.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/API.pm.orig delete mode 100644 Master/tlpkg/installer/perllib/Win32/API/Callback.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/API/Struct.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/API/Test.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/API/Type.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Client.pl delete mode 100644 Master/tlpkg/installer/perllib/Win32/Clipboard.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Console.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Event.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/EventLog.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/File.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/FileSecurity.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/IPC.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Internet.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Job.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Mutex.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/NetAdmin.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/NetResource.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/ODBC.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/PerfLib.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Pipe.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Process.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Registry.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Semaphore.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Server.pl delete mode 100644 Master/tlpkg/installer/perllib/Win32/Service.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Shortcut.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Sound.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/Test.pl delete mode 100644 Master/tlpkg/installer/perllib/Win32/TieRegistry.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/WinError.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32/test-async.pl delete mode 100644 Master/tlpkg/installer/perllib/Win32API/Registry.pm delete mode 100644 Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc delete mode 100644 Master/tlpkg/installer/perllib/XSLoader.pm delete mode 100644 Master/tlpkg/installer/perllib/attributes.pm delete mode 100644 Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Digest/MD5/MD5.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Digest/MD5/MD5.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al delete mode 100644 Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al delete mode 100644 Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Encode/Encode.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Encode/Encode.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/IO/IO.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/IO/IO.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/List/Util/Util.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/List/Util/Util.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/POSIX.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/POSIX/POSIX.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/abs.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/alarm.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/assert.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atan2.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atexit.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atof.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atoi.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atol.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/bsearch.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/calloc.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/chdir.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/chmod.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/chown.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/clearerr.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/closedir.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/cos.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/creat.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/div.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/errno.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execl.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execle.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execlp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execv.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execve.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execvp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/exit.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/exp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fabs.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fclose.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fcntl.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fdopen.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/feof.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/ferror.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fflush.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fgetc.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fgetpos.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fgets.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fileno.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fopen.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fork.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fprintf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fputc.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fputs.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fread.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/free.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/freopen.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fscanf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fseek.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fsetpos.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fstat.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fsync.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/ftell.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fwrite.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getc.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getchar.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getegid.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getenv.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/geteuid.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getgid.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getgrgid.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getgrnam.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getgroups.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getlogin.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getpgrp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getpid.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getppid.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getpwnam.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getpwuid.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/gets.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getuid.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/gmtime.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/isatty.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/kill.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/labs.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/ldiv.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/link.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/load_imports.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/localtime.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/log.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/longjmp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/malloc.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memchr.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memcmp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memcpy.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memmove.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memset.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/mkdir.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/offsetof.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/opendir.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/perror.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/pow.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/printf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/putc.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/putchar.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/puts.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/qsort.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/raise.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rand.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/readdir.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/realloc.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/redef.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/remove.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rename.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rewind.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rewinddir.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rmdir.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/scanf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/setbuf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/setjmp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/setvbuf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/siglongjmp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sigsetjmp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sin.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sleep.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sprintf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sqrt.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/srand.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sscanf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/stat.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strcat.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strchr.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strcmp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strcpy.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strcspn.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strerror.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strlen.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strncat.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strncmp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strncpy.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strpbrk.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strrchr.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strspn.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strstr.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strtok.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/system.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/time.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/tmpfile.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/tolower.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/toupper.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/umask.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/ungetc.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/unimpl.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/unlink.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/usage.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/utime.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/vfprintf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/vprintf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/vsprintf.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/wait.al delete mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/waitpid.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Error.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/AddScrollbars.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/FindMenu.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/freeze_on_map.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/label.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/labelPack.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/labelVariable.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/packscrollbars.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/queuePack.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/sbset.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/scrollbars.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonDown.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonUp.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Drag.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/EndDrag.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Enter.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Leave.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Motion.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByPages.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByUnits.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlToPos.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlTopBottom.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Select.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/StartDrag.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Text/Text.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Tk/Text/Text.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Text/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Tk.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Tk/Tk.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix delete mode 100644 Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al delete mode 100644 Master/tlpkg/installer/perllib/auto/Win32/API/API.bs delete mode 100644 Master/tlpkg/installer/perllib/auto/Win32/API/API.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs delete mode 100644 Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.bs delete mode 100644 Master/tlpkg/installer/perllib/auto/Win32/Shortcut/Shortcut.dll delete mode 100644 Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs delete mode 100755 Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll delete mode 100644 Master/tlpkg/installer/perllib/base.pm delete mode 100644 Master/tlpkg/installer/perllib/bytes.pm delete mode 100644 Master/tlpkg/installer/perllib/bytes_heavy.pl delete mode 100644 Master/tlpkg/installer/perllib/constant.pm delete mode 100644 Master/tlpkg/installer/perllib/fields.pm delete mode 100644 Master/tlpkg/installer/perllib/lib.pm delete mode 100644 Master/tlpkg/installer/perllib/newgetopt.pl delete mode 100644 Master/tlpkg/installer/perllib/overload.pm delete mode 100644 Master/tlpkg/installer/perllib/re.pm delete mode 100644 Master/tlpkg/installer/perllib/strict.pm delete mode 100644 Master/tlpkg/installer/perllib/subs.pm delete mode 100644 Master/tlpkg/installer/perllib/unicore/Canonical.pl delete mode 100644 Master/tlpkg/installer/perllib/unicore/Exact.pl delete mode 100644 Master/tlpkg/installer/perllib/unicore/PVA.pl delete mode 100644 Master/tlpkg/installer/perllib/unicore/To/Lower.pl delete mode 100644 Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl delete mode 100644 Master/tlpkg/installer/perllib/utf8.pm delete mode 100644 Master/tlpkg/installer/perllib/utf8_heavy.pl delete mode 100644 Master/tlpkg/installer/perllib/vars.pm delete mode 100644 Master/tlpkg/installer/perllib/warnings.pm delete mode 100644 Master/tlpkg/installer/perllib/warnings/register.pm (limited to 'Master') diff --git a/Master/tlpkg/installer/perl.exe b/Master/tlpkg/installer/perl.exe deleted file mode 100755 index 30108d9a8cc..00000000000 Binary files a/Master/tlpkg/installer/perl.exe and /dev/null differ diff --git a/Master/tlpkg/installer/perl58.dll b/Master/tlpkg/installer/perl58.dll deleted file mode 100755 index d783261a862..00000000000 Binary files a/Master/tlpkg/installer/perl58.dll and /dev/null differ diff --git a/Master/tlpkg/installer/perllib/AnyDBM_File.pm b/Master/tlpkg/installer/perllib/AnyDBM_File.pm deleted file mode 100644 index d73abab0f9e..00000000000 --- a/Master/tlpkg/installer/perllib/AnyDBM_File.pm +++ /dev/null @@ -1,93 +0,0 @@ -package AnyDBM_File; - -use 5.006_001; -our $VERSION = '1.00'; -our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; - -my $mod; -for $mod (@ISA) { - if (eval "require $mod") { - @ISA = ($mod); # if we leave @ISA alone, warnings abound - return 1; - } -} - -die "No DBM package was successfully found or installed"; -#return 0; - -=head1 NAME - -AnyDBM_File - provide framework for multiple DBMs - -NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations - -=head1 SYNOPSIS - - use AnyDBM_File; - -=head1 DESCRIPTION - -This module is a "pure virtual base class"--it has nothing of its own. -It's just there to inherit from one of the various DBM packages. It -prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See -L), 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/installer/perllib/AutoLoader.pm b/Master/tlpkg/installer/perllib/AutoLoader.pm deleted file mode 100644 index 4352d8b1fbe..00000000000 --- a/Master/tlpkg/installer/perllib/AutoLoader.pm +++ /dev/null @@ -1,343 +0,0 @@ -package AutoLoader; - -use strict; -use 5.006_001; - -our($VERSION, $AUTOLOAD); - -my $is_dosish; -my $is_epoc; -my $is_vms; -my $is_macos; - -BEGIN { - $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare'; - $is_epoc = $^O eq 'epoc'; - $is_vms = $^O eq 'VMS'; - $is_macos = $^O eq 'MacOS'; - $VERSION = '5.60'; -} - -AUTOLOAD { - my $sub = $AUTOLOAD; - my $filename; - # Braces used to preserve $1 et al. - { - # Try to find the autoloaded file from the package-qualified - # name of the sub. e.g., if the sub needed is - # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is - # something like '/usr/lib/perl5/Getopt/Long.pm', and the - # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'. - # - # However, if @INC is a relative path, this might not work. If, - # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is - # 'lib/Getopt/Long.pm', and we want to require - # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib'). - # In this case, we simple prepend the 'auto/' and let the - # C 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/installer/perllib/B.pm b/Master/tlpkg/installer/perllib/B.pm deleted file mode 100644 index 12917347cd0..00000000000 --- a/Master/tlpkg/installer/perllib/B.pm +++ /dev/null @@ -1,1111 +0,0 @@ -# B.pm -# -# Copyright (c) 1996, 1997, 1998 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B; - -our $VERSION = '1.09_01'; - -use XSLoader (); -require Exporter; -@ISA = qw(Exporter); - -# walkoptree_slow comes from B.pm (you are there), -# walkoptree comes from B.xs -@EXPORT_OK = qw(minus_c ppname save_BEGINs - class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object opnumber - amagic_generation perlstring - walkoptree_slow walkoptree walkoptree_exec walksymtable - parents comppadlist sv_undef compile_stats timing_info - begin_av init_av check_av end_av regex_padav dowarn - defstash curstash warnhook diehook inc_gv - ); - -sub OPf_KIDS (); -use strict; -@B::SV::ISA = 'B::OBJECT'; -@B::NULL::ISA = 'B::SV'; -@B::PV::ISA = 'B::SV'; -@B::IV::ISA = 'B::SV'; -@B::NV::ISA = 'B::SV'; -@B::RV::ISA = 'B::SV'; -@B::PVIV::ISA = qw(B::PV B::IV); -@B::PVNV::ISA = qw(B::PVIV B::NV); -@B::PVMG::ISA = 'B::PVNV'; -# Change in the inheritance hierarchy post 5.9.0 -@B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG'; -@B::BM::ISA = 'B::PVMG'; -@B::AV::ISA = 'B::PVMG'; -@B::GV::ISA = 'B::PVMG'; -@B::HV::ISA = 'B::PVMG'; -@B::CV::ISA = 'B::PVMG'; -@B::IO::ISA = 'B::PVMG'; -@B::FM::ISA = 'B::CV'; - -@B::OP::ISA = 'B::OBJECT'; -@B::UNOP::ISA = 'B::OP'; -@B::BINOP::ISA = 'B::UNOP'; -@B::LOGOP::ISA = 'B::UNOP'; -@B::LISTOP::ISA = 'B::BINOP'; -@B::SVOP::ISA = 'B::OP'; -@B::PADOP::ISA = 'B::OP'; -@B::PVOP::ISA = 'B::OP'; -@B::LOOP::ISA = 'B::LISTOP'; -@B::PMOP::ISA = 'B::LISTOP'; -@B::COP::ISA = 'B::OP'; - -@B::SPECIAL::ISA = 'B::OBJECT'; - -{ - # Stop "-w" from complaining about the lack of a real B::OBJECT class - package B::OBJECT; -} - -sub B::GV::SAFENAME { - my $name = (shift())->NAME; - - # The regex below corresponds to the isCONTROLVAR macro - # from toke.c - - $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^". - chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e; - - # When we say unicode_to_native we really mean ascii_to_native, - # which matters iff this is a non-ASCII platform (EBCDIC). - - return $name; -} - -sub B::IV::int_value { - my ($self) = @_; - return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV); -} - -sub B::NULL::as_string() {""} -sub B::IV::as_string() {goto &B::IV::int_value} -sub B::PV::as_string() {goto &B::PV::PV} - -my $debug; -my $op_count = 0; -my @parents = (); - -sub debug { - my ($class, $value) = @_; - $debug = $value; - walkoptree_debug($value); -} - -sub class { - my $obj = shift; - my $name = ref $obj; - $name =~ s/^.*:://; - return $name; -} - -sub parents { \@parents } - -# For debugging -sub peekop { - my $op = shift; - return sprintf("%s (0x%x) %s", class($op), $$op, $op->name); -} - -sub walkoptree_slow { - my($op, $method, $level) = @_; - $op_count++; # just for statistics - $level ||= 0; - warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug; - $op->$method($level); - if ($$op && ($op->flags & OPf_KIDS)) { - my $kid; - unshift(@parents, $op); - for ($kid = $op->first; $$kid; $kid = $kid->sibling) { - walkoptree_slow($kid, $method, $level + 1); - } - shift @parents; - } - if (class($op) eq 'PMOP' && ref($op->pmreplroot) && ${$op->pmreplroot}) { - unshift(@parents, $op); - walkoptree_slow($op->pmreplroot, $method, $level + 1); - shift @parents; - } -} - -sub compile_stats { - return "Total number of OPs processed: $op_count\n"; -} - -sub timing_info { - my ($sec, $min, $hr) = localtime; - my ($user, $sys) = times; - sprintf("%02d:%02d:%02d user=$user sys=$sys", - $hr, $min, $sec, $user, $sys); -} - -my %symtable; - -sub clearsym { - %symtable = (); -} - -sub savesym { - my ($obj, $value) = @_; -# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug - $symtable{sprintf("sym_%x", $$obj)} = $value; -} - -sub objsym { - my $obj = shift; - return $symtable{sprintf("sym_%x", $$obj)}; -} - -sub walkoptree_exec { - my ($op, $method, $level) = @_; - $level ||= 0; - my ($sym, $ppname); - my $prefix = " " x $level; - for (; $$op; $op = $op->next) { - $sym = objsym($op); - if (defined($sym)) { - print $prefix, "goto $sym\n"; - return; - } - savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); - $op->$method($level); - $ppname = $op->name; - if ($ppname =~ - /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/) - { - print $prefix, uc($1), " => {\n"; - walkoptree_exec($op->other, $method, $level + 1); - print $prefix, "}\n"; - } elsif ($ppname eq "match" || $ppname eq "subst") { - my $pmreplstart = $op->pmreplstart; - if ($$pmreplstart) { - print $prefix, "PMREPLSTART => {\n"; - walkoptree_exec($pmreplstart, $method, $level + 1); - print $prefix, "}\n"; - } - } elsif ($ppname eq "substcont") { - print $prefix, "SUBSTCONT => {\n"; - walkoptree_exec($op->other->pmreplstart, $method, $level + 1); - print $prefix, "}\n"; - $op = $op->other; - } elsif ($ppname eq "enterloop") { - print $prefix, "REDO => {\n"; - walkoptree_exec($op->redoop, $method, $level + 1); - print $prefix, "}\n", $prefix, "NEXT => {\n"; - walkoptree_exec($op->nextop, $method, $level + 1); - print $prefix, "}\n", $prefix, "LAST => {\n"; - walkoptree_exec($op->lastop, $method, $level + 1); - print $prefix, "}\n"; - } elsif ($ppname eq "subst") { - my $replstart = $op->pmreplstart; - if ($$replstart) { - print $prefix, "SUBST => {\n"; - walkoptree_exec($replstart, $method, $level + 1); - print $prefix, "}\n"; - } - } - } -} - -sub walksymtable { - my ($symref, $method, $recurse, $prefix) = @_; - my $sym; - my $ref; - my $fullname; - no strict 'refs'; - $prefix = '' unless defined $prefix; - while (($sym, $ref) = each %$symref) { - $fullname = "*main::".$prefix.$sym; - if ($sym =~ /::$/) { - $sym = $prefix . $sym; - if ($sym ne "main::" && $sym ne "::" && &$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/installer/perllib/B/Asmdata.pm b/Master/tlpkg/installer/perllib/B/Asmdata.pm deleted file mode 100644 index 9e41d6dd757..00000000000 --- a/Master/tlpkg/installer/perllib/B/Asmdata.pm +++ /dev/null @@ -1,250 +0,0 @@ -# -#- buffer-read-only: t -#- -# -# Copyright (c) 1996-1999 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -# -# -# This file is autogenerated from bytecode.pl. Changes made here will be lost. -# -package B::Asmdata; - -our $VERSION = '1.01'; - -use Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name); -our(%insn_data, @insn_name, @optype, @specialsv_name); - -@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); -@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); - -# XXX insn_data is initialised this way because with a large -# %insn_data = (foo => [...], bar => [...], ...) initialiser -# I get a hard-to-track-down stack underflow and segfault. -$insn_data{comment} = [35, \&PUT_comment_t, "GET_comment_t"]; -$insn_data{nop} = [10, \&PUT_none, "GET_none"]; -$insn_data{ret} = [0, \&PUT_none, "GET_none"]; -$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"]; -$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"]; -$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"]; -$insn_data{stop} = [4, \&PUT_U32, "GET_U32"]; -$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"]; -$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"]; -$insn_data{ldspecsvx} = [7, \&PUT_U8, "GET_U8"]; -$insn_data{newsv} = [8, \&PUT_U8, "GET_U8"]; -$insn_data{newsvx} = [9, \&PUT_U32, "GET_U32"]; -$insn_data{newop} = [11, \&PUT_U8, "GET_U8"]; -$insn_data{newopx} = [12, \&PUT_U16, "GET_U16"]; -$insn_data{newopn} = [13, \&PUT_U8, "GET_U8"]; -$insn_data{newpv} = [14, \&PUT_PV, "GET_PV"]; -$insn_data{pv_cur} = [15, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{pv_free} = [16, \&PUT_none, "GET_none"]; -$insn_data{sv_upgrade} = [17, \&PUT_U8, "GET_U8"]; -$insn_data{sv_refcnt} = [18, \&PUT_U32, "GET_U32"]; -$insn_data{sv_refcnt_add} = [19, \&PUT_I32, "GET_I32"]; -$insn_data{sv_flags} = [20, \&PUT_U32, "GET_U32"]; -$insn_data{xrv} = [21, \&PUT_svindex, "GET_svindex"]; -$insn_data{xpv} = [22, \&PUT_none, "GET_none"]; -$insn_data{xpv_cur} = [23, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xpv_len} = [24, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xiv} = [25, \&PUT_IV, "GET_IV"]; -$insn_data{xnv} = [26, \&PUT_NV, "GET_NV"]; -$insn_data{xlv_targoff} = [27, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xlv_targlen} = [28, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xlv_targ} = [29, \&PUT_svindex, "GET_svindex"]; -$insn_data{xlv_type} = [30, \&PUT_U8, "GET_U8"]; -$insn_data{xbm_useful} = [31, \&PUT_I32, "GET_I32"]; -$insn_data{xbm_previous} = [32, \&PUT_U16, "GET_U16"]; -$insn_data{xbm_rare} = [33, \&PUT_U8, "GET_U8"]; -$insn_data{xfm_lines} = [34, \&PUT_IV, "GET_IV"]; -$insn_data{xio_lines} = [36, \&PUT_IV, "GET_IV"]; -$insn_data{xio_page} = [37, \&PUT_IV, "GET_IV"]; -$insn_data{xio_page_len} = [38, \&PUT_IV, "GET_IV"]; -$insn_data{xio_lines_left} = [39, \&PUT_IV, "GET_IV"]; -$insn_data{xio_top_name} = [40, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xio_top_gv} = [41, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_fmt_name} = [42, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xio_fmt_gv} = [43, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_bottom_name} = [44, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xio_bottom_gv} = [45, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_subprocess} = [46, \&PUT_U16, "GET_U16"]; -$insn_data{xio_type} = [47, \&PUT_U8, "GET_U8"]; -$insn_data{xio_flags} = [48, \&PUT_U8, "GET_U8"]; -$insn_data{xcv_xsubany} = [49, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_stash} = [50, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_start} = [51, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_root} = [52, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_gv} = [53, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_file} = [54, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xcv_depth} = [55, \&PUT_long, "GET_long"]; -$insn_data{xcv_padlist} = [56, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_outside} = [57, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_outside_seq} = [58, \&PUT_U32, "GET_U32"]; -$insn_data{xcv_flags} = [59, \&PUT_U16, "GET_U16"]; -$insn_data{av_extend} = [60, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{av_pushx} = [61, \&PUT_svindex, "GET_svindex"]; -$insn_data{av_push} = [62, \&PUT_svindex, "GET_svindex"]; -$insn_data{xav_fill} = [63, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xav_max} = [64, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xav_flags} = [65, \&PUT_U8, "GET_U8"]; -$insn_data{xhv_riter} = [66, \&PUT_I32, "GET_I32"]; -$insn_data{xhv_name} = [67, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xhv_pmroot} = [68, \&PUT_opindex, "GET_opindex"]; -$insn_data{hv_store} = [69, \&PUT_svindex, "GET_svindex"]; -$insn_data{sv_magic} = [70, \&PUT_U8, "GET_U8"]; -$insn_data{mg_obj} = [71, \&PUT_svindex, "GET_svindex"]; -$insn_data{mg_private} = [72, \&PUT_U16, "GET_U16"]; -$insn_data{mg_flags} = [73, \&PUT_U8, "GET_U8"]; -$insn_data{mg_name} = [74, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{mg_namex} = [75, \&PUT_svindex, "GET_svindex"]; -$insn_data{xmg_stash} = [76, \&PUT_svindex, "GET_svindex"]; -$insn_data{gv_fetchpv} = [77, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_fetchpvx} = [78, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_stashpv} = [79, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_stashpvx} = [80, \&PUT_strconst, "GET_strconst"]; -$insn_data{gp_sv} = [81, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_refcnt} = [82, \&PUT_U32, "GET_U32"]; -$insn_data{gp_refcnt_add} = [83, \&PUT_I32, "GET_I32"]; -$insn_data{gp_av} = [84, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_hv} = [85, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cv} = [86, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_file} = [87, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{gp_io} = [88, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_form} = [89, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cvgen} = [90, \&PUT_U32, "GET_U32"]; -$insn_data{gp_line} = [91, \&PUT_U32, "GET_U32"]; -$insn_data{gp_share} = [92, \&PUT_svindex, "GET_svindex"]; -$insn_data{xgv_flags} = [93, \&PUT_U8, "GET_U8"]; -$insn_data{op_next} = [94, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_sibling} = [95, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_ppaddr} = [96, \&PUT_strconst, "GET_strconst"]; -$insn_data{op_targ} = [97, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{op_type} = [98, \&PUT_U16, "GET_U16"]; -$insn_data{op_seq} = [99, \&PUT_U16, "GET_U16"]; -$insn_data{op_flags} = [100, \&PUT_U8, "GET_U8"]; -$insn_data{op_private} = [101, \&PUT_U8, "GET_U8"]; -$insn_data{op_first} = [102, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_last} = [103, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_other} = [104, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplroot} = [105, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplstart} = [106, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmnext} = [107, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmstashpv} = [108, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{op_pmreplrootpo} = [109, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{op_pmstash} = [110, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pmreplrootgv} = [111, \&PUT_svindex, "GET_svindex"]; -$insn_data{pregcomp} = [112, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pmflags} = [113, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmpermflags} = [114, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmdynflags} = [115, \&PUT_U8, "GET_U8"]; -$insn_data{op_sv} = [116, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_padix} = [117, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{op_pv} = [118, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pv_tr} = [119, \&PUT_op_tr_array, "GET_op_tr_array"]; -$insn_data{op_redoop} = [120, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_nextop} = [121, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_lastop} = [122, \&PUT_opindex, "GET_opindex"]; -$insn_data{cop_label} = [123, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_stashpv} = [124, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_file} = [125, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_stash} = [126, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_filegv} = [127, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_seq} = [128, \&PUT_U32, "GET_U32"]; -$insn_data{cop_arybase} = [129, \&PUT_I32, "GET_I32"]; -$insn_data{cop_line} = [130, \&PUT_U32, "GET_U32"]; -$insn_data{cop_io} = [131, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_warnings} = [132, \&PUT_svindex, "GET_svindex"]; -$insn_data{main_start} = [133, \&PUT_opindex, "GET_opindex"]; -$insn_data{main_root} = [134, \&PUT_opindex, "GET_opindex"]; -$insn_data{main_cv} = [135, \&PUT_svindex, "GET_svindex"]; -$insn_data{curpad} = [136, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_begin} = [137, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_init} = [138, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_end} = [139, \&PUT_svindex, "GET_svindex"]; -$insn_data{curstash} = [140, \&PUT_svindex, "GET_svindex"]; -$insn_data{defstash} = [141, \&PUT_svindex, "GET_svindex"]; -$insn_data{data} = [142, \&PUT_U8, "GET_U8"]; -$insn_data{incav} = [143, \&PUT_svindex, "GET_svindex"]; -$insn_data{load_glob} = [144, \&PUT_svindex, "GET_svindex"]; -$insn_data{regex_padav} = [145, \&PUT_svindex, "GET_svindex"]; -$insn_data{dowarn} = [146, \&PUT_U8, "GET_U8"]; -$insn_data{comppad_name} = [147, \&PUT_svindex, "GET_svindex"]; -$insn_data{xgv_stash} = [148, \&PUT_svindex, "GET_svindex"]; -$insn_data{signal} = [149, \&PUT_strconst, "GET_strconst"]; -$insn_data{formfeed} = [150, \&PUT_svindex, "GET_svindex"]; - -my ($insn_name, $insn_data); -while (($insn_name, $insn_data) = each %insn_data) { - $insn_name[$insn_data->[0]] = $insn_name; -} -# Fill in any gaps -@insn_name = map($_ || "unused", @insn_name); - -1; - -__END__ - -=head1 NAME - -B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode - -=head1 SYNOPSIS - - use B::Asmdata qw(%insn_data @insn_name @optype @specialsv_name); - -=head1 DESCRIPTION - -Provides information about Perl ops in order to generate bytecode via -a bunch of exported variables. Its mostly used by B::Assembler and -B::Disassembler. - -=over 4 - -=item %insn_data - - my($bytecode_num, $put_sub, $get_meth) = @$insn_data{$op_name}; - -For a given $op_name (for example, 'cop_label', 'sv_flags', etc...) -you get an array ref containing the bytecode number of the op, a -reference to the subroutine used to 'PUT', and the name of the method -used to 'GET'. - -=for _private -Add more detail about what $put_sub and $get_meth are and how to use them. - -=item @insn_name - - my $op_name = $insn_name[$bytecode_num]; - -A simple mapping of the bytecode number to the name of the op. -Suitable for using with %insn_data like so: - - my $op_info = $insn_data{$insn_name[$bytecode_num]}; - -=item @optype - - my $op_type = $optype[$op_type_num]; - -A simple mapping of the op type number to its type (like 'COP' or 'BINOP'). - -=item @specialsv_name - - my $sv_name = $specialsv_name[$sv_index]; - -Certain SV types are considered 'special'. They're represented by -B::SPECIAL and are referred to by a number from the specialsv_list. -This array maps that number back to the name of the SV (like 'Nullsv' -or '&PL_sv_undef'). - -=back - -=head1 AUTHOR - -Malcolm Beattie, C - -=cut - -# ex: set ro: diff --git a/Master/tlpkg/installer/perllib/B/Assembler.pm b/Master/tlpkg/installer/perllib/B/Assembler.pm deleted file mode 100644 index f312273ce36..00000000000 --- a/Master/tlpkg/installer/perllib/B/Assembler.pm +++ /dev/null @@ -1,328 +0,0 @@ -# Assembler.pm -# -# Copyright (c) 1996 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. - -package B::Assembler; -use Exporter; -use B qw(ppname); -use B::Asmdata qw(%insn_data @insn_name); -use Config qw(%Config); -require ByteLoader; # we just need its $VERSION - -no warnings; # XXX - -@ISA = qw(Exporter); -@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm); -$VERSION = 0.07; - -use strict; -my %opnumber; -my ($i, $opname); -for ($i = 0; defined($opname = ppname($i)); $i++) { - $opnumber{$opname} = $i; -} - -my($linenum, $errors, $out); # global state, set up by newasm - -sub error { - my $str = shift; - warn "$linenum: $str\n"; - $errors++; -} - -my $debug = 0; -sub debug { $debug = shift } - -sub limcheck($$$$){ - my( $val, $lo, $hi, $loc ) = @_; - if( $val < $lo || $hi < $val ){ - error "argument for $loc outside [$lo, $hi]: $val"; - $val = $hi; - } - return $val; -} - -# -# First define all the data conversion subs to which Asmdata will refer -# - -sub B::Asmdata::PUT_U8 { - my $arg = shift; - my $c = uncstring($arg); - if (defined($c)) { - if (length($c) != 1) { - error "argument for U8 is too long: $c"; - $c = substr($c, 0, 1); - } - } else { - $arg = limcheck( $arg, 0, 0xff, 'U8' ); - $c = chr($arg); - } - return $c; -} - -sub B::Asmdata::PUT_U16 { - my $arg = limcheck( $_[0], 0, 0xffff, 'U16' ); - pack("S", $arg); -} -sub B::Asmdata::PUT_U32 { - my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' ); - pack("L", $arg); -} -sub B::Asmdata::PUT_I32 { - my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' ); - pack("l", $arg); -} -sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) - # may not even be portable between compilers -sub B::Asmdata::PUT_objindex { # could allow names here - my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' ); - pack("L", $arg); -} -sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } -sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } -sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } - -sub B::Asmdata::PUT_strconst { - my $arg = shift; - my $str = uncstring($arg); - if (!defined($str)) { - error "bad string constant: $arg"; - $str = ''; - } - if ($str =~ s/\0//g) { - error "string constant argument contains NUL: $arg"; - $str = ''; - } - return $str . "\0"; -} - -sub B::Asmdata::PUT_pvcontents { - my $arg = shift; - error "extraneous argument: $arg" if defined $arg; - return ""; -} -sub B::Asmdata::PUT_PV { - my $arg = shift; - my $str = uncstring($arg); - if( ! defined($str) ){ - error "bad string argument: $arg"; - $str = ''; - } - return pack("L", length($str)) . $str; -} -sub B::Asmdata::PUT_comment_t { - my $arg = shift; - $arg = uncstring($arg); - error "bad string argument: $arg" unless defined($arg); - if ($arg =~ s/\n//g) { - error "comment argument contains linefeed: $arg"; - } - return $arg . "\n"; -} -sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above -sub B::Asmdata::PUT_none { - my $arg = shift; - error "extraneous argument: $arg" if defined $arg; - return ""; -} -sub B::Asmdata::PUT_op_tr_array { - my @ary = split /\s*,\s*/, shift; - return pack "S*", @ary; -} - -sub B::Asmdata::PUT_IV64 { - return pack "Q", shift; -} - -sub B::Asmdata::PUT_IV { - $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64; -} - -sub B::Asmdata::PUT_PADOFFSET { - $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32; -} - -sub B::Asmdata::PUT_long { - $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32; -} - -my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", - b => "\b", f => "\f", v => "\013"); - -sub uncstring { - my $s = shift; - $s =~ s/^"// and $s =~ s/"$// or return undef; - $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg; - return $s; -} - -sub strip_comments { - my $stmt = shift; - # Comments only allowed in instructions which don't take string arguments - # Treat string as a single line so .* eats \n characters. - $stmt =~ s{ - ^\s* # Ignore leading whitespace - ( - [^"]* # A double quote '"' indicates a string argument. If we - # find a double quote, the match fails and we strip nothing. - ) - \s*\# # Any amount of whitespace plus the comment marker... - .*$ # ...which carries on to end-of-string. - }{$1}sx; # Keep only the instruction and optional argument. - return $stmt; -} - -# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize, -# ptrsize, byteorder -# nvtype is irrelevant (floats are stored as strings) -# byteorder is strconst not U32 because of varying size issues - -sub gen_header { - my $header = ""; - - $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC' - $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"'); - $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]); - $header .= B::Asmdata::PUT_U32($Config{ivsize}); - $header .= B::Asmdata::PUT_U32($Config{ptrsize}); - $header; -} - -sub parse_statement { - my $stmt = shift; - my ($insn, $arg) = $stmt =~ m{ - ^\s* # allow (but ignore) leading whitespace - (.*?) # Instruction continues up until... - (?: # ...an optional whitespace+argument group - \s+ # first whitespace. - (.*) # The argument is all the rest (newlines included). - )?$ # anchor at end-of-line - }sx; - if (defined($arg)) { - if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) { - $arg = hex($arg); - } elsif ($arg =~ s/^0(?=[0-7]+$)//) { - $arg = oct($arg); - } elsif ($arg =~ /^pp_/) { - $arg =~ s/\s*$//; # strip trailing whitespace - my $opnum = $opnumber{$arg}; - if (defined($opnum)) { - $arg = $opnum; - } else { - error qq(No such op type "$arg"); - $arg = 0; - } - } - } - return ($insn, $arg); -} - -sub assemble_insn { - my ($insn, $arg) = @_; - my $data = $insn_data{$insn}; - if (defined($data)) { - my ($bytecode, $putsub) = @{$data}[0, 1]; - my $argcode = &$putsub($arg); - return chr($bytecode).$argcode; - } else { - error qq(no such instruction "$insn"); - return ""; - } -} - -sub assemble_fh { - my ($fh, $out) = @_; - my $line; - my $asm = newasm($out); - while ($line = <$fh>) { - assemble($line); - } - endasm(); -} - -sub newasm { - my($outsub) = @_; - - die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE'; - die <(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/installer/perllib/B/Bblock.pm b/Master/tlpkg/installer/perllib/B/Bblock.pm deleted file mode 100644 index 9566d125aaa..00000000000 --- a/Master/tlpkg/installer/perllib/B/Bblock.pm +++ /dev/null @@ -1,224 +0,0 @@ -package B::Bblock; - -our $VERSION = '1.02_01'; - -use Exporter (); -@ISA = "Exporter"; -@EXPORT_OK = qw(find_leaders); - -use B qw(peekop walkoptree walkoptree_exec - main_root main_start svref_2object - OPf_SPECIAL OPf_STACKED ); - -use B::Concise qw(concise_cv concise_main set_style_standard); -use strict; - -my $bblock; -my @bblock_ends; - -sub mark_leader { - my $op = shift; - if ($$op) { - $bblock->{$$op} = $op; - } -} - -sub remove_sortblock{ - foreach (keys %$bblock){ - my $leader=$$bblock{$_}; - delete $$bblock{$_} if( $leader == 0); - } -} -sub find_leaders { - my ($root, $start) = @_; - $bblock = {}; - mark_leader($start) if ( ref $start ne "B::NULL" ); - walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ; - remove_sortblock(); - return $bblock; -} - -# Debugging -sub walk_bblocks { - my ($root, $start) = @_; - my ($op, $lastop, $leader, $bb); - $bblock = {}; - mark_leader($start); - walkoptree($root, "mark_if_leader"); - my @leaders = values %$bblock; - while ($leader = shift @leaders) { - $lastop = $leader; - $op = $leader->next; - while ($$op && !exists($bblock->{$$op})) { - $bblock->{$$op} = $leader; - $lastop = $op; - $op = $op->next; - } - push(@bblock_ends, [$leader, $lastop]); - } - foreach $bb (@bblock_ends) { - ($leader, $lastop) = @$bb; - printf "%s .. %s\n", peekop($leader), peekop($lastop); - for ($op = $leader; $$op != $$lastop; $op = $op->next) { - printf " %s\n", peekop($op); - } - printf " %s\n", peekop($lastop); - } -} - -sub walk_bblocks_obj { - my $cvref = shift; - my $cv = svref_2object($cvref); - walk_bblocks($cv->ROOT, $cv->START); -} - -sub B::OP::mark_if_leader {} - -sub B::COP::mark_if_leader { - my $op = shift; - if ($op->label) { - mark_leader($op); - } -} - -sub B::LOOP::mark_if_leader { - my $op = shift; - mark_leader($op->next); - mark_leader($op->nextop); - mark_leader($op->redoop); - mark_leader($op->lastop->next); -} - -sub B::LOGOP::mark_if_leader { - my $op = shift; - my $opname = $op->name; - mark_leader($op->next); - if ($opname eq "entertry") { - mark_leader($op->other->next); - } else { - mark_leader($op->other); - } -} - -sub B::LISTOP::mark_if_leader { - my $op = shift; - my $first=$op->first; - $first=$first->next while ($first->name eq "null"); - mark_leader($op->first) unless (exists( $bblock->{$$first})); - mark_leader($op->next); - if ($op->name eq "sort" and $op->flags & OPf_SPECIAL - and $op->flags & OPf_STACKED){ - my $root=$op->first->sibling->first; - my $leader=$root->first; - $bblock->{$$leader} = 0; - } -} - -sub B::PMOP::mark_if_leader { - my $op = shift; - if ($op->name ne "pushre") { - my $replroot = $op->pmreplroot; - if ($$replroot) { - mark_leader($replroot); - mark_leader($op->next); - mark_leader($op->pmreplstart); - } - } -} - -# PMOP stuff omitted - -sub compile { - my @options = @_; - B::clearsym(); - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "walk_bblocks_obj(\\&$objname)"; - die "walk_bblocks_obj(\\&$objname) failed: $@" if $@; - print "-------\n"; - set_style_standard("terse"); - eval "concise_cv('exec', \\&$objname)"; - die "concise_cv('exec', \\&$objname) failed: $@" if $@; - } - } - } else { - return sub { - walk_bblocks(main_root, main_start); - print "-------\n"; - set_style_standard("terse"); - concise_main("exec"); - }; - } -} - -# Basic block leaders: -# Any COP (pp_nextstate) with a non-NULL label -# [The op after a pp_enter] Omit -# [The op after a pp_entersub. Don't count this one.] -# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP -# The ops pointed at by op_next and op_other of a LOGOP, except -# for pp_entertry which has op_next and op_other->op_next -# The op pointed at by op_pmreplstart of a PMOP -# The op pointed at by op_other->op_pmreplstart of pp_substcont? -# [The op after a pp_return] Omit - -1; - -__END__ - -=head1 NAME - -B::Bblock - Walk basic blocks - -=head1 SYNOPSIS - - # External interface - perl -MO=Bblock[,OPTIONS] foo.pl - - # Programmatic API - use B::Bblock qw(find_leaders); - my $leaders = find_leaders($root_op, $start_op); - -=head1 DESCRIPTION - -This module is used by the B::CC back end. It walks "basic blocks". -A basic block is a series of operations which is known to execute from -start to finish, with no possibility of branching or halting. - -It can be used either stand alone or from inside another program. - -=for _private -Somebody who understands the stand-alone options document them, please. - -=head2 Functions - -=over 4 - -=item B - - 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/installer/perllib/B/Bytecode.pm b/Master/tlpkg/installer/perllib/B/Bytecode.pm deleted file mode 100644 index 250569ae57b..00000000000 --- a/Master/tlpkg/installer/perllib/B/Bytecode.pm +++ /dev/null @@ -1,889 +0,0 @@ -# B::Bytecode.pm -# Copyright (c) 2003 Enache Adrian. All rights reserved. -# This module is free software; you can redistribute and/or modify -# it under the same terms as Perl itself. - -# Based on the original Bytecode.pm module written by Malcolm Beattie. - -package B::Bytecode; - -our $VERSION = '1.01_01'; - -use strict; -use Config; -use B qw(class main_cv main_root main_start cstring comppadlist - defstash curstash begin_av init_av end_av inc_gv warnhook diehook - dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD - OPpLVAL_INTRO SVf_FAKE SVf_READONLY); -use B::Asmdata qw(@specialsv_name); -use B::Assembler qw(asm newasm endasm); - -################################################# - -my ($varix, $opix, $savebegins, %walked, %files, @cloop); -my %strtab = (0,0); -my %svtab = (0,0); -my %optab = (0,0); -my %spectab = (0,0); -my $tix = 1; -sub asm; -sub nice ($) { } - -BEGIN { - my $ithreads = $Config{'useithreads'} eq 'define'; - eval qq{ - sub ITHREADS() { $ithreads } - sub VERSION() { $] } - }; die $@ if $@; -} - -################################################# - -sub pvstring { - my $pv = shift; - defined($pv) ? cstring ($pv."\0") : "\"\""; -} - -sub pvix { - my $str = pvstring shift; - my $ix = $strtab{$str}; - defined($ix) ? $ix : do { - asm "newpv", $str; - asm "stpv", $strtab{$str} = $tix; - $tix++; - } -} - -sub B::OP::ix { - my $op = shift; - my $ix = $optab{$$op}; - defined($ix) ? $ix : do { - nice "[".$op->name." $tix]"; - asm "newopx", $op->size | $op->type <<7; - $optab{$$op} = $opix = $ix = $tix++; - $op->bsave($ix); - $ix; - } -} - -sub B::SPECIAL::ix { - my $spec = shift; - my $ix = $spectab{$$spec}; - defined($ix) ? $ix : do { - nice '['.$specialsv_name[$$spec].']'; - asm "ldspecsvx", $$spec; - $spectab{$$spec} = $varix = $tix++; - } -} - -sub B::SV::ix { - my $sv = shift; - my $ix = $svtab{$$sv}; - defined($ix) ? $ix : do { - nice '['.class($sv).']'; - asm "newsvx", $sv->FLAGS; - $svtab{$$sv} = $varix = $ix = $tix++; - $sv->bsave($ix); - $ix; - } -} - -sub B::GV::ix { - my ($gv,$desired) = @_; - my $ix = $svtab{$$gv}; - defined($ix) ? $ix : do { - if ($gv->GP) { - my ($svix, $avix, $hvix, $cvix, $ioix, $formix); - nice "[GV]"; - my $name = $gv->STASH->NAME . "::" . $gv->NAME; - asm "gv_fetchpvx", cstring $name; - $svtab{$$gv} = $varix = $ix = $tix++; - asm "sv_flags", $gv->FLAGS; - asm "sv_refcnt", $gv->REFCNT; - asm "xgv_flags", $gv->GvFLAGS; - - asm "gp_refcnt", $gv->GvREFCNT; - asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob"; - return $ix - unless $desired || desired $gv; - $svix = $gv->SV->ix; - $avix = $gv->AV->ix; - $hvix = $gv->HV->ix; - - # XXX {{{{ - my $cv = $gv->CV; - $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0; - my $form = $gv->FORM; - $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0; - - $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0; - # }}}} XXX - - nice "-GV-", - asm "ldsv", $varix = $ix unless $ix == $varix; - asm "gp_sv", $svix; - asm "gp_av", $avix; - asm "gp_hv", $hvix; - asm "gp_cv", $cvix; - asm "gp_io", $ioix; - asm "gp_cvgen", $gv->CVGEN; - asm "gp_form", $formix; - asm "gp_file", pvix $gv->FILE; - asm "gp_line", $gv->LINE; - asm "formfeed", $svix if $name eq "main::\cL"; - } else { - nice "[GV]"; - asm "newsvx", $gv->FLAGS; - $svtab{$$gv} = $varix = $ix = $tix++; - my $stashix = $gv->STASH->ix; - $gv->B::PVMG::bsave($ix); - asm "xgv_flags", $gv->GvFLAGS; - asm "xgv_stash", $stashix; - } - $ix; - } -} - -sub B::HV::ix { - my $hv = shift; - my $ix = $svtab{$$hv}; - defined($ix) ? $ix : do { - my ($ix,$i,@array); - my $name = $hv->NAME; - if ($name) { - nice "[STASH]"; - asm "gv_stashpvx", cstring $name; - asm "sv_flags", $hv->FLAGS; - $svtab{$$hv} = $varix = $ix = $tix++; - asm "xhv_name", pvix $name; - # my $pmrootix = $hv->PMROOT->ix; # XXX - asm "ldsv", $varix = $ix unless $ix == $varix; - # asm "xhv_pmroot", $pmrootix; # XXX - } else { - nice "[HV]"; - asm "newsvx", $hv->FLAGS; - $svtab{$$hv} = $varix = $ix = $tix++; - my $stashix = $hv->SvSTASH->ix; - for (@array = $hv->ARRAY) { - next if $i = not $i; - $_ = $_->ix; - } - nice "-HV-", - asm "ldsv", $varix = $ix unless $ix == $varix; - ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_) - for @array; - if (VERSION < 5.009) { - asm "xnv", $hv->NVX; - } - asm "xmg_stash", $stashix; - asm "xhv_riter", $hv->RITER; - } - asm "sv_refcnt", $hv->REFCNT; - $ix; - } -} - -sub B::NULL::ix { - my $sv = shift; - $$sv ? $sv->B::SV::ix : 0; -} - -sub B::NULL::opwalk { 0 } - -################################################# - -sub B::NULL::bsave { - my ($sv,$ix) = @_; - - nice '-'.class($sv).'-', - asm "ldsv", $varix = $ix unless $ix == $varix; - asm "sv_refcnt", $sv->REFCNT; -} - -sub B::SV::bsave; - *B::SV::bsave = *B::NULL::bsave; - -sub B::RV::bsave { - my ($sv,$ix) = @_; - my $rvix = $sv->RV->ix; - $sv->B::NULL::bsave($ix); - asm "xrv", $rvix; -} - -sub B::PV::bsave { - my ($sv,$ix) = @_; - $sv->B::NULL::bsave($ix); - asm "newpv", pvstring $sv->PVBM; - asm "xpv"; -} - -sub B::IV::bsave { - my ($sv,$ix) = @_; - $sv->B::NULL::bsave($ix); - asm "xiv", $sv->IVX; -} - -sub B::NV::bsave { - my ($sv,$ix) = @_; - $sv->B::NULL::bsave($ix); - asm "xnv", sprintf "%.40g", $sv->NVX; -} - -sub B::PVIV::bsave { - my ($sv,$ix) = @_; - $sv->POK ? - $sv->B::PV::bsave($ix): - $sv->ROK ? - $sv->B::RV::bsave($ix): - $sv->B::NULL::bsave($ix); - if (VERSION >= 5.009) { - # See note below in B::PVNV::bsave - return if $sv->isa('B::AV'); - return if $sv->isa('B::HV'); - } - asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ? - "0 but true" : $sv->IVX; -} - -sub B::PVNV::bsave { - my ($sv,$ix) = @_; - $sv->B::PVIV::bsave($ix); - if (VERSION >= 5.009) { - # Magical AVs end up here, but AVs now don't have an NV slot actually - # allocated. Hence don't write out assembly to store the NV slot if - # we're actually an array. - return if $sv->isa('B::AV'); - # Likewise HVs have no NV slot actually allocated. - # I don't think that they can get here, but better safe than sorry - return if $sv->isa('B::HV'); - } - asm "xnv", sprintf "%.40g", $sv->NVX; -} - -sub B::PVMG::domagic { - my ($sv,$ix) = @_; - nice '-MAGICAL-'; - my @mglist = $sv->MAGIC; - my (@mgix, @namix); - for (@mglist) { - push @mgix, $_->OBJ->ix; - push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY; - } - - nice '-'.class($sv).'-', - asm "ldsv", $varix = $ix unless $ix == $varix; - for (@mglist) { - asm "sv_magic", cstring $_->TYPE; - asm "mg_obj", shift @mgix; - my $length = $_->LENGTH; - if ($length == B::HEf_SVKEY) { - asm "mg_namex", shift @namix; - } elsif ($length) { - asm "newpv", pvstring $_->PTR; - asm "mg_name"; - } - } -} - -sub B::PVMG::bsave { - my ($sv,$ix) = @_; - my $stashix = $sv->SvSTASH->ix; - $sv->B::PVNV::bsave($ix); - asm "xmg_stash", $stashix; - $sv->domagic($ix) if $sv->MAGICAL; -} - -sub B::PVLV::bsave { - my ($sv,$ix) = @_; - my $targix = $sv->TARG->ix; - $sv->B::PVMG::bsave($ix); - asm "xlv_targ", $targix; - asm "xlv_targoff", $sv->TARGOFF; - asm "xlv_targlen", $sv->TARGLEN; - asm "xlv_type", $sv->TYPE; - -} - -sub B::BM::bsave { - my ($sv,$ix) = @_; - $sv->B::PVMG::bsave($ix); - asm "xpv_cur", $sv->CUR; - asm "xbm_useful", $sv->USEFUL; - asm "xbm_previous", $sv->PREVIOUS; - asm "xbm_rare", $sv->RARE; -} - -sub B::IO::bsave { - my ($io,$ix) = @_; - my $topix = $io->TOP_GV->ix; - my $fmtix = $io->FMT_GV->ix; - my $bottomix = $io->BOTTOM_GV->ix; - $io->B::PVMG::bsave($ix); - asm "xio_lines", $io->LINES; - asm "xio_page", $io->PAGE; - asm "xio_page_len", $io->PAGE_LEN; - asm "xio_lines_left", $io->LINES_LEFT; - asm "xio_top_name", pvix $io->TOP_NAME; - asm "xio_top_gv", $topix; - asm "xio_fmt_name", pvix $io->FMT_NAME; - asm "xio_fmt_gv", $fmtix; - asm "xio_bottom_name", pvix $io->BOTTOM_NAME; - asm "xio_bottom_gv", $bottomix; - asm "xio_subprocess", $io->SUBPROCESS; - asm "xio_type", ord $io->IoTYPE; - # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX -} - -sub B::CV::bsave { - my ($cv,$ix) = @_; - my $stashix = $cv->STASH->ix; - my $gvix = $cv->GV->ix; - my $padlistix = $cv->PADLIST->ix; - my $outsideix = $cv->OUTSIDE->ix; - my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0; - my $startix = $cv->START->opwalk; - my $rootix = $cv->ROOT->ix; - - $cv->B::PVMG::bsave($ix); - asm "xcv_stash", $stashix; - asm "xcv_start", $startix; - asm "xcv_root", $rootix; - asm "xcv_xsubany", $constix; - asm "xcv_gv", $gvix; - asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD - asm "xcv_padlist", $padlistix; - asm "xcv_outside", $outsideix; - asm "xcv_flags", $cv->CvFLAGS; - asm "xcv_outside_seq", $cv->OUTSIDE_SEQ; - asm "xcv_depth", $cv->DEPTH; -} - -sub B::FM::bsave { - my ($form,$ix) = @_; - - $form->B::CV::bsave($ix); - asm "xfm_lines", $form->LINES; -} - -sub B::AV::bsave { - my ($av,$ix) = @_; - return $av->B::PVMG::bsave($ix) if $av->MAGICAL; - my @array = $av->ARRAY; - $_ = $_->ix for @array; - my $stashix = $av->SvSTASH->ix; - - nice "-AV-", - asm "ldsv", $varix = $ix unless $ix == $varix; - asm "av_extend", $av->MAX if $av->MAX >= 0; - asm "av_pushx", $_ for @array; - asm "sv_refcnt", $av->REFCNT; - if (VERSION < 5.009) { - asm "xav_flags", $av->AvFLAGS; - } - asm "xmg_stash", $stashix; -} - -sub B::GV::desired { - my $gv = shift; - my ($cv, $form); - $files{$gv->FILE} && $gv->LINE - || ${$cv = $gv->CV} && $files{$cv->FILE} - || ${$form = $gv->FORM} && $files{$form->FILE} -} - -sub B::HV::bwalk { - my $hv = shift; - return if $walked{$$hv}++; - my %stash = $hv->ARRAY; - while (my($k,$v) = each %stash) { - if ($v->SvTYPE == SVt_PVGV) { - my $hash = $v->HV; - if ($$hash && $hash->NAME) { - $hash->bwalk; - } - $v->ix(1) if desired $v; - } else { - nice "[prototype]"; - asm "gv_fetchpvx", cstring $hv->NAME . "::$k"; - $svtab{$$v} = $varix = $tix; - $v->bsave($tix++); - asm "sv_flags", $v->FLAGS; - } - } -} - -###################################################### - - -sub B::OP::bsave_thin { - my ($op, $ix) = @_; - my $next = $op->next; - my $nextix = $optab{$$next}; - $nextix = 0, push @cloop, $op unless defined $nextix; - if ($ix != $opix) { - nice '-'.$op->name.'-', - asm "ldop", $opix = $ix; - } - asm "op_next", $nextix; - asm "op_targ", $op->targ if $op->type; # tricky - asm "op_flags", $op->flags; - asm "op_private", $op->private; -} - -sub B::OP::bsave; - *B::OP::bsave = *B::OP::bsave_thin; - -sub B::UNOP::bsave { - my ($op, $ix) = @_; - my $name = $op->name; - my $flags = $op->flags; - my $first = $op->first; - my $firstix = - $name =~ /fl[io]p/ - # that's just neat - || (!ITHREADS && $name eq 'regcomp') - # trick for /$a/o in pp_regcomp - || $name eq 'rv2sv' - && $op->flags & OPf_MOD - && $op->private & OPpLVAL_INTRO - # change #18774 made my life hard - ? $first->ix - : 0; - - $op->B::OP::bsave($ix); - asm "op_first", $firstix; -} - -sub B::BINOP::bsave { - my ($op, $ix) = @_; - if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) { - my $last = $op->last; - my $lastix = do { - local *B::OP::bsave = *B::OP::bsave_fat; - local *B::UNOP::bsave = *B::UNOP::bsave_fat; - $last->ix; - }; - asm "ldop", $lastix unless $lastix == $opix; - asm "op_targ", $last->targ; - $op->B::OP::bsave($ix); - asm "op_last", $lastix; - } else { - $op->B::OP::bsave($ix); - } -} - -# not needed if no pseudohashes - -*B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009; - -# deal with sort / formline - -sub B::LISTOP::bsave { - my ($op, $ix) = @_; - my $name = $op->name; - sub blocksort() { OPf_SPECIAL|OPf_STACKED } - if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) { - my $first = $op->first; - my $pushmark = $first->sibling; - my $rvgv = $pushmark->first; - my $leave = $rvgv->first; - - my $leaveix = $leave->ix; - - my $rvgvix = $rvgv->ix; - asm "ldop", $rvgvix unless $rvgvix == $opix; - asm "op_first", $leaveix; - - my $pushmarkix = $pushmark->ix; - asm "ldop", $pushmarkix unless $pushmarkix == $opix; - asm "op_first", $rvgvix; - - my $firstix = $first->ix; - asm "ldop", $firstix unless $firstix == $opix; - asm "op_sibling", $pushmarkix; - - $op->B::OP::bsave($ix); - asm "op_first", $firstix; - } elsif ($name eq 'formline') { - $op->B::UNOP::bsave_fat($ix); - } else { - $op->B::OP::bsave($ix); - } -} - -# fat versions - -sub B::OP::bsave_fat { - my ($op, $ix) = @_; - my $siblix = $op->sibling->ix; - - $op->B::OP::bsave_thin($ix); - asm "op_sibling", $siblix; - # asm "op_seq", -1; XXX don't allocate OPs piece by piece -} - -sub B::UNOP::bsave_fat { - my ($op,$ix) = @_; - my $firstix = $op->first->ix; - - $op->B::OP::bsave($ix); - asm "op_first", $firstix; -} - -sub B::BINOP::bsave_fat { - my ($op,$ix) = @_; - my $last = $op->last; - my $lastix = $op->last->ix; - if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') { - asm "ldop", $lastix unless $lastix == $opix; - asm "op_targ", $last->targ; - } - - $op->B::UNOP::bsave($ix); - asm "op_last", $lastix; -} - -sub B::LOGOP::bsave { - my ($op,$ix) = @_; - my $otherix = $op->other->ix; - - $op->B::UNOP::bsave($ix); - asm "op_other", $otherix; -} - -sub B::PMOP::bsave { - my ($op,$ix) = @_; - my ($rrop, $rrarg, $rstart); - - # my $pmnextix = $op->pmnext->ix; # XXX - - if (ITHREADS) { - if ($op->name eq 'subst') { - $rrop = "op_pmreplroot"; - $rrarg = $op->pmreplroot->ix; - $rstart = $op->pmreplstart->ix; - } elsif ($op->name eq 'pushre') { - $rrop = "op_pmreplrootpo"; - $rrarg = $op->pmreplroot; - } - $op->B::BINOP::bsave($ix); - asm "op_pmstashpv", pvix $op->pmstashpv; - } else { - $rrop = "op_pmreplrootgv"; - $rrarg = $op->pmreplroot->ix; - $rstart = $op->pmreplstart->ix if $op->name eq 'subst'; - my $stashix = $op->pmstash->ix; - $op->B::BINOP::bsave($ix); - asm "op_pmstash", $stashix; - } - - asm $rrop, $rrarg if $rrop; - asm "op_pmreplstart", $rstart if $rstart; - - asm "op_pmflags", $op->pmflags; - asm "op_pmpermflags", $op->pmpermflags; - asm "op_pmdynflags", $op->pmdynflags; - # asm "op_pmnext", $pmnextix; # XXX - asm "newpv", pvstring $op->precomp; - asm "pregcomp"; -} - -sub B::SVOP::bsave { - my ($op,$ix) = @_; - my $svix = $op->sv->ix; - - $op->B::OP::bsave($ix); - asm "op_sv", $svix; -} - -sub B::PADOP::bsave { - my ($op,$ix) = @_; - - $op->B::OP::bsave($ix); - asm "op_padix", $op->padix; -} - -sub B::PVOP::bsave { - my ($op,$ix) = @_; - $op->B::OP::bsave($ix); - return unless my $pv = $op->pv; - - if ($op->name eq 'trans') { - asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv); - } else { - asm "newpv", pvstring $pv; - asm "op_pv"; - } -} - -sub B::LOOP::bsave { - my ($op,$ix) = @_; - my $nextix = $op->nextop->ix; - my $lastix = $op->lastop->ix; - my $redoix = $op->redoop->ix; - - $op->B::BINOP::bsave($ix); - asm "op_redoop", $redoix; - asm "op_nextop", $nextix; - asm "op_lastop", $lastix; -} - -sub B::COP::bsave { - my ($cop,$ix) = @_; - my $warnix = $cop->warnings->ix; - my $ioix = $cop->io->ix; - if (ITHREADS) { - $cop->B::OP::bsave($ix); - asm "cop_stashpv", pvix $cop->stashpv; - asm "cop_file", pvix $cop->file; - } else { - my $stashix = $cop->stash->ix; - my $fileix = $cop->filegv->ix(1); - $cop->B::OP::bsave($ix); - asm "cop_stash", $stashix; - asm "cop_filegv", $fileix; - } - asm "cop_label", pvix $cop->label if $cop->label; # XXX AD - asm "cop_seq", $cop->cop_seq; - asm "cop_arybase", $cop->arybase; - asm "cop_line", $cop->line; - asm "cop_warnings", $warnix; - asm "cop_io", $ioix; -} - -sub B::OP::opwalk { - my $op = shift; - my $ix = $optab{$$op}; - defined($ix) ? $ix : do { - my $ix; - my @oplist = $op->oplist; - push @cloop, undef; - $ix = $_->ix while $_ = pop @oplist; - while ($_ = pop @cloop) { - asm "ldop", $optab{$$_}; - asm "op_next", $optab{${$_->next}}; - } - $ix; - } -} - -################################################# - -sub save_cq { - my $av; - if (($av=begin_av)->isa("B::AV")) { - if ($savebegins) { - for ($av->ARRAY) { - next unless $_->FILE eq $0; - asm "push_begin", $_->ix; - } - } else { - for ($av->ARRAY) { - next unless $_->FILE eq $0; - # XXX BEGIN { goto A while 1; A: } - for (my $op = $_->START; $$op; $op = $op->next) { - next unless $op->name eq 'require' || - # this kludge needed for tests - $op->name eq 'gv' && do { - my $gv = class($op) eq 'SVOP' ? - $op->gv : - (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix]; - $$gv && $gv->NAME =~ /use_ok|plan/ - }; - asm "push_begin", $_->ix; - last; - } - } - } - } - if (($av=init_av)->isa("B::AV")) { - for ($av->ARRAY) { - next unless $_->FILE eq $0; - asm "push_init", $_->ix; - } - } - if (($av=end_av)->isa("B::AV")) { - for ($av->ARRAY) { - next unless $_->FILE eq $0; - asm "push_end", $_->ix; - } - } -} - -sub compile { - my ($head, $scan, $T_inhinc, $keep_syn); - my $cwd = ''; - $files{$0} = 1; - sub keep_syn { - $keep_syn = 1; - *B::OP::bsave = *B::OP::bsave_fat; - *B::UNOP::bsave = *B::UNOP::bsave_fat; - *B::BINOP::bsave = *B::BINOP::bsave_fat; - *B::LISTOP::bsave = *B::LISTOP::bsave_fat; - } - sub bwarn { print STDERR "Bytecode.pm: @_\n" } - - for (@_) { - if (/^-S/) { - *newasm = *endasm = sub { }; - *asm = sub { print " @_\n" }; - *nice = sub ($) { print "\n@_\n" }; - } elsif (/^-H/) { - require ByteLoader; - $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n"; - } elsif (/^-k/) { - keep_syn; - } elsif (/^-o(.*)$/) { - open STDOUT, ">$1" or die "open $1: $!"; - } elsif (/^-f(.*)$/) { - $files{$1} = 1; - } elsif (/^-s(.*)$/) { - $scan = length($1) ? $1 : $0; - } elsif (/^-b/) { - $savebegins = 1; - # this is here for the testsuite - } elsif (/^-TI/) { - $T_inhinc = 1; - } elsif (/^-TF(.*)/) { - my $thatfile = $1; - *B::COP::file = sub { $thatfile }; - } else { - bwarn "Ignoring '$_' option"; - } - } - if ($scan) { - my $f; - if (open $f, $scan) { - while (<$f>) { - /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1; - /^#/ and next; - if (/\bgoto\b\s*[^&]/ && !$keep_syn) { - bwarn "keeping the syntax tree: \"goto\" op found"; - keep_syn; - } - } - } else { - bwarn "cannot rescan '$scan'"; - } - close $f; - } - binmode STDOUT; - return sub { - print $head if $head; - newasm sub { print @_ }; - - defstash->bwalk; - asm "main_start", main_start->opwalk; - asm "main_root", main_root->ix; - asm "main_cv", main_cv->ix; - asm "curpad", (comppadlist->ARRAY)[1]->ix; - - asm "signal", cstring "__WARN__" # XXX - if warnhook->ix; - asm "incav", inc_gv->AV->ix if $T_inhinc; - save_cq; - asm "incav", inc_gv->AV->ix if $T_inhinc; - asm "dowarn", dowarn; - - { - no strict 'refs'; - nice ""; - 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/installer/perllib/B/C.pm b/Master/tlpkg/installer/perllib/B/C.pm deleted file mode 100644 index cebf4132ffd..00000000000 --- a/Master/tlpkg/installer/perllib/B/C.pm +++ /dev/null @@ -1,2272 +0,0 @@ -# C.pm -# -# Copyright (c) 1996, 1997, 1998 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# - -package B::C; - -our $VERSION = '1.04_01'; - -package B::C::Section; - -use B (); -use base B::Section; - -sub new -{ - my $class = shift; - my $o = $class->SUPER::new(@_); - push @$o, { values => [] }; - return $o; -} - -sub add -{ - my $section = shift; - push(@{$section->[-1]{values}},@_); -} - -sub index -{ - my $section = shift; - return scalar(@{$section->[-1]{values}})-1; -} - -sub output -{ - my ($section, $fh, $format) = @_; - my $sym = $section->symtable || {}; - my $default = $section->default; - my $i; - foreach (@{$section->[-1]{values}}) - { - s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge; - printf $fh $format, $_, $i; - ++$i; - } -} - -package B::C::InitSection; - -# avoid use vars -@B::C::InitSection::ISA = qw(B::C::Section); - -sub new { - my $class = shift; - my $max_lines = 10000; #pop; - my $section = $class->SUPER::new( @_ ); - - $section->[-1]{evals} = []; - $section->[-1]{chunks} = []; - $section->[-1]{nosplit} = 0; - $section->[-1]{current} = []; - $section->[-1]{count} = 0; - $section->[-1]{max_lines} = $max_lines; - - return $section; -} - -sub split { - my $section = shift; - $section->[-1]{nosplit}-- - if $section->[-1]{nosplit} > 0; -} - -sub no_split { - shift->[-1]{nosplit}++; -} - -sub inc_count { - my $section = shift; - - $section->[-1]{count} += $_[0]; - # this is cheating - $section->add(); -} - -sub add { - my $section = shift->[-1]; - my $current = $section->{current}; - my $nosplit = $section->{nosplit}; - - push @$current, @_; - $section->{count} += scalar(@_); - if( !$nosplit && $section->{count} >= $section->{max_lines} ) { - push @{$section->{chunks}}, $current; - $section->{current} = []; - $section->{count} = 0; - } -} - -sub add_eval { - my $section = shift; - my @strings = @_; - - foreach my $i ( @strings ) { - $i =~ s/\"/\\\"/g; - } - push @{$section->[-1]{evals}}, @strings; -} - -sub output { - my( $section, $fh, $format, $init_name ) = @_; - my $sym = $section->symtable || {}; - my $default = $section->default; - push @{$section->[-1]{chunks}}, $section->[-1]{current}; - - my $name = "aaaa"; - foreach my $i ( @{$section->[-1]{chunks}} ) { - print $fh <<"EOT"; -static int perl_init_${name}() -{ - dTARG; - dSP; -EOT - foreach my $j ( @$i ) { - $j =~ s{(s\\_[0-9a-f]+)} - { exists($sym->{$1}) ? $sym->{$1} : $default; }ge; - print $fh "\t$j\n"; - } - print $fh "\treturn 0;\n}\n"; - - $section->SUPER::add( "perl_init_${name}();" ); - ++$name; - } - foreach my $i ( @{$section->[-1]{evals}} ) { - $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i ); - } - - print $fh <<"EOT"; -static int ${init_name}() -{ - dTARG; - dSP; -EOT - $section->SUPER::output( $fh, $format ); - print $fh "\treturn 0;\n}\n"; -} - - -package B::C; -use Exporter (); -our %REGEXP; - -{ # block necessary for caller to work - my $caller = caller; - if( $caller eq 'O' ) { - require XSLoader; - XSLoader::load( 'B::C' ); - } -} - -@ISA = qw(Exporter); -@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused - init_sections set_callback save_unused_subs objsym save_context); - -use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop - class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation - HEf_SVKEY SVf_POK SVf_ROK CVf_CONST); -use B::Asmdata qw(@specialsv_name); - -use FileHandle; -use Carp; -use strict; -use Config; - -my $hv_index = 0; -my $gv_index = 0; -my $re_index = 0; -my $pv_index = 0; -my $cv_index = 0; -my $anonsub_index = 0; -my $initsub_index = 0; - -my %symtable; -my %xsub; -my $warn_undefined_syms; -my $verbose; -my %unused_sub_packages; -my $use_xsloader; -my $nullop_count; -my $pv_copy_on_grow = 0; -my $optimize_ppaddr = 0; -my $optimize_warn_sv = 0; -my $use_perl_script_name = 0; -my $save_data_fh = 0; -my $save_sig = 0; -my ($debug_cops, $debug_av, $debug_cv, $debug_mg); -my $max_string_len; - -my $ithreads = $Config{useithreads} eq 'define'; - -my @threadsv_names; -BEGIN { - @threadsv_names = threadsv_names(); -} - -# Code sections -my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, - $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, - $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, - $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, - $xrvsect, $xpvbmsect, $xpviosect ); -my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect, - $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect, - $unopsect ); - -sub walk_and_save_optree; -my $saveoptree_callback = \&walk_and_save_optree; -sub set_callback { $saveoptree_callback = shift } -sub saveoptree { &$saveoptree_callback(@_) } - -sub walk_and_save_optree { - my ($name, $root, $start) = @_; - walkoptree($root, "save"); - return objsym($start); -} - -# Look this up here so we can do just a number compare -# rather than looking up the name of every BASEOP in B::OP -my $OP_THREADSV = opnumber('threadsv'); - -sub savesym { - my ($obj, $value) = @_; - my $sym = sprintf("s\\_%x", $$obj); - $symtable{$sym} = $value; -} - -sub objsym { - my $obj = shift; - return $symtable{sprintf("s\\_%x", $$obj)}; -} - -sub getsym { - my $sym = shift; - my $value; - - return 0 if $sym eq "sym_0"; # special case - $value = $symtable{$sym}; - if (defined($value)) { - return $value; - } else { - warn "warning: undefined symbol $sym\n" if $warn_undefined_syms; - return "UNUSED"; - } -} - -sub savere { - my $re = shift; - my $sym = sprintf("re%d", $re_index++); - $decl->add(sprintf("static char *$sym = %s;", cstring($re))); - - return ($sym,length(pack "a*",$re)); -} - -sub savepv { - my $pv = pack "a*", shift; - my $pvsym = 0; - my $pvmax = 0; - if ($pv_copy_on_grow) { - $pvsym = sprintf("pv%d", $pv_index++); - - if( defined $max_string_len && length($pv) > $max_string_len ) { - my $chars = join ', ', map { cchar $_ } split //, $pv; - $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars)); - } - else { - my $cstring = cstring($pv); - if ($cstring ne "0") { # sic - $decl->add(sprintf("static char %s[] = %s;", - $pvsym, $cstring)); - } - } - } else { - $pvmax = length(pack "a*",$pv) + 1; - } - return ($pvsym, $pvmax); -} - -sub save_rv { - my $sv = shift; -# confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK; - my $rv = $sv->RV->save; - - $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/; - - return $rv; -} - -# savesym, pvmax, len, pv -sub save_pv_or_rv { - my $sv = shift; - - my $rok = $sv->FLAGS & SVf_ROK; - my $pok = $sv->FLAGS & SVf_POK; - my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 ); - if( $rok ) { - $savesym = '(char*)' . save_rv( $sv ); - } - else { - $pv = $pok ? (pack "a*", $sv->PV) : undef; - $len = $pok ? length($pv) : 0; - ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 ); - } - - return ( $savesym, $pvmax, $len, $pv ); -} - -# see also init_op_ppaddr below; initializes the ppaddt to the -# OpTYPE; init_op_ppaddr iterates over the ops and sets -# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente -# in perl_init ( ~10 bytes/op with GCC/i386 ) -sub B::OP::fake_ppaddr { - return $optimize_ppaddr ? - sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) : - 'NULL'; -} - -# This pair is needed becase B::FAKEOP::save doesn't scalar dereference -# $op->next and $op->sibling - -{ - # For 5.9 the hard coded text is the values for op_opt and op_static in each - # op. The value of op_opt is irrelevant, and the value of op_static needs to - # be 1 to tell op_free that this is a statically defined op and that is - # shouldn't be freed. - - # For 5.8: - # Current workaround/fix for op_free() trying to free statically - # defined OPs is to set op_seq = -1 and check for that in op_free(). - # Instead of hardwiring -1 in place of $op->seq, we use $op_seq - # so that it can be changed back easily if necessary. In fact, to - # stop compilers from moaning about a U16 being initialised with an - # uncast -1 (the printf format is %d so we can't tweak it), we have - # to "know" that op_seq is a U16 and use 65535. Ugh. - - my $static = $] > 5.009 ? '0, 1, 0' : sprintf "%u", 65535; - sub B::OP::_save_common_middle { - my $op = shift; - sprintf ("%s, %u, %u, $static, 0x%x, 0x%x", - $op->fake_ppaddr, $op->targ, $op->type, $op->flags, $op->private); - } -} - -sub B::OP::_save_common { - my $op = shift; - return sprintf("s\\_%x, s\\_%x, %s", - ${$op->next}, ${$op->sibling}, $op->_save_common_middle); -} - -sub B::OP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - my $type = $op->type; - $nullop_count++ unless $type; - if ($type == $OP_THREADSV) { - # saves looking up ppaddr but it's a bit naughty to hard code this - $init->add(sprintf("(void)find_threadsv(%s);", - cstring($threadsv_names[$op->targ]))); - } - $opsect->add($op->_save_common); - my $ix = $opsect->index; - $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "&op_list[$ix]"); -} - -sub B::FAKEOP::new { - my ($class, %objdata) = @_; - bless \%objdata, $class; -} - -sub B::FAKEOP::save { - my ($op, $level) = @_; - $opsect->add(sprintf("%s, %s, %s", - $op->next, $op->sibling, $op->_save_common_middle)); - my $ix = $opsect->index; - $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - return "&op_list[$ix]"; -} - -sub B::FAKEOP::next { $_[0]->{"next"} || 0 } -sub B::FAKEOP::type { $_[0]->{type} || 0} -sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 } -sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 } -sub B::FAKEOP::targ { $_[0]->{targ} || 0 } -sub B::FAKEOP::flags { $_[0]->{flags} || 0 } -sub B::FAKEOP::private { $_[0]->{private} || 0 } - -sub B::UNOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $unopsect->add(sprintf("%s, s\\_%x", $op->_save_common, ${$op->first})); - my $ix = $unopsect->index; - $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&unop_list[$ix]"); -} - -sub B::BINOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $binopsect->add(sprintf("%s, s\\_%x, s\\_%x", - $op->_save_common, ${$op->first}, ${$op->last})); - my $ix = $binopsect->index; - $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&binop_list[$ix]"); -} - -sub B::LISTOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $listopsect->add(sprintf("%s, s\\_%x, s\\_%x", - $op->_save_common, ${$op->first}, ${$op->last})); - my $ix = $listopsect->index; - $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&listop_list[$ix]"); -} - -sub B::LOGOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $logopsect->add(sprintf("%s, s\\_%x, s\\_%x", - $op->_save_common, ${$op->first}, ${$op->other})); - my $ix = $logopsect->index; - $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&logop_list[$ix]"); -} - -sub B::LOOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", - # peekop($op->redoop), peekop($op->nextop), - # peekop($op->lastop)); # debug - $loopsect->add(sprintf("%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x", - $op->_save_common, ${$op->first}, ${$op->last}, - ${$op->redoop}, ${$op->nextop}, - ${$op->lastop})); - my $ix = $loopsect->index; - $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&loop_list[$ix]"); -} - -sub B::PVOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $pvopsect->add(sprintf("%s, %s", $op->_save_common, cstring($op->pv))); - my $ix = $pvopsect->index; - $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&pvop_list[$ix]"); -} - -sub B::SVOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - my $sv = $op->sv; - my $svsym = '(SV*)' . $sv->save; - my $is_const_addr = $svsym =~ m/Null|\&/; - $svopsect->add(sprintf("%s, %s", $op->_save_common, - ( $is_const_addr ? $svsym : 'Nullsv' ))); - my $ix = $svopsect->index; - $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - $init->add("svop_list[$ix].op_sv = $svsym;") - unless $is_const_addr; - savesym($op, "(OP*)&svop_list[$ix]"); -} - -sub B::PADOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $padopsect->add(sprintf("%s, %d", - $op->_save_common, $op->padix)); - my $ix = $padopsect->index; - $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; -# $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix)); - savesym($op, "(OP*)&padop_list[$ix]"); -} - -sub B::COP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - warn sprintf("COP: line %d file %s\n", $op->line, $op->file) - if $debug_cops; - # shameless cut'n'paste from B::Deparse - my $warn_sv; - my $warnings = $op->warnings; - my $is_special = $warnings->isa("B::SPECIAL"); - if ($is_special && $$warnings == 4) { - # use warnings 'all'; - $warn_sv = $optimize_warn_sv ? - 'INT2PTR(SV*,1)' : - 'pWARN_ALL'; - } - elsif ($is_special && $$warnings == 5) { - # no warnings 'all'; - $warn_sv = $optimize_warn_sv ? - 'INT2PTR(SV*,2)' : - 'pWARN_NONE'; - } - elsif ($is_special) { - # use warnings; - $warn_sv = $optimize_warn_sv ? - 'INT2PTR(SV*,3)' : - 'pWARN_STD'; - } - else { - # something else - $warn_sv = $warnings->save; - } - - $copsect->add(sprintf("%s, %s, NULL, NULL, %u, %d, %u, %s", - $op->_save_common, cstring($op->label), $op->cop_seq, - $op->arybase, $op->line, - ( $optimize_warn_sv ? $warn_sv : 'NULL' ))); - my $ix = $copsect->index; - $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv )) - unless $optimize_warn_sv; - $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)), - sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv))); - - savesym($op, "(OP*)&cop_list[$ix]"); -} - -sub B::PMOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - my $replroot = $op->pmreplroot; - my $replstart = $op->pmreplstart; - my $replrootfield; - my $replstartfield = sprintf("s\\_%x", $$replstart); - my $gvsym; - my $ppaddr = $op->ppaddr; - # under ithreads, OP_PUSHRE.op_replroot is an integer - $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot; - if($ithreads && $op->name eq "pushre") { - $replrootfield = "INT2PTR(OP*,${replroot})"; - } elsif ($$replroot) { - # OP_PUSHRE (a mutated version of OP_MATCH for the regexp - # argument to a split) stores a GV in op_pmreplroot instead - # of a substitution syntax tree. We don't want to walk that... - if ($op->name eq "pushre") { - $gvsym = $replroot->save; -# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug - $replrootfield = 0; - } else { - $replstartfield = saveoptree("*ignore*", $replroot, $replstart); - } - } - # pmnext handling is broken in perl itself, I think. Bad op_pmnext - # fields aren't noticed in perl's runtime (unless you try reset) but we - # segfault when trying to dereference it to find op->op_pmnext->op_type - $pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x", - $op->_save_common, ${$op->first}, ${$op->last}, - $replrootfield, $replstartfield, - ( $ithreads ? $op->pmoffset : 0 ), - $op->pmflags, $op->pmpermflags, $op->pmdynflags )); - my $pm = sprintf("pmop_list[%d]", $pmopsect->index); - $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr)) - unless $optimize_ppaddr; - my $re = $op->precomp; - if (defined($re)) { - my( $resym, $relen ) = savere( $re ); - $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));", - $relen)); - } - if ($gvsym) { - $init->add("$pm.op_pmreplroot = (OP*)$gvsym;"); - } - savesym($op, "(OP*)&$pm"); -} - -sub B::SPECIAL::save { - my ($sv) = @_; - # special case: $$sv is not the address but an index into specialsv_list -# warn "SPECIAL::save specialsv $$sv\n"; # debug - my $sym = $specialsv_name[$$sv]; - if (!defined($sym)) { - confess "unknown specialsv index $$sv passed to B::SPECIAL::save"; - } - return $sym; -} - -sub B::OBJECT::save {} - -sub B::NULL::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; -# warn "Saving SVt_NULL SV\n"; # debug - # debug - if ($$sv == 0) { - warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; - return savesym($sv, "(void*)Nullsv /* XXX */"); - } - $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::IV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX)); - $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x", - $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::NV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $val= $sv->NVX; - $val .= '.00' if $val =~ /^-?\d+$/; - $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val)); - $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub savepvn { - my ($dest,$pv) = @_; - my @res; - # work with byte offsets/lengths - my $pv = pack "a*", $pv; - if (defined $max_string_len && length($pv) > $max_string_len) { - push @res, sprintf("Newx(%s,%u,char);", $dest, length($pv)+1); - my $offset = 0; - while (length $pv) { - my $str = substr $pv, 0, $max_string_len, ''; - push @res, sprintf("Copy(%s,$dest+$offset,%u,char);", - cstring($str), length($str)); - $offset += length $str; - } - push @res, sprintf("%s[%u] = '\\0';", $dest, $offset); - } - else { - push @res, sprintf("%s = savepvn(%s, %u);", $dest, - cstring($pv), length($pv)); - } - return @res; -} - -sub B::PVLV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - my ($lvtarg, $lvtarg_sym); - $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, - $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE))); - $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", - $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv", - $xpvlvsect->index), $pv)); - } - $sv->save_magic; - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PVIV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); - $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX)); - $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", - $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); - if (defined($pv) && !$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv", - $xpvivsect->index), $pv)); - } - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PVNV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); - my $val= $sv->NVX; - $val .= '.00' if $val =~ /^-?\d+$/; - $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", - $savesym, $len, $pvmax, $sv->IVX, $val)); - $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); - if (defined($pv) && !$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv", - $xpvnvsect->index), $pv)); - } - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::BM::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE); - my $len = length($pv); - $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x", - $len, $len + 258, $sv->IVX, $sv->NVX, - $sv->USEFUL, $sv->PREVIOUS, $sv->RARE)); - $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", - $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS)); - $sv->save_magic; - $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv", - $xpvbmsect->index), $pv), - sprintf("xpvbm_list[%d].xpv_cur = %u;", - $xpvbmsect->index, $len - 257)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); - $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax)); - $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", - $xpvsect->index, $sv->REFCNT , $sv->FLAGS)); - if (defined($pv) && !$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv", - $xpvsect->index), $pv)); - } - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PVMG::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); - - $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", - $savesym, $len, $pvmax, - $sv->IVX, $sv->NVX)); - $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", - $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS)); - if (defined($pv) && !$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv", - $xpvmgsect->index), $pv)); - } - $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); - $sv->save_magic; - return $sym; -} - -sub B::PVMG::save_magic { - my ($sv) = @_; - #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug - my $stash = $sv->SvSTASH; - $stash->save; - if ($$stash) { - warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash) - if $debug_mg; - # XXX Hope stash is already going to be saved. - $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash)); - } - my @mgchain = $sv->MAGIC; - my ($mg, $type, $obj, $ptr,$len,$ptrsv); - foreach $mg (@mgchain) { - $type = $mg->TYPE; - $ptr = $mg->PTR; - $len=$mg->LENGTH; - if ($debug_mg) { - warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n", - class($sv), $$sv, class($obj), $$obj, - cchar($type), cstring($ptr)); - } - - unless( $type eq 'r' ) { - $obj = $mg->OBJ; - $obj->save; - } - - if ($len == HEf_SVKEY){ - #The pointer is an SV* - $ptrsv=svref_2object($ptr)->save; - $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);", - $$sv, $$obj, cchar($type),$ptrsv,$len)); - }elsif( $type eq 'r' ){ - my $rx = $mg->REGEX; - my $pmop = $REGEXP{$rx}; - - confess "PMOP not found for REGEXP $rx" unless $pmop; - - my( $resym, $relen ) = savere( $mg->precomp ); - my $pmsym = $pmop->save; - $init->add( split /\n/, sprintf <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/installer/perllib/B/CC.pm b/Master/tlpkg/installer/perllib/B/CC.pm deleted file mode 100644 index 079313a0a4e..00000000000 --- a/Master/tlpkg/installer/perllib/B/CC.pm +++ /dev/null @@ -1,2005 +0,0 @@ -# CC.pm -# -# Copyright (c) 1996, 1997, 1998 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::CC; - -our $VERSION = '1.00_01'; - -use Config; -use strict; -use B qw(main_start main_root class comppadlist peekop svref_2object - timing_info init_av sv_undef amagic_generation - OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL - OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV - OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR - CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK - ); -use B::C qw(save_unused_subs objsym init_sections mark_unused - output_all output_boilerplate output_main); -use B::Bblock qw(find_leaders); -use B::Stackobj qw(:types :flags); - -# These should probably be elsewhere -# Flags for $op->flags - -my $module; # module name (when compiled with -m) -my %done; # hash keyed by $$op of leaders of basic blocks - # which have already been done. -my $leaders; # ref to hash of basic block leaders. Keys are $$op - # addresses, values are the $op objects themselves. -my @bblock_todo; # list of leaders of basic blocks that need visiting - # sometime. -my @cc_todo; # list of tuples defining what PP code needs to be - # saved (e.g. CV, main or PMOP repl code). Each tuple - # is [$name, $root, $start, @padlist]. PMOP repl code - # tuples inherit padlist. -my @stack; # shadows perl's stack when contents are known. - # Values are objects derived from class B::Stackobj -my @pad; # Lexicals in current pad as Stackobj-derived objects -my @padlist; # Copy of current padlist so PMOP repl code can find it -my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo -my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs -my %constobj; # OP_CONST constants as Stackobj-derived objects - # keyed by $$sv. -my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic - # block or even to the end of each loop of blocks, - # depending on optimisation options. -my $know_op = 0; # Set when C variable op already holds the right op - # (from an immediately preceding DOOP(ppname)). -my $errors = 0; # Number of errors encountered -my %skip_stack; # Hash of PP names which don't need write_back_stack -my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals -my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals -my %ignore_op; # Hash of ops which do nothing except returning op_next -my %need_curcop; # Hash of ops which need PL_curcop - -my %lexstate; #state of padsvs at the start of a bblock - -BEGIN { - foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) { - $ignore_op{$_} = 1; - } -} - -my ($module_name); -my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime, - $debug_shadow, $debug_queue, $debug_lineno, $debug_timings); - -# Optimisation options. On the command line, use hyphens instead of -# underscores for compatibility with gcc-style options. We use -# underscores here because they are OK in (strict) barewords. -my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint); -my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock, - freetmps_each_loop => \$freetmps_each_loop, - omit_taint => \$omit_taint); -# perl patchlevel to generate code for (defaults to current patchlevel) -my $patchlevel = int(0.5 + 1000 * ($] - 5)); - -# Could rewrite push_runtime() and output_runtime() to use a -# temporary file if memory is at a premium. -my $ppname; # name of current fake PP function -my $runtime_list_ref; -my $declare_ref; # Hash ref keyed by C variable type of declarations. - -my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref] - # tuples to be written out. - -my ($init, $decl); - -sub init_hash { map { $_ => 1 } @_ } - -# -# Initialise the hashes for the default PP functions where we can avoid -# either write_back_stack, write_back_lexicals or invalidate_lexicals. -# -%skip_lexicals = init_hash qw(pp_enter pp_enterloop); -%skip_invalidate = init_hash qw(pp_enter pp_enterloop); -%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller - pp_reset pp_rv2cv pp_entereval pp_require pp_dofile - pp_entertry pp_enterloop pp_enteriter pp_entersub - pp_enter pp_method); - -sub debug { - if ($debug_runtime) { - warn(@_); - } else { - my @tmp=@_; - runtime(map { chomp; "/* $_ */"} @tmp); - } -} - -sub declare { - my ($type, $var) = @_; - push(@{$declare_ref->{$type}}, $var); -} - -sub push_runtime { - push(@$runtime_list_ref, @_); - warn join("\n", @_) . "\n" if $debug_runtime; -} - -sub save_runtime { - push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]); -} - -sub output_runtime { - my $ppdata; - print qq(#include "cc_runtime.h"\n); - foreach $ppdata (@pp_list) { - my ($name, $runtime, $declare) = @$ppdata; - print "\nstatic\nCCPP($name)\n{\n"; - my ($type, $varlist, $line); - while (($type, $varlist) = each %$declare) { - print "\t$type ", join(", ", @$varlist), ";\n"; - } - foreach $line (@$runtime) { - print $line, "\n"; - } - print "}\n"; - } -} - -sub runtime { - my $line; - foreach $line (@_) { - push_runtime("\t$line"); - } -} - -sub init_pp { - $ppname = shift; - $runtime_list_ref = []; - $declare_ref = {}; - runtime("dSP;"); - declare("I32", "oldsave"); - declare("SV", "**svp"); - map { declare("SV", "*$_") } qw(sv src dst left right); - declare("MAGIC", "*mg"); - $decl->add("static OP * $ppname (pTHX);"); - debug "init_pp: $ppname\n" if $debug_queue; -} - -# Initialise runtime_callback function for Stackobj class -BEGIN { B::Stackobj::set_callback(\&runtime) } - -# Initialise saveoptree_callback for B::C class -sub cc_queue { - my ($name, $root, $start, @pl) = @_; - debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n" - if $debug_queue; - if ($name eq "*ignore*") { - $name = 0; - } else { - push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]); - } - my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name); - $start = $fakeop->save; - debug "cc_queue: name $name returns $start\n" if $debug_queue; - return $start; -} -BEGIN { B::C::set_callback(\&cc_queue) } - -sub valid_int { $_[0]->{flags} & VALID_INT } -sub valid_double { $_[0]->{flags} & VALID_DOUBLE } -sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) } -sub valid_sv { $_[0]->{flags} & VALID_SV } - -sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } -sub top_double { @stack ? $stack[-1]->as_double : "TOPn" } -sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" } -sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" } -sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" } - -sub pop_int { @stack ? (pop @stack)->as_int : "POPi" } -sub pop_double { @stack ? (pop @stack)->as_double : "POPn" } -sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" } -sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" } -sub pop_bool { - if (@stack) { - return ((pop @stack)->as_bool); - } else { - # Careful: POPs has an auto-decrement and SvTRUE evaluates - # its argument more than once. - runtime("sv = POPs;"); - return "SvTRUE(sv)"; - } -} - -sub write_back_lexicals { - my $avoid = shift || 0; - debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n" - if $debug_shadow; - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - $lex->write_back unless $lex->{flags} & $avoid; - } -} - -sub save_or_restore_lexical_state { - my $bblock=shift; - unless( exists $lexstate{$bblock}){ - foreach my $lex (@pad) { - next unless ref($lex); - ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ; - } - } - else { - foreach my $lex (@pad) { - next unless ref($lex); - my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ; - next if ( $old_flags eq $lex->{flags}); - if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){ - $lex->write_back; - } - if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){ - $lex->load_double; - } - if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){ - $lex->load_int; - } - } - } -} - -sub write_back_stack { - my $obj; - return unless @stack; - runtime(sprintf("EXTEND(sp, %d);", scalar(@stack))); - foreach $obj (@stack) { - runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv)); - } - @stack = (); -} - -sub invalidate_lexicals { - my $avoid = shift || 0; - debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n" - if $debug_shadow; - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - $lex->invalidate unless $lex->{flags} & $avoid; - } -} - -sub reload_lexicals { - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - my $type = $lex->{type}; - if ($type == T_INT) { - $lex->as_int; - } elsif ($type == T_DOUBLE) { - $lex->as_double; - } else { - $lex->as_sv; - } - } -} - -{ - package B::Pseudoreg; - # - # This class allocates pseudo-registers (OK, so they're C variables). - # - my %alloc; # Keyed by variable name. A value of 1 means the - # variable has been declared. A value of 2 means - # it's in use. - - sub new_scope { %alloc = () } - - sub new ($$$) { - my ($class, $type, $prefix) = @_; - my ($ptr, $i, $varname, $status, $obj); - $prefix =~ s/^(\**)//; - $ptr = $1; - $i = 0; - do { - $varname = "$prefix$i"; - $status = $alloc{$varname}; - } while $status == 2; - if ($status != 1) { - # Not declared yet - B::CC::declare($type, "$ptr$varname"); - $alloc{$varname} = 2; # declared and in use - } - $obj = bless \$varname, $class; - return $obj; - } - sub DESTROY { - my $obj = shift; - $alloc{$$obj} = 1; # no longer in use but still declared - } -} -{ - package B::Shadow; - # - # This class gives a standard API for a perl object to shadow a - # C variable and only generate reloads/write-backs when necessary. - # - # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo"). - # Use $obj->write_back whenever shadowed_c_var needs to be up to date. - # Use $obj->invalidate whenever an unknown function may have - # set shadow itself. - - sub new { - my ($class, $write_back) = @_; - # Object fields are perl shadow variable, validity flag - # (for *C* variable) and callback sub for write_back - # (passed perl shadow variable as argument). - bless [undef, 1, $write_back], $class; - } - sub load { - my ($obj, $newval) = @_; - $obj->[1] = 0; # C variable no longer valid - $obj->[0] = $newval; - } - sub write_back { - my $obj = shift; - if (!($obj->[1])) { - $obj->[1] = 1; # C variable will now be valid - &{$obj->[2]}($obj->[0]); - } - } - sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid -} -my $curcop = new B::Shadow (sub { - my $opsym = shift->save; - runtime("PL_curcop = (COP*)$opsym;"); -}); - -# -# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on. -# -sub dopoptoloop { - my $cxix = $#cxstack; - while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) { - $cxix--; - } - debug "dopoptoloop: returning $cxix" if $debug_cxstack; - return $cxix; -} - -sub dopoptolabel { - my $label = shift; - my $cxix = $#cxstack; - while ($cxix >= 0 && - ($cxstack[$cxix]->{type} != CXt_LOOP || - $cxstack[$cxix]->{label} ne $label)) { - $cxix--; - } - debug "dopoptolabel: returning $cxix" if $debug_cxstack; - return $cxix; -} - -sub error { - my $format = shift; - my $file = $curcop->[0]->file; - my $line = $curcop->[0]->line; - $errors++; - if (@_) { - warn sprintf("%s:%d: $format\n", $file, $line, @_); - } else { - warn sprintf("%s:%d: %s\n", $file, $line, $format); - } -} - -# -# Load pad takes (the elements of) a PADLIST as arguments and loads -# up @pad with Stackobj-derived objects which represent those lexicals. -# If/when perl itself can generate type information (my int $foo) then -# we'll take advantage of that here. Until then, we'll use various hacks -# to tell the compiler when we want a lexical to be a particular type -# or to be a register. -# -sub load_pad { - my ($namelistav, $valuelistav) = @_; - @padlist = @_; - my @namelist = $namelistav->ARRAY; - my @valuelist = $valuelistav->ARRAY; - my $ix; - @pad = (); - debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad; - # Temporary lexicals don't get named so it's possible for @valuelist - # to be strictly longer than @namelist. We count $ix up to the end of - # @valuelist but index into @namelist for the name. Any temporaries which - # run off the end of @namelist will make $namesv undefined and we treat - # that the same as having an explicit SPECIAL sv_undef object in @namelist. - # [XXX If/when @_ becomes a lexical, we must start at 0 here.] - for ($ix = 1; $ix < @valuelist; $ix++) { - my $namesv = $namelist[$ix]; - my $type = T_UNKNOWN; - my $flags = 0; - my $name = "tmp$ix"; - my $class = class($namesv); - if (!defined($namesv) || $class eq "SPECIAL") { - # temporaries have &PL_sv_undef instead of a PVNV for a name - $flags = VALID_SV|TEMPORARY|REGISTER; - } else { - if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) { - $name = $1; - if ($2 eq "i") { - $type = T_INT; - $flags = VALID_SV|VALID_INT; - } elsif ($2 eq "d") { - $type = T_DOUBLE; - $flags = VALID_SV|VALID_DOUBLE; - } - $flags |= REGISTER if $3; - } - } - $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix, - "i_$name", "d_$name"); - - debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad; - } -} - -sub declare_pad { - my $ix; - for ($ix = 1; $ix <= $#pad; $ix++) { - my $type = $pad[$ix]->{type}; - declare("IV", $type == T_INT ? - sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int; - declare("double", $type == T_DOUBLE ? - sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double; - - } -} -# -# Debugging stuff -# -sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) } - -# -# OP stuff -# - -sub label { - my $op = shift; - # XXX Preserve original label name for "real" labels? - return sprintf("lab_%x", $$op); -} - -sub write_label { - my $op = shift; - push_runtime(sprintf(" %s:", label($op))); -} - -sub loadop { - my $op = shift; - my $opsym = $op->save; - runtime("PL_op = $opsym;") unless $know_op; - return $opsym; -} - -sub doop { - my $op = shift; - my $ppname = $op->ppaddr; - my $sym = loadop($op); - runtime("DOOP($ppname);"); - $know_op = 1; - return $sym; -} - -sub gimme { - my $op = shift; - my $flags = $op->flags; - return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()"); -} - -# -# Code generation for PP code -# - -sub pp_null { - my $op = shift; - return $op->next; -} - -sub pp_stub { - my $op = shift; - my $gimme = gimme($op); - if ($gimme != G_ARRAY) { - my $obj= new B::Stackobj::Const(sv_undef); - push(@stack, $obj); - # XXX Change to push a constant sv_undef Stackobj onto @stack - #write_back_stack(); - #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);"); - } - return $op->next; -} - -sub pp_unstack { - my $op = shift; - @stack = (); - runtime("PP_UNSTACK;"); - return $op->next; -} - -sub pp_and { - my $op = shift; - my $next = $op->next; - reload_lexicals(); - unshift(@bblock_todo, $next); - if (@stack >= 1) { - my $bool = pop_bool(); - write_back_stack(); - save_or_restore_lexical_state($$next); - runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next))); - } else { - save_or_restore_lexical_state($$next); - runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)), - "*sp--;"); - } - return $op->other; -} - -sub pp_or { - my $op = shift; - my $next = $op->next; - reload_lexicals(); - unshift(@bblock_todo, $next); - if (@stack >= 1) { - my $bool = pop_bool @stack; - write_back_stack(); - save_or_restore_lexical_state($$next); - runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }", - $bool, label($next))); - } else { - save_or_restore_lexical_state($$next); - runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)), - "*sp--;"); - } - return $op->other; -} - -sub pp_cond_expr { - my $op = shift; - my $false = $op->next; - unshift(@bblock_todo, $false); - reload_lexicals(); - my $bool = pop_bool(); - write_back_stack(); - save_or_restore_lexical_state($$false); - runtime(sprintf("if (!$bool) goto %s;", label($false))); - return $op->other; -} - -sub pp_padsv { - my $op = shift; - my $ix = $op->targ; - push(@stack, $pad[$ix]); - if ($op->flags & OPf_MOD) { - my $private = $op->private; - if ($private & OPpLVAL_INTRO) { - runtime("SAVECLEARSV(PL_curpad[$ix]);"); - } elsif ($private & OPpDEREF) { - runtime(sprintf("vivify_ref(PL_curpad[%d], %d);", - $ix, $private & OPpDEREF)); - $pad[$ix]->invalidate; - } - } - return $op->next; -} - -sub pp_const { - my $op = shift; - my $sv = $op->sv; - my $obj; - # constant could be in the pad (under useithreads) - if ($$sv) { - $obj = $constobj{$$sv}; - if (!defined($obj)) { - $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); - } - } - else { - $obj = $pad[$op->targ]; - } - push(@stack, $obj); - return $op->next; -} - -sub pp_nextstate { - my $op = shift; - $curcop->load($op); - @stack = (); - debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno; - runtime("TAINT_NOT;") unless $omit_taint; - runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); - if ($freetmps_each_bblock || $freetmps_each_loop) { - $need_freetmps = 1; - } else { - runtime("FREETMPS;"); - } - return $op->next; -} - -sub pp_dbstate { - my $op = shift; - $curcop->invalidate; # XXX? - return default_pp($op); -} - -#default_pp will handle this: -#sub pp_bless { $curcop->write_back; default_pp(@_) } -#sub pp_repeat { $curcop->write_back; default_pp(@_) } -# The following subs need $curcop->write_back if we decide to support arybase: -# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice -#sub pp_caller { $curcop->write_back; default_pp(@_) } -#sub pp_reset { $curcop->write_back; default_pp(@_) } - -sub pp_rv2gv{ - my $op =shift; - $curcop->write_back; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - my $sym=doop($op); - if ($op->private & OPpDEREF) { - $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;")); - $init->add(sprintf("((UNOP *)$sym)->op_type = %d;", - $op->first->type)); - } - return $op->next; -} -sub pp_sort { - my $op = shift; - my $ppname = $op->ppaddr; - if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){ - #this indicates the sort BLOCK Array case - #ugly surgery required. - my $root=$op->first->sibling->first; - my $start=$root->first; - $op->first->save; - $op->first->sibling->save; - $root->save; - my $sym=$start->save; - my $fakeop=cc_queue("pp_sort".$$op,$root,$start); - $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop)); - } - $curcop->write_back; - write_back_lexicals(); - write_back_stack(); - doop($op); - return $op->next; -} - -sub pp_gv { - my $op = shift; - my $gvsym; - if ($Config{useithreads}) { - $gvsym = $pad[$op->padix]->as_sv; - } - else { - $gvsym = $op->gv->save; - } - write_back_stack(); - runtime("XPUSHs((SV*)$gvsym);"); - return $op->next; -} - -sub pp_gvsv { - my $op = shift; - my $gvsym; - if ($Config{useithreads}) { - $gvsym = $pad[$op->padix]->as_sv; - } - else { - $gvsym = $op->gv->save; - } - write_back_stack(); - if ($op->private & OPpLVAL_INTRO) { - runtime("XPUSHs(save_scalar($gvsym));"); - } else { - runtime("XPUSHs(GvSV($gvsym));"); - } - return $op->next; -} - -sub pp_aelemfast { - my $op = shift; - my $gvsym; - if ($Config{useithreads}) { - $gvsym = $pad[$op->padix]->as_sv; - } - else { - $gvsym = $op->gv->save; - } - my $ix = $op->private; - my $flag = $op->flags & OPf_MOD; - write_back_stack(); - runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);", - "PUSHs(svp ? *svp : &PL_sv_undef);"); - return $op->next; -} - -sub int_binop { - my ($op, $operator) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_int(); - if (@stack >= 1) { - my $left = top_int(); - $stack[-1]->set_int(&$operator($left, $right)); - } else { - runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right))); - } - } else { - my $targ = $pad[$op->targ]; - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int)); - $targ->set_int(&$operator($$left, $$right)); - push(@stack, $targ); - } - return $op->next; -} - -sub INTS_CLOSED () { 0x1 } -sub INT_RESULT () { 0x2 } -sub NUMERIC_RESULT () { 0x4 } - -sub numeric_binop { - my ($op, $operator, $flags) = @_; - my $force_int = 0; - $force_int ||= ($flags & INT_RESULT); - $force_int ||= ($flags & INTS_CLOSED && @stack >= 2 - && valid_int($stack[-2]) && valid_int($stack[-1])); - if ($op->flags & OPf_STACKED) { - my $right = pop_numeric(); - if (@stack >= 1) { - my $left = top_numeric(); - if ($force_int) { - $stack[-1]->set_int(&$operator($left, $right)); - } else { - $stack[-1]->set_numeric(&$operator($left, $right)); - } - } else { - if ($force_int) { - my $rightruntime = new B::Pseudoreg ("IV", "riv"); - runtime(sprintf("$$rightruntime = %s;",$right)); - runtime(sprintf("sv_setiv(TOPs, %s);", - &$operator("TOPi", $$rightruntime))); - } else { - my $rightruntime = new B::Pseudoreg ("double", "rnv"); - runtime(sprintf("$$rightruntime = %s;",$right)); - runtime(sprintf("sv_setnv(TOPs, %s);", - &$operator("TOPn",$$rightruntime))); - } - } - } else { - my $targ = $pad[$op->targ]; - $force_int ||= ($targ->{type} == T_INT); - if ($force_int) { - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - $targ->set_int(&$operator($$left, $$right)); - } else { - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - $targ->set_numeric(&$operator($$left, $$right)); - } - push(@stack, $targ); - } - return $op->next; -} - -sub pp_ncmp { - my ($op) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_numeric(); - if (@stack >= 1) { - my $left = top_numeric(); - runtime sprintf("if (%s > %s){",$left,$right); - $stack[-1]->set_int(1); - $stack[-1]->write_back(); - runtime sprintf("}else if (%s < %s ) {",$left,$right); - $stack[-1]->set_int(-1); - $stack[-1]->write_back(); - runtime sprintf("}else if (%s == %s) {",$left,$right); - $stack[-1]->set_int(0); - $stack[-1]->write_back(); - runtime sprintf("}else {"); - $stack[-1]->set_sv("&PL_sv_undef"); - runtime "}"; - } else { - my $rightruntime = new B::Pseudoreg ("double", "rnv"); - runtime(sprintf("$$rightruntime = %s;",$right)); - runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime); - runtime sprintf("sv_setiv(TOPs,1);"); - runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime); - runtime sprintf("sv_setiv(TOPs,-1);"); - runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime); - runtime sprintf("sv_setiv(TOPs,0);"); - runtime sprintf(qq/}else {/); - runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;"); - runtime "}"; - } - } else { - my $targ = $pad[$op->targ]; - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - runtime sprintf("if (%s > %s){",$$left,$$right); - $targ->set_int(1); - $targ->write_back(); - runtime sprintf("}else if (%s < %s ) {",$$left,$$right); - $targ->set_int(-1); - $targ->write_back(); - runtime sprintf("}else if (%s == %s) {",$$left,$$right); - $targ->set_int(0); - $targ->write_back(); - runtime sprintf("}else {"); - $targ->set_sv("&PL_sv_undef"); - runtime "}"; - push(@stack, $targ); - } - return $op->next; -} - -sub sv_binop { - my ($op, $operator, $flags) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_sv(); - if (@stack >= 1) { - my $left = top_sv(); - if ($flags & INT_RESULT) { - $stack[-1]->set_int(&$operator($left, $right)); - } elsif ($flags & NUMERIC_RESULT) { - $stack[-1]->set_numeric(&$operator($left, $right)); - } else { - # XXX Does this work? - runtime(sprintf("sv_setsv($left, %s);", - &$operator($left, $right))); - $stack[-1]->invalidate; - } - } else { - my $f; - if ($flags & INT_RESULT) { - $f = "sv_setiv"; - } elsif ($flags & NUMERIC_RESULT) { - $f = "sv_setnv"; - } else { - $f = "sv_setsv"; - } - runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right))); - } - } else { - my $targ = $pad[$op->targ]; - runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv)); - if ($flags & INT_RESULT) { - $targ->set_int(&$operator("left", "right")); - } elsif ($flags & NUMERIC_RESULT) { - $targ->set_numeric(&$operator("left", "right")); - } else { - # XXX Does this work? - runtime(sprintf("sv_setsv(%s, %s);", - $targ->as_sv, &$operator("left", "right"))); - $targ->invalidate; - } - push(@stack, $targ); - } - return $op->next; -} - -sub bool_int_binop { - my ($op, $operator) = @_; - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_int(&$operator($$left, $$right)); - push(@stack, $bool); - return $op->next; -} - -sub bool_numeric_binop { - my ($op, $operator) = @_; - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_numeric(&$operator($$left, $$right)); - push(@stack, $bool); - return $op->next; -} - -sub bool_sv_binop { - my ($op, $operator) = @_; - runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_numeric(&$operator("left", "right")); - push(@stack, $bool); - return $op->next; -} - -sub infix_op { - my $opname = shift; - return sub { "$_[0] $opname $_[1]" } -} - -sub prefix_op { - my $opname = shift; - return sub { sprintf("%s(%s)", $opname, join(", ", @_)) } -} - -BEGIN { - my $plus_op = infix_op("+"); - my $minus_op = infix_op("-"); - my $multiply_op = infix_op("*"); - my $divide_op = infix_op("/"); - my $modulo_op = infix_op("%"); - my $lshift_op = infix_op("<<"); - my $rshift_op = infix_op(">>"); - my $scmp_op = prefix_op("sv_cmp"); - my $seq_op = prefix_op("sv_eq"); - my $sne_op = prefix_op("!sv_eq"); - my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" }; - my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" }; - my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" }; - my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" }; - my $eq_op = infix_op("=="); - my $ne_op = infix_op("!="); - my $lt_op = infix_op("<"); - my $gt_op = infix_op(">"); - my $le_op = infix_op("<="); - my $ge_op = infix_op(">="); - - # - # XXX The standard perl PP code has extra handling for - # some special case arguments of these operators. - # - sub pp_add { numeric_binop($_[0], $plus_op) } - sub pp_subtract { numeric_binop($_[0], $minus_op) } - sub pp_multiply { numeric_binop($_[0], $multiply_op) } - sub pp_divide { numeric_binop($_[0], $divide_op) } - sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's - - sub pp_left_shift { int_binop($_[0], $lshift_op) } - sub pp_right_shift { int_binop($_[0], $rshift_op) } - sub pp_i_add { int_binop($_[0], $plus_op) } - sub pp_i_subtract { int_binop($_[0], $minus_op) } - sub pp_i_multiply { int_binop($_[0], $multiply_op) } - sub pp_i_divide { int_binop($_[0], $divide_op) } - sub pp_i_modulo { int_binop($_[0], $modulo_op) } - - sub pp_eq { bool_numeric_binop($_[0], $eq_op) } - sub pp_ne { bool_numeric_binop($_[0], $ne_op) } - sub pp_lt { bool_numeric_binop($_[0], $lt_op) } - sub pp_gt { bool_numeric_binop($_[0], $gt_op) } - sub pp_le { bool_numeric_binop($_[0], $le_op) } - sub pp_ge { bool_numeric_binop($_[0], $ge_op) } - - sub pp_i_eq { bool_int_binop($_[0], $eq_op) } - sub pp_i_ne { bool_int_binop($_[0], $ne_op) } - sub pp_i_lt { bool_int_binop($_[0], $lt_op) } - sub pp_i_gt { bool_int_binop($_[0], $gt_op) } - sub pp_i_le { bool_int_binop($_[0], $le_op) } - sub pp_i_ge { bool_int_binop($_[0], $ge_op) } - - sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) } - sub pp_slt { bool_sv_binop($_[0], $slt_op) } - sub pp_sgt { bool_sv_binop($_[0], $sgt_op) } - sub pp_sle { bool_sv_binop($_[0], $sle_op) } - sub pp_sge { bool_sv_binop($_[0], $sge_op) } - sub pp_seq { bool_sv_binop($_[0], $seq_op) } - sub pp_sne { bool_sv_binop($_[0], $sne_op) } -} - - -sub pp_sassign { - my $op = shift; - my $backwards = $op->private & OPpASSIGN_BACKWARDS; - my ($dst, $src); - if (@stack >= 2) { - $dst = pop @stack; - $src = pop @stack; - ($src, $dst) = ($dst, $src) if $backwards; - my $type = $src->{type}; - if ($type == T_INT) { - $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED); - } elsif ($type == T_DOUBLE) { - $dst->set_numeric($src->as_numeric); - } else { - $dst->set_sv($src->as_sv); - } - push(@stack, $dst); - } elsif (@stack == 1) { - if ($backwards) { - my $src = pop @stack; - my $type = $src->{type}; - runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); - if ($type == T_INT) { - if ($src->{flags} & VALID_UNSIGNED){ - runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int); - }else{ - runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); - } - } elsif ($type == T_DOUBLE) { - runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double); - } else { - runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv); - } - runtime("SvSETMAGIC(TOPs);"); - } else { - my $dst = $stack[-1]; - my $type = $dst->{type}; - runtime("sv = POPs;"); - runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); - if ($type == T_INT) { - $dst->set_int("SvIV(sv)"); - } elsif ($type == T_DOUBLE) { - $dst->set_double("SvNV(sv)"); - } else { - runtime("SvSetMagicSV($dst->{sv}, sv);"); - $dst->invalidate; - } - } - } else { - if ($backwards) { - runtime("src = POPs; dst = TOPs;"); - } else { - runtime("dst = POPs; src = TOPs;"); - } - runtime("MAYBE_TAINT_SASSIGN_SRC(src);", - "SvSetSV(dst, src);", - "SvSETMAGIC(dst);", - "SETs(dst);"); - } - return $op->next; -} - -sub pp_preinc { - my $op = shift; - if (@stack >= 1) { - my $obj = $stack[-1]; - my $type = $obj->{type}; - if ($type == T_INT || $type == T_DOUBLE) { - $obj->set_int($obj->as_int . " + 1"); - } else { - runtime sprintf("PP_PREINC(%s);", $obj->as_sv); - $obj->invalidate(); - } - } else { - runtime sprintf("PP_PREINC(TOPs);"); - } - return $op->next; -} - - -sub pp_pushmark { - my $op = shift; - write_back_stack(); - runtime("PUSHMARK(sp);"); - return $op->next; -} - -sub pp_list { - my $op = shift; - write_back_stack(); - my $gimme = gimme($op); - if ($gimme == G_ARRAY) { # sic - runtime("POPMARK;"); # need this even though not a "full" pp_list - } else { - runtime("PP_LIST($gimme);"); - } - return $op->next; -} - -sub pp_entersub { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); - runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);"); - runtime("SPAGAIN;}"); - $know_op = 0; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} -sub pp_formline { - my $op = shift; - my $ppname = $op->ppaddr; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - my $sym=doop($op); - # See comment in pp_grepwhile to see why! - $init->add("((LISTOP*)$sym)->op_first = $sym;"); - runtime("if (PL_op == ((LISTOP*)($sym))->op_first){"); - save_or_restore_lexical_state(${$op->first}); - runtime( sprintf("goto %s;",label($op->first))); - runtime("}"); - return $op->next; -} - -sub pp_goto{ - - my $op = shift; - my $ppname = $op->ppaddr; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - my $sym=doop($op); - runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}"); - invalidate_lexicals() unless $skip_invalidate{$ppname}; - return $op->next; -} -sub pp_enterwrite { - my $op = shift; - pp_entersub($op); -} -sub pp_leavesub{ - my $op = shift; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){"); - runtime("\tPUTBACK;return 0;"); - runtime("}"); - doop($op); - return $op->next; -} -sub pp_leavewrite { - my $op = shift; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - # XXX Is this the right way to distinguish between it returning - # CvSTART(cv) (via doform) and pop_return()? - #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);"); - runtime("SPAGAIN;"); - $know_op = 0; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub doeval { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = loadop($op); - my $ppaddr = $op->ppaddr; - #runtime(qq/printf("$ppaddr type eval\n");/); - runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); - $know_op = 1; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub pp_entereval { doeval(@_) } -sub pp_dofile { doeval(@_) } - -#pp_require is protected by pp_entertry, so no protection for it. -sub pp_require { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); - runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); - runtime("SPAGAIN;}"); - $know_op = 1; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - - -sub pp_entertry { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++); - declare("JMPENV", $jmpbuf); - runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next))); - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub pp_leavetry{ - my $op=shift; - default_pp($op); - runtime("PP_LEAVETRY;"); - return $op->next; -} - -sub pp_grepstart { - my $op = shift; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up - $need_freetmps = 0; - } - write_back_stack(); - my $sym= doop($op); - my $next=$op->next; - $next->save; - my $nexttonext=$next->next; - $nexttonext->save; - save_or_restore_lexical_state($$nexttonext); - runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", - label($nexttonext))); - return $op->next->other; -} - -sub pp_mapstart { - my $op = shift; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up - $need_freetmps = 0; - } - write_back_stack(); - # pp_mapstart can return either op_next->op_next or op_next->op_other and - # we need to be able to distinguish the two at runtime. - my $sym= doop($op); - my $next=$op->next; - $next->save; - my $nexttonext=$next->next; - $nexttonext->save; - save_or_restore_lexical_state($$nexttonext); - runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", - label($nexttonext))); - return $op->next->other; -} - -sub pp_grepwhile { - my $op = shift; - my $next = $op->next; - unshift(@bblock_todo, $next); - write_back_lexicals(); - write_back_stack(); - my $sym = doop($op); - # pp_grepwhile can return either op_next or op_other and we need to - # be able to distinguish the two at runtime. Since it's possible for - # both ops to be "inlined", the fields could both be zero. To get - # around that, we hack op_next to be our own op (purely because we - # know it's a non-NULL pointer and can't be the same as op_other). - $init->add("((LOGOP*)$sym)->op_next = $sym;"); - save_or_restore_lexical_state($$next); - runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next))); - $know_op = 0; - return $op->other; -} - -sub pp_mapwhile { - pp_grepwhile(@_); -} - -sub pp_return { - my $op = shift; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - doop($op); - runtime("PUTBACK;", "return PL_op;"); - $know_op = 0; - return $op->next; -} - -sub nyi { - my $op = shift; - warn sprintf("%s not yet implemented properly\n", $op->ppaddr); - return default_pp($op); -} - -sub pp_range { - my $op = shift; - my $flags = $op->flags; - if (!($flags & OPf_WANT)) { - error("context of range unknown at compile-time"); - } - write_back_lexicals(); - write_back_stack(); - unless (($flags & OPf_WANT)== OPf_WANT_LIST) { - # We need to save our UNOP structure since pp_flop uses - # it to find and adjust out targ. We don't need it ourselves. - $op->save; - save_or_restore_lexical_state(${$op->other}); - runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;", - $op->targ, label($op->other)); - unshift(@bblock_todo, $op->other); - } - return $op->next; -} - -sub pp_flip { - my $op = shift; - my $flags = $op->flags; - if (!($flags & OPf_WANT)) { - error("context of flip unknown at compile-time"); - } - if (($flags & OPf_WANT)==OPf_WANT_LIST) { - return $op->first->other; - } - write_back_lexicals(); - write_back_stack(); - # We need to save our UNOP structure since pp_flop uses - # it to find and adjust out targ. We don't need it ourselves. - $op->save; - my $ix = $op->targ; - my $rangeix = $op->first->targ; - runtime(($op->private & OPpFLIP_LINENUM) ? - "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {" - : "if (SvTRUE(TOPs)) {"); - runtime("\tsv_setiv(PL_curpad[$rangeix], 1);"); - if ($op->flags & OPf_SPECIAL) { - runtime("sv_setiv(PL_curpad[$ix], 1);"); - } else { - save_or_restore_lexical_state(${$op->first->other}); - runtime("\tsv_setiv(PL_curpad[$ix], 0);", - "\tsp--;", - sprintf("\tgoto %s;", label($op->first->other))); - } - runtime("}", - qq{sv_setpv(PL_curpad[$ix], "");}, - "SETs(PL_curpad[$ix]);"); - $know_op = 0; - return $op->next; -} - -sub pp_flop { - my $op = shift; - default_pp($op); - $know_op = 0; - return $op->next; -} - -sub enterloop { - my $op = shift; - my $nextop = $op->nextop; - my $lastop = $op->lastop; - my $redoop = $op->redoop; - $curcop->write_back; - debug "enterloop: pushing on cxstack" if $debug_cxstack; - push(@cxstack, { - type => CXt_LOOP, - op => $op, - "label" => $curcop->[0]->label, - nextop => $nextop, - lastop => $lastop, - redoop => $redoop - }); - $nextop->save; - $lastop->save; - $redoop->save; - return default_pp($op); -} - -sub pp_enterloop { enterloop(@_) } -sub pp_enteriter { enterloop(@_) } - -sub pp_leaveloop { - my $op = shift; - if (!@cxstack) { - die "panic: leaveloop"; - } - debug "leaveloop: popping from cxstack" if $debug_cxstack; - pop(@cxstack); - return default_pp($op); -} - -sub pp_next { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"next" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "next %s"', $op->pv); - return $op->next; # ignore the op - } - } - default_pp($op); - my $nextop = $cxstack[$cxix]->{nextop}; - push(@bblock_todo, $nextop); - save_or_restore_lexical_state($$nextop); - runtime(sprintf("goto %s;", label($nextop))); - return $op->next; -} - -sub pp_redo { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"redo" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "redo %s"', $op->pv); - return $op->next; # ignore the op - } - } - default_pp($op); - my $redoop = $cxstack[$cxix]->{redoop}; - push(@bblock_todo, $redoop); - save_or_restore_lexical_state($$redoop); - runtime(sprintf("goto %s;", label($redoop))); - return $op->next; -} - -sub pp_last { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"last" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "last %s"', $op->pv); - return $op->next; # ignore the op - } - # XXX Add support for "last" to leave non-loop blocks - if ($cxstack[$cxix]->{type} != CXt_LOOP) { - error('Use of "last" for non-loop blocks is not yet implemented'); - return $op->next; # ignore the op - } - } - default_pp($op); - my $lastop = $cxstack[$cxix]->{lastop}->next; - push(@bblock_todo, $lastop); - save_or_restore_lexical_state($$lastop); - runtime(sprintf("goto %s;", label($lastop))); - return $op->next; -} - -sub pp_subst { - my $op = shift; - write_back_lexicals(); - write_back_stack(); - my $sym = doop($op); - my $replroot = $op->pmreplroot; - if ($$replroot) { - save_or_restore_lexical_state($$replroot); - runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;", - $sym, label($replroot)); - $op->pmreplstart->save; - push(@bblock_todo, $replroot); - } - invalidate_lexicals(); - return $op->next; -} - -sub pp_substcont { - my $op = shift; - write_back_lexicals(); - write_back_stack(); - doop($op); - my $pmop = $op->other; - # warn sprintf("substcont: op = %s, pmop = %s\n", - # peekop($op), peekop($pmop));#debug -# my $pmopsym = objsym($pmop); - my $pmopsym = $pmop->save; # XXX can this recurse? -# warn "pmopsym = $pmopsym\n";#debug - save_or_restore_lexical_state(${$pmop->pmreplstart}); - runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;", - $pmopsym, label($pmop->pmreplstart)); - invalidate_lexicals(); - return $pmop->next; -} - -sub default_pp { - my $op = shift; - my $ppname = "pp_" . $op->name; - if ($curcop and $need_curcop{$ppname}){ - $curcop->write_back; - } - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - doop($op); - # XXX If the only way that ops can write to a TEMPORARY lexical is - # when it's named in $op->targ then we could call - # invalidate_lexicals(TEMPORARY) and avoid having to write back all - # the temporaries. For now, we'll play it safe and write back the lot. - invalidate_lexicals() unless $skip_invalidate{$ppname}; - return $op->next; -} - -sub compile_op { - my $op = shift; - my $ppname = "pp_" . $op->name; - if (exists $ignore_op{$ppname}) { - return $op->next; - } - debug peek_stack() if $debug_stack; - if ($debug_op) { - debug sprintf("%s [%s]\n", - peekop($op), - $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ); - } - no strict 'refs'; - if (defined(&$ppname)) { - $know_op = 0; - return &$ppname($op); - } else { - return default_pp($op); - } -} - -sub compile_bblock { - my $op = shift; - #warn "compile_bblock: ", peekop($op), "\n"; # debug - save_or_restore_lexical_state($$op); - write_label($op); - $know_op = 0; - do { - $op = compile_op($op); - } while (defined($op) && $$op && !exists($leaders->{$$op})); - write_back_stack(); # boo hoo: big loss - reload_lexicals(); - return $op; -} - -sub cc { - my ($name, $root, $start, @padlist) = @_; - my $op; - if($done{$$start}){ - #warn "repeat=>".ref($start)."$name,\n";#debug - $decl->add(sprintf("#define $name %s",$done{$$start})); - return; - } - init_pp($name); - load_pad(@padlist); - %lexstate=(); - B::Pseudoreg->new_scope; - @cxstack = (); - if ($debug_timings) { - warn sprintf("Basic block analysis at %s\n", timing_info); - } - $leaders = find_leaders($root, $start); - my @leaders= keys %$leaders; - if ($#leaders > -1) { - @bblock_todo = ($start, values %$leaders) ; - } else{ - runtime("return PL_op?PL_op->op_next:0;"); - } - if ($debug_timings) { - warn sprintf("Compilation at %s\n", timing_info); - } - while (@bblock_todo) { - $op = shift @bblock_todo; - #warn sprintf("Considering basic block %s\n", peekop($op)); # debug - next if !defined($op) || !$$op || $done{$$op}; - #warn "...compiling it\n"; # debug - do { - $done{$$op} = $name; - $op = compile_bblock($op); - if ($need_freetmps && $freetmps_each_bblock) { - runtime("FREETMPS;"); - $need_freetmps = 0; - } - } while defined($op) && $$op && !$done{$$op}; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); - $need_freetmps = 0; - } - if (!$$op) { - runtime("PUTBACK;","return PL_op;"); - } elsif ($done{$$op}) { - save_or_restore_lexical_state($$op); - runtime(sprintf("goto %s;", label($op))); - } - } - if ($debug_timings) { - warn sprintf("Saving runtime at %s\n", timing_info); - } - declare_pad(@padlist) ; - save_runtime(); -} - -sub cc_recurse { - my $ccinfo; - my $start; - $start = cc_queue(@_) if @_; - while ($ccinfo = shift @cc_todo) { - cc(@$ccinfo); - } - return $start; -} - -sub cc_obj { - my ($name, $cvref) = @_; - my $cv = svref_2object($cvref); - my @padlist = $cv->PADLIST->ARRAY; - my $curpad_sym = $padlist[1]->save; - cc_recurse($name, $cv->ROOT, $cv->START, @padlist); -} - -sub cc_main { - my @comppadlist = comppadlist->ARRAY; - my $curpad_nam = $comppadlist[0]->save; - my $curpad_sym = $comppadlist[1]->save; - my $init_av = init_av->save; - my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); - # Do save_unused_subs before saving inc_hv - save_unused_subs(); - cc_recurse(); - - my $inc_hv = svref_2object(\%INC)->save; - my $inc_av = svref_2object(\@INC)->save; - my $amagic_generate= amagic_generation; - return if $errors; - if (!defined($module)) { - $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), - "PL_main_start = $start;", - "PL_curpad = AvARRAY($curpad_sym);", - "PL_initav = (AV *) $init_av;", - "GvHV(PL_incgv) = $inc_hv;", - "GvAV(PL_incgv) = $inc_av;", - "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", - "PL_amagic_generation= $amagic_generate;", - ); - - } - seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output - output_boilerplate(); - print "\n"; - output_all("perl_init"); - output_runtime(); - print "\n"; - output_main(); - if (defined($module)) { - my $cmodule = $module; - $cmodule =~ s/::/__/g; - print <<"EOT"; - -#include "XSUB.h" -XS(boot_$cmodule) -{ - dXSARGS; - perl_init(); - ENTER; - SAVETMPS; - SAVEVPTR(PL_curpad); - SAVEVPTR(PL_op); - PL_curpad = AvARRAY($curpad_sym); - PL_op = $start; - pp_main(aTHX); - FREETMPS; - LEAVE; - ST(0) = &PL_sv_yes; - XSRETURN(1); -} -EOT - } - if ($debug_timings) { - warn sprintf("Done at %s\n", timing_info); - } -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(STDOUT, ">$arg") or return "open '>$arg': $!\n"; - } elsif ($opt eq "n") { - $arg ||= shift @options; - $module_name = $arg; - } elsif ($opt eq "u") { - $arg ||= shift @options; - mark_unused($arg,undef); - } elsif ($opt eq "f") { - $arg ||= shift @options; - my $value = $arg !~ s/^no-//; - $arg =~ s/-/_/g; - my $ref = $optimise{$arg}; - if (defined($ref)) { - $$ref = $value; - } else { - warn qq(ignoring unknown optimisation option "$arg"\n); - } - } elsif ($opt eq "O") { - $arg = 1 if $arg eq ""; - my $ref; - foreach $ref (values %optimise) { - $$ref = 0; - } - if ($arg >= 2) { - $freetmps_each_loop = 1; - } - if ($arg >= 1) { - $freetmps_each_bblock = 1 unless $freetmps_each_loop; - } - } elsif ($opt eq "m") { - $arg ||= shift @options; - $module = $arg; - mark_unused($arg,undef); - } elsif ($opt eq "p") { - $arg ||= shift @options; - $patchlevel = $arg; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "O") { - $debug_op = 1; - } elsif ($arg eq "s") { - $debug_stack = 1; - } elsif ($arg eq "c") { - $debug_cxstack = 1; - } elsif ($arg eq "p") { - $debug_pad = 1; - } elsif ($arg eq "r") { - $debug_runtime = 1; - } elsif ($arg eq "S") { - $debug_shadow = 1; - } elsif ($arg eq "q") { - $debug_queue = 1; - } elsif ($arg eq "l") { - $debug_lineno = 1; - } elsif ($arg eq "t") { - $debug_timings = 1; - } - } - } - } - init_sections(); - $init = B::Section->get("init"); - $decl = B::Section->get("decl"); - - if (@options) { - return sub { - my ($objname, $ppname); - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - ($ppname = $objname) =~ s/^.*?:://; - eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)"; - die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@; - return if $errors; - } - output_boilerplate(); - print "\n"; - output_all($module_name || "init_module"); - output_runtime(); - } - } else { - return sub { cc_main() }; - } -} - -1; - -__END__ - -=head1 NAME - -B::CC - Perl compiler's optimized C translation backend - -=head1 SYNOPSIS - - perl -MO=CC[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This compiler backend takes Perl source and generates C source code -corresponding to the flow of your program. In other words, this -backend is somewhat a "real" compiler in the sense that many people -think about compilers. Note however that, currently, it is a very -poor compiler in that although it generates (mostly, or at least -sometimes) correct code, it performs relatively few optimisations. -This will change as the compiler develops. The result is that -running an executable compiled with this backend may start up more -quickly than running the original Perl program (a feature shared -by the B 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/installer/perllib/B/Concise.pm b/Master/tlpkg/installer/perllib/B/Concise.pm deleted file mode 100644 index c84578e44c4..00000000000 --- a/Master/tlpkg/installer/perllib/B/Concise.pm +++ /dev/null @@ -1,1628 +0,0 @@ -package B::Concise; -# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved. -# This program is free software; you can redistribute and/or modify it -# under the same terms as Perl itself. - -# Note: we need to keep track of how many use declarations/BEGIN -# blocks this module uses, so we can avoid printing them when user -# asks for the BEGIN blocks in her program. Update the comments and -# the count in concise_specials if you add or delete one. The -# -MO=Concise counts as use #1. - -use strict; # use #2 -use warnings; # uses #3 and #4, since warnings uses Carp - -use Exporter (); # use #5 - -our $VERSION = "0.66"; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw( set_style set_style_standard add_callback - concise_subref concise_cv concise_main - add_style walk_output compile reset_sequence ); -our %EXPORT_TAGS = - ( io => [qw( walk_output compile reset_sequence )], - style => [qw( add_style set_style_standard )], - cb => [qw( add_callback )], - mech => [qw( concise_subref concise_cv concise_main )], ); - -# use #6 -use B qw(class ppname main_start main_root main_cv cstring svref_2object - SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL - CVf_ANON); - -my %style = - ("terse" => - ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) " - . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n", - "(*( )*)goto #class (#addr)\n", - "#class pp_#name"], - "concise" => - ["#hyphseq2 (*( (x( ;)x))*)<#classsym> " - . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n" - , " (*( )*) goto #seq\n", - "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], - "linenoise" => - ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)", - "gt_#seq ", - "(?(#seq)?)#noise#arg(?([#targarg])?)"], - "debug" => - ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" - . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" . - ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n") - . "\top_flags\t#flagval\n\top_private\t#privval\n" - . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" - . "(?(\top_sv\t\t#svaddr\n)?)", - " GOTO #addr\n", - "#addr"], - "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT}, - $ENV{B_CONCISE_TREE_FORMAT}], - ); - -# Renderings, ie how Concise prints, is controlled by these vars -# primary: -our $stylename; # selects current style from %style -my $order = "basic"; # how optree is walked & printed: basic, exec, tree - -# rendering mechanics: -# these 'formats' are the line-rendering templates -# they're updated from %style when $stylename changes -my ($format, $gotofmt, $treefmt); - -# lesser players: -my $base = 36; # how 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/installer/perllib/B/Debug.pm b/Master/tlpkg/installer/perllib/B/Debug.pm deleted file mode 100644 index cb369682d66..00000000000 --- a/Master/tlpkg/installer/perllib/B/Debug.pm +++ /dev/null @@ -1,305 +0,0 @@ -package B::Debug; - -our $VERSION = '1.02_01'; - -use strict; -use B qw(peekop class walkoptree walkoptree_exec - main_start main_root cstring sv_undef); -use B::Asmdata qw(@specialsv_name); - -my %done_gv; - -sub B::OP::debug { - my ($op) = @_; - printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type; -%s (0x%lx) - op_next 0x%x - op_sibling 0x%x - op_ppaddr %s - op_targ %d - op_type %d -EOT - if ($] > 5.009) { - printf <<'EOT', $op->opt, $op->static; - op_opt %d - op_static %d -EOT - } else { - printf <<'EOT', $op->seq; - op_seq %d -EOT - } - printf <<'EOT', $op->flags, $op->private; - op_flags %d - op_private %d -EOT -} - -sub B::UNOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_first\t0x%x\n", ${$op->first}; -} - -sub B::BINOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_last\t\t0x%x\n", ${$op->last}; -} - -sub B::LOOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop}; - op_redoop 0x%x - op_nextop 0x%x - op_lastop 0x%x -EOT -} - -sub B::LOGOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_other\t0x%x\n", ${$op->other}; -} - -sub B::LISTOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf "\top_children\t%d\n", $op->children; -} - -sub B::PMOP::debug { - my ($op) = @_; - $op->B::LISTOP::debug(); - printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot}; - printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; - printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; - printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); - printf "\top_pmflags\t0x%x\n", $op->pmflags; - $op->pmreplroot->debug; -} - -sub B::COP::debug { - my ($op) = @_; - $op->B::OP::debug(); - my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; - printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io); - cop_label %s - cop_stashpv %s - cop_file %s - cop_seq %d - cop_arybase %d - cop_line %d - cop_warnings 0x%x - cop_io %s -EOT -} - -sub B::SVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_sv\t\t0x%x\n", ${$op->sv}; - $op->sv->debug; -} - -sub B::PVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_pv\t\t%s\n", cstring($op->pv); -} - -sub B::PADOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_padix\t\t%ld\n", $op->padix; -} - -sub B::NULL::debug { - my ($sv) = @_; - if ($$sv == ${sv_undef()}) { - print "&sv_undef\n"; - } else { - printf "NULL (0x%x)\n", $$sv; - } -} - -sub B::SV::debug { - my ($sv) = @_; - if (!$$sv) { - print class($sv), " = NULL\n"; - return; - } - printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; -%s (0x%x) - REFCNT %d - FLAGS 0x%x -EOT -} - -sub B::RV::debug { - my ($rv) = @_; - B::SV::debug($rv); - printf <<'EOT', ${$rv->RV}; - RV 0x%x -EOT - $rv->RV->debug; -} - -sub B::PV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - my $pv = $sv->PV(); - printf <<'EOT', cstring($pv), length($pv); - xpv_pv %s - xpv_cur %d -EOT -} - -sub B::IV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV; -} - -sub B::NV::debug { - my ($sv) = @_; - $sv->B::IV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV; -} - -sub B::PVIV::debug { - my ($sv) = @_; - $sv->B::PV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV; -} - -sub B::PVNV::debug { - my ($sv) = @_; - $sv->B::PVIV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV; -} - -sub B::PVLV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txlv_targoff\t%d\n", $sv->TARGOFF; - printf "\txlv_targlen\t%u\n", $sv->TARGLEN; - printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); -} - -sub B::BM::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txbm_useful\t%d\n", $sv->USEFUL; - printf "\txbm_previous\t%u\n", $sv->PREVIOUS; - printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); -} - -sub B::CV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - my ($stash) = $sv->STASH; - my ($start) = $sv->START; - my ($root) = $sv->ROOT; - my ($padlist) = $sv->PADLIST; - my ($file) = $sv->FILE; - my ($gv) = $sv->GV; - printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ; - STASH 0x%x - START 0x%x - ROOT 0x%x - GV 0x%x - FILE %s - DEPTH %d - PADLIST 0x%x - OUTSIDE 0x%x - OUTSIDE_SEQ %d -EOT - $start->debug if $start; - $root->debug if $root; - $gv->debug if $gv; - $padlist->debug if $padlist; -} - -sub B::AV::debug { - my ($av) = @_; - $av->B::SV::debug; - my(@array) = $av->ARRAY; - print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; - printf <<'EOT', scalar(@array), $av->MAX, $av->OFF; - FILL %d - MAX %d - OFF %d -EOT - printf <<'EOT', $av->AvFLAGS if $] < 5.009; - AvFLAGS %d -EOT -} - -sub B::GV::debug { - my ($gv) = @_; - if ($done_gv{$$gv}++) { - printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; - return; - } - my ($sv) = $gv->SV; - my ($av) = $gv->AV; - my ($cv) = $gv->CV; - $gv->B::SV::debug; - printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; - NAME %s - STASH %s (0x%x) - SV 0x%x - GvREFCNT %d - FORM 0x%x - AV 0x%x - HV 0x%x - EGV 0x%x - CV 0x%x - CVGEN %d - LINE %d - FILE %s - GvFLAGS 0x%x -EOT - $sv->debug if $sv; - $av->debug if $av; - $cv->debug if $cv; -} - -sub B::SPECIAL::debug { - my $sv = shift; - print $specialsv_name[$$sv], "\n"; -} - -sub compile { - my $order = shift; - B::clearsym(); - if ($order && $order eq "exec") { - return sub { walkoptree_exec(main_start, "debug") } - } else { - return sub { walkoptree(main_root, "debug") } - } -} - -1; - -__END__ - -=head1 NAME - -B::Debug - Walk Perl syntax tree, printing debug info about ops - -=head1 SYNOPSIS - - perl -MO=Debug[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -See F. - -=head1 AUTHOR - -Malcolm Beattie, C - -=cut diff --git a/Master/tlpkg/installer/perllib/B/Deparse.pm b/Master/tlpkg/installer/perllib/B/Deparse.pm deleted file mode 100644 index 3db6fbe6e1f..00000000000 --- a/Master/tlpkg/installer/perllib/B/Deparse.pm +++ /dev/null @@ -1,4642 +0,0 @@ -# B::Deparse.pm -# Copyright (c) 1998-2000, 2002, 2003 Stephen McCamant. All rights reserved. -# This module is free software; you can redistribute and/or modify -# it under the same terms as Perl itself. - -# This is based on the module of the same name by Malcolm Beattie, -# but essentially none of his code remains. - -package B::Deparse; -use Carp; -use B qw(class main_root main_start main_cv svref_2object opnumber perlstring - OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST - OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD - OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE - OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY - OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER - OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED - SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG - CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION - PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE - PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.71; -use strict; -use vars qw/$AUTOLOAD/; -use warnings (); - -# Changes between 0.50 and 0.51: -# - fixed nulled leave with live enter in sort { } -# - fixed reference constants (\"str") -# - handle empty programs gracefully -# - handle infinte loops (for (;;) {}, while (1) {}) -# - differentiate between `for my $x ...' and `my $x; for $x ...' -# - various minor cleanups -# - moved globals into an object -# - added `-u', like B::C -# - package declarations using cop_stash -# - subs, formats and code sorted by cop_seq -# Changes between 0.51 and 0.52: -# - added pp_threadsv (special variables under USE_5005THREADS) -# - added documentation -# Changes between 0.52 and 0.53: -# - many changes adding precedence contexts and associativity -# - added `-p' and `-s' output style options -# - various other minor fixes -# Changes between 0.53 and 0.54: -# - added support for new `for (1..100)' optimization, -# thanks to Gisle Aas -# Changes between 0.54 and 0.55: -# - added support for new qr// construct -# - added support for new pp_regcreset OP -# Changes between 0.55 and 0.56: -# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t -# - fixed $# on non-lexicals broken in last big rewrite -# - added temporary fix for change in opcode of OP_STRINGIFY -# - fixed problem in 0.54's for() patch in `for (@ary)' -# - fixed precedence in conditional of ?: -# - tweaked list paren elimination in `my($x) = @_' -# - made continue-block detection trickier wrt. null ops -# - fixed various prototype problems in pp_entersub -# - added support for sub prototypes that never get GVs -# - added unquoting for special filehandle first arg in truncate -# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV' -# - added semicolons at the ends of blocks -# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28 -# Changes between 0.56 and 0.561: -# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy) -# - used new B.pm symbolic constants (done by Nick Ing-Simmons) -# Changes between 0.561 and 0.57: -# - stylistic changes to symbolic constant stuff -# - handled scope in s///e replacement code -# - added unquote option for expanding "" into concats, etc. -# - split method and proto parts of pp_entersub into separate functions -# - various minor cleanups -# Changes after 0.57: -# - added parens in \&foo (patch by Albert Dvornik) -# Changes between 0.57 and 0.58: -# - fixed `0' statements that weren't being printed -# - added methods for use from other programs -# (based on patches from James Duncan and Hugo van der Sanden) -# - added -si and -sT to control indenting (also based on a patch from Hugo) -# - added -sv to print something else instead of '???' -# - preliminary version of utf8 tr/// handling -# Changes after 0.58: -# - uses of $op->ppaddr changed to new $op->name (done by Sarathy) -# - added support for Hugo's new OP_SETSTATE (like nextstate) -# Changes between 0.58 and 0.59 -# - added support for Chip's OP_METHOD_NAMED -# - added support for Ilya's OPpTARGET_MY optimization -# - elided arrows before `()' subscripts when possible -# Changes between 0.59 and 0.60 -# - support for method attribues was added -# - some warnings fixed -# - separate recognition of constant subs -# - rewrote continue block handling, now recoginizing for loops -# - added more control of expanding control structures -# Changes between 0.60 and 0.61 (mostly by Robin Houston) -# - many bug-fixes -# - support for pragmas and 'use' -# - support for the little-used $[ variable -# - support for __DATA__ sections -# - UTF8 support -# - BEGIN, CHECK, INIT and END blocks -# - scoping of subroutine declarations fixed -# - compile-time output from the input program can be suppressed, so that the -# output is just the deparsed code. (a change to O.pm in fact) -# - our() declarations -# - *all* the known bugs are now listed in the BUGS section -# - comprehensive test mechanism (TEST -deparse) -# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez) -# - bug-fixes -# - new switch -P -# - support for command-line switches (-l, -0, etc.) -# Changes between 0.63 and 0.64 -# - support for //, CHECK blocks, and assertions -# - improved handling of foreach loops and lexicals -# - option to use Data::Dumper for constants -# - more bug fixes -# - discovered lots more bugs not yet fixed - -# Todo: -# (See also BUGS section at the end of this file) -# -# - finish tr/// changes -# - add option for even more parens (generalize \&foo change) -# - left/right context -# - copy comments (look at real text with $^P?) -# - avoid semis in one-statement blocks -# - associativity of &&=, ||=, ?: -# - ',' => '=>' (auto-unquote?) -# - break long lines ("\r" as discretionary break?) -# - configurable syntax highlighting: ANSI color, HTML, TeX, etc. -# - more style options: brace style, hex vs. octal, quotes, ... -# - print big ints as hex/octal instead of decimal (heuristic?) -# - handle `my $x if 0'? -# - version using op_next instead of op_first/sibling? -# - avoid string copies (pass arrays, one big join?) -# - here-docs? - -# Current test.deparse failures -# comp/assertions 38 - disabled assertions should be like "my($x) if 0" -# 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}' -# comp/hints 6 - location of BEGIN blocks wrt. block openings -# run/switchI 1 - missing -I switches entirely -# perl -Ifoo -e 'print @INC' -# op/caller 2 - warning mask propagates backwards before warnings::register -# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register' -# op/getpid 2 - can't assign to shared my() declaration (threads only) -# 'my $x : shared = 5' -# op/override 7 - parens on overriden require change v-string interpretation -# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6' -# c.f. 'BEGIN { *f = sub {0} }; f 2' -# op/pat 774 - losing Unicode-ness of Latin1-only strings -# 'use charnames ":short"; $x="\N{latin:a with acute}"' -# op/recurse 12 - missing parens on recursive call makes it look like method -# 'sub f { f($x) }' -# op/subst 90 - inconsistent handling of utf8 under "use utf8" -# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open -# op/tiehandle compile - "use strict" deparsed in the wrong place -# uni/tr_ several -# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs -# ext/Data/Dumper/t/dumper compile -# ext/DB_file/several -# ext/Encode/several -# ext/Ernno/Errno warnings -# ext/IO/lib/IO/t/io_sel 23 -# ext/PerlIO/t/encoding compile -# ext/POSIX/t/posix 6 -# ext/Socket/Socket 8 -# ext/Storable/t/croak compile -# lib/Attribute/Handlers/t/multi compile -# lib/bignum/ several -# lib/charnames 35 -# lib/constant 32 -# lib/English 40 -# lib/ExtUtils/t/bytes 4 -# lib/File/DosGlob compile -# lib/Filter/Simple/t/data 1 -# lib/Math/BigInt/t/constant 1 -# lib/Net/t/config Deparse-warning -# lib/overload compile -# lib/Switch/ several -# lib/Symbol 4 -# lib/Test/Simple several -# lib/Term/Complete -# lib/Tie/File/t/29_downcopy 5 -# lib/vars 22 - -# Object fields (were globals): -# -# avoid_local: -# (local($a), local($b)) and local($a, $b) have the same internal -# representation but the short form looks better. We notice we can -# use a large-scale local when checking the list, but need to prevent -# individual locals too. This hash holds the addresses of OPs that -# have already had their local-ness accounted for. The same thing -# is done with my(). -# -# curcv: -# CV for current sub (or main program) being deparsed -# -# curcvlex: -# Cached hash of lexical variables for curcv: keys are names, -# each value is an array of pairs, indicating the cop_seq of scopes -# in which a var of that name is valid. -# -# curcop: -# COP for statement being deparsed -# -# curstash: -# name of the current package for deparsed code -# -# subs_todo: -# array of [cop_seq, CV, is_format?] for subs and formats we still -# want to deparse -# -# protos_todo: -# as above, but [name, prototype] for subs that never got a GV -# -# subs_done, forms_done: -# keys are addresses of GVs for subs and formats we've already -# deparsed (or at least put into subs_todo) -# -# subs_declared -# keys are names of subs for which we've printed declarations. -# That means we can omit parentheses from the arguments. -# -# subs_deparsed -# Keeps track of fully qualified names of all deparsed subs. -# -# parens: -p -# linenums: -l -# unquote: -q -# cuddle: ` ' or `\n', depending on -sC -# indent_size: -si -# use_tabs: -sT -# ex_const: -sv - -# A little explanation of how precedence contexts and associativity -# work: -# -# deparse() calls each per-op subroutine with an argument $cx (short -# for context, but not the same as the cx* in the perl core), which is -# a number describing the op's parents in terms of precedence, whether -# they're inside an expression or at statement level, etc. (see -# chart below). When ops with children call deparse on them, they pass -# along their precedence. Fractional values are used to implement -# associativity (`($x + $y) + $z' => `$x + $y + $y') and related -# parentheses hacks. The major disadvantage of this scheme is that -# it doesn't know about right sides and left sides, so say if you -# assign a listop to a variable, it can't tell it's allowed to leave -# the parens off the listop. - -# Precedences: -# 26 [TODO] inside interpolation context ("") -# 25 left terms and list operators (leftward) -# 24 left -> -# 23 nonassoc ++ -- -# 22 right ** -# 21 right ! ~ \ and unary + and - -# 20 left =~ !~ -# 19 left * / % x -# 18 left + - . -# 17 left << >> -# 16 nonassoc named unary operators -# 15 nonassoc < > <= >= lt gt le ge -# 14 nonassoc == != <=> eq ne cmp -# 13 left & -# 12 left | ^ -# 11 left && -# 10 left || -# 9 nonassoc .. ... -# 8 right ?: -# 7 right = += -= *= etc. -# 6 left , => -# 5 nonassoc list operators (rightward) -# 4 right not -# 3 left and -# 2 left or xor -# 1 statement modifiers -# 0.5 statements, but still print scopes as do { ... } -# 0 statement level - -# Nonprinting characters with special meaning: -# \cS - steal parens (see maybe_parens_unop) -# \n - newline and indent -# \t - increase indent -# \b - decrease indent (`outdent') -# \f - flush left (no indent) -# \cK - kill following semicolon, if any - -sub null { - my $op = shift; - return class($op) eq "NULL"; -} - -sub todo { - my $self = shift; - my($cv, $is_form) = @_; - return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE}); - my $seq; - if ($cv->OUTSIDE_SEQ) { - $seq = $cv->OUTSIDE_SEQ; - } elsif (!null($cv->START) and is_state($cv->START)) { - $seq = $cv->START->cop_seq; - } else { - $seq = 0; - } - push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form]; - unless ($is_form || class($cv->STASH) eq 'SPECIAL') { - $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1; - } -} - -sub next_todo { - my $self = shift; - my $ent = shift @{$self->{'subs_todo'}}; - my $cv = $ent->[1]; - my $gv = $cv->GV; - my $name = $self->gv_name($gv); - if ($ent->[2]) { - return "format $name =\n" - . $self->deparse_format($ent->[1]). "\n"; - } else { - $self->{'subs_declared'}{$name} = 1; - if ($name eq "BEGIN") { - my $use_dec = $self->begin_is_use($cv); - if (defined ($use_dec) and $self->{'expand'} < 5) { - return () if 0 == length($use_dec); - return $use_dec; - } - } - my $l = ''; - if ($self->{'linenums'}) { - my $line = $gv->LINE; - my $file = $gv->FILE; - $l = "\n\f#line $line \"$file\"\n"; - } - my $p = ''; - if (class($cv->STASH) ne "SPECIAL") { - my $stash = $cv->STASH->NAME; - if ($stash ne $self->{'curstash'}) { - $p = "package $stash;\n"; - $name = "$self->{'curstash'}::$name" unless $name =~ /::/; - $self->{'curstash'} = $stash; - } - $name =~ s/^\Q$stash\E:://; - } - return "${p}${l}sub $name " . $self->deparse_sub($cv); - } -} - -# Return a "use" declaration for this BEGIN block, if appropriate -sub begin_is_use { - my ($self, $cv) = @_; - my $root = $cv->ROOT; - local @$self{qw'curcv curcvlex'} = ($cv); -#require B::Debug; -#B::walkoptree($cv->ROOT, "debug"); - my $lineseq = $root->first; - return if $lineseq->name ne "lineseq"; - - my $req_op = $lineseq->first->sibling; - return if $req_op->name ne "require"; - - my $module; - if ($req_op->first->private & OPpCONST_BARE) { - # Actually it should always be a bareword - $module = $self->const_sv($req_op->first)->PV; - $module =~ s[/][::]g; - $module =~ s/.pm$//; - } - else { - $module = $self->const($self->const_sv($req_op->first), 6); - } - - my $version; - my $version_op = $req_op->sibling; - return if class($version_op) eq "NULL"; - if ($version_op->name eq "lineseq") { - # We have a version parameter; skip nextstate & pushmark - my $constop = $version_op->first->next->next; - - return unless $self->const_sv($constop)->PV eq $module; - $constop = $constop->sibling; - $version = $self->const_sv($constop); - if (class($version) eq "IV") { - $version = $version->int_value; - } elsif (class($version) eq "NV") { - $version = $version->NV; - } elsif (class($version) ne "PVMG") { - # Includes PVIV and PVNV - $version = $version->PV; - } else { - # version specified as a v-string - $version = 'v'.join '.', map ord, split //, $version->PV; - } - $constop = $constop->sibling; - return if $constop->name ne "method_named"; - return if $self->const_sv($constop)->PV ne "VERSION"; - } - - $lineseq = $version_op->sibling; - return if $lineseq->name ne "lineseq"; - my $entersub = $lineseq->first->sibling; - if ($entersub->name eq "stub") { - return "use $module $version ();\n" if defined $version; - return "use $module ();\n"; - } - return if $entersub->name ne "entersub"; - - # See if there are import arguments - my $args = ''; - - my $svop = $entersub->first->sibling; # Skip over pushmark - return unless $self->const_sv($svop)->PV eq $module; - - # Pull out the arguments - for ($svop=$svop->sibling; $svop->name ne "method_named"; - $svop = $svop->sibling) { - $args .= ", " if length($args); - $args .= $self->deparse($svop, 6); - } - - my $use = 'use'; - my $method_named = $svop; - return if $method_named->name ne "method_named"; - my $method_name = $self->const_sv($method_named)->PV; - - if ($method_name eq "unimport") { - $use = 'no'; - } - - # Certain pragmas are dealt with using hint bits, - # so we ignore them here - if ($module eq 'strict' || $module eq 'integer' - || $module eq 'bytes' || $module eq 'warnings') { - return ""; - } - - if (defined $version && length $args) { - return "$use $module $version ($args);\n"; - } elsif (defined $version) { - return "$use $module $version;\n"; - } elsif (length $args) { - return "$use $module ($args);\n"; - } else { - return "$use $module;\n"; - } -} - -sub stash_subs { - my ($self, $pack) = @_; - my (@ret, $stash); - if (!defined $pack) { - $pack = ''; - $stash = \%::; - } - else { - $pack =~ s/(::)?$/::/; - no strict 'refs'; - $stash = \%$pack; - } - my %stash = svref_2object($stash)->ARRAY; - while (my ($key, $val) = each %stash) { - next if $key eq 'main::'; # avoid infinite recursion - my $class = class($val); - if ($class eq "PV") { - # Just a prototype. As an ugly but fairly effective way - # to find out if it belongs here is to see if the AUTOLOAD - # (if any) for the stash was defined in one of our files. - my $A = $stash{"AUTOLOAD"}; - if (defined ($A) && class($A) eq "GV" && defined($A->CV) - && class($A->CV) eq "CV") { - my $AF = $A->FILE; - next unless $AF eq $0 || exists $self->{'files'}{$AF}; - } - push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV]; - } elsif ($class eq "IV") { - # Just a name. As above. - my $A = $stash{"AUTOLOAD"}; - if (defined ($A) && class($A) eq "GV" && defined($A->CV) - && class($A->CV) eq "CV") { - my $AF = $A->FILE; - next unless $AF eq $0 || exists $self->{'files'}{$AF}; - } - push @{$self->{'protos_todo'}}, [$pack . $key, undef]; - } elsif ($class eq "GV") { - if (class(my $cv = $val->CV) ne "SPECIAL") { - next if $self->{'subs_done'}{$$val}++; - next if $$val != ${$cv->GV}; # Ignore imposters - $self->todo($cv, 0); - } - if (class(my $cv = $val->FORM) ne "SPECIAL") { - next if $self->{'forms_done'}{$$val}++; - next if $$val != ${$cv->GV}; # Ignore imposters - $self->todo($cv, 1); - } - if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) { - $self->stash_subs($pack . $key); - } - } - } -} - -sub print_protos { - my $self = shift; - my $ar; - my @ret; - foreach $ar (@{$self->{'protos_todo'}}) { - my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : ""); - push @ret, "sub " . $ar->[0] . "$proto;\n"; - } - delete $self->{'protos_todo'}; - return @ret; -} - -sub style_opts { - my $self = shift; - my $opts = shift; - my $opt; - while (length($opt = substr($opts, 0, 1))) { - if ($opt eq "C") { - $self->{'cuddle'} = " "; - $opts = substr($opts, 1); - } elsif ($opt eq "i") { - $opts =~ s/^i(\d+)//; - $self->{'indent_size'} = $1; - } elsif ($opt eq "T") { - $self->{'use_tabs'} = 1; - $opts = substr($opts, 1); - } elsif ($opt eq "v") { - $opts =~ s/^v([^.]*)(.|$)//; - $self->{'ex_const'} = $1; - } - } -} - -sub new { - my $class = shift; - my $self = bless {}, $class; - $self->{'cuddle'} = "\n"; - $self->{'curcop'} = undef; - $self->{'curstash'} = "main"; - $self->{'ex_const'} = "'???'"; - $self->{'expand'} = 0; - $self->{'files'} = {}; - $self->{'indent_size'} = 4; - $self->{'linenums'} = 0; - $self->{'parens'} = 0; - $self->{'subs_todo'} = []; - $self->{'unquote'} = 0; - $self->{'use_dumper'} = 0; - $self->{'use_tabs'} = 0; - - $self->{'ambient_arybase'} = 0; - $self->{'ambient_warnings'} = undef; # Assume no lexical warnings - $self->{'ambient_hints'} = 0; - $self->init(); - - while (my $arg = shift @_) { - if ($arg eq "-d") { - $self->{'use_dumper'} = 1; - require Data::Dumper; - } elsif ($arg =~ /^-f(.*)/) { - $self->{'files'}{$1} = 1; - } elsif ($arg eq "-l") { - $self->{'linenums'} = 1; - } elsif ($arg eq "-p") { - $self->{'parens'} = 1; - } elsif ($arg eq "-P") { - $self->{'noproto'} = 1; - } elsif ($arg eq "-q") { - $self->{'unquote'} = 1; - } elsif (substr($arg, 0, 2) eq "-s") { - $self->style_opts(substr $arg, 2); - } elsif ($arg =~ /^-x(\d)$/) { - $self->{'expand'} = $1; - } - } - return $self; -} - -{ - # Mask out the bits that L 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/installer/perllib/B/Disassembler.pm b/Master/tlpkg/installer/perllib/B/Disassembler.pm deleted file mode 100644 index e1993aa9537..00000000000 --- a/Master/tlpkg/installer/perllib/B/Disassembler.pm +++ /dev/null @@ -1,233 +0,0 @@ -# Disassembler.pm -# -# Copyright (c) 1996 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. - -$B::Disassembler::VERSION = '1.05'; - -package B::Disassembler::BytecodeStream; - -use FileHandle; -use Carp; -use Config qw(%Config); -use B qw(cstring cast_I32); -@ISA = qw(FileHandle); -sub readn { - my ($fh, $len) = @_; - my $data; - read($fh, $data, $len); - croak "reached EOF while reading $len bytes" unless length($data) == $len; - return $data; -} - -sub GET_U8 { - my $fh = shift; - my $c = $fh->getc; - croak "reached EOF while reading U8" unless defined($c); - return ord($c); -} - -sub GET_U16 { - my $fh = shift; - my $str = $fh->readn(2); - croak "reached EOF while reading U16" unless length($str) == 2; - return unpack("S", $str); -} - -sub GET_NV { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading double" unless defined($c); - return $str; -} - -sub GET_U32 { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading U32" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_I32 { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading I32" unless length($str) == 4; - return unpack("l", $str); -} - -sub GET_objindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading objindex" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_opindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading opindex" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_svindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading svindex" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_pvindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading pvindex" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_strconst { - my $fh = shift; - my ($str, $c); - $str = ''; - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading strconst" unless defined($c); - return cstring($str); -} - -sub GET_pvcontents {} - -sub GET_PV { - my $fh = shift; - my $str; - my $len = $fh->GET_U32; - if ($len) { - read($fh, $str, $len); - croak "reached EOF while reading PV" unless length($str) == $len; - return cstring($str); - } else { - return '""'; - } -} - -sub GET_comment_t { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\n") { - $str .= $c; - } - croak "reached EOF while reading comment" unless defined($c); - return cstring($str); -} - -sub GET_double { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading double" unless defined($c); - return $str; -} - -sub GET_none {} - -sub GET_op_tr_array { - my $fh = shift; - my $len = unpack "S", $fh->readn(2); - my @ary = unpack "S*", $fh->readn($len*2); - return join(",", $len, @ary); -} - -sub GET_IV64 { - my $fh = shift; - my $str = $fh->readn(8); - croak "reached EOF while reading I32" unless length($str) == 8; - return sprintf "0x%09llx", unpack("q", $str); -} - -sub GET_IV { - $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64; -} - -sub GET_PADOFFSET { - $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32; -} - -sub GET_long { - $Config{longsize} == 8 ? &GET_IV64 : &GET_U32; -} - - -package B::Disassembler; -use Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(disassemble_fh get_header); -use Carp; -use strict; - -use B::Asmdata qw(%insn_data @insn_name); - -our( $magic, $archname, $blversion, $ivsize, $ptrsize ); - -sub dis_header($){ - my( $fh ) = @_; - $magic = $fh->GET_U32(); - warn( "bad magic" ) if $magic != 0x43424c50; - $archname = $fh->GET_strconst(); - $blversion = $fh->GET_strconst(); - $ivsize = $fh->GET_U32(); - $ptrsize = $fh->GET_U32(); -} - -sub get_header(){ - return( $magic, $archname, $blversion, $ivsize, $ptrsize); -} - -sub disassemble_fh { - my ($fh, $out) = @_; - my ($c, $getmeth, $insn, $arg); - bless $fh, "B::Disassembler::BytecodeStream"; - dis_header( $fh ); - while (defined($c = $fh->getc)) { - $c = ord($c); - $insn = $insn_name[$c]; - if (!defined($insn) || $insn eq "unused") { - my $pos = $fh->tell - 1; - die "Illegal instruction code $c at stream offset $pos\n"; - } - $getmeth = $insn_data{$insn}->[2]; - $arg = $fh->$getmeth(); - if (defined($arg)) { - &$out($insn, $arg); - } else { - &$out($insn); - } - } -} - -1; - -__END__ - -=head1 NAME - -B::Disassembler - Disassemble Perl bytecode - -=head1 SYNOPSIS - - use Disassembler; - -=head1 DESCRIPTION - -See F. - -=head1 AUTHOR - -Malcolm Beattie, C - -=cut diff --git a/Master/tlpkg/installer/perllib/B/Lint.pm b/Master/tlpkg/installer/perllib/B/Lint.pm deleted file mode 100644 index 3475bd2596e..00000000000 --- a/Master/tlpkg/installer/perllib/B/Lint.pm +++ /dev/null @@ -1,392 +0,0 @@ -package B::Lint; - -our $VERSION = '1.03'; - -=head1 NAME - -B::Lint - Perl lint - -=head1 SYNOPSIS - -perl -MO=Lint[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -The B::Lint module is equivalent to an extended version of the B<-w> -option of B. 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/installer/perllib/B/Showlex.pm b/Master/tlpkg/installer/perllib/B/Showlex.pm deleted file mode 100644 index 3b261a337df..00000000000 --- a/Master/tlpkg/installer/perllib/B/Showlex.pm +++ /dev/null @@ -1,205 +0,0 @@ -package B::Showlex; - -our $VERSION = '1.02'; - -use strict; -use B qw(svref_2object comppadlist class); -use B::Terse (); -use B::Concise (); - -# -# Invoke as -# perl -MO=Showlex,foo bar.pl -# to see the names of lexical variables used by &foo -# or as -# perl -MO=Showlex bar.pl -# to see the names of file scope lexicals used by bar.pl -# - - -# borrowed from B::Concise -our $walkHandle = \*STDOUT; - -sub walk_output { # updates $walkHandle - $walkHandle = B::Concise::walk_output(@_); - #print "got $walkHandle"; - #print $walkHandle "using it"; - $walkHandle; -} - -sub shownamearray { - my ($name, $av) = @_; - my @els = $av->ARRAY; - my $count = @els; - my $i; - print $walkHandle "$name has $count entries\n"; - for ($i = 0; $i < $count; $i++) { - my $sv = $els[$i]; - if (class($sv) ne "SPECIAL") { - printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; - } else { - printf $walkHandle "$i: %s\n", $sv->terse; - #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); - } - } -} - -sub showvaluearray { - my ($name, $av) = @_; - my @els = $av->ARRAY; - my $count = @els; - my $i; - print $walkHandle "$name has $count entries\n"; - for ($i = 0; $i < $count; $i++) { - printf $walkHandle "$i: %s\n", $els[$i]->terse; - #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]); - } -} - -sub showlex { - my ($objname, $namesav, $valsav) = @_; - shownamearray("Pad of lexical names for $objname", $namesav); - showvaluearray("Pad of lexical values for $objname", $valsav); -} - -my ($newlex, $nosp1); # rendering state vars - -sub newlex { # drop-in for showlex - my ($objname, $names, $vals) = @_; - my @names = $names->ARRAY; - my @vals = $vals->ARRAY; - my $count = @names; - print $walkHandle "$objname Pad has $count entries\n"; - printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1; - for (my $i = 1; $i < $count; $i++) { - printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse - unless $nosp1 and $names[$i]->terse =~ /SPECIAL/; - } -} - -sub showlex_obj { - my ($objname, $obj) = @_; - $objname =~ s/^&main::/&/; - showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex; - newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex; -} - -sub showlex_main { - showlex("comppadlist", comppadlist->ARRAY) if !$newlex; - newlex ("main", comppadlist->ARRAY) if $newlex; -} - -sub compile { - my @options = grep(/^-/, @_); - my @args = grep(!/^-/, @_); - for my $o (@options) { - $newlex = 1 if $o eq "-newlex"; - $nosp1 = 1 if $o eq "-nosp"; - } - - return \&showlex_main unless @args; - return sub { - my $objref; - foreach my $objname (@args) { - next unless $objname; # skip nulls w/o carping - - if (ref $objname) { - print $walkHandle "B::Showlex::compile($objname)\n"; - $objref = $objname; - } else { - $objname = "main::$objname" unless $objname =~ /::/; - print $walkHandle "$objname:\n"; - no strict 'refs'; - die "err: unknown function ($objname)\n" - unless *{$objname}{CODE}; - $objref = \&$objname; - } - showlex_obj($objname, $objref); - } - } -} - -1; - -__END__ - -=head1 NAME - -B::Showlex - Show lexical variables used in functions or files - -=head1 SYNOPSIS - - perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl - -=head1 DESCRIPTION - -When a comma-separated list of subroutine names is given as options, Showlex -prints the lexical variables used in those subroutines. Otherwise, it prints -the file-scope lexicals in the file. - -=head1 EXAMPLES - -Traditional form: - - $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")' - Pad of lexical names for comppadlist has 4 entries - 0: SPECIAL #1 &PL_sv_undef - 1: PVNV (0x9db0fb0) $i - 2: PVNV (0x9db0f38) $j - 3: PVNV (0x9db0f50) $k - Pad of lexical values for comppadlist has 5 entries - 0: SPECIAL #1 &PL_sv_undef - 1: NULL (0x9da4234) - 2: NULL (0x9db0f2c) - 3: NULL (0x9db0f44) - 4: NULL (0x9da4264) - -e syntax OK - -New-style form: - - $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")' - main Pad has 4 entries - 0: SPECIAL #1 &PL_sv_undef - 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234) - 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34) - 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c) - -e syntax OK - -New form, no specials, outside O framework: - - $ perl -MB::Showlex -e \ - 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()' - main Pad has 4 entries - 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1 - 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo" - 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74) - -Note that this example shows the values of the lexicals, whereas the other -examples did not (as they're compile-time only). - -=head2 OPTIONS - -The C<-newlex> option produces a more readable C<< name => value >> format, -and is shown in the second example above. - -The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL -#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm -your declared lexicals. - -=head1 SEE ALSO - -C 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/installer/perllib/B/Stackobj.pm b/Master/tlpkg/installer/perllib/B/Stackobj.pm deleted file mode 100644 index b17dfb8173a..00000000000 --- a/Master/tlpkg/installer/perllib/B/Stackobj.pm +++ /dev/null @@ -1,349 +0,0 @@ -# Stackobj.pm -# -# Copyright (c) 1996 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::Stackobj; - -our $VERSION = '1.00'; - -use Exporter (); -@ISA = qw(Exporter); -@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED - VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY); -%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)], - flags => [qw(VALID_INT VALID_DOUBLE VALID_SV - VALID_UNSIGNED REGISTER TEMPORARY)]); - -use Carp qw(confess); -use strict; -use B qw(class SVf_IOK SVf_NOK SVf_IVisUV); - -# Types -sub T_UNKNOWN () { 0 } -sub T_DOUBLE () { 1 } -sub T_INT () { 2 } -sub T_SPECIAL () { 3 } - -# Flags -sub VALID_INT () { 0x01 } -sub VALID_UNSIGNED () { 0x02 } -sub VALID_DOUBLE () { 0x04 } -sub VALID_SV () { 0x08 } -sub REGISTER () { 0x10 } # no implicit write-back when calling subs -sub TEMPORARY () { 0x20 } # no implicit write-back needed at all -sub SAVE_INT () { 0x40 } #if int part needs to be saved at all -sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all - - -# -# Callback for runtime code generation -# -my $runtime_callback = sub { confess "set_callback not yet called" }; -sub set_callback (&) { $runtime_callback = shift } -sub runtime { &$runtime_callback(@_) } - -# -# Methods -# - -sub write_back { confess "stack object does not implement write_back" } - -sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) } - -sub as_sv { - my $obj = shift; - if (!($obj->{flags} & VALID_SV)) { - $obj->write_back; - $obj->{flags} |= VALID_SV; - } - return $obj->{sv}; -} - -sub as_int { - my $obj = shift; - if (!($obj->{flags} & VALID_INT)) { - $obj->load_int; - $obj->{flags} |= VALID_INT|SAVE_INT; - } - return $obj->{iv}; -} - -sub as_double { - my $obj = shift; - if (!($obj->{flags} & VALID_DOUBLE)) { - $obj->load_double; - $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; - } - return $obj->{nv}; -} - -sub as_numeric { - my $obj = shift; - return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double; -} - -sub as_bool { - my $obj=shift; - if ($obj->{flags} & VALID_INT ){ - return $obj->{iv}; - } - if ($obj->{flags} & VALID_DOUBLE ){ - return $obj->{nv}; - } - return sprintf("(SvTRUE(%s))", $obj->as_sv) ; -} - -# -# Debugging methods -# -sub peek { - my $obj = shift; - my $type = $obj->{type}; - my $flags = $obj->{flags}; - my @flags; - if ($type == T_UNKNOWN) { - $type = "T_UNKNOWN"; - } elsif ($type == T_INT) { - $type = "T_INT"; - } elsif ($type == T_DOUBLE) { - $type = "T_DOUBLE"; - } else { - $type = "(illegal type $type)"; - } - push(@flags, "VALID_INT") if $flags & VALID_INT; - push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE; - push(@flags, "VALID_SV") if $flags & VALID_SV; - push(@flags, "REGISTER") if $flags & REGISTER; - push(@flags, "TEMPORARY") if $flags & TEMPORARY; - @flags = ("none") unless @flags; - return sprintf("%s type=$type flags=%s sv=$obj->{sv}", - class($obj), join("|", @flags)); -} - -sub minipeek { - my $obj = shift; - my $type = $obj->{type}; - my $flags = $obj->{flags}; - if ($type == T_INT || $flags & VALID_INT) { - return $obj->{iv}; - } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) { - return $obj->{nv}; - } else { - return $obj->{sv}; - } -} - -# -# Caller needs to ensure that set_int, set_double, -# set_numeric and set_sv are only invoked on legal lvalues. -# -sub set_int { - my ($obj, $expr,$unsigned) = @_; - runtime("$obj->{iv} = $expr;"); - $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE); - $obj->{flags} |= VALID_INT|SAVE_INT; - $obj->{flags} |= VALID_UNSIGNED if $unsigned; -} - -sub set_double { - my ($obj, $expr) = @_; - runtime("$obj->{nv} = $expr;"); - $obj->{flags} &= ~(VALID_SV | VALID_INT); - $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; -} - -sub set_numeric { - my ($obj, $expr) = @_; - if ($obj->{type} == T_INT) { - $obj->set_int($expr); - } else { - $obj->set_double($expr); - } -} - -sub set_sv { - my ($obj, $expr) = @_; - runtime("SvSetSV($obj->{sv}, $expr);"); - $obj->invalidate; - $obj->{flags} |= VALID_SV; -} - -# -# Stackobj::Padsv -# - -@B::Stackobj::Padsv::ISA = 'B::Stackobj'; -sub B::Stackobj::Padsv::new { - my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_; - $extra_flags |= SAVE_INT if $extra_flags & VALID_INT; - $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE; - bless { - type => $type, - flags => VALID_SV | $extra_flags, - sv => "PL_curpad[$ix]", - iv => "$iname", - nv => "$dname" - }, $class; -} - -sub B::Stackobj::Padsv::load_int { - my $obj = shift; - if ($obj->{flags} & VALID_DOUBLE) { - runtime("$obj->{iv} = $obj->{nv};"); - } else { - runtime("$obj->{iv} = SvIV($obj->{sv});"); - } - $obj->{flags} |= VALID_INT|SAVE_INT; -} - -sub B::Stackobj::Padsv::load_double { - my $obj = shift; - $obj->write_back; - runtime("$obj->{nv} = SvNV($obj->{sv});"); - $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; -} -sub B::Stackobj::Padsv::save_int { - my $obj = shift; - return $obj->{flags} & SAVE_INT; -} - -sub B::Stackobj::Padsv::save_double { - my $obj = shift; - return $obj->{flags} & SAVE_DOUBLE; -} - -sub B::Stackobj::Padsv::write_back { - my $obj = shift; - my $flags = $obj->{flags}; - return if $flags & VALID_SV; - if ($flags & VALID_INT) { - if ($flags & VALID_UNSIGNED ){ - runtime("sv_setuv($obj->{sv}, $obj->{iv});"); - }else{ - runtime("sv_setiv($obj->{sv}, $obj->{iv});"); - } - } elsif ($flags & VALID_DOUBLE) { - runtime("sv_setnv($obj->{sv}, $obj->{nv});"); - } else { - confess "write_back failed for lexical @{[$obj->peek]}\n"; - } - $obj->{flags} |= VALID_SV; -} - -# -# Stackobj::Const -# - -@B::Stackobj::Const::ISA = 'B::Stackobj'; -sub B::Stackobj::Const::new { - my ($class, $sv) = @_; - my $obj = bless { - flags => 0, - sv => $sv # holds the SV object until write_back happens - }, $class; - if ( ref($sv) eq "B::SPECIAL" ){ - $obj->{type}= T_SPECIAL; - }else{ - my $svflags = $sv->FLAGS; - if ($svflags & SVf_IOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_INT; - if ($svflags & SVf_IVisUV){ - $obj->{flags} |= VALID_UNSIGNED; - $obj->{nv} = $obj->{iv} = $sv->UVX; - }else{ - $obj->{nv} = $obj->{iv} = $sv->IV; - } - } elsif ($svflags & SVf_NOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_DOUBLE; - $obj->{iv} = $obj->{nv} = $sv->NV; - } else { - $obj->{type} = T_UNKNOWN; - } - } - return $obj; -} - -sub B::Stackobj::Const::write_back { - my $obj = shift; - return if $obj->{flags} & VALID_SV; - # Save the SV object and replace $obj->{sv} by its C source code name - $obj->{sv} = $obj->{sv}->save; - $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE; -} - -sub B::Stackobj::Const::load_int { - my $obj = shift; - if (ref($obj->{sv}) eq "B::RV"){ - $obj->{iv} = int($obj->{sv}->RV->PV); - }else{ - $obj->{iv} = int($obj->{sv}->PV); - } - $obj->{flags} |= VALID_INT; -} - -sub B::Stackobj::Const::load_double { - my $obj = shift; - if (ref($obj->{sv}) eq "B::RV"){ - $obj->{nv} = $obj->{sv}->RV->PV + 0.0; - }else{ - $obj->{nv} = $obj->{sv}->PV + 0.0; - } - $obj->{flags} |= VALID_DOUBLE; -} - -sub B::Stackobj::Const::invalidate {} - -# -# Stackobj::Bool -# - -@B::Stackobj::Bool::ISA = 'B::Stackobj'; -sub B::Stackobj::Bool::new { - my ($class, $preg) = @_; - my $obj = bless { - type => T_INT, - flags => VALID_INT|VALID_DOUBLE, - iv => $$preg, - nv => $$preg, - preg => $preg # this holds our ref to the pseudo-reg - }, $class; - return $obj; -} - -sub B::Stackobj::Bool::write_back { - my $obj = shift; - return if $obj->{flags} & VALID_SV; - $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)"; - $obj->{flags} |= VALID_SV; -} - -# XXX Might want to handle as_double/set_double/load_double? - -sub B::Stackobj::Bool::invalidate {} - -1; - -__END__ - -=head1 NAME - -B::Stackobj - Helper module for CC backend - -=head1 SYNOPSIS - - use B::Stackobj; - -=head1 DESCRIPTION - -See F. - -=head1 AUTHOR - -Malcolm Beattie, C - -=cut diff --git a/Master/tlpkg/installer/perllib/B/Stash.pm b/Master/tlpkg/installer/perllib/B/Stash.pm deleted file mode 100644 index 5e60868a28e..00000000000 --- a/Master/tlpkg/installer/perllib/B/Stash.pm +++ /dev/null @@ -1,52 +0,0 @@ -# Stash.pm -- show what stashes are loaded -# vishalb@hotmail.com -package B::Stash; - -our $VERSION = '1.00'; - -=pod - -=head1 NAME - -B::Stash - show what stashes are loaded - -=cut - -BEGIN { %Seen = %INC } - -CHECK { - my @arr=scan($main::{"main::"}); - @arr=map{s/\:\:$//;$_ eq ""?():$_;} @arr; - print "-umain,-u", join (",-u",@arr) ,"\n"; -} -sub scan{ - my $start=shift; - my $prefix=shift; - $prefix = '' unless defined $prefix; - my @return; - foreach my $key ( keys %{$start}){ -# print $prefix,$key,"\n"; - if ($key =~ /::$/){ - unless ($start eq ${$start}{$key} or $key eq "B::" ){ - push @return, $key unless omit($prefix.$key); - foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){ - push @return, "$key".$subscan; - } - } - } - } - return @return; -} -sub omit{ - my $module = shift; - my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 , - "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 ); - return 1 if $omit{$module}; - if ($module eq "IO::" or $module eq "IO::Handle::"){ - $module =~ s/::/\//g; - return 1 unless $INC{$module}; - } - - return 0; -} -1; diff --git a/Master/tlpkg/installer/perllib/B/Terse.pm b/Master/tlpkg/installer/perllib/B/Terse.pm deleted file mode 100644 index 1d53950ad3b..00000000000 --- a/Master/tlpkg/installer/perllib/B/Terse.pm +++ /dev/null @@ -1,103 +0,0 @@ -package B::Terse; - -our $VERSION = '1.03_01'; - -use strict; -use B qw(class); -use B::Asmdata qw(@specialsv_name); -use B::Concise qw(concise_subref set_style_standard); -use Carp; - -sub terse { - my ($order, $subref) = @_; - set_style_standard("terse"); - if ($order eq "exec") { - concise_subref('exec', $subref); - } else { - concise_subref('basic', $subref); - } -} - -sub compile { - my @args = @_; - my $order = @args ? shift(@args) : ""; - $order = "-exec" if $order eq "exec"; - unshift @args, $order if $order ne ""; - B::Concise::compile("-terse", @args); -} - -sub indent { - my ($level) = @_ ? shift : 0; - return " " x $level; -} - -# Don't use this, at least on OPs in subroutines: it has no way of -# getting to the pad, and will give wrong answers or crash. -sub B::OP::terse { - carp "B::OP::terse is deprecated; use B::Concise instead"; - B::Concise::b_terse(@_); -} - -sub B::SV::terse { - my($sv, $level) = (@_, 0); - my %info; - B::Concise::concise_sv($sv, \%info); - my $s = indent($level) - . B::Concise::fmt_line(\%info, $sv, - "#svclass~(?((#svaddr))?)~#svval", 0); - chomp $s; - print "$s\n" unless defined wantarray; - $s; -} - -sub B::NULL::terse { - my ($sv, $level) = (@_, 0); - my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv; - print "$s\n" unless defined wantarray; - $s; -} - -sub B::SPECIAL::terse { - my ($sv, $level) = (@_, 0); - my $s = indent($level) - . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]); - print "$s\n" unless defined wantarray; - $s; -} - -1; - -__END__ - -=head1 NAME - -B::Terse - Walk Perl syntax tree, printing terse info about ops - -=head1 SYNOPSIS - - perl -MO=Terse[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This version of B::Terse is really just a wrapper that calls B::Concise -with the B<-terse> option. It is provided for compatibility with old scripts -(and habits) but using B::Concise directly is now recommended instead. - -For compatibility with the old B::Terse, this module also adds a -method named C 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/installer/perllib/B/Xref.pm b/Master/tlpkg/installer/perllib/B/Xref.pm deleted file mode 100644 index f727dc766b5..00000000000 --- a/Master/tlpkg/installer/perllib/B/Xref.pm +++ /dev/null @@ -1,430 +0,0 @@ -package B::Xref; - -our $VERSION = '1.01'; - -=head1 NAME - -B::Xref - Generates cross reference reports for Perl programs - -=head1 SYNOPSIS - -perl -MO=Xref[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -The B::Xref module is used to generate a cross reference listing of all -definitions and uses of variables, subroutines and formats in a Perl program. -It is implemented as a backend for the Perl compiler. - -The report generated is in the following format: - - File filename1 - Subroutine subname1 - Package package1 - object1 line numbers - object2 line numbers - ... - Package package2 - ... - -Each B 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/installer/perllib/B/assemble b/Master/tlpkg/installer/perllib/B/assemble deleted file mode 100644 index 43cc5bc4b33..00000000000 --- a/Master/tlpkg/installer/perllib/B/assemble +++ /dev/null @@ -1,30 +0,0 @@ -use B::Assembler qw(assemble_fh); -use FileHandle; - -my ($filename, $fh, $out); - -if ($ARGV[0] eq "-d") { - B::Assembler::debug(1); - shift; -} - -$out = \*STDOUT; - -if (@ARGV == 0) { - $fh = \*STDIN; - $filename = "-"; -} elsif (@ARGV == 1) { - $filename = $ARGV[0]; - $fh = new FileHandle "<$filename"; -} elsif (@ARGV == 2) { - $filename = $ARGV[0]; - $fh = new FileHandle "<$filename"; - $out = new FileHandle ">$ARGV[1]"; -} else { - die "Usage: assemble [filename] [outfilename]\n"; -} - -binmode $out; -$SIG{__WARN__} = sub { warn "$filename:@_" }; -$SIG{__DIE__} = sub { die "$filename: @_" }; -assemble_fh($fh, sub { print $out @_ }); diff --git a/Master/tlpkg/installer/perllib/B/cc_harness b/Master/tlpkg/installer/perllib/B/cc_harness deleted file mode 100644 index 79f8727a8f0..00000000000 --- a/Master/tlpkg/installer/perllib/B/cc_harness +++ /dev/null @@ -1,12 +0,0 @@ -use Config; - -$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE"; - -if (!grep(/^-[cS]$/, @ARGV)) { - $linkargs = sprintf("%s $libdir/$Config{libperl} %s", - @Config{qw(ldflags libs)}); -} - -$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs"; -print "$cccmd\n"; -exec $cccmd; diff --git a/Master/tlpkg/installer/perllib/B/disassemble b/Master/tlpkg/installer/perllib/B/disassemble deleted file mode 100644 index 6530b809502..00000000000 --- a/Master/tlpkg/installer/perllib/B/disassemble +++ /dev/null @@ -1,22 +0,0 @@ -use B::Disassembler qw(disassemble_fh); -use FileHandle; - -my $fh; -if (@ARGV == 0) { - $fh = \*STDIN; -} elsif (@ARGV == 1) { - $fh = new FileHandle "<$ARGV[0]"; -} else { - die "Usage: disassemble [filename]\n"; -} - -sub print_insn { - my ($insn, $arg) = @_; - if (defined($arg)) { - printf "%s %s\n", $insn, $arg; - } else { - print $insn, "\n"; - } -} - -disassemble_fh($fh, \&print_insn); diff --git a/Master/tlpkg/installer/perllib/B/makeliblinks b/Master/tlpkg/installer/perllib/B/makeliblinks deleted file mode 100644 index 82560783c01..00000000000 --- a/Master/tlpkg/installer/perllib/B/makeliblinks +++ /dev/null @@ -1,54 +0,0 @@ -use File::Find; -use Config; - -if (@ARGV != 2) { - warn <<"EOT"; -Usage: makeliblinks libautodir targetdir -where libautodir is the architecture-dependent auto directory -(e.g. $Config::Config{archlib}/auto). -EOT - exit 2; -} - -my ($libautodir, $targetdir) = @ARGV; - -# Calculate relative path prefix from $targetdir to $libautodir -sub relprefix { - my ($to, $from) = @_; - my $up; - for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) { - $from =~ s( - [^/]+ (?# a group of non-slashes) - /* (?# maybe with some trailing slashes) - $ (?# at the end of the path) - )()x; - } - return (("../" x $up) . substr($to, length($from))); -} - -my $relprefix = relprefix($libautodir, $targetdir); - -my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)}; - -sub link_if_library { - if (/\.($dlext|$lib_ext)$/o) { - my $ext = $1; - my $name = $File::Find::name; - if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") { - die "directory of $name doesn't match $libautodir\n"; - } - substr($name, 0, length($libautodir) + 1) = ''; - my @parts = split(m(/), $name); - if ($parts[-1] ne "$parts[-2].$ext") { - die "module name $_ doesn't match its directory $libautodir\n"; - } - pop @parts; - my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext"; - print "$libpath -> $relprefix/$name\n"; - symlink("$relprefix/$name", $libpath) - or warn "above link failed with error: $!\n"; - } -} - -find(\&link_if_library, $libautodir); -exit 0; diff --git a/Master/tlpkg/installer/perllib/Carp.pm b/Master/tlpkg/installer/perllib/Carp.pm deleted file mode 100644 index 1a814ead34f..00000000000 --- a/Master/tlpkg/installer/perllib/Carp.pm +++ /dev/null @@ -1,274 +0,0 @@ -package Carp; - -our $VERSION = '1.04'; - -=head1 NAME - -carp - warn of errors (from perspective of caller) - -cluck - warn of errors with stack backtrace - (not exported by default) - -croak - die of errors (from perspective of caller) - -confess - die of errors with stack backtrace - -shortmess - return the message that carp and croak produce - -longmess - return the message that cluck and confess produce - -=head1 SYNOPSIS - - use Carp; - croak "We're outta here!"; - - use Carp qw(cluck); - cluck "This is how we got here!"; - - print FH Carp::shortmess("This will have caller's details added"); - print FH Carp::longmess("This will have stack backtrace added"); - -=head1 DESCRIPTION - -The Carp routines are useful in your own modules because -they act like die() or warn(), but with a message which is more -likely to be useful to a user of your module. In the case of -cluck, confess, and longmess that context is a summary of every -call in the call-stack. For a shorter message you can use carp, -croak or shortmess which report the error as being from where -your module was called. There is no guarantee that that is where -the error was, but it is a good educated guess. - -You can also alter the way the output and logic of C 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/installer/perllib/Carp/Heavy.pm b/Master/tlpkg/installer/perllib/Carp/Heavy.pm deleted file mode 100644 index 55bca2b421a..00000000000 --- a/Master/tlpkg/installer/perllib/Carp/Heavy.pm +++ /dev/null @@ -1,241 +0,0 @@ -# Carp::Heavy uses some variables in common with Carp. -package Carp; - -=head1 NAME - -Carp::Heavy - heavy machinery, no user serviceable parts inside - -=cut - -# use strict; # not yet - -# On one line so MakeMaker will see it. -use Carp; our $VERSION = $Carp::VERSION; - -our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose); - -sub caller_info { - my $i = shift(@_) + 1; - package DB; - my %call_info; - @call_info{ - qw(pack file line sub has_args wantarray evaltext is_require) - } = caller($i); - - unless (defined $call_info{pack}) { - return (); - } - - my $sub_name = Carp::get_subname(\%call_info); - if ($call_info{has_args}) { - my @args = map {Carp::format_arg($_)} @DB::args; - if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? - $#args = $MaxArgNums; - push @args, '...'; - } - # Push the args onto the subroutine - $sub_name .= '(' . join (', ', @args) . ')'; - } - $call_info{sub_name} = $sub_name; - return wantarray() ? %call_info : \%call_info; -} - -# Transform an argument to a function into a string. -sub format_arg { - my $arg = shift; - if (ref($arg)) { - $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; - }elsif (not defined($arg)) { - $arg = 'undef'; - } - $arg =~ s/'/\\'/g; - $arg = str_len_trim($arg, $MaxArgLen); - - # Quote it? - $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; - - # The following handling of "control chars" is direct from - # the original code - it is broken on Unicode though. - # Suggestions? - utf8::is_utf8($arg) - or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; - return $arg; -} - -# Takes an inheritance cache and a package and returns -# an anon hash of known inheritances and anon array of -# inheritances which consequences have not been figured -# for. -sub get_status { - my $cache = shift; - my $pkg = shift; - $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; - return @{$cache->{$pkg}}; -} - -# Takes the info from caller() and figures out the name of -# the sub/require/eval -sub get_subname { - my $info = shift; - if (defined($info->{evaltext})) { - my $eval = $info->{evaltext}; - if ($info->{is_require}) { - return "require $eval"; - } - else { - $eval =~ s/([\\\'])/\\$1/g; - return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'"; - } - } - - return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; -} - -# Figures out what call (from the point of view of the caller) -# the long error backtrace should start at. -sub long_error_loc { - my $i; - my $lvl = $CarpLevel; - { - my $pkg = caller(++$i); - unless(defined($pkg)) { - # This *shouldn't* happen. - if (%Internal) { - local %Internal; - $i = long_error_loc(); - last; - } - else { - # OK, now I am irritated. - return 2; - } - } - redo if $CarpInternal{$pkg}; - redo unless 0 > --$lvl; - redo if $Internal{$pkg}; - } - return $i - 1; -} - - -sub longmess_heavy { - return @_ if ref($_[0]); # don't break references as exceptions - my $i = long_error_loc(); - return ret_backtrace($i, @_); -} - -# Returns a full stack backtrace starting from where it is -# told. -sub ret_backtrace { - my ($i, @error) = @_; - my $mess; - my $err = join '', @error; - $i++; - - my $tid_msg = ''; - if (defined &Thread::tid) { - my $tid = Thread->self->tid; - $tid_msg = " thread $tid" if $tid; - } - - my %i = caller_info($i); - $mess = "$err at $i{file} line $i{line}$tid_msg\n"; - - while (my %i = caller_info(++$i)) { - $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; - } - - return $mess; -} - -sub ret_summary { - my ($i, @error) = @_; - my $err = join '', @error; - $i++; - - my $tid_msg = ''; - if (defined &Thread::tid) { - my $tid = Thread->self->tid; - $tid_msg = " thread $tid" if $tid; - } - - my %i = caller_info($i); - return "$err at $i{file} line $i{line}$tid_msg\n"; -} - - -sub short_error_loc { - my $cache; - my $i = 1; - my $lvl = $CarpLevel; - { - my $called = caller($i++); - my $caller = caller($i); - return 0 unless defined($caller); # What happened? - redo if $Internal{$caller}; - redo if $CarpInternal{$called}; - redo if trusts($called, $caller, $cache); - redo if trusts($caller, $called, $cache); - redo unless 0 > --$lvl; - } - return $i - 1; -} - -sub shortmess_heavy { - return longmess_heavy(@_) if $Verbose; - return @_ if ref($_[0]); # don't break references as exceptions - my $i = short_error_loc(); - if ($i) { - ret_summary($i, @_); - } - else { - longmess_heavy(@_); - } -} - -# If a string is too long, trims it with ... -sub str_len_trim { - my $str = shift; - my $max = shift || 0; - if (2 < $max and $max < length($str)) { - substr($str, $max - 3) = '...'; - } - return $str; -} - -# Takes two packages and an optional cache. Says whether the -# first inherits from the second. -# -# Recursive versions of this have to work to avoid certain -# possible endless loops, and when following long chains of -# inheritance are less efficient. -sub trusts { - my $child = shift; - my $parent = shift; - my $cache = shift || {}; - my ($known, $partial) = get_status($cache, $child); - # Figure out consequences until we have an answer - while (@$partial and not exists $known->{$parent}) { - my $anc = shift @$partial; - next if exists $known->{$anc}; - $known->{$anc}++; - my ($anc_knows, $anc_partial) = get_status($cache, $anc); - my @found = keys %$anc_knows; - @$known{@found} = (); - push @$partial, @$anc_partial; - } - return exists $known->{$parent}; -} - -# Takes a package and gives a list of those trusted directly -sub trusts_directly { - my $class = shift; - no strict 'refs'; - no warnings 'once'; - return @{"$class\::CARP_NOT"} - ? @{"$class\::CARP_NOT"} - : @{"$class\::ISA"}; -} - -1; - diff --git a/Master/tlpkg/installer/perllib/Class/ISA.pm b/Master/tlpkg/installer/perllib/Class/ISA.pm deleted file mode 100644 index e1371912e2c..00000000000 --- a/Master/tlpkg/installer/perllib/Class/ISA.pm +++ /dev/null @@ -1,214 +0,0 @@ -#!/usr/local/bin/perl -# Time-stamp: "2004-12-29 20:01:02 AST" -*-Perl-*- - -package Class::ISA; -require 5; -use strict; -use vars qw($Debug $VERSION); -$VERSION = '0.33'; -$Debug = 0 unless defined $Debug; - -=head1 NAME - -Class::ISA -- report the search path for a class's ISA tree - -=head1 SYNOPSIS - - # Suppose you go: use Food::Fishstick, and that uses and - # inherits from other things, which in turn use and inherit - # from other things. And suppose, for sake of brevity of - # example, that their ISA tree is the same as: - - @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals); - @Food::Fish::ISA = qw(Food); - @Food::ISA = qw(Matter); - @Life::Fungus::ISA = qw(Life); - @Chemicals::ISA = qw(Matter); - @Life::ISA = qw(Matter); - @Matter::ISA = qw(); - - use Class::ISA; - print "Food::Fishstick path is:\n ", - join(", ", Class::ISA::super_path('Food::Fishstick')), - "\n"; - -That prints: - - Food::Fishstick path is: - Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals - -=head1 DESCRIPTION - -Suppose you have a class (like Food::Fish::Fishstick) that is derived, -via its @ISA, from one or more superclasses (as Food::Fish::Fishstick -is from Food::Fish, Life::Fungus, and Chemicals), and some of those -superclasses may themselves each be derived, via its @ISA, from one or -more superclasses (as above). - -When, then, you call a method in that class ($fishstick->calories), -Perl first searches there for that method, but if it's not there, it -goes searching in its superclasses, and so on, in a depth-first (or -maybe "height-first" is the word) search. In the above example, it'd -first look in Food::Fish, then Food, then Matter, then Life::Fungus, -then Life, then Chemicals. - -This library, Class::ISA, provides functions that return that list -- -the list (in order) of names of classes Perl would search to find a -method, with no duplicates. - -=head1 FUNCTIONS - -=over - -=item the function Class::ISA::super_path($CLASS) - -This returns the ordered list of names of classes that Perl would -search thru in order to find a method, with no duplicates in the list. -$CLASS is not included in the list. UNIVERSAL is not included -- if -you need to consider it, add it to the end. - - -=item the function Class::ISA::self_and_super_path($CLASS) - -Just like C, 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/installer/perllib/Class/Struct.pm b/Master/tlpkg/installer/perllib/Class/Struct.pm deleted file mode 100644 index 7a9af54faf8..00000000000 --- a/Master/tlpkg/installer/perllib/Class/Struct.pm +++ /dev/null @@ -1,636 +0,0 @@ -package Class::Struct; - -## See POD after __END__ - -use 5.006_001; - -use strict; -use warnings::register; -our(@ISA, @EXPORT, $VERSION); - -use Carp; - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(struct); - -$VERSION = '0.63'; - -## Tested on 5.002 and 5.003 without class membership tests: -my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95); - -my $print = 0; -sub printem { - if (@_) { $print = shift } - else { $print++ } -} - -{ - package Class::Struct::Tie_ISA; - - sub TIEARRAY { - my $class = shift; - return bless [], $class; - } - - sub STORE { - my ($self, $index, $value) = @_; - Class::Struct::_subclass_error(); - } - - sub FETCH { - my ($self, $index) = @_; - $self->[$index]; - } - - sub FETCHSIZE { - my $self = shift; - return scalar(@$self); - } - - sub DESTROY { } -} - -sub import { - my $self = shift; - - if ( @_ == 0 ) { - $self->export_to_level( 1, $self, @EXPORT ); - } elsif ( @_ == 1 ) { - # This is admittedly a little bit silly: - # do we ever export anything else than 'struct'...? - $self->export_to_level( 1, $self, @_ ); - } else { - goto &struct; - } -} - -sub struct { - - # Determine parameter list structure, one of: - # struct( class => [ element-list ]) - # struct( class => { element-list }) - # struct( element-list ) - # Latter form assumes current package name as struct name. - - my ($class, @decls); - my $base_type = ref $_[1]; - if ( $base_type eq 'HASH' ) { - $class = shift; - @decls = %{shift()}; - _usage_error() if @_; - } - elsif ( $base_type eq 'ARRAY' ) { - $class = shift; - @decls = @{shift()}; - _usage_error() if @_; - } - else { - $base_type = 'ARRAY'; - $class = (caller())[0]; - @decls = @_; - } - - _usage_error() if @decls % 2 == 1; - - # Ensure we are not, and will not be, a subclass. - - my $isa = do { - no strict 'refs'; - \@{$class . '::ISA'}; - }; - _subclass_error() if @$isa; - tie @$isa, 'Class::Struct::Tie_ISA'; - - # Create constructor. - - croak "function 'new' already defined in package $class" - if do { no strict 'refs'; defined &{$class . "::new"} }; - - my @methods = (); - my %refs = (); - my %arrays = (); - my %hashes = (); - my %classes = (); - my $got_class = 0; - my $out = ''; - - $out = "{\n package $class;\n use Carp;\n sub new {\n"; - $out .= " my (\$class, \%init) = \@_;\n"; - $out .= " \$class = __PACKAGE__ unless \@_;\n"; - - my $cnt = 0; - my $idx = 0; - my( $cmt, $name, $type, $elem ); - - if( $base_type eq 'HASH' ){ - $out .= " my(\$r) = {};\n"; - $cmt = ''; - } - elsif( $base_type eq 'ARRAY' ){ - $out .= " my(\$r) = [];\n"; - } - while( $idx < @decls ){ - $name = $decls[$idx]; - $type = $decls[$idx+1]; - push( @methods, $name ); - if( $base_type eq 'HASH' ){ - $elem = "{'${class}::$name'}"; - } - elsif( $base_type eq 'ARRAY' ){ - $elem = "[$cnt]"; - ++$cnt; - $cmt = " # $name"; - } - if( $type =~ /^\*(.)/ ){ - $refs{$name}++; - $type = $1; - } - my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :"; - if( $type eq '@' ){ - $out .= " croak 'Initializer for $name must be array reference'\n"; - $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n"; - $out .= " \$r->$elem = $init [];$cmt\n"; - $arrays{$name}++; - } - elsif( $type eq '%' ){ - $out .= " croak 'Initializer for $name must be hash reference'\n"; - $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n"; - $out .= " \$r->$elem = $init {};$cmt\n"; - $hashes{$name}++; - } - elsif ( $type eq '$') { - $out .= " \$r->$elem = $init undef;$cmt\n"; - } - elsif( $type =~ /^\w+(?:::\w+)*$/ ){ - $out .= " if (defined(\$init{'$name'})) {\n"; - $out .= " if (ref \$init{'$name'} eq 'HASH')\n"; - $out .= " { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n"; - $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n"; - $out .= " { \$r->$elem = \$init{'$name'} } $cmt\n"; - $out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n"; - $out .= " }\n"; - $classes{$name} = $type; - $got_class = 1; - } - else{ - croak "'$type' is not a valid struct element type"; - } - $idx += 2; - } - $out .= " bless \$r, \$class;\n }\n"; - - # Create accessor methods. - - my( $pre, $pst, $sel ); - $cnt = 0; - foreach $name (@methods){ - if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { - warnings::warnif("function '$name' already defined, overrides struct accessor method"); - } - else { - $pre = $pst = $cmt = $sel = ''; - if( defined $refs{$name} ){ - $pre = "\\("; - $pst = ")"; - $cmt = " # returns ref"; - } - $out .= " sub $name {$cmt\n my \$r = shift;\n"; - if( $base_type eq 'ARRAY' ){ - $elem = "[$cnt]"; - ++$cnt; - } - elsif( $base_type eq 'HASH' ){ - $elem = "{'${class}::$name'}"; - } - if( defined $arrays{$name} ){ - $out .= " my \$i;\n"; - $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; - $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n"; - $sel = "->[\$i]"; - } - elsif( defined $hashes{$name} ){ - $out .= " my \$i;\n"; - $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; - $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n"; - $sel = "->{\$i}"; - } - elsif( defined $classes{$name} ){ - if ( $CHECK_CLASS_MEMBERSHIP ) { - $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; - } - } - $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; - $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n"; - $out .= " }\n"; - } - } - $out .= "}\n1;\n"; - - print $out if $print; - my $result = eval $out; - carp $@ if $@; -} - -sub _usage_error { - confess "struct usage error"; -} - -sub _subclass_error { - croak 'struct class cannot be a subclass (@ISA not allowed)'; -} - -1; # for require - - -__END__ - -=head1 NAME - -Class::Struct - declare struct-like datatypes as Perl classes - -=head1 SYNOPSIS - - use Class::Struct; - # declare struct, based on array: - struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]); - # declare struct, based on hash: - struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }); - - package CLASS_NAME; - use Class::Struct; - # declare struct, based on array, implicit class name: - struct( ELEMENT_NAME => ELEMENT_TYPE, ... ); - - # Declare struct at compile time - use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]; - use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }; - - # declare struct at compile time, based on array, implicit class name: - package CLASS_NAME; - use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ; - - package Myobj; - use Class::Struct; - # declare struct with four types of elements: - struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' ); - - $obj = new Myobj; # constructor - - # scalar type accessor: - $element_value = $obj->s; # element value - $obj->s('new value'); # assign to element - - # array type accessor: - $ary_ref = $obj->a; # reference to whole array - $ary_element_value = $obj->a(2); # array element value - $obj->a(2, 'new value'); # assign to array element - - # hash type accessor: - $hash_ref = $obj->h; # reference to whole hash - $hash_element_value = $obj->h('x'); # hash element value - $obj->h('x', 'new value'); # assign to hash element - - # class type accessor: - $element_value = $obj->c; # object reference - $obj->c->method(...); # call method of object - $obj->c(new My_Other_Class); # assign a new object - -=head1 DESCRIPTION - -C 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/installer/perllib/Config.pm b/Master/tlpkg/installer/perllib/Config.pm deleted file mode 100644 index 7e5ad77b30a..00000000000 --- a/Master/tlpkg/installer/perllib/Config.pm +++ /dev/null @@ -1,95 +0,0 @@ -# This file was created by configpm when Perl was built. Any changes -# made to this file will be lost the next time perl is built. - -package Config; -use strict; -# use warnings; Pulls in Carp -# use vars pulls in Carp -@Config::EXPORT = qw(%Config); -@Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re); - -# Need to stub all the functions to make code such as print Config::config_sh -# keep working - -sub myconfig; -sub config_sh; -sub config_vars; -sub config_re; - -my %Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK); - -our %Config; - -# Define our own import method to avoid pulling in the full Exporter: -sub import { - my $pkg = shift; - @_ = @Config::EXPORT unless @_; - - my @funcs = grep $_ ne '%Config', @_; - my $export_Config = @funcs < @_ ? 1 : 0; - - no strict 'refs'; - my $callpkg = caller(0); - foreach my $func (@funcs) { - die sprintf qq{"%s" is not exported by the %s module\n}, - $func, __PACKAGE__ unless $Export_Cache{$func}; - *{$callpkg.'::'.$func} = \&{$func}; - } - - *{"$callpkg\::Config"} = \%Config if $export_Config; - return; -} - -die "Perl lib version (v5.8.8) doesn't match executable version ($])" - unless $^V; - -$^V eq v5.8.8 - or die "Perl lib version (v5.8.8) doesn't match executable version (" . - sprintf("v%vd",$^V) . ")"; - - -sub FETCH { - my($self, $key) = @_; - - # check for cached value (which may be undef so we use exists not defined) - return $self->{$key} if exists $self->{$key}; - - return $self->fetch_string($key); -} -sub TIEHASH { - bless $_[1], $_[0]; -} - -sub DESTROY { } - -sub AUTOLOAD { - require 'Config_heavy.pl'; - goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/; - die "&Config::AUTOLOAD failed on $Config::AUTOLOAD"; -} - -# tie returns the object, so the value returned to require will be true. -tie %Config, 'Config', { - archlibexp => 'x:\\perl\\lib', - archname => 'MSWin32-x86-multi-thread', - cc => 'gcc', - d_readlink => undef, - d_symlink => undef, - dlsrc => 'dl_win32.xs', - dont_use_nlink => undef, - exe_ext => '.exe', - inc_version_list => '', - intsize => '4', - ldlibpthname => '', - libpth => 'x:\\msys\\mingw\\lib', - osname => 'MSWin32', - osvers => '5.1', - path_sep => ';', - privlibexp => 'x:\\perl\\lib', - scriptdir => 'x:\\perl\\bin', - sitearchexp => 'x:\\perl\\site\\lib', - sitelibexp => 'x:\\perl\\site\\lib', - useithreads => 'define', - usevendorprefix => undef, - version => '5.8.8', -}; diff --git a/Master/tlpkg/installer/perllib/Config_heavy.pl b/Master/tlpkg/installer/perllib/Config_heavy.pl deleted file mode 100644 index 919d4637cf2..00000000000 --- a/Master/tlpkg/installer/perllib/Config_heavy.pl +++ /dev/null @@ -1,1185 +0,0 @@ -# This file was created by configpm when Perl was built. Any changes -# made to this file will be lost the next time perl is built. - -package Config; -use strict; -# use warnings; Pulls in Carp -# use vars pulls in Carp -### Configured by: siepo@xpeco -### Target system: WIN32 - -our $summary = <<'!END!'; -Summary of my $package (revision $revision $version_patchlevel_string) configuration: - Platform: - osname=$osname, osvers=$osvers, archname=$archname - uname='$myuname' - config_args='$config_args' - hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction - usethreads=$usethreads use5005threads=$use5005threads useithreads=$useithreads usemultiplicity=$usemultiplicity - useperlio=$useperlio d_sfio=$d_sfio uselargefiles=$uselargefiles usesocks=$usesocks - use64bitint=$use64bitint use64bitall=$use64bitall uselongdouble=$uselongdouble - usemymalloc=$usemymalloc, bincompat5005=undef - Compiler: - cc='$cc', ccflags ='$ccflags', - optimize='$optimize', - cppflags='$cppflags' - ccversion='$ccversion', gccversion='$gccversion', gccosandvers='$gccosandvers' - intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder - d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize - ivtype='$ivtype', ivsize=$ivsize, nvtype='$nvtype', nvsize=$nvsize, Off_t='$lseektype', lseeksize=$lseeksize - alignbytes=$alignbytes, prototype=$prototype - Linker and Libraries: - ld='$ld', ldflags ='$ldflags' - libpth=$libpth - libs=$libs - perllibs=$perllibs - libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl - gnulibc_version='$gnulibc_version' - Dynamic Linking: - dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' - cccdlflags='$cccdlflags', lddlflags='$lddlflags' - -!END! -my $summary_expanded; - -sub myconfig { - return $summary_expanded if $summary_expanded; - ($summary_expanded = $summary) =~ s{\$(\w+)} - { my $c = $Config::Config{$1}; defined($c) ? $c : 'undef' }ge; - $summary_expanded; -} - -local *_ = \my $a; -$_ = <<'!END!'; -Author='' -CONFIG='true' -Date='$Date' -Header='' -Id='$Id' -Locker='' -Log='$Log' -Mcc='Mcc' -PATCHLEVEL='8' -PERL_API_REVISION='5' -PERL_API_SUBVERSION='0' -PERL_API_VERSION='8' -PERL_CONFIG_SH='true' -PERL_PATCHLEVEL='8' -PERL_REVISION='5' -PERL_SUBVERSION='8' -PERL_VERSION='8' -RCSfile='$RCSfile' -Revision='$Revision' -SUBVERSION='8' -Source='' -State='' -_a='.a' -_exe='.exe' -_o='.o' -afs='false' -afsroot='/afs' -alignbytes='8' -ansi2knr='' -aphostname='' -api_revision='5' -api_subversion='0' -api_version='8' -api_versionstring='5.8.0' -ar='ar' -archlib='x:\perl\lib' -archlibexp='x:\perl\lib' -archname64='' -archname='MSWin32-x86-multi-thread' -archobjs='' -asctime_r_proto='0' -awk='awk' -baserev='5' -bash='' -bin='x:\perl\bin' -binexp='x:\perl\bin' -bison='' -byacc='byacc' -byteorder='1234' -c='' -castflags='0' -cat='type' -cc='gcc' -cccdlflags=' ' -ccdlflags=' ' -ccflags=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DPERL_IMPLICIT_CONTEXT -fno-strict-aliasing -DPERL_MSVCRT_READFIX' -ccflags_uselargefiles='' -ccname='gcc' -ccsymbols='' -ccversion='' -cf_by='siepo' -cf_email='siepo@xpeco' -cf_time='Sun May 27 17:53:00 2007' -charsize='1' -chgrp='' -chmod='' -chown='' -clocktype='clock_t' -comm='' -compress='' -contains='grep' -cp='copy' -cpio='' -cpp='gcc -E' -cpp_stuff='42' -cppccsymbols='' -cppflags='-DWIN32' -cpplast='' -cppminus='-' -cpprun='gcc -E' -cppstdin='gcc -E' -cppsymbols='' -crypt_r_proto='0' -cryptlib='' -csh='undef' -ctermid_r_proto='0' -ctime_r_proto='0' -d_Gconvert='sprintf((b),"%.*g",(n),(x))' -d_PRIEUldbl='undef' -d_PRIFUldbl='undef' -d_PRIGUldbl='undef' -d_PRIXU64='undef' -d_PRId64='undef' -d_PRIeldbl='undef' -d_PRIfldbl='undef' -d_PRIgldbl='undef' -d_PRIi64='undef' -d_PRIo64='undef' -d_PRIu64='undef' -d_PRIx64='undef' -d_SCNfldbl='undef' -d__fwalk='undef' -d_access='define' -d_accessx='undef' -d_aintl='undef' -d_alarm='define' -d_archlib='define' -d_asctime_r='undef' -d_atolf='undef' -d_atoll='undef' -d_attribute_format='undef' -d_attribute_malloc='undef' -d_attribute_nonnull='undef' -d_attribute_noreturn='undef' -d_attribute_pure='undef' -d_attribute_unused='undef' -d_attribute_warn_unused_result='undef' -d_bcmp='undef' -d_bcopy='undef' -d_bsd='define' -d_bsdgetpgrp='undef' -d_bsdsetpgrp='undef' -d_bzero='undef' -d_casti32='define' -d_castneg='define' -d_charvspr='undef' -d_chown='undef' -d_chroot='undef' -d_chsize='define' -d_class='undef' -d_clearenv='undef' -d_closedir='define' -d_cmsghdr_s='undef' -d_const='define' -d_copysignl='undef' -d_crypt='define' -d_crypt_r='undef' -d_csh='undef' -d_ctermid_r='undef' -d_ctime_r='undef' -d_cuserid='undef' -d_dbl_dig='define' -d_dbminitproto='undef' -d_difftime='define' -d_dirfd='undef' -d_dirnamlen='define' -d_dlerror='define' -d_dlopen='define' -d_dlsymun='undef' -d_dosuid='undef' -d_drand48_r='undef' -d_drand48proto='undef' -d_dup2='define' -d_eaccess='undef' -d_endgrent='undef' -d_endgrent_r='undef' -d_endhent='undef' -d_endhostent_r='undef' -d_endnent='undef' -d_endnetent_r='undef' -d_endpent='undef' -d_endprotoent_r='undef' -d_endpwent='undef' -d_endpwent_r='undef' -d_endsent='undef' -d_endservent_r='undef' -d_eofnblk='define' -d_eunice='undef' -d_faststdio='define' -d_fchdir='undef' -d_fchmod='undef' -d_fchown='undef' -d_fcntl='undef' -d_fcntl_can_lock='undef' -d_fd_macros='define' -d_fd_set='define' -d_fds_bits='define' -d_fgetpos='define' -d_finite='undef' -d_finitel='undef' -d_flexfnam='define' -d_flock='define' -d_flockproto='define' -d_fork='undef' -d_fp_class='undef' -d_fpathconf='undef' -d_fpclass='undef' -d_fpclassify='undef' -d_fpclassl='undef' -d_fpos64_t='undef' -d_frexpl='undef' -d_fs_data_s='undef' -d_fseeko='undef' -d_fsetpos='define' -d_fstatfs='undef' -d_fstatvfs='undef' -d_fsync='undef' -d_ftello='undef' -d_ftime='define' -d_futimes='undef' -d_getcwd='define' -d_getespwnam='undef' -d_getfsstat='undef' -d_getgrent='undef' -d_getgrent_r='undef' -d_getgrgid_r='undef' -d_getgrnam_r='undef' -d_getgrps='undef' -d_gethbyaddr='define' -d_gethbyname='define' -d_gethent='undef' -d_gethname='define' -d_gethostbyaddr_r='undef' -d_gethostbyname_r='undef' -d_gethostent_r='undef' -d_gethostprotos='define' -d_getitimer='undef' -d_getlogin='define' -d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='undef' -d_getnbyaddr='undef' -d_getnbyname='undef' -d_getnent='undef' -d_getnetbyaddr_r='undef' -d_getnetbyname_r='undef' -d_getnetent_r='undef' -d_getnetprotos='undef' -d_getpagsz='undef' -d_getpbyname='define' -d_getpbynumber='define' -d_getpent='undef' -d_getpgid='undef' -d_getpgrp2='undef' -d_getpgrp='undef' -d_getppid='undef' -d_getprior='undef' -d_getprotobyname_r='undef' -d_getprotobynumber_r='undef' -d_getprotoent_r='undef' -d_getprotoprotos='define' -d_getprpwnam='undef' -d_getpwent='undef' -d_getpwent_r='undef' -d_getpwnam_r='undef' -d_getpwuid_r='undef' -d_getsbyname='define' -d_getsbyport='define' -d_getsent='undef' -d_getservbyname_r='undef' -d_getservbyport_r='undef' -d_getservent_r='undef' -d_getservprotos='define' -d_getspnam='undef' -d_getspnam_r='undef' -d_gettimeod='define' -d_gmtime_r='undef' -d_gnulibc='undef' -d_grpasswd='undef' -d_hasmntopt='undef' -d_htonl='define' -d_ilogbl='undef' -d_index='undef' -d_inetaton='undef' -d_int64_t='undef' -d_isascii='define' -d_isfinite='undef' -d_isinf='undef' -d_isnan='define' -d_isnanl='undef' -d_killpg='undef' -d_lchown='undef' -d_ldbl_dig='define' -d_libm_lib_version='undef' -d_link='define' -d_localtime_r='undef' -d_locconv='define' -d_lockf='undef' -d_longdbl='define' -d_longlong='undef' -d_lseekproto='define' -d_lstat='undef' -d_madvise='undef' -d_malloc_good_size='undef' -d_malloc_size='undef' -d_mblen='define' -d_mbstowcs='define' -d_mbtowc='define' -d_memchr='define' -d_memcmp='define' -d_memcpy='define' -d_memmove='define' -d_memset='define' -d_mkdir='define' -d_mkdtemp='undef' -d_mkfifo='undef' -d_mkstemp='undef' -d_mkstemps='undef' -d_mktime='define' -d_mmap='undef' -d_modfl='undef' -d_modfl_pow32_bug='undef' -d_modflproto='undef' -d_mprotect='undef' -d_msg='undef' -d_msg_ctrunc='undef' -d_msg_dontroute='undef' -d_msg_oob='undef' -d_msg_peek='undef' -d_msg_proxy='undef' -d_msgctl='undef' -d_msgget='undef' -d_msghdr_s='undef' -d_msgrcv='undef' -d_msgsnd='undef' -d_msync='undef' -d_munmap='undef' -d_mymalloc='undef' -d_nice='undef' -d_nl_langinfo='undef' -d_nv_preserves_uv='define' -d_nv_zero_is_allbits_zero='define' -d_off64_t='undef' -d_old_pthread_create_joinable='undef' -d_oldpthreads='undef' -d_oldsock='undef' -d_open3='undef' -d_pathconf='undef' -d_pause='define' -d_perl_otherlibdirs='undef' -d_phostname='undef' -d_pipe='define' -d_poll='undef' -d_portable='define' -d_procselfexe='undef' -d_pthread_atfork='undef' -d_pthread_attr_setscope='undef' -d_pthread_yield='undef' -d_pwage='undef' -d_pwchange='undef' -d_pwclass='undef' -d_pwcomment='undef' -d_pwexpire='undef' -d_pwgecos='undef' -d_pwpasswd='undef' -d_pwquota='undef' -d_qgcvt='undef' -d_quad='undef' -d_random_r='undef' -d_readdir64_r='undef' -d_readdir='define' -d_readdir_r='undef' -d_readlink='undef' -d_readv='undef' -d_recvmsg='undef' -d_rename='define' -d_rewinddir='define' -d_rmdir='define' -d_safebcpy='undef' -d_safemcpy='undef' -d_sanemcmp='define' -d_sbrkproto='undef' -d_scalbnl='undef' -d_sched_yield='undef' -d_scm_rights='undef' -d_seekdir='define' -d_select='define' -d_sem='undef' -d_semctl='undef' -d_semctl_semid_ds='undef' -d_semctl_semun='undef' -d_semget='undef' -d_semop='undef' -d_sendmsg='undef' -d_setegid='undef' -d_seteuid='undef' -d_setgrent='undef' -d_setgrent_r='undef' -d_setgrps='undef' -d_sethent='undef' -d_sethostent_r='undef' -d_setitimer='undef' -d_setlinebuf='undef' -d_setlocale='define' -d_setlocale_r='undef' -d_setnent='undef' -d_setnetent_r='undef' -d_setpent='undef' -d_setpgid='undef' -d_setpgrp2='undef' -d_setpgrp='undef' -d_setprior='undef' -d_setproctitle='undef' -d_setprotoent_r='undef' -d_setpwent='undef' -d_setpwent_r='undef' -d_setregid='undef' -d_setresgid='undef' -d_setresuid='undef' -d_setreuid='undef' -d_setrgid='undef' -d_setruid='undef' -d_setsent='undef' -d_setservent_r='undef' -d_setsid='undef' -d_setvbuf='define' -d_sfio='undef' -d_shm='undef' -d_shmat='undef' -d_shmatprototype='undef' -d_shmctl='undef' -d_shmdt='undef' -d_shmget='undef' -d_sigaction='undef' -d_sigprocmask='undef' -d_sigsetjmp='undef' -d_sockatmark='undef' -d_sockatmarkproto='undef' -d_socket='define' -d_socklen_t='undef' -d_sockpair='undef' -d_socks5_init='undef' -d_sprintf_returns_strlen='define' -d_sqrtl='undef' -d_srand48_r='undef' -d_srandom_r='undef' -d_sresgproto='undef' -d_sresuproto='undef' -d_statblks='undef' -d_statfs_f_flags='undef' -d_statfs_s='undef' -d_statvfs='undef' -d_stdio_cnt_lval='define' -d_stdio_ptr_lval='define' -d_stdio_ptr_lval_nochange_cnt='define' -d_stdio_ptr_lval_sets_cnt='undef' -d_stdio_stream_array='undef' -d_stdiobase='define' -d_stdstdio='define' -d_strchr='define' -d_strcoll='define' -d_strctcpy='define' -d_strerrm='strerror(e)' -d_strerror='define' -d_strerror_r='undef' -d_strftime='define' -d_strlcat='undef' -d_strlcpy='undef' -d_strtod='define' -d_strtol='define' -d_strtold='undef' -d_strtoll='undef' -d_strtoq='undef' -d_strtoul='define' -d_strtoull='undef' -d_strtouq='undef' -d_strxfrm='define' -d_suidsafe='undef' -d_symlink='undef' -d_syscall='undef' -d_syscallproto='undef' -d_sysconf='undef' -d_sysernlst='' -d_syserrlst='define' -d_system='define' -d_tcgetpgrp='undef' -d_tcsetpgrp='undef' -d_telldir='define' -d_telldirproto='define' -d_time='define' -d_times='define' -d_tm_tm_gmtoff='undef' -d_tm_tm_zone='undef' -d_tmpnam_r='undef' -d_truncate='undef' -d_ttyname_r='undef' -d_tzname='define' -d_u32align='define' -d_ualarm='undef' -d_umask='define' -d_uname='define' -d_union_semun='define' -d_unordered='undef' -d_unsetenv='undef' -d_usleep='undef' -d_usleepproto='undef' -d_ustat='undef' -d_vendorarch='undef' -d_vendorbin='undef' -d_vendorlib='undef' -d_vendorscript='undef' -d_vfork='undef' -d_void_closedir='undef' -d_voidsig='define' -d_voidtty='' -d_volatile='define' -d_vprintf='define' -d_wait4='undef' -d_waitpid='define' -d_wcstombs='define' -d_wctomb='define' -d_writev='undef' -d_xenix='undef' -date='date' -db_hashtype='int' -db_prefixtype='int' -db_version_major='0' -db_version_minor='0' -db_version_patch='0' -defvoidused='15' -direntrytype='struct direct' -dlext='dll' -dlsrc='dl_win32.xs' -doublesize='8' -drand01='(rand()/(double)((unsigned)1<{$key} = $value; # cache it -} - -my $prevpos = 0; - -sub FIRSTKEY { - $prevpos = 0; - substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 ); -} - -sub NEXTKEY { - my $pos = index($Config_SH_expanded, qq('\n), $prevpos) + 2; - my $len = index($Config_SH_expanded, "=", $pos) - $pos; - $prevpos = $pos; - $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef; -} - -sub EXISTS { - return 1 if exists($_[0]->{$_[1]}); - - return(index($Config_SH_expanded, "\n$_[1]='") != -1 - ); -} - -sub STORE { die "\%Config::Config is read-only\n" } -*DELETE = \&STORE; -*CLEAR = \&STORE; - - -sub config_sh { - substr $Config_SH_expanded, 1, $config_sh_len; -} - -sub config_re { - my $re = shift; - return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/, - $Config_SH_expanded; -} - -sub config_vars { - # implements -V:cfgvar option (see perlrun -V:) - foreach (@_) { - # find optional leading, trailing colons; and query-spec - my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/; # flags fore and aft, - # map colon-flags to print decorations - my $prfx = $notag ? '': "$qry="; # tag-prefix for print - my $lnend = $lncont ? ' ' : ";\n"; # line ending for print - - # all config-vars are by definition \w only, any \W means regex - if ($qry =~ /\W/) { - my @matches = config_re($qry); - print map "$_$lnend", @matches ? @matches : "$qry: not found" if !$notag; - print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found" if $notag; - } else { - my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry} - : 'UNKNOWN'; - $v = 'undef' unless defined $v; - print "${prfx}'${v}'$lnend"; - } - } -} - -# Called by the real AUTOLOAD -sub launcher { - undef &AUTOLOAD; - goto \&$Config::AUTOLOAD; -} - -1; diff --git a/Master/tlpkg/installer/perllib/Cwd.pm b/Master/tlpkg/installer/perllib/Cwd.pm deleted file mode 100644 index 8d25af9f7cd..00000000000 --- a/Master/tlpkg/installer/perllib/Cwd.pm +++ /dev/null @@ -1,710 +0,0 @@ -package Cwd; - -=head1 NAME - -Cwd - get pathname of current working directory - -=head1 SYNOPSIS - - use Cwd; - my $dir = getcwd; - - use Cwd 'abs_path'; - my $abs_path = abs_path($file); - -=head1 DESCRIPTION - -This module provides functions for determining the pathname of the -current working directory. It is recommended that getcwd (or another -*cwd() function) be used in I 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/installer/perllib/Data/Dumper.pm b/Master/tlpkg/installer/perllib/Data/Dumper.pm deleted file mode 100644 index b7fe1d61e77..00000000000 --- a/Master/tlpkg/installer/perllib/Data/Dumper.pm +++ /dev/null @@ -1,1264 +0,0 @@ -# -# Data/Dumper.pm -# -# convert perl data structures into perl syntax suitable for both printing -# and eval -# -# Documentation at the __END__ -# - -package Data::Dumper; - -$VERSION = '2.121_08'; - -#$| = 1; - -use 5.006_001; -require Exporter; -require overload; - -use Carp; - -BEGIN { - @ISA = qw(Exporter); - @EXPORT = qw(Dumper); - @EXPORT_OK = qw(DumperX); - - # if run under miniperl, or otherwise lacking dynamic loading, - # XSLoader should be attempted to load, or the pure perl flag - # toggled on load failure. - eval { - require XSLoader; - }; - $Useperl = 1 if $@; -} - -XSLoader::load( 'Data::Dumper' ) unless $Useperl; - -# module vars and their defaults -$Indent = 2 unless defined $Indent; -$Purity = 0 unless defined $Purity; -$Pad = "" unless defined $Pad; -$Varname = "VAR" unless defined $Varname; -$Useqq = 0 unless defined $Useqq; -$Terse = 0 unless defined $Terse; -$Freezer = "" unless defined $Freezer; -$Toaster = "" unless defined $Toaster; -$Deepcopy = 0 unless defined $Deepcopy; -$Quotekeys = 1 unless defined $Quotekeys; -$Bless = "bless" unless defined $Bless; -#$Expdepth = 0 unless defined $Expdepth; -$Maxdepth = 0 unless defined $Maxdepth; -$Pair = ' => ' unless defined $Pair; -$Useperl = 0 unless defined $Useperl; -$Sortkeys = 0 unless defined $Sortkeys; -$Deparse = 0 unless defined $Deparse; - -# -# expects an arrayref of values to be dumped. -# can optionally pass an arrayref of names for the values. -# names must have leading $ sign stripped. begin the name with * -# to cause output of arrays and hashes rather than refs. -# -sub new { - my($c, $v, $n) = @_; - - croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])" - unless (defined($v) && (ref($v) eq 'ARRAY')); - $n = [] unless (defined($n) && (ref($v) eq 'ARRAY')); - - my($s) = { - level => 0, # current recursive depth - indent => $Indent, # various styles of indenting - pad => $Pad, # all lines prefixed by this string - xpad => "", # padding-per-level - apad => "", # added padding for hash keys n such - sep => "", # list separator - pair => $Pair, # hash key/value separator: defaults to ' => ' - seen => {}, # local (nested) refs (id => [name, val]) - todump => $v, # values to dump [] - names => $n, # optional names for values [] - varname => $Varname, # prefix to use for tagging nameless ones - purity => $Purity, # degree to which output is evalable - useqq => $Useqq, # use "" for strings (backslashitis ensues) - terse => $Terse, # avoid name output (where feasible) - freezer => $Freezer, # name of Freezer method for objects - toaster => $Toaster, # name of method to revive objects - deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion - quotekeys => $Quotekeys, # quote hash keys - 'bless' => $Bless, # keyword to use for "bless" -# expdepth => $Expdepth, # cutoff depth for explicit dumping - maxdepth => $Maxdepth, # depth beyond which we give up - useperl => $Useperl, # use the pure Perl implementation - sortkeys => $Sortkeys, # flag or filter for sorting hash keys - deparse => $Deparse, # use B::Deparse for coderefs - }; - - if ($Indent > 0) { - $s->{xpad} = " "; - $s->{sep} = "\n"; - } - return bless($s, $c); -} - -sub init_refaddr_format { - require Config; - my $f = $Config::Config{uvxformat}; - $f =~ tr/"//d; - our $refaddr_format = "0x%" . $f; -} - -sub format_refaddr { - require Scalar::Util; - sprintf our $refaddr_format, Scalar::Util::refaddr(shift); -} - -# -# add-to or query the table of already seen references -# -sub Seen { - my($s, $g) = @_; - if (defined($g) && (ref($g) eq 'HASH')) { - my($k, $v, $id); - while (($k, $v) = each %$g) { - if (defined $v and ref $v) { - $id = format_refaddr($v); - if ($k =~ /^[*](.*)$/) { - $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) : - (ref $v eq 'HASH') ? ( "\\\%" . $1 ) : - (ref $v eq 'CODE') ? ( "\\\&" . $1 ) : - ( "\$" . $1 ) ; - } - elsif ($k !~ /^\$/) { - $k = "\$" . $k; - } - $s->{seen}{$id} = [$k, $v]; - } - else { - carp "Only refs supported, ignoring non-ref item \$$k"; - } - } - return $s; - } - else { - return map { @$_ } values %{$s->{seen}}; - } -} - -# -# set or query the values to be dumped -# -sub Values { - my($s, $v) = @_; - if (defined($v) && (ref($v) eq 'ARRAY')) { - $s->{todump} = [@$v]; # make a copy - return $s; - } - else { - return @{$s->{todump}}; - } -} - -# -# set or query the names of the values to be dumped -# -sub Names { - my($s, $n) = @_; - if (defined($n) && (ref($n) eq 'ARRAY')) { - $s->{names} = [@$n]; # make a copy - return $s; - } - else { - return @{$s->{names}}; - } -} - -sub DESTROY {} - -sub Dump { - return &Dumpxs - unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) || - $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}) || - $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse}); - return &Dumpperl; -} - -# -# dump the refs in the current dumper object. -# expects same args as new() if called via package name. -# -sub Dumpperl { - my($s) = shift; - my(@out, $val, $name); - my($i) = 0; - local(@post); - init_refaddr_format(); - - $s = $s->new(@_) unless ref $s; - - for $val (@{$s->{todump}}) { - my $out = ""; - @post = (); - $name = $s->{names}[$i++]; - if (defined $name) { - if ($name =~ /^[*](.*)$/) { - if (defined $val) { - $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) : - (ref $val eq 'HASH') ? ( "\%" . $1 ) : - (ref $val eq 'CODE') ? ( "\*" . $1 ) : - ( "\$" . $1 ) ; - } - else { - $name = "\$" . $1; - } - } - elsif ($name !~ /^\$/) { - $name = "\$" . $name; - } - } - else { - $name = "\$" . $s->{varname} . $i; - } - - my $valstr; - { - local($s->{apad}) = $s->{apad}; - $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2; - $valstr = $s->_dump($val, $name); - } - - $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse}; - $out .= $s->{pad} . $valstr . $s->{sep}; - $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post) - . ';' . $s->{sep} if @post; - - push @out, $out; - } - return wantarray ? @out : join('', @out); -} - -# -# twist, toil and turn; -# and recurse, of course. -# sometimes sordidly; -# and curse if no recourse. -# -sub _dump { - my($s, $val, $name) = @_; - my($sname); - my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad); - - $type = ref $val; - $out = ""; - - if ($type) { - - # Call the freezer method if it's specified and the object has the - # method. Trap errors and warn() instead of die()ing, like the XS - # implementation. - my $freezer = $s->{freezer}; - if ($freezer and UNIVERSAL::can($val, $freezer)) { - eval { $val->$freezer() }; - warn "WARNING(Freezer method call failed): $@" if $@; - } - - require Scalar::Util; - $realpack = Scalar::Util::blessed($val); - $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val; - $id = format_refaddr($val); - - # if it has a name, we need to either look it up, or keep a tab - # on it so we know when we hit it later - if (defined($name) and length($name)) { - # keep a tab on it so that we dont fall into recursive pit - if (exists $s->{seen}{$id}) { -# if ($s->{expdepth} < $s->{level}) { - if ($s->{purity} and $s->{level} > 0) { - $out = ($realtype eq 'HASH') ? '{}' : - ($realtype eq 'ARRAY') ? '[]' : - 'do{my $o}' ; - push @post, $name . " = " . $s->{seen}{$id}[0]; - } - else { - $out = $s->{seen}{$id}[0]; - if ($name =~ /^([\@\%])/) { - my $start = $1; - if ($out =~ /^\\$start/) { - $out = substr($out, 1); - } - else { - $out = $start . '{' . $out . '}'; - } - } - } - return $out; -# } - } - else { - # store our name - $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : - ($realtype eq 'CODE' and - $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : - $name ), - $val ]; - } - } - - if ($realpack and $realpack eq 'Regexp') { - $out = "$val"; - $out =~ s,/,\\/,g; - return "qr/$out/"; - } - - # If purity is not set and maxdepth is set, then check depth: - # if we have reached maximum depth, return the string - # representation of the thing we are currently examining - # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). - if (!$s->{purity} - and $s->{maxdepth} > 0 - and $s->{level} >= $s->{maxdepth}) - { - return qq['$val']; - } - - # we have a blessed ref - if ($realpack) { - $out = $s->{'bless'} . '( '; - $blesspad = $s->{apad}; - $s->{apad} .= ' ' if ($s->{indent} >= 2); - } - - $s->{level}++; - $ipad = $s->{xpad} x $s->{level}; - - if ($realtype eq 'SCALAR' || $realtype eq 'REF') { - if ($realpack) { - $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; - } - else { - $out .= '\\' . $s->_dump($$val, "\${$name}"); - } - } - elsif ($realtype eq 'GLOB') { - $out .= '\\' . $s->_dump($$val, "*{$name}"); - } - elsif ($realtype eq 'ARRAY') { - my($v, $pad, $mname); - my($i) = 0; - $out .= ($name =~ /^\@/) ? '(' : '['; - $pad = $s->{sep} . $s->{pad} . $s->{apad}; - ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : - # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} - ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : - ($mname = $name . '->'); - $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; - for $v (@$val) { - $sname = $mname . '[' . $i . ']'; - $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3; - $out .= $pad . $ipad . $s->_dump($v, $sname); - $out .= "," if $i++ < $#$val; - } - $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i; - $out .= ($name =~ /^\@/) ? ')' : ']'; - } - elsif ($realtype eq 'HASH') { - my($k, $v, $pad, $lpad, $mname, $pair); - $out .= ($name =~ /^\%/) ? '(' : '{'; - $pad = $s->{sep} . $s->{pad} . $s->{apad}; - $lpad = $s->{apad}; - $pair = $s->{pair}; - ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : - # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} - ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : - ($mname = $name . '->'); - $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; - my ($sortkeys, $keys, $key) = ("$s->{sortkeys}"); - if ($sortkeys) { - if (ref($s->{sortkeys}) eq 'CODE') { - $keys = $s->{sortkeys}($val); - unless (ref($keys) eq 'ARRAY') { - carp "Sortkeys subroutine did not return ARRAYREF"; - $keys = []; - } - } - else { - $keys = [ sort keys %$val ]; - } - } - while (($k, $v) = ! $sortkeys ? (each %$val) : - @$keys ? ($key = shift(@$keys), $val->{$key}) : - () ) - { - my $nk = $s->_dump($k, ""); - $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/; - $sname = $mname . '{' . $nk . '}'; - $out .= $pad . $ipad . $nk . $pair; - - # temporarily alter apad - $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2; - $out .= $s->_dump($val->{$k}, $sname) . ","; - $s->{apad} = $lpad if $s->{indent} >= 2; - } - if (substr($out, -1) eq ',') { - chop $out; - $out .= $pad . ($s->{xpad} x ($s->{level} - 1)); - } - $out .= ($name =~ /^\%/) ? ')' : '}'; - } - elsif ($realtype eq 'CODE') { - if ($s->{deparse}) { - require B::Deparse; - my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val); - $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1); - $sub =~ s/\n/$pad/gse; - $out .= $sub; - } else { - $out .= 'sub { "DUMMY" }'; - carp "Encountered CODE ref, using dummy placeholder" if $s->{purity}; - } - } - else { - croak "Can\'t handle $realtype type."; - } - - if ($realpack) { # we have a blessed ref - $out .= ', \'' . $realpack . '\'' . ' )'; - $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne ''; - $s->{apad} = $blesspad; - } - $s->{level}--; - - } - else { # simple scalar - - my $ref = \$_[1]; - # first, catalog the scalar - if ($name ne '') { - $id = format_refaddr($ref); - if (exists $s->{seen}{$id}) { - if ($s->{seen}{$id}[2]) { - $out = $s->{seen}{$id}[0]; - #warn "[<$out]\n"; - return "\${$out}"; - } - } - else { - #warn "[>\\$name]\n"; - $s->{seen}{$id} = ["\\$name", $ref]; - } - } - if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob - my $name = substr($val, 1); - if ($name =~ /^[A-Za-z_][\w:]*$/) { - $name =~ s/^main::/::/; - $sname = $name; - } - else { - $sname = $s->_dump($name, ""); - $sname = '{' . $sname . '}'; - } - if ($s->{purity}) { - my $k; - local ($s->{level}) = 0; - for $k (qw(SCALAR ARRAY HASH)) { - my $gval = *$val{$k}; - next unless defined $gval; - next if $k eq "SCALAR" && ! defined $$gval; # always there - - # _dump can push into @post, so we hold our place using $postlen - my $postlen = scalar @post; - $post[$postlen] = "\*$sname = "; - local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2; - $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}"); - } - } - $out .= '*' . $sname; - } - elsif (!defined($val)) { - $out .= "undef"; - } - elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})\z/) { # safe decimal number - $out .= $val; - } - else { # string - if ($s->{useqq} or $val =~ tr/\0-\377//c) { - # Fall back to qq if there's unicode - $out .= qquote($val, $s->{useqq}); - } - else { - $val =~ s/([\\\'])/\\$1/g; - $out .= '\'' . $val . '\''; - } - } - } - if ($id) { - # if we made it this far, $id was added to seen list at current - # level, so remove it to get deep copies - if ($s->{deepcopy}) { - delete($s->{seen}{$id}); - } - elsif ($name) { - $s->{seen}{$id}[2] = 1; - } - } - return $out; -} - -# -# non-OO style of earlier version -# -sub Dumper { - return Data::Dumper->Dump([@_]); -} - -# compat stub -sub DumperX { - return Data::Dumper->Dumpxs([@_], []); -} - -sub Dumpf { return Data::Dumper->Dump(@_) } - -sub Dumpp { print Data::Dumper->Dump(@_) } - -# -# reset the "seen" cache -# -sub Reset { - my($s) = shift; - $s->{seen} = {}; - return $s; -} - -sub Indent { - my($s, $v) = @_; - if (defined($v)) { - if ($v == 0) { - $s->{xpad} = ""; - $s->{sep} = ""; - } - else { - $s->{xpad} = " "; - $s->{sep} = "\n"; - } - $s->{indent} = $v; - return $s; - } - else { - return $s->{indent}; - } -} - -sub Pair { - my($s, $v) = @_; - defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair}; -} - -sub Pad { - my($s, $v) = @_; - defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad}; -} - -sub Varname { - my($s, $v) = @_; - defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname}; -} - -sub Purity { - my($s, $v) = @_; - defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity}; -} - -sub Useqq { - my($s, $v) = @_; - defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq}; -} - -sub Terse { - my($s, $v) = @_; - defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse}; -} - -sub Freezer { - my($s, $v) = @_; - defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer}; -} - -sub Toaster { - my($s, $v) = @_; - defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster}; -} - -sub Deepcopy { - my($s, $v) = @_; - defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy}; -} - -sub Quotekeys { - my($s, $v) = @_; - defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys}; -} - -sub Bless { - my($s, $v) = @_; - defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; -} - -sub Maxdepth { - my($s, $v) = @_; - defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; -} - -sub Useperl { - my($s, $v) = @_; - defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'}; -} - -sub Sortkeys { - my($s, $v) = @_; - defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'}; -} - -sub Deparse { - my($s, $v) = @_; - defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'}; -} - -# used by qquote below -my %esc = ( - "\a" => "\\a", - "\b" => "\\b", - "\t" => "\\t", - "\n" => "\\n", - "\f" => "\\f", - "\r" => "\\r", - "\e" => "\\e", -); - -# put a string value in double quotes -sub qquote { - local($_) = shift; - s/([\\\"\@\$])/\\$1/g; - my $bytes; { use bytes; $bytes = length } - s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length; - return qq("$_") unless - /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit - - my $high = shift || ""; - s/([\a\b\t\n\f\r\e])/$esc{$1}/g; - - if (ord('^')==94) { # ascii - # no need for 3 digits in escape for these - s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; - s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; - # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE-- - if ($high eq "iso8859") { - s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; - } elsif ($high eq "utf8") { -# use utf8; -# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; - } elsif ($high eq "8bit") { - # leave it as it is - } else { - s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; - s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; - } - } - else { # ebcdic - s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)} - {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg; - s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])} - {'\\'.sprintf('%03o',ord($1))}eg; - } - - return qq("$_"); -} - -# helper sub to sort hash keys in Perl < 5.8.0 where we don't have -# access to sortsv() from XS -sub _sortkeys { [ sort keys %{$_[0]} ] } - -1; -__END__ - -=head1 NAME - -Data::Dumper - stringified perl data structures, suitable for both printing and C - -=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/installer/perllib/Digest/MD5.pm b/Master/tlpkg/installer/perllib/Digest/MD5.pm deleted file mode 100644 index 17fb11d678a..00000000000 --- a/Master/tlpkg/installer/perllib/Digest/MD5.pm +++ /dev/null @@ -1,376 +0,0 @@ -package Digest::MD5; - -use strict; -use vars qw($VERSION @ISA @EXPORT_OK); - -$VERSION = '2.36'; # $Date: 2005/11/30 13:46:47 $ - -require Exporter; -*import = \&Exporter::import; -@EXPORT_OK = qw(md5 md5_hex md5_base64); - -eval { - require Digest::base; - push(@ISA, 'Digest::base'); -}; -if ($@) { - my $err = $@; - *add_bits = sub { die $err }; -} - - -eval { - require XSLoader; - XSLoader::load('Digest::MD5', $VERSION); -}; -if ($@) { - my $olderr = $@; - eval { - # Try to load the pure perl version - require Digest::Perl::MD5; - - Digest::Perl::MD5->import(qw(md5 md5_hex md5_base64)); - push(@ISA, "Digest::Perl::MD5"); # make OO interface work - }; - if ($@) { - # restore the original error - die $olderr; - } -} -else { - *reset = \&new; -} - -1; -__END__ - -=head1 NAME - -Digest::MD5 - Perl interface to the MD5 Algorithm - -=head1 SYNOPSIS - - # Functional style - use Digest::MD5 qw(md5 md5_hex md5_base64); - - $digest = md5($data); - $digest = md5_hex($data); - $digest = md5_base64($data); - - # OO style - use Digest::MD5; - - $ctx = Digest::MD5->new; - - $ctx->add($data); - $ctx->addfile(*FILE); - - $digest = $ctx->digest; - $digest = $ctx->hexdigest; - $digest = $ctx->b64digest; - -=head1 DESCRIPTION - -The C 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/installer/perllib/Digest/base.pm b/Master/tlpkg/installer/perllib/Digest/base.pm deleted file mode 100644 index cb336c2cf61..00000000000 --- a/Master/tlpkg/installer/perllib/Digest/base.pm +++ /dev/null @@ -1,100 +0,0 @@ -package Digest::base; - -use strict; -use vars qw($VERSION); -$VERSION = "1.00"; - -# subclass is supposed to implement at least these -sub new; -sub clone; -sub add; -sub digest; - -sub reset { - my $self = shift; - $self->new(@_); # ugly -} - -sub addfile { - my ($self, $handle) = @_; - - my $n; - my $buf = ""; - - while (($n = read($handle, $buf, 4*1024))) { - $self->add($buf); - } - unless (defined $n) { - require Carp; - Carp::croak("Read failed: $!"); - } - - $self; -} - -sub add_bits { - my $self = shift; - my $bits; - my $nbits; - if (@_ == 1) { - my $arg = shift; - $bits = pack("B*", $arg); - $nbits = length($arg); - } - else { - ($bits, $nbits) = @_; - } - if (($nbits % 8) != 0) { - require Carp; - Carp::croak("Number of bits must be multiple of 8 for this algorithm"); - } - return $self->add(substr($bits, 0, $nbits/8)); -} - -sub hexdigest { - my $self = shift; - return unpack("H*", $self->digest(@_)); -} - -sub b64digest { - my $self = shift; - require MIME::Base64; - my $b64 = MIME::Base64::encode($self->digest(@_), ""); - $b64 =~ s/=+$//; - return $b64; -} - -1; - -__END__ - -=head1 NAME - -Digest::base - Digest base class - -=head1 SYNOPSIS - - package Digest::Foo; - use base 'Digest::base'; - -=head1 DESCRIPTION - -The C 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/installer/perllib/Digest/file.pm b/Master/tlpkg/installer/perllib/Digest/file.pm deleted file mode 100644 index 67985fd7599..00000000000 --- a/Master/tlpkg/installer/perllib/Digest/file.pm +++ /dev/null @@ -1,85 +0,0 @@ -package Digest::file; - -use strict; - -use Exporter (); -use Carp qw(croak); -use Digest (); - -use vars qw($VERSION @ISA @EXPORT_OK); - -$VERSION = "1.00"; -@ISA = qw(Exporter); -@EXPORT_OK = qw(digest_file_ctx digest_file digest_file_hex digest_file_base64); - -sub digest_file_ctx { - my $file = shift; - croak("No digest algorithm specified") unless @_; - local *F; - open(F, $file) || croak("Can't open '$file': $!"); - binmode(F); - my $ctx = Digest->new(@_); - $ctx->addfile(*F); - close(F); - return $ctx; -} - -sub digest_file { - digest_file_ctx(@_)->digest; -} - -sub digest_file_hex { - digest_file_ctx(@_)->hexdigest; -} - -sub digest_file_base64 { - digest_file_ctx(@_)->b64digest; -} - -1; - -__END__ - -=head1 NAME - -Digest::file - Calculate digests of files - -=head1 SYNOPSIS - - # Poor mans "md5sum" command - use Digest::file qw(digest_file_hex); - for (@ARGV) { - print digest_file_hex($_, "MD5"), " $_\n"; - } - -=head1 DESCRIPTION - -This module provide 3 convenience functions to calculate the digest -of files. The following functions are provided: - -=over - -=item digest_file( $file, $algorithm, [$arg,...] ) - -This function will calculate and return the binary digest of the bytes -of the given file. The function will croak if it fails to open or -read the file. - -The $algorithm is a string like "MD2", "MD5", "SHA-1", "SHA-512". -Additional arguments are passed to the constructor for the -implementation of the given algorithm. - -=item digest_file_hex( $file, $algorithm, [$arg,...] ) - -Same as digest_file(), but return the digest in hex form. - -=item digest_file_base64( $file, $algorithm, [$arg,...] ) - -Same as digest_file(), but return the digest as a base64 encoded -string. - -=back - -=head1 SEE ALSO - -L diff --git a/Master/tlpkg/installer/perllib/DynaLoader.pm b/Master/tlpkg/installer/perllib/DynaLoader.pm deleted file mode 100644 index 178e9b2616c..00000000000 --- a/Master/tlpkg/installer/perllib/DynaLoader.pm +++ /dev/null @@ -1,833 +0,0 @@ - -# Generated from DynaLoader.pm.PL - -package DynaLoader; - -# And Gandalf said: 'Many folk like to know beforehand what is to -# be set on the table; but those who have laboured to prepare the -# feast like to keep their secret; for wonder makes the words of -# praise louder.' - -# (Quote from Tolkien suggested by Anno Siegel.) -# -# See pod text at end of file for documentation. -# See also ext/DynaLoader/README in source tree for other information. -# -# Tim.Bunce@ig.co.uk, August 1994 - -use vars qw($VERSION *AUTOLOAD); - -$VERSION = '1.05'; # avoid typo warning - -require AutoLoader; -*AUTOLOAD = \&AutoLoader::AUTOLOAD; - -use Config; - -# The following require can't be removed during maintenance -# releases, sadly, because of the risk of buggy code that does -# require Carp; Carp::croak "..."; without brackets dying -# if Carp hasn't been loaded in earlier compile time. :-( -# We'll let those bugs get found on the development track. -require Carp if $] < 5.00450; - -# enable debug/trace messages from DynaLoader perl code -$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; - -# -# Flags to alter dl_load_file behaviour. Assigned bits: -# 0x01 make symbols available for linking later dl_load_file's. -# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) -# (ignored under VMS; effect is built-in to image linking) -# -# This is called as a class method $module->dl_load_flags. The -# definition here will be inherited and result on "default" loading -# behaviour unless a sub-class of DynaLoader defines its own version. -# - -sub dl_load_flags { 0x00 } - -# ($dl_dlext, $dlsrc) -# = @Config::Config{'dlext', 'dlsrc'}; - ($dl_dlext, $dlsrc) = ('dll','dl_win32.xs') -; -# Some systems need special handling to expand file specifications -# (VMS support by Charles Bailey ) -# 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/installer/perllib/Encode.pm b/Master/tlpkg/installer/perllib/Encode.pm deleted file mode 100644 index ac0123c89ec..00000000000 --- a/Master/tlpkg/installer/perllib/Encode.pm +++ /dev/null @@ -1,851 +0,0 @@ -# -# $Id: Encode.pm,v 2.12 2005/09/08 14:17:17 dankogai Exp dankogai $ -# -package Encode; -use strict; -our $VERSION = sprintf "%d.%02d", q$Revision: 2.12 $ =~ /(\d+)/g; -sub DEBUG () { 0 } -use XSLoader (); -XSLoader::load(__PACKAGE__, $VERSION); - -require Exporter; -use base qw/Exporter/; - -# Public, encouraged API is exported by default - -our @EXPORT = qw( - decode decode_utf8 encode encode_utf8 - encodings find_encoding clone_encoding -); - -our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC - PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL); -our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN - FB_PERLQQ FB_HTMLCREF FB_XMLCREF); - -our @EXPORT_OK = - ( - qw( - _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit - is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade - ), - @FB_FLAGS, @FB_CONSTS, - ); - -our %EXPORT_TAGS = - ( - all => [ @EXPORT, @EXPORT_OK ], - fallbacks => [ @FB_CONSTS ], - fallback_all => [ @FB_CONSTS, @FB_FLAGS ], - ); - -# Documentation moved after __END__ for speed - NI-S - -our $ON_EBCDIC = (ord("A") == 193); - -use Encode::Alias; - -# Make a %Encoding package variable to allow a certain amount of cheating -our %Encoding; -our %ExtModule; -require Encode::Config; -eval { require Encode::ConfigLocal }; - -sub encodings -{ - my $class = shift; - my %enc; - if (@_ and $_[0] eq ":all"){ - %enc = ( %Encoding, %ExtModule ); - }else{ - %enc = %Encoding; - for my $mod (map {m/::/o ? $_ : "Encode::$_" } @_){ - DEBUG and warn $mod; - for my $enc (keys %ExtModule){ - $ExtModule{$enc} eq $mod and $enc{$enc} = $mod; - } - } - } - return - sort { lc $a cmp lc $b } - grep {!/^(?:Internal|Unicode|Guess)$/o} keys %enc; -} - -sub perlio_ok{ - my $obj = ref($_[0]) ? $_[0] : find_encoding($_[0]); - $obj->can("perlio_ok") and return $obj->perlio_ok(); - return 0; # safety net -} - -sub define_encoding -{ - my $obj = shift; - my $name = shift; - $Encoding{$name} = $obj; - my $lc = lc($name); - define_alias($lc => $obj) unless $lc eq $name; - while (@_){ - my $alias = shift; - define_alias($alias, $obj); - } - return $obj; -} - -sub getEncoding -{ - my ($class, $name, $skip_external) = @_; - - ref($name) && $name->can('renew') and return $name; - exists $Encoding{$name} and return $Encoding{$name}; - my $lc = lc $name; - exists $Encoding{$lc} and return $Encoding{$lc}; - - my $oc = $class->find_alias($name); - defined($oc) and return $oc; - $lc ne $name and $oc = $class->find_alias($lc); - defined($oc) and return $oc; - - unless ($skip_external) - { - if (my $mod = $ExtModule{$name} || $ExtModule{$lc}){ - $mod =~ s,::,/,g ; $mod .= '.pm'; - eval{ require $mod; }; - exists $Encoding{$name} and return $Encoding{$name}; - } - } - return; -} - -sub find_encoding($;$) -{ - my ($name, $skip_external) = @_; - return __PACKAGE__->getEncoding($name,$skip_external); -} - -sub resolve_alias($){ - my $obj = find_encoding(shift); - defined $obj and return $obj->name; - return; -} - -sub clone_encoding($){ - my $obj = find_encoding(shift); - ref $obj or return; - eval { require Storable }; - $@ and return; - return Storable::dclone($obj); -} - -sub encode($$;$) -{ - my ($name, $string, $check) = @_; - return undef unless defined $string; - $string .= '' if ref $string; # stringify; - $check ||=0; - my $enc = find_encoding($name); - unless(defined $enc){ - require Carp; - Carp::croak("Unknown encoding '$name'"); - } - my $octets = $enc->encode($string,$check); - $_[1] = $string if $check and !($check & LEAVE_SRC()); - return $octets; -} - -sub decode($$;$) -{ - my ($name,$octets,$check) = @_; - return undef unless defined $octets; - $octets .= '' if ref $octets; - $check ||=0; - my $enc = find_encoding($name); - unless(defined $enc){ - require Carp; - Carp::croak("Unknown encoding '$name'"); - } - my $string = $enc->decode($octets,$check); - $_[1] = $octets if $check and !($check & LEAVE_SRC()); - return $string; -} - -sub from_to($$$;$) -{ - my ($string,$from,$to,$check) = @_; - return undef unless defined $string; - $check ||=0; - my $f = find_encoding($from); - unless (defined $f){ - require Carp; - Carp::croak("Unknown encoding '$from'"); - } - my $t = find_encoding($to); - unless (defined $t){ - require Carp; - Carp::croak("Unknown encoding '$to'"); - } - my $uni = $f->decode($string,$check); - return undef if ($check && length($string)); - $string = $t->encode($uni,$check); - return undef if ($check && length($uni)); - return defined($_[0] = $string) ? length($string) : undef ; -} - -sub encode_utf8($) -{ - my ($str) = @_; - utf8::encode($str); - return $str; -} - -sub decode_utf8($;$) -{ - my ($str, $check) = @_; - if ($check){ - return decode("utf8", $str, $check); - }else{ - return decode("utf8", $str); - return $str; - } -} - -predefine_encodings(1); - -# -# This is to restore %Encoding if really needed; -# - -sub predefine_encodings{ - use Encode::Encoding; - no warnings 'redefine'; - my $use_xs = shift; - if ($ON_EBCDIC) { - # was in Encode::UTF_EBCDIC - package Encode::UTF_EBCDIC; - push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding'; - *decode = sub{ - my ($obj,$str,$chk) = @_; - my $res = ''; - for (my $i = 0; $i < length($str); $i++) { - $res .= - chr(utf8::unicode_to_native(ord(substr($str,$i,1)))); - } - $_[1] = '' if $chk; - return $res; - }; - *encode = sub{ - my ($obj,$str,$chk) = @_; - my $res = ''; - for (my $i = 0; $i < length($str); $i++) { - $res .= - chr(utf8::native_to_unicode(ord(substr($str,$i,1)))); - } - $_[1] = '' if $chk; - return $res; - }; - $Encode::Encoding{Unicode} = - bless {Name => "UTF_EBCDIC"} => "Encode::UTF_EBCDIC"; - } else { - package Encode::Internal; - push @Encode::Internal::ISA, 'Encode::Encoding'; - *decode = sub{ - my ($obj,$str,$chk) = @_; - utf8::upgrade($str); - $_[1] = '' if $chk; - return $str; - }; - *encode = \&decode; - $Encode::Encoding{Unicode} = - bless {Name => "Internal"} => "Encode::Internal"; - } - - { - # was in Encode::utf8 - package Encode::utf8; - push @Encode::utf8::ISA, 'Encode::Encoding'; - # - if ($use_xs){ - Encode::DEBUG and warn __PACKAGE__, " XS on"; - *decode = \&decode_xs; - *encode = \&encode_xs; - }else{ - Encode::DEBUG and warn __PACKAGE__, " XS off"; - *decode = sub{ - my ($obj,$octets,$chk) = @_; - my $str = Encode::decode_utf8($octets); - if (defined $str) { - $_[1] = '' if $chk; - return $str; - } - return undef; - }; - *encode = sub { - my ($obj,$string,$chk) = @_; - my $octets = Encode::encode_utf8($string); - $_[1] = '' if $chk; - return $octets; - }; - } - *cat_decode = sub{ # ($obj, $dst, $src, $pos, $trm, $chk) - my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk - my ($rdst, $rsrc, $rpos) = \@_[1,2,3]; - use bytes; - if ((my $npos = index($$rsrc, $trm, $pos)) >= 0) { - $$rdst .= substr($$rsrc, $pos, $npos - $pos + length($trm)); - $$rpos = $npos + length($trm); - return 1; - } - $$rdst .= substr($$rsrc, $pos); - $$rpos = length($$rsrc); - return ''; - }; - $Encode::Encoding{utf8} = - bless {Name => "utf8"} => "Encode::utf8"; - $Encode::Encoding{"utf-8-strict"} = - bless {Name => "utf-8-strict", strict_utf8 => 1 } => "Encode::utf8"; - } -} - -1; - -__END__ - -=head1 NAME - -Encode - character encodings - -=head1 SYNOPSIS - - use Encode; - -=head2 Table of Contents - -Encode consists of a collection of modules whose details are too big -to fit in one document. This POD itself explains the top-level APIs -and general topics at a glance. For other topics and more details, -see the PODs below: - - Name Description - -------------------------------------------------------- - Encode::Alias Alias definitions to encodings - Encode::Encoding Encode Implementation Base Class - Encode::Supported List of Supported Encodings - Encode::CN Simplified Chinese Encodings - Encode::JP Japanese Encodings - Encode::KR Korean Encodings - Encode::TW Traditional Chinese Encodings - -------------------------------------------------------- - -=head1 DESCRIPTION - -The C 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/installer/perllib/Encode/Alias.pm b/Master/tlpkg/installer/perllib/Encode/Alias.pm deleted file mode 100644 index c0bbf69f469..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Alias.pm +++ /dev/null @@ -1,341 +0,0 @@ -package Encode::Alias; -use strict; -no warnings 'redefine'; -use Encode; -our $VERSION = do { my @r = (q$Revision: 2.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; -sub DEBUG () { 0 } - -use base qw(Exporter); - -# Public, encouraged API is exported by default - -our @EXPORT = - qw ( - define_alias - find_alias - ); - -our @Alias; # ordered matching list -our %Alias; # cached known aliases - -sub find_alias{ - my $class = shift; - my $find = shift; - unless (exists $Alias{$find}) { - $Alias{$find} = undef; # Recursion guard - for (my $i=0; $i < @Alias; $i += 2){ - my $alias = $Alias[$i]; - my $val = $Alias[$i+1]; - my $new; - if (ref($alias) eq 'Regexp' && $find =~ $alias){ - DEBUG and warn "eval $val"; - $new = eval $val; - DEBUG and $@ and warn "$val, $@"; - }elsif (ref($alias) eq 'CODE'){ - DEBUG and warn "$alias", "->", "($find)"; - $new = $alias->($find); - }elsif (lc($find) eq lc($alias)){ - $new = $val; - } - if (defined($new)){ - next if $new eq $find; # avoid (direct) recursion on bugs - DEBUG and warn "$alias, $new"; - my $enc = (ref($new)) ? $new : Encode::find_encoding($new); - if ($enc){ - $Alias{$find} = $enc; - last; - } - } - } - # case insensitive search when canonical is not in all lowercase - # RT ticket #7835 - unless ($Alias{$find}){ - my $lcfind = lc($find); - for my $name (keys %Encode::Encoding, keys %Encode::ExtModule){ - $lcfind eq lc($name) or next; - $Alias{$find} = Encode::find_encoding($name); - DEBUG and warn "$find => $name"; - } - } - } - if (DEBUG){ - my $name; - if (my $e = $Alias{$find}){ - $name = $e->name; - }else{ - $name = ""; - } - warn "find_alias($class, $find)->name = $name"; - } - return $Alias{$find}; -} - -sub define_alias{ - while (@_){ - my ($alias,$name) = splice(@_,0,2); - unshift(@Alias, $alias => $name); # newer one has precedence - if (ref($alias)){ - # clear %Alias cache to allow overrides - my @a = keys %Alias; - for my $k (@a){ - if (ref($alias) eq 'Regexp' && $k =~ $alias){ - DEBUG and warn "delete \$Alias\{$k\}"; - delete $Alias{$k}; - } - elsif (ref($alias) eq 'CODE'){ - DEBUG and warn "delete \$Alias\{$k\}"; - delete $Alias{$alias->($name)}; - } - } - }else{ - DEBUG and warn "delete \$Alias\{$alias\}"; - delete $Alias{$alias}; - } - } -} - -# Allow latin-1 style names as well -# 0 1 2 3 4 5 6 7 8 9 10 -our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 ); -# Allow winlatin1 style names as well -our %Winlatin2cp = ( - 'latin1' => 1252, - 'latin2' => 1250, - 'cyrillic' => 1251, - 'greek' => 1253, - 'turkish' => 1254, - 'hebrew' => 1255, - 'arabic' => 1256, - 'baltic' => 1257, - 'vietnamese' => 1258, - ); - -init_aliases(); - -sub undef_aliases{ - @Alias = (); - %Alias = (); -} - -sub init_aliases -{ - undef_aliases(); - # Try all-lower-case version should all else fails - define_alias( qr/^(.*)$/ => '"\L$1"' ); - - # UTF/UCS stuff - define_alias( qr/^UTF-?7$/i => '"UTF-7"'); - define_alias( qr/^UCS-?2-?LE$/i => '"UCS-2LE"' ); - define_alias( qr/^UCS-?2-?(BE)?$/i => '"UCS-2BE"', - qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")', - qr/^iso-10646-1$/i => '"UCS-2BE"' ); - define_alias( qr/^UTF-?(16|32)-?BE$/i => '"UTF-$1BE"', - qr/^UTF-?(16|32)-?LE$/i => '"UTF-$1LE"', - qr/^UTF-?(16|32)$/i => '"UTF-$1"', - ); - # ASCII - define_alias(qr/^(?:US-?)ascii$/i => '"ascii"'); - define_alias('C' => 'ascii'); - define_alias(qr/\bISO[-_]?646[-_]?US$/i => '"ascii"'); - # Allow variants of iso-8859-1 etc. - define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' ); - - # At least HP-UX has these. - define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' ); - - # More HP stuff. - define_alias( qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i => '"${1}8"' ); - - # The Official name of ASCII. - define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' ); - - # This is a font issue, not an encoding issue. - # (The currency symbol of the Latin 1 upper half - # has been redefined as the euro symbol.) - define_alias( qr/^(.+)\@euro$/i => '"$1"' ); - - define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i - => 'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef' ); - - define_alias( qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish| - hebrew|arabic|baltic|vietnamese)$/ix => - '"cp" . $Encode::Alias::Winlatin2cp{lc($1)}' ); - - # Common names for non-latin preferred MIME names - define_alias( 'ascii' => 'US-ascii', - 'cyrillic' => 'iso-8859-5', - 'arabic' => 'iso-8859-6', - 'greek' => 'iso-8859-7', - 'hebrew' => 'iso-8859-8', - 'thai' => 'iso-8859-11', - 'tis620' => 'iso-8859-11', - ); - - # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN. - # And Microsoft has their own naming (again, surprisingly). - # And windows-* is registered in IANA! - define_alias( qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"'); - - # Sometimes seen with a leading zero. - # define_alias( qr/\bcp037\b/i => '"cp37"'); - - # Mac Mappings - # predefined in *.ucm; unneeded - # define_alias( qr/\bmacIcelandic$/i => '"macIceland"'); - define_alias( qr/^mac_(.*)$/i => '"mac$1"'); - # Ououououou. gone. They are differente! - # define_alias( qr/\bmacRomanian$/i => '"macRumanian"'); - - # Standardize on the dashed versions. - define_alias( qr/\bkoi8[\s\-_]*([ru])$/i => '"koi8-$1"' ); - - unless ($Encode::ON_EBCDIC){ - # for Encode::CN - define_alias( qr/\beuc.*cn$/i => '"euc-cn"' ); - define_alias( qr/\bcn.*euc$/i => '"euc-cn"' ); - # define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' ) - # CP936 doesn't have vendor-addon for GBK, so they're identical. - define_alias( qr/^gbk$/i => '"cp936"'); - # This fixes gb2312 vs. euc-cn confusion, practically - define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' ); - # for Encode::JP - define_alias( qr/\bjis$/i => '"7bit-jis"' ); - define_alias( qr/\beuc.*jp$/i => '"euc-jp"' ); - define_alias( qr/\bjp.*euc$/i => '"euc-jp"' ); - define_alias( qr/\bujis$/i => '"euc-jp"' ); - define_alias( qr/\bshift.*jis$/i => '"shiftjis"' ); - define_alias( qr/\bsjis$/i => '"shiftjis"' ); - define_alias( qr/\bwindows-31j$/i => '"cp932"' ); - # for Encode::KR - define_alias( qr/\beuc.*kr$/i => '"euc-kr"' ); - define_alias( qr/\bkr.*euc$/i => '"euc-kr"' ); - # This fixes ksc5601 vs. euc-kr confusion, practically - define_alias( qr/(?:x-)?uhc$/i => '"cp949"' ); - define_alias( qr/(?:x-)?windows-949$/i => '"cp949"' ); - define_alias( qr/\bks_c_5601-1987$/i => '"cp949"' ); - # for Encode::TW - define_alias( qr/\bbig-?5$/i => '"big5-eten"' ); - define_alias( qr/\bbig5-?et(?:en)?$/i => '"big5-eten"' ); - define_alias( qr/\btca[-_]?big5$/i => '"big5-eten"' ); - define_alias( qr/\bbig5-?hk(?:scs)?$/i => '"big5-hkscs"' ); - define_alias( qr/\bhk(?:scs)?[-_]?big5$/i => '"big5-hkscs"' ); - } - # utf8 is blessed :) - define_alias( qr/^UTF-8$/i => '"utf-8-strict"'); - # At last, Map white space and _ to '-' - define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' ); -} - -1; -__END__ - -# TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8 -# TODO: HP-UX '15' encodings japanese15 korean15 roi15 -# TODO: Cyrillic encoding ISO-IR-111 (useful?) -# TODO: Armenian encoding ARMSCII-8 -# TODO: Hebrew encoding ISO-8859-8-1 -# TODO: Thai encoding TCVN -# TODO: Vietnamese encodings VPS -# TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese -# ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic -# Farsi Georgian Gujarati Gurmukhi Hebrew Japanese -# Kannada Khmer Korean Laotian Malayalam Mongolian -# Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese - -=head1 NAME - -Encode::Alias - alias definitions to encodings - -=head1 SYNOPSIS - - use Encode; - use Encode::Alias; - define_alias( newName => ENCODING); - -=head1 DESCRIPTION - -Allows newName to be used as an alias for ENCODING. ENCODING may be -either the name of an encoding or an encoding object (as described -in L). - -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/installer/perllib/Encode/Byte.pm b/Master/tlpkg/installer/perllib/Encode/Byte.pm deleted file mode 100644 index d40c1c3d9d1..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Byte.pm +++ /dev/null @@ -1,119 +0,0 @@ -package Encode::Byte; -use Encode; -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -1; -__END__ - -=head1 NAME - -Encode::Byte - Single Byte Encodings - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $greek = encode("iso-8859-7", $utf8); # loads Encode::Byte implicitly - $utf8 = decode("iso-8859-7", $greek); # ditto - -=head1 ABSTRACT - -This module implements various single byte encodings. For most cases it uses -\x80-\xff (upper half) to map non-ASCII characters. Encodings -supported are as follows. - - Canonical Alias Description - -------------------------------------------------------------------- - # ISO 8859 series - (iso-8859-1 is in built-in) - iso-8859-2 latin2 [ISO] - iso-8859-3 latin3 [ISO] - iso-8859-4 latin4 [ISO] - iso-8859-5 [ISO] - iso-8859-6 [ISO] - iso-8859-7 [ISO] - iso-8859-8 [ISO] - iso-8859-9 latin5 [ISO] - iso-8859-10 latin6 [ISO] - iso-8859-11 - (iso-8859-12 is nonexistent) - iso-8859-13 latin7 [ISO] - iso-8859-14 latin8 [ISO] - iso-8859-15 latin9 [ISO] - iso-8859-16 latin10 [ISO] - - # Cyrillic - koi8-f - koi8-r cp878 [RFC1489] - koi8-u [RFC2319] - - # Vietnamese - viscii - - # all cp* are also available as ibm-*, ms-*, and windows-* - # also see L - - 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/installer/perllib/Encode/CJKConstants.pm b/Master/tlpkg/installer/perllib/Encode/CJKConstants.pm deleted file mode 100644 index 4ab40e72ef2..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/CJKConstants.pm +++ /dev/null @@ -1,66 +0,0 @@ -# -# $Id: CJKConstants.pm,v 2.0 2004/05/16 20:55:16 dankogai Exp $ -# - -package Encode::CJKConstants; - -use strict; - -our $RCSID = q$Id: CJKConstants.pm,v 2.0 2004/05/16 20:55:16 dankogai Exp $; -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Carp; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT = qw(); -our @EXPORT_OK = qw(%CHARCODE %ESC %RE); -our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK, @EXPORT ] ); - -my %_0208 = ( - 1978 => '\e\$\@', - 1983 => '\e\$B', - 1990 => '\e&\@\e\$B', - ); - -our %CHARCODE = ( - UNDEF_EUC => "\xa2\xae", # ¢® in EUC - UNDEF_SJIS => "\x81\xac", # ¢® in SJIS - UNDEF_JIS => "\xa2\xf7", # ¢÷ -- used in unicode - UNDEF_UNICODE => "\x20\x20", # ¢÷ -- used in unicode - ); - -our %ESC = ( - GB_2312 => "\e\$A", - JIS_0208 => "\e\$B", - JIS_0212 => "\e\$(D", - KSC_5601 => "\e\$(C", - ASC => "\e\(B", - KANA => "\e\(I", - '2022_KR' => "\e\$)C", - ); - -our %RE = - ( - ASCII => '[\x00-\x7f]', - BIN => '[\x00-\x06\x7f\xff]', - EUC_0212 => '\x8f[\xa1-\xfe][\xa1-\xfe]', - EUC_C => '[\xa1-\xfe][\xa1-\xfe]', - EUC_KANA => '\x8e[\xa1-\xdf]', - JIS_0208 => "$_0208{1978}|$_0208{1983}|$_0208{1990}", - JIS_0212 => "\e" . '\$\(D', - ISO_ASC => "\e" . '\([BJ]', - JIS_KANA => "\e" . '\(I', - '2022_KR' => "\e" . '\$\)C', - SJIS_C => '[\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc]', - SJIS_KANA => '[\xa1-\xdf]', - UTF8 => '[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf][\x80-\xbf]' - ); - -1; - -=head1 NAME - -Encode::CJKConstants.pm -- Internally used by Encode::??::ISO_2022_* - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/CN.pm b/Master/tlpkg/installer/perllib/Encode/CN.pm deleted file mode 100644 index be5a830fc51..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/CN.pm +++ /dev/null @@ -1,76 +0,0 @@ -package Encode::CN; -BEGIN { - if (ord("A") == 193) { - die "Encode::CN not supported on EBCDIC\n"; - } -} -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Encode; -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -# Relocated from Encode.pm - -use Encode::CN::HZ; -# use Encode::CN::2022_CN; - -1; -__END__ - -=head1 NAME - -Encode::CN - China-based Chinese Encodings - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $euc_cn = encode("euc-cn", $utf8); # loads Encode::CN implicitly - $utf8 = decode("euc-cn", $euc_cn); # ditto - -=head1 DESCRIPTION - -This module implements China-based Chinese charset encodings. -Encodings supported are as follows. - - Canonical Alias Description - -------------------------------------------------------------------- - euc-cn /\beuc.*cn$/i EUC (Extended Unix Character) - /\bcn.*euc$/i - /\bGB[-_ ]?2312(?:\D.*$|$)/i (see below) - gb2312-raw The raw (low-bit) GB2312 character map - gb12345-raw Traditional chinese counterpart to - GB2312 (raw) - iso-ir-165 GB2312 + GB6345 + GB8565 + additions - MacChineseSimp GB2312 + Apple Additions - cp936 Code Page 936, also known as GBK - (Extended GuoBiao) - hz 7-bit escaped GB2312 encoding - -------------------------------------------------------------------- - -To find how to use this module in detail, see L. - -=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/installer/perllib/Encode/CN/HZ.pm b/Master/tlpkg/installer/perllib/Encode/CN/HZ.pm deleted file mode 100644 index fbc6ba60ced..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/CN/HZ.pm +++ /dev/null @@ -1,196 +0,0 @@ -package Encode::CN::HZ; - -use strict; - -use vars qw($VERSION); -$VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Encode qw(:fallbacks); - -use base qw(Encode::Encoding); -__PACKAGE__->Define('hz'); - -# HZ is a combination of ASCII and escaped GB, so we implement it -# with the GB2312(raw) encoding here. Cf. RFCs 1842 & 1843. - -# not ported for EBCDIC. Which should be used, "~" or "\x7E"? - -sub needs_lines { 1 } - -sub decode ($$;$) -{ - my ($obj,$str,$chk) = @_; - - my $GB = Encode::find_encoding('gb2312-raw'); - my $ret = ''; - my $in_ascii = 1; # default mode is ASCII. - - while (length $str) { - if ($in_ascii) { # ASCII mode - if ($str =~ s/^([\x00-\x7D\x7F]+)//) { # no '~' => ASCII - $ret .= $1; - # EBCDIC should need ascii2native, but not ported. - } - elsif ($str =~ s/^\x7E\x7E//) { # escaped tilde - $ret .= '~'; - } - elsif ($str =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII - 1; # no-op - } - elsif ($str =~ s/^\x7E\x7B//) { # '~{' - $in_ascii = 0; # to GB - } - else { # encounters an invalid escape, \x80 or greater - last; - } - } - else { # GB mode; the byte ranges are as in RFC 1843. - if ($str =~ s/^((?:[\x21-\x77][\x21-\x7E])+)//) { - $ret .= $GB->decode($1, $chk); - } - elsif ($str =~ s/^\x7E\x7D//) { # '~}' - $in_ascii = 1; - } - else { # invalid - last; - } - } - } - $_[1] = '' if $chk; # needs_lines guarantees no partial character - return $ret; -} - -sub cat_decode { - my ($obj, undef, $src, $pos, $trm, $chk) = @_; - my ($rdst, $rsrc, $rpos) = \@_[1..3]; - - my $GB = Encode::find_encoding('gb2312-raw'); - my $ret = ''; - my $in_ascii = 1; # default mode is ASCII. - - my $ini_pos = pos($$rsrc); - - substr($src, 0, $pos) = ''; - - my $ini_len = bytes::length($src); - - # $trm is the first of the pair '~~', then 2nd tilde is to be removed. - # XXX: Is better C<$src =~ s/^\x7E// or die if ...>? - $src =~ s/^\x7E// if $trm eq "\x7E"; - - while (length $src) { - my $now; - if ($in_ascii) { # ASCII mode - if ($src =~ s/^([\x00-\x7D\x7F])//) { # no '~' => ASCII - $now = $1; - } - elsif ($src =~ s/^\x7E\x7E//) { # escaped tilde - $now = '~'; - } - elsif ($src =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII - next; - } - elsif ($src =~ s/^\x7E\x7B//) { # '~{' - $in_ascii = 0; # to GB - next; - } - else { # encounters an invalid escape, \x80 or greater - last; - } - } - else { # GB mode; the byte ranges are as in RFC 1843. - if ($src =~ s/^((?:[\x21-\x77][\x21-\x7F])+)//) { - $now = $GB->decode($1, $chk); - } - elsif ($src =~ s/^\x7E\x7D//) { # '~}' - $in_ascii = 1; - next; - } - else { # invalid - last; - } - } - - next if ! defined $now; - - $ret .= $now; - - if ($now eq $trm) { - $$rdst .= $ret; - $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src); - pos($$rsrc) = $ini_pos; - return 1; - } - } - - $$rdst .= $ret; - $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src); - pos($$rsrc) = $ini_pos; - return ''; # terminator not found -} - - -sub encode($$;$) -{ - my ($obj,$str,$chk) = @_; - - my $GB = Encode::find_encoding('gb2312-raw'); - my $ret = ''; - my $in_ascii = 1; # default mode is ASCII. - - no warnings 'utf8'; # $str may be malformed UTF8 at the end of a chunk. - - while (length $str) { - if ($str =~ s/^([[:ascii:]]+)//) { - my $tmp = $1; - $tmp =~ s/~/~~/g; # escapes tildes - if (! $in_ascii) { - $ret .= "\x7E\x7D"; # '~}' - $in_ascii = 1; - } - $ret .= pack 'a*', $tmp; # remove UTF8 flag. - } - elsif ($str =~ s/(.)//) { - my $s = $1; - my $tmp = $GB->encode($s, $chk); - last if !defined $tmp; - if (length $tmp == 2) { # maybe a valid GB char (XXX) - if ($in_ascii) { - $ret .= "\x7E\x7B"; # '~{' - $in_ascii = 0; - } - $ret .= $tmp; - } - elsif (length $tmp) { # maybe FALLBACK in ASCII (XXX) - if (!$in_ascii) { - $ret .= "\x7E\x7D"; # '~}' - $in_ascii = 1; - } - $ret .= $tmp; - } - } - else { # if $str is malformed UTF8 *and* if length $str != 0. - last; - } - } - $_[1] = $str if $chk; - - # The state at the end of the chunk is discarded, even if in GB mode. - # That results in the combination of GB-OUT and GB-IN, i.e. "~}~{". - # Parhaps it is harmless, but further investigations may be required... - - if (! $in_ascii) { - $ret .= "\x7E\x7D"; # '~}' - $in_ascii = 1; - } - return $ret; -} - -1; -__END__ - -=head1 NAME - -Encode::CN::HZ -- internally used by Encode::CN - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Changes.e2x b/Master/tlpkg/installer/perllib/Encode/Changes.e2x deleted file mode 100644 index 5c67c55cb93..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Changes.e2x +++ /dev/null @@ -1,7 +0,0 @@ -# -# $Id: Changes.e2x,v 2.0 2004/05/16 20:55:15 dankogai Exp $ -# Revision history for Perl extension Encode::$_Name_. -# - -0.01 $_Now_ - Autogenerated by enc2xs version $_Version_. diff --git a/Master/tlpkg/installer/perllib/Encode/Config.pm b/Master/tlpkg/installer/perllib/Encode/Config.pm deleted file mode 100644 index d69b92d8248..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Config.pm +++ /dev/null @@ -1,166 +0,0 @@ -# -# Demand-load module list -# -package Encode::Config; -our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use strict; - -our %ExtModule = - ( - # Encode::Byte - #iso-8859-1 is in Encode.pm itself - 'iso-8859-2' => 'Encode::Byte', - 'iso-8859-3' => 'Encode::Byte', - 'iso-8859-4' => 'Encode::Byte', - 'iso-8859-5' => 'Encode::Byte', - 'iso-8859-6' => 'Encode::Byte', - 'iso-8859-7' => 'Encode::Byte', - 'iso-8859-8' => 'Encode::Byte', - 'iso-8859-9' => 'Encode::Byte', - 'iso-8859-10' => 'Encode::Byte', - 'iso-8859-11' => 'Encode::Byte', - 'iso-8859-13' => 'Encode::Byte', - 'iso-8859-14' => 'Encode::Byte', - 'iso-8859-15' => 'Encode::Byte', - 'iso-8859-16' => 'Encode::Byte', - 'koi8-f' => 'Encode::Byte', - 'koi8-r' => 'Encode::Byte', - 'koi8-u' => 'Encode::Byte', - 'viscii' => 'Encode::Byte', - 'cp424' => 'Encode::Byte', - 'cp437' => 'Encode::Byte', - 'cp737' => 'Encode::Byte', - 'cp775' => 'Encode::Byte', - 'cp850' => 'Encode::Byte', - 'cp852' => 'Encode::Byte', - 'cp855' => 'Encode::Byte', - 'cp856' => 'Encode::Byte', - 'cp857' => 'Encode::Byte', - 'cp860' => 'Encode::Byte', - 'cp861' => 'Encode::Byte', - 'cp862' => 'Encode::Byte', - 'cp863' => 'Encode::Byte', - 'cp864' => 'Encode::Byte', - 'cp865' => 'Encode::Byte', - 'cp866' => 'Encode::Byte', - 'cp869' => 'Encode::Byte', - 'cp874' => 'Encode::Byte', - 'cp1006' => 'Encode::Byte', - 'cp1250' => 'Encode::Byte', - 'cp1251' => 'Encode::Byte', - 'cp1252' => 'Encode::Byte', - 'cp1253' => 'Encode::Byte', - 'cp1254' => 'Encode::Byte', - 'cp1255' => 'Encode::Byte', - 'cp1256' => 'Encode::Byte', - 'cp1257' => 'Encode::Byte', - 'cp1258' => 'Encode::Byte', - 'AdobeStandardEncoding' => 'Encode::Byte', - 'MacArabic' => 'Encode::Byte', - 'MacCentralEurRoman' => 'Encode::Byte', - 'MacCroatian' => 'Encode::Byte', - 'MacCyrillic' => 'Encode::Byte', - 'MacFarsi' => 'Encode::Byte', - 'MacGreek' => 'Encode::Byte', - 'MacHebrew' => 'Encode::Byte', - 'MacIcelandic' => 'Encode::Byte', - 'MacRoman' => 'Encode::Byte', - 'MacRomanian' => 'Encode::Byte', - 'MacRumanian' => 'Encode::Byte', - 'MacSami' => 'Encode::Byte', - 'MacThai' => 'Encode::Byte', - 'MacTurkish' => 'Encode::Byte', - 'MacUkrainian' => 'Encode::Byte', - 'nextstep' => 'Encode::Byte', - 'hp-roman8' => 'Encode::Byte', - 'gsm0338' => 'Encode::Byte', - # Encode::EBCDIC - 'cp37' => 'Encode::EBCDIC', - 'cp500' => 'Encode::EBCDIC', - 'cp875' => 'Encode::EBCDIC', - 'cp1026' => 'Encode::EBCDIC', - 'cp1047' => 'Encode::EBCDIC', - 'posix-bc' => 'Encode::EBCDIC', - # Encode::Symbol - 'dingbats' => 'Encode::Symbol', - 'symbol' => 'Encode::Symbol', - 'AdobeSymbol' => 'Encode::Symbol', - 'AdobeZdingbat' => 'Encode::Symbol', - 'MacDingbats' => 'Encode::Symbol', - 'MacSymbol' => 'Encode::Symbol', - # Encode::Unicode - 'UCS-2BE' => 'Encode::Unicode', - 'UCS-2LE' => 'Encode::Unicode', - 'UTF-16' => 'Encode::Unicode', - 'UTF-16BE' => 'Encode::Unicode', - 'UTF-16LE' => 'Encode::Unicode', - 'UTF-32' => 'Encode::Unicode', - 'UTF-32BE' => 'Encode::Unicode', - 'UTF-32LE' => 'Encode::Unicode', - 'UTF-7' => 'Encode::Unicode::UTF7', - ); - -unless (ord("A") == 193){ - %ExtModule = - ( - %ExtModule, - 'euc-cn' => 'Encode::CN', - 'gb12345-raw' => 'Encode::CN', - 'gb2312-raw' => 'Encode::CN', - 'hz' => 'Encode::CN', - 'iso-ir-165' => 'Encode::CN', - 'cp936' => 'Encode::CN', - 'MacChineseSimp' => 'Encode::CN', - - '7bit-jis' => 'Encode::JP', - 'euc-jp' => 'Encode::JP', - 'iso-2022-jp' => 'Encode::JP', - 'iso-2022-jp-1' => 'Encode::JP', - 'jis0201-raw' => 'Encode::JP', - 'jis0208-raw' => 'Encode::JP', - 'jis0212-raw' => 'Encode::JP', - 'cp932' => 'Encode::JP', - 'MacJapanese' => 'Encode::JP', - 'shiftjis' => 'Encode::JP', - - - 'euc-kr' => 'Encode::KR', - 'iso-2022-kr' => 'Encode::KR', - 'johab' => 'Encode::KR', - 'ksc5601-raw' => 'Encode::KR', - 'cp949' => 'Encode::KR', - 'MacKorean' => 'Encode::KR', - - 'big5-eten' => 'Encode::TW', - 'big5-hkscs' => 'Encode::TW', - 'cp950' => 'Encode::TW', - 'MacChineseTrad' => 'Encode::TW', - - #'big5plus' => 'Encode::HanExtra', - #'euc-tw' => 'Encode::HanExtra', - #'gb18030' => 'Encode::HanExtra', - - 'MIME-Header' => 'Encode::MIME::Header', - 'MIME-B' => 'Encode::MIME::Header', - 'MIME-Q' => 'Encode::MIME::Header', - - 'MIME-Header-ISO_2022_JP' => 'Encode::MIME::Header::ISO_2022_JP', - ); -} - -# -# Why not export ? to keep ConfigLocal Happy! -# -while (my ($enc,$mod) = each %ExtModule){ - $Encode::ExtModule{$enc} = $mod; -} - -1; -__END__ - -=head1 NAME - -Encode::Config -- internally used by Encode - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x b/Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x deleted file mode 100644 index e203dfded50..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x +++ /dev/null @@ -1,13 +0,0 @@ -# -# Local demand-load module list -# -# You should not edit this file by hand! use "enc2xs -C" -# -package Encode::ConfigLocal; -our $VERSION = $_LocalVer_; - -use strict; - -$_ModLines_ - -1; diff --git a/Master/tlpkg/installer/perllib/Encode/EBCDIC.pm b/Master/tlpkg/installer/perllib/Encode/EBCDIC.pm deleted file mode 100644 index 200a82fea46..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/EBCDIC.pm +++ /dev/null @@ -1,43 +0,0 @@ -package Encode::EBCDIC; -use Encode; -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -1; -__END__ - -=head1 NAME - -Encode::EBCDIC - EBCDIC Encodings - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $posix_bc = encode("posix-bc", $utf8); # loads Encode::EBCDIC implicitly - $utf8 = decode("", $posix_bc); # ditto - -=head1 ABSTRACT - -This module implements various EBCDIC-Based encodings. Encodings -supported are as follows. - - Canonical Alias Description - -------------------------------------------------------------------- - cp37 - cp500 - cp875 - cp1026 - cp1047 - posix-bc - -=head1 DESCRIPTION - -To find how to use this module in detail, see L. - -=head1 SEE ALSO - -L, L - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Encoder.pm b/Master/tlpkg/installer/perllib/Encode/Encoder.pm deleted file mode 100644 index fe2a2b90ff6..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Encoder.pm +++ /dev/null @@ -1,249 +0,0 @@ -# -# $Id: Encoder.pm,v 2.0 2004/05/16 20:55:17 dankogai Exp $ -# -package Encode::Encoder; -use strict; -use warnings; -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw ( encoder ); - -our $AUTOLOAD; -sub DEBUG () { 0 } -use Encode qw(encode decode find_encoding from_to); -use Carp; - -sub new{ - my ($class, $data, $encname) = @_; - unless($encname){ - $encname = Encode::is_utf8($data) ? 'utf8' : ''; - }else{ - my $obj = find_encoding($encname) - or croak __PACKAGE__, ": unknown encoding: $encname"; - $encname = $obj->name; - } - my $self = { - data => $data, - encoding => $encname, - }; - bless $self => $class; -} - -sub encoder{ __PACKAGE__->new(@_) } - -sub data{ - my ($self, $data) = @_; - if (defined $data){ - $self->{data} = $data; - return $data; - }else{ - return $self->{data}; - } -} - -sub encoding{ - my ($self, $encname) = @_; - if ($encname){ - my $obj = find_encoding($encname) - or confess __PACKAGE__, ": unknown encoding: $encname"; - $self->{encoding} = $obj->name; - return $self; - }else{ - return $self->{encoding} - } -} - -sub bytes { - my ($self, $encname) = @_; - $encname ||= $self->{encoding}; - my $obj = find_encoding($encname) - or confess __PACKAGE__, ": unknown encoding: $encname"; - $self->{data} = $obj->decode($self->{data}, 1); - $self->{encoding} = '' ; - return $self; -} - -sub DESTROY{ # defined so it won't autoload. - DEBUG and warn shift; -} - -sub AUTOLOAD { - my $self = shift; - my $type = ref($self) - or confess "$self is not an object"; - my $myname = $AUTOLOAD; - $myname =~ s/.*://; # strip fully-qualified portion - my $obj = find_encoding($myname) - or confess __PACKAGE__, ": unknown encoding: $myname"; - DEBUG and warn $self->{encoding}, " => ", $obj->name; - if ($self->{encoding}){ - from_to($self->{data}, $self->{encoding}, $obj->name, 1); - }else{ - $self->{data} = $obj->encode($self->{data}, 1); - } - $self->{encoding} = $obj->name; - return $self; -} - -use overload - q("") => sub { $_[0]->{data} }, - q(0+) => sub { use bytes (); bytes::length($_[0]->{data}) }, - fallback => 1, - ; - -1; -__END__ - -=head1 NAME - -Encode::Encoder -- Object Oriented Encoder - -=head1 SYNOPSIS - - use Encode::Encoder; - # Encode::encode("ISO-8859-1", $data); - Encode::Encoder->new($data)->iso_8859_1; # OOP way - # shortcut - use Encode::Encoder qw(encoder); - encoder($data)->iso_8859_1; - # you can stack them! - encoder($data)->iso_8859_1->base64; # provided base64() is defined - # you can use it as a decoder as well - encoder($base64)->bytes('base64')->latin1; - # stringified - print encoder($data)->utf8->latin1; # prints the string in latin1 - # numified - encoder("\x{abcd}\x{ef}g")->utf8 == 6; # true. bytes::length($data) - -=head1 ABSTRACT - -B 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/installer/perllib/Encode/Encoding.pm b/Master/tlpkg/installer/perllib/Encode/Encoding.pm deleted file mode 100644 index 06af9fb6994..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Encoding.pm +++ /dev/null @@ -1,341 +0,0 @@ -package Encode::Encoding; -# Base class for classes which implement encodings -use strict; -our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -require Encode; - -sub DEBUG { 0 } -sub Define -{ - my $obj = shift; - my $canonical = shift; - $obj = bless { Name => $canonical },$obj unless ref $obj; - # warn "$canonical => $obj\n"; - Encode::define_encoding($obj, $canonical, @_); -} - -sub name { return shift->{'Name'} } - -# sub renew { return $_[0] } - -sub renew { - my $self = shift; - my $clone = bless { %$self } => ref($self); - $clone->{renewed}++; # so the caller can see it - DEBUG and warn $clone->{renewed}; - return $clone; -} - -sub renewed{ return $_[0]->{renewed} || 0 } - -*new_sequence = \&renew; - -sub needs_lines { 0 }; - -sub perlio_ok { - eval{ require PerlIO::encoding }; - return $@ ? 0 : 1; -} - -# (Temporary|legacy) methods - -sub toUnicode { shift->decode(@_) } -sub fromUnicode { shift->encode(@_) } - -# -# Needs to be overloaded or just croak -# - -sub encode { - require Carp; - my $obj = shift; - my $class = ref($obj) ? ref($obj) : $obj; - Carp::croak($class . "->encode() not defined!"); -} - -sub decode{ - require Carp; - my $obj = shift; - my $class = ref($obj) ? ref($obj) : $obj; - Carp::croak($class . "->encode() not defined!"); -} - -sub DESTROY {} - -1; -__END__ - -=head1 NAME - -Encode::Encoding - Encode Implementation Base Class - -=head1 SYNOPSIS - - package Encode::MyEncoding; - use base qw(Encode::Encoding); - - __PACKAGE__->Define(qw(myCanonical myAlias)); - -=head1 DESCRIPTION - -As mentioned in L, 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/installer/perllib/Encode/Guess.pm b/Master/tlpkg/installer/perllib/Encode/Guess.pm deleted file mode 100644 index 5692cee9a4a..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Guess.pm +++ /dev/null @@ -1,351 +0,0 @@ -package Encode::Guess; -use strict; - -use Encode qw(:fallbacks find_encoding); -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -my $Canon = 'Guess'; -sub DEBUG () { 0 } -our %DEF_SUSPECTS = map { $_ => find_encoding($_) } qw(ascii utf8); -$Encode::Encoding{$Canon} = - bless { - Name => $Canon, - Suspects => { %DEF_SUSPECTS }, - } => __PACKAGE__; - -use base qw(Encode::Encoding); -sub needs_lines { 1 } -sub perlio_ok { 0 } - -our @EXPORT = qw(guess_encoding); -our $NoUTFAutoGuess = 0; -our $UTF8_BOM = pack("C3", 0xef, 0xbb, 0xbf); - -sub import { # Exporter not used so we do it on our own - my $callpkg = caller; - for my $item (@EXPORT){ - no strict 'refs'; - *{"$callpkg\::$item"} = \&{"$item"}; - } - set_suspects(@_); -} - -sub set_suspects{ - my $class = shift; - my $self = ref($class) ? $class : $Encode::Encoding{$Canon}; - $self->{Suspects} = { %DEF_SUSPECTS }; - $self->add_suspects(@_); -} - -sub add_suspects{ - my $class = shift; - my $self = ref($class) ? $class : $Encode::Encoding{$Canon}; - for my $c (@_){ - my $e = find_encoding($c) or die "Unknown encoding: $c"; - $self->{Suspects}{$e->name} = $e; - DEBUG and warn "Added: ", $e->name; - } -} - -sub decode($$;$){ - my ($obj, $octet, $chk) = @_; - my $guessed = guess($obj, $octet); - unless (ref($guessed)){ - require Carp; - Carp::croak($guessed); - } - my $utf8 = $guessed->decode($octet, $chk); - $_[1] = $octet if $chk; - return $utf8; -} - -sub guess_encoding{ - guess($Encode::Encoding{$Canon}, @_); -} - -sub guess { - my $class = shift; - my $obj = ref($class) ? $class : $Encode::Encoding{$Canon}; - my $octet = shift; - - # sanity check - return unless defined $octet and length $octet; - - # cheat 0: utf8 flag; - if ( Encode::is_utf8($octet) ) { - return find_encoding('utf8') unless $NoUTFAutoGuess; - Encode::_utf8_off($octet); - } - # cheat 1: BOM - use Encode::Unicode; - unless ($NoUTFAutoGuess) { - my $BOM = pack('C3', unpack("C3", $octet)); - return find_encoding('utf8') - if (defined $BOM and $BOM eq $UTF8_BOM); - $BOM = unpack('N', $octet); - return find_encoding('UTF-32') - if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe0000)); - $BOM = unpack('n', $octet); - return find_encoding('UTF-16') - if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe)); - if ($octet =~ /\x00/o){ # if \x00 found, we assume UTF-(16|32)(BE|LE) - my $utf; - my ($be, $le) = (0, 0); - if ($octet =~ /\x00\x00/o){ # UTF-32(BE|LE) assumed - $utf = "UTF-32"; - for my $char (unpack('N*', $octet)){ - $char & 0x0000ffff and $be++; - $char & 0xffff0000 and $le++; - } - }else{ # UTF-16(BE|LE) assumed - $utf = "UTF-16"; - for my $char (unpack('n*', $octet)){ - $char & 0x00ff and $be++; - $char & 0xff00 and $le++; - } - } - DEBUG and warn "$utf, be == $be, le == $le"; - $be == $le - and return - "Encodings ambiguous between $utf BE and LE ($be, $le)"; - $utf .= ($be > $le) ? 'BE' : 'LE'; - return find_encoding($utf); - } - } - my %try = %{$obj->{Suspects}}; - for my $c (@_){ - my $e = find_encoding($c) or die "Unknown encoding: $c"; - $try{$e->name} = $e; - DEBUG and warn "Added: ", $e->name; - } - my $nline = 1; - for my $line (split /\r\n?|\n/, $octet){ - # cheat 2 -- \e in the string - if ($line =~ /\e/o){ - my @keys = keys %try; - delete @try{qw/utf8 ascii/}; - for my $k (@keys){ - ref($try{$k}) eq 'Encode::XS' and delete $try{$k}; - } - } - my %ok = %try; - # warn join(",", keys %try); - for my $k (keys %try){ - my $scratch = $line; - $try{$k}->decode($scratch, FB_QUIET); - if ($scratch eq ''){ - DEBUG and warn sprintf("%4d:%-24s ok\n", $nline, $k); - }else{ - use bytes (); - DEBUG and - warn sprintf("%4d:%-24s not ok; %d bytes left\n", - $nline, $k, bytes::length($scratch)); - delete $ok{$k}; - } - } - %ok or return "No appropriate encodings found!"; - if (scalar(keys(%ok)) == 1){ - my ($retval) = values(%ok); - return $retval; - } - %try = %ok; $nline++; - } - $try{ascii} or - return "Encodings too ambiguous: ", join(" or ", keys %try); - return $try{ascii}; -} - - - -1; -__END__ - -=head1 NAME - -Encode::Guess -- Guesses encoding from data - -=head1 SYNOPSIS - - # if you are sure $data won't contain anything bogus - - use Encode; - use Encode::Guess qw/euc-jp shiftjis 7bit-jis/; - my $utf8 = decode("Guess", $data); - my $data = encode("Guess", $utf8); # this doesn't work! - - # more elaborate way - use Encode::Guess; - my $enc = guess_encoding($data, qw/euc-jp shiftjis 7bit-jis/); - ref($enc) or die "Can't guess: $enc"; # trap error this way - $utf8 = $enc->decode($data); - # or - $utf8 = decode($enc->name, $data) - -=head1 ABSTRACT - -Encode::Guess enables you to guess in what encoding a given data is -encoded, or at least tries to. - -=head1 DESCRIPTION - -By default, it checks only ascii, utf8 and UTF-16/32 with BOM. - - use Encode::Guess; # ascii/utf8/BOMed UTF - -To use it more practically, you have to give the names of encodings to -check (I 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/installer/perllib/Encode/JP.pm b/Master/tlpkg/installer/perllib/Encode/JP.pm deleted file mode 100644 index 01ad37f30db..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/JP.pm +++ /dev/null @@ -1,97 +0,0 @@ -package Encode::JP; -BEGIN { - if (ord("A") == 193) { - die "Encode::JP not supported on EBCDIC\n"; - } -} -use Encode; -our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -use Encode::JP::JIS7; - -1; -__END__ - -=head1 NAME - -Encode::JP - Japanese Encodings - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $euc_jp = encode("euc-jp", $utf8); # loads Encode::JP implicitly - $utf8 = decode("euc-jp", $euc_jp); # ditto - -=head1 ABSTRACT - -This module implements Japanese charset encodings. Encodings -supported are as follows. - - Canonical Alias Description - -------------------------------------------------------------------- - euc-jp /\beuc.*jp$/i EUC (Extended Unix Character) - /\bjp.*euc/i - /\bujis$/i - shiftjis /\bshift.*jis$/i Shift JIS (aka MS Kanji) - /\bsjis$/i - 7bit-jis /\bjis$/i 7bit JIS - iso-2022-jp ISO-2022-JP [RFC1468] - = 7bit JIS with all Halfwidth Kana - converted to Fullwidth - iso-2022-jp-1 ISO-2022-JP-1 [RFC2237] - = ISO-2022-JP with JIS X 0212-1990 - support. See below - MacJapanese Shift JIS + Apple vendor mappings - cp932 /\bwindows-31j$/i Code Page 932 - = Shift JIS + MS/IBM vendor mappings - jis0201-raw JIS0201, raw format - jis0208-raw JIS0201, raw format - jis0212-raw JIS0201, raw format - -------------------------------------------------------------------- - -=head1 DESCRIPTION - -To find out how to use this module in detail, see L. - -=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/installer/perllib/Encode/JP/H2Z.pm b/Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm deleted file mode 100644 index 0c84c62fda6..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm +++ /dev/null @@ -1,174 +0,0 @@ -# -# $Id: H2Z.pm,v 2.0 2004/05/16 20:55:17 dankogai Exp $ -# - -package Encode::JP::H2Z; - -use strict; - -our $RCSID = q$Id: H2Z.pm,v 2.0 2004/05/16 20:55:17 dankogai Exp $; -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Encode::CJKConstants qw(:all); - -use vars qw(%_D2Z $_PAT_D2Z - %_Z2D $_PAT_Z2D - %_H2Z $_PAT_H2Z - %_Z2H $_PAT_Z2H); - -%_H2Z = ( - "\x8e\xa1" => "\xa1\xa3", #¡£ - "\x8e\xa2" => "\xa1\xd6", #¡Ö - "\x8e\xa3" => "\xa1\xd7", #¡× - "\x8e\xa4" => "\xa1\xa2", #¡¢ - "\x8e\xa5" => "\xa1\xa6", #¡¦ - "\x8e\xa6" => "\xa5\xf2", #¥ò - "\x8e\xa7" => "\xa5\xa1", #¥¡ - "\x8e\xa8" => "\xa5\xa3", #¥£ - "\x8e\xa9" => "\xa5\xa5", #¥¥ - "\x8e\xaa" => "\xa5\xa7", #¥§ - "\x8e\xab" => "\xa5\xa9", #¥© - "\x8e\xac" => "\xa5\xe3", #¥ã - "\x8e\xad" => "\xa5\xe5", #¥å - "\x8e\xae" => "\xa5\xe7", #¥ç - "\x8e\xaf" => "\xa5\xc3", #¥Ã - "\x8e\xb0" => "\xa1\xbc", #¡¼ - "\x8e\xb1" => "\xa5\xa2", #¥¢ - "\x8e\xb2" => "\xa5\xa4", #¥¤ - "\x8e\xb3" => "\xa5\xa6", #¥¦ - "\x8e\xb4" => "\xa5\xa8", #¥¨ - "\x8e\xb5" => "\xa5\xaa", #¥ª - "\x8e\xb6" => "\xa5\xab", #¥« - "\x8e\xb7" => "\xa5\xad", #¥­ - "\x8e\xb8" => "\xa5\xaf", #¥¯ - "\x8e\xb9" => "\xa5\xb1", #¥± - "\x8e\xba" => "\xa5\xb3", #¥³ - "\x8e\xbb" => "\xa5\xb5", #¥µ - "\x8e\xbc" => "\xa5\xb7", #¥· - "\x8e\xbd" => "\xa5\xb9", #¥¹ - "\x8e\xbe" => "\xa5\xbb", #¥» - "\x8e\xbf" => "\xa5\xbd", #¥½ - "\x8e\xc0" => "\xa5\xbf", #¥¿ - "\x8e\xc1" => "\xa5\xc1", #¥Á - "\x8e\xc2" => "\xa5\xc4", #¥Ä - "\x8e\xc3" => "\xa5\xc6", #¥Æ - "\x8e\xc4" => "\xa5\xc8", #¥È - "\x8e\xc5" => "\xa5\xca", #¥Ê - "\x8e\xc6" => "\xa5\xcb", #¥Ë - "\x8e\xc7" => "\xa5\xcc", #¥Ì - "\x8e\xc8" => "\xa5\xcd", #¥Í - "\x8e\xc9" => "\xa5\xce", #¥Î - "\x8e\xca" => "\xa5\xcf", #¥Ï - "\x8e\xcb" => "\xa5\xd2", #¥Ò - "\x8e\xcc" => "\xa5\xd5", #¥Õ - "\x8e\xcd" => "\xa5\xd8", #¥Ø - "\x8e\xce" => "\xa5\xdb", #¥Û - "\x8e\xcf" => "\xa5\xde", #¥Þ - "\x8e\xd0" => "\xa5\xdf", #¥ß - "\x8e\xd1" => "\xa5\xe0", #¥à - "\x8e\xd2" => "\xa5\xe1", #¥á - "\x8e\xd3" => "\xa5\xe2", #¥â - "\x8e\xd4" => "\xa5\xe4", #¥ä - "\x8e\xd5" => "\xa5\xe6", #¥æ - "\x8e\xd6" => "\xa5\xe8", #¥è - "\x8e\xd7" => "\xa5\xe9", #¥é - "\x8e\xd8" => "\xa5\xea", #¥ê - "\x8e\xd9" => "\xa5\xeb", #¥ë - "\x8e\xda" => "\xa5\xec", #¥ì - "\x8e\xdb" => "\xa5\xed", #¥í - "\x8e\xdc" => "\xa5\xef", #¥ï - "\x8e\xdd" => "\xa5\xf3", #¥ó - "\x8e\xde" => "\xa1\xab", #¡« - "\x8e\xdf" => "\xa1\xac", #¡¬ -); - -%_D2Z = ( - "\x8e\xb6\x8e\xde" => "\xa5\xac", #¥¬ - "\x8e\xb7\x8e\xde" => "\xa5\xae", #¥® - "\x8e\xb8\x8e\xde" => "\xa5\xb0", #¥° - "\x8e\xb9\x8e\xde" => "\xa5\xb2", #¥² - "\x8e\xba\x8e\xde" => "\xa5\xb4", #¥´ - "\x8e\xbb\x8e\xde" => "\xa5\xb6", #¥¶ - "\x8e\xbc\x8e\xde" => "\xa5\xb8", #¥¸ - "\x8e\xbd\x8e\xde" => "\xa5\xba", #¥º - "\x8e\xbe\x8e\xde" => "\xa5\xbc", #¥¼ - "\x8e\xbf\x8e\xde" => "\xa5\xbe", #¥¾ - "\x8e\xc0\x8e\xde" => "\xa5\xc0", #¥À - "\x8e\xc1\x8e\xde" => "\xa5\xc2", #¥Â - "\x8e\xc2\x8e\xde" => "\xa5\xc5", #¥Å - "\x8e\xc3\x8e\xde" => "\xa5\xc7", #¥Ç - "\x8e\xc4\x8e\xde" => "\xa5\xc9", #¥É - "\x8e\xca\x8e\xde" => "\xa5\xd0", #¥Ð - "\x8e\xcb\x8e\xde" => "\xa5\xd3", #¥Ó - "\x8e\xcc\x8e\xde" => "\xa5\xd6", #¥Ö - "\x8e\xcd\x8e\xde" => "\xa5\xd9", #¥Ù - "\x8e\xce\x8e\xde" => "\xa5\xdc", #¥Ü - "\x8e\xca\x8e\xdf" => "\xa5\xd1", #¥Ñ - "\x8e\xcb\x8e\xdf" => "\xa5\xd4", #¥Ô - "\x8e\xcc\x8e\xdf" => "\xa5\xd7", #¥× - "\x8e\xcd\x8e\xdf" => "\xa5\xda", #¥Ú - "\x8e\xce\x8e\xdf" => "\xa5\xdd", #¥Ý - "\x8e\xb3\x8e\xde" => "\xa5\xf4", #¥ô -); - -# init only once; - -#$_PAT_D2Z = join("|", keys %_D2Z); -#$_PAT_H2Z = join("|", keys %_H2Z); - -%_Z2H = reverse %_H2Z; -%_Z2D = reverse %_D2Z; - -#$_PAT_Z2H = join("|", keys %_Z2H); -#$_PAT_Z2D = join("|", keys %_Z2D); - -sub h2z { - no warnings qw(uninitialized); - my $r_str = shift; - my ($keep_dakuten) = @_; - my $n = 0; - unless ($keep_dakuten){ - $n = ( - $$r_str =~ s( - ($RE{EUC_KANA} - (?:\x8e[\xde\xdf])?) - ){ - my $str = $1; - $_D2Z{$str} || $_H2Z{$str} || - # in case dakuten and handakuten are side-by-side! - $_H2Z{substr($str,0,2)} . $_H2Z{substr($str,2,2)}; - }eogx - ); - }else{ - $n = ( - $$r_str =~ s( - ($RE{EUC_KANA}) - ){ - $_H2Z{$1}; - }eogx - ); - } - $n; -} - -sub z2h { - my $r_str = shift; - my $n = ( - $$r_str =~ s( - ($RE{EUC_C}|$RE{EUC_0212}|$RE{EUC_KANA}) - ){ - $_Z2D{$1} || $_Z2H{$1} || $1; - }eogx - ); - $n; -} - -1; -__END__ - - -=head1 NAME - -Encode::JP::H2Z -- internally used by Encode::JP::2022_JP* - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm b/Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm deleted file mode 100644 index 28503ec760c..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm +++ /dev/null @@ -1,165 +0,0 @@ -package Encode::JP::JIS7; -use strict; - -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Encode qw(:fallbacks); - -for my $name ('7bit-jis', 'iso-2022-jp', 'iso-2022-jp-1'){ - my $h2z = ($name eq '7bit-jis') ? 0 : 1; - my $jis0212 = ($name eq 'iso-2022-jp') ? 0 : 1; - - $Encode::Encoding{$name} = - bless { - Name => $name, - h2z => $h2z, - jis0212 => $jis0212, - } => __PACKAGE__; -} - -use base qw(Encode::Encoding); - -# we override this to 1 so PerlIO works -sub needs_lines { 1 } - -use Encode::CJKConstants qw(:all); - -# -# decode is identical for all 2022 variants -# - -sub decode($$;$) -{ - my ($obj, $str, $chk) = @_; - my $residue = ''; - if ($chk){ - $str =~ s/([^\x00-\x7f].*)$//so and $residue = $1; - } - $residue .= jis_euc(\$str); - $_[1] = $residue if $chk; - return Encode::decode('euc-jp', $str, FB_PERLQQ); -} - -# -# encode is different -# - -sub encode($$;$) -{ - require Encode::JP::H2Z; - my ($obj, $utf8, $chk) = @_; - # empty the input string in the stack so perlio is ok - $_[1] = '' if $chk; - my ($h2z, $jis0212) = @$obj{qw(h2z jis0212)}; - my $octet = Encode::encode('euc-jp', $utf8, FB_PERLQQ) ; - $h2z and &Encode::JP::H2Z::h2z(\$octet); - euc_jis(\$octet, $jis0212); - return $octet; -} - -# -# cat_decode -# -my $re_scan_jis_g = qr{ - \G ( ($RE{JIS_0212}) | $RE{JIS_0208} | - ($RE{ISO_ASC}) | ($RE{JIS_KANA}) | ) - ([^\e]*) -}x; -sub cat_decode { # ($obj, $dst, $src, $pos, $trm, $chk) - my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk - my ($rdst, $rsrc, $rpos) = \@_[1,2,3]; - local ${^ENCODING}; - use bytes; - my $opos = pos($$rsrc); - pos($$rsrc) = $pos; - while ($$rsrc =~ /$re_scan_jis_g/gc) { - my ($esc, $esc_0212, $esc_asc, $esc_kana, $chunk) = - ($1, $2, $3, $4, $5); - - unless ($chunk) { $esc or last; next; } - - if ($esc && !$esc_asc) { - $chunk =~ tr/\x21-\x7e/\xa1-\xfe/; - if ($esc_kana) { - $chunk =~ s/([\xa1-\xdf])/\x8e$1/og; - } elsif ($esc_0212) { - $chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og; - } - $chunk = Encode::decode('euc-jp', $chunk, 0); - } - elsif ((my $npos = index($chunk, $trm)) >= 0) { - $$rdst .= substr($chunk, 0, $npos + length($trm)); - $$rpos += length($esc) + $npos + length($trm); - pos($$rsrc) = $opos; - return 1; - } - $$rdst .= $chunk; - $$rpos = pos($$rsrc); - } - $$rpos = pos($$rsrc); - pos($$rsrc) = $opos; - return ''; -} - -# JIS<->EUC -my $re_scan_jis = qr{ - (?:($RE{JIS_0212})|$RE{JIS_0208}|($RE{ISO_ASC})|($RE{JIS_KANA}))([^\e]*) -}x; - -sub jis_euc { - local ${^ENCODING}; - my $r_str = shift; - $$r_str =~ s($re_scan_jis) - { - my ($esc_0212, $esc_asc, $esc_kana, $chunk) = - ($1, $2, $3, $4); - if (!$esc_asc) { - $chunk =~ tr/\x21-\x7e/\xa1-\xfe/; - if ($esc_kana) { - $chunk =~ s/([\xa1-\xdf])/\x8e$1/og; - } - elsif ($esc_0212) { - $chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og; - } - } - $chunk; - }geox; - my ($residue) = ($$r_str =~ s/(\e.*)$//so); - return $residue; -} - -sub euc_jis{ - no warnings qw(uninitialized); - my $r_str = shift; - my $jis0212 = shift; - $$r_str =~ s{ - ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+) - }{ - my $chunk = $1; - my $esc = - ( $chunk =~ tr/\x8E//d ) ? $ESC{KANA} : - ( $chunk =~ tr/\x8F//d ) ? $ESC{JIS_0212} : - $ESC{JIS_0208}; - if ($esc eq $ESC{JIS_0212} && !$jis0212){ - # fallback to '?' - $chunk =~ tr/\xA1-\xFE/\x3F/; - }else{ - $chunk =~ tr/\xA1-\xFE/\x21-\x7E/; - } - $esc . $chunk . $ESC{ASC}; - }geox; - $$r_str =~ - s/\Q$ESC{ASC}\E - (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox; - $$r_str; -} - -1; -__END__ - - -=head1 NAME - -Encode::JP::JIS7 -- internally used by Encode::JP - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/KR.pm b/Master/tlpkg/installer/perllib/Encode/KR.pm deleted file mode 100644 index e9d4073b7b4..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/KR.pm +++ /dev/null @@ -1,72 +0,0 @@ -package Encode::KR; -BEGIN { - if (ord("A") == 193) { - die "Encode::KR not supported on EBCDIC\n"; - } -} -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Encode; -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -use Encode::KR::2022_KR; - -1; -__END__ - -=head1 NAME - -Encode::KR - Korean Encodings - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $euc_kr = encode("euc-kr", $utf8); # loads Encode::KR implicitly - $utf8 = decode("euc-kr", $euc_kr); # ditto - -=head1 DESCRIPTION - -This module implements Korean charset encodings. Encodings supported -are as follows. - - - Canonical Alias Description - -------------------------------------------------------------------- - euc-kr /\beuc.*kr$/i EUC (Extended Unix Character) - /\bkr.*euc$/i - ksc5601-raw Korean standard code set (as is) - cp949 /(?:x-)?uhc$/i - /(?:x-)?windows-949$/i - /\bks_c_5601-1987$/i - Code Page 949 (EUC-KR + 8,822 - (additional Hangul syllables) - MacKorean EUC-KR + Apple Vendor Mappings - johab JOHAB A supplementary encoding defined in - Annex 3 of KS X 1001:1998 - iso-2022-kr iso-2022-kr [RFC1557] - -------------------------------------------------------------------- - -To find how to use this module in detail, see L. - -=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/installer/perllib/Encode/KR/2022_KR.pm b/Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm deleted file mode 100644 index 8b4052be570..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm +++ /dev/null @@ -1,79 +0,0 @@ -package Encode::KR::2022_KR; -use strict; - -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Encode qw(:fallbacks); - -use base qw(Encode::Encoding); -__PACKAGE__->Define('iso-2022-kr'); - -sub needs_lines { 1 } - -sub perlio_ok { - return 0; # for the time being -} - -sub decode -{ - my ($obj, $str, $chk) = @_; - my $res = $str; - my $residue = iso_euc(\$res); - # This is for PerlIO - $_[1] = $residue if $chk; - return Encode::decode('euc-kr', $res, FB_PERLQQ); -} - -sub encode -{ - my ($obj, $utf8, $chk) = @_; - # empty the input string in the stack so perlio is ok - $_[1] = '' if $chk; - my $octet = Encode::encode('euc-kr', $utf8, FB_PERLQQ) ; - euc_iso(\$octet); - return $octet; -} - -use Encode::CJKConstants qw(:all); - -# ISO<->EUC - -sub iso_euc{ - my $r_str = shift; - $$r_str =~ s/$RE{'2022_KR'}//gox; # remove the designator - $$r_str =~ s{ # replace characters in GL - \x0e # between SO(\x0e) and SI(\x0f) - ([^\x0f]*) # with characters in GR - \x0f - } - { - my $out= $1; - $out =~ tr/\x21-\x7e/\xa1-\xfe/; - $out; - }geox; - my ($residue) = ($$r_str =~ s/(\e.*)$//so); - return $residue; -} - -sub euc_iso{ - no warnings qw(uninitialized); - my $r_str = shift; - substr($$r_str,0,0)=$ESC{'2022_KR'}; # put the designator at the beg. - $$r_str =~ s{ # move KS X 1001 characters in GR to GL - ($RE{EUC_C}+) # and enclose them with SO and SI - }{ - my $str = $1; - $str =~ tr/\xA1-\xFE/\x21-\x7E/; - "\x0e" . $str . "\x0f"; - }geox; - $$r_str; -} - -1; -__END__ - -=head1 NAME - -Encode::KR::2022_KR -- internally used by Encode::KR - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/MIME/Header.pm b/Master/tlpkg/installer/perllib/Encode/MIME/Header.pm deleted file mode 100644 index f4e2ad6e2b5..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/MIME/Header.pm +++ /dev/null @@ -1,230 +0,0 @@ -package Encode::MIME::Header; -use strict; -# use warnings; -our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; -use Encode qw(find_encoding encode_utf8 decode_utf8); -use MIME::Base64; -use Carp; - -my %seed = - ( - decode_b => '1', # decodes 'B' encoding ? - decode_q => '1', # decodes 'Q' encoding ? - encode => 'B', # encode with 'B' or 'Q' ? - bpl => 75, # bytes per line - ); - -$Encode::Encoding{'MIME-Header'} = - bless { - %seed, - Name => 'MIME-Header', - } => __PACKAGE__; - -$Encode::Encoding{'MIME-B'} = - bless { - %seed, - decode_q => 0, - Name => 'MIME-B', - } => __PACKAGE__; - -$Encode::Encoding{'MIME-Q'} = - bless { - %seed, - decode_q => 1, - encode => 'Q', - Name => 'MIME-Q', - } => __PACKAGE__; - -use base qw(Encode::Encoding); - -sub needs_lines { 1 } -sub perlio_ok{ 0 }; - -sub decode($$;$){ - use utf8; - my ($obj, $str, $chk) = @_; - # zap spaces between encoded words - $str =~ s/\?=\s+=\?/\?==\?/gos; - # multi-line header to single line - $str =~ s/(:?\r|\n|\r\n)[ \t]//gos; - $str =~ - s{ - =\? # begin encoded word - ([0-9A-Za-z\-_]+) # charset (encoding) - \?([QqBb])\? # delimiter - (.*?) # Base64-encodede contents - \?= # end encoded word - }{ - if (uc($2) eq 'B'){ - $obj->{decode_b} or croak qq(MIME "B" unsupported); - decode_b($1, $3); - }elsif(uc($2) eq 'Q'){ - $obj->{decode_q} or croak qq(MIME "Q" unsupported); - decode_q($1, $3); - }else{ - croak qq(MIME "$2" encoding is nonexistent!); - } - }egox; - $_[1] = '' if $chk; - return $str; -} - -sub decode_b{ - my $enc = shift; - my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc"); - my $db64 = decode_base64(shift); - return $d->name eq 'utf8' ? - Encode::decode_utf8($db64) : $d->decode($db64, Encode::FB_PERLQQ); -} - -sub decode_q{ - my ($enc, $q) = @_; - my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc"); - $q =~ s/_/ /go; - $q =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ego; - return $d->name eq 'utf8' ? - Encode::decode_utf8($q) : $d->decode($q, Encode::FB_PERLQQ); -} - -my $especials = - join('|' => - map {quotemeta(chr($_))} - unpack("C*", qq{()<>@,;:\"\'/[]?.=})); - -my $re_encoded_word = - qr{ - (?: - =\? # begin encoded word - (?:[0-9A-Za-z\-_]+) # charset (encoding) - \?(?:[QqBb])\? # delimiter - (?:.*?) # Base64-encodede contents - \?= # end encoded word - ) - }xo; - -my $re_especials = qr{$re_encoded_word|$especials}xo; - -sub encode($$;$){ - my ($obj, $str, $chk) = @_; - my @line = (); - for my $line (split /\r|\n|\r\n/o, $str){ - my (@word, @subline); - for my $word (split /($re_especials)/o, $line){ - if ($word =~ /[^\x00-\x7f]/o or $word =~ /^$re_encoded_word$/o){ - push @word, $obj->_encode($word); - }else{ - push @word, $word; - } - } - my $subline = ''; - for my $word (@word){ - use bytes (); - if (bytes::length($subline) + bytes::length($word) > $obj->{bpl}){ - push @subline, $subline; - $subline = ''; - } - $subline .= $word; - } - $subline and push @subline, $subline; - push @line, join("\n " => @subline); - } - $_[1] = '' if $chk; - return join("\n", @line); -} - -use constant HEAD => '=?UTF-8?'; -use constant TAIL => '?='; -use constant SINGLE => { B => \&_encode_b, Q => \&_encode_q, }; - -sub _encode{ - my ($o, $str) = @_; - my $enc = $o->{encode}; - my $llen = ($o->{bpl} - length(HEAD) - 2 - length(TAIL)); - # to coerce a floating-point arithmetics, the following contains - # .0 in numbers -- dankogai - $llen *= $enc eq 'B' ? 3.0/4.0 : 1.0/3.0; - my @result = (); - my $chunk = ''; - while(length(my $chr = substr($str, 0, 1, ''))){ - use bytes (); - if (bytes::length($chunk) + bytes::length($chr) > $llen){ - push @result, SINGLE->{$enc}($chunk); - $chunk = ''; - } - $chunk .= $chr; - } - $chunk and push @result, SINGLE->{$enc}($chunk); - return @result; -} - -sub _encode_b{ - HEAD . 'B?' . encode_base64(encode_utf8(shift), '') . TAIL; -} - -sub _encode_q{ - my $chunk = shift; - $chunk =~ s{ - ([^0-9A-Za-z]) - }{ - join("" => map {sprintf "=%02X", $_} unpack("C*", $1)) - }egox; - return decode_utf8(HEAD . 'Q?' . $chunk . TAIL); -} - -1; -__END__ - -=head1 NAME - -Encode::MIME::Header -- MIME 'B' and 'Q' header encoding - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $utf8 = decode('MIME-Header', $header); - $header = encode('MIME-Header', $utf8); - -=head1 ABSTRACT - -This module implements RFC 2047 Mime Header Encoding. There are 3 -variant encoding names; C, 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/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm b/Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm deleted file mode 100644 index 5f637a32472..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm +++ /dev/null @@ -1,127 +0,0 @@ -package Encode::MIME::Header::ISO_2022_JP; - -use strict; -use base qw(Encode::MIME::Header); - -$Encode::Encoding{'MIME-Header-ISO_2022_JP'} - = bless {encode => 'B', bpl => 76, Name => 'MIME-Header-ISO_2022_JP'} - => __PACKAGE__; - -use constant HEAD => '=?ISO-2022-JP?B?'; -use constant TAIL => '?='; - -use Encode::CJKConstants qw(%RE); - -our $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - - -# I owe the below codes totally to -# Jcode by Dan Kogai & http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64 - -sub encode { - my $self = shift; - my $str = shift; - - utf8::encode($str) if( Encode::is_utf8($str) ); - Encode::from_to($str, 'utf8', 'euc-jp'); - - my($trailing_crlf) = ($str =~ /(\n|\r|\x0d\x0a)$/o); - - $str = _mime_unstructured_header($str, $self->{bpl}); - - not $trailing_crlf and $str =~ s/(\n|\r|\x0d\x0a)$//o; - - return $str; -} - - -sub _mime_unstructured_header { - my ($oldheader, $bpl) = @_; - my $crlf = $oldheader =~ /\n$/; - my($header, @words, @wordstmp, $i) = (''); - - $oldheader =~ s/\s+$//; - - @wordstmp = split /\s+/, $oldheader; - - for ($i = 0; $i < $#wordstmp; $i++){ - if( $wordstmp[$i] !~ /^[\x21-\x7E]+$/ and $wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/){ - $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]"; - } - else{ - push(@words, $wordstmp[$i]); - } - } - - push(@words, $wordstmp[-1]); - - for my $word (@words){ - if ($word =~ /^[\x21-\x7E]+$/) { - $header =~ /(?:.*\n)*(.*)/; - if (length($1) + length($word) > $bpl) { - $header .= "\n $word"; - } - else{ - $header .= $word; - } - } - else{ - $header = _add_encoded_word($word, $header, $bpl); - } - - $header =~ /(?:.*\n)*(.*)/; - - if(length($1) == $bpl){ - $header .= "\n "; - } - else { - $header .= ' '; - } - } - - $header =~ s/\n? $//mg; - - $crlf ? "$header\n" : $header; -} - - -sub _add_encoded_word { - my($str, $line, $bpl) = @_; - my $result = ''; - - while( length($str) ){ - my $target = $str; - $str = ''; - - if(length($line) + 22 + ($target =~ /^(?:$RE{EUC_0212}|$RE{EUC_C})/o) * 8 > $bpl){ - $line =~ s/[ \t\n\r]*$/\n/; - $result .= $line; - $line = ' '; - } - - while(1){ - my $iso_2022_jp = $target; - Encode::from_to($iso_2022_jp, 'euc-jp', 'iso-2022-jp'); - - my $encoded - = HEAD . MIME::Base64::encode_base64($iso_2022_jp, '') . TAIL; - - if(length($encoded) + length($line) > $bpl){ - $target =~ s/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|$RE{ASCII})$//o; - $str = $1 . $str; - } - else{ - $line .= $encoded; - last; - } - } - - } - - $result . $line; -} - - -1; -__END__ - diff --git a/Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x b/Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x deleted file mode 100644 index 3bca0bff52b..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x +++ /dev/null @@ -1,180 +0,0 @@ -# -# This file is auto-generated by: -# enc2xs version $_Version_ -# $_Now_ -# -use 5.7.2; -use strict; -use ExtUtils::MakeMaker; -use Config; - -# Please edit the following to the taste! -my $name = '$_Name_'; -my %tables = ( - $_Name__t => [ $_TableFiles_ ], - ); - -#### DO NOT EDIT BEYOND THIS POINT! -require File::Spec; -my ($enc2xs, $encode_h) = (); -PATHLOOP: -for my $d (@Config{qw/bin sitebin vendorbin/}, - (split /$Config{path_sep}/o, $ENV{PATH})){ - for my $f (qw/enc2xs enc2xs5.7.3/){ - my $path = File::Spec->catfile($d, $f); - -r $path and $enc2xs = $path and last PATHLOOP; - } -} -$enc2xs or die "enc2xs not found!"; -print "enc2xs is $enc2xs\n"; -my %encode_h = (); -for my $d (@INC){ - my $dir = File::Spec->catfile($d, "Encode"); - my $file = File::Spec->catfile($dir, "encode.h"); - -f $file and $encode_h{$dir} = -M $file; -} -%encode_h or die "encode.h not found!"; -# find the latest one -($encode_h) = sort {$encode_h{$b} <=> $encode_h{$a}} keys %encode_h; -print "encode.h is at $encode_h\n"; - -WriteMakefile( - INC => "-I$encode_h", -#### END_OF_HEADER -- DO NOT EDIT THIS LINE BY HAND! #### - NAME => 'Encode::'.$name, - VERSION_FROM => "$name.pm", - OBJECT => '$(O_FILES)', - 'dist' => { - COMPRESS => 'gzip -9f', - SUFFIX => 'gz', - DIST_DEFAULT => 'all tardist', - }, - MAN3PODS => {}, - PREREQ_PM => { - 'Encode' => "1.41", - }, - # OS 390 winges about line numbers > 64K ??? - XSOPT => '-nolinenumbers', - ); - -package MY; - -sub post_initialize -{ - my ($self) = @_; - my %o; - my $x = $self->{'OBJ_EXT'}; - # Add the table O_FILES - foreach my $e (keys %tables) - { - $o{$e.$x} = 1; - } - $o{"$name$x"} = 1; - $self->{'O_FILES'} = [sort keys %o]; - my @files = ("$name.xs"); - $self->{'C'} = ["$name.c"]; - # The next two lines to make MacPerl Happy -- dankogai via pudge - $self->{SOURCE} .= " $name.c" - if $^O eq 'MacOS' && $self->{SOURCE} !~ /\b$name\.c\b/; - # $self->{'H'} = [$self->catfile($self->updir,'encode.h')]; - my %xs; - foreach my $table (keys %tables) { - push (@{$self->{'C'}},"$table.c"); - # Do NOT add $table.h etc. to H_FILES unless we own up as to how they - # get built. - foreach my $ext (qw($(OBJ_EXT) .c .h .exh .fnm)) { - push (@files,$table.$ext); - } - } - $self->{'XS'} = { "$name.xs" => "$name.c" }; - $self->{'clean'}{'FILES'} .= join(' ',@files); - open(XS,">$name.xs") || die "Cannot open $name.xs:$!"; - print XS <<'END'; -#include -#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/installer/perllib/Encode/PerlIO.pod b/Master/tlpkg/installer/perllib/Encode/PerlIO.pod deleted file mode 100644 index abd1f2d10a1..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/PerlIO.pod +++ /dev/null @@ -1,167 +0,0 @@ -=head1 NAME - -Encode::PerlIO -- a detailed document on Encode and PerlIO - -=head1 Overview - -It is very common to want to do encoding transformations when -reading or writing files, network connections, pipes etc. -If Perl is configured to use the new 'perlio' IO system then -C 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/installer/perllib/Encode/README.e2x b/Master/tlpkg/installer/perllib/Encode/README.e2x deleted file mode 100644 index 28a31a655c2..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/README.e2x +++ /dev/null @@ -1,31 +0,0 @@ -Encode::$_Name_ version 0.1 -======== - -NAME - Encode::$_Name_ - - -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/installer/perllib/Encode/Supported.pod b/Master/tlpkg/installer/perllib/Encode/Supported.pod deleted file mode 100644 index 651f7e6ed4f..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Supported.pod +++ /dev/null @@ -1,890 +0,0 @@ -=head1 NAME - -Encode::Supported -- Encodings supported by Encode - -=head1 DESCRIPTION - -=head2 Encoding Names - -Encoding names are case insensitive. White space in names -is ignored. In addition, an encoding may have aliases. -Each encoding has one "canonical" name. The "canonical" -name is chosen from the names of the encoding by picking -the first in the following sequence (with a few exceptions). - -=over 4 - -=item * - -The name used by the Perl community. That includes 'utf8' and 'ascii'. -Unlike aliases, canonical names directly reach the method so such -frequently used words like 'utf8' don't need to do alias lookups. - -=item * - -The MIME name as defined in IETF RFCs. This includes all "iso-"s. - -=item * - -The name in the IANA registry. - -=item * - -The name used by the organization that defined it. - -=back - -In case I 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/installer/perllib/Encode/Symbol.pm b/Master/tlpkg/installer/perllib/Encode/Symbol.pm deleted file mode 100644 index 7ad8ca92c7d..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Symbol.pm +++ /dev/null @@ -1,42 +0,0 @@ -package Encode::Symbol; -use Encode; -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -1; -__END__ - -=head1 NAME - -Encode::Symbol - Symbol Encodings - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $symbol = encode("symbol", $utf8); # loads Encode::Symbol implicitly - $utf8 = decode("", $symbol); # ditto - -=head1 ABSTRACT - -This module implements symbol and dingbats encodings. Encodings -supported are as follows. - - Canonical Alias Description - -------------------------------------------------------------------- - symbol - dingbats - AdobeZDingbat - AdobeSymbol - MacDingbats - -=head1 DESCRIPTION - -To find out how to use this module in detail, see L. - -=head1 SEE ALSO - -L - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/TW.pm b/Master/tlpkg/installer/perllib/Encode/TW.pm deleted file mode 100644 index 2e1abc0c7f9..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/TW.pm +++ /dev/null @@ -1,78 +0,0 @@ -package Encode::TW; -BEGIN { - if (ord("A") == 193) { - die "Encode::TW not supported on EBCDIC\n"; - } -} -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Encode; -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -1; -__END__ - -=head1 NAME - -Encode::TW - Taiwan-based Chinese Encodings - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $big5 = encode("big5", $utf8); # loads Encode::TW implicitly - $utf8 = decode("big5", $big5); # ditto - -=head1 DESCRIPTION - -This module implements tradition Chinese charset encodings as used -in Taiwan and Hong Kong. -Encodings supported are as follows. - - Canonical Alias Description - -------------------------------------------------------------------- - big5-eten /\bbig-?5$/i Big5 encoding (with ETen extensions) - /\bbig5-?et(en)?$/i - /\btca-?big5$/i - big5-hkscs /\bbig5-?hk(scs)?$/i - /\bhk(scs)?-?big5$/i - Big5 + Cantonese characters in Hong Kong - MacChineseTrad Big5 + Apple Vendor Mappings - cp950 Code Page 950 - = Big5 + Microsoft vendor mappings - -------------------------------------------------------------------- - -To find out how to use this module in detail, see L. - -=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/installer/perllib/Encode/Unicode.pm b/Master/tlpkg/installer/perllib/Encode/Unicode.pm deleted file mode 100644 index 4d0c31d82d3..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Unicode.pm +++ /dev/null @@ -1,268 +0,0 @@ -package Encode::Unicode; - -use strict; -use warnings; -no warnings 'redefine'; - -our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -# -# Object Generator 8 transcoders all at once! -# - -require Encode; - -our %BOM_Unknown = map {$_ => 1} qw(UTF-16 UTF-32); - -for my $name (qw(UTF-16 UTF-16BE UTF-16LE - UTF-32 UTF-32BE UTF-32LE - UCS-2BE UCS-2LE)) -{ - my ($size, $endian, $ucs2, $mask); - $name =~ /^(\w+)-(\d+)(\w*)$/o; - if ($ucs2 = ($1 eq 'UCS')){ - $size = 2; - }else{ - $size = $2/8; - } - $endian = ($3 eq 'BE') ? 'n' : ($3 eq 'LE') ? 'v' : '' ; - $size == 4 and $endian = uc($endian); - - $Encode::Encoding{$name} = - bless { - Name => $name, - size => $size, - endian => $endian, - ucs2 => $ucs2, - } => __PACKAGE__; -} - -use base qw(Encode::Encoding); - -sub renew { - my $self = shift; - $BOM_Unknown{$self->name} or return $self; - my $clone = bless { %$self } => ref($self); - $clone->{renewed}++; # so the caller knows it is renewed. - return $clone; -} - -# There used to be a perl implemntation of (en|de)code but with -# XS version is ripe, perl version is zapped for optimal speed - -*decode = \&decode_xs; -*encode = \&encode_xs; - -1; -__END__ - -=head1 NAME - -Encode::Unicode -- Various Unicode Transformation Formats - -=cut - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $ucs2 = encode("UCS-2BE", $utf8); - $utf8 = decode("UCS-2BE", $ucs2); - -=head1 ABSTRACT - -This module implements all Character Encoding Schemes of Unicode that -are officially documented by Unicode Consortium (except, of course, -for UTF-8, which is a native format in perl). - -=over 4 - -=item L 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/installer/perllib/Encode/Unicode/UTF7.pm b/Master/tlpkg/installer/perllib/Encode/Unicode/UTF7.pm deleted file mode 100644 index dc75ce37816..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/Unicode/UTF7.pm +++ /dev/null @@ -1,118 +0,0 @@ -# -# $Id: UTF7.pm,v 2.1 2004/05/25 16:27:14 dankogai Exp $ -# -package Encode::Unicode::UTF7; -use strict; -no warnings 'redefine'; -use base qw(Encode::Encoding); -__PACKAGE__->Define('UTF-7'); -our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; -use MIME::Base64; -use Encode; - -# -# Algorithms taken from Unicode::String by Gisle Aas -# - -our $OPTIONAL_DIRECT_CHARS = 1; -my $specials = quotemeta "\'(),-./:?"; -$OPTIONAL_DIRECT_CHARS and - $specials .= quotemeta "!\"#$%&*;<=>@[]^_`{|}"; -# \s will not work because it matches U+3000 DEOGRAPHIC SPACE -# We use qr/[\n\r\t\ ] instead -my $re_asis = qr/(?:[\n\r\t\ A-Za-z0-9$specials])/; -my $re_encoded = qr/(?:[^\n\r\t\ A-Za-z0-9$specials])/; -my $e_utf16 = find_encoding("UTF-16BE"); - -sub needs_lines { 1 }; - -sub encode($$;$){ - my ($obj, $str, $chk) = @_; - my $len = length($str); - pos($str) = 0; - my $bytes = ''; - while (pos($str) < $len){ - if ($str =~ /\G($re_asis+)/ogc){ - $bytes .= $1; - }elsif($str =~ /\G($re_encoded+)/ogsc){ - if ($1 eq "+"){ - $bytes .= "+-"; - }else{ - my $s = $1; - my $base64 = encode_base64($e_utf16->encode($s), ''); - $base64 =~ s/=+$//; - $bytes .= "+$base64-"; - } - }else{ - die "This should not happen! (pos=" . pos($str) . ")"; - } - } - $_[1] = '' if $chk; - return $bytes; -} - -sub decode{ - my ($obj, $bytes, $chk) = @_; - my $len = length($bytes); - my $str = ""; - while (pos($bytes) < $len) { - if ($bytes =~ /\G([^+]+)/ogc) { - $str .= $1; - }elsif($bytes =~ /\G\+-/ogc) { - $str .= "+"; - }elsif($bytes =~ /\G\+([A-Za-z0-9+\/]+)-?/ogsc) { - my $base64 = $1; - my $pad = length($base64) % 4; - $base64 .= "=" x (4 - $pad) if $pad; - $str .= $e_utf16->decode(decode_base64($base64)); - }elsif($bytes =~ /\G\+/ogc) { - $^W and warn "Bad UTF7 data escape"; - $str .= "+"; - }else{ - die "This should not happen " . pos($bytes); - } - } - $_[1] = '' if $chk; - return $str; -} -1; -__END__ - -=head1 NAME - -Encode::Unicode::UTF7 -- UTF-7 encoding - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $utf7 = encode("UTF-7", $utf8); - $utf8 = decode("UTF-7", $ucs2); - -=head1 ABSTRACT - -This module implements UTF-7 encoding documented in RFC 2152. UTF-7, -as its name suggests, is a 7-bit re-encoded version of UTF-16BE. It -is designed to be MTA-safe and expected to be a standard way to -exchange Unicoded mails via mails. But with the advent of UTF-8 and -8-bit compliant MTAs, UTF-7 is hardly ever used. - -UTF-7 was not supported by Encode until version 1.95 because of that. -But Unicode::String, a module by Gisle Aas which adds Unicode supports -to non-utf8-savvy perl did support UTF-7, the UTF-7 support was added -so Encode can supersede Unicode::String 100%. - -=head1 In Practice - -When you want to encode Unicode for mails and web pages, however, do -not use UTF-7 unless you are sure your recipients and readers can -handle it. Very few MUAs and WWW Browsers support these days (only -Mozilla seems to support one). For general cases, use UTF-8 for -message body and MIME-Header for header instead. - -=head1 SEE ALSO - -L, L, L - -RFC 2781 L - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/_PM.e2x b/Master/tlpkg/installer/perllib/Encode/_PM.e2x deleted file mode 100644 index eb59cd1b520..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/_PM.e2x +++ /dev/null @@ -1,23 +0,0 @@ -package Encode::$_Name_; -our $VERSION = "0.01"; - -use Encode; -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -1; -__END__ - -=head1 NAME - -Encode::$_Name_ - New Encoding - -=head1 SYNOPSIS - -You got to fill this in! - -=head1 SEE ALSO - -L - -=cut diff --git a/Master/tlpkg/installer/perllib/Encode/_T.e2x b/Master/tlpkg/installer/perllib/Encode/_T.e2x deleted file mode 100644 index 6cf5f293d54..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/_T.e2x +++ /dev/null @@ -1,7 +0,0 @@ -use strict; -# Adjust the number here! -use Test::More tests => 2; - -use_ok('Encode'); -use_ok('Encode::$_Name_'); -# Add more test here! diff --git a/Master/tlpkg/installer/perllib/Encode/encode.h b/Master/tlpkg/installer/perllib/Encode/encode.h deleted file mode 100644 index 94764a6a14c..00000000000 --- a/Master/tlpkg/installer/perllib/Encode/encode.h +++ /dev/null @@ -1,111 +0,0 @@ -#ifndef ENCODE_H -#define ENCODE_H - -#ifndef U8 -/* - A tad devious this: - perl normally has a #define for U8 - if that isn't present then we - typedef it - leaving it #ifndef so we can do data parts without - getting extern references to the code parts -*/ -typedef unsigned char U8; -#endif - -typedef struct encpage_s encpage_t; - -struct encpage_s -{ - /* fields ordered to pack nicely on 32-bit machines */ - const U8 *seq; /* Packed output sequences we generate - if we match */ - encpage_t *next; /* Page to go to if we match */ - U8 min; /* Min value of octet to match this entry */ - U8 max; /* Max value of octet to match this entry */ - U8 dlen; /* destination length - - size of entries in seq */ - U8 slen; /* source length - - number of source octets needed */ -}; - -/* - At any point in a translation there is a page pointer which points - at an array of the above structures. - - Basic operation : - get octet from source stream. - if (octet >= min && octet < max) { - if slen is 0 then we cannot represent this character. - if we have less than slen octets (including this one) then - we have a partial character. - otherwise - copy dlen octets from seq + dlen*(octet-min) to output - (dlen may be zero if we don't know yet.) - load page pointer with next to continue. - (is slen is one this is end of a character) - get next octet. - } - else { - increment the page pointer to look at next slot in the array - } - - arrays SHALL be constructed so there is an entry which matches - ..0xFF at the end, and either maps it or indicates no - representation. - - if MSB of slen is set then mapping is an approximate "FALLBACK" entry. - -*/ - - -typedef struct encode_s encode_t; -struct encode_s -{ - encpage_t *t_utf8; /* Starting table for translation from - the encoding to UTF-8 form */ - encpage_t *f_utf8; /* Starting table for translation - from UTF-8 to the encoding */ - const U8 *rep; /* Replacement character in this encoding - e.g. "?" */ - int replen; /* Number of octets in rep */ - U8 min_el; /* Minimum octets to represent a character */ - U8 max_el; /* Maximum octets to represent a character */ - const char *name[2]; /* name(s) of this encoding */ -}; - -#ifdef U8 -/* See comment at top of file for deviousness */ - -extern int do_encode(encpage_t *enc, const U8 *src, STRLEN *slen, - U8 *dst, STRLEN dlen, STRLEN *dout, int approx, - const U8 *term, STRLEN tlen); - -extern void Encode_DefineEncoding(encode_t *enc); - -#endif /* U8 */ - -#define ENCODE_NOSPACE 1 -#define ENCODE_PARTIAL 2 -#define ENCODE_NOREP 3 -#define ENCODE_FALLBACK 4 -#define ENCODE_FOUND_TERM 5 - -#define FBCHAR_UTF8 "\xEF\xBF\xBD" - -#define ENCODE_DIE_ON_ERR 0x0001 /* croaks immediately */ -#define ENCODE_WARN_ON_ERR 0x0002 /* warn on error; may proceed */ -#define ENCODE_RETURN_ON_ERR 0x0004 /* immediately returns on NOREP */ -#define ENCODE_LEAVE_SRC 0x0008 /* $src updated unless set */ -#define ENCODE_PERLQQ 0x0100 /* perlqq fallback string */ -#define ENCODE_HTMLCREF 0x0200 /* HTML character ref. fb mode */ -#define ENCODE_XMLCREF 0x0400 /* XML character ref. fb mode */ -#define ENCODE_STOP_AT_PARTIAL 0x0800 /* stop at partial explicitly */ - -#define ENCODE_FB_DEFAULT 0x0000 -#define ENCODE_FB_CROAK 0x0001 -#define ENCODE_FB_QUIET ENCODE_RETURN_ON_ERR -#define ENCODE_FB_WARN (ENCODE_RETURN_ON_ERR|ENCODE_WARN_ON_ERR) -#define ENCODE_FB_PERLQQ (ENCODE_PERLQQ|ENCODE_LEAVE_SRC) -#define ENCODE_FB_HTMLCREF (ENCODE_HTMLCREF|ENCODE_LEAVE_SRC) -#define ENCODE_FB_XMLCREF (ENCODE_XMLCREF|ENCODE_LEAVE_SRC) - -#endif /* ENCODE_H */ diff --git a/Master/tlpkg/installer/perllib/Errno.pm b/Master/tlpkg/installer/perllib/Errno.pm deleted file mode 100644 index 23c07ea0482..00000000000 --- a/Master/tlpkg/installer/perllib/Errno.pm +++ /dev/null @@ -1,227 +0,0 @@ -# -# This file is auto-generated. ***ANY*** changes here will be lost -# - -package Errno; -our (@EXPORT_OK,%EXPORT_TAGS,@ISA,$VERSION,%errno,$AUTOLOAD); -use Exporter (); -use strict; - -$VERSION = "1.09_01"; -$VERSION = eval $VERSION; -@ISA = qw(Exporter); - -@EXPORT_OK = qw(EBADR ENOMSG ENOTSUP ESTRPIPE EADDRINUSE EL3HLT EBADF - ENOTBLK ENAVAIL ECHRNG ENOTNAM ELNRNG ENOKEY EXDEV EBADE EBADSLT - ECONNREFUSED ENOSTR ENONET EOVERFLOW EISCONN EFBIG EKEYREVOKED - ECONNRESET EWOULDBLOCK ELIBMAX EREMOTEIO ENOPKG ELIBSCN EDESTADDRREQ - ENOTSOCK EIO EMEDIUMTYPE EINPROGRESS ERANGE EAFNOSUPPORT EADDRNOTAVAIL - EINTR EREMOTE EILSEQ ENOMEM EPIPE ENETUNREACH ENODATA EUSERS - EOPNOTSUPP EPROTO EISNAM ESPIPE EALREADY ENAMETOOLONG ENOEXEC EISDIR - EBADRQC EEXIST EDOTDOT ELIBBAD EOWNERDEAD ESRCH EFAULT EXFULL - EDEADLOCK EAGAIN ENOPROTOOPT ENETDOWN EPROTOTYPE EL2NSYNC ENETRESET - EUCLEAN EADV EROFS ESHUTDOWN EMULTIHOP EPROTONOSUPPORT ENFILE ENOLCK - ECONNABORTED ECANCELED EDEADLK ESRMNT ENOLINK ETIME ENOTDIR EINVAL - ENOTTY ENOANO ELOOP ENOENT EPFNOSUPPORT EBADMSG ENOMEDIUM EL2HLT EDOM - EBFONT EKEYEXPIRED EMSGSIZE ENOCSI EL3RST ENOSPC EIDRM ENOBUFS ENOSYS - EHOSTDOWN EBADFD ENOSR ENOTCONN ESTALE EDQUOT EKEYREJECTED EMFILE - ENOTRECOVERABLE EACCES EBUSY E2BIG EPERM ELIBEXEC ETOOMANYREFS ELIBACC - ENOTUNIQ ECOMM ERESTART ESOCKTNOSUPPORT EUNATCH ETIMEDOUT ENXIO ENODEV - ETXTBSY EMLINK ECHILD EHOSTUNREACH EREMCHG ENOTEMPTY); - -%EXPORT_TAGS = ( - POSIX => [qw( - E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY - EBADF EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK - EDESTADDRREQ EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH - EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK - EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS - ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK - ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM - EPFNOSUPPORT EPIPE EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART - EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT - ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV - )] -); - -sub EPERM () { 1 } -sub ENOENT () { 2 } -sub ESRCH () { 3 } -sub EINTR () { 4 } -sub EIO () { 5 } -sub ENXIO () { 6 } -sub E2BIG () { 7 } -sub ENOEXEC () { 8 } -sub EBADF () { 9 } -sub ECHILD () { 10 } -sub EWOULDBLOCK () { 11 } -sub EAGAIN () { 11 } -sub ENOMEM () { 12 } -sub EACCES () { 13 } -sub EFAULT () { 14 } -sub ENOTBLK () { 15 } -sub EBUSY () { 16 } -sub EEXIST () { 17 } -sub EXDEV () { 18 } -sub ENODEV () { 19 } -sub ENOTDIR () { 20 } -sub EISDIR () { 21 } -sub EINVAL () { 22 } -sub ENFILE () { 23 } -sub EMFILE () { 24 } -sub ENOTTY () { 25 } -sub ETXTBSY () { 26 } -sub EFBIG () { 27 } -sub ENOSPC () { 28 } -sub ESPIPE () { 29 } -sub EROFS () { 30 } -sub EMLINK () { 31 } -sub EPIPE () { 32 } -sub EDOM () { 33 } -sub ERANGE () { 34 } -sub EDEADLOCK () { 35 } -sub EDEADLK () { 35 } -sub ENAMETOOLONG () { 36 } -sub ENOLCK () { 37 } -sub ENOSYS () { 38 } -sub ENOTEMPTY () { 39 } -sub ELOOP () { 40 } -sub ENOMSG () { 42 } -sub EIDRM () { 43 } -sub ECHRNG () { 44 } -sub EL2NSYNC () { 45 } -sub EL3HLT () { 46 } -sub EL3RST () { 47 } -sub ELNRNG () { 48 } -sub EUNATCH () { 49 } -sub ENOCSI () { 50 } -sub EL2HLT () { 51 } -sub EBADE () { 52 } -sub EBADR () { 53 } -sub EXFULL () { 54 } -sub ENOANO () { 55 } -sub EBADRQC () { 56 } -sub EBADSLT () { 57 } -sub EBFONT () { 59 } -sub ENOSTR () { 60 } -sub ENODATA () { 61 } -sub ETIME () { 62 } -sub ENOSR () { 63 } -sub ENONET () { 64 } -sub ENOPKG () { 65 } -sub EREMOTE () { 66 } -sub ENOLINK () { 67 } -sub EADV () { 68 } -sub ESRMNT () { 69 } -sub ECOMM () { 70 } -sub EPROTO () { 71 } -sub EMULTIHOP () { 72 } -sub EDOTDOT () { 73 } -sub EBADMSG () { 74 } -sub EOVERFLOW () { 75 } -sub ENOTUNIQ () { 76 } -sub EBADFD () { 77 } -sub EREMCHG () { 78 } -sub ELIBACC () { 79 } -sub ELIBBAD () { 80 } -sub ELIBSCN () { 81 } -sub ELIBMAX () { 82 } -sub ELIBEXEC () { 83 } -sub EILSEQ () { 84 } -sub ERESTART () { 85 } -sub ESTRPIPE () { 86 } -sub EUSERS () { 87 } -sub ENOTSOCK () { 88 } -sub EDESTADDRREQ () { 89 } -sub EMSGSIZE () { 90 } -sub EPROTOTYPE () { 91 } -sub ENOPROTOOPT () { 92 } -sub EPROTONOSUPPORT () { 93 } -sub ESOCKTNOSUPPORT () { 94 } -sub ENOTSUP () { 95 } -sub EOPNOTSUPP () { 95 } -sub EPFNOSUPPORT () { 96 } -sub EAFNOSUPPORT () { 97 } -sub EADDRINUSE () { 98 } -sub EADDRNOTAVAIL () { 99 } -sub ENETDOWN () { 100 } -sub ENETUNREACH () { 101 } -sub ENETRESET () { 102 } -sub ECONNABORTED () { 103 } -sub ECONNRESET () { 104 } -sub ENOBUFS () { 105 } -sub EISCONN () { 106 } -sub ENOTCONN () { 107 } -sub ESHUTDOWN () { 108 } -sub ETOOMANYREFS () { 109 } -sub ETIMEDOUT () { 110 } -sub ECONNREFUSED () { 111 } -sub EHOSTDOWN () { 112 } -sub EHOSTUNREACH () { 113 } -sub EALREADY () { 114 } -sub EINPROGRESS () { 115 } -sub ESTALE () { 116 } -sub EUCLEAN () { 117 } -sub ENOTNAM () { 118 } -sub ENAVAIL () { 119 } -sub EISNAM () { 120 } -sub EREMOTEIO () { 121 } -sub EDQUOT () { 122 } -sub ENOMEDIUM () { 123 } -sub EMEDIUMTYPE () { 124 } -sub ECANCELED () { 125 } -sub ENOKEY () { 126 } -sub EKEYEXPIRED () { 127 } -sub EKEYREVOKED () { 128 } -sub EKEYREJECTED () { 129 } -sub EOWNERDEAD () { 130 } -sub ENOTRECOVERABLE () { 131 } - -sub TIEHASH { bless [] } - -sub FETCH { - my ($self, $errname) = @_; - my $proto = prototype("Errno::$errname"); - my $errno = ""; - if (defined($proto) && $proto eq "") { - no strict 'refs'; - $errno = &$errname; - $errno = 0 unless $! == $errno; - } - return $errno; -} - -sub STORE { - require Carp; - Carp::confess("ERRNO hash is read only!"); -} - -*CLEAR = \&STORE; -*DELETE = \&STORE; - -sub NEXTKEY { - my($k,$v); - while(($k,$v) = each %Errno::) { - my $proto = prototype("Errno::$k"); - last if (defined($proto) && $proto eq ""); - } - $k -} - -sub FIRSTKEY { - my $s = scalar keys %Errno::; # initialize iterator - goto &NEXTKEY; -} - -sub EXISTS { - my ($self, $errname) = @_; - my $r = ref $errname; - my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef; - defined($proto) && $proto eq ""; -} - -tie %!, __PACKAGE__; - -1; -__END__ - diff --git a/Master/tlpkg/installer/perllib/Exporter.pm b/Master/tlpkg/installer/perllib/Exporter.pm deleted file mode 100644 index d9c22049776..00000000000 --- a/Master/tlpkg/installer/perllib/Exporter.pm +++ /dev/null @@ -1,440 +0,0 @@ -package Exporter; - -require 5.006; - -# Be lean. -#use strict; -#no strict 'refs'; - -our $Debug = 0; -our $ExportLevel = 0; -our $Verbose ||= 0; -our $VERSION = '5.58'; -our (%Cache); -$Carp::Internal{Exporter} = 1; - -sub as_heavy { - require Exporter::Heavy; - # Unfortunately, this does not work if the caller is aliased as *name = \&foo - # Thus the need to create a lot of identical subroutines - my $c = (caller(1))[3]; - $c =~ s/.*:://; - \&{"Exporter::Heavy::heavy_$c"}; -} - -sub export { - goto &{as_heavy()}; -} - -sub import { - my $pkg = shift; - my $callpkg = caller($ExportLevel); - - if ($pkg eq "Exporter" and @_ and $_[0] eq "import") { - *{$callpkg."::import"} = \&import; - return; - } - - # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( - my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"}); - return export $pkg, $callpkg, @_ - if $Verbose or $Debug or @$fail > 1; - my $export_cache = ($Cache{$pkg} ||= {}); - my $args = @_ or @_ = @$exports; - - local $_; - if ($args and not %$export_cache) { - s/^&//, $export_cache->{$_} = 1 - foreach (@$exports, @{"$pkg\::EXPORT_OK"}); - } - my $heavy; - # Try very hard not to use {} and hence have to enter scope on the foreach - # We bomb out of the loop with last as soon as heavy is set. - if ($args or $fail) { - ($heavy = (/\W/ or $args and not exists $export_cache->{$_} - or @$fail and $_ eq $fail->[0])) and last - foreach (@_); - } else { - ($heavy = /\W/) and last - foreach (@_); - } - return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy; - local $SIG{__WARN__} = - sub {require Carp; &Carp::carp}; - # shortcut for the common case of no type character - *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_; -} - -# Default methods - -sub export_fail { - my $self = shift; - @_; -} - -# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as -# *name = \&foo. Thus the need to create a lot of identical subroutines -# Otherwise we could have aliased them to export(). - -sub export_to_level { - goto &{as_heavy()}; -} - -sub export_tags { - goto &{as_heavy()}; -} - -sub export_ok_tags { - goto &{as_heavy()}; -} - -sub require_version { - goto &{as_heavy()}; -} - -1; -__END__ - -=head1 NAME - -Exporter - Implements default import method for modules - -=head1 SYNOPSIS - -In module YourModule.pm: - - package YourModule; - require Exporter; - @ISA = qw(Exporter); - @EXPORT_OK = qw(munge frobnicate); # symbols to export on request - -or - - package YourModule; - use Exporter 'import'; # gives you Exporter's import() method directly - @EXPORT_OK = qw(munge frobnicate); # symbols to export on request - -In other files which wish to use YourModule: - - use ModuleName qw(frobnicate); # import listed symbols - frobnicate ($left, $right) # calls YourModule::frobnicate - -=head1 DESCRIPTION - -The Exporter module implements an C 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/installer/perllib/Exporter/Heavy.pm b/Master/tlpkg/installer/perllib/Exporter/Heavy.pm deleted file mode 100644 index 2cc792288f0..00000000000 --- a/Master/tlpkg/installer/perllib/Exporter/Heavy.pm +++ /dev/null @@ -1,248 +0,0 @@ -package Exporter::Heavy; - -use strict; -no strict 'refs'; - -# On one line so MakeMaker will see it. -require Exporter; our $VERSION = $Exporter::VERSION; -$Carp::Internal{"Exporter::Heavy"} = 1; - -=head1 NAME - -Exporter::Heavy - Exporter guts - -=head1 SYNOPSIS - -(internal use only) - -=head1 DESCRIPTION - -No user-serviceable parts inside. - -=cut - -# -# We go to a lot of trouble not to 'require Carp' at file scope, -# because Carp requires Exporter, and something has to give. -# - -sub _rebuild_cache { - my ($pkg, $exports, $cache) = @_; - s/^&// foreach @$exports; - @{$cache}{@$exports} = (1) x @$exports; - my $ok = \@{"${pkg}::EXPORT_OK"}; - if (@$ok) { - s/^&// foreach @$ok; - @{$cache}{@$ok} = (1) x @$ok; - } -} - -sub heavy_export { - - # First make import warnings look like they're coming from the "use". - local $SIG{__WARN__} = sub { - my $text = shift; - if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) { - require Carp; - local $Carp::CarpLevel = 1; # ignore package calling us too. - Carp::carp($text); - } - else { - warn $text; - } - }; - local $SIG{__DIE__} = sub { - require Carp; - local $Carp::CarpLevel = 1; # ignore package calling us too. - Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT") - if $_[0] =~ /^Unable to create sub named "(.*?)::"/; - }; - - my($pkg, $callpkg, @imports) = @_; - my($type, $sym, $cache_is_current, $oops); - my($exports, $export_cache) = (\@{"${pkg}::EXPORT"}, - $Exporter::Cache{$pkg} ||= {}); - - if (@imports) { - if (!%$export_cache) { - _rebuild_cache ($pkg, $exports, $export_cache); - $cache_is_current = 1; - } - - if (grep m{^[/!:]}, @imports) { - my $tagsref = \%{"${pkg}::EXPORT_TAGS"}; - my $tagdata; - my %imports; - my($remove, $spec, @names, @allexports); - # negated first item implies starting with default set: - unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/; - foreach $spec (@imports){ - $remove = $spec =~ s/^!//; - - if ($spec =~ s/^://){ - if ($spec eq 'DEFAULT'){ - @names = @$exports; - } - elsif ($tagdata = $tagsref->{$spec}) { - @names = @$tagdata; - } - else { - warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS]; - ++$oops; - next; - } - } - elsif ($spec =~ m:^/(.*)/$:){ - my $patn = $1; - @allexports = keys %$export_cache unless @allexports; # only do keys once - @names = grep(/$patn/, @allexports); # not anchored by default - } - else { - @names = ($spec); # is a normal symbol name - } - - warn "Import ".($remove ? "del":"add").": @names " - if $Exporter::Verbose; - - if ($remove) { - foreach $sym (@names) { delete $imports{$sym} } - } - else { - @imports{@names} = (1) x @names; - } - } - @imports = keys %imports; - } - - my @carp; - foreach $sym (@imports) { - if (!$export_cache->{$sym}) { - if ($sym =~ m/^\d/) { - $pkg->VERSION($sym); # inherit from UNIVERSAL - # If the version number was the only thing specified - # then we should act as if nothing was specified: - if (@imports == 1) { - @imports = @$exports; - last; - } - # We need a way to emulate 'use Foo ()' but still - # allow an easy version check: "use Foo 1.23, ''"; - if (@imports == 2 and !$imports[1]) { - @imports = (); - last; - } - } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) { - # Last chance - see if they've updated EXPORT_OK since we - # cached it. - - unless ($cache_is_current) { - %$export_cache = (); - _rebuild_cache ($pkg, $exports, $export_cache); - $cache_is_current = 1; - } - - if (!$export_cache->{$sym}) { - # accumulate the non-exports - push @carp, - qq["$sym" is not exported by the $pkg module\n]; - $oops++; - } - } - } - } - if ($oops) { - require Carp; - Carp::croak("@{carp}Can't continue after import errors"); - } - } - else { - @imports = @$exports; - } - - my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"}, - $Exporter::FailCache{$pkg} ||= {}); - - if (@$fail) { - if (!%$fail_cache) { - # Build cache of symbols. Optimise the lookup by adding - # barewords twice... both with and without a leading &. - # (Technique could be applied to $export_cache at cost of memory) - my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail; - warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose; - @{$fail_cache}{@expanded} = (1) x @expanded; - } - my @failed; - foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} } - if (@failed) { - @failed = $pkg->export_fail(@failed); - foreach $sym (@failed) { - require Carp; - Carp::carp(qq["$sym" is not implemented by the $pkg module ], - "on this architecture"); - } - if (@failed) { - require Carp; - Carp::croak("Can't continue after import errors"); - } - } - } - - warn "Importing into $callpkg from $pkg: ", - join(", ",sort @imports) if $Exporter::Verbose; - - foreach $sym (@imports) { - # shortcut for the common case of no type character - (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next) - unless $sym =~ s/^(\W)//; - $type = $1; - *{"${callpkg}::$sym"} = - $type eq '&' ? \&{"${pkg}::$sym"} : - $type eq '$' ? \${"${pkg}::$sym"} : - $type eq '@' ? \@{"${pkg}::$sym"} : - $type eq '%' ? \%{"${pkg}::$sym"} : - $type eq '*' ? *{"${pkg}::$sym"} : - do { require Carp; Carp::croak("Can't export symbol: $type$sym") }; - } -} - -sub heavy_export_to_level -{ - my $pkg = shift; - my $level = shift; - (undef) = shift; # XXX redundant arg - my $callpkg = caller($level); - $pkg->export($callpkg, @_); -} - -# Utility functions - -sub _push_tags { - my($pkg, $var, $syms) = @_; - my @nontag = (); - my $export_tags = \%{"${pkg}::EXPORT_TAGS"}; - push(@{"${pkg}::$var"}, - map { $export_tags->{$_} ? @{$export_tags->{$_}} - : scalar(push(@nontag,$_),$_) } - (@$syms) ? @$syms : keys %$export_tags); - if (@nontag and $^W) { - # This may change to a die one day - require Carp; - Carp::carp(join(", ", @nontag)." are not tags of $pkg"); - } -} - -sub heavy_require_version { - my($self, $wanted) = @_; - my $pkg = ref $self || $self; - return ${pkg}->VERSION($wanted); -} - -sub heavy_export_tags { - _push_tags((caller)[0], "EXPORT", \@_); -} - -sub heavy_export_ok_tags { - _push_tags((caller)[0], "EXPORT_OK", \@_); -} - -1; diff --git a/Master/tlpkg/installer/perllib/Fcntl.pm b/Master/tlpkg/installer/perllib/Fcntl.pm deleted file mode 100644 index 7ef0038bd18..00000000000 --- a/Master/tlpkg/installer/perllib/Fcntl.pm +++ /dev/null @@ -1,236 +0,0 @@ -package Fcntl; - -=head1 NAME - -Fcntl - load the C Fcntl.h defines - -=head1 SYNOPSIS - - use Fcntl; - use Fcntl qw(:DEFAULT :flock); - -=head1 DESCRIPTION - -This module is just a translation of the C F 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/installer/perllib/File/Basename.pm b/Master/tlpkg/installer/perllib/File/Basename.pm deleted file mode 100644 index 837b753972a..00000000000 --- a/Master/tlpkg/installer/perllib/File/Basename.pm +++ /dev/null @@ -1,398 +0,0 @@ -=head1 NAME - -File::Basename - Parse file paths into directory, filename and suffix. - -=head1 SYNOPSIS - - use File::Basename; - - ($name,$path,$suffix) = fileparse($fullname,@suffixlist); - $name = fileparse($fullname,@suffixlist); - - $basename = basename($fullname,@suffixlist); - $dirname = dirname($fullname); - - -=head1 DESCRIPTION - -These routines allow you to parse file paths into their directory, filename -and suffix. - -B: 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/installer/perllib/File/CheckTree.pm b/Master/tlpkg/installer/perllib/File/CheckTree.pm deleted file mode 100644 index 20ffd68124d..00000000000 --- a/Master/tlpkg/installer/perllib/File/CheckTree.pm +++ /dev/null @@ -1,229 +0,0 @@ -package File::CheckTree; - -use 5.006; -use Cwd; -use Exporter; -use File::Spec; -use warnings; -use strict; - -our $VERSION = '4.3'; -our @ISA = qw(Exporter); -our @EXPORT = qw(validate); - -=head1 NAME - -validate - run many filetest checks on a tree - -=head1 SYNOPSIS - - use File::CheckTree; - - $num_warnings = validate( q{ - /vmunix -e || die - /boot -e || die - /bin cd - csh -ex - csh !-ug - sh -ex - sh !-ug - /usr -d || warn "What happened to $file?\n" - }); - -=head1 DESCRIPTION - -The validate() routine takes a single multiline string consisting of -directives, each containing a filename plus a file test to try on it. -(The file test may also be a "cd", causing subsequent relative filenames -to be interpreted relative to that directory.) After the file test -you may put C<|| die> to make it a fatal error if the file test fails. -The default is C<|| warn>. The file test may optionally have a "!' prepended -to test for the opposite condition. If you do a cd and then list some -relative filenames, you may want to indent them slightly for readability. -If you supply your own die() or warn() message, you can use $file to -interpolate the filename. - -Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>. -Only the first failed test of the bunch will produce a warning. - -The routine returns the number of warnings issued. - -=head1 AUTHOR - -File::CheckTree was derived from lib/validate.pl which was -written by Larry Wall. -Revised by Paul Grassie > in 2002. - -=head1 HISTORY - -File::CheckTree used to not display fatal error messages. -It used to count only those warnings produced by a generic C<|| warn> -(and not those in which the user supplied the message). In addition, -the validate() routine would leave the user program in whatever -directory was last entered through the use of "cd" directives. -These bugs were fixed during the development of perl 5.8. -The first fixed version of File::CheckTree was 4.2. - -=cut - -my $Warnings; - -sub validate { - my ($starting_dir, $file, $test, $cwd, $oldwarnings); - - $starting_dir = cwd; - - $cwd = ""; - $Warnings = 0; - - foreach my $check (split /\n/, $_[0]) { - my ($testlist, @testlist); - - # skip blanks/comments - next if $check =~ /^\s*#/ || $check =~ /^\s*$/; - - # Todo: - # should probably check for invalid directives and die - # but earlier versions of File::CheckTree did not do this either - - # split a line like "/foo -r || die" - # so that $file is "/foo", $test is "-rwx || die" - ($file, $test) = split(' ', $check, 2); # special whitespace split - - # change a $test like "!-ug || die" to "!-Z || die", - # capturing the bundled tests (e.g. "ug") in $2 - if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) { - $testlist = $2; - # split bundled tests, e.g. "ug" to 'u', 'g' - @testlist = split(//, $testlist); - } - else { - # put in placeholder Z for stand-alone test - @testlist = ('Z'); - } - - # will compare these two later to stop on 1st warning w/in a bundle - $oldwarnings = $Warnings; - - foreach my $one (@testlist) { - # examples of $test: "!-Z || die" or "-w || warn" - my $this = $test; - - # expand relative $file to full pathname if preceded by cd directive - $file = File::Spec->catfile($cwd, $file) - if $cwd && !File::Spec->file_name_is_absolute($file); - - # put filename in after the test operator - $this =~ s/(-\w\b)/$1 "\$file"/g; - - # change the "-Z" representing a bundle with the $one test - $this =~ s/-Z/-$one/; - - # if it's a "cd" directive... - if ($this =~ /^cd\b/) { - # add "|| die ..." - $this .= ' || die "cannot cd to $file\n"'; - # expand "cd" directive with directory name - $this =~ s/\bcd\b/chdir(\$cwd = '$file')/; - } - else { - # add "|| warn" as a default disposition - $this .= ' || warn' unless $this =~ /\|\|/; - - # change a generic ".. || die" or ".. || warn" - # to call valmess instead of die/warn directly - # valmess will look up the error message from %Val_Message - $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $ - /$1 || valmess('$3', '$2', \$file)/x; - } - - { - # count warnings, either from valmess or '-r || warn "my msg"' - # also, call any pre-existing signal handler for __WARN__ - my $orig_sigwarn = $SIG{__WARN__}; - local $SIG{__WARN__} = sub { - ++$Warnings; - if ( $orig_sigwarn ) { - $orig_sigwarn->(@_); - } - else { - warn "@_"; - } - }; - - # do the test - eval $this; - - # re-raise an exception caused by a "... || die" test - if ($@) { - # in case of any cd directives, return from whence we came - if ($starting_dir ne cwd) { - chdir($starting_dir) || die "$starting_dir: $!"; - } - die $@ if $@; - } - } - - # stop on 1st warning within a bundle of tests - last if $Warnings > $oldwarnings; - } - } - - # in case of any cd directives, return from whence we came - if ($starting_dir ne cwd) { - chdir($starting_dir) || die "chdir $starting_dir: $!"; - } - - return $Warnings; -} - -my %Val_Message = ( - 'r' => "is not readable by uid $>.", - 'w' => "is not writable by uid $>.", - 'x' => "is not executable by uid $>.", - 'o' => "is not owned by uid $>.", - 'R' => "is not readable by you.", - 'W' => "is not writable by you.", - 'X' => "is not executable by you.", - 'O' => "is not owned by you.", - 'e' => "does not exist.", - 'z' => "does not have zero size.", - 's' => "does not have non-zero size.", - 'f' => "is not a plain file.", - 'd' => "is not a directory.", - 'l' => "is not a symbolic link.", - 'p' => "is not a named pipe (FIFO).", - 'S' => "is not a socket.", - 'b' => "is not a block special file.", - 'c' => "is not a character special file.", - 'u' => "does not have the setuid bit set.", - 'g' => "does not have the setgid bit set.", - 'k' => "does not have the sticky bit set.", - 'T' => "is not a text file.", - 'B' => "is not a binary file." -); - -sub valmess { - my ($disposition, $test, $file) = @_; - my $ferror; - - if ($test =~ / ^ (!?) -(\w) \s* $ /x) { - my ($neg, $ftype) = ($1, $2); - - $ferror = "$file $Val_Message{$ftype}"; - - if ($neg eq '!') { - $ferror =~ s/ is not / should not be / || - $ferror =~ s/ does not / should not / || - $ferror =~ s/ not / /; - } - } - else { - $ferror = "Can't do $test $file.\n"; - } - - die "$ferror\n" if $disposition eq 'die'; - warn "$ferror\n"; -} - -1; diff --git a/Master/tlpkg/installer/perllib/File/Compare.pm b/Master/tlpkg/installer/perllib/File/Compare.pm deleted file mode 100644 index 0b73d7c7657..00000000000 --- a/Master/tlpkg/installer/perllib/File/Compare.pm +++ /dev/null @@ -1,178 +0,0 @@ -package File::Compare; - -use 5.006; -use strict; -use warnings; -our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big); - -require Exporter; -use Carp; - -$VERSION = '1.1003'; -@ISA = qw(Exporter); -@EXPORT = qw(compare); -@EXPORT_OK = qw(cmp compare_text); - -$Too_Big = 1024 * 1024 * 2; - -sub compare { - croak("Usage: compare( file1, file2 [, buffersize]) ") - unless(@_ == 2 || @_ == 3); - - my ($from,$to,$size) = @_; - my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0); - - my ($fromsize,$closefrom,$closeto); - local (*FROM, *TO); - - croak("from undefined") unless (defined $from); - croak("to undefined") unless (defined $to); - - if (ref($from) && - (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) { - *FROM = *$from; - } elsif (ref(\$from) eq 'GLOB') { - *FROM = $from; - } else { - open(FROM,"<$from") or goto fail_open1; - unless ($text_mode) { - binmode FROM; - $fromsize = -s FROM; - } - $closefrom = 1; - } - - if (ref($to) && - (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) { - *TO = *$to; - } elsif (ref(\$to) eq 'GLOB') { - *TO = $to; - } else { - open(TO,"<$to") or goto fail_open2; - binmode TO unless $text_mode; - $closeto = 1; - } - - if (!$text_mode && $closefrom && $closeto) { - # If both are opened files we know they differ if their size differ - goto fail_inner if $fromsize != -s TO; - } - - if ($text_mode) { - local $/ = "\n"; - my ($fline,$tline); - while (defined($fline = )) { - 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/installer/perllib/File/Copy.pm b/Master/tlpkg/installer/perllib/File/Copy.pm deleted file mode 100644 index 52ba7c6d81a..00000000000 --- a/Master/tlpkg/installer/perllib/File/Copy.pm +++ /dev/null @@ -1,459 +0,0 @@ -# File/Copy.pm. Written in 1994 by Aaron Sherman . 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/installer/perllib/File/DosGlob.pm b/Master/tlpkg/installer/perllib/File/DosGlob.pm deleted file mode 100644 index a1c27d5c32a..00000000000 --- a/Master/tlpkg/installer/perllib/File/DosGlob.pm +++ /dev/null @@ -1,571 +0,0 @@ -#!perl -w - -# use strict fails -#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. - -# -# Documentation at the __END__ -# - -package File::DosGlob; - -our $VERSION = '1.00'; -use strict; -use warnings; - -sub doglob { - my $cond = shift; - my @retval = (); - #print "doglob: ", join('|', @_), "\n"; - OUTER: - for my $pat (@_) { - my @matched = (); - my @globdirs = (); - my $head = '.'; - my $sepchr = '/'; - my $tail; - next OUTER unless defined $pat and $pat ne ''; - # if arg is within quotes strip em and do no globbing - if ($pat =~ /^"(.*)"\z/s) { - $pat = $1; - if ($cond eq 'd') { push(@retval, $pat) if -d $pat } - else { push(@retval, $pat) if -e $pat } - next OUTER; - } - # wildcards with a drive prefix such as h:*.pm must be changed - # to h:./*.pm to expand correctly - if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) { - substr($_,0,2) = $1 . "./"; - } - if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { - ($head, $sepchr, $tail) = ($1,$2,$3); - #print "div: |$head|$sepchr|$tail|\n"; - push (@retval, $pat), next OUTER if $tail eq ''; - if ($head =~ /[*?]/) { - @globdirs = doglob('d', $head); - push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), - next OUTER if @globdirs; - } - $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s; - $pat = $tail; - } - # - # If file component has no wildcards, we can avoid opendir - unless ($pat =~ /[*?]/) { - $head = '' if $head eq '.'; - $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; - $head .= $pat; - if ($cond eq 'd') { push(@retval,$head) if -d $head } - else { push(@retval,$head) if -e $head } - next OUTER; - } - opendir(D, $head) or next OUTER; - my @leaves = readdir D; - closedir D; - $head = '' if $head eq '.'; - $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; - - # escape regex metachars but not glob chars - $pat =~ s:([].+^\-\${}[|]):\\$1:g; - # and convert DOS-style wildcards to regex - $pat =~ s/\*/.*/g; - $pat =~ s/\?/.?/g; - - #print "regex: '$pat', head: '$head'\n"; - my $matchsub = sub { $_[0] =~ m|^$pat\z|is }; - INNER: - for my $e (@leaves) { - next INNER if $e eq '.' or $e eq '..'; - next INNER if $cond eq 'd' and ! -d "$head$e"; - push(@matched, "$head$e"), next INNER if &$matchsub($e); - # - # [DOS compatibility special case] - # Failed, add a trailing dot and try again, but only - # if name does not have a dot in it *and* pattern - # has a dot *and* name is shorter than 9 chars. - # - if (index($e,'.') == -1 and length($e) < 9 - and index($pat,'\\.') != -1) { - push(@matched, "$head$e"), next INNER if &$matchsub("$e."); - } - } - push @retval, @matched if @matched; - } - return @retval; -} - - -# -# Do DOS-like globbing on Mac OS -# -sub doglob_Mac { - my $cond = shift; - my @retval = (); - - #print "doglob_Mac: ", join('|', @_), "\n"; - OUTER: - for my $arg (@_) { - local $_ = $arg; - my @matched = (); - my @globdirs = (); - my $head = ':'; - my $not_esc_head = $head; - my $sepchr = ':'; - next OUTER unless defined $_ and $_ ne ''; - # if arg is within quotes strip em and do no globbing - if (/^"(.*)"\z/s) { - $_ = $1; - # $_ may contain escaped metachars '\*', '\?' and '\' - my $not_esc_arg = $_; - $not_esc_arg =~ s/\\([*?\\])/$1/g; - if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg } - else { push(@retval, $not_esc_arg) if -e $not_esc_arg } - next OUTER; - } - - if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy - my $tail; - ($head, $sepchr, $tail) = ($1,$2,$3); - #print "div: |$head|$sepchr|$tail|\n"; - push (@retval, $_), next OUTER if $tail eq ''; - # - # $head may contain escaped metachars '\*' and '\?' - - my $tmp_head = $head; - # if a '*' or '?' is preceded by an odd count of '\', temporary delete - # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as - # wildcards - $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; - - if ($tmp_head =~ /[*?]/) { # if there are wildcards ... - @globdirs = doglob_Mac('d', $head); - push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)), - next OUTER if @globdirs; - } - - $head .= $sepchr; - $not_esc_head = $head; - # unescape $head for file operations - $not_esc_head =~ s/\\([*?\\])/$1/g; - $_ = $tail; - } - # - # If file component has no wildcards, we can avoid opendir - - my $tmp_tail = $_; - # if a '*' or '?' is preceded by an odd count of '\', temporary delete - # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as - # wildcards - $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; - - unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ... - $not_esc_head = $head = '' if $head eq ':'; - my $not_esc_tail = $_; - # unescape $head and $tail for file operations - $not_esc_tail =~ s/\\([*?\\])/$1/g; - $head .= $_; - $not_esc_head .= $not_esc_tail; - if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head } - else { push(@retval,$head) if -e $not_esc_head } - next OUTER; - } - #print "opendir($not_esc_head)\n"; - opendir(D, $not_esc_head) or next OUTER; - my @leaves = readdir D; - closedir D; - - # escape regex metachars but not '\' and glob chars '*', '?' - $_ =~ s:([].+^\-\${}[|]):\\$1:g; - # and convert DOS-style wildcards to regex, - # but only if they are not escaped - $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; - - #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n"; - my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; - warn($@), next OUTER if $@; - INNER: - for my $e (@leaves) { - next INNER if $e eq '.' or $e eq '..'; - next INNER if $cond eq 'd' and ! -d "$not_esc_head$e"; - - if (&$matchsub($e)) { - my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ? - "$e" : "$not_esc_head$e"; - # - # On Mac OS, the two glob metachars '*' and '?' and the escape - # char '\' are valid characters for file and directory names. - # We have to escape and treat them specially. - $leave =~ s|([*?\\])|\\$1|g; - push(@matched, $leave); - next INNER; - } - } - push @retval, @matched if @matched; - } - return @retval; -} - -# -# _expand_volume() will only be used on Mac OS (Classic): -# Takes an array of original patterns as argument and returns an array of -# possibly modified patterns. Each original pattern is processed like -# that: -# + If there's a volume name in the pattern, we push a separate pattern -# for each mounted volume that matches (with '*', '?' and '\' escaped). -# + If there's no volume name in the original pattern, it is pushed -# unchanged. -# Note that the returned array of patterns may be empty. -# -sub _expand_volume { - - require MacPerl; # to be verbose - - my @pat = @_; - my @new_pat = (); - my @FSSpec_Vols = MacPerl::Volumes(); - my @mounted_volumes = (); - - foreach my $spec_vol (@FSSpec_Vols) { - # push all mounted volumes into array - push @mounted_volumes, MacPerl::MakePath($spec_vol); - } - #print "mounted volumes: |@mounted_volumes|\n"; - - while (@pat) { - my $pat = shift @pat; - if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name? - my $vol_pat = $1; - my $tail = $2; - # - # escape regex metachars but not '\' and glob chars '*', '?' - $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g; - # and convert DOS-style wildcards to regex, - # but only if they are not escaped - $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; - #print "volume regex: '$vol_pat' \n"; - - foreach my $volume (@mounted_volumes) { - if ($volume =~ m|^$vol_pat\z|ios) { - # - # On Mac OS, the two glob metachars '*' and '?' and the - # escape char '\' are valid characters for volume names. - # We have to escape and treat them specially. - $volume =~ s|([*?\\])|\\$1|g; - push @new_pat, $volume . $tail; - } - } - } else { # no volume name in pattern, push original pattern - push @new_pat, $pat; - } - } - return @new_pat; -} - - -# -# _preprocess_pattern() will only be used on Mac OS (Classic): -# Resolves any updirs in the pattern. Removes a single trailing colon -# from the pattern, unless it's a volume name pattern like "*HD:" -# -sub _preprocess_pattern { - my @pat = @_; - - foreach my $p (@pat) { - my $proceed; - # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*" - do { - $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); - } while ($proceed); - # remove a single trailing colon, e.g. ":*:" -> ":*" - $p =~ s/:([^:]+):\z/:$1/; - } - return @pat; -} - - -# -# _un_escape() will only be used on Mac OS (Classic): -# Unescapes a list of arguments which may contain escaped -# metachars '*', '?' and '\'. -# -sub _un_escape { - foreach (@_) { - s/\\([*?\\])/$1/g; - } - return @_; -} - -# -# this can be used to override CORE::glob in a specific -# package by saying C 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/installer/perllib/File/Find.pm b/Master/tlpkg/installer/perllib/File/Find.pm deleted file mode 100644 index 497051e0635..00000000000 --- a/Master/tlpkg/installer/perllib/File/Find.pm +++ /dev/null @@ -1,1275 +0,0 @@ -package File::Find; -use 5.006; -use strict; -use warnings; -use warnings::register; -our $VERSION = '1.10'; -require Exporter; -require Cwd; - -# -# Modified to ensure sub-directory traversal order is not inverded by stack -# push and pops. That is remains in the same order as in the directory file, -# or user pre-processing (EG:sorted). -# - -=head1 NAME - -File::Find - Traverse a directory tree. - -=head1 SYNOPSIS - - use File::Find; - find(\&wanted, @directories_to_search); - sub wanted { ... } - - use File::Find; - finddepth(\&wanted, @directories_to_search); - sub wanted { ... } - - use File::Find; - find({ wanted => \&process, follow => 1 }, '.'); - -=head1 DESCRIPTION - -These are functions for searching through directory trees doing work -on each file found similar to the Unix I 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/installer/perllib/File/Glob.pm b/Master/tlpkg/installer/perllib/File/Glob.pm deleted file mode 100644 index 133c650529b..00000000000 --- a/Master/tlpkg/installer/perllib/File/Glob.pm +++ /dev/null @@ -1,496 +0,0 @@ -package File::Glob; - -use strict; -our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, - $AUTOLOAD, $DEFAULT_FLAGS); - -use XSLoader (); - -@ISA = qw(Exporter); - -# NOTE: The glob() export is only here for compatibility with 5.6.0. -# csh_glob() should not be used directly, unless you know what you're doing. - -@EXPORT_OK = qw( - csh_glob - bsd_glob - glob - GLOB_ABEND - GLOB_ALPHASORT - GLOB_ALTDIRFUNC - GLOB_BRACE - GLOB_CSH - GLOB_ERR - GLOB_ERROR - GLOB_LIMIT - GLOB_MARK - GLOB_NOCASE - GLOB_NOCHECK - GLOB_NOMAGIC - GLOB_NOSORT - GLOB_NOSPACE - GLOB_QUOTE - GLOB_TILDE -); - -%EXPORT_TAGS = ( - 'glob' => [ qw( - GLOB_ABEND - GLOB_ALPHASORT - GLOB_ALTDIRFUNC - GLOB_BRACE - GLOB_CSH - GLOB_ERR - GLOB_ERROR - GLOB_LIMIT - GLOB_MARK - GLOB_NOCASE - GLOB_NOCHECK - GLOB_NOMAGIC - GLOB_NOSORT - GLOB_NOSPACE - GLOB_QUOTE - GLOB_TILDE - glob - bsd_glob - ) ], -); - -$VERSION = '1.05'; - -sub import { - require Exporter; - my $i = 1; - while ($i < @_) { - if ($_[$i] =~ /^:(case|nocase|globally)$/) { - splice(@_, $i, 1); - $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case'; - $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase'; - if ($1 eq 'globally') { - local $^W; - *CORE::GLOBAL::glob = \&File::Glob::csh_glob; - } - next; - } - ++$i; - } - goto &Exporter::import; -} - -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. If a constant is not found then control is passed - # to the AUTOLOAD in AutoLoader. - - my $constname; - ($constname = $AUTOLOAD) =~ s/.*:://; - my ($error, $val) = constant($constname); - if ($error) { - require Carp; - Carp::croak($error); - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -XSLoader::load 'File::Glob', $VERSION; - -# Preloaded methods go here. - -sub GLOB_ERROR { - return (constant('GLOB_ERROR'))[1]; -} - -sub GLOB_CSH () { - GLOB_BRACE() - | GLOB_NOMAGIC() - | GLOB_QUOTE() - | GLOB_TILDE() - | GLOB_ALPHASORT() -} - -$DEFAULT_FLAGS = GLOB_CSH(); -if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { - $DEFAULT_FLAGS |= GLOB_NOCASE(); -} - -# Autoload methods go after =cut, and are processed by the autosplit program. - -sub bsd_glob { - my ($pat,$flags) = @_; - $flags = $DEFAULT_FLAGS if @_ < 2; - return doglob($pat,$flags); -} - -# File::Glob::glob() is deprecated because its prototype is different from -# CORE::glob() (use bsd_glob() instead) -sub glob { - splice @_, 1; # don't pass PL_glob_index as flags! - goto &bsd_glob; -} - -## borrowed heavily from gsar's File::DosGlob -my %iter; -my %entries; - -sub csh_glob { - my $pat = shift; - my $cxix = shift; - my @pat; - - # glob without args defaults to $_ - $pat = $_ unless defined $pat; - - # extract patterns - $pat =~ s/^\s+//; # Protect against empty elements in - $pat =~ s/\s+$//; # things like < *.c> and <*.c >. - # These alone shouldn't trigger ParseWords. - if ($pat =~ /\s/) { - # XXX this is needed for compatibility with the csh - # implementation in Perl. Need to support a flag - # to disable this behavior. - require Text::ParseWords; - @pat = Text::ParseWords::parse_line('\s+',0,$pat); - } - - # assume global context if not provided one - $cxix = '_G_' unless defined $cxix; - $iter{$cxix} = 0 unless exists $iter{$cxix}; - - # if we're just beginning, do it all first - if ($iter{$cxix} == 0) { - if (@pat) { - $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ]; - } - else { - $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ]; - } - } - - # chuck it all out, quick or slow - if (wantarray) { - delete $iter{$cxix}; - return @{delete $entries{$cxix}}; - } - else { - if ($iter{$cxix} = scalar @{$entries{$cxix}}) { - return shift @{$entries{$cxix}}; - } - else { - # return undef for EOL - delete $iter{$cxix}; - delete $entries{$cxix}; - return undef; - } - } -} - -1; -__END__ - -=head1 NAME - -File::Glob - Perl extension for BSD glob routine - -=head1 SYNOPSIS - - use File::Glob ':glob'; - - @list = bsd_glob('*.[ch]'); - $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR); - - if (GLOB_ERROR) { - # an error occurred reading $homedir - } - - ## override the core glob (CORE::glob() does this automatically - ## by default anyway, since v5.6.0) - use File::Glob ':globally'; - my @sources = <*.{c,h,y}>; - - ## override the core glob, forcing case sensitivity - use File::Glob qw(:globally :case); - my @sources = <*.{c,h,y}>; - - ## override the core glob forcing case insensitivity - use File::Glob qw(:globally :nocase); - my @sources = <*.{c,h,y}>; - - ## glob on all files in home directory - use File::Glob ':globally'; - my @sources = <~gnat/*>; - -=head1 DESCRIPTION - -The glob angle-bracket operator C<< <> >> is a pathname generator that -implements the rules for file name pattern matching used by Unix-like shells -such as the Bourne shell or C shell. - -File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is -a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). -bsd_glob() takes a mandatory C 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/installer/perllib/File/Path.pm b/Master/tlpkg/installer/perllib/File/Path.pm deleted file mode 100644 index 2e41ff3f77f..00000000000 --- a/Master/tlpkg/installer/perllib/File/Path.pm +++ /dev/null @@ -1,285 +0,0 @@ -package File::Path; - -=head1 NAME - -File::Path - create or remove directory trees - -=head1 SYNOPSIS - - use File::Path; - - mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); - rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); - -=head1 DESCRIPTION - -The C 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/installer/perllib/File/Spec.pm b/Master/tlpkg/installer/perllib/File/Spec.pm deleted file mode 100644 index 0c8cd21e057..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec.pm +++ /dev/null @@ -1,322 +0,0 @@ -package File::Spec; - -use strict; -use vars qw(@ISA $VERSION); - -$VERSION = '3.12'; -$VERSION = eval $VERSION; - -my %module = (MacOS => 'Mac', - MSWin32 => 'Win32', - os2 => 'OS2', - VMS => 'VMS', - epoc => 'Epoc', - NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. - symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. - dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. - cygwin => 'Cygwin'); - - -my $module = $module{$^O} || 'Unix'; - -require "File/Spec/$module.pm"; -@ISA = ("File::Spec::$module"); - -1; - -__END__ - -=head1 NAME - -File::Spec - portably perform operations on file names - -=head1 SYNOPSIS - - use File::Spec; - - $x=File::Spec->catfile('a', 'b', 'c'); - -which returns 'a/b/c' under Unix. Or: - - use File::Spec::Functions; - - $x = catfile('a', 'b', 'c'); - -=head1 DESCRIPTION - -This module is designed to support operations commonly performed on file -specifications (usually called "file names", but not to be confused with the -contents of a file, or Perl's file handles), such as concatenating several -directory and file names into a single path, or determining whether a path -is rooted. It is based on code directly taken from MakeMaker 5.17, code -written by Andreas 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/installer/perllib/File/Spec/Cygwin.pm b/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm deleted file mode 100644 index 19a2937c6b9..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm +++ /dev/null @@ -1,93 +0,0 @@ -package File::Spec::Cygwin; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.1'; - -@ISA = qw(File::Spec::Unix); - -=head1 NAME - -File::Spec::Cygwin - methods for Cygwin file specs - -=head1 SYNOPSIS - - require File::Spec::Cygwin; # Done internally by File::Spec if needed - -=head1 DESCRIPTION - -See L 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/installer/perllib/File/Spec/Epoc.pm b/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm deleted file mode 100644 index a7168f9e494..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm +++ /dev/null @@ -1,77 +0,0 @@ -package File::Spec::Epoc; - -use strict; -use vars qw($VERSION @ISA); - -$VERSION = '1.1'; - -require File::Spec::Unix; -@ISA = qw(File::Spec::Unix); - -=head1 NAME - -File::Spec::Epoc - methods for Epoc file specs - -=head1 SYNOPSIS - - require File::Spec::Epoc; # Done internally by File::Spec if needed - -=head1 DESCRIPTION - -See File::Spec::Unix for a documentation of the methods provided -there. This package overrides the implementation of these methods, not -the semantics. - -This package is still work in progress ;-) - -=cut - -sub case_tolerant { - return 1; -} - -=pod - -=over 4 - -=item canonpath() - -No physical check on the filesystem, but a logical cleanup of a -path. On UNIX eliminated successive slashes and successive "/.". - -=back - -=cut - -sub canonpath { - my ($self,$path) = @_; - - $path =~ s|/+|/|g; # xx////xx -> xx/xx - $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx - $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx - $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx - $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx - return $path; -} - -=pod - -=head1 AUTHOR - -o.flebbe@gmx.de - -=head1 COPYRIGHT - -Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. - -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 SEE ALSO - -See L and L. This package overrides the -implementation of these methods, not the semantics. - -=cut - -1; diff --git a/Master/tlpkg/installer/perllib/File/Spec/Functions.pm b/Master/tlpkg/installer/perllib/File/Spec/Functions.pm deleted file mode 100644 index 38c898c5d8f..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Functions.pm +++ /dev/null @@ -1,109 +0,0 @@ -package File::Spec::Functions; - -use File::Spec; -use strict; - -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); - -$VERSION = '1.3'; - -require Exporter; - -@ISA = qw(Exporter); - -@EXPORT = qw( - canonpath - catdir - catfile - curdir - rootdir - updir - no_upwards - file_name_is_absolute - path -); - -@EXPORT_OK = qw( - devnull - tmpdir - splitpath - splitdir - catpath - abs2rel - rel2abs - case_tolerant -); - -%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); - -foreach my $meth (@EXPORT, @EXPORT_OK) { - my $sub = File::Spec->can($meth); - no strict 'refs'; - *{$meth} = sub {&$sub('File::Spec', @_)}; -} - - -1; -__END__ - -=head1 NAME - -File::Spec::Functions - portably perform operations on file names - -=head1 SYNOPSIS - - use File::Spec::Functions; - $x = catfile('a','b'); - -=head1 DESCRIPTION - -This module exports convenience functions for all of the class methods -provided by File::Spec. - -For a reference of available functions, please consult L, -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/installer/perllib/File/Spec/Mac.pm b/Master/tlpkg/installer/perllib/File/Spec/Mac.pm deleted file mode 100644 index 8b51bd6c249..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Mac.pm +++ /dev/null @@ -1,780 +0,0 @@ -package File::Spec::Mac; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.4'; - -@ISA = qw(File::Spec::Unix); - -my $macfiles; -if ($^O eq 'MacOS') { - $macfiles = eval { require Mac::Files }; -} - -sub case_tolerant { 1 } - - -=head1 NAME - -File::Spec::Mac - File::Spec for Mac OS (Classic) - -=head1 SYNOPSIS - - require File::Spec::Mac; # Done internally by File::Spec if needed - -=head1 DESCRIPTION - -Methods for manipulating file specifications. - -=head1 METHODS - -=over 2 - -=item canonpath - -On Mac OS, there's nothing to be done. Returns what it's given. - -=cut - -sub canonpath { - my ($self,$path) = @_; - return $path; -} - -=item catdir() - -Concatenate two or more directory names to form a path separated by colons -(":") ending with a directory. Resulting paths are B 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/installer/perllib/File/Spec/OS2.pm b/Master/tlpkg/installer/perllib/File/Spec/OS2.pm deleted file mode 100644 index ec308f3b6f3..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/OS2.pm +++ /dev/null @@ -1,272 +0,0 @@ -package File::Spec::OS2; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.2'; - -@ISA = qw(File::Spec::Unix); - -sub devnull { - return "/dev/nul"; -} - -sub case_tolerant { - return 1; -} - -sub file_name_is_absolute { - my ($self,$file) = @_; - return scalar($file =~ m{^([a-z]:)?[\\/]}is); -} - -sub path { - my $path = $ENV{PATH}; - $path =~ s:\\:/:g; - my @path = split(';',$path); - foreach (@path) { $_ = '.' if $_ eq '' } - return @path; -} - -sub _cwd { - # In OS/2 the "require Cwd" is unnecessary bloat. - return Cwd::sys_cwd(); -} - -my $tmpdir; -sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, - '/tmp', - '/' ); -} - -sub catdir { - my $self = shift; - my @args = @_; - foreach (@args) { - tr[\\][/]; - # append a backslash to each argument unless it has one there - $_ .= "/" unless m{/$}; - } - return $self->canonpath(join('', @args)); -} - -sub canonpath { - my ($self,$path) = @_; - $path =~ s/^([a-z]:)/\l$1/s; - $path =~ s|\\|/|g; - $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx - $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx - $path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx - $path =~ s|/\Z(?!\n)|| - unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx - $path =~ s{^/\.\.$}{/}; # /.. -> / - 1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx - return $path; -} - - -sub splitpath { - my ($self,$path, $nofile) = @_; - my ($volume,$directory,$file) = ('','',''); - if ( $nofile ) { - $path =~ - m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) - (.*) - }xs; - $volume = $1; - $directory = $2; - } - else { - $path =~ - m{^ ( (?: [a-zA-Z]: | - (?:\\\\|//)[^\\/]+[\\/][^\\/]+ - )? - ) - ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) - (.*) - }xs; - $volume = $1; - $directory = $2; - $file = $3; - } - - return ($volume,$directory,$file); -} - - -sub splitdir { - my ($self,$directories) = @_ ; - split m|[\\/]|, $directories, -1; -} - - -sub catpath { - my ($self,$volume,$directory,$file) = @_; - - # If it's UNC, make sure the glue separator is there, reusing - # whatever separator is first in the $volume - $volume .= $1 - if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && - $directory =~ m@^[^\\/]@s - ) ; - - $volume .= $directory ; - - # If the volume is not just A:, make sure the glue separator is - # there, reusing whatever separator is first in the $volume if possible. - if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && - $volume =~ m@[^\\/]\Z(?!\n)@ && - $file =~ m@[^\\/]@ - ) { - $volume =~ m@([\\/])@ ; - my $sep = $1 ? $1 : '/' ; - $volume .= $sep ; - } - - $volume .= $file ; - - return $volume ; -} - - -sub abs2rel { - my($self,$path,$base) = @_; - - # Clean up $path - if ( ! $self->file_name_is_absolute( $path ) ) { - $path = $self->rel2abs( $path ) ; - } else { - $path = $self->canonpath( $path ) ; - } - - # Figure out the effective $base and clean it up. - if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); - } elsif ( ! $self->file_name_is_absolute( $base ) ) { - $base = $self->rel2abs( $base ) ; - } else { - $base = $self->canonpath( $base ) ; - } - - # Split up paths - my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ; - my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ; - return $path unless $path_volume eq $base_volume; - - # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path_directories ); - my @basechunks = $self->splitdir( $base_directories ); - - while ( @pathchunks && - @basechunks && - lc( $pathchunks[0] ) eq lc( $basechunks[0] ) - ) { - shift @pathchunks ; - shift @basechunks ; - } - - # No need to catdir, we know these are well formed. - $path_directories = CORE::join( '/', @pathchunks ); - $base_directories = CORE::join( '/', @basechunks ); - - # $base_directories now contains the directories the resulting relative - # path must ascend out of before it can descend to $path_directory. So, - # replace all names with $parentDir - - #FA Need to replace between backslashes... - $base_directories =~ s|[^\\/]+|..|g ; - - # Glue the two together, using a separator if necessary, and preventing an - # empty result. - - #FA Must check that new directories are not empty. - if ( $path_directories ne '' && $base_directories ne '' ) { - $path_directories = "$base_directories/$path_directories" ; - } else { - $path_directories = "$base_directories$path_directories" ; - } - - return $self->canonpath( - $self->catpath( "", $path_directories, $path_file ) - ) ; -} - - -sub rel2abs { - my ($self,$path,$base ) = @_; - - if ( ! $self->file_name_is_absolute( $path ) ) { - - if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); - } - elsif ( ! $self->file_name_is_absolute( $base ) ) { - $base = $self->rel2abs( $base ) ; - } - else { - $base = $self->canonpath( $base ) ; - } - - my ( $path_directories, $path_file ) = - ($self->splitpath( $path, 1 ))[1,2] ; - - my ( $base_volume, $base_directories ) = - $self->splitpath( $base, 1 ) ; - - $path = $self->catpath( - $base_volume, - $self->catdir( $base_directories, $path_directories ), - $path_file - ) ; - } - - return $self->canonpath( $path ) ; -} - -1; -__END__ - -=head1 NAME - -File::Spec::OS2 - methods for OS/2 file specs - -=head1 SYNOPSIS - - require File::Spec::OS2; # Done internally by File::Spec if needed - -=head1 DESCRIPTION - -See L 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/installer/perllib/File/Spec/Unix.pm b/Master/tlpkg/installer/perllib/File/Spec/Unix.pm deleted file mode 100644 index 4a25fe632f2..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Unix.pm +++ /dev/null @@ -1,510 +0,0 @@ -package File::Spec::Unix; - -use strict; -use vars qw($VERSION); - -$VERSION = '1.5'; - -=head1 NAME - -File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules - -=head1 SYNOPSIS - - require File::Spec::Unix; # Done automatically by File::Spec - -=head1 DESCRIPTION - -Methods for manipulating file specifications. Other File::Spec -modules, such as File::Spec::Mac, inherit from File::Spec::Unix and -override specific methods. - -=head1 METHODS - -=over 2 - -=item canonpath() - -No physical check on the filesystem, but a logical cleanup of a -path. On UNIX eliminates successive slashes and successive "/.". - - $cpath = File::Spec->canonpath( $path ) ; - -Note that this does *not* collapse F 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/installer/perllib/File/Spec/VMS.pm b/Master/tlpkg/installer/perllib/File/Spec/VMS.pm deleted file mode 100644 index f8923f25fb2..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/VMS.pm +++ /dev/null @@ -1,521 +0,0 @@ -package File::Spec::VMS; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.4'; - -@ISA = qw(File::Spec::Unix); - -use File::Basename; -use VMS::Filespec; - -=head1 NAME - -File::Spec::VMS - methods for VMS file specs - -=head1 SYNOPSIS - - require File::Spec::VMS; # Done internally by File::Spec if needed - -=head1 DESCRIPTION - -See File::Spec::Unix for a documentation of the methods provided -there. This package overrides the implementation of these methods, not -the semantics. - -=over 4 - -=item canonpath (override) - -Removes redundant portions of file specifications according to VMS syntax. - -=cut - -sub canonpath { - my($self,$path) = @_; - - if ($path =~ m|/|) { # Fake Unix - my $pathify = $path =~ m|/\Z(?!\n)|; - $path = $self->SUPER::canonpath($path); - if ($pathify) { return vmspath($path); } - else { return vmsify($path); } - } - else { - $path =~ tr/<>/[]/; # < and > ==> [ and ] - $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][ - $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [ - $path =~ s/\[000000\./\[/g; # [000000. ==> [ - $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ] - $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar - 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/); - # That loop does the following - # with any amount of dashes: - # .-.-. ==> .--. - # [-.-. ==> [--. - # .-.-] ==> .--] - # [-.-] ==> [--] - 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/); - # That loop does the following - # with any amount (minimum 2) - # of dashes: - # .foo.--. ==> .-. - # .foo.--] ==> .-] - # [foo.--. ==> [-. - # [foo.--] ==> [-] - # - # And then, the remaining cases - $path =~ s/\[\.-/[-/; # [.- ==> [- - $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> . - $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [ - $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ] - $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000] - $path =~ s/\[\]//; # [] ==> - return $path; - } -} - -=item catdir (override) - -Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. No check is made for "impossible" -cases (e.g. elements other than the first being absolute filespecs). - -=cut - -sub catdir { - my ($self,@dirs) = @_; - my $dir = pop @dirs; - @dirs = grep($_,@dirs); - my $rslt; - if (@dirs) { - my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); - my ($spath,$sdir) = ($path,$dir); - $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); - - # Special case for VMS absolute directory specs: these will have had device - # prepended during trip through Unix syntax in eliminate_macros(), since - # Unix syntax has no way to express "absolute from the top of this device's - # directory tree". - if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } - } - else { - if (not defined $dir or not length $dir) { $rslt = ''; } - elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; } - else { $rslt = vmspath($dir); } - } - return $self->canonpath($rslt); -} - -=item catfile (override) - -Concatenates a list of file specifications, and returns the result as a -VMS-syntax file specification. - -=cut - -sub catfile { - my ($self,@files) = @_; - my $file = $self->canonpath(pop @files); - @files = grep($_,@files); - my $rslt; - if (@files) { - my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); - my $spath = $path; - $spath =~ s/\.dir\Z(?!\n)//; - if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { - $rslt = "$spath$file"; - } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); - } - } - else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } - return $self->canonpath($rslt); -} - - -=item curdir (override) - -Returns a string representation of the current directory: '[]' - -=cut - -sub curdir { - return '[]'; -} - -=item devnull (override) - -Returns a string representation of the null device: '_NLA0:' - -=cut - -sub devnull { - return "_NLA0:"; -} - -=item rootdir (override) - -Returns a string representation of the root directory: 'SYS$DISK:[000000]' - -=cut - -sub rootdir { - return 'SYS$DISK:[000000]'; -} - -=item tmpdir (override) - -Returns a string representation of the first writable directory -from the following list or '' if none are writable: - - sys$scratch: - $ENV{TMPDIR} - -Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} -is tainted, it is not used. - -=cut - -my $tmpdir; -sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); -} - -=item updir (override) - -Returns a string representation of the parent directory: '[-]' - -=cut - -sub updir { - return '[-]'; -} - -=item case_tolerant (override) - -VMS file specification syntax is case-tolerant. - -=cut - -sub case_tolerant { - return 1; -} - -=item path (override) - -Translate logical name DCL$PATH as a searchlist, rather than trying -to C 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/installer/perllib/File/Spec/Win32.pm b/Master/tlpkg/installer/perllib/File/Spec/Win32.pm deleted file mode 100644 index a324306a74b..00000000000 --- a/Master/tlpkg/installer/perllib/File/Spec/Win32.pm +++ /dev/null @@ -1,369 +0,0 @@ -package File::Spec::Win32; - -use strict; - -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.6'; - -@ISA = qw(File::Spec::Unix); - -=head1 NAME - -File::Spec::Win32 - methods for Win32 file specs - -=head1 SYNOPSIS - - require File::Spec::Win32; # Done internally by File::Spec if needed - -=head1 DESCRIPTION - -See File::Spec::Unix for a documentation of the methods provided -there. This package overrides the implementation of these methods, not -the semantics. - -=over 4 - -=item devnull - -Returns a string representation of the null device. - -=cut - -sub devnull { - return "nul"; -} - -sub rootdir () { '\\' } - - -=item tmpdir - -Returns a string representation of the first existing directory -from the following list: - - $ENV{TMPDIR} - $ENV{TEMP} - $ENV{TMP} - SYS:/temp - C:\system\temp - C:/temp - /tmp - / - -The SYS:/temp is preferred in Novell NetWare and the C:\system\temp -for Symbian (the File::Spec::Win32 is used also for those platforms). - -Since Perl 5.8.0, if running under taint mode, and if the environment -variables are tainted, they are not used. - -=cut - -my $tmpdir; -sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, - 'SYS:/temp', - 'C:\system\temp', - 'C:/temp', - '/tmp', - '/' ); -} - -sub case_tolerant { - return 1; -} - -sub file_name_is_absolute { - my ($self,$file) = @_; - return scalar($file =~ m{^([a-z]:)?[\\/]}is); -} - -=item catfile - -Concatenate one or more directory names and a filename to form a -complete path ending with a filename - -=cut - -sub catfile { - my $self = shift; - my $file = $self->canonpath(pop @_); - return $file unless @_; - my $dir = $self->catdir(@_); - $dir .= "\\" unless substr($dir,-1) eq "\\"; - return $dir.$file; -} - -sub catdir { - my $self = shift; - my @args = @_; - foreach (@args) { - tr[/][\\]; - # append a backslash to each argument unless it has one there - $_ .= "\\" unless m{\\$}; - } - return $self->canonpath(join('', @args)); -} - -sub path { - my @path = split(';', $ENV{PATH}); - s/"//g for @path; - @path = grep length, @path; - unshift(@path, "."); - return @path; -} - -=item canonpath - -No physical check on the filesystem, but a logical cleanup of a -path. On UNIX eliminated successive slashes and successive "/.". -On Win32 makes - - dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even - dir1\dir2\dir3\...\dir4 -> \dir\dir4 - -=cut - -sub canonpath { - my ($self,$path) = @_; - - $path =~ s/^([a-z]:)/\u$1/s; - $path =~ s|/|\\|g; - $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx - $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx - $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx - $path =~ s|\\\Z(?!\n)|| - unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx - # xx1/xx2/xx3/../../xx -> xx1/xx - $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up - $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up - return $path if $path =~ m|^\.\.|; # skip relative paths - return $path unless $path =~ /\.\./; # too few .'s to cleanup - return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup - $path =~ s{^\\\.\.$}{\\}; # \.. -> \ - 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx - - return $self->_collapse($path); -} - -=item splitpath - - ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); - -Splits a path into volume, directory, and filename portions. Assumes that -the last file is a path unless the path ends in '\\', '\\.', '\\..' -or $no_file is true. On Win32 this means that $no_file true makes this return -( $volume, $path, '' ). - -Separators accepted are \ and /. - -Volumes can be drive letters or UNC sharenames (\\server\share). - -The results can be passed to L 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/installer/perllib/File/Temp.pm b/Master/tlpkg/installer/perllib/File/Temp.pm deleted file mode 100644 index 6ddcb3619a7..00000000000 --- a/Master/tlpkg/installer/perllib/File/Temp.pm +++ /dev/null @@ -1,2244 +0,0 @@ -package File::Temp; - -=head1 NAME - -File::Temp - return name and handle of a temporary file safely - -=begin __INTERNALS - -=head1 PORTABILITY - -This section is at the top in order to provide easier access to -porters. It is not expected to be rendered by a standard pod -formatting tool. Please skip straight to the SYNOPSIS section if you -are not trying to port this module to a new platform. - -This module is designed to be portable across operating systems and it -currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS -(Classic). When porting to a new OS there are generally three main -issues that have to be solved: - -=over 4 - -=item * - -Can the OS unlink an open file? If it can not then the -C<_can_unlink_opened_file> method should be modified. - -=item * - -Are the return values from C 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/installer/perllib/File/stat.pm b/Master/tlpkg/installer/perllib/File/stat.pm deleted file mode 100644 index 132cbee27ad..00000000000 --- a/Master/tlpkg/installer/perllib/File/stat.pm +++ /dev/null @@ -1,139 +0,0 @@ -package File::stat; -use 5.006; - -use strict; -use warnings; - -our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); - -our $VERSION = '1.00'; - -BEGIN { - use Exporter (); - @EXPORT = qw(stat lstat); - @EXPORT_OK = qw( $st_dev $st_ino $st_mode - $st_nlink $st_uid $st_gid - $st_rdev $st_size - $st_atime $st_mtime $st_ctime - $st_blksize $st_blocks - ); - %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); -} -use vars @EXPORT_OK; - -# Class::Struct forbids use of @ISA -sub import { goto &Exporter::import } - -use Class::Struct qw(struct); -struct 'File::stat' => [ - map { $_ => '$' } qw{ - dev ino mode nlink uid gid rdev size - atime mtime ctime blksize blocks - } -]; - -sub populate (@) { - return unless @_; - my $stob = new(); - @$stob = ( - $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev, - $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) - = @_; - return $stob; -} - -sub lstat ($) { populate(CORE::lstat(shift)) } - -sub stat ($) { - my $arg = shift; - my $st = populate(CORE::stat $arg); - return $st if $st; - my $fh; - { - local $!; - no strict 'refs'; - require Symbol; - $fh = \*{ Symbol::qualify( $arg, caller() )}; - return unless defined fileno $fh; - } - return populate(CORE::stat $fh); -} - -1; -__END__ - -=head1 NAME - -File::stat - by-name interface to Perl's built-in stat() functions - -=head1 SYNOPSIS - - use File::stat; - $st = stat($file) or die "No $file: $!"; - if ( ($st->mode & 0111) && $st->nlink > 1) ) { - print "$file is executable with lotsa links\n"; - } - - use File::stat qw(:FIELDS); - stat($file) or die "No $file: $!"; - if ( ($st_mode & 0111) && $st_nlink > 1) ) { - print "$file is executable with lotsa links\n"; - } - -=head1 DESCRIPTION - -This module's default exports override the core stat() -and lstat() functions, replacing them with versions that return -"File::stat" objects. This object has methods that -return the similarly named structure field name from the -stat(2) function; namely, -dev, -ino, -mode, -nlink, -uid, -gid, -rdev, -size, -atime, -mtime, -ctime, -blksize, -and -blocks. - -You may also import all the structure fields directly into your namespace -as regular variables using the :FIELDS import tag. (Note that this still -overrides your stat() and lstat() functions.) Access these fields as -variables named with a preceding C 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/installer/perllib/FileHandle.pm b/Master/tlpkg/installer/perllib/FileHandle.pm deleted file mode 100644 index 6be22429440..00000000000 --- a/Master/tlpkg/installer/perllib/FileHandle.pm +++ /dev/null @@ -1,262 +0,0 @@ -package FileHandle; - -use 5.006; -use strict; -our($VERSION, @ISA, @EXPORT, @EXPORT_OK); - -$VERSION = "2.01"; - -require IO::File; -@ISA = qw(IO::File); - -@EXPORT = qw(_IOFBF _IOLBF _IONBF); - -@EXPORT_OK = qw( - pipe - - autoflush - output_field_separator - output_record_separator - input_record_separator - input_line_number - format_page_number - format_lines_per_page - format_lines_left - format_name - format_top_name - format_line_break_characters - format_formfeed - - print - printf - getline - getlines -); - -# -# Everything we're willing to export, we must first import. -# -import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK; - -# -# Some people call "FileHandle::function", so all the functions -# that were in the old FileHandle class must be imported, too. -# -{ - no strict 'refs'; - - my %import = ( - 'IO::Handle' => - [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets - eof flush error clearerr setbuf setvbuf _open_mode_string)], - 'IO::Seekable' => - [qw(seek tell getpos setpos)], - 'IO::File' => - [qw(new new_tmpfile open)] - ); - for my $pkg (keys %import) { - for my $func (@{$import{$pkg}}) { - my $c = *{"${pkg}::$func"}{CODE} - or die "${pkg}::$func missing"; - *$func = $c; - } - } -} - -# -# Specialized importer for Fcntl magic. -# -sub import { - my $pkg = shift; - my $callpkg = caller; - require Exporter; - Exporter::export($pkg, $callpkg, @_); - - # - # If the Fcntl extension is available, - # export its constants. - # - eval { - require Fcntl; - Exporter::export('Fcntl', $callpkg); - }; -} - -################################################ -# This is the only exported function we define; -# the rest come from other classes. -# - -sub pipe { - my $r = new IO::Handle; - my $w = new IO::Handle; - CORE::pipe($r, $w) or return undef; - ($r, $w); -} - -# Rebless standard file handles -bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle"; -bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle"; -bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle"; - -1; - -__END__ - -=head1 NAME - -FileHandle - supply object methods for filehandles - -=head1 SYNOPSIS - - use FileHandle; - - $fh = new FileHandle; - if ($fh->open("< file")) { - print <$fh>; - $fh->close; - } - - $fh = new FileHandle "> FOO"; - if (defined $fh) { - print $fh "bar\n"; - $fh->close; - } - - $fh = new FileHandle "file", "r"; - if (defined $fh) { - print <$fh>; - undef $fh; # automatically closes the file - } - - $fh = new FileHandle "file", O_WRONLY|O_APPEND; - if (defined $fh) { - print $fh "corge\n"; - undef $fh; # automatically closes the file - } - - $pos = $fh->getpos; - $fh->setpos($pos); - - $fh->setvbuf($buffer_var, _IOLBF, 1024); - - ($readfh, $writefh) = FileHandle::pipe; - - autoflush STDOUT 1; - -=head1 DESCRIPTION - -NOTE: This class is now a front-end to the IO::* classes. - -C 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/installer/perllib/Getopt/Long.pm b/Master/tlpkg/installer/perllib/Getopt/Long.pm deleted file mode 100644 index 04038db58e3..00000000000 --- a/Master/tlpkg/installer/perllib/Getopt/Long.pm +++ /dev/null @@ -1,2504 +0,0 @@ -# Getopt::Long.pm -- Universal options parsing - -package Getopt::Long; - -# RCS Status : $Id: GetoptLong.pm,v 2.72 2005-04-28 21:18:33+02 jv Exp $ -# Author : Johan Vromans -# Created On : Tue Sep 11 15:00:12 1990 -# Last Modified By: Johan Vromans -# Last Modified On: Wed Dec 14 21:17:21 2005 -# Update Count : 1458 -# Status : Released - -################ Copyright ################ - -# This program is Copyright 1990,2005 by Johan Vromans. -# This program is free software; you can redistribute it and/or -# modify it under the terms of the Perl Artistic License or the -# GNU General Public License as published by the Free Software -# Foundation; either version 2 of the License, or (at your option) any -# later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# If you do not have a copy of the GNU General Public License write to -# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -# MA 02139, USA. - -################ Module Preamble ################ - -use 5.004; - -use strict; - -use vars qw($VERSION); -$VERSION = 2.35; -# For testing versions only. -#use vars qw($VERSION_STRING); -#$VERSION_STRING = "2.35"; - -use Exporter; -use vars qw(@ISA @EXPORT @EXPORT_OK); -@ISA = qw(Exporter); - -# Exported subroutines. -sub GetOptions(@); # always -sub Configure(@); # on demand -sub HelpMessage(@); # on demand -sub VersionMessage(@); # in demand - -BEGIN { - # Init immediately so their contents can be used in the 'use vars' below. - @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); - @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure); -} - -# User visible variables. -use vars @EXPORT, @EXPORT_OK; -use vars qw($error $debug $major_version $minor_version); -# Deprecated visible variables. -use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order - $passthrough); -# Official invisible variables. -use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix); - -# Public subroutines. -sub config(@); # deprecated name - -# Private subroutines. -sub ConfigDefaults(); -sub ParseOptionSpec($$); -sub OptCtl($); -sub FindOption($$$$); -sub ValidValue ($$$$$); - -################ Local Variables ################ - -# $requested_version holds the version that was mentioned in the 'use' -# or 'require', if any. It can be used to enable or disable specific -# features. -my $requested_version = 0; - -################ Resident subroutines ################ - -sub ConfigDefaults() { - # Handle POSIX compliancy. - if ( defined $ENV{"POSIXLY_CORRECT"} ) { - $genprefix = "(--|-)"; - $autoabbrev = 0; # no automatic abbrev of options - $bundling = 0; # no bundling of single letter switches - $getopt_compat = 0; # disallow '+' to start options - $order = $REQUIRE_ORDER; - } - else { - $genprefix = "(--|-|\\+)"; - $autoabbrev = 1; # automatic abbrev of options - $bundling = 0; # bundling off by default - $getopt_compat = 1; # allow '+' to start options - $order = $PERMUTE; - } - # Other configurable settings. - $debug = 0; # for debugging - $error = 0; # error tally - $ignorecase = 1; # ignore case when matching options - $passthrough = 0; # leave unrecognized options alone - $gnu_compat = 0; # require --opt=val if value is optional - $longprefix = "(--)"; # what does a long prefix look like -} - -# Override import. -sub import { - my $pkg = shift; # package - my @syms = (); # symbols to import - my @config = (); # configuration - my $dest = \@syms; # symbols first - for ( @_ ) { - if ( $_ eq ':config' ) { - $dest = \@config; # config next - next; - } - push(@$dest, $_); # push - } - # Hide one level and call super. - local $Exporter::ExportLevel = 1; - push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions - $pkg->SUPER::import(@syms); - # And configure. - Configure(@config) if @config; -} - -################ Initialization ################ - -# Values for $order. See GNU getopt.c for details. -($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); -# Version major/minor numbers. -($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; - -ConfigDefaults(); - -################ OO Interface ################ - -package Getopt::Long::Parser; - -# Store a copy of the default configuration. Since ConfigDefaults has -# just been called, what we get from Configure is the default. -my $default_config = do { - Getopt::Long::Configure () -}; - -sub new { - my $that = shift; - my $class = ref($that) || $that; - my %atts = @_; - - # Register the callers package. - my $self = { caller_pkg => (caller)[0] }; - - bless ($self, $class); - - # Process config attributes. - if ( defined $atts{config} ) { - my $save = Getopt::Long::Configure ($default_config, @{$atts{config}}); - $self->{settings} = Getopt::Long::Configure ($save); - delete ($atts{config}); - } - # Else use default config. - else { - $self->{settings} = $default_config; - } - - if ( %atts ) { # Oops - die(__PACKAGE__.": unhandled attributes: ". - join(" ", sort(keys(%atts)))."\n"); - } - - $self; -} - -sub configure { - my ($self) = shift; - - # Restore settings, merge new settings in. - my $save = Getopt::Long::Configure ($self->{settings}, @_); - - # Restore orig config and save the new config. - $self->{settings} = Getopt::Long::Configure ($save); -} - -sub getoptions { - my ($self) = shift; - - # Restore config settings. - my $save = Getopt::Long::Configure ($self->{settings}); - - # Call main routine. - my $ret = 0; - $Getopt::Long::caller = $self->{caller_pkg}; - - eval { - # Locally set exception handler to default, otherwise it will - # be called implicitly here, and again explicitly when we try - # to deliver the messages. - local ($SIG{__DIE__}) = '__DEFAULT__'; - $ret = Getopt::Long::GetOptions (@_); - }; - - # Restore saved settings. - Getopt::Long::Configure ($save); - - # Handle errors and return value. - die ($@) if $@; - return $ret; -} - -package Getopt::Long; - -################ Back to Normal ################ - -# Indices in option control info. -# Note that ParseOptions uses the fields directly. Search for 'hard-wired'. -use constant CTL_TYPE => 0; -#use constant CTL_TYPE_FLAG => ''; -#use constant CTL_TYPE_NEG => '!'; -#use constant CTL_TYPE_INCR => '+'; -#use constant CTL_TYPE_INT => 'i'; -#use constant CTL_TYPE_INTINC => 'I'; -#use constant CTL_TYPE_XINT => 'o'; -#use constant CTL_TYPE_FLOAT => 'f'; -#use constant CTL_TYPE_STRING => 's'; - -use constant CTL_CNAME => 1; - -use constant CTL_DEFAULT => 2; - -use constant CTL_DEST => 3; - use constant CTL_DEST_SCALAR => 0; - use constant CTL_DEST_ARRAY => 1; - use constant CTL_DEST_HASH => 2; - use constant CTL_DEST_CODE => 3; - -use constant CTL_AMIN => 4; -use constant CTL_AMAX => 5; - -# FFU. -#use constant CTL_RANGE => ; -#use constant CTL_REPEAT => ; - -sub GetOptions(@) { - - my @optionlist = @_; # local copy of the option descriptions - my $argend = '--'; # option list terminator - my %opctl = (); # table of option specs - my $pkg = $caller || (caller)[0]; # current context - # Needed if linkage is omitted. - my @ret = (); # accum for non-options - my %linkage; # linkage - my $userlinkage; # user supplied HASH - my $opt; # current option - my $prefix = $genprefix; # current prefix - - $error = ''; - - if ( $debug ) { - # Avoid some warnings if debugging. - local ($^W) = 0; - print STDERR - ("Getopt::Long $Getopt::Long::VERSION (", - '$Revision: 2.72 $', ") ", - "called from package \"$pkg\".", - "\n ", - "ARGV: (@ARGV)", - "\n ", - "autoabbrev=$autoabbrev,". - "bundling=$bundling,", - "getopt_compat=$getopt_compat,", - "gnu_compat=$gnu_compat,", - "order=$order,", - "\n ", - "ignorecase=$ignorecase,", - "requested_version=$requested_version,", - "passthrough=$passthrough,", - "genprefix=\"$genprefix\",", - "longprefix=\"$longprefix\".", - "\n"); - } - - # Check for ref HASH as first argument. - # First argument may be an object. It's OK to use this as long - # as it is really a hash underneath. - $userlinkage = undef; - if ( @optionlist && ref($optionlist[0]) and - UNIVERSAL::isa($optionlist[0],'HASH') ) { - $userlinkage = shift (@optionlist); - print STDERR ("=> user linkage: $userlinkage\n") if $debug; - } - - # See if the first element of the optionlist contains option - # starter characters. - # Be careful not to interpret '<>' as option starters. - if ( @optionlist && $optionlist[0] =~ /^\W+$/ - && !($optionlist[0] eq '<>' - && @optionlist > 0 - && ref($optionlist[1])) ) { - $prefix = shift (@optionlist); - # Turn into regexp. Needs to be parenthesized! - $prefix =~ s/(\W)/\\$1/g; - $prefix = "([" . $prefix . "])"; - print STDERR ("=> prefix=\"$prefix\"\n") if $debug; - } - - # Verify correctness of optionlist. - %opctl = (); - while ( @optionlist ) { - my $opt = shift (@optionlist); - - unless ( defined($opt) ) { - $error .= "Undefined argument in option spec\n"; - next; - } - - # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $+ if $opt =~ /^$prefix+(.*)$/s; - - if ( $opt eq '<>' ) { - if ( (defined $userlinkage) - && !(@optionlist > 0 && ref($optionlist[0])) - && (exists $userlinkage->{$opt}) - && ref($userlinkage->{$opt}) ) { - unshift (@optionlist, $userlinkage->{$opt}); - } - unless ( @optionlist > 0 - && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { - $error .= "Option spec <> requires a reference to a subroutine\n"; - # Kill the linkage (to avoid another error). - shift (@optionlist) - if @optionlist && ref($optionlist[0]); - next; - } - $linkage{'<>'} = shift (@optionlist); - next; - } - - # Parse option spec. - my ($name, $orig) = ParseOptionSpec ($opt, \%opctl); - unless ( defined $name ) { - # Failed. $orig contains the error message. Sorry for the abuse. - $error .= $orig; - # Kill the linkage (to avoid another error). - shift (@optionlist) - if @optionlist && ref($optionlist[0]); - next; - } - - # If no linkage is supplied in the @optionlist, copy it from - # the userlinkage if available. - if ( defined $userlinkage ) { - unless ( @optionlist > 0 && ref($optionlist[0]) ) { - if ( exists $userlinkage->{$orig} && - ref($userlinkage->{$orig}) ) { - print STDERR ("=> found userlinkage for \"$orig\": ", - "$userlinkage->{$orig}\n") - if $debug; - unshift (@optionlist, $userlinkage->{$orig}); - } - else { - # Do nothing. Being undefined will be handled later. - next; - } - } - } - - # Copy the linkage. If omitted, link to global variable. - if ( @optionlist > 0 && ref($optionlist[0]) ) { - print STDERR ("=> link \"$orig\" to $optionlist[0]\n") - if $debug; - my $rl = ref($linkage{$orig} = shift (@optionlist)); - - if ( $rl eq "ARRAY" ) { - $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY; - } - elsif ( $rl eq "HASH" ) { - $opctl{$name}[CTL_DEST] = CTL_DEST_HASH; - } - elsif ( $rl eq "SCALAR" ) { -# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { -# my $t = $linkage{$orig}; -# $$t = $linkage{$orig} = []; -# } -# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { -# } -# else { - # Ok. -# } - } - elsif ( $rl eq "CODE" ) { - # Ok. - } - else { - $error .= "Invalid option linkage for \"$opt\"\n"; - } - } - else { - # Link to global $opt_XXX variable. - # Make sure a valid perl identifier results. - my $ov = $orig; - $ov =~ s/\W/_/g; - if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { - print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n") - if $debug; - eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;"); - } - elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { - print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n") - if $debug; - eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;"); - } - else { - print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n") - if $debug; - eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;"); - } - } - } - - # Bail out if errors found. - die ($error) if $error; - $error = 0; - - # Supply --version and --help support, if needed and allowed. - if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) { - if ( !defined($opctl{version}) ) { - $opctl{version} = ['','version',0,CTL_DEST_CODE,undef]; - $linkage{version} = \&VersionMessage; - } - $auto_version = 1; - } - if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) { - if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) { - $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef]; - $linkage{help} = \&HelpMessage; - } - $auto_help = 1; - } - - # Show the options tables if debugging. - if ( $debug ) { - my ($arrow, $k, $v); - $arrow = "=> "; - while ( ($k,$v) = each(%opctl) ) { - print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n"); - $arrow = " "; - } - } - - # Process argument list - my $goon = 1; - while ( $goon && @ARGV > 0 ) { - - # Get next argument. - $opt = shift (@ARGV); - print STDERR ("=> arg \"", $opt, "\"\n") if $debug; - - # Double dash is option list terminator. - if ( $opt eq $argend ) { - push (@ret, $argend) if $passthrough; - last; - } - - # Look it up. - my $tryopt = $opt; - my $found; # success status - my $key; # key (if hash type) - my $arg; # option argument - my $ctl; # the opctl entry - - ($found, $opt, $ctl, $arg, $key) = - FindOption ($prefix, $argend, $opt, \%opctl); - - if ( $found ) { - - # FindOption undefines $opt in case of errors. - next unless defined $opt; - - my $argcnt = 0; - while ( defined $arg ) { - - # Get the canonical name. - print STDERR ("=> cname for \"$opt\" is ") if $debug; - $opt = $ctl->[CTL_CNAME]; - print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug; - - if ( defined $linkage{$opt} ) { - print STDERR ("=> ref(\$L{$opt}) -> ", - ref($linkage{$opt}), "\n") if $debug; - - if ( ref($linkage{$opt}) eq 'SCALAR' ) { - if ( $ctl->[CTL_TYPE] eq '+' ) { - print STDERR ("=> \$\$L{$opt} += \"$arg\"\n") - if $debug; - if ( defined ${$linkage{$opt}} ) { - ${$linkage{$opt}} += $arg; - } - else { - ${$linkage{$opt}} = $arg; - } - } - elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { - print STDERR ("=> ref(\$L{$opt}) auto-vivified", - " to ARRAY\n") - if $debug; - my $t = $linkage{$opt}; - $$t = $linkage{$opt} = []; - print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") - if $debug; - push (@{$linkage{$opt}}, $arg); - } - elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { - print STDERR ("=> ref(\$L{$opt}) auto-vivified", - " to HASH\n") - if $debug; - my $t = $linkage{$opt}; - $$t = $linkage{$opt} = {}; - print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") - if $debug; - $linkage{$opt}->{$key} = $arg; - } - else { - print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") - if $debug; - ${$linkage{$opt}} = $arg; - } - } - elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { - print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") - if $debug; - push (@{$linkage{$opt}}, $arg); - } - elsif ( ref($linkage{$opt}) eq 'HASH' ) { - print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") - if $debug; - $linkage{$opt}->{$key} = $arg; - } - elsif ( ref($linkage{$opt}) eq 'CODE' ) { - print STDERR ("=> &L{$opt}(\"$opt\"", - $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "", - ", \"$arg\")\n") - if $debug; - my $eval_error = do { - local $@; - local $SIG{__DIE__} = '__DEFAULT__'; - eval { - &{$linkage{$opt}}($opt, - $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (), - $arg); - }; - $@; - }; - print STDERR ("=> die($eval_error)\n") - if $debug && $eval_error ne ''; - if ( $eval_error =~ /^!/ ) { - if ( $eval_error =~ /^!FINISH\b/ ) { - $goon = 0; - } - } - elsif ( $eval_error ne '' ) { - warn ($eval_error); - $error++; - } - } - else { - print STDERR ("Invalid REF type \"", ref($linkage{$opt}), - "\" in linkage\n"); - die("Getopt::Long -- internal error!\n"); - } - } - # No entry in linkage means entry in userlinkage. - elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { - if ( defined $userlinkage->{$opt} ) { - print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") - if $debug; - push (@{$userlinkage->{$opt}}, $arg); - } - else { - print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") - if $debug; - $userlinkage->{$opt} = [$arg]; - } - } - elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { - if ( defined $userlinkage->{$opt} ) { - print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") - if $debug; - $userlinkage->{$opt}->{$key} = $arg; - } - else { - print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n") - if $debug; - $userlinkage->{$opt} = {$key => $arg}; - } - } - else { - if ( $ctl->[CTL_TYPE] eq '+' ) { - print STDERR ("=> \$L{$opt} += \"$arg\"\n") - if $debug; - if ( defined $userlinkage->{$opt} ) { - $userlinkage->{$opt} += $arg; - } - else { - $userlinkage->{$opt} = $arg; - } - } - else { - print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; - $userlinkage->{$opt} = $arg; - } - } - - $argcnt++; - last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1; - undef($arg); - - # Need more args? - if ( $argcnt < $ctl->[CTL_AMIN] ) { - if ( @ARGV ) { - if ( ValidValue($ctl, $ARGV[0], 1, $argend, $prefix) ) { - $arg = shift(@ARGV); - ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ - if $ctl->[CTL_DEST] == CTL_DEST_HASH; - next; - } - warn("Value \"$ARGV[0]\" invalid for option $opt\n"); - $error++; - } - else { - warn("Insufficient arguments for option $opt\n"); - $error++; - } - } - - # Any more args? - if ( @ARGV && ValidValue($ctl, $ARGV[0], 0, $argend, $prefix) ) { - $arg = shift(@ARGV); - ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ - if $ctl->[CTL_DEST] == CTL_DEST_HASH; - next; - } - } - } - - # Not an option. Save it if we $PERMUTE and don't have a <>. - elsif ( $order == $PERMUTE ) { - # Try non-options call-back. - my $cb; - if ( (defined ($cb = $linkage{'<>'})) ) { - print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n") - if $debug; - my $eval_error = do { - local $@; - local $SIG{__DIE__} = '__DEFAULT__'; - eval { &$cb ($tryopt) }; - $@; - }; - print STDERR ("=> die($eval_error)\n") - if $debug && $eval_error ne ''; - if ( $eval_error =~ /^!/ ) { - if ( $eval_error =~ /^!FINISH\b/ ) { - $goon = 0; - } - } - elsif ( $eval_error ne '' ) { - warn ($eval_error); - $error++; - } - } - else { - print STDERR ("=> saving \"$tryopt\" ", - "(not an option, may permute)\n") if $debug; - push (@ret, $tryopt); - } - next; - } - - # ...otherwise, terminate. - else { - # Push this one back and exit. - unshift (@ARGV, $tryopt); - return ($error == 0); - } - - } - - # Finish. - if ( @ret && $order == $PERMUTE ) { - # Push back accumulated arguments - print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") - if $debug; - unshift (@ARGV, @ret); - } - - return ($error == 0); -} - -# A readable representation of what's in an optbl. -sub OptCtl ($) { - my ($v) = @_; - my @v = map { defined($_) ? ($_) : ("") } @$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/installer/perllib/Getopt/Std.pm b/Master/tlpkg/installer/perllib/Getopt/Std.pm deleted file mode 100644 index 99f93590622..00000000000 --- a/Master/tlpkg/installer/perllib/Getopt/Std.pm +++ /dev/null @@ -1,294 +0,0 @@ -package Getopt::Std; -require 5.000; -require Exporter; - -=head1 NAME - -getopt, getopts - Process single-character switches with switch clustering - -=head1 SYNOPSIS - - use Getopt::Std; - - getopt('oDI'); # -o, -D & -I take arg. Sets $opt_* as a side effect. - getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts - getopts('oif:'); # -o & -i are boolean flags, -f takes an argument - # Sets $opt_* as a side effect. - getopts('oif:', \%opts); # options as above. Values in %opts - -=head1 DESCRIPTION - -The getopt() function processes single-character switches with switch -clustering. Pass one argument which is a string containing all switches -that take an argument. For each switch found, sets $opt_x (where x is the -switch name) to the value of the argument if an argument is expected, -or 1 otherwise. Switches which take an argument don't care whether -there is a space between the switch and the argument. - -The getopts() function is similar, but you should pass to it the list of all -switches to be recognized. If unspecified switches are found on the -command-line, the user will be warned that an unknown option was given. - -Note that, if your code is running under the recommended C 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/installer/perllib/IO.pm b/Master/tlpkg/installer/perllib/IO.pm deleted file mode 100644 index 9fccc3a7356..00000000000 --- a/Master/tlpkg/installer/perllib/IO.pm +++ /dev/null @@ -1,68 +0,0 @@ -# - -package IO; - -use XSLoader (); -use Carp; -use strict; -use warnings; - -our $VERSION = "1.22"; -XSLoader::load 'IO', $VERSION; - -sub import { - shift; - - warnings::warnif('deprecated', qq{Parameterless "use IO" deprecated}) - if @_ == 0 ; - - my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir); - - eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l) - or croak $@; -} - -1; - -__END__ - -=head1 NAME - -IO - load various IO modules - -=head1 SYNOPSIS - - use IO qw(Handle File); # loads IO modules, here IO::Handle, IO::File - use IO; # DEPRECATED - -=head1 DESCRIPTION - -C provides a simple mechanism to load several of the IO modules -in one go. The IO modules belonging to the core are: - - IO::Handle - IO::Seekable - IO::File - IO::Pipe - IO::Socket - IO::Dir - IO::Select - IO::Poll - -Some other IO modules don't belong to the perl core but can be loaded -as well if they have been installed from CPAN. You can discover which -ones exist by searching for "^IO::" on http://search.cpan.org. - -For more information on any of these modules, please see its respective -documentation. - -=head1 DEPRECATED - - use IO; # loads all the modules listed below - -The loaded modules are IO::Handle, IO::Seekable, IO::File, IO::Pipe, -IO::Socket, IO::Dir. You should instead explicitly import the IO -modules you want. - -=cut - diff --git a/Master/tlpkg/installer/perllib/IO/Dir.pm b/Master/tlpkg/installer/perllib/IO/Dir.pm deleted file mode 100644 index fccd02c088a..00000000000 --- a/Master/tlpkg/installer/perllib/IO/Dir.pm +++ /dev/null @@ -1,246 +0,0 @@ -# IO::Dir.pm -# -# Copyright (c) 1997-8 Graham Barr . 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/installer/perllib/IO/File.pm b/Master/tlpkg/installer/perllib/IO/File.pm deleted file mode 100644 index e7cdbbed6d7..00000000000 --- a/Master/tlpkg/installer/perllib/IO/File.pm +++ /dev/null @@ -1,208 +0,0 @@ -# - -package IO::File; - -=head1 NAME - -IO::File - supply object methods for filehandles - -=head1 SYNOPSIS - - use IO::File; - - $fh = new IO::File; - if ($fh->open("< file")) { - print <$fh>; - $fh->close; - } - - $fh = new IO::File "> file"; - if (defined $fh) { - print $fh "bar\n"; - $fh->close; - } - - $fh = new IO::File "file", "r"; - if (defined $fh) { - print <$fh>; - undef $fh; # automatically closes the file - } - - $fh = new IO::File "file", O_WRONLY|O_APPEND; - if (defined $fh) { - print $fh "corge\n"; - - $pos = $fh->getpos; - $fh->setpos($pos); - - undef $fh; # automatically closes the file - } - - autoflush STDOUT 1; - -=head1 DESCRIPTION - -C 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/installer/perllib/IO/Handle.pm b/Master/tlpkg/installer/perllib/IO/Handle.pm deleted file mode 100644 index 329d26ad198..00000000000 --- a/Master/tlpkg/installer/perllib/IO/Handle.pm +++ /dev/null @@ -1,625 +0,0 @@ -package IO::Handle; - -=head1 NAME - -IO::Handle - supply object methods for I/O handles - -=head1 SYNOPSIS - - use IO::Handle; - - $io = new IO::Handle; - if ($io->fdopen(fileno(STDIN),"r")) { - print $io->getline; - $io->close; - } - - $io = new IO::Handle; - if ($io->fdopen(fileno(STDOUT),"w")) { - $io->print("Some text\n"); - } - - # setvbuf is not available by default on Perls 5.8.0 and later. - use IO::Handle '_IOLBF'; - $io->setvbuf($buffer_var, _IOLBF, 1024); - - undef $io; # automatically closes the file if it's open - - autoflush STDOUT 1; - -=head1 DESCRIPTION - -C 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/installer/perllib/IO/Pipe.pm b/Master/tlpkg/installer/perllib/IO/Pipe.pm deleted file mode 100644 index 827cc48bfcd..00000000000 --- a/Master/tlpkg/installer/perllib/IO/Pipe.pm +++ /dev/null @@ -1,257 +0,0 @@ -# IO::Pipe.pm -# -# Copyright (c) 1996-8 Graham Barr . 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/installer/perllib/IO/Poll.pm b/Master/tlpkg/installer/perllib/IO/Poll.pm deleted file mode 100644 index e7fb0135069..00000000000 --- a/Master/tlpkg/installer/perllib/IO/Poll.pm +++ /dev/null @@ -1,209 +0,0 @@ - -# IO::Poll.pm -# -# Copyright (c) 1997-8 Graham Barr . 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/installer/perllib/IO/Seekable.pm b/Master/tlpkg/installer/perllib/IO/Seekable.pm deleted file mode 100644 index db1effda287..00000000000 --- a/Master/tlpkg/installer/perllib/IO/Seekable.pm +++ /dev/null @@ -1,128 +0,0 @@ -# - -package IO::Seekable; - -=head1 NAME - -IO::Seekable - supply seek based methods for I/O objects - -=head1 SYNOPSIS - - use IO::Seekable; - package IO::Something; - @ISA = qw(IO::Seekable); - -=head1 DESCRIPTION - -C 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/installer/perllib/IO/Select.pm b/Master/tlpkg/installer/perllib/IO/Select.pm deleted file mode 100644 index fc05fe70e9c..00000000000 --- a/Master/tlpkg/installer/perllib/IO/Select.pm +++ /dev/null @@ -1,381 +0,0 @@ -# IO::Select.pm -# -# Copyright (c) 1997-8 Graham Barr . All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Select; - -use strict; -use warnings::register; -use vars qw($VERSION @ISA); -require Exporter; - -$VERSION = "1.17"; - -@ISA = qw(Exporter); # This is only so we can do version checking - -sub VEC_BITS () {0} -sub FD_COUNT () {1} -sub FIRST_FD () {2} - -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - - my $vec = bless [undef,0], $type; - - $vec->add(@_) - if @_; - - $vec; -} - -sub add -{ - shift->_update('add', @_); -} - - -sub remove -{ - shift->_update('remove', @_); -} - - -sub exists -{ - my $vec = shift; - my $fno = $vec->_fileno(shift); - return undef unless defined $fno; - $vec->[$fno + FIRST_FD]; -} - - -sub _fileno -{ - my($self, $f) = @_; - return unless defined $f; - $f = $f->[0] if ref($f) eq 'ARRAY'; - ($f =~ /^\d+$/) ? $f : fileno($f); -} - -sub _update -{ - my $vec = shift; - my $add = shift eq 'add'; - - my $bits = $vec->[VEC_BITS]; - $bits = '' unless defined $bits; - - my $count = 0; - my $f; - foreach $f (@_) - { - my $fn = $vec->_fileno($f); - next unless defined $fn; - my $i = $fn + FIRST_FD; - if ($add) { - if (defined $vec->[$i]) { - $vec->[$i] = $f; # if array rest might be different, so we update - next; - } - $vec->[FD_COUNT]++; - vec($bits, $fn, 1) = 1; - $vec->[$i] = $f; - } else { # remove - next unless defined $vec->[$i]; - $vec->[FD_COUNT]--; - vec($bits, $fn, 1) = 0; - $vec->[$i] = undef; - } - $count++; - } - $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; - $count; -} - -sub can_read -{ - my $vec = shift; - my $timeout = shift; - my $r = $vec->[VEC_BITS]; - - defined($r) && (select($r,undef,undef,$timeout) > 0) - ? handles($vec, $r) - : (); -} - -sub can_write -{ - my $vec = shift; - my $timeout = shift; - my $w = $vec->[VEC_BITS]; - - defined($w) && (select(undef,$w,undef,$timeout) > 0) - ? handles($vec, $w) - : (); -} - -sub has_exception -{ - my $vec = shift; - my $timeout = shift; - my $e = $vec->[VEC_BITS]; - - defined($e) && (select(undef,undef,$e,$timeout) > 0) - ? handles($vec, $e) - : (); -} - -sub has_error -{ - warnings::warn("Call to deprecated method 'has_error', use 'has_exception'") - if warnings::enabled(); - goto &has_exception; -} - -sub count -{ - my $vec = shift; - $vec->[FD_COUNT]; -} - -sub bits -{ - my $vec = shift; - $vec->[VEC_BITS]; -} - -sub as_string # for debugging -{ - my $vec = shift; - my $str = ref($vec) . ": "; - my $bits = $vec->bits; - my $count = $vec->count; - $str .= defined($bits) ? unpack("b*", $bits) : "undef"; - $str .= " $count"; - my @handles = @$vec; - splice(@handles, 0, FIRST_FD); - for (@handles) { - $str .= " " . (defined($_) ? "$_" : "-"); - } - $str; -} - -sub _max -{ - my($a,$b,$c) = @_; - $a > $b - ? $a > $c - ? $a - : $c - : $b > $c - ? $b - : $c; -} - -sub select -{ - shift - if defined $_[0] && !ref($_[0]); - - my($r,$w,$e,$t) = @_; - my @result = (); - - my $rb = defined $r ? $r->[VEC_BITS] : undef; - my $wb = defined $w ? $w->[VEC_BITS] : undef; - my $eb = defined $e ? $e->[VEC_BITS] : undef; - - if(select($rb,$wb,$eb,$t) > 0) - { - my @r = (); - my @w = (); - my @e = (); - my $i = _max(defined $r ? scalar(@$r)-1 : 0, - defined $w ? scalar(@$w)-1 : 0, - defined $e ? scalar(@$e)-1 : 0); - - for( ; $i >= FIRST_FD ; $i--) - { - my $j = $i - FIRST_FD; - push(@r, $r->[$i]) - if defined $rb && defined $r->[$i] && vec($rb, $j, 1); - push(@w, $w->[$i]) - if defined $wb && defined $w->[$i] && vec($wb, $j, 1); - push(@e, $e->[$i]) - if defined $eb && defined $e->[$i] && vec($eb, $j, 1); - } - - @result = (\@r, \@w, \@e); - } - @result; -} - - -sub handles -{ - my $vec = shift; - my $bits = shift; - my @h = (); - my $i; - my $max = scalar(@$vec) - 1; - - for ($i = FIRST_FD; $i <= $max; $i++) - { - next unless defined $vec->[$i]; - push(@h, $vec->[$i]) - if !defined($bits) || vec($bits, $i - FIRST_FD, 1); - } - - @h; -} - -1; -__END__ - -=head1 NAME - -IO::Select - OO interface to the select system call - -=head1 SYNOPSIS - - use IO::Select; - - $s = IO::Select->new(); - - $s->add(\*STDIN); - $s->add($some_handle); - - @ready = $s->can_read($timeout); - - @ready = IO::Select->new(@handles)->can_read(0); - -=head1 DESCRIPTION - -The C package implements an object approach to the system C static method. - -=item bits() - -Return the bit string suitable as argument to the core select() call. - -=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] ) - -C method. - -Some HTML escapes are missing and many have not been tested. - -=head1 SEE ALSO - -L, L, L - -=head1 AUTHORS - -Tim Jenness Etjenness@cpan.orgE - -Bug fixes and improvements have been received from: Simon Cozens -Esimon@cozens.netE, Mark A. Hershberger -Emah@everybody.orgE, Marcel Grunauer -Emarcel@codewerk.comE, Hugh S Myers -Ehsmyers@sdragons.comE, Peter J Acklam -Ejacklam@math.uio.noE, Sudhi Herle Esudhi@herle.netE, -Ariel Scolnicov Eariels@compugen.co.ilE, -Adriano Rodrigues Ferreira Eferreira@triang.com.brE and -R. de Vries Er.de.vries@dutchspace.nlE. - - -=head1 COPYRIGHT - -Copyright (C) 2000-2004 Tim Jenness. All Rights Reserved. - -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=begin __PRIVATE__ - -=head1 REVISION - -$Id: LaTeX.pm,v 1.19 2004/12/30 01:40:44 timj Exp $ - -=end __PRIVATE__ - -=cut - -1; diff --git a/Master/tlpkg/installer/perllib/Pod/Man.pm b/Master/tlpkg/installer/perllib/Pod/Man.pm deleted file mode 100644 index 693e4c46896..00000000000 --- a/Master/tlpkg/installer/perllib/Pod/Man.pm +++ /dev/null @@ -1,1413 +0,0 @@ -# Pod::Man -- Convert POD data to formatted *roff input. -# $Id: Man.pm,v 1.37 2003/03/30 22:34:11 eagle Exp $ -# -# Copyright 1999, 2000, 2001, 2002, 2003 by Russ Allbery -# -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. -# -# This module translates POD documentation into *roff markup using the man -# macro set, and is intended for converting POD documents written as Unix -# manual pages to manual pages that can be read by the man(1) command. It is -# a replacement for the pod2man command distributed with versions of Perl -# prior to 5.6. -# -# Perl core hackers, please note that this module is also separately -# maintained outside of the Perl core as part of the podlators. Please send -# me any patches at the address above in addition to sending them to the -# standard Perl mailing lists. - -############################################################################## -# Modules and declarations -############################################################################## - -package Pod::Man; - -require 5.005; - -use Carp qw(carp croak); -use Pod::ParseLink qw(parselink); -use Pod::Parser (); - -use strict; -use subs qw(makespace); -use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); - -@ISA = qw(Pod::Parser); - -# Don't use the CVS revision as the version, since this module is also in Perl -# core and too many things could munge CVS magic revision strings. This -# number should ideally be the same as the CVS revision in podlators, however. -$VERSION = 1.37; - - -############################################################################## -# Preamble and *roff output tables -############################################################################## - -# The following is the static preamble which starts all *roff output we -# generate. It's completely static except for the font to use as a -# fixed-width font, which is designed by @CFONT@, and the left and right -# quotes to use for C<> text, designated by @LQOUTE@ and @RQUOTE@. $PREAMBLE -# should therefore be run through s/\@CFONT\@//g before output. -$PREAMBLE = <<'----END OF PREAMBLE----'; -.de Sh \" Subsection heading -.br -.if t .Sp -.ne 5 -.PP -\fB\\$1\fR -.PP -.. -.de Sp \" Vertical space (when we can't use .PP) -.if t .sp .5v -.if n .sp -.. -.de Vb \" Begin verbatim text -.ft @CFONT@ -.nf -.ne \\$1 -.. -.de Ve \" End verbatim text -.ft R -.fi -.. -.\" Set up some character translations and predefined strings. \*(-- will -.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left -.\" double quote, and \*(R" will give a right double quote. \*(C+ will -.\" give a nicer C++. Capital omega is used to do unbreakable dashes and -.\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff, -.\" nothing in troff, for use with C<>. -.tr \(*W- -.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' -.ie n \{\ -. ds -- \(*W- -. ds PI pi -. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch -. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch -. ds L" "" -. ds R" "" -. ds C` @LQUOTE@ -. ds C' @RQUOTE@ -'br\} -.el\{\ -. ds -- \|\(em\| -. ds PI \(*p -. ds L" `` -. ds R" '' -'br\} -.\" -.\" If the F register is turned on, we'll generate index entries on stderr for -.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index -.\" entries marked with X<> in POD. Of course, you'll have to process the -.\" output yourself in some meaningful fashion. -.if \nF \{\ -. de IX -. tm Index:\\$1\t\\n%\t"\\$2" -.. -. nr % 0 -. rr F -.\} -.\" -.\" For nroff, turn off justification. Always turn off hyphenation; it makes -.\" way too many mistakes in technical documents. -.hy 0 -.if n .na -.\" -.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). -.\" Fear. Run. Save yourself. No user-serviceable parts. -. \" fudge factors for nroff and troff -.if n \{\ -. ds #H 0 -. ds #V .8m -. ds #F .3m -. ds #[ \f1 -. ds #] \fP -.\} -.if t \{\ -. ds #H ((1u-(\\\\n(.fu%2u))*.13m) -. ds #V .6m -. ds #F 0 -. ds #[ \& -. ds #] \& -.\} -. \" simple accents for nroff and troff -.if n \{\ -. ds ' \& -. ds ` \& -. ds ^ \& -. ds , \& -. ds ~ ~ -. ds / -.\} -.if t \{\ -. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" -. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' -. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' -. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' -. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' -. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' -.\} -. \" troff and (daisy-wheel) nroff accents -.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' -.ds 8 \h'\*(#H'\(*b\h'-\*(#H' -.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] -.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' -.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' -.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] -.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] -.ds ae a\h'-(\w'a'u*4/10)'e -.ds Ae A\h'-(\w'A'u*4/10)'E -. \" corrections for vroff -.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' -.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' -. \" for low resolution devices (crt and lpr) -.if \n(.H>23 .if \n(.V>19 \ -\{\ -. ds : e -. ds 8 ss -. ds o a -. ds d- d\h'-1'\(ga -. ds D- D\h'-1'\(hy -. ds th \o'bp' -. ds Th \o'LP' -. ds ae ae -. ds Ae AE -.\} -.rm #[ #] #H #V #F C -----END OF PREAMBLE---- -#`# for cperl-mode - -# This table is taken nearly verbatim from Tom Christiansen's pod2man. It -# assumes that the standard preamble has already been printed, since that's -# what defines all of the accent marks. Note that some of these are quoted -# with double quotes since they contain embedded single quotes, so use \\ -# uniformly for backslash for readability. -%ESCAPES = ( - 'amp' => '&', # ampersand - 'apos' => "'", # apostrophe - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - 'sol' => '/', # solidus (forward slash) - 'verbar' => '|', # vertical bar - - 'Aacute' => "A\\*'", # capital A, acute accent - 'aacute' => "a\\*'", # small a, acute accent - 'Acirc' => 'A\\*^', # capital A, circumflex accent - 'acirc' => 'a\\*^', # small a, circumflex accent - 'AElig' => '\*(AE', # capital AE diphthong (ligature) - 'aelig' => '\*(ae', # small ae diphthong (ligature) - 'Agrave' => "A\\*`", # capital A, grave accent - 'agrave' => "A\\*`", # small a, grave accent - 'Aring' => 'A\\*o', # capital A, ring - 'aring' => 'a\\*o', # small a, ring - 'Atilde' => 'A\\*~', # capital A, tilde - 'atilde' => 'a\\*~', # small a, tilde - 'Auml' => 'A\\*:', # capital A, dieresis or umlaut mark - 'auml' => 'a\\*:', # small a, dieresis or umlaut mark - 'Ccedil' => 'C\\*,', # capital C, cedilla - 'ccedil' => 'c\\*,', # small c, cedilla - 'Eacute' => "E\\*'", # capital E, acute accent - 'eacute' => "e\\*'", # small e, acute accent - 'Ecirc' => 'E\\*^', # capital E, circumflex accent - 'ecirc' => 'e\\*^', # small e, circumflex accent - 'Egrave' => 'E\\*`', # capital E, grave accent - 'egrave' => 'e\\*`', # small e, grave accent - 'ETH' => '\\*(D-', # capital Eth, Icelandic - 'eth' => '\\*(d-', # small eth, Icelandic - 'Euml' => 'E\\*:', # capital E, dieresis or umlaut mark - 'euml' => 'e\\*:', # small e, dieresis or umlaut mark - 'Iacute' => "I\\*'", # capital I, acute accent - 'iacute' => "i\\*'", # small i, acute accent - 'Icirc' => 'I\\*^', # capital I, circumflex accent - 'icirc' => 'i\\*^', # small i, circumflex accent - 'Igrave' => 'I\\*`', # capital I, grave accent - 'igrave' => 'i\\*`', # small i, grave accent - 'Iuml' => 'I\\*:', # capital I, dieresis or umlaut mark - 'iuml' => 'i\\*:', # small i, dieresis or umlaut mark - 'Ntilde' => 'N\*~', # capital N, tilde - 'ntilde' => 'n\*~', # small n, tilde - 'Oacute' => "O\\*'", # capital O, acute accent - 'oacute' => "o\\*'", # small o, acute accent - 'Ocirc' => 'O\\*^', # capital O, circumflex accent - 'ocirc' => 'o\\*^', # small o, circumflex accent - 'Ograve' => 'O\\*`', # capital O, grave accent - 'ograve' => 'o\\*`', # small o, grave accent - 'Oslash' => 'O\\*/', # capital O, slash - 'oslash' => 'o\\*/', # small o, slash - 'Otilde' => 'O\\*~', # capital O, tilde - 'otilde' => 'o\\*~', # small o, tilde - 'Ouml' => 'O\\*:', # capital O, dieresis or umlaut mark - 'ouml' => 'o\\*:', # small o, dieresis or umlaut mark - 'szlig' => '\*8', # small sharp s, German (sz ligature) - 'THORN' => '\\*(Th', # capital THORN, Icelandic - 'thorn' => '\\*(th', # small thorn, Icelandic - 'Uacute' => "U\\*'", # capital U, acute accent - 'uacute' => "u\\*'", # small u, acute accent - 'Ucirc' => 'U\\*^', # capital U, circumflex accent - 'ucirc' => 'u\\*^', # small u, circumflex accent - 'Ugrave' => 'U\\*`', # capital U, grave accent - 'ugrave' => 'u\\*`', # small u, grave accent - 'Uuml' => 'U\\*:', # capital U, dieresis or umlaut mark - 'uuml' => 'u\\*:', # small u, dieresis or umlaut mark - 'Yacute' => "Y\\*'", # capital Y, acute accent - 'yacute' => "y\\*'", # small y, acute accent - 'yuml' => 'y\\*:', # small y, dieresis or umlaut mark - - 'nbsp' => '\\ ', # non-breaking space - 'shy' => '', # soft (discretionary) hyphen -); - - -############################################################################## -# Static helper functions -############################################################################## - -# Protect leading quotes and periods against interpretation as commands. Also -# protect anything starting with a backslash, since it could expand or hide -# something that *roff would interpret as a command. This is overkill, but -# it's much simpler than trying to parse *roff here. -sub protect { - local $_ = shift; - s/^([.\'\\])/\\&$1/mg; - $_; -} - -# Translate a font string into an escape. -sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] } - - -############################################################################## -# Initialization -############################################################################## - -# Initialize the object. Here, we also process any additional options passed -# to the constructor or set up defaults if none were given. center is the -# centered title, release is the version number, and date is the date for the -# documentation. Note that we can't know what file name we're processing due -# to the architecture of Pod::Parser, so that *has* to either be passed to the -# constructor or set separately with Pod::Man::name(). -sub initialize { - my $self = shift; - - # Figure out the fixed-width font. If user-supplied, make sure that they - # are the right length. - for (qw/fixed fixedbold fixeditalic fixedbolditalic/) { - if (defined $$self{$_}) { - if (length ($$self{$_}) < 1 || length ($$self{$_}) > 2) { - croak qq(roff font should be 1 or 2 chars,) - . qq( not "$$self{$_}"); - } - } else { - $$self{$_} = ''; - } - } - - # Set the default fonts. We can't be sure what fixed bold-italic is going - # to be called, so default to just bold. - $$self{fixed} ||= 'CW'; - $$self{fixedbold} ||= 'CB'; - $$self{fixeditalic} ||= 'CI'; - $$self{fixedbolditalic} ||= 'CB'; - - # Set up a table of font escapes. First number is fixed-width, second is - # bold, third is italic. - $$self{FONTS} = { '000' => '\fR', '001' => '\fI', - '010' => '\fB', '011' => '\f(BI', - '100' => toescape ($$self{fixed}), - '101' => toescape ($$self{fixeditalic}), - '110' => toescape ($$self{fixedbold}), - '111' => toescape ($$self{fixedbolditalic})}; - - # Extra stuff for page titles. - $$self{center} = 'User Contributed Perl Documentation' - unless defined $$self{center}; - $$self{indent} = 4 unless defined $$self{indent}; - - # We used to try first to get the version number from a local binary, but - # we shouldn't need that any more. Get the version from the running Perl. - # Work a little magic to handle subversions correctly under both the - # pre-5.6 and the post-5.6 version numbering schemes. - if (!defined $$self{release}) { - my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/); - $version[2] ||= 0; - $version[2] *= 10 ** (3 - length $version[2]); - for (@version) { $_ += 0 } - $$self{release} = 'perl v' . join ('.', @version); - } - - # Double quotes in things that will be quoted. - for (qw/center date release/) { - $$self{$_} =~ s/\"/\"\"/g if $$self{$_}; - } - - # Figure out what quotes we'll be using for C<> text. - $$self{quotes} ||= '"'; - if ($$self{quotes} eq 'none') { - $$self{LQUOTE} = $$self{RQUOTE} = ''; - } elsif (length ($$self{quotes}) == 1) { - $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes}; - } elsif ($$self{quotes} =~ /^(.)(.)$/ - || $$self{quotes} =~ /^(..)(..)$/) { - $$self{LQUOTE} = $1; - $$self{RQUOTE} = $2; - } else { - croak qq(Invalid quote specification "$$self{quotes}"); - } - - # Double the first quote; note that this should not be s///g as two double - # quotes is represented in *roff as three double quotes, not four. Weird, - # I know. - $$self{LQUOTE} =~ s/\"/\"\"/; - $$self{RQUOTE} =~ s/\"/\"\"/; - - $self->SUPER::initialize; -} - -# For each document we process, output the preamble first. -sub begin_pod { - my $self = shift; - - # Try to figure out the name and section from the file name. - my $section = $$self{section} || 1; - my $name = $$self{name}; - if (!defined $name) { - $name = $self->input_file; - $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i); - $name =~ s/\.p(od|[lm])\z//i; - if ($section !~ /^3/) { - require File::Basename; - $name = uc File::Basename::basename ($name); - } else { - # Assume that we're dealing with a module. We want to figure out - # the full module name from the path to the file, but we don't - # want to include too much of the path into the module name. Lose - # everything up to the first of: - # - # */lib/*perl*/ standard or site_perl module - # */*perl*/lib/ from -Dprefix=/opt/perl - # */*perl*/ random module hierarchy - # - # which works. Also strip off a leading site or site_perl - # component, any OS-specific component, and any version number - # component, and strip off an initial component of "lib" or - # "blib/lib" since that's what ExtUtils::MakeMaker creates. - # splitdir requires at least File::Spec 0.8. - require File::Spec; - my ($volume, $dirs, $file) = File::Spec->splitpath ($name); - my @dirs = File::Spec->splitdir ($dirs); - my $cut = 0; - my $i; - for ($i = 0; $i < scalar @dirs; $i++) { - if ($dirs[$i] eq 'lib' && $dirs[$i + 1] =~ /perl/) { - $cut = $i + 2; - last; - } elsif ($dirs[$i] =~ /perl/) { - $cut = $i + 1; - $cut++ if $dirs[$i + 1] eq 'lib'; - last; - } - } - if ($cut > 0) { - splice (@dirs, 0, $cut); - shift @dirs if ($dirs[0] =~ /^site(_perl)?$/); - shift @dirs if ($dirs[0] =~ /^[\d.]+$/); - shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/); - } - shift @dirs if $dirs[0] eq 'lib'; - splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib'); - - # Remove empty directories when building the module name; they - # occur too easily on Unix by doubling slashes. - $name = join ('::', (grep { $_ ? $_ : () } @dirs), $file); - } - } - - # If $name contains spaces, quote it; this mostly comes up in the case of - # input from stdin. - $name = '"' . $name . '"' if ($name =~ /\s/); - - # Modification date header. Try to use the modification time of our - # input. - if (!defined $$self{date}) { - my $time = (stat $self->input_file)[9] || time; - my ($day, $month, $year) = (localtime $time)[3,4,5]; - $month++; - $year += 1900; - $$self{date} = sprintf ('%4d-%02d-%02d', $year, $month, $day); - } - - # Now, print out the preamble and the title. The meaning of the arguments - # to .TH unfortunately vary by system; some systems consider the fourth - # argument to be a "source" and others use it as a version number. - # Generally it's just presented as the left-side footer, though, so it - # doesn't matter too much if a particular system gives it another - # interpretation. - # - # The order of date and release used to be reversed in older versions of - # this module, but this order is correct for both Solaris and Linux. - local $_ = $PREAMBLE; - s/\@CFONT\@/$$self{fixed}/; - s/\@LQUOTE\@/$$self{LQUOTE}/; - s/\@RQUOTE\@/$$self{RQUOTE}/; - chomp $_; - my $pversion = $Pod::Parser::VERSION; - print { $self->output_handle } <<"----END OF HEADER----"; -.\\" Automatically generated by Pod::Man v$VERSION, Pod::Parser v$pversion -.\\" -.\\" Standard preamble: -.\\" ======================================================================== -$_ -.\\" ======================================================================== -.\\" -.IX Title "$name $section" -.TH $name $section "$$self{date}" "$$self{release}" "$$self{center}" -----END OF HEADER---- - - # Initialize a few per-file variables. - $$self{INDENT} = 0; # Current indentation level. - $$self{INDENTS} = []; # Stack of indentations. - $$self{INDEX} = []; # Index keys waiting to be printed. - $$self{IN_NAME} = 0; # Whether processing the NAME section. - $$self{ITEMS} = 0; # The number of consecutive =items. - $$self{ITEMTYPES} = []; # Stack of =item types, one per list. - $$self{SHIFTWAIT} = 0; # Whether there is a shift waiting. - $$self{SHIFTS} = []; # Stack of .RS shifts. -} - - -############################################################################## -# Core overrides -############################################################################## - -# Called for each command paragraph. Gets the command, the associated -# paragraph, the line number, and a Pod::Paragraph object. Just dispatches -# the command to a method named the same as the command. =cut is handled -# internally by Pod::Parser. -sub command { - my $self = shift; - my $command = shift; - return if $command eq 'pod'; - return if ($$self{EXCLUDE} && $command ne 'end'); - if ($self->can ('cmd_' . $command)) { - $command = 'cmd_' . $command; - $self->$command (@_); - } else { - my ($text, $line, $paragraph) = @_; - my $file; - ($file, $line) = $paragraph->file_line; - $text =~ s/\n+\z//; - $text = " $text" if ($text =~ /^\S/); - warn qq($file:$line: Unknown command paragraph "=$command$text"\n); - return; - } -} - -# Called for a verbatim paragraph. Gets the paragraph, the line number, and a -# Pod::Paragraph object. Rofficate backslashes, untabify, put a zero-width -# character at the beginning of each line to protect against commands, and -# wrap in .Vb/.Ve. -sub verbatim { - my $self = shift; - return if $$self{EXCLUDE}; - local $_ = shift; - return if /^\s+$/; - s/\s+$/\n/; - my $lines = tr/\n/\n/; - 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; - s/\\/\\e/g; - s/-/\\-/g; - s/'/\\(aq/g; - s/^(\s*\S)/'\&' . $1/gme; - $self->makespace; - $self->output (".Vb $lines\n$_.Ve\n"); - $$self{NEEDSPACE} = 1; -} - -# Called for a regular text block. Gets the paragraph, the line number, and a -# Pod::Paragraph object. Perform interpolation and output the results. -sub textblock { - my $self = shift; - return if $$self{EXCLUDE}; - $self->output ($_[0]), return if $$self{VERBATIM}; - - # Parse the tree. collapse knows about references to scalars as well as - # scalars and does the right thing with them. Tidy up any trailing - # whitespace. - my $text = shift; - $text = $self->parse ($text, @_); - $text =~ s/\n\s*$/\n/; - - # Output the paragraph. We also have to handle =over without =item. If - # there's an =over without =item, SHIFTWAIT will be set, and we need to - # handle creation of the indent here. Add the shift to SHIFTS so that it - # will be cleaned up on =back. - $self->makespace; - if ($$self{SHIFTWAIT}) { - $self->output (".RS $$self{INDENT}\n"); - push (@{ $$self{SHIFTS} }, $$self{INDENT}); - $$self{SHIFTWAIT} = 0; - } - $self->output (protect $self->textmapfonts ($text)); - $self->outindex; - $$self{NEEDSPACE} = 1; -} - -# Called for a formatting code. Takes a Pod::InteriorSequence object and -# returns a reference to a scalar. This scalar is the final formatted text. -# It's returned as a reference to an array so that other formatting codes -# above us know that the text has already been processed. -sub sequence { - my ($self, $seq) = @_; - my $command = $seq->cmd_name; - - # We have to defer processing of the inside of an L<> formatting code. If - # this code is nested inside an L<> code, return the literal raw text of - # it. - my $parent = $seq->nested; - while (defined $parent) { - return $seq->raw_text if ($parent->cmd_name eq 'L'); - $parent = $parent->nested; - } - - # Zero-width characters. - return [ '\&' ] if ($command eq 'Z'); - - # C<>, L<>, X<>, and E<> don't apply guesswork to their contents. C<> - # needs some additional special handling. - my $literal = ($command =~ /^[CELX]$/); - local $_ = $self->collapse ($seq->parse_tree, $literal, $command eq 'C'); - - # Handle E<> escapes. Numeric escapes that match one of the supported ISO - # 8859-1 characters don't work at present. - if ($command eq 'E') { - if (/^\d+$/) { - return [ chr ($_) ]; - } elsif (exists $ESCAPES{$_}) { - return [ $ESCAPES{$_} ]; - } else { - my ($file, $line) = $seq->file_line; - warn "$file:$line: Unknown escape E<$_>\n"; - return [ "E<$_>" ]; - } - } - - # For all the other codes, empty content produces no output. - return '' if $_ eq ''; - - # Handle simple formatting codes. - if ($command eq 'B') { - return [ '\f(BS' . $_ . '\f(BE' ]; - } elsif ($command eq 'F' || $command eq 'I') { - return [ '\f(IS' . $_ . '\f(IE' ]; - } elsif ($command eq 'C') { - return [ $self->quote_literal ($_) ]; - } - - # Handle links. - if ($command eq 'L') { - my ($text, $type) = (parselink ($_))[1,4]; - return '' unless $text; - my ($file, $line) = $seq->file_line; - $text = $self->parse ($text, $line); - $text = '<' . $text . '>' if $type eq 'url'; - return [ $text ]; - } - - # Whitespace protection replaces whitespace with "\ ". - if ($command eq 'S') { - s/\s+/\\ /g; - return [ $_ ]; - } - - # Add an index entry to the list of ones waiting to be output. - if ($command eq 'X') { - push (@{ $$self{INDEX} }, $_); - return ''; - } - - # Anything else is unknown. - my ($file, $line) = $seq->file_line; - warn "$file:$line: Unknown formatting code $command<$_>\n"; -} - - -############################################################################## -# Command paragraphs -############################################################################## - -# All command paragraphs take the paragraph and the line number. - -# First level heading. We can't output .IX in the NAME section due to a bug -# in some versions of catman, so don't output a .IX for that section. .SH -# already uses small caps, so remove \s1 and \s-1. Maintain IN_NAME as -# appropriate, but don't leave it set while calling parse() so as to not -# override guesswork on section headings after NAME. -sub cmd_head1 { - my $self = shift; - $$self{IN_NAME} = 0; - local $_ = $self->parse (@_); - s/\s+$//; - s/\\s-?\d//g; - s/\s*\n\s*/ /g; - if ($$self{ITEMS} > 1) { - $$self{ITEMS} = 0; - $self->output (".PD\n"); - } - $self->output ($self->switchquotes ('.SH', $self->mapfonts ($_))); - $self->outindex (($_ eq 'NAME') ? () : ('Header', $_)); - $$self{NEEDSPACE} = 0; - $$self{IN_NAME} = ($_ eq 'NAME'); -} - -# Second level heading. -sub cmd_head2 { - my $self = shift; - local $_ = $self->parse (@_); - s/\s+$//; - s/\s*\n\s*/ /g; - if ($$self{ITEMS} > 1) { - $$self{ITEMS} = 0; - $self->output (".PD\n"); - } - $self->output ($self->switchquotes ('.Sh', $self->mapfonts ($_))); - $self->outindex ('Subsection', $_); - $$self{NEEDSPACE} = 0; -} - -# Third level heading. -sub cmd_head3 { - my $self = shift; - local $_ = $self->parse (@_); - s/\s+$//; - s/\s*\n\s*/ /g; - if ($$self{ITEMS} > 1) { - $$self{ITEMS} = 0; - $self->output (".PD\n"); - } - $self->makespace; - $self->output ($self->textmapfonts ('\f(IS' . $_ . '\f(IE') . "\n"); - $self->outindex ('Subsection', $_); - $$self{NEEDSPACE} = 1; -} - -# Fourth level heading. -sub cmd_head4 { - my $self = shift; - local $_ = $self->parse (@_); - s/\s+$//; - s/\s*\n\s*/ /g; - if ($$self{ITEMS} > 1) { - $$self{ITEMS} = 0; - $self->output (".PD\n"); - } - $self->makespace; - $self->output ($self->textmapfonts ($_) . "\n"); - $self->outindex ('Subsection', $_); - $$self{NEEDSPACE} = 1; -} - -# Start a list. For indents after the first, wrap the outside indent in .RS -# so that hanging paragraph tags will be correct. -sub cmd_over { - my $self = shift; - local $_ = shift; - unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } - if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) { - $self->output (".RS $$self{INDENT}\n"); - push (@{ $$self{SHIFTS} }, $$self{INDENT}); - } - push (@{ $$self{INDENTS} }, $$self{INDENT}); - push (@{ $$self{ITEMTYPES} }, 'unknown'); - $$self{INDENT} = ($_ + 0); - $$self{SHIFTWAIT} = 1; -} - -# End a list. If we've closed an embedded indent, we've mangled the hanging -# paragraph indent, so temporarily replace it with .RS and set WEIRDINDENT. -# We'll close that .RS at the next =back or =item. -sub cmd_back { - my $self = shift; - $$self{INDENT} = pop @{ $$self{INDENTS} }; - if (defined $$self{INDENT}) { - pop @{ $$self{ITEMTYPES} }; - } else { - my ($file, $line, $paragraph) = @_; - ($file, $line) = $paragraph->file_line; - warn "$file:$line: Unmatched =back\n"; - $$self{INDENT} = 0; - } - if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) { - $self->output (".RE\n"); - pop @{ $$self{SHIFTS} }; - } - if (@{ $$self{INDENTS} } > 0) { - $self->output (".RE\n"); - $self->output (".RS $$self{INDENT}\n"); - } - $$self{NEEDSPACE} = 1; - $$self{SHIFTWAIT} = 0; -} - -# An individual list item. Emit an index entry for anything that's -# interesting, but don't emit index entries for things like bullets and -# numbers. rofficate bullets too while we're at it (so for nice output, use * -# for your lists rather than o or . or - or some other thing). Newlines in an -# item title are turned into spaces since *roff can't handle them embedded. -sub cmd_item { - my $self = shift; - local $_ = $self->parse (@_); - s/\s+$//; - s/\s*\n\s*/ /g; - my $index; - if (/\w/ && !/^\w[.\)]\s*$/) { - $index = $_; - $index =~ s/^\s*[-*+o.]?(?:\s+|\Z)//; - } - $_ = '*' unless length ($_) > 0; - my $type = $$self{ITEMTYPES}[0]; - unless (defined $type) { - my ($file, $line, $paragraph) = @_; - ($file, $line) = $paragraph->file_line; - $type = 'unknown'; - } - if ($type eq 'unknown') { - $type = /^\*\s*\Z/ ? 'bullet' : 'text'; - $$self{ITEMTYPES}[0] = $type if $$self{ITEMTYPES}[0]; - } - s/^\*\s*\Z/\\\(bu/ if $type eq 'bullet'; - if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) { - $self->output (".RE\n"); - pop @{ $$self{SHIFTS} }; - } - $_ = $self->textmapfonts ($_); - $self->output (".PD 0\n") if ($$self{ITEMS} == 1); - $self->output ($self->switchquotes ('.IP', $_, $$self{INDENT})); - $self->outindex ($index ? ('Item', $index) : ()); - $$self{NEEDSPACE} = 0; - $$self{ITEMS}++; - $$self{SHIFTWAIT} = 0; -} - -# Begin a block for a particular translator. Setting VERBATIM triggers -# special handling in textblock(). -sub cmd_begin { - my $self = shift; - local $_ = shift; - my ($kind) = /^(\S+)/ or return; - if ($kind eq 'man' || $kind eq 'roff') { - $$self{VERBATIM} = 1; - } else { - $$self{EXCLUDE} = 1; - } -} - -# End a block for a particular translator. We assume that all =begin/=end -# pairs are properly closed. -sub cmd_end { - my $self = shift; - $$self{EXCLUDE} = 0; - $$self{VERBATIM} = 0; -} - -# One paragraph for a particular translator. Ignore it unless it's intended -# for man or roff, in which case we output it verbatim. -sub cmd_for { - my $self = shift; - local $_ = shift; - return unless s/^(?:man|roff)\b[ \t]*\n?//; - $self->output ($_); -} - - -############################################################################## -# Escaping and fontification -############################################################################## - -# At this point, we'll have embedded font codes of the form \f([SE] -# where is one of B, I, or F. Turn those into the right font start or -# end codes. The old pod2man didn't get B else> right; after I<> -# it switched back to normal text rather than bold. We take care of this by -# using variables as a combined pointer to our current font sequence, and set -# each to the number of current nestings of start tags for that font. Use -# them as a vector to look up what font sequence to use. -# -# \fP changes to the previous font, but only one previous font is kept. We -# don't know what the outside level font is; normally it's R, but if we're -# inside a heading it could be something else. So arrange things so that the -# outside font is always the "previous" font and end with \fP instead of \fR. -# Idea from Zack Weinberg. -sub mapfonts { - my $self = shift; - local $_ = shift; - - my ($fixed, $bold, $italic) = (0, 0, 0); - my %magic = (F => \$fixed, B => \$bold, I => \$italic); - my $last = '\fR'; - s { \\f\((.)(.) } { - my $sequence = ''; - my $f; - if ($last ne '\fR') { $sequence = '\fP' } - ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; - $f = $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)}; - if ($f eq $last) { - ''; - } else { - if ($f ne '\fR') { $sequence .= $f } - $last = $f; - $sequence; - } - }gxe; - $_; -} - -# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU -# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather -# than R, presumably because \f(CW doesn't actually do a font change. To work -# around this, use a separate textmapfonts for text blocks where the default -# font is always R and only use the smart mapfonts for headings. -sub textmapfonts { - my $self = shift; - local $_ = shift; - - my ($fixed, $bold, $italic) = (0, 0, 0); - my %magic = (F => \$fixed, B => \$bold, I => \$italic); - s { \\f\((.)(.) } { - ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; - $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)}; - }gxe; - $_; -} - - -############################################################################## -# *roff-specific parsing and magic -############################################################################## - -# Called instead of parse_text, calls parse_text with the right flags. -sub parse { - my $self = shift; - $self->parse_text ({ -expand_seq => 'sequence', - -expand_ptree => 'collapse' }, @_); -} - -# Takes a parse tree, a flag saying whether or not to treat it as literal text -# (not call guesswork on it), and a flag saying whether or not to clean some -# things up for *roff, and returns the concatenation of all of the text -# strings in that parse tree. If the literal flag isn't true, guesswork() -# will be called on all plain scalars in the parse tree. Otherwise, if -# collapse is being called on a C<> code, $cleanup should be set to true and -# some additional cleanup will be done. Assumes that everything in the parse -# tree is either a scalar or a reference to a scalar. -sub collapse { - my ($self, $ptree, $literal, $cleanup) = @_; - - # If we're processing the NAME section, don't do normal guesswork. This - # is because NAME lines are often extracted by utilities like catman that - # require plain text and don't understand *roff markup. We still need to - # escape backslashes and hyphens for *roff (and catman expects \- instead - # of -). - if ($$self{IN_NAME}) { - $literal = 1; - $cleanup = 1; - } - - # Do the collapse of the parse tree as described above. - return join ('', map { - if (ref $_) { - join ('', @$_); - } elsif ($literal) { - if ($cleanup) { - s/\\/\\e/g; - s/-/\\-/g; - s/__/_\\|_/g; - } - $_; - } else { - $self->guesswork ($_); - } - } $ptree->children); -} - -# Takes a text block to perform guesswork on; this is guaranteed not to -# contain any formatting codes. Returns the text block with remapping done. -sub guesswork { - my $self = shift; - local $_ = shift; - - # rofficate backslashes. - s/\\/\\e/g; - - # Ensure double underbars have a tiny space between them. - s/__/_\\|_/g; - - # Leave hyphens only if they're part of regular words and there is only - # one dash at a time. Leave a dash after the first character as a regular - # non-breaking dash, but don't let it mark the rest of the word invalid - # for hyphenation. - s/-/\\-/g; - s{ - ( (?:\G|^|\s) [a-zA-Z] ) ( \\- )? - ( (?: [a-zA-Z]+ \\-)+ ) - ( [a-zA-Z]+ ) (?=\s|\Z) - \b - } { - my ($prefix, $hyphen, $main, $suffix) = ($1, $2, $3, $4); - $hyphen ||= ''; - $main =~ s/\\-/-/g; - $prefix . $hyphen . $main . $suffix; - }egx; - - # Translate -- into a real em dash if it's used like one. - s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx; - s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx; - - # Make all caps a little smaller. Be careful here, since we don't want to - # make @ARGV into small caps, nor do we want to fix the MIME in - # MIME-Version, since it looks weird with the full-height V. - s{ - ( ^ | [\s\(\"\'\`\[\{<>] ) - ( [A-Z] [A-Z] (?: [/A-Z+:\d_\$&] | \\- )* ) - (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | $ ) - } { $1 . '\s-1' . $2 . '\s0' }egx; - - # Italize functions in the form func(). - s{ - ( \b | \\s-1 ) - ( - [A-Za-z_] ([:\w]|\\s-?[01])+ \(\) - ) - } { $1 . '\f(IS' . $2 . '\f(IE' }egx; - - # func(n) is a reference to a manual page. Make it \fIfunc\fR\|(n). - s{ - ( \b | \\s-1 ) - ( [A-Za-z_] (?:[.:\w]|\\-|\\s-?[01])+ ) - ( - \( \d [a-z]* \) - ) - } { $1 . '\f(IS' . $2 . '\f(IE\|' . $3 }egx; - - # Convert simple Perl variable references to a fixed-width font. - s{ - ( \s+ ) - ( [\$\@%] [\w:]+ ) - (?! \( ) - } { $1 . '\f(FS' . $2 . '\f(FE'}egx; - - # Fix up double quotes. - s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx; - - # Make C++ into \*(C+, which is a squinched version. - s{ \b C\+\+ } {\\*\(C+}gx; - - # All done. - $_; -} - -# Handles C<> text, deciding whether to put \*C` around it or not. This is a -# whole bunch of messy heuristics to try to avoid overquoting, originally from -# Barrie Slaymaker. This largely duplicates similar code in Pod::Text. -sub quote_literal { - my $self = shift; - local $_ = shift; - - # A regex that matches the portion of a variable reference that's the - # array or hash index, separated out just because we want to use it in - # several places in the following regex. - my $index = '(?: \[.*\] | \{.*\} )?'; - - # Check for things that we don't want to quote, and if we find any of - # them, return the string with just a font change and no quoting. - m{ - ^\s* - (?: - ( [\'\`\"] ) .* \1 # already quoted - | \` .* \' # `quoted' - | \$+ [\#^]? \S $index # special ($^Foo, $") - | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func - | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call - | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number - | 0x [a-fA-F\d]+ # a hex constant - ) - \s*\z - }xo && return '\f(FS' . $_ . '\f(FE'; - - # If we didn't return, go ahead and quote the text. - return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE"; -} - - -############################################################################## -# Output formatting -############################################################################## - -# Make vertical whitespace. -sub makespace { - my $self = shift; - $self->output (".PD\n") if ($$self{ITEMS} > 1); - $$self{ITEMS} = 0; - $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n") - if $$self{NEEDSPACE}; -} - -# Output any pending index entries, and optionally an index entry given as an -# argument. Support multiple index entries in X<> separated by slashes, and -# strip special escapes from index entries. -sub outindex { - my ($self, $section, $index) = @_; - my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} }; - return unless ($section || @entries); - $$self{INDEX} = []; - my @output; - if (@entries) { - push (@output, [ 'Xref', join (' ', @entries) ]); - } - if ($section) { - $index =~ s/\\-/-/g; - $index =~ s/\\(?:s-?\d|.\(..|.)//g; - push (@output, [ $section, $index ]); - } - for (@output) { - my ($type, $entry) = @$_; - $entry =~ s/\"/\"\"/g; - $entry =~ s/\\/\\e/g; - $self->output (".IX $type " . '"' . $entry . '"' . "\n"); - } -} - -# Output text to the output device. -sub output { print { $_[0]->output_handle } $_[1] } - -# Given a command and a single argument that may or may not contain double -# quotes, handle double-quote formatting for it. If there are no double -# quotes, just return the command followed by the argument in double quotes. -# If there are double quotes, use an if statement to test for nroff, and for -# nroff output the command followed by the argument in double quotes with -# embedded double quotes doubled. For other formatters, remap paired double -# quotes to LQUOTE and RQUOTE. -sub switchquotes { - my $self = shift; - my $command = shift; - local $_ = shift; - my $extra = shift; - s/\\\*\([LR]\"/\"/g; - - # We also have to deal with \*C` and \*C', which are used to add the - # quotes around C<> text, since they may expand to " and if they do this - # confuses the .SH macros and the like no end. Expand them ourselves. - # Also separate troff from nroff if there are any fixed-width fonts in use - # to work around problems with Solaris nroff. - my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/); - my $fixedpat = join ('|', @{ $$self{FONTS} }{'100', '101', '110', '111'}); - $fixedpat =~ s/\\/\\\\/g; - $fixedpat =~ s/\(/\\\(/g; - if (/\"/ || /$fixedpat/) { - s/\"/\"\"/g; - my $nroff = $_; - my $troff = $_; - $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g; - if ($c_is_quote && /\\\*\(C[\'\`]/) { - $nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g; - $nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g; - $troff =~ s/\\\*\(C[\'\`]//g; - } - $nroff = qq("$nroff") . ($extra ? " $extra" : ''); - $troff = qq("$troff") . ($extra ? " $extra" : ''); - - # Work around the Solaris nroff bug where \f(CW\fP leaves the font set - # to Roman rather than the actual previous font when used in headings. - # troff output may still be broken, but at least we can fix nroff by - # just switching the font changes to the non-fixed versions. - $nroff =~ s/\Q$$self{FONTS}{100}\E(.*)\\f[PR]/$1/g; - $nroff =~ s/\Q$$self{FONTS}{101}\E(.*)\\f([PR])/\\fI$1\\f$2/g; - $nroff =~ s/\Q$$self{FONTS}{110}\E(.*)\\f([PR])/\\fB$1\\f$2/g; - $nroff =~ s/\Q$$self{FONTS}{111}\E(.*)\\f([PR])/\\f\(BI$1\\f$2/g; - - # Now finally output the command. Only bother with .ie if the nroff - # and troff output isn't the same. - if ($nroff ne $troff) { - return ".ie n $command $nroff\n.el $command $troff\n"; - } else { - return "$command $nroff\n"; - } - } else { - $_ = qq("$_") . ($extra ? " $extra" : ''); - return "$command $_\n"; - } -} - -############################################################################## -# Module return value and documentation -############################################################################## - -1; -__END__ - -=head1 NAME - -Pod::Man - Convert POD data to formatted *roff input - -=head1 SYNOPSIS - - use Pod::Man; - my $parser = Pod::Man->new (release => $VERSION, section => 8); - - # Read POD from STDIN and write to STDOUT. - $parser->parse_from_filehandle; - - # Read POD from file.pod and write to file.1. - $parser->parse_from_file ('file.pod', 'file.1'); - -=head1 DESCRIPTION - -Pod::Man is a module to convert documentation in the POD format (the -preferred language for documenting Perl) into *roff input using the man -macro set. The resulting *roff code is suitable for display on a terminal -using L, normally via L, or printing using L. -It is conventionally invoked using the driver script B, but it can -also be used directly. - -As a derived class from Pod::Parser, Pod::Man supports the same methods and -interfaces. See L for all the details; briefly, one creates a -new parser with C<< Pod::Man->new() >> and then calls either -parse_from_filehandle() or parse_from_file(). - -new() can take options, in the form of key/value pairs that control the -behavior of the parser. See below for details. - -If no options are given, Pod::Man uses the name of the input file with any -trailing C<.pod>, C<.pm>, or C<.pl> stripped as the man page title, to -section 1 unless the file ended in C<.pm> in which case it defaults to -section 3, to a centered title of "User Contributed Perl Documentation", to -a centered footer of the Perl version it is run with, and to a left-hand -footer of the modification date of its input (or the current date if given -STDIN for input). - -Pod::Man assumes that your *roff formatters have a fixed-width font named -CW. If yours is called something else (like CR), use the C option to -specify it. This generally only matters for troff output for printing. -Similarly, you can set the fonts used for bold, italic, and bold italic -fixed-width output. - -Besides the obvious pod conversions, Pod::Man also takes care of formatting -func(), func(3), and simple variable references like $foo or @bar so you -don't have to use code escapes for them; complex expressions like -C<$fred{'stuff'}> will still need to be escaped, though. It also translates -dashes that aren't used as hyphens into en dashes, makes long dashes--like -this--into proper em dashes, fixes "paired quotes," makes C++ look right, -puts a little space between double underbars, makes ALLCAPS a teeny bit -smaller in B, and escapes stuff that *roff treats as special so that -you don't have to. - -The recognized options to new() are as follows. All options take a single -argument. - -=over 4 - -=item center - -Sets the centered page header to use instead of "User Contributed Perl -Documentation". - -=item date - -Sets the left-hand footer. By default, the modification date of the input -file will be used, or the current date if stat() can't find that file (the -case if the input is from STDIN), and the date will be formatted as -YYYY-MM-DD. - -=item fixed - -The fixed-width font to use for vertabim text and code. Defaults to CW. -Some systems may want CR instead. Only matters for B output. - -=item fixedbold - -Bold version of the fixed-width font. Defaults to CB. Only matters for -B output. - -=item fixeditalic - -Italic version of the fixed-width font (actually, something of a misnomer, -since most fixed-width fonts only have an oblique version, not an italic -version). Defaults to CI. Only matters for B output. - -=item fixedbolditalic - -Bold italic (probably actually oblique) version of the fixed-width font. -Pod::Man doesn't assume you have this, and defaults to CB. Some systems -(such as Solaris) have this font available as CX. Only matters for B -output. - -=item name - -Set the name of the manual page. Without this option, the manual name is -set to the uppercased base name of the file being converted unless the -manual section is 3, in which case the path is parsed to see if it is a Perl -module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted into -a name like C. This option, if given, overrides any automatic -determination of the name. - -=item quotes - -Sets the quote marks used to surround CE> text. If the value is a -single character, it is used as both the left and right quote; if it is two -characters, the first character is used as the left quote and the second as -the right quoted; and if it is four characters, the first two are used as -the left quote and the second two as the right quote. - -This may also be set to the special value C, in which case no quote -marks are added around CE> text (but the font is still changed for troff -output). - -=item release - -Set the centered footer. By default, this is the version of Perl you run -Pod::Man under. Note that some system an macro sets assume that the -centered footer will be a modification date and will prepend something like -"Last modified: "; if this is the case, you may want to set C to -the last modified date and C to the version number. - -=item section - -Set the section for the C<.TH> macro. The standard section numbering -convention is to use 1 for user commands, 2 for system calls, 3 for -functions, 4 for devices, 5 for file formats, 6 for games, 7 for -miscellaneous information, and 8 for administrator commands. There is a lot -of variation here, however; some systems (like Solaris) use 4 for file -formats, 5 for miscellaneous information, and 7 for devices. Still others -use 1m instead of 8, or some mix of both. About the only section numbers -that are reliably consistent are 1, 2, and 3. - -By default, section 1 will be used unless the file ends in .pm in which case -section 3 will be selected. - -=back - -The standard Pod::Parser method parse_from_filehandle() takes up to two -arguments, the first being the file handle to read POD from and the second -being the file handle to write the formatted output to. The first defaults -to STDIN if not given, and the second defaults to STDOUT. The method -parse_from_file() is almost identical, except that its two arguments are the -input and output disk files instead. See L for the specific -details. - -=head1 DIAGNOSTICS - -=over 4 - -=item roff font should be 1 or 2 chars, not "%s" - -(F) You specified a *roff font (using C, C, etc.) that -wasn't either one or two characters. Pod::Man doesn't support *roff fonts -longer than two characters, although some *roff extensions do (the canonical -versions of B and B don't either). - -=item Invalid link %s - -(W) The POD source contained a CE> formatting code that -Pod::Man was unable to parse. You should never see this error message; it -probably indicates a bug in Pod::Man. - -=item Invalid quote specification "%s" - -(F) The quote specification given (the quotes option to the constructor) was -invalid. A quote specification must be one, two, or four characters long. - -=item %s:%d: Unknown command paragraph "%s". - -(W) The POD source contained a non-standard command paragraph (something of -the form C<=command args>) that Pod::Man didn't know about. It was ignored. - -=item %s:%d: Unknown escape EE%sE - -(W) The POD source contained an CE> escape that Pod::Man didn't -know about. C%sE> was printed verbatim in the output. - -=item %s:%d: Unknown formatting code %s - -(W) The POD source contained a non-standard formatting code (something of -the form CE>) that Pod::Man didn't know about. It was ignored. - -=item %s:%d: Unmatched =back - -(W) Pod::Man encountered a C<=back> command that didn't correspond to an -C<=over> command. - -=back - -=head1 BUGS - -Eight-bit input data isn't handled at all well at present. The correct -approach would be to map EEE escapes to the appropriate UTF-8 -characters and then do a translation pass on the output according to the -user-specified output character set. Unfortunately, we can't send eight-bit -data directly to the output unless the user says this is okay, since some -vendor *roff implementations can't handle eight-bit data. If the *roff -implementation can, however, that's far superior to the current hacked -characters that only work under troff. - -There is currently no way to turn off the guesswork that tries to format -unmarked text appropriately, and sometimes it isn't wanted (particularly -when using POD to document something other than Perl). - -The NAME section should be recognized specially and index entries emitted -for everything in that section. This would have to be deferred until the -next section, since extraneous things in NAME tends to confuse various man -page processors. - -Pod::Man doesn't handle font names longer than two characters. Neither do -most B implementations, but GNU troff does as an extension. It would -be nice to support as an option for those who want to use it. - -The preamble added to each output file is rather verbose, and most of it is -only necessary in the presence of EEE escapes for non-ASCII -characters. It would ideally be nice if all of those definitions were only -output if needed, perhaps on the fly as the characters are used. - -Pod::Man is excessively slow. - -=head1 CAVEATS - -The handling of hyphens and em dashes is somewhat fragile, and one may get -the wrong one under some circumstances. This should only matter for -B output. - -When and whether to use small caps is somewhat tricky, and Pod::Man doesn't -necessarily get it right. - -=head1 SEE ALSO - -L, L, L, L, L, -L, L - -Ossanna, Joseph F., and Brian W. Kernighan. "Troff User's Manual," -Computing Science Technical Report No. 54, AT&T Bell Laboratories. This is -the best documentation of standard B and B. At the time of -this writing, it's available at -L. - -The man page documenting the man macro set may be L instead of -L on your system. Also, please see L for extensive -documentation on writing manual pages if you've not done it before and -aren't familiar with the conventions. - -The current version of this module is always available from its web site at -L. It is also part of the -Perl core distribution as of 5.6.0. - -=head1 AUTHOR - -Russ Allbery , based I heavily on the original -B by Tom Christiansen . - -=head1 COPYRIGHT AND LICENSE - -Copyright 1999, 2000, 2001, 2002, 2003 by Russ Allbery . - -This program is free software; you may redistribute it and/or modify it -under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/installer/perllib/Pod/ParseLink.pm b/Master/tlpkg/installer/perllib/Pod/ParseLink.pm deleted file mode 100644 index 7e4153da3d0..00000000000 --- a/Master/tlpkg/installer/perllib/Pod/ParseLink.pm +++ /dev/null @@ -1,184 +0,0 @@ -# Pod::ParseLink -- Parse an L<> formatting code in POD text. -# $Id: ParseLink.pm,v 1.6 2002/07/15 05:46:00 eagle Exp $ -# -# Copyright 2001 by Russ Allbery -# -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. -# -# This module implements parsing of the text of an L<> formatting code as -# defined in perlpodspec. It should be suitable for any POD formatter. It -# exports only one function, parselink(), which returns the five-item parse -# defined in perlpodspec. -# -# Perl core hackers, please note that this module is also separately -# maintained outside of the Perl core as part of the podlators. Please send -# me any patches at the address above in addition to sending them to the -# standard Perl mailing lists. - -############################################################################## -# Modules and declarations -############################################################################## - -package Pod::ParseLink; - -require 5.004; - -use strict; -use vars qw(@EXPORT @ISA $VERSION); - -use Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(parselink); - -# Don't use the CVS revision as the version, since this module is also in Perl -# core and too many things could munge CVS magic revision strings. This -# number should ideally be the same as the CVS revision in podlators, however. -$VERSION = 1.06; - - -############################################################################## -# Implementation -############################################################################## - -# Parse the name and section portion of a link into a name and section. -sub _parse_section { - my ($link) = @_; - $link =~ s/^\s+//; - $link =~ s/\s+$//; - - # If the whole link is enclosed in quotes, interpret it all as a section - # even if it contains a slash. - return (undef, $1) if ($link =~ /^"\s*(.*?)\s*"$/); - - # Split into page and section on slash, and then clean up quoting in the - # section. If there is no section and the name contains spaces, also - # guess that it's an old section link. - my ($page, $section) = split (/\s*\/\s*/, $link, 2); - $section =~ s/^"\s*(.*?)\s*"$/$1/ if $section; - if ($page && $page =~ / / && !defined ($section)) { - $section = $page; - $page = undef; - } else { - $page = undef unless $page; - $section = undef unless $section; - } - return ($page, $section); -} - -# Infer link text from the page and section. -sub _infer_text { - my ($page, $section) = @_; - my $inferred; - if ($page && !$section) { - $inferred = $page; - } elsif (!$page && $section) { - $inferred = '"' . $section . '"'; - } elsif ($page && $section) { - $inferred = '"' . $section . '" in ' . $page; - } - return $inferred; -} - -# Given the contents of an L<> formatting code, parse it into the link text, -# the possibly inferred link text, the name or URL, the section, and the type -# of link (pod, man, or url). -sub parselink { - my ($link) = @_; - $link =~ s/\s+/ /g; - if ($link =~ /\A\w+:[^:\s]\S*\Z/) { - return (undef, $link, $link, undef, 'url'); - } else { - my $text; - if ($link =~ /\|/) { - ($text, $link) = split (/\|/, $link, 2); - } - my ($name, $section) = _parse_section ($link); - my $inferred = $text || _infer_text ($name, $section); - my $type = ($name && $name =~ /\(\S*\)/) ? 'man' : 'pod'; - return ($text, $inferred, $name, $section, $type); - } -} - - -############################################################################## -# Module return value and documentation -############################################################################## - -# Ensure we evaluate to true. -1; -__END__ - -=head1 NAME - -Pod::ParseLink - Parse an LEE formatting code in POD text - -=head1 SYNOPSIS - - use Pod::ParseLink; - my ($text, $inferred, $name, $section, $type) = parselink ($link); - -=head1 DESCRIPTION - -This module only provides a single function, parselink(), which takes the -text of an LEE formatting code and parses it. It returns the anchor -text for the link (if any was given), the anchor text possibly inferred from -the name and section, the name or URL, the section if any, and the type of -link. The type will be one of 'url', 'pod', or 'man', indicating a URL, a -link to a POD page, or a link to a Unix manual page. - -Parsing is implemented per L. For backward compatibility, -links where there is no section and name contains spaces, or links where the -entirety of the link (except for the anchor text if given) is enclosed in -double-quotes are interpreted as links to a section (LE/sectionE). - -The inferred anchor text is implemented per L: - - L => L - L => L<"section"|/section> - L => L<"section" in name|name/section> - -The name may contain embedded EEE and ZEE formatting codes, -and the section, anchor text, and inferred anchor text may contain any -formatting codes. Any double quotes around the section are removed as part -of the parsing, as is any leading or trailing whitespace. - -If the text of the LEE escape is entirely enclosed in double quotes, -it's interpreted as a link to a section for backwards compatibility. - -No attempt is made to resolve formatting codes. This must be done after -calling parselink (since EEE formatting codes can be used to escape -characters that would otherwise be significant to the parser and resolving -them before parsing would result in an incorrect parse of a formatting code -like: - - LbarEslash> - -which should be interpreted as a link to the C POD page -and not as a link to the C section of the C POD page with an -anchor text of C. Note that not only the anchor text will need to -have formatting codes expanded, but so will the target of the link (to deal -with EEE and ZEE formatting codes), and special handling of -the section may be necessary depending on whether the translator wants to -consider markup in sections to be significant when resolving links. See -L for more information. - -=head1 SEE ALSO - -L - -The current version of this module is always available from its web site at -L. - -=head1 AUTHOR - -Russ Allbery . - -=head1 COPYRIGHT AND LICENSE - -Copyright 2001 by Russ Allbery . - -This program is free software; you may redistribute it and/or modify it -under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/installer/perllib/Pod/ParseUtils.pm b/Master/tlpkg/installer/perllib/Pod/ParseUtils.pm deleted file mode 100644 index 878860121d3..00000000000 --- a/Master/tlpkg/installer/perllib/Pod/ParseUtils.pm +++ /dev/null @@ -1,852 +0,0 @@ -############################################################################# -# Pod/ParseUtils.pm -- helpers for POD parsing and conversion -# -# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::ParseUtils; - -use vars qw($VERSION); -$VERSION = 1.33; ## Current version of this package -require 5.005; ## requires this Perl version or later - -=head1 NAME - -Pod::ParseUtils - helpers for POD parsing and conversion - -=head1 SYNOPSIS - - use Pod::ParseUtils; - - my $list = new Pod::List; - my $link = Pod::Hyperlink->new('Pod::Parser'); - -=head1 DESCRIPTION - -B contains a few object-oriented helper packages for -POD parsing and processing (i.e. in POD formatters and translators). - -=cut - -#----------------------------------------------------------------------------- -# Pod::List -# -# class to hold POD list info (=over, =item, =back) -#----------------------------------------------------------------------------- - -package Pod::List; - -use Carp; - -=head2 Pod::List - -B can be used to hold information about POD lists -(written as =over ... =item ... =back) for further processing. -The following methods are available: - -=over 4 - -=item Pod::List-Enew() - -Create a new list object. Properties may be specified through a hash -reference like this: - - my $list = Pod::List->new({ -start => $., -indent => 4 }); - -See the individual methods/properties for details. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - $self->initialize(); - return $self; -} - -sub initialize { - my $self = shift; - $self->{-file} ||= 'unknown'; - $self->{-start} ||= 'unknown'; - $self->{-indent} ||= 4; # perlpod: "should be the default" - $self->{_items} = []; - $self->{-type} ||= ''; -} - -=item $list-Efile() - -Without argument, retrieves the file name the list is in. This must -have been set before by either specifying B<-file> in the B -method or by calling the B method with a scalar argument. - -=cut - -# The POD file name the list appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $list-Estart() - -Without argument, retrieves the line number where the list started. -This must have been set before by either specifying B<-start> in the -B method or by calling the B method with a scalar -argument. - -=cut - -# The line in the file the node appears -sub start { - return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; -} - -=item $list-Eindent() - -Without argument, retrieves the indent level of the list as specified -in C<=over n>. This must have been set before by either specifying -B<-indent> in the B method or by calling the B method -with a scalar argument. - -=cut - -# indent level -sub indent { - return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; -} - -=item $list-Etype() - -Without argument, retrieves the list type, which can be an arbitrary value, -e.g. C
    , C