From 320d8694fec25ed148613684543b5a0504a046ae Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Thu, 17 Feb 2011 17:57:31 +0000 Subject: New tlperl part XIV git-svn-id: svn://tug.org/texlive/trunk@21436 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/App/Cpan.pm | 1067 +++ Master/tlpkg/tlperl/lib/App/Prove.pm | 774 ++ Master/tlpkg/tlperl/lib/App/Prove/State.pm | 517 ++ Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm | 233 + .../tlperl/lib/App/Prove/State/Result/Test.pm | 153 + Master/tlpkg/tlperl/lib/Archive/Extract.pm | 1511 ++++ Master/tlpkg/tlperl/lib/Archive/Tar.pm | 2146 +++++ Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm | 86 + Master/tlpkg/tlperl/lib/Archive/Tar/File.pm | 660 ++ Master/tlpkg/tlperl/lib/Attribute/Handlers.pm | 924 +++ Master/tlpkg/tlperl/lib/B/Concise.pm | 1836 +++++ Master/tlpkg/tlperl/lib/B/Debug.pm | 424 + Master/tlpkg/tlperl/lib/B/Deparse.pm | 4875 ++++++++++++ Master/tlpkg/tlperl/lib/B/Lint.pm | 792 ++ Master/tlpkg/tlperl/lib/B/Lint/Debug.pm | 67 + Master/tlpkg/tlperl/lib/B/Showlex.pm | 205 + Master/tlpkg/tlperl/lib/B/Terse.pm | 102 + Master/tlpkg/tlperl/lib/B/Xref.pm | 431 + Master/tlpkg/tlperl/lib/CGI/Apache.pm | 27 + Master/tlpkg/tlperl/lib/CGI/Carp.pm | 601 ++ Master/tlpkg/tlperl/lib/CGI/Cookie.pm | 549 ++ Master/tlpkg/tlperl/lib/CGI/Fast.pm | 224 + Master/tlpkg/tlperl/lib/CGI/Pretty.pm | 312 + Master/tlpkg/tlperl/lib/CGI/Push.pm | 325 + Master/tlpkg/tlperl/lib/CGI/Switch.pm | 28 + Master/tlpkg/tlperl/lib/CGI/Util.pm | 392 + Master/tlpkg/tlperl/lib/Carp/Heavy.pm | 10 + Master/tlpkg/tlperl/lib/Class/ISA.pm | 218 + Master/tlpkg/tlperl/lib/Class/Struct.pm | 636 ++ Master/tlpkg/tlperl/lib/Compress/Raw/Bzip2.pm | 355 + Master/tlpkg/tlperl/lib/Compress/Raw/Zlib.pm | 1419 ++++ Master/tlpkg/tlperl/lib/Compress/Zlib.pm | 1494 ++++ Master/tlpkg/tlperl/lib/Config/Extensions.pm | 63 + Master/tlpkg/tlperl/lib/DBM_Filter/compress.pm | 53 + Master/tlpkg/tlperl/lib/DBM_Filter/encode.pm | 86 + Master/tlpkg/tlperl/lib/DBM_Filter/int32.pm | 50 + Master/tlpkg/tlperl/lib/DBM_Filter/null.pm | 52 + Master/tlpkg/tlperl/lib/DBM_Filter/utf8.pm | 51 + Master/tlpkg/tlperl/lib/Data/Dumper.pm | 1306 ++++ Master/tlpkg/tlperl/lib/Devel/DProf.pm | 238 + Master/tlpkg/tlperl/lib/Devel/DProf/V.pm | 63 + Master/tlpkg/tlperl/lib/Devel/DProf/test1_t | 18 + Master/tlpkg/tlperl/lib/Devel/DProf/test1_v | 24 + Master/tlpkg/tlperl/lib/Devel/DProf/test2_t | 21 + Master/tlpkg/tlperl/lib/Devel/DProf/test2_v | 36 + Master/tlpkg/tlperl/lib/Devel/DProf/test3_t | 19 + Master/tlpkg/tlperl/lib/Devel/DProf/test3_v | 29 + Master/tlpkg/tlperl/lib/Devel/DProf/test4_t | 24 + Master/tlpkg/tlperl/lib/Devel/DProf/test4_v | 36 + Master/tlpkg/tlperl/lib/Devel/DProf/test5_t | 25 + Master/tlpkg/tlperl/lib/Devel/DProf/test5_v | 15 + Master/tlpkg/tlperl/lib/Devel/DProf/test6_t | 29 + Master/tlpkg/tlperl/lib/Devel/DProf/test6_v | 16 + Master/tlpkg/tlperl/lib/Devel/DProf/test7_t | 9 + Master/tlpkg/tlperl/lib/Devel/DProf/test7_v | 10 + Master/tlpkg/tlperl/lib/Devel/DProf/test8_t | 15 + Master/tlpkg/tlperl/lib/Devel/DProf/test8_v | 11 + Master/tlpkg/tlperl/lib/Devel/InnerPackage.pm | 128 + Master/tlpkg/tlperl/lib/Devel/PPPort.pm | 8269 ++++++++++++++++++++ Master/tlpkg/tlperl/lib/Devel/Peek.pm | 570 ++ Master/tlpkg/tlperl/lib/Devel/SelfStubber.pm | 152 + Master/tlpkg/tlperl/lib/Digest/MD5.pm | 376 + Master/tlpkg/tlperl/lib/Digest/SHA.pm | 669 ++ Master/tlpkg/tlperl/lib/Digest/SHA1.pm | 246 + Master/tlpkg/tlperl/lib/Digest/base.pm | 100 + Master/tlpkg/tlperl/lib/Digest/file.pm | 85 + Master/tlpkg/tlperl/lib/Exporter/Heavy.pm | 248 + Master/tlpkg/tlperl/lib/File/Basename.pm | 402 + Master/tlpkg/tlperl/lib/File/CheckTree.pm | 238 + Master/tlpkg/tlperl/lib/File/Compare.pm | 182 + Master/tlpkg/tlperl/lib/File/Copy.pm | 656 ++ Master/tlpkg/tlperl/lib/File/DosGlob.pm | 571 ++ Master/tlpkg/tlperl/lib/File/Fetch.pm | 1466 ++++ Master/tlpkg/tlperl/lib/File/Find.pm | 1349 ++++ Master/tlpkg/tlperl/lib/File/Glob.pm | 496 ++ Master/tlpkg/tlperl/lib/File/GlobMapper.pm | 679 ++ Master/tlpkg/tlperl/lib/File/Path.pm | 981 +++ Master/tlpkg/tlperl/lib/File/Spec.pm | 336 + Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm | 155 + Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm | 79 + Master/tlpkg/tlperl/lib/File/Spec/Functions.pm | 110 + Master/tlpkg/tlperl/lib/File/Spec/Mac.pm | 781 ++ Master/tlpkg/tlperl/lib/File/Spec/OS2.pm | 274 + Master/tlpkg/tlperl/lib/File/Spec/Unix.pm | 521 ++ Master/tlpkg/tlperl/lib/File/Spec/VMS.pm | 1141 +++ Master/tlpkg/tlperl/lib/File/Spec/Win32.pm | 444 ++ Master/tlpkg/tlperl/lib/File/Temp.pm | 2452 ++++++ Master/tlpkg/tlperl/lib/File/Which.pm | 254 + Master/tlpkg/tlperl/lib/File/stat.pm | 346 + Master/tlpkg/tlperl/lib/Filter/Simple.pm | 797 ++ Master/tlpkg/tlperl/lib/Filter/Util/Call.pm | 498 ++ Master/tlpkg/tlperl/lib/Getopt/Long.pm | 2649 +++++++ Master/tlpkg/tlperl/lib/Getopt/Std.pm | 295 + Master/tlpkg/tlperl/lib/Hash/Util.pm | 520 ++ Master/tlpkg/tlperl/lib/Hash/Util/FieldHash.pm | 860 ++ Master/tlpkg/tlperl/lib/I18N/Collate.pm | 196 + Master/tlpkg/tlperl/lib/I18N/LangTags.pm | 887 +++ Master/tlpkg/tlperl/lib/I18N/LangTags/Detect.pm | 237 + Master/tlpkg/tlperl/lib/I18N/LangTags/List.pm | 1779 +++++ Master/tlpkg/tlperl/lib/IPC/Cmd.pm | 1646 ++++ Master/tlpkg/tlperl/lib/IPC/Open2.pm | 121 + Master/tlpkg/tlperl/lib/IPC/Open3.pm | 376 + Master/tlpkg/tlperl/lib/List/Util.pm | 233 + Master/tlpkg/tlperl/lib/List/Util/PP.pm | 83 + Master/tlpkg/tlperl/lib/List/Util/XS.pm | 45 + Master/tlpkg/tlperl/lib/Locale/Constants.pm | 31 + Master/tlpkg/tlperl/lib/Locale/Constants.pod | 76 + Master/tlpkg/tlperl/lib/Locale/Country.pm | 550 ++ Master/tlpkg/tlperl/lib/Locale/Country.pod | 306 + Master/tlpkg/tlperl/lib/Locale/Currency.pm | 356 + Master/tlpkg/tlperl/lib/Locale/Currency.pod | 191 + Master/tlpkg/tlperl/lib/Locale/Language.pm | 315 + Master/tlpkg/tlperl/lib/Locale/Language.pod | 158 + Master/tlpkg/tlperl/lib/Locale/Maketext.pm | 456 ++ Master/tlpkg/tlperl/lib/Locale/Maketext.pod | 1326 ++++ Master/tlpkg/tlperl/lib/Locale/Maketext/Guts.pm | 328 + .../tlpkg/tlperl/lib/Locale/Maketext/GutsLoader.pm | 49 + Master/tlpkg/tlperl/lib/Locale/Maketext/Simple.pm | 341 + Master/tlpkg/tlperl/lib/Locale/Maketext/TPJ13.pod | 775 ++ Master/tlpkg/tlperl/lib/Locale/Script.pm | 294 + Master/tlpkg/tlperl/lib/Locale/Script.pod | 253 + Master/tlpkg/tlperl/lib/Log/Message.pm | 600 ++ Master/tlpkg/tlperl/lib/Log/Message/Config.pm | 197 + Master/tlpkg/tlperl/lib/Log/Message/Handlers.pm | 191 + Master/tlpkg/tlperl/lib/Log/Message/Item.pm | 192 + Master/tlpkg/tlperl/lib/Log/Message/Simple.pm | 293 + Master/tlpkg/tlperl/lib/MIME/Base64.pm | 175 + Master/tlpkg/tlperl/lib/MIME/QuotedPrint.pm | 114 + Master/tlpkg/tlperl/lib/Math/BigFloat.pm | 4402 +++++++++++ Master/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm | 58 + Master/tlpkg/tlperl/lib/Math/BigInt.pm | 5115 ++++++++++++ Master/tlpkg/tlperl/lib/Math/BigInt/Calc.pm | 2612 +++++++ Master/tlpkg/tlperl/lib/Math/BigInt/CalcEmu.pm | 329 + Master/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm | 125 + Master/tlpkg/tlperl/lib/Math/BigInt/Trace.pm | 47 + Master/tlpkg/tlperl/lib/Math/BigRat.pm | 2020 +++++ Master/tlpkg/tlperl/lib/Math/Complex.pm | 2093 +++++ Master/tlpkg/tlperl/lib/Math/Trig.pm | 768 ++ Master/tlpkg/tlperl/lib/Memoize/AnyDBM_File.pm | 31 + Master/tlpkg/tlperl/lib/Memoize/Expire.pm | 365 + Master/tlpkg/tlperl/lib/Memoize/ExpireFile.pm | 52 + Master/tlpkg/tlperl/lib/Memoize/ExpireTest.pm | 49 + Master/tlpkg/tlperl/lib/Memoize/NDBM_File.pm | 77 + Master/tlpkg/tlperl/lib/Memoize/SDBM_File.pm | 75 + Master/tlpkg/tlperl/lib/Memoize/Storable.pm | 72 + Master/tlpkg/tlperl/lib/Net/Cmd.pm | 783 ++ Master/tlpkg/tlperl/lib/Net/Config.pm | 312 + Master/tlpkg/tlperl/lib/Net/Domain.pm | 347 + Master/tlpkg/tlperl/lib/Net/FTP.pm | 1829 +++++ Master/tlpkg/tlperl/lib/Net/FTP/A.pm | 111 + Master/tlpkg/tlperl/lib/Net/FTP/E.pm | 8 + Master/tlpkg/tlperl/lib/Net/FTP/I.pm | 80 + Master/tlpkg/tlperl/lib/Net/FTP/L.pm | 8 + Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm | 124 + Master/tlpkg/tlperl/lib/Net/NNTP.pm | 1140 +++ Master/tlpkg/tlperl/lib/Net/Netrc.pm | 325 + Master/tlpkg/tlperl/lib/Net/POP3.pm | 742 ++ Master/tlpkg/tlperl/lib/Net/Ping.pm | 1777 +++++ Master/tlpkg/tlperl/lib/Net/SMTP.pm | 867 ++ Master/tlpkg/tlperl/lib/Net/Time.pm | 151 + Master/tlpkg/tlperl/lib/Net/hostent.pm | 151 + Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod | 303 + Master/tlpkg/tlperl/lib/Net/netent.pm | 169 + Master/tlpkg/tlperl/lib/Net/protoent.pm | 96 + Master/tlpkg/tlperl/lib/Net/servent.pm | 113 + Master/tlpkg/tlperl/lib/Object/Accessor.pm | 819 ++ Master/tlpkg/tlperl/lib/Package/Constants.pm | 106 + Master/tlpkg/tlperl/lib/Params/Check.pm | 712 ++ Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm | 437 ++ Master/tlpkg/tlperl/lib/PerlIO/encoding.pm | 53 + Master/tlpkg/tlperl/lib/PerlIO/scalar.pm | 41 + Master/tlpkg/tlperl/lib/PerlIO/via.pm | 243 + Master/tlpkg/tlperl/lib/PerlIO/via/QuotedPrint.pm | 94 + Master/tlpkg/tlperl/lib/Scalar/Util.pm | 283 + Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm | 109 + Master/tlpkg/tlperl/lib/Search/Dict.pm | 108 + Master/tlpkg/tlperl/lib/Sys/Hostname.pm | 165 + Master/tlpkg/tlperl/lib/TAP/Base.pm | 129 + Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm | 449 ++ Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm | 148 + Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm | 91 + .../lib/TAP/Formatter/Console/ParallelSession.pm | 202 + .../tlperl/lib/TAP/Formatter/Console/Session.pm | 219 + Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm | 58 + .../tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm | 110 + Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm | 183 + Master/tlpkg/tlperl/lib/TAP/Harness.pm | 830 ++ Master/tlpkg/tlperl/lib/TAP/Object.pm | 139 + Master/tlpkg/tlperl/lib/TAP/Parser.pm | 1873 +++++ Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm | 416 + Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm | 580 ++ Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm | 165 + .../tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm | 106 + .../tlperl/lib/TAP/Parser/Iterator/Process.pm | 377 + .../tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm | 112 + .../tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm | 171 + Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm | 195 + Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm | 300 + .../tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm | 63 + .../tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm | 61 + Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm | 120 + .../tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm | 63 + Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm | 274 + .../tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm | 51 + .../tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm | 63 + Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm | 62 + .../tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm | 189 + Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm | 312 + .../tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm | 107 + .../tlperl/lib/TAP/Parser/Scheduler/Spinner.pm | 53 + Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm | 173 + Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm | 326 + Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm | 72 + .../tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm | 333 + .../tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm | 255 + Master/tlpkg/tlperl/lib/Term/ANSIColor.pm | 609 ++ Master/tlpkg/tlperl/lib/Term/Cap.pm | 799 ++ Master/tlpkg/tlperl/lib/Term/Complete.pm | 188 + Master/tlpkg/tlperl/lib/Term/ReadLine.pm | 416 + Master/tlpkg/tlperl/lib/Term/UI.pm | 620 ++ Master/tlpkg/tlperl/lib/Term/UI/History.pm | 137 + Master/tlpkg/tlperl/lib/Test/Builder.pm | 2501 ++++++ Master/tlpkg/tlperl/lib/Test/Builder/Module.pm | 173 + Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm | 603 ++ .../tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm | 51 + Master/tlpkg/tlperl/lib/Test/Harness.pm | 585 ++ Master/tlpkg/tlperl/lib/Test/More.pm | 1776 +++++ Master/tlpkg/tlperl/lib/Test/Simple.pm | 214 + Master/tlpkg/tlperl/lib/Test/Tutorial.pod | 604 ++ Master/tlpkg/tlperl/lib/Text/Abbrev.pm | 84 + Master/tlpkg/tlperl/lib/Text/Balanced.pm | 2281 ++++++ Master/tlpkg/tlperl/lib/Text/ParseWords.pm | 294 + Master/tlpkg/tlperl/lib/Text/Soundex.pm | 260 + Master/tlpkg/tlperl/lib/Text/Tabs.pm | 136 + Master/tlpkg/tlperl/lib/Text/Wrap.pm | 265 + Master/tlpkg/tlperl/lib/Thread/Queue.pm | 481 ++ Master/tlpkg/tlperl/lib/Thread/Semaphore.pm | 170 + Master/tlpkg/tlperl/lib/Tie/Array.pm | 287 + Master/tlpkg/tlperl/lib/Tie/File.pm | 2632 +++++++ Master/tlpkg/tlperl/lib/Tie/Handle.pm | 201 + Master/tlpkg/tlperl/lib/Tie/Hash.pm | 257 + Master/tlpkg/tlperl/lib/Tie/Hash/NamedCapture.pm | 62 + Master/tlpkg/tlperl/lib/Tie/Memoize.pm | 128 + Master/tlpkg/tlperl/lib/Tie/RefHash.pm | 274 + Master/tlpkg/tlperl/lib/Tie/Registry.pm | 45 + Master/tlpkg/tlperl/lib/Tie/Scalar.pm | 163 + Master/tlpkg/tlperl/lib/Tie/StdHandle.pm | 71 + Master/tlpkg/tlperl/lib/Tie/SubstrHash.pm | 215 + Master/tlpkg/tlperl/lib/Tie/Watch.pm | 560 ++ Master/tlpkg/tlperl/lib/Time/HiRes.pm | 591 ++ Master/tlpkg/tlperl/lib/Time/Local.pm | 341 + Master/tlpkg/tlperl/lib/Time/Piece.pm | 859 ++ Master/tlpkg/tlperl/lib/Time/Seconds.pm | 230 + Master/tlpkg/tlperl/lib/Time/gmtime.pm | 91 + Master/tlpkg/tlperl/lib/Time/localtime.pm | 86 + Master/tlpkg/tlperl/lib/Time/tm.pm | 33 + Master/tlpkg/tlperl/lib/User/grent.pm | 95 + Master/tlpkg/tlperl/lib/User/pwent.pm | 298 + Master/tlpkg/tlperl/lib/Win32/API.pm | 778 ++ Master/tlpkg/tlperl/lib/Win32/API/Callback.pm | 174 + Master/tlpkg/tlperl/lib/Win32/API/Struct.pm | 532 ++ Master/tlpkg/tlperl/lib/Win32/API/Test.pm | 111 + Master/tlpkg/tlperl/lib/Win32/API/Type.pm | 453 ++ Master/tlpkg/tlperl/lib/Win32/Shortcut.pm | 752 ++ Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm | 3809 +++++++++ Master/tlpkg/tlperl/lib/Win32API/File.pm | 3035 +++++++ Master/tlpkg/tlperl/lib/Win32API/File/cFile.pc | 165 + Master/tlpkg/tlperl/lib/Win32API/Registry.pm | 1775 +++++ .../tlperl/lib/Win32API/Registry/cRegistry.pc | 87 + Master/tlpkg/tlperl/lib/autodie/exception.pm | 741 ++ .../tlpkg/tlperl/lib/autodie/exception/system.pm | 81 + Master/tlpkg/tlperl/lib/autodie/hints.pm | 598 ++ Master/tlpkg/tlperl/lib/encoding/warnings.pm | 239 + Master/tlpkg/tlperl/lib/inc/latest.pm | 246 + Master/tlpkg/tlperl/lib/inc/latest/private.pm | 101 + Master/tlpkg/tlperl/lib/overload/numbers.pm | 163 + Master/tlpkg/tlperl/lib/threads/shared.pm | 616 ++ Master/tlpkg/tlperl/lib/version/Internals.pod | 698 ++ Master/tlpkg/tlperl/lib/warnings/register.pm | 51 + 279 files changed, 145534 insertions(+) create mode 100644 Master/tlpkg/tlperl/lib/App/Cpan.pm create mode 100644 Master/tlpkg/tlperl/lib/App/Prove.pm create mode 100644 Master/tlpkg/tlperl/lib/App/Prove/State.pm create mode 100644 Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm create mode 100644 Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm create mode 100644 Master/tlpkg/tlperl/lib/Archive/Extract.pm create mode 100644 Master/tlpkg/tlperl/lib/Archive/Tar.pm create mode 100644 Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm create mode 100644 Master/tlpkg/tlperl/lib/Archive/Tar/File.pm create mode 100644 Master/tlpkg/tlperl/lib/Attribute/Handlers.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Concise.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Debug.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Deparse.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Lint.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Lint/Debug.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Showlex.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Terse.pm create mode 100644 Master/tlpkg/tlperl/lib/B/Xref.pm create mode 100644 Master/tlpkg/tlperl/lib/CGI/Apache.pm create mode 100644 Master/tlpkg/tlperl/lib/CGI/Carp.pm create mode 100644 Master/tlpkg/tlperl/lib/CGI/Cookie.pm create mode 100644 Master/tlpkg/tlperl/lib/CGI/Fast.pm create mode 100644 Master/tlpkg/tlperl/lib/CGI/Pretty.pm create mode 100644 Master/tlpkg/tlperl/lib/CGI/Push.pm create mode 100644 Master/tlpkg/tlperl/lib/CGI/Switch.pm create mode 100644 Master/tlpkg/tlperl/lib/CGI/Util.pm create mode 100644 Master/tlpkg/tlperl/lib/Carp/Heavy.pm create mode 100644 Master/tlpkg/tlperl/lib/Class/ISA.pm create mode 100644 Master/tlpkg/tlperl/lib/Class/Struct.pm create mode 100644 Master/tlpkg/tlperl/lib/Compress/Raw/Bzip2.pm create mode 100644 Master/tlpkg/tlperl/lib/Compress/Raw/Zlib.pm create mode 100644 Master/tlpkg/tlperl/lib/Compress/Zlib.pm create mode 100644 Master/tlpkg/tlperl/lib/Config/Extensions.pm create mode 100644 Master/tlpkg/tlperl/lib/DBM_Filter/compress.pm create mode 100644 Master/tlpkg/tlperl/lib/DBM_Filter/encode.pm create mode 100644 Master/tlpkg/tlperl/lib/DBM_Filter/int32.pm create mode 100644 Master/tlpkg/tlperl/lib/DBM_Filter/null.pm create mode 100644 Master/tlpkg/tlperl/lib/DBM_Filter/utf8.pm create mode 100644 Master/tlpkg/tlperl/lib/Data/Dumper.pm create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf.pm create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/V.pm create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test1_t create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test1_v create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test2_t create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test2_v create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test3_t create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test3_v create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test4_t create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test4_v create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test5_t create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test5_v create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test6_t create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test6_v create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test7_t create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test7_v create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test8_t create mode 100644 Master/tlpkg/tlperl/lib/Devel/DProf/test8_v create mode 100644 Master/tlpkg/tlperl/lib/Devel/InnerPackage.pm create mode 100644 Master/tlpkg/tlperl/lib/Devel/PPPort.pm create mode 100644 Master/tlpkg/tlperl/lib/Devel/Peek.pm create mode 100644 Master/tlpkg/tlperl/lib/Devel/SelfStubber.pm create mode 100644 Master/tlpkg/tlperl/lib/Digest/MD5.pm create mode 100644 Master/tlpkg/tlperl/lib/Digest/SHA.pm create mode 100644 Master/tlpkg/tlperl/lib/Digest/SHA1.pm create mode 100644 Master/tlpkg/tlperl/lib/Digest/base.pm create mode 100644 Master/tlpkg/tlperl/lib/Digest/file.pm create mode 100644 Master/tlpkg/tlperl/lib/Exporter/Heavy.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Basename.pm create mode 100644 Master/tlpkg/tlperl/lib/File/CheckTree.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Compare.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Copy.pm create mode 100644 Master/tlpkg/tlperl/lib/File/DosGlob.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Fetch.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Find.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Glob.pm create mode 100644 Master/tlpkg/tlperl/lib/File/GlobMapper.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Path.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Functions.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Mac.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/OS2.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Unix.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/VMS.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Spec/Win32.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Temp.pm create mode 100644 Master/tlpkg/tlperl/lib/File/Which.pm create mode 100644 Master/tlpkg/tlperl/lib/File/stat.pm create mode 100644 Master/tlpkg/tlperl/lib/Filter/Simple.pm create mode 100644 Master/tlpkg/tlperl/lib/Filter/Util/Call.pm create mode 100644 Master/tlpkg/tlperl/lib/Getopt/Long.pm create mode 100644 Master/tlpkg/tlperl/lib/Getopt/Std.pm create mode 100644 Master/tlpkg/tlperl/lib/Hash/Util.pm create mode 100644 Master/tlpkg/tlperl/lib/Hash/Util/FieldHash.pm create mode 100644 Master/tlpkg/tlperl/lib/I18N/Collate.pm create mode 100644 Master/tlpkg/tlperl/lib/I18N/LangTags.pm create mode 100644 Master/tlpkg/tlperl/lib/I18N/LangTags/Detect.pm create mode 100644 Master/tlpkg/tlperl/lib/I18N/LangTags/List.pm create mode 100644 Master/tlpkg/tlperl/lib/IPC/Cmd.pm create mode 100644 Master/tlpkg/tlperl/lib/IPC/Open2.pm create mode 100644 Master/tlpkg/tlperl/lib/IPC/Open3.pm create mode 100644 Master/tlpkg/tlperl/lib/List/Util.pm create mode 100644 Master/tlpkg/tlperl/lib/List/Util/PP.pm create mode 100644 Master/tlpkg/tlperl/lib/List/Util/XS.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Constants.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Constants.pod create mode 100644 Master/tlpkg/tlperl/lib/Locale/Country.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Country.pod create mode 100644 Master/tlpkg/tlperl/lib/Locale/Currency.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Currency.pod create mode 100644 Master/tlpkg/tlperl/lib/Locale/Language.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Language.pod create mode 100644 Master/tlpkg/tlperl/lib/Locale/Maketext.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Maketext.pod create mode 100644 Master/tlpkg/tlperl/lib/Locale/Maketext/Guts.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Maketext/GutsLoader.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Maketext/Simple.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Maketext/TPJ13.pod create mode 100644 Master/tlpkg/tlperl/lib/Locale/Script.pm create mode 100644 Master/tlpkg/tlperl/lib/Locale/Script.pod create mode 100644 Master/tlpkg/tlperl/lib/Log/Message.pm create mode 100644 Master/tlpkg/tlperl/lib/Log/Message/Config.pm create mode 100644 Master/tlpkg/tlperl/lib/Log/Message/Handlers.pm create mode 100644 Master/tlpkg/tlperl/lib/Log/Message/Item.pm create mode 100644 Master/tlpkg/tlperl/lib/Log/Message/Simple.pm create mode 100644 Master/tlpkg/tlperl/lib/MIME/Base64.pm create mode 100644 Master/tlpkg/tlperl/lib/MIME/QuotedPrint.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/BigFloat.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/BigFloat/Trace.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/BigInt.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/BigInt/Calc.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/BigInt/CalcEmu.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/BigInt/FastCalc.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/BigInt/Trace.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/BigRat.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/Complex.pm create mode 100644 Master/tlpkg/tlperl/lib/Math/Trig.pm create mode 100644 Master/tlpkg/tlperl/lib/Memoize/AnyDBM_File.pm create mode 100644 Master/tlpkg/tlperl/lib/Memoize/Expire.pm create mode 100644 Master/tlpkg/tlperl/lib/Memoize/ExpireFile.pm create mode 100644 Master/tlpkg/tlperl/lib/Memoize/ExpireTest.pm create mode 100644 Master/tlpkg/tlperl/lib/Memoize/NDBM_File.pm create mode 100644 Master/tlpkg/tlperl/lib/Memoize/SDBM_File.pm create mode 100644 Master/tlpkg/tlperl/lib/Memoize/Storable.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/Cmd.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/Config.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/Domain.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/FTP.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/FTP/A.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/FTP/E.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/FTP/I.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/FTP/L.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/FTP/dataconn.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/NNTP.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/Netrc.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/POP3.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/Ping.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/SMTP.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/Time.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/hostent.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/libnetFAQ.pod create mode 100644 Master/tlpkg/tlperl/lib/Net/netent.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/protoent.pm create mode 100644 Master/tlpkg/tlperl/lib/Net/servent.pm create mode 100644 Master/tlpkg/tlperl/lib/Object/Accessor.pm create mode 100644 Master/tlpkg/tlperl/lib/Package/Constants.pm create mode 100644 Master/tlpkg/tlperl/lib/Params/Check.pm create mode 100644 Master/tlpkg/tlperl/lib/Parse/CPAN/Meta.pm create mode 100644 Master/tlpkg/tlperl/lib/PerlIO/encoding.pm create mode 100644 Master/tlpkg/tlperl/lib/PerlIO/scalar.pm create mode 100644 Master/tlpkg/tlperl/lib/PerlIO/via.pm create mode 100644 Master/tlpkg/tlperl/lib/PerlIO/via/QuotedPrint.pm create mode 100644 Master/tlpkg/tlperl/lib/Scalar/Util.pm create mode 100644 Master/tlpkg/tlperl/lib/Scalar/Util/PP.pm create mode 100644 Master/tlpkg/tlperl/lib/Search/Dict.pm create mode 100644 Master/tlpkg/tlperl/lib/Sys/Hostname.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Base.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Harness.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Object.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm create mode 100644 Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/ANSIColor.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/Cap.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/Complete.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/ReadLine.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/UI.pm create mode 100644 Master/tlpkg/tlperl/lib/Term/UI/History.pm create mode 100644 Master/tlpkg/tlperl/lib/Test/Builder.pm create mode 100644 Master/tlpkg/tlperl/lib/Test/Builder/Module.pm create mode 100644 Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm create mode 100644 Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm create mode 100644 Master/tlpkg/tlperl/lib/Test/Harness.pm create mode 100644 Master/tlpkg/tlperl/lib/Test/More.pm create mode 100644 Master/tlpkg/tlperl/lib/Test/Simple.pm create mode 100644 Master/tlpkg/tlperl/lib/Test/Tutorial.pod create mode 100644 Master/tlpkg/tlperl/lib/Text/Abbrev.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/Balanced.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/ParseWords.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/Soundex.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/Tabs.pm create mode 100644 Master/tlpkg/tlperl/lib/Text/Wrap.pm create mode 100644 Master/tlpkg/tlperl/lib/Thread/Queue.pm create mode 100644 Master/tlpkg/tlperl/lib/Thread/Semaphore.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Array.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/File.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Handle.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Hash.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Hash/NamedCapture.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Memoize.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/RefHash.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Registry.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Scalar.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/StdHandle.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/SubstrHash.pm create mode 100644 Master/tlpkg/tlperl/lib/Tie/Watch.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/HiRes.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/Local.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/Piece.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/Seconds.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/gmtime.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/localtime.pm create mode 100644 Master/tlpkg/tlperl/lib/Time/tm.pm create mode 100644 Master/tlpkg/tlperl/lib/User/grent.pm create mode 100644 Master/tlpkg/tlperl/lib/User/pwent.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/API.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/API/Callback.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/API/Struct.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/API/Test.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/API/Type.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/Shortcut.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32API/File.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32API/File/cFile.pc create mode 100644 Master/tlpkg/tlperl/lib/Win32API/Registry.pm create mode 100644 Master/tlpkg/tlperl/lib/Win32API/Registry/cRegistry.pc create mode 100644 Master/tlpkg/tlperl/lib/autodie/exception.pm create mode 100644 Master/tlpkg/tlperl/lib/autodie/exception/system.pm create mode 100644 Master/tlpkg/tlperl/lib/autodie/hints.pm create mode 100644 Master/tlpkg/tlperl/lib/encoding/warnings.pm create mode 100644 Master/tlpkg/tlperl/lib/inc/latest.pm create mode 100644 Master/tlpkg/tlperl/lib/inc/latest/private.pm create mode 100644 Master/tlpkg/tlperl/lib/overload/numbers.pm create mode 100644 Master/tlpkg/tlperl/lib/threads/shared.pm create mode 100644 Master/tlpkg/tlperl/lib/version/Internals.pod create mode 100644 Master/tlpkg/tlperl/lib/warnings/register.pm diff --git a/Master/tlpkg/tlperl/lib/App/Cpan.pm b/Master/tlpkg/tlperl/lib/App/Cpan.pm new file mode 100644 index 00000000000..cfc12908e52 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/App/Cpan.pm @@ -0,0 +1,1067 @@ +package App::Cpan; +use strict; +use warnings; +use vars qw($VERSION); + +$VERSION = '1.5701'; + +=head1 NAME + +App::Cpan - easily interact with CPAN from the command line + +=head1 SYNOPSIS + + # with arguments and no switches, installs specified modules + cpan module_name [ module_name ... ] + + # with switches, installs modules with extra behavior + cpan [-cfFimt] module_name [ module_name ... ] + + # use local::lib + cpan -l module_name [ module_name ... ] + + # with just the dot, install from the distribution in the + # current directory + cpan . + + # without arguments, starts CPAN.pm shell + cpan + + # without arguments, but some switches + cpan [-ahruvACDLO] + +=head1 DESCRIPTION + +This script provides a command interface (not a shell) to CPAN. At the +moment it uses CPAN.pm to do the work, but it is not a one-shot command +runner for CPAN.pm. + +=head2 Options + +=over 4 + +=item -a + +Creates a CPAN.pm autobundle with CPAN::Shell->autobundle. + +=item -A module [ module ... ] + +Shows the primary maintainers for the specified modules. + +=item -c module + +Runs a `make clean` in the specified module's directories. + +=item -C module [ module ... ] + +Show the F files for the specified modules + +=item -D module [ module ... ] + +Show the module details. This prints one line for each out-of-date module +(meaning, modules locally installed but have newer versions on CPAN). +Each line has three columns: module name, local version, and CPAN +version. + +=item -f + +Force the specified action, when it normally would have failed. Use this +to install a module even if its tests fail. When you use this option, +-i is not optional for installing a module when you need to force it: + + % cpan -f -i Module::Foo + +=item -F + +Turn off CPAN.pm's attempts to lock anything. You should be careful with +this since you might end up with multiple scripts trying to muck in the +same directory. This isn't so much of a concern if you're loading a special +config with C<-j>, and that config sets up its own work directories. + +=item -g module [ module ... ] + +Downloads to the current directory the latest distribution of the module. + +=item -G module [ module ... ] + +UNIMPLEMENTED + +Download to the current directory the latest distribution of the +modules, unpack each distribution, and create a git repository for each +distribution. + +If you want this feature, check out Yanick Champoux's C +distribution. + +=item -h + +Print a help message and exit. When you specify C<-h>, it ignores all +of the other options and arguments. + +=item -i + +Install the specified modules. + +=item -j Config.pm + +Load the file that has the CPAN configuration data. This should have the +same format as the standard F file, which defines +C<$CPAN::Config> as an anonymous hash. + +=item -J + +Dump the configuration in the same format that CPAN.pm uses. This is useful +for checking the configuration as well as using the dump as a starting point +for a new, custom configuration. + +=item -l + +Use C. + +=item -L author [ author ... ] + +List the modules by the specified authors. + +=item -m + +Make the specified modules. + +=item -O + +Show the out-of-date modules. + +=item -t + +Run a `make test` on the specified modules. + +=item -r + +Recompiles dynamically loaded modules with CPAN::Shell->recompile. + +=item -u + +Upgrade all installed modules. Blindly doing this can really break things, +so keep a backup. + +=item -v + +Print the script version and CPAN.pm version then exit. + +=back + +=head2 Examples + + # print a help message + cpan -h + + # print the version numbers + cpan -v + + # create an autobundle + cpan -a + + # recompile modules + cpan -r + + # upgrade all installed modules + cpan -u + + # install modules ( sole -i is optional ) + cpan -i Netscape::Booksmarks Business::ISBN + + # force install modules ( must use -i ) + cpan -fi CGI::Minimal URI + + +=head2 Methods + +=over 4 + +=cut + +use autouse Carp => qw(carp croak cluck); +use CPAN (); +use autouse Cwd => qw(cwd); +use autouse 'Data::Dumper' => qw(Dumper); +use File::Spec::Functions; +use File::Basename; + +use Getopt::Std; + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# Internal constants +use constant TRUE => 1; +use constant FALSE => 0; + + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# The return values +use constant HEY_IT_WORKED => 0; +use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001 +use constant ITS_NOT_MY_FAULT => 2; +use constant THE_PROGRAMMERS_AN_IDIOT => 4; +use constant A_MODULE_FAILED_TO_INSTALL => 8; + + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# set up the order of options that we layer over CPAN::Shell +BEGIN { # most of this should be in methods +use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order + %Method_table %Method_table_index ); + +@META_OPTIONS = qw( h v g G C A D O l L a r j: J ); + +$Default = 'default'; + +%CPAN_METHODS = ( # map switches to method names in CPAN::Shell + $Default => 'install', + 'c' => 'clean', + 'f' => 'force', + 'i' => 'install', + 'm' => 'make', + 't' => 'test', + 'u' => 'upgrade', + ); +@CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS; + +@option_order = ( @META_OPTIONS, @CPAN_OPTIONS ); + + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# map switches to the subroutines in this script, along with other information. +# use this stuff instead of hard-coded indices and values +sub NO_ARGS () { 0 } +sub ARGS () { 1 } +sub GOOD_EXIT () { 0 } + +%Method_table = ( +# key => [ sub ref, takes args?, exit value, description ] + + # options that do their thing first, then exit + h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ], + v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ], + + # options that affect other options + j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ], + J => [ \&_dump_config, NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ], + F => [ \&_lock_lobotomy, NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files' ], + + # options that do their one thing + g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ], + G => [ \&_gitify, NO_ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ], + + C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ], + A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ], + D => [ \&_show_Details, ARGS, GOOD_EXIT, 'Showing Details' ], + O => [ \&_show_out_of_date, NO_ARGS, GOOD_EXIT, 'Showing Out of date' ], + + l => [ \&_list_all_mods, NO_ARGS, GOOD_EXIT, 'Listing all modules' ], + + L => [ \&_show_author_mods, ARGS, GOOD_EXIT, 'Showing author mods' ], + a => [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle' ], + r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ], + u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ], + + c => [ \&_default, ARGS, GOOD_EXIT, 'Running `make clean`' ], + f => [ \&_default, ARGS, GOOD_EXIT, 'Installing with force' ], + i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ], + 'm' => [ \&_default, ARGS, GOOD_EXIT, 'Running `make`' ], + t => [ \&_default, ARGS, GOOD_EXIT, 'Running `make test`' ], + + ); + +%Method_table_index = ( + code => 0, + takes_args => 1, + exit_value => 2, + description => 3, + ); +} + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# finally, do some argument processing + +sub _stupid_interface_hack_for_non_rtfmers + { + no warnings 'uninitialized'; + shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 ) + } + +sub _process_options + { + my %options; + + # if no arguments, just drop into the shell + if( 0 == @ARGV ) { CPAN::shell(); exit 0 } + else + { + Getopt::Std::getopts( + join( '', @option_order ), \%options ); + \%options; + } + } + +sub _process_setup_options + { + my( $class, $options ) = @_; + + if( $options->{j} ) + { + $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} ); + delete $options->{j}; + } + else + { + # this is what CPAN.pm would do otherwise + CPAN::HandleConfig->load( + # be_silent => 1, # candidate to be ripped out forever + write_file => 0, + ); + } + + if( $options->{F} ) + { + $Method_table{F}[ $Method_table_index{code} ]->( $options->{F} ); + delete $options->{F}; + } + + my $option_count = grep { $options->{$_} } @option_order; + no warnings 'uninitialized'; + $option_count -= $options->{'f'}; # don't count force + + # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + # if there are no options, set -i (this line fixes RT ticket 16915) + $options->{i}++ unless $option_count; + } + + +=item run() + +Just do it. + +The C method returns 0 on success and a postive number on +failure. See the section on EXIT CODES for details on the values. + +=cut + +my $logger; + +sub run + { + my $class = shift; + + my $return_value = HEY_IT_WORKED; # assume that things will work + + $logger = $class->_init_logger; + $logger->debug( "Using logger from @{[ref $logger]}" ); + + $class->_hook_into_CPANpm_report; + $logger->debug( "Hooked into output" ); + + $class->_stupid_interface_hack_for_non_rtfmers; + $logger->debug( "Patched cargo culting" ); + + my $options = $class->_process_options; + $logger->debug( "Options are @{[Dumper($options)]}" ); + + $class->_process_setup_options( $options ); + + OPTION: foreach my $option ( @option_order ) + { + next unless $options->{$option}; + + my( $sub, $takes_args, $description ) = + map { $Method_table{$option}[ $Method_table_index{$_} ] } + qw( code takes_args ); + + unless( ref $sub eq ref sub {} ) + { + $return_value = THE_PROGRAMMERS_AN_IDIOT; + last OPTION; + } + + $logger->info( "$description -- ignoring other arguments" ) + if( @ARGV && ! $takes_args ); + + $return_value = $sub->( \ @ARGV, $options ); + + last; + } + + return $return_value; + } + +{ +package Local::Null::Logger; + +sub new { bless \ my $x, $_[0] } +sub AUTOLOAD { shift; print "NullLogger: ", @_, $/ if $ENV{CPAN_NULL_LOGGER} } +sub DESTROY { 1 } +} + +sub _init_logger + { + my $log4perl_loaded = eval "require Log::Log4perl; 1"; + + unless( $log4perl_loaded ) + { + $logger = Local::Null::Logger->new; + return $logger; + } + + my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO'; + + Log::Log4perl::init( \ <<"HERE" ); +log4perl.rootLogger=$LEVEL, A1 +log4perl.appender.A1=Log::Log4perl::Appender::Screen +log4perl.appender.A1.layout=PatternLayout +log4perl.appender.A1.layout.ConversionPattern=%m%n +HERE + + $logger = Log::Log4perl->get_logger( 'App::Cpan' ); + } + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + +sub _default + { + my( $args, $options ) = @_; + + my $switch = ''; + + # choose the option that we're going to use + # we'll deal with 'f' (force) later, so skip it + foreach my $option ( @CPAN_OPTIONS ) + { + next if $option eq 'f'; + next unless $options->{$option}; + $switch = $option; + last; + } + + # 1. with no switches, but arguments, use the default switch (install) + # 2. with no switches and no args, start the shell + # 3. With a switch but no args, die! These switches need arguments. + if( not $switch and @$args ) { $switch = $Default; } + elsif( not $switch and not @$args ) { return CPAN::shell() } + elsif( $switch and not @$args ) + { die "Nothing to $CPAN_METHODS{$switch}!\n"; } + + # Get and check the method from CPAN::Shell + my $method = $CPAN_METHODS{$switch}; + die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method ); + + # call the CPAN::Shell method, with force if specified + my $action = do { + if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } } + else { sub { CPAN::Shell->$method( @_ ) } } + }; + + # How do I handle exit codes for multiple arguments? + my $errors = 0; + + foreach my $arg ( @$args ) + { + _clear_cpanpm_output(); + $action->( $arg ); + + $errors += defined _cpanpm_output_indicates_failure(); + } + + $errors ? I_DONT_KNOW_WHAT_HAPPENED : HEY_IT_WORKED; + } + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + +=for comment + +CPAN.pm sends all the good stuff either to STDOUT. I have to intercept +that output so I can find out what happened. + +=cut + +{ +my $scalar = ''; + +sub _hook_into_CPANpm_report + { + no warnings 'redefine'; + + *CPAN::Shell::myprint = sub { + my($self,$what) = @_; + $scalar .= $what if defined $what; + $self->print_ornamented($what, + $CPAN::Config->{colorize_print}||'bold blue on_white', + ); + }; + + *CPAN::Shell::mywarn = sub { + my($self,$what) = @_; + $scalar .= $what if defined $what; + $self->print_ornamented($what, + $CPAN::Config->{colorize_warn}||'bold red on_white' + ); + }; + + } + +sub _clear_cpanpm_output { $scalar = '' } + +sub _get_cpanpm_output { $scalar } + +BEGIN { +my @skip_lines = ( + qr/^\QWarning \(usually harmless\)/, + qr/\bwill not store persistent state\b/, + qr(//hint//), + qr/^\s+reports\s+/, + ); + +sub _get_cpanpm_last_line + { + open my($fh), "<", \ $scalar; + + my @lines = <$fh>; + + # This is a bit ugly. Once we examine a line, we have to + # examine the line before it and go through all of the same + # regexes. I could do something fancy, but this works. + REGEXES: { + foreach my $regex ( @skip_lines ) + { + if( $lines[-1] =~ m/$regex/ ) + { + pop @lines; + redo REGEXES; # we have to go through all of them for every line! + } + } + } + + $logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" ); + + $lines[-1]; + } +} + +BEGIN { +my $epic_fail_words = join '|', + qw( Error stop(?:ping)? problems force not unsupported fail(?:ed)? ); + +sub _cpanpm_output_indicates_failure + { + my $last_line = _get_cpanpm_last_line(); + + my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i; + $result || (); + } +} + +sub _cpanpm_output_indicates_success + { + my $last_line = _get_cpanpm_last_line(); + + my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/; + $result || (); + } + +sub _cpanpm_output_is_vague + { + return FALSE if + _cpanpm_output_indicates_failure() || + _cpanpm_output_indicates_success(); + + return TRUE; + } + +} + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +sub _print_help + { + $logger->info( "Use perldoc to read the documentation" ); + exec "perldoc $0"; + } + +sub _print_version + { + $logger->info( + "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION ); + + return HEY_IT_WORKED; + } + +sub _create_autobundle + { + $logger->info( + "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" ); + + CPAN::Shell->autobundle; + + return HEY_IT_WORKED; + } + +sub _recompile + { + $logger->info( "Recompiling dynamically-loaded extensions" ); + + CPAN::Shell->recompile; + + return HEY_IT_WORKED; + } + +sub _upgrade + { + $logger->info( "Upgrading all modules" ); + + CPAN::Shell->upgrade(); + + return HEY_IT_WORKED; + } + +sub _load_config # -j + { + my $file = shift || ''; + + # should I clear out any existing config here? + $CPAN::Config = {}; + delete $INC{'CPAN/Config.pm'}; + croak( "Config file [$file] does not exist!\n" ) unless -e $file; + + my $rc = eval "require '$file'"; + + # CPAN::HandleConfig::require_myconfig_or_config looks for this + $INC{'CPAN/MyConfig.pm'} = 'fake out!'; + + # CPAN::HandleConfig::load looks for this + $CPAN::Config_loaded = 'fake out'; + + croak( "Could not load [$file]: $@\n") unless $rc; + + return HEY_IT_WORKED; + } + +sub _dump_config + { + my $args = shift; + require Data::Dumper; + + my $fh = $args->[0] || \*STDOUT; + + my $dd = Data::Dumper->new( + [$CPAN::Config], + ['$CPAN::Config'] + ); + + print $fh $dd->Dump, "\n1;\n__END__\n"; + + return HEY_IT_WORKED; + } + +sub _lock_lobotomy + { + no warnings 'redefine'; + + *CPAN::_flock = sub { 1 }; + *CPAN::checklock = sub { 1 }; + + return HEY_IT_WORKED; + } + +sub _download + { + my $args = shift; + + local $CPAN::DEBUG = 1; + + my %paths; + + foreach my $module ( @$args ) + { + $logger->info( "Checking $module" ); + my $path = CPAN::Shell->expand( "Module", $module )->cpan_file; + + $logger->debug( "Inst file would be $path\n" ); + + $paths{$module} = _get_file( _make_path( $path ) ); + } + + return \%paths; + } + +sub _make_path { join "/", qw(authors id), $_[0] } + +sub _get_file + { + my $path = shift; + + my $loaded = eval "require LWP::Simple; 1;"; + croak "You need LWP::Simple to use features that fetch files from CPAN\n" + unless $loaded; + + my $file = substr $path, rindex( $path, '/' ) + 1; + my $store_path = catfile( cwd(), $file ); + $logger->debug( "Store path is $store_path" ); + + foreach my $site ( @{ $CPAN::Config->{urllist} } ) + { + my $fetch_path = join "/", $site, $path; + $logger->debug( "Trying $fetch_path" ); + last if LWP::Simple::getstore( $fetch_path, $store_path ); + } + + return $store_path; + } + +sub _gitify + { + my $args = shift; + + my $loaded = eval "require Archive::Extract; 1;"; + croak "You need Archive::Extract to use features that gitify distributions\n" + unless $loaded; + + my $starting_dir = cwd(); + + foreach my $module ( @$args ) + { + $logger->info( "Checking $module" ); + my $path = CPAN::Shell->expand( "Module", $module )->cpan_file; + + my $store_paths = _download( [ $module ] ); + $logger->debug( "gitify Store path is $store_paths->{$module}" ); + my $dirname = dirname( $store_paths->{$module} ); + + my $ae = Archive::Extract->new( archive => $store_paths->{$module} ); + $ae->extract( to => $dirname ); + + chdir $ae->extract_path; + + my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git'; + croak "Could not find $git" unless -e $git; + croak "$git is not executable" unless -x $git; + + # can we do this in Pure Perl? + system( $git, 'init' ); + system( $git, qw( add . ) ); + system( $git, qw( commit -a -m ), 'initial import' ); + } + + chdir $starting_dir; + + return HEY_IT_WORKED; + } + +sub _show_Changes + { + my $args = shift; + + foreach my $arg ( @$args ) + { + $logger->info( "Checking $arg\n" ); + + my $module = eval { CPAN::Shell->expand( "Module", $arg ) }; + my $out = _get_cpanpm_output(); + + next unless eval { $module->inst_file }; + #next if $module->uptodate; + + ( my $id = $module->id() ) =~ s/::/\-/; + + my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" . + $id . "-" . $module->cpan_version() . "/"; + + #print "URL: $url\n"; + _get_changes_file($url); + } + + return HEY_IT_WORKED; + } + +sub _get_changes_file + { + croak "Reading Changes files requires LWP::Simple and URI\n" + unless eval "require LWP::Simple; require URI; 1"; + + my $url = shift; + + my $content = LWP::Simple::get( $url ); + $logger->info( "Got $url ..." ) if defined $content; + #print $content; + + my( $change_link ) = $content =~ m|Changes|gi; + + my $changes_url = URI->new_abs( $change_link, $url ); + $logger->debug( "Change link is: $changes_url" ); + + my $changes = LWP::Simple::get( $changes_url ); + + print $changes; + + return HEY_IT_WORKED; + } + +sub _show_Author + { + my $args = shift; + + foreach my $arg ( @$args ) + { + my $module = CPAN::Shell->expand( "Module", $arg ); + unless( $module ) + { + $logger->info( "Didn't find a $arg module, so no author!" ); + next; + } + + my $author = CPAN::Shell->expand( "Author", $module->userid ); + + next unless $module->userid; + + printf "%-25s %-8s %-25s %s\n", + $arg, $module->userid, $author->email, $author->fullname; + } + + return HEY_IT_WORKED; + } + +sub _show_Details + { + my $args = shift; + + foreach my $arg ( @$args ) + { + my $module = CPAN::Shell->expand( "Module", $arg ); + my $author = CPAN::Shell->expand( "Author", $module->userid ); + + next unless $module->userid; + + print "$arg\n", "-" x 73, "\n\t"; + print join "\n\t", + $module->description ? $module->description : "(no description)", + $module->cpan_file, + $module->inst_file, + 'Installed: ' . $module->inst_version, + 'CPAN: ' . $module->cpan_version . ' ' . + ($module->uptodate ? "" : "Not ") . "up to date", + $author->fullname . " (" . $module->userid . ")", + $author->email; + print "\n\n"; + + } + + return HEY_IT_WORKED; + } + +sub _show_out_of_date + { + my @modules = CPAN::Shell->expand( "Module", "/./" ); + + printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN"; + print "-" x 73, "\n"; + + foreach my $module ( @modules ) + { + next unless $module->inst_file; + next if $module->uptodate; + printf "%-40s %.4f %.4f\n", + $module->id, + $module->inst_version ? $module->inst_version : '', + $module->cpan_version; + } + + return HEY_IT_WORKED; + } + +sub _show_author_mods + { + my $args = shift; + + my %hash = map { lc $_, 1 } @$args; + + my @modules = CPAN::Shell->expand( "Module", "/./" ); + + foreach my $module ( @modules ) + { + next unless exists $hash{ lc $module->userid }; + print $module->id, "\n"; + } + + return HEY_IT_WORKED; + } + +sub _list_all_mods + { + require File::Find; + + my $args = shift; + + + my $fh = \*STDOUT; + + INC: foreach my $inc ( @INC ) + { + my( $wanted, $reporter ) = _generator(); + File::Find::find( { wanted => $wanted }, $inc ); + + my $count = 0; + FILE: foreach my $file ( @{ $reporter->() } ) + { + my $version = _parse_version_safely( $file ); + + my $module_name = _path_to_module( $inc, $file ); + next FILE unless defined $module_name; + + print $fh "$module_name\t$version\n"; + + #last if $count++ > 5; + } + } + + return HEY_IT_WORKED; + } + +sub _generator + { + my @files = (); + + sub { push @files, + File::Spec->canonpath( $File::Find::name ) + if m/\A\w+\.pm\z/ }, + sub { \@files }, + } + +sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored + { + my( $file ) = @_; + + local $/ = "\n"; + local $_; # don't mess with the $_ in the map calling this + + return unless open FILE, "<$file"; + + my $in_pod = 0; + my $version; + while( ) + { + chomp; + $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod; + next if $in_pod || /^\s*#/; + + next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; + my( $sigil, $var ) = ( $1, $2 ); + + $version = _eval_version( $_, $sigil, $var ); + last; + } + close FILE; + + return 'undef' unless defined $version; + + return $version; + } + +sub _eval_version + { + my( $line, $sigil, $var ) = @_; + + my $eval = qq{ + package ExtUtils::MakeMaker::_version; + + local $sigil$var; + \$$var=undef; do { + $line + }; \$$var + }; + + my $version = do { + local $^W = 0; + no strict; + eval( $eval ); + }; + + return $version; + } + +sub _path_to_module + { + my( $inc, $path ) = @_; + return if length $path< length $inc; + + my $module_path = substr( $path, length $inc ); + $module_path =~ s/\.pm\z//; + + # XXX: this is cheating and doesn't handle everything right + my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path ); + shift @dirs; + + my $module_name = join "::", @dirs; + + return $module_name; + } + +1; + +=back + +=head1 EXIT VALUES + +The script exits with zero if it thinks that everything worked, or a +positive number if it thinks that something failed. Note, however, that +in some cases it has to divine a failure by the output of things it does +not control. For now, the exit codes are vague: + + 1 An unknown error + + 2 The was an external problem + + 4 There was an internal problem with the script + + 8 A module failed to install + +=head1 TO DO + +* There is initial support for Log4perl if it is available, but I +haven't gone through everything to make the NullLogger work out +correctly if Log4perl is not installed. + +* When I capture CPAN.pm output, I need to check for errors and +report them to the user. + +=head1 BUGS + +* none noted + +=head1 SEE ALSO + +Most behaviour, including environment variables and configuration, +comes directly from CPAN.pm. + +=head1 SOURCE AVAILABILITY + +This code is in Github: + + git://github.com/briandfoy/cpan_script.git + +=head1 CREDITS + +Japheth Cleaver added the bits to allow a forced install (-f). + +Jim Brandt suggest and provided the initial implementation for the +up-to-date and Changes features. + +Adam Kennedy pointed out that exit() causes problems on Windows +where this script ends up with a .bat extension + +=head1 AUTHOR + +brian d foy, C<< >> + +=head1 COPYRIGHT + +Copyright (c) 2001-2009, brian d foy, All Rights Reserved. + +You may redistribute this under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/App/Prove.pm b/Master/tlpkg/tlperl/lib/App/Prove.pm new file mode 100644 index 00000000000..fd431ed2f05 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/App/Prove.pm @@ -0,0 +1,774 @@ +package App::Prove; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Object (); +use TAP::Harness; +use TAP::Parser::Utils qw( split_shell ); +use File::Spec; +use Getopt::Long; +use App::Prove::State; +use Carp; + +=head1 NAME + +App::Prove - Implements the C command. + +=head1 VERSION + +Version 3.17 + +=cut + +$VERSION = '3.17'; + +=head1 DESCRIPTION + +L provides a command, C, which runs a TAP based +test suite and prints a report. The C command is a minimal +wrapper around an instance of this module. + +=head1 SYNOPSIS + + use App::Prove; + + my $app = App::Prove->new; + $app->process_args(@ARGV); + $app->run; + +=cut + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => $^O eq 'VMS'; +use constant IS_UNIXY => !( IS_VMS || IS_WIN32 ); + +use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove'; +use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc'; + +use constant PLUGINS => 'App::Prove::Plugin'; + +my @ATTR; + +BEGIN { + @ISA = qw(TAP::Object); + + @ATTR = qw( + archive argv blib show_count color directives exec failures comments + formatter harness includes modules plugins jobs lib merge parse quiet + really_quiet recurse backwards shuffle taint_fail taint_warn timer + verbose warnings_fail warnings_warn show_help show_man show_version + state_class test_args state dry extension ignore_exit rules state_manager + normalize + ); + __PACKAGE__->mk_methods(@ATTR); +} + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +Create a new C. Optionally a hash ref of attribute +initializers may be passed. + +=cut + +# new() implementation supplied by TAP::Object + +sub _initialize { + my $self = shift; + my $args = shift || {}; + + # setup defaults: + for my $key (qw( argv rc_opts includes modules state plugins rules )) { + $self->{$key} = []; + } + $self->{harness_class} = 'TAP::Harness'; + + for my $attr (@ATTR) { + if ( exists $args->{$attr} ) { + + # TODO: Some validation here + $self->{$attr} = $args->{$attr}; + } + } + + my %env_provides_default = ( + HARNESS_TIMER => 'timer', + ); + + while ( my ( $env, $attr ) = each %env_provides_default ) { + $self->{$attr} = 1 if $ENV{$env}; + } + $self->state_class('App::Prove::State'); + return $self; +} + +=head3 C + +Getter/setter for the name of the class used for maintaining state. This +class should either subclass from C or provide an identical +interface. + +=head3 C + +Getter/setter for the instance of the C. + +=cut + +=head3 C + + $prove->add_rc_file('myproj/.proverc'); + +Called before C to prepend the contents of an rc file to +the options. + +=cut + +sub add_rc_file { + my ( $self, $rc_file ) = @_; + + local *RC; + open RC, "<$rc_file" or croak "Can't read $rc_file ($!)"; + while ( defined( my $line = ) ) { + push @{ $self->{rc_opts} }, + grep { defined and not /^#/ } + $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg; + } + close RC; +} + +=head3 C + + $prove->process_args(@args); + +Processes the command-line arguments. Attributes will be set +appropriately. Any filenames may be found in the C attribute. + +Dies on invalid arguments. + +=cut + +sub process_args { + my $self = shift; + + my @rc = RC_FILE; + unshift @rc, glob '~/' . RC_FILE if IS_UNIXY; + + # Preprocess meta-args. + my @args; + while ( defined( my $arg = shift ) ) { + if ( $arg eq '--norc' ) { + @rc = (); + } + elsif ( $arg eq '--rc' ) { + defined( my $rc = shift ) + or croak "Missing argument to --rc"; + push @rc, $rc; + } + elsif ( $arg =~ m{^--rc=(.+)$} ) { + push @rc, $1; + } + else { + push @args, $arg; + } + } + + # Everything after the arisdottle '::' gets passed as args to + # test programs. + if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) { + my @test_args = splice @args, $stop_at; + shift @test_args; + $self->{test_args} = \@test_args; + } + + # Grab options from RC files + $self->add_rc_file($_) for grep -f, @rc; + unshift @args, @{ $self->{rc_opts} }; + + if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) { + die "Long options should be written with two dashes: ", + join( ', ', @bad ), "\n"; + } + + # And finally... + + { + local @ARGV = @args; + Getopt::Long::Configure( 'no_ignore_case', 'bundling' ); + + # Don't add coderefs to GetOptions + GetOptions( + 'v|verbose' => \$self->{verbose}, + 'f|failures' => \$self->{failures}, + 'o|comments' => \$self->{comments}, + 'l|lib' => \$self->{lib}, + 'b|blib' => \$self->{blib}, + 's|shuffle' => \$self->{shuffle}, + 'color!' => \$self->{color}, + 'colour!' => \$self->{color}, + 'count!' => \$self->{show_count}, + 'c' => \$self->{color}, + 'D|dry' => \$self->{dry}, + 'ext=s' => \$self->{extension}, + 'harness=s' => \$self->{harness}, + 'ignore-exit' => \$self->{ignore_exit}, + 'formatter=s' => \$self->{formatter}, + 'r|recurse' => \$self->{recurse}, + 'reverse' => \$self->{backwards}, + 'p|parse' => \$self->{parse}, + 'q|quiet' => \$self->{quiet}, + 'Q|QUIET' => \$self->{really_quiet}, + 'e|exec=s' => \$self->{exec}, + 'm|merge' => \$self->{merge}, + 'I=s@' => $self->{includes}, + 'M=s@' => $self->{modules}, + 'P=s@' => $self->{plugins}, + 'state=s@' => $self->{state}, + 'directives' => \$self->{directives}, + 'h|help|?' => \$self->{show_help}, + 'H|man' => \$self->{show_man}, + 'V|version' => \$self->{show_version}, + 'a|archive=s' => \$self->{archive}, + 'j|jobs=i' => \$self->{jobs}, + 'timer' => \$self->{timer}, + 'T' => \$self->{taint_fail}, + 't' => \$self->{taint_warn}, + 'W' => \$self->{warnings_fail}, + 'w' => \$self->{warnings_warn}, + 'normalize' => \$self->{normalize}, + 'rules=s@' => $self->{rules}, + ) or croak('Unable to continue'); + + # Stash the remainder of argv for later + $self->{argv} = [@ARGV]; + } + + return; +} + +sub _first_pos { + my $want = shift; + for ( 0 .. $#_ ) { + return $_ if $_[$_] eq $want; + } + return; +} + +sub _help { + my ( $self, $verbosity ) = @_; + + eval('use Pod::Usage 1.12 ()'); + if ( my $err = $@ ) { + die 'Please install Pod::Usage for the --help option ' + . '(or try `perldoc prove`.)' + . "\n ($@)"; + } + + Pod::Usage::pod2usage( { -verbose => $verbosity } ); + + return; +} + +sub _color_default { + my $self = shift; + + return -t STDOUT && !$ENV{HARNESS_NOTTY} && !IS_WIN32; +} + +sub _get_args { + my $self = shift; + + my %args; + + if ( defined $self->color ? $self->color : $self->_color_default ) { + $args{color} = 1; + } + if ( !defined $self->show_count ) { + $args{show_count} = 1; + } + else { + $args{show_count} = $self->show_count; + } + + if ( $self->archive ) { + $self->require_harness( archive => 'TAP::Harness::Archive' ); + $args{archive} = $self->archive; + } + + if ( my $jobs = $self->jobs ) { + $args{jobs} = $jobs; + } + + if ( my $harness_opt = $self->harness ) { + $self->require_harness( harness => $harness_opt ); + } + + if ( my $formatter = $self->formatter ) { + $args{formatter_class} = $formatter; + } + + if ( $self->ignore_exit ) { + $args{ignore_exit} = 1; + } + + if ( $self->taint_fail && $self->taint_warn ) { + die '-t and -T are mutually exclusive'; + } + + if ( $self->warnings_fail && $self->warnings_warn ) { + die '-w and -W are mutually exclusive'; + } + + for my $a (qw( lib switches )) { + my $method = "_get_$a"; + my $val = $self->$method(); + $args{$a} = $val if defined $val; + } + + # Handle verbose, quiet, really_quiet flags + my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, ); + + my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 } + keys %verb_map; + + die "Only one of verbose, quiet or really_quiet should be specified\n" + if @verb_adj > 1; + + $args{verbosity} = shift @verb_adj || 0; + + for my $a (qw( merge failures comments timer directives normalize )) { + $args{$a} = 1 if $self->$a(); + } + + $args{errors} = 1 if $self->parse; + + # defined but zero-length exec runs test files as binaries + $args{exec} = [ split( /\s+/, $self->exec ) ] + if ( defined( $self->exec ) ); + + if ( defined( my $test_args = $self->test_args ) ) { + $args{test_args} = $test_args; + } + + if ( @{ $self->rules } ) { + my @rules; + for ( @{ $self->rules } ) { + if (/^par=(.*)/) { + push @rules, $1; + } + elsif (/^seq=(.*)/) { + push @rules, { seq => $1 }; + } + } + $args{rules} = { par => [@rules] }; + } + + return ( \%args, $self->{harness_class} ); +} + +sub _find_module { + my ( $self, $class, @search ) = @_; + + croak "Bad module name $class" + unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; + + for my $pfx (@search) { + my $name = join( '::', $pfx, $class ); + eval "require $name"; + return $name unless $@; + } + + eval "require $class"; + return $class unless $@; + return; +} + +sub _load_extension { + my ( $self, $name, @search ) = @_; + + my @args = (); + if ( $name =~ /^(.*?)=(.*)/ ) { + $name = $1; + @args = split( /,/, $2 ); + } + + if ( my $class = $self->_find_module( $name, @search ) ) { + $class->import(@args); + if ( $class->can('load') ) { + $class->load( { app_prove => $self, args => [@args] } ); + } + } + else { + croak "Can't load module $name"; + } +} + +sub _load_extensions { + my ( $self, $ext, @search ) = @_; + $self->_load_extension( $_, @search ) for @$ext; +} + +=head3 C + +Perform whatever actions the command line args specified. The C +command line tool consists of the following code: + + use App::Prove; + + my $app = App::Prove->new; + $app->process_args(@ARGV); + exit( $app->run ? 0 : 1 ); # if you need the exit code + +=cut + +sub run { + my $self = shift; + + unless ( $self->state_manager ) { + $self->state_manager( + $self->state_class->new( { store => STATE_FILE } ) ); + } + + if ( $self->show_help ) { + $self->_help(1); + } + elsif ( $self->show_man ) { + $self->_help(2); + } + elsif ( $self->show_version ) { + $self->print_version; + } + elsif ( $self->dry ) { + print "$_\n" for $self->_get_tests; + } + else { + + $self->_load_extensions( $self->modules ); + $self->_load_extensions( $self->plugins, PLUGINS ); + + local $ENV{TEST_VERBOSE} = 1 if $self->verbose; + + return $self->_runtests( $self->_get_args, $self->_get_tests ); + } + + return 1; +} + +sub _get_tests { + my $self = shift; + + my $state = $self->state_manager; + my $ext = $self->extension; + $state->extension($ext) if defined $ext; + if ( defined( my $state_switch = $self->state ) ) { + $state->apply_switch(@$state_switch); + } + + my @tests = $state->get_tests( $self->recurse, @{ $self->argv } ); + + $self->_shuffle(@tests) if $self->shuffle; + @tests = reverse @tests if $self->backwards; + + return @tests; +} + +sub _runtests { + my ( $self, $args, $harness_class, @tests ) = @_; + my $harness = $harness_class->new($args); + + my $state = $self->state_manager; + + $harness->callback( + after_test => sub { + $state->observe_test(@_); + } + ); + + $harness->callback( + after_runtests => sub { + $state->commit(@_); + } + ); + + my $aggregator = $harness->runtests(@tests); + + return !$aggregator->has_errors; +} + +sub _get_switches { + my $self = shift; + my @switches; + + # notes that -T or -t must be at the front of the switches! + if ( $self->taint_fail ) { + push @switches, '-T'; + } + elsif ( $self->taint_warn ) { + push @switches, '-t'; + } + if ( $self->warnings_fail ) { + push @switches, '-W'; + } + elsif ( $self->warnings_warn ) { + push @switches, '-w'; + } + + push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} ); + + return @switches ? \@switches : (); +} + +sub _get_lib { + my $self = shift; + my @libs; + if ( $self->lib ) { + push @libs, 'lib'; + } + if ( $self->blib ) { + push @libs, 'blib/lib', 'blib/arch'; + } + if ( @{ $self->includes } ) { + push @libs, @{ $self->includes }; + } + + #24926 + @libs = map { File::Spec->rel2abs($_) } @libs; + + # Huh? + return @libs ? \@libs : (); +} + +sub _shuffle { + my $self = shift; + + # Fisher-Yates shuffle + my $i = @_; + while ($i) { + my $j = rand $i--; + @_[ $i, $j ] = @_[ $j, $i ]; + } + return; +} + +=head3 C + +Load a harness replacement class. + + $prove->require_harness($for => $class_name); + +=cut + +sub require_harness { + my ( $self, $for, $class ) = @_; + + my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/; + + # Emulate Perl's -MModule=arg1,arg2 behaviour + $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!; + + eval("use $class;"); + die "$class_name is required to use the --$for feature: $@" if $@; + + $self->{harness_class} = $class_name; + + return; +} + +=head3 C + +Display the version numbers of the loaded L and the +current Perl. + +=cut + +sub print_version { + my $self = shift; + printf( + "TAP::Harness v%s and Perl v%vd\n", + $TAP::Harness::VERSION, $^V + ); + + return; +} + +1; + +# vim:ts=4:sw=4:et:sta + +__END__ + +=head2 Attributes + +After command line parsing the following attributes reflect the values +of the corresponding command line switches. They may be altered before +calling C. + +=over + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=back + +=head1 PLUGINS + +C provides support for 3rd-party plugins. These are currently +loaded at run-time, I arguments have been parsed (so you can not +change the way arguments are processed, sorry), typically with the +C<< -PI >> switch, eg: + + prove -PMyPlugin + +This will search for a module named C, or failing +that, C. If the plugin can't be found, C will complain & exit. + +You can pass an argument to your plugin by appending an C<=> after the plugin +name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas: + + prove -PMyPlugin=foo,bar,baz + +These are passed in to your plugin's C class method (if it has one), +along with a reference to the C object that is invoking your plugin: + + sub load { + my ($class, $p) = @_; + + my @args = @{ $p->{args} }; + # @args will contain ( 'foo', 'bar', 'baz' ) + $p->{app_prove}->do_something; + ... + } + +Note that the user's arguments are also passed to your plugin's C +function as a list, eg: + + sub import { + my ($class, @args) = @_; + # @args will contain ( 'foo', 'bar', 'baz' ) + ... + } + +This is for backwards compatibility, and may be deprecated in the future. + +=head2 Sample Plugin + +Here's a sample plugin, for your reference: + + package App::Prove::Plugin::Foo; + + # Sample plugin, try running with: + # prove -PFoo=bar -r -j3 + # prove -PFoo -Q + # prove -PFoo=bar,My::Formatter + + use strict; + use warnings; + + sub load { + my ($class, $p) = @_; + my @args = @{ $p->{args} }; + my $app = $p->{app_prove}; + + print "loading plugin: $class, args: ", join(', ', @args ), "\n"; + + # turn on verbosity + $app->verbose( 1 ); + + # set the formatter? + $app->formatter( $args[1] ) if @args > 1; + + # print some of App::Prove's state: + for my $attr (qw( jobs quiet really_quiet recurse verbose )) { + my $val = $app->$attr; + $val = 'undef' unless defined( $val ); + print "$attr: $val\n"; + } + + return 1; + } + + 1; + +=head1 SEE ALSO + +L, L + +=cut diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State.pm b/Master/tlpkg/tlperl/lib/App/Prove/State.pm new file mode 100644 index 00000000000..202f7aadd3b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/App/Prove/State.pm @@ -0,0 +1,517 @@ +package App::Prove::State; + +use strict; +use vars qw($VERSION @ISA); + +use File::Find; +use File::Spec; +use Carp; + +use App::Prove::State::Result; +use TAP::Parser::YAMLish::Reader (); +use TAP::Parser::YAMLish::Writer (); +use TAP::Base; + +BEGIN { + @ISA = qw( TAP::Base ); + __PACKAGE__->mk_methods('result_class'); +} + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant NEED_GLOB => IS_WIN32; + +=head1 NAME + +App::Prove::State - State storage for the C command. + +=head1 VERSION + +Version 3.17 + +=cut + +$VERSION = '3.17'; + +=head1 DESCRIPTION + +The C command supports a C<--state> option that instructs it to +store persistent state across runs. This module implements that state +and the operations that may be performed on it. + +=head1 SYNOPSIS + + # Re-run failed tests + $ prove --state=fail,save -rbv + +=cut + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +Accepts a hashref with the following key/value pairs: + +=over 4 + +=item * C + +The filename of the data store holding the data that App::Prove::State reads. + +=item * C (optional) + +The test name extension. Defaults to C<.t>. + +=item * C (optional) + +The name of the C. Defaults to C. + +=back + +=cut + +# override TAP::Base::new: +sub new { + my $class = shift; + my %args = %{ shift || {} }; + + my $self = bless { + select => [], + seq => 1, + store => delete $args{store}, + extension => ( delete $args{extension} || '.t' ), + result_class => + ( delete $args{result_class} || 'App::Prove::State::Result' ), + }, $class; + + $self->{_} = $self->result_class->new( + { tests => {}, + generation => 1, + } + ); + my $store = $self->{store}; + $self->load($store) + if defined $store && -f $store; + + return $self; +} + +=head2 C + +Getter/setter for the name of the class used for tracking test results. This +class should either subclass from C or provide an +identical interface. + +=cut + +=head2 C + +Get or set the extension files must have in order to be considered +tests. Defaults to '.t'. + +=cut + +sub extension { + my $self = shift; + $self->{extension} = shift if @_; + return $self->{extension}; +} + +=head2 C + +Get the results of the last test run. Returns a C instance. + +=cut + +sub results { + my $self = shift; + $self->{_} || $self->result_class->new; +} + +=head2 C + +Save the test results. Should be called after all tests have run. + +=cut + +sub commit { + my $self = shift; + if ( $self->{should_save} ) { + $self->save; + } +} + +=head2 Instance Methods + +=head3 C + + $self->apply_switch('failed,save'); + +Apply a list of switch options to the state, updating the internal +object state as a result. Nothing is returned. + +Diagnostics: + - "Illegal state option: %s" + +=over + +=item C + +Run in the same order as last time + +=item C + +Run only the failed tests from last time + +=item C + +Run only the passed tests from last time + +=item C + +Run all tests in normal order + +=item C + +Run the tests that most recently failed first + +=item C + +Run the tests ordered by number of todos. + +=item C + +Run the tests in slowest to fastest order. + +=item C + +Run test tests in fastest to slowest order. + +=item C + +Run the tests in newest to oldest order. + +=item C + +Run the tests in oldest to newest order. + +=item C + +Save the state on exit. + +=back + +=cut + +sub apply_switch { + my $self = shift; + my @opts = @_; + + my $last_gen = $self->results->generation - 1; + my $last_run_time = $self->results->last_run_time; + my $now = $self->get_time; + + my @switches = map { split /,/ } @opts; + + my %handler = ( + last => sub { + $self->_select( + where => sub { $_->generation >= $last_gen }, + order => sub { $_->sequence } + ); + }, + failed => sub { + $self->_select( + where => sub { $_->result != 0 }, + order => sub { -$_->result } + ); + }, + passed => sub { + $self->_select( where => sub { $_->result == 0 } ); + }, + all => sub { + $self->_select(); + }, + todo => sub { + $self->_select( + where => sub { $_->num_todo != 0 }, + order => sub { -$_->num_todo; } + ); + }, + hot => sub { + $self->_select( + where => sub { defined $_->last_fail_time }, + order => sub { $now - $_->last_fail_time } + ); + }, + slow => sub { + $self->_select( order => sub { -$_->elapsed } ); + }, + fast => sub { + $self->_select( order => sub { $_->elapsed } ); + }, + new => sub { + $self->_select( order => sub { -$_->mtime } ); + }, + old => sub { + $self->_select( order => sub { $_->mtime } ); + }, + fresh => sub { + $self->_select( where => sub { $_->mtime >= $last_run_time } ); + }, + save => sub { + $self->{should_save}++; + }, + adrian => sub { + unshift @switches, qw( hot all save ); + }, + ); + + while ( defined( my $ele = shift @switches ) ) { + my ( $opt, $arg ) + = ( $ele =~ /^([^:]+):(.*)/ ) + ? ( $1, $2 ) + : ( $ele, undef ); + my $code = $handler{$opt} + || croak "Illegal state option: $opt"; + $code->($arg); + } + return; +} + +sub _select { + my ( $self, %spec ) = @_; + push @{ $self->{select} }, \%spec; +} + +=head3 C + +Given a list of args get the names of tests that should run + +=cut + +sub get_tests { + my $self = shift; + my $recurse = shift; + my @argv = @_; + my %seen; + + my @selected = $self->_query; + + unless ( @argv || @{ $self->{select} } ) { + @argv = $recurse ? '.' : 't'; + croak qq{No tests named and '@argv' directory not found} + unless -d $argv[0]; + } + + push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv; + return grep { !$seen{$_}++ } @selected; +} + +sub _query { + my $self = shift; + if ( my @sel = @{ $self->{select} } ) { + warn "No saved state, selection will be empty\n" + unless $self->results->num_tests; + return map { $self->_query_clause($_) } @sel; + } + return; +} + +sub _query_clause { + my ( $self, $clause ) = @_; + my @got; + my $results = $self->results; + my $where = $clause->{where} || sub {1}; + + # Select + for my $name ( $results->test_names ) { + next unless -f $name; + local $_ = $results->test($name); + push @got, $name if $where->(); + } + + # Sort + if ( my $order = $clause->{order} ) { + @got = map { $_->[0] } + sort { + ( defined $b->[1] <=> defined $a->[1] ) + || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) ) + } map { + [ $_, + do { local $_ = $results->test($_); $order->() } + ] + } @got; + } + + return @got; +} + +sub _get_raw_tests { + my $self = shift; + my $recurse = shift; + my @argv = @_; + my @tests; + + # Do globbing on Win32. + @argv = map { glob "$_" } @argv if NEED_GLOB; + my $extension = $self->{extension}; + + for my $arg (@argv) { + if ( '-' eq $arg ) { + push @argv => ; + chomp(@argv); + next; + } + + push @tests, + sort -d $arg + ? $recurse + ? $self->_expand_dir_recursive( $arg, $extension ) + : glob( File::Spec->catfile( $arg, "*$extension" ) ) + : $arg; + } + return @tests; +} + +sub _expand_dir_recursive { + my ( $self, $dir, $extension ) = @_; + + my @tests; + find( + { follow => 1, #21938 + follow_skip => 2, + wanted => sub { + -f + && /\Q$extension\E$/ + && push @tests => $File::Find::name; + } + }, + $dir + ); + return @tests; +} + +=head3 C + +Store the results of a test. + +=cut + +# Store: +# last fail time +# last pass time +# last run time +# most recent result +# most recent todos +# total failures +# total passes +# state generation +# parser + +sub observe_test { + + my ( $self, $test_info, $parser ) = @_; + my $name = $test_info->[0]; + my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ); + my $todo = scalar( $parser->todo ); + my $start_time = $parser->start_time; + my $end_time = $parser->end_time, + + my $test = $self->results->test($name); + + $test->sequence( $self->{seq}++ ); + $test->generation( $self->results->generation ); + + $test->run_time($end_time); + $test->result($fail); + $test->num_todo($todo); + $test->elapsed( $end_time - $start_time ); + + $test->parser($parser); + + if ($fail) { + $test->total_failures( $test->total_failures + 1 ); + $test->last_fail_time($end_time); + } + else { + $test->total_passes( $test->total_passes + 1 ); + $test->last_pass_time($end_time); + } +} + +=head3 C + +Write the state to a file. + +=cut + +sub save { + my ($self) = @_; + + my $store = $self->{store} or return; + $self->results->last_run_time( $self->get_time ); + + my $writer = TAP::Parser::YAMLish::Writer->new; + local *FH; + open FH, ">$store" or croak "Can't write $store ($!)"; + $writer->write( $self->results->raw, \*FH ); + close FH; +} + +=head3 C + +Load the state from a file + +=cut + +sub load { + my ( $self, $name ) = @_; + my $reader = TAP::Parser::YAMLish::Reader->new; + local *FH; + open FH, "<$name" or croak "Can't read $name ($!)"; + + # XXX this is temporary + $self->{_} = $self->result_class->new( + $reader->read( + sub { + my $line = ; + defined $line && chomp $line; + return $line; + } + ) + ); + + # $writer->write( $self->{tests} || {}, \*FH ); + close FH; + $self->_regen_seq; + $self->_prune_and_stamp; + $self->results->generation( $self->results->generation + 1 ); +} + +sub _prune_and_stamp { + my $self = shift; + + my $results = $self->results; + my @tests = $self->results->tests; + for my $test (@tests) { + my $name = $test->name; + if ( my @stat = stat $name ) { + $test->mtime( $stat[9] ); + } + else { + $results->remove($name); + } + } +} + +sub _regen_seq { + my $self = shift; + for my $test ( $self->results->tests ) { + $self->{seq} = $test->sequence + 1 + if defined $test->sequence && $test->sequence >= $self->{seq}; + } +} + +1; diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm b/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm new file mode 100644 index 00000000000..274676a62f9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm @@ -0,0 +1,233 @@ +package App::Prove::State::Result; + +use strict; +use Carp 'croak'; + +use App::Prove::State::Result::Test; +use vars qw($VERSION); + +use constant STATE_VERSION => 1; + +=head1 NAME + +App::Prove::State::Result - Individual test suite results. + +=head1 VERSION + +Version 3.17 + +=cut + +$VERSION = '3.17'; + +=head1 DESCRIPTION + +The C command supports a C<--state> option that instructs it to +store persistent state across runs. This module encapsulates the results for a +single test suite run. + +=head1 SYNOPSIS + + # Re-run failed tests + $ prove --state=fail,save -rbv + +=cut + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $result = App::Prove::State::Result->new({ + generation => $generation, + tests => \%tests, + }); + +Returns a new C instance. + +=cut + +sub new { + my ( $class, $arg_for ) = @_; + $arg_for ||= {}; + my %instance_data = %$arg_for; # shallow copy + $instance_data{version} = $class->state_version; + my $tests = delete $instance_data{tests} || {}; + my $self = bless \%instance_data => $class; + $self->_initialize($tests); + return $self; +} + +sub _initialize { + my ( $self, $tests ) = @_; + my %tests; + while ( my ( $name, $test ) = each %$tests ) { + $tests{$name} = $self->test_class->new( + { %$test, + name => $name + } + ); + } + $self->tests( \%tests ); + return $self; +} + +=head2 C + +Returns the current version of state storage. + +=cut + +sub state_version {STATE_VERSION} + +=head2 C + +Returns the name of the class used for tracking individual tests. This class +should either subclass from C or provide an +identical interface. + +=cut + +sub test_class { + return 'App::Prove::State::Result::Test'; +} + +my %methods = ( + generation => { method => 'generation', default => 0 }, + last_run_time => { method => 'last_run_time', default => undef }, +); + +while ( my ( $key, $description ) = each %methods ) { + my $default = $description->{default}; + no strict 'refs'; + *{ $description->{method} } = sub { + my $self = shift; + if (@_) { + $self->{$key} = shift; + return $self; + } + return $self->{$key} || $default; + }; +} + +=head3 C + +Getter/setter for the "generation" of the test suite run. The first +generation is 1 (one) and subsequent generations are 2, 3, etc. + +=head3 C + +Getter/setter for the time of the test suite run. + +=head3 C + +Returns the tests for a given generation. This is a hashref or a hash, +depending on context called. The keys to the hash are the individual +test names and the value is a hashref with various interesting values. +Each k/v pair might resemble something like this: + + 't/foo.t' => { + elapsed => '0.0428488254547119', + gen => '7', + last_pass_time => '1219328376.07815', + last_result => '0', + last_run_time => '1219328376.07815', + last_todo => '0', + mtime => '1191708862', + seq => '192', + total_passes => '6', + } + +=cut + +sub tests { + my $self = shift; + if (@_) { + $self->{tests} = shift; + return $self; + } + my %tests = %{ $self->{tests} }; + my @tests = sort { $a->sequence <=> $b->sequence } values %tests; + return wantarray ? @tests : \@tests; +} + +=head3 C + + my $test = $result->test('t/customer/create.t'); + +Returns an individual C instance for the +given test name (usually the filename). Will return a new +C instance if the name is not found. + +=cut + +sub test { + my ( $self, $name ) = @_; + croak("test() requires a test name") unless defined $name; + + my $tests = $self->{tests} ||= {}; + if ( my $test = $tests->{$name} ) { + return $test; + } + else { + my $test = $self->test_class->new( { name => $name } ); + $self->{tests}->{$name} = $test; + return $test; + } +} + +=head3 C + +Returns an list of test names, sorted by run order. + +=cut + +sub test_names { + my $self = shift; + return map { $_->name } $self->tests; +} + +=head3 C + + $result->remove($test_name); # remove the test + my $test = $result->test($test_name); # fatal error + +Removes a given test from results. This is a no-op if the test name is not +found. + +=cut + +sub remove { + my ( $self, $name ) = @_; + delete $self->{tests}->{$name}; + return $self; +} + +=head3 C + +Returns the number of tests for a given test suite result. + +=cut + +sub num_tests { keys %{ shift->{tests} } } + +=head3 C + +Returns a hashref of raw results, suitable for serialization by YAML. + +=cut + +sub raw { + my $self = shift; + my %raw = %$self; + + my %tests; + foreach my $test ( $self->tests ) { + $tests{ $test->name } = $test->raw; + } + $raw{tests} = \%tests; + return \%raw; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm b/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm new file mode 100644 index 00000000000..231f78919e2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm @@ -0,0 +1,153 @@ +package App::Prove::State::Result::Test; + +use strict; + +use vars qw($VERSION); + +=head1 NAME + +App::Prove::State::Result::Test - Individual test results. + +=head1 VERSION + +Version 3.17 + +=cut + +$VERSION = '3.17'; + +=head1 DESCRIPTION + +The C command supports a C<--state> option that instructs it to +store persistent state across runs. This module encapsulates the results for a +single test. + +=head1 SYNOPSIS + + # Re-run failed tests + $ prove --state=fail,save -rbv + +=cut + +my %methods = ( + name => { method => 'name' }, + elapsed => { method => 'elapsed', default => 0 }, + gen => { method => 'generation', default => 1 }, + last_pass_time => { method => 'last_pass_time', default => undef }, + last_fail_time => { method => 'last_fail_time', default => undef }, + last_result => { method => 'result', default => 0 }, + last_run_time => { method => 'run_time', default => undef }, + last_todo => { method => 'num_todo', default => 0 }, + mtime => { method => 'mtime', default => undef }, + seq => { method => 'sequence', default => 1 }, + total_passes => { method => 'total_passes', default => 0 }, + total_failures => { method => 'total_failures', default => 0 }, + parser => { method => 'parser' }, +); + +while ( my ( $key, $description ) = each %methods ) { + my $default = $description->{default}; + no strict 'refs'; + *{ $description->{method} } = sub { + my $self = shift; + if (@_) { + $self->{$key} = shift; + return $self; + } + return $self->{$key} || $default; + }; +} + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +=cut + +sub new { + my ( $class, $arg_for ) = @_; + $arg_for ||= {}; + bless $arg_for => $class; +} + +=head2 Instance Methods + +=head3 C + +The name of the test. Usually a filename. + +=head3 C + +The total elapsed times the test took to run, in seconds from the epoch.. + +=head3 C + +The number for the "generation" of the test run. The first generation is 1 +(one) and subsequent generations are 2, 3, etc. + +=head3 C + +The last time the test program passed, in seconds from the epoch. + +Returns C if the program has never passed. + +=head3 C + +The last time the test suite failed, in seconds from the epoch. + +Returns C if the program has never failed. + +=head3 C + +Returns the mtime of the test, in seconds from the epoch. + +=head3 C + +Returns a hashref of raw test data, suitable for serialization by YAML. + +=head3 C + +Currently, whether or not the test suite passed with no 'problems' (such as +TODO passed). + +=head3 C + +The total time it took for the test to run, in seconds. If C is +available, it will have finer granularity. + +=head3 C + +The number of tests with TODO directives. + +=head3 C + +The order in which this test was run for the given test suite result. + +=head3 C + +The number of times the test has passed. + +=head3 C + +The number of times the test has failed. + +=head3 C + +The underlying parser object. This is useful if you need the full +information for the test program. + +=cut + +sub raw { + my $self = shift; + my %raw = %$self; + + # this is backwards-compatibility hack and is not guaranteed. + delete $raw{name}; + delete $raw{parser}; + return \%raw; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Extract.pm b/Master/tlpkg/tlperl/lib/Archive/Extract.pm new file mode 100644 index 00000000000..08676fb1e08 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Archive/Extract.pm @@ -0,0 +1,1511 @@ +package Archive::Extract; + +use strict; + +use Cwd qw[cwd chdir]; +use Carp qw[carp]; +use IPC::Cmd qw[run can_run]; +use FileHandle; +use File::Path qw[mkpath]; +use File::Spec; +use File::Basename qw[dirname basename]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Style => 'gettext'; + +### solaris has silly /bin/tar output ### +use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0; +use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 }; + +### VMS may require quoting upper case command options +use constant ON_VMS => $^O eq 'VMS' ? 1 : 0; + +### Windows needs special treatment of Tar options +use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0; + +### we can't use this extraction method, because of missing +### modules/binaries: +use constant METHOD_NA => []; + +### If these are changed, update @TYPES and the new() POD +use constant TGZ => 'tgz'; +use constant TAR => 'tar'; +use constant GZ => 'gz'; +use constant ZIP => 'zip'; +use constant BZ2 => 'bz2'; +use constant TBZ => 'tbz'; +use constant Z => 'Z'; +use constant LZMA => 'lzma'; + +use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG + $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER + ]; + +$VERSION = '0.38'; +$PREFER_BIN = 0; +$WARN = 1; +$DEBUG = 0; +$_ALLOW_PURE_PERL = 1; # allow pure perl extractors +$_ALLOW_BIN = 1; # allow binary extractors +$_ALLOW_TAR_ITER = 1; # try to use Archive::Tar->iter if available + +# same as all constants +my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA ); + +local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +Archive::Extract - A generic archive extracting mechanism + +=head1 SYNOPSIS + + use Archive::Extract; + + ### build an Archive::Extract object ### + my $ae = Archive::Extract->new( archive => 'foo.tgz' ); + + ### extract to cwd() ### + my $ok = $ae->extract; + + ### extract to /tmp ### + my $ok = $ae->extract( to => '/tmp' ); + + ### what if something went wrong? + my $ok = $ae->extract or die $ae->error; + + ### files from the archive ### + my $files = $ae->files; + + ### dir that was extracted to ### + my $outdir = $ae->extract_path; + + + ### quick check methods ### + $ae->is_tar # is it a .tar file? + $ae->is_tgz # is it a .tar.gz or .tgz file? + $ae->is_gz; # is it a .gz file? + $ae->is_zip; # is it a .zip file? + $ae->is_bz2; # is it a .bz2 file? + $ae->is_tbz; # is it a .tar.bz2 or .tbz file? + $ae->is_lzma; # is it a .lzma file? + + ### absolute path to the archive you provided ### + $ae->archive; + + ### commandline tools, if found ### + $ae->bin_tar # path to /bin/tar, if found + $ae->bin_gzip # path to /bin/gzip, if found + $ae->bin_unzip # path to /bin/unzip, if found + $ae->bin_bunzip2 # path to /bin/bunzip2 if found + $ae->bin_unlzma # path to /bin/unlzma if found + +=head1 DESCRIPTION + +Archive::Extract is a generic archive extraction mechanism. + +It allows you to extract any archive file of the type .tar, .tar.gz, +.gz, .Z, tar.bz2, .tbz, .bz2, .zip or .lzma without having to worry how it +does so, or use different interfaces for each type by using either +perl modules, or commandline tools on your system. + +See the C section further down for details. + +=cut + + +### see what /bin/programs are available ### +$PROGRAMS = {}; +for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma]) { + $PROGRAMS->{$pgm} = can_run($pgm); +} + +### mapping from types to extractor methods ### +my $Mapping = { # binary program # pure perl module + is_tgz => { bin => '_untar_bin', pp => '_untar_at' }, + is_tar => { bin => '_untar_bin', pp => '_untar_at' }, + is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' }, + is_zip => { bin => '_unzip_bin', pp => '_unzip_az' }, + is_tbz => { bin => '_untar_bin', pp => '_untar_at' }, + is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'}, + is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' }, + is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' }, +}; + +{ ### use subs so we re-generate array refs etc for the no-overide flags + ### if we don't, then we reuse the same arrayref, meaning objects store + ### previous errors + my $tmpl = { + archive => sub { { required => 1, allow => FILE_EXISTS } }, + type => sub { { default => '', allow => [ @Types ] } }, + _error_msg => sub { { no_override => 1, default => [] } }, + _error_msg_long => sub { { no_override => 1, default => [] } }, + }; + + ### build accesssors ### + for my $method( keys %$tmpl, + qw[_extractor _gunzip_to files extract_path], + ) { + no strict 'refs'; + *$method = sub { + my $self = shift; + $self->{$method} = $_[0] if @_; + return $self->{$method}; + } + } + +=head1 METHODS + +=head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE]) + +Creates a new C object based on the archive file you +passed it. Automatically determines the type of archive based on the +extension, but you can override that by explicitly providing the +C argument. + +Valid values for C are: + +=over 4 + +=item tar + +Standard tar files, as produced by, for example, C. +Corresponds to a C<.tar> suffix. + +=item tgz + +Gzip compressed tar files, as produced by, for example C. +Corresponds to a C<.tgz> or C<.tar.gz> suffix. + +=item gz + +Gzip compressed file, as produced by, for example C. +Corresponds to a C<.gz> suffix. + +=item Z + +Lempel-Ziv compressed file, as produced by, for example C. +Corresponds to a C<.Z> suffix. + +=item zip + +Zip compressed file, as produced by, for example C. +Corresponds to a C<.zip>, C<.jar> or C<.par> suffix. + +=item bz2 + +Bzip2 compressed file, as produced by, for example, C. +Corresponds to a C<.bz2> suffix. + +=item tbz + +Bzip2 compressed tar file, as produced by, for exmample C. +Corresponds to a C<.tbz> or C<.tar.bz2> suffix. + +=item lzma + +Lzma compressed file, as produced by C. +Corresponds to a C<.lzma> suffix. + +=back + +Returns a C object on success, or false on failure. + +=cut + + ### constructor ### + sub new { + my $class = shift; + my %hash = @_; + + ### see above why we use subs here and generate the template; + ### it's basically to not re-use arrayrefs + my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl; + + my $parsed = check( \%utmpl, \%hash ) or return; + + ### make sure we have an absolute path ### + my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} ); + + ### figure out the type, if it wasn't already specified ### + unless ( $parsed->{type} ) { + $parsed->{type} = + $ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ : + $ar =~ /.+?\.gz$/i ? GZ : + $ar =~ /.+?\.tar$/i ? TAR : + $ar =~ /.+?\.(zip|jar|par)$/i ? ZIP : + $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ : + $ar =~ /.+?\.bz2$/i ? BZ2 : + $ar =~ /.+?\.Z$/ ? Z : + $ar =~ /.+?\.lzma$/ ? LZMA : + ''; + + } + + bless $parsed, $class; + + ### don't know what type of file it is + ### XXX this *has* to be an object call, not a package call + return $parsed->_error(loc("Cannot determine file type for '%1'", + $parsed->{archive} )) unless $parsed->{type}; + return $parsed; + } +} + +=head2 $ae->extract( [to => '/output/path'] ) + +Extracts the archive represented by the C object to +the path of your choice as specified by the C argument. Defaults to +C. + +Since C<.gz> files never hold a directory, but only a single file; if +the C argument is an existing directory, the file is extracted +there, with its C<.gz> suffix stripped. +If the C argument is not an existing directory, the C argument +is understood to be a filename, if the archive type is C. +In the case that you did not specify a C argument, the output +file will be the name of the archive file, stripped from its C<.gz> +suffix, in the current working directory. + +C will try a pure perl solution first, and then fall back to +commandline tools if they are available. See the C +section below on how to alter this behaviour. + +It will return true on success, and false on failure. + +On success, it will also set the follow attributes in the object: + +=over 4 + +=item $ae->extract_path + +This is the directory that the files where extracted to. + +=item $ae->files + +This is an array ref with the paths of all the files in the archive, +relative to the C argument you specified. +To get the full path to an extracted file, you would use: + + File::Spec->catfile( $to, $ae->files->[0] ); + +Note that all files from a tar archive will be in unix format, as per +the tar specification. + +=back + +=cut + +sub extract { + my $self = shift; + my %hash = @_; + + ### reset error messages + $self->_error_msg( [] ); + $self->_error_msg_long( [] ); + + my $to; + my $tmpl = { + to => { default => '.', store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + ### so 'to' could be a file or a dir, depending on whether it's a .gz + ### file, or basically anything else. + ### so, check that, then act accordingly. + ### set an accessor specifically so _gunzip can know what file to extract + ### to. + my $dir; + { ### a foo.gz file + if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma ) { + + my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma)$//i; + + ### to is a dir? + if ( -d $to ) { + $dir = $to; + $self->_gunzip_to( basename($cp) ); + + ### then it's a filename + } else { + $dir = dirname($to); + $self->_gunzip_to( basename($to) ); + } + + ### not a foo.gz file + } else { + $dir = $to; + } + } + + ### make the dir if it doesn't exist ### + unless( -d $dir ) { + eval { mkpath( $dir ) }; + + return $self->_error(loc("Could not create path '%1': %2", $dir, $@)) + if $@; + } + + ### get the current dir, to restore later ### + my $cwd = cwd(); + + my $ok = 1; + EXTRACT: { + + ### chdir to the target dir ### + unless( chdir $dir ) { + $self->_error(loc("Could not chdir to '%1': %2", $dir, $!)); + $ok = 0; last EXTRACT; + } + + ### set files to an empty array ref, so there's always an array + ### ref IN the accessor, to avoid errors like: + ### Can't use an undefined value as an ARRAY reference at + ### ../lib/Archive/Extract.pm line 742. (rt #19815) + $self->files( [] ); + + ### find out the dispatch methods needed for this type of + ### archive. Do a $self->is_XXX to figure out the type, then + ### get the hashref with bin + pure perl dispatchers. + my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping; + + ### add pure perl extractor if allowed & add bin extractor if allowed + my @methods; + push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL; + push @methods, $map->{'bin'} if $_ALLOW_BIN; + + ### reverse it if we prefer bin extractors + @methods = reverse @methods if $PREFER_BIN; + + my($na, $fail); + for my $method (@methods) { + print "# Extracting with ->$method\n" if $DEBUG; + + my $rv = $self->$method; + + ### a positive extraction + if( $rv and $rv ne METHOD_NA ) { + print "# Extraction succeeded\n" if $DEBUG; + $self->_extractor($method); + last; + + ### method is not available + } elsif ( $rv and $rv eq METHOD_NA ) { + print "# Extraction method not available\n" if $DEBUG; + $na++; + } else { + print "# Extraction method failed\n" if $DEBUG; + $fail++; + } + } + + ### warn something went wrong if we didn't get an extractor + unless( $self->_extractor ) { + my $diag = $fail ? loc("Extract failed due to errors") : + $na ? loc("Extract failed; no extractors available") : + ''; + + $self->_error($diag); + $ok = 0; + } + } + + ### and chdir back ### + unless( chdir $cwd ) { + $self->_error(loc("Could not chdir back to start dir '%1': %2'", + $cwd, $!)); + } + + return $ok; +} + +=pod + +=head1 ACCESSORS + +=head2 $ae->error([BOOL]) + +Returns the last encountered error as string. +Pass it a true value to get the C output instead. + +=head2 $ae->extract_path + +This is the directory the archive got extracted to. +See C for details. + +=head2 $ae->files + +This is an array ref holding all the paths from the archive. +See C for details. + +=head2 $ae->archive + +This is the full path to the archive file represented by this +C object. + +=head2 $ae->type + +This is the type of archive represented by this C +object. See accessors below for an easier way to use this. +See the C method for details. + +=head2 $ae->types + +Returns a list of all known C for C's +C method. + +=cut + +sub types { return @Types } + +=head2 $ae->is_tgz + +Returns true if the file is of type C<.tar.gz>. +See the C method for details. + +=head2 $ae->is_tar + +Returns true if the file is of type C<.tar>. +See the C method for details. + +=head2 $ae->is_gz + +Returns true if the file is of type C<.gz>. +See the C method for details. + +=head2 $ae->is_Z + +Returns true if the file is of type C<.Z>. +See the C method for details. + +=head2 $ae->is_zip + +Returns true if the file is of type C<.zip>. +See the C method for details. + +=head2 $ae->is_lzma + +Returns true if the file is of type C<.lzma>. +See the C method for details. + +=cut + +### quick check methods ### +sub is_tgz { return $_[0]->type eq TGZ } +sub is_tar { return $_[0]->type eq TAR } +sub is_gz { return $_[0]->type eq GZ } +sub is_zip { return $_[0]->type eq ZIP } +sub is_tbz { return $_[0]->type eq TBZ } +sub is_bz2 { return $_[0]->type eq BZ2 } +sub is_Z { return $_[0]->type eq Z } +sub is_lzma { return $_[0]->type eq LZMA } + +=pod + +=head2 $ae->bin_tar + +Returns the full path to your tar binary, if found. + +=head2 $ae->bin_gzip + +Returns the full path to your gzip binary, if found + +=head2 $ae->bin_unzip + +Returns the full path to your unzip binary, if found + +=head2 $ae->bin_unlzma + +Returns the full path to your unlzma binary, if found + +=cut + +### paths to commandline tools ### +sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} } +sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} } +sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} } +sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} } +sub bin_uncompress { return $PROGRAMS->{'uncompress'} + if $PROGRAMS->{'uncompress'} } +sub bin_unlzma { return $PROGRAMS->{'unlzma'} if $PROGRAMS->{'unlzma'} } + +=head2 $bool = $ae->have_old_bunzip2 + +Older versions of C, from before the C release, +require all archive names to end in C<.bz2> or it will not extract +them. This method checks if you have a recent version of C +that allows any extension, or an older one that doesn't. + +=cut + +sub have_old_bunzip2 { + my $self = shift; + + ### no bunzip2? no old bunzip2 either :) + return unless $self->bin_bunzip2; + + ### if we can't run this, we can't be sure if it's too old or not + ### XXX stupid stupid stupid bunzip2 doesn't understand --version + ### is not a request to extract data: + ### $ bunzip2 --version + ### bzip2, a block-sorting file compressor. Version 1.0.2, 30-Dec-2001. + ### [...] + ### bunzip2: I won't read compressed data from a terminal. + ### bunzip2: For help, type: `bunzip2 --help'. + ### $ echo $? + ### 1 + ### HATEFUL! + + ### double hateful: bunzip2 --version also hangs if input is a pipe + ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH] + ### So, we have to provide *another* argument which is a fake filename, + ### just so it wont try to read from stdin to print its version.. + ### *sigh* + ### Even if the file exists, it won't clobber or change it. + my $buffer; + scalar run( + command => [$self->bin_bunzip2, '--version', 'NoSuchFile'], + verbose => 0, + buffer => \$buffer + ); + + ### no output + return unless $buffer; + + my ($version) = $buffer =~ /version \s+ (\d+)/ix; + + return 1 if $version < 1; + return; +} + +################################# +# +# Untar code +# +################################# + +### annoying issue with (gnu) tar on win32, as illustrated by this +### bug: https://rt.cpan.org/Ticket/Display.html?id=40138 +### which shows that (gnu) tar will interpret a file name with a : +### in it as a remote file name, so C:\tmp\foo.txt is interpreted +### as a remote shell, and the extract fails. +{ my @ExtraTarFlags; + if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) { + + ### if this is gnu tar we are running, we need to use --force-local + push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i; + } + + + ### use /bin/tar to extract ### + sub _untar_bin { + my $self = shift; + + ### check for /bin/tar ### + ### check for /bin/gzip if we need it ### + ### if any of the binaries are not available, return NA + { my $diag = not $self->bin_tar ? + loc("No '%1' program found", '/bin/tar') : + $self->is_tgz && !$self->bin_gzip ? + loc("No '%1' program found", '/bin/gzip') : + $self->is_tbz && !$self->bin_bunzip2 ? + loc("No '%1' program found", '/bin/bunzip2') : + ''; + + if( $diag ) { + $self->_error( $diag ); + return METHOD_NA; + } + } + + ### XXX figure out how to make IPC::Run do this in one call -- + ### currently i don't know how to get output of a command after a pipe + ### trapped in a scalar. Mailed barries about this 5th of june 2004. + + ### see what command we should run, based on whether + ### it's a .tgz or .tar + + ### XXX solaris tar and bsdtar are having different outputs + ### depending whether you run with -x or -t + ### compensate for this insanity by running -t first, then -x + { my $cmd = + $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|', + $self->bin_tar, '-tf', '-'] : + $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|', + $self->bin_tar, '-tf', '-'] : + [$self->bin_tar, @ExtraTarFlags, '-tf', $self->archive]; + + ### run the command + ### newer versions of 'tar' (1.21 and up) now print record size + ### to STDERR as well if v OR t is given (used to be both). This + ### is a 'feature' according to the changelog, so we must now only + ### inspect STDOUT, otherwise, failures like these occur: + ### nntp.perl.org/group/perl.cpan.testers/2009/02/msg3230366.html + my $buffer = ''; + my @out = run( command => $cmd, + buffer => \$buffer, + verbose => $DEBUG ); + + ### command was unsuccessful + unless( $out[0] ) { + return $self->_error(loc( + "Error listing contents of archive '%1': %2", + $self->archive, $buffer )); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_files( $self->archive ) ); + + } else { + ### if we're on solaris we /might/ be using /bin/tar, which has + ### a weird output format... we might also be using + ### /usr/local/bin/tar, which is gnu tar, which is perfectly + ### fine... so we have to do some guessing here =/ + my @files = map { chomp; + !ON_SOLARIS ? $_ + : (m|^ x \s+ # 'xtract' -- sigh + (.+?), # the actual file name + \s+ [\d,.]+ \s bytes, + \s+ [\d,.]+ \s tape \s blocks + |x ? $1 : $_); + + ### only STDOUT, see above. Sometims, extra whitespace + ### is present, so make sure we only pick lines with + ### a length + } grep { length } map { split $/, $_ } @{$out[3]}; + + ### store the files that are in the archive ### + $self->files(\@files); + } + } + + ### now actually extract it ### + { my $cmd = + $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|', + $self->bin_tar, '-xf', '-'] : + $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|', + $self->bin_tar, '-xf', '-'] : + [$self->bin_tar, @ExtraTarFlags, '-xf', $self->archive]; + + my $buffer = ''; + unless( scalar run( command => $cmd, + buffer => \$buffer, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Error extracting archive '%1': %2", + $self->archive, $buffer )); + } + + ### we might not have them, due to lack of buffers + if( $self->files ) { + ### now that we've extracted, figure out where we extracted to + my $dir = $self->__get_extract_dir( $self->files ); + + ### store the extraction dir ### + $self->extract_path( $dir ); + } + } + + ### we got here, no error happened + return 1; + } +} + + +### use archive::tar to extract ### +sub _untar_at { + my $self = shift; + + ### Loading Archive::Tar is going to set it to 1, so make it local + ### within this block, starting with its initial value. Whatever + ### Achive::Tar does will be undone when we return. + ### + ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN + ### so users don't have to even think about this variable. If they + ### do, they still get their set value outside of this call. + local $Archive::Tar::WARN = $Archive::Tar::WARN; + + ### we definitely need Archive::Tar, so load that first + { my $use_list = { 'Archive::Tar' => '0.0' }; + + unless( can_load( modules => $use_list ) ) { + + $self->_error(loc("You do not have '%1' installed - " . + "Please install it as soon as possible.", + 'Archive::Tar')); + + return METHOD_NA; + } + } + + ### we might pass it a filehandle if it's a .tbz file.. + my $fh_to_read = $self->archive; + + ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib + ### if A::T's version is 0.99 or higher + if( $self->is_tgz ) { + my $use_list = { 'Compress::Zlib' => '0.0' }; + $use_list->{ 'IO::Zlib' } = '0.0' + if $Archive::Tar::VERSION >= '0.99'; + + unless( can_load( modules => $use_list ) ) { + my $which = join '/', sort keys %$use_list; + + $self->_error(loc( + "You do not have '%1' installed - Please ". + "install it as soon as possible.", $which) + ); + + return METHOD_NA; + } + + } elsif ( $self->is_tbz ) { + my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc( + "You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::Bunzip2') + ); + + return METHOD_NA; + } + + my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or + return $self->_error(loc("Unable to open '%1': %2", + $self->archive, + $IO::Uncompress::Bunzip2::Bunzip2Error)); + + $fh_to_read = $bz; + } + + my @files; + { + ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've + ### localized $Archive::Tar::WARN already. + $Archive::Tar::WARN = $Archive::Extract::WARN; + + ### only tell it it's compressed if it's a .tgz, as we give it a file + ### handle if it's a .tbz + my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) ); + + ### for version of Archive::Tar > 1.04 + local $Archive::Tar::CHOWN = 0; + + ### use the iterator if we can. it's a feature of A::T 1.40 and up + if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) { + + my $next; + unless ( $next = Archive::Tar->iter( @read ) ) { + return $self->_error(loc( + "Unable to read '%1': %2", $self->archive, + $Archive::Tar::error)); + } + + while ( my $file = $next->() ) { + push @files, $file->full_path; + + $file->extract or return $self->_error(loc( + "Unable to read '%1': %2", + $self->archive, + $Archive::Tar::error)); + } + + ### older version, read the archive into memory + } else { + + my $tar = Archive::Tar->new(); + + unless( $tar->read( @read ) ) { + return $self->_error(loc("Unable to read '%1': %2", + $self->archive, $Archive::Tar::error)); + } + + ### workaround to prevent Archive::Tar from setting uid, which + ### is a potential security hole. -autrijus + ### have to do it here, since A::T needs to be /loaded/ first ### + { no strict 'refs'; local $^W; + + ### older versions of archive::tar <= 0.23 + *Archive::Tar::chown = sub {}; + } + + { local $^W; # quell 'splice() offset past end of array' warnings + # on older versions of A::T + + ### older archive::tar always returns $self, return value + ### slightly fux0r3d because of it. + $tar->extract or return $self->_error(loc( + "Unable to extract '%1': %2", + $self->archive, $Archive::Tar::error )); + } + + @files = $tar->list_files; + } + } + + my $dir = $self->__get_extract_dir( \@files ); + + ### store the files that are in the archive ### + $self->files(\@files); + + ### store the extraction dir ### + $self->extract_path( $dir ); + + ### check if the dir actually appeared ### + return 1 if -d $self->extract_path; + + ### no dir, we failed ### + return $self->_error(loc("Unable to extract '%1': %2", + $self->archive, $Archive::Tar::error )); +} + +################################# +# +# Gunzip code +# +################################# + +sub _gunzip_bin { + my $self = shift; + + ### check for /bin/gzip -- we need it ### + unless( $self->bin_gzip ) { + $self->_error(loc("No '%1' program found", '/bin/gzip')); + return METHOD_NA; + } + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to gunzip '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +sub _gunzip_cz { + my $self = shift; + + my $use_list = { 'Compress::Zlib' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Compress::Zlib')); + return METHOD_NA; + } + + my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or + return $self->_error(loc("Unable to open '%1': %2", + $self->archive, $Compress::Zlib::gzerrno)); + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $buffer; + $self->_print($fh, $buffer) while $gz->gzread($buffer) > 0; + $fh->close; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +################################# +# +# Uncompress code +# +################################# + +sub _uncompress_bin { + my $self = shift; + + ### check for /bin/gzip -- we need it ### + unless( $self->bin_uncompress ) { + $self->_error(loc("No '%1' program found", '/bin/uncompress')); + return METHOD_NA; + } + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $cmd = [ $self->bin_uncompress, '-c', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to uncompress '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + + +################################# +# +# Unzip code +# +################################# + + +sub _unzip_bin { + my $self = shift; + + ### check for /bin/gzip if we need it ### + unless( $self->bin_unzip ) { + $self->_error(loc("No '%1' program found", '/bin/unzip')); + return METHOD_NA; + } + + ### first, get the files.. it must be 2 different commands with 'unzip' :( + { ### on VMS, capital letter options have to be quoted. This is + ### peported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11 + ### Subject: [patch@31735]Archive Extract fix on VMS. + my $opt = ON_VMS ? '"-Z"' : '-Z'; + my $cmd = [ $self->bin_unzip, $opt, '-1', $self->archive ]; + + my $buffer = ''; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unzip '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_files( $self->archive ) ); + + } else { + $self->files( [split $/, $buffer] ); + } + } + + ### now, extract the archive ### + { my $cmd = [ $self->bin_unzip, '-qq', '-o', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unzip '%1': %2", + $self->archive, $buffer)); + } + + if( scalar @{$self->files} ) { + my $files = $self->files; + my $dir = $self->__get_extract_dir( $files ); + + $self->extract_path( $dir ); + } + } + + return 1; +} + +sub _unzip_az { + my $self = shift; + + my $use_list = { 'Archive::Zip' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Archive::Zip')); + return METHOD_NA; + } + + my $zip = Archive::Zip->new(); + + unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) { + return $self->_error(loc("Unable to read '%1'", $self->archive)); + } + + my @files; + + + ### Address: #43278: Explicitly tell Archive::Zip where to put the files: + ### "In my BackPAN indexing, Archive::Zip was extracting things + ### in my script's directory instead of the current working directory. + ### I traced this back through Archive::Zip::_asLocalName which + ### eventually calls File::Spec::Win32::rel2abs which on Windows might + ### call Cwd::getdcwd. getdcwd returns the wrong directory in my + ### case, even though I think I'm on the same drive. + ### + ### To fix this, I pass the optional second argument to + ### extractMember using the cwd from Archive::Extract." --bdfoy + + ## store cwd() before looping; calls to cwd() can be expensive, and + ### it won't change during the loop + my $extract_dir = cwd(); + + ### have to extract every member individually ### + for my $member ($zip->members) { + push @files, $member->{fileName}; + + ### file to extact to, to avoid the above problem + my $to = File::Spec->catfile( $extract_dir, $member->{fileName} ); + + unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) { + return $self->_error(loc("Extraction of '%1' from '%2' failed", + $member->{fileName}, $self->archive )); + } + } + + my $dir = $self->__get_extract_dir( \@files ); + + ### set what files where extract, and where they went ### + $self->files( \@files ); + $self->extract_path( File::Spec->rel2abs($dir) ); + + return 1; +} + +sub __get_extract_dir { + my $self = shift; + my $files = shift || []; + + return unless scalar @$files; + + my($dir1, $dir2); + for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) { + my($dir,$pos) = @$aref; + + ### add a catdir(), so that any trailing slashes get + ### take care of (removed) + ### also, a catdir() normalises './dir/foo' to 'dir/foo'; + ### which was the problem in bug #23999 + my $res = -d $files->[$pos] + ? File::Spec->catdir( $files->[$pos], '' ) + : File::Spec->catdir( dirname( $files->[$pos] ) ); + + $$dir = $res; + } + + ### if the first and last dir don't match, make sure the + ### dirname is not set wrongly + my $dir; + + ### dirs are the same, so we know for sure what the extract dir is + if( $dir1 eq $dir2 ) { + $dir = $dir1; + + ### dirs are different.. do they share the base dir? + ### if so, use that, if not, fall back to '.' + } else { + my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0]; + my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0]; + + $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' ); + } + + return File::Spec->rel2abs( $dir ); +} + +################################# +# +# Bunzip2 code +# +################################# + +sub _bunzip2_bin { + my $self = shift; + + ### check for /bin/gzip -- we need it ### + unless( $self->bin_bunzip2 ) { + $self->_error(loc("No '%1' program found", '/bin/bunzip2')); + return METHOD_NA; + } + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + ### guard against broken bunzip2. See ->have_old_bunzip2() + ### for details + if( $self->have_old_bunzip2 and $self->archive !~ /\.bz2$/i ) { + return $self->_error(loc("Your bunzip2 version is too old and ". + "can only extract files ending in '%1'", + '.bz2')); + } + + my $cmd = [ $self->bin_bunzip2, '-cd', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to bunzip2 '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +### using cz2, the compact versions... this we use mainly in archive::tar +### extractor.. +# sub _bunzip2_cz1 { +# my $self = shift; +# +# my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; +# unless( can_load( modules => $use_list ) ) { +# return $self->_error(loc("You do not have '%1' installed - Please " . +# "install it as soon as possible.", +# 'IO::Uncompress::Bunzip2')); +# } +# +# my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or +# return $self->_error(loc("Unable to open '%1': %2", +# $self->archive, +# $IO::Uncompress::Bunzip2::Bunzip2Error)); +# +# my $fh = FileHandle->new('>'. $self->_gunzip_to) or +# return $self->_error(loc("Could not open '%1' for writing: %2", +# $self->_gunzip_to, $! )); +# +# my $buffer; +# $fh->print($buffer) while $bz->read($buffer) > 0; +# $fh->close; +# +# ### set what files where extract, and where they went ### +# $self->files( [$self->_gunzip_to] ); +# $self->extract_path( File::Spec->rel2abs(cwd()) ); +# +# return 1; +# } + +sub _bunzip2_bz2 { + my $self = shift; + + my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::Bunzip2')); + return METHOD_NA; + } + + IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to) + or return $self->_error(loc("Unable to uncompress '%1': %2", + $self->archive, + $IO::Uncompress::Bunzip2::Bunzip2Error)); + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + + +################################# +# +# unlzma code +# +################################# + +sub _unlzma_bin { + my $self = shift; + + ### check for /bin/unlzma -- we need it ### + unless( $self->bin_unlzma ) { + $self->_error(loc("No '%1' program found", '/bin/unlzma')); + return METHOD_NA; + } + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $cmd = [ $self->bin_unlzma, '-c', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unlzma '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +sub _unlzma_cz { + my $self = shift; + + my $use_list = { 'Compress::unLZMA' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Compress::unLZMA')); + return METHOD_NA; + } + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $buffer; + $buffer = Compress::unLZMA::uncompressfile( $self->archive ); + unless ( defined $buffer ) { + return $self->_error(loc("Could not unlzma '%1': %2", + $self->archive, $@)); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +################################# +# +# Error code +# +################################# + +# For printing binaries that avoids interfering globals +sub _print { + my $self = shift; + my $fh = shift; + + local( $\, $", $, ) = ( undef, ' ', '' ); + return print $fh @_; +} + +sub _error { + my $self = shift; + my $error = shift; + my $lerror = Carp::longmess($error); + + push @{$self->_error_msg}, $error; + push @{$self->_error_msg_long}, $lerror; + + ### set $Archive::Extract::WARN to 0 to disable printing + ### of errors + if( $WARN ) { + carp $DEBUG ? $lerror : $error; + } + + return; +} + +sub error { + my $self = shift; + + ### make sure we have a fallback aref + my $aref = do { + shift() + ? $self->_error_msg_long + : $self->_error_msg + } || []; + + return join $/, @$aref; +} + +sub _no_buffer_files { + my $self = shift; + my $file = shift or return; + return loc("No buffer captured, unable to tell ". + "extracted files or extraction dir for '%1'", $file); +} + +sub _no_buffer_content { + my $self = shift; + my $file = shift or return; + return loc("No buffer captured, unable to get content for '%1'", $file); +} +1; + +=pod + +=head1 HOW IT WORKS + +C tries first to determine what type of archive you +are passing it, by inspecting its suffix. It does not do this by using +Mime magic, or something related. See C below. + +Once it has determined the file type, it knows which extraction methods +it can use on the archive. It will try a perl solution first, then fall +back to a commandline tool if that fails. If that also fails, it will +return false, indicating it was unable to extract the archive. +See the section on C to see how to alter this order. + +=head1 CAVEATS + +=head2 File Extensions + +C trusts on the extension of the archive to determine +what type it is, and what extractor methods therefore can be used. If +your archives do not have any of the extensions as described in the +C method, you will have to specify the type explicitly, or +C will not be able to extract the archive for you. + +=head2 Supporting Very Large Files + +C can use either pure perl modules or command line +programs under the hood. Some of the pure perl modules (like +C and Compress::unLZMA) take the entire contents of the archive into memory, +which may not be feasible on your system. Consider setting the global +variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer +the use of command line programs and won't consume so much memory. + +See the C section below for details. + +=head2 Bunzip2 support of arbitrary extensions. + +Older versions of C do not support arbitrary file +extensions and insist on a C<.bz2> suffix. Although we do our best +to guard against this, if you experience a bunzip2 error, it may +be related to this. For details, please see the C +method. + +=head1 GLOBAL VARIABLES + +=head2 $Archive::Extract::DEBUG + +Set this variable to C to have all calls to command line tools +be printed out, including all their output. +This also enables C errors, instead of the regular +C errors. + +Good for tracking down why things don't work with your particular +setup. + +Defaults to C. + +=head2 $Archive::Extract::WARN + +This variable controls whether errors encountered internally by +C should be C'd or not. + +Set to false to silence warnings. Inspect the output of the C +method manually to see what went wrong. + +Defaults to C. + +=head2 $Archive::Extract::PREFER_BIN + +This variables controls whether C should prefer the +use of perl modules, or commandline tools to extract archives. + +Set to C to have C prefer commandline tools. + +Defaults to C. + +=head1 TODO / CAVEATS + +=over 4 + +=item Mime magic support + +Maybe this module should use something like C to determine +the type, rather than blindly trust the suffix. + +=item Thread safety + +Currently, C does a C to the extraction dir before +extraction, and a C back again after. This is not necessarily +thread safe. See C bug C<#45671> for details. + +=back + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-archive-extract@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar.pm b/Master/tlpkg/tlperl/lib/Archive/Tar.pm new file mode 100644 index 00000000000..006edbd5c3e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Archive/Tar.pm @@ -0,0 +1,2146 @@ +### the gnu tar specification: +### http://www.gnu.org/software/tar/manual/tar.html +### +### and the pax format spec, which tar derives from: +### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html + +package Archive::Tar; +require 5.005_03; + +use Cwd; +use IO::Zlib; +use IO::File; +use Carp qw(carp croak); +use File::Spec (); +use File::Spec::Unix (); +use File::Path (); + +use Archive::Tar::File; +use Archive::Tar::Constant; + +require Exporter; + +use strict; +use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD + $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING $SAME_PERMISSIONS + $INSECURE_EXTRACT_MODE @ISA @EXPORT + ]; + +@ISA = qw[Exporter]; +@EXPORT = qw[ COMPRESS_GZIP COMPRESS_BZIP ]; +$DEBUG = 0; +$WARN = 1; +$FOLLOW_SYMLINK = 0; +$VERSION = "1.54"; +$CHOWN = 1; +$CHMOD = 1; +$SAME_PERMISSIONS = $> == 0 ? 1 : 0; +$DO_NOT_USE_PREFIX = 0; +$INSECURE_EXTRACT_MODE = 0; + +BEGIN { + use Config; + $HAS_PERLIO = $Config::Config{useperlio}; + + ### try and load IO::String anyway, so you can dynamically + ### switch between perlio and IO::String + $HAS_IO_STRING = eval { + require IO::String; + import IO::String; + 1; + } || 0; +} + +=head1 NAME + +Archive::Tar - module for manipulations of tar archives + +=head1 SYNOPSIS + + use Archive::Tar; + my $tar = Archive::Tar->new; + + $tar->read('origin.tgz'); + $tar->extract(); + + $tar->add_files('file/foo.pl', 'docs/README'); + $tar->add_data('file/baz.txt', 'This is the contents now'); + + $tar->rename('oldname', 'new/file/name'); + + $tar->write('files.tar'); # plain tar + $tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed + $tar->write('files.tbz', COMPRESS_BZIP); # bzip2 compressed + +=head1 DESCRIPTION + +Archive::Tar provides an object oriented mechanism for handling tar +files. It provides class methods for quick and easy files handling +while also allowing for the creation of tar file objects for custom +manipulation. If you have the IO::Zlib module installed, +Archive::Tar will also support compressed or gzipped tar files. + +An object of class Archive::Tar represents a .tar(.gz) archive full +of files and things. + +=head1 Object Methods + +=head2 Archive::Tar->new( [$file, $compressed] ) + +Returns a new Tar object. If given any arguments, C calls the +C method automatically, passing on the arguments provided to +the C method. + +If C is invoked with arguments and the C method fails +for any reason, C returns undef. + +=cut + +my $tmpl = { + _data => [ ], + _file => 'Unknown', +}; + +### install get/set accessors for this object. +for my $key ( keys %$tmpl ) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + my $self = shift; + $self->{$key} = $_[0] if @_; + return $self->{$key}; + } +} + +sub new { + my $class = shift; + $class = ref $class if ref $class; + + ### copying $tmpl here since a shallow copy makes it use the + ### same aref, causing for files to remain in memory always. + my $obj = bless { _data => [ ], _file => 'Unknown', _error => '' }, $class; + + if (@_) { + unless ( $obj->read( @_ ) ) { + $obj->_error(qq[No data could be read from file]); + return; + } + } + + return $obj; +} + +=head2 $tar->read ( $filename|$handle, [$compressed, {opt => 'val'}] ) + +Read the given tar file into memory. +The first argument can either be the name of a file or a reference to +an already open filehandle (or an IO::Zlib object if it's compressed) + +The C will I any previous content in C<$tar>! + +The second argument may be considered optional, but remains for +backwards compatibility. Archive::Tar now looks at the file +magic to determine what class should be used to open the file +and will transparently Do The Right Thing. + +Archive::Tar will warn if you try to pass a bzip2 compressed file and the +IO::Zlib / IO::Uncompress::Bunzip2 modules are not available and simply return. + +Note that you can currently B pass a C compressed +filehandle, which is not opened with C, a C compressed +filehandle, which is not opened with C, nor a string +containing the full archive information (either compressed or +uncompressed). These are worth while features, but not currently +implemented. See the C section. + +The third argument can be a hash reference with options. Note that +all options are case-sensitive. + +=over 4 + +=item limit + +Do not read more than C files. This is useful if you have +very big archives, and are only interested in the first few files. + +=item filter + +Can be set to a regular expression. Only files with names that match +the expression will be read. + +=item extract + +If set to true, immediately extract entries when reading them. This +gives you the same memory break as the C function. +Note however that entries will not be read into memory, but written +straight to disk. This means no C objects are +created for you to inspect. + +=back + +All files are stored internally as C objects. +Please consult the L documentation for details. + +Returns the number of files read in scalar context, and a list of +C objects in list context. + +=cut + +sub read { + my $self = shift; + my $file = shift; + my $gzip = shift || 0; + my $opts = shift || {}; + + unless( defined $file ) { + $self->_error( qq[No file to read from!] ); + return; + } else { + $self->_file( $file ); + } + + my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) ) + or return; + + my $data = $self->_read_tar( $handle, $opts ) or return; + + $self->_data( $data ); + + return wantarray ? @$data : scalar @$data; +} + +sub _get_handle { + my $self = shift; + my $file = shift; return unless defined $file; + return $file if ref $file; + my $compress = shift || 0; + my $mode = shift || READ_ONLY->( ZLIB ); # default to read only + + + ### get a FH opened to the right class, so we can use it transparently + ### throughout the program + my $fh; + { ### reading magic only makes sense if we're opening a file for + ### reading. otherwise, just use what the user requested. + my $magic = ''; + if( MODE_READ->($mode) ) { + open my $tmp, $file or do { + $self->_error( qq[Could not open '$file' for reading: $!] ); + return; + }; + + ### read the first 4 bites of the file to figure out which class to + ### use to open the file. + sysread( $tmp, $magic, 4 ); + close $tmp; + } + + ### is it bzip? + ### if you asked specifically for bzip compression, or if we're in + ### read mode and the magic numbers add up, use bzip + if( BZIP and ( + ($compress eq COMPRESS_BZIP) or + ( MODE_READ->($mode) and $magic =~ BZIP_MAGIC_NUM ) + ) + ) { + + ### different reader/writer modules, different error vars... sigh + if( MODE_READ->($mode) ) { + $fh = IO::Uncompress::Bunzip2->new( $file ) or do { + $self->_error( qq[Could not read '$file': ] . + $IO::Uncompress::Bunzip2::Bunzip2Error + ); + return; + }; + + } else { + $fh = IO::Compress::Bzip2->new( $file ) or do { + $self->_error( qq[Could not write to '$file': ] . + $IO::Compress::Bzip2::Bzip2Error + ); + return; + }; + } + + ### is it gzip? + ### if you asked for compression, if you wanted to read or the gzip + ### magic number is present (redundant with read) + } elsif( ZLIB and ( + $compress or MODE_READ->($mode) or $magic =~ GZIP_MAGIC_NUM + ) + ) { + $fh = IO::Zlib->new; + + unless( $fh->open( $file, $mode ) ) { + $self->_error(qq[Could not create filehandle for '$file': $!]); + return; + } + + ### is it plain tar? + } else { + $fh = IO::File->new; + + unless( $fh->open( $file, $mode ) ) { + $self->_error(qq[Could not create filehandle for '$file': $!]); + return; + } + + ### enable bin mode on tar archives + binmode $fh; + } + } + + return $fh; +} + + +sub _read_tar { + my $self = shift; + my $handle = shift or return; + my $opts = shift || {}; + + my $count = $opts->{limit} || 0; + my $filter = $opts->{filter}; + my $extract = $opts->{extract} || 0; + + ### set a cap on the amount of files to extract ### + my $limit = 0; + $limit = 1 if $count > 0; + + my $tarfile = [ ]; + my $chunk; + my $read = 0; + my $real_name; # to set the name of a file when + # we're encountering @longlink + my $data; + + LOOP: + while( $handle->read( $chunk, HEAD ) ) { + ### IO::Zlib doesn't support this yet + my $offset = eval { tell $handle } || 'unknown'; + + unless( $read++ ) { + my $gzip = GZIP_MAGIC_NUM; + if( $chunk =~ /$gzip/ ) { + $self->_error( qq[Cannot read compressed format in tar-mode] ); + return; + } + + ### size is < HEAD, which means a corrupted file, as the minimum + ### length is _at least_ HEAD + if (length $chunk != HEAD) { + $self->_error( qq[Cannot read enough bytes from the tarfile] ); + return; + } + } + + ### if we can't read in all bytes... ### + last if length $chunk != HEAD; + + ### Apparently this should really be two blocks of 512 zeroes, + ### but GNU tar sometimes gets it wrong. See comment in the + ### source code (tar.c) to GNU cpio. + next if $chunk eq TAR_END; + + ### according to the posix spec, the last 12 bytes of the header are + ### null bytes, to pad it to a 512 byte block. That means if these + ### bytes are NOT null bytes, it's a corrrupt header. See: + ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx + ### line 111 + { my $nulls = join '', "\0" x 12; + unless( $nulls eq substr( $chunk, 500, 12 ) ) { + $self->_error( qq[Invalid header block at offset $offset] ); + next LOOP; + } + } + + ### pass the realname, so we can set it 'proper' right away + ### some of the heuristics are done on the name, so important + ### to set it ASAP + my $entry; + { my %extra_args = (); + $extra_args{'name'} = $$real_name if defined $real_name; + + unless( $entry = Archive::Tar::File->new( chunk => $chunk, + %extra_args ) + ) { + $self->_error( qq[Couldn't read chunk at offset $offset] ); + next LOOP; + } + } + + ### ignore labels: + ### http://www.gnu.org/manual/tar/html_node/tar_139.html + next if $entry->is_label; + + if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) { + + if ( $entry->is_file && !$entry->validate ) { + ### sometimes the chunk is rather fux0r3d and a whole 512 + ### bytes ends up in the ->name area. + ### clean it up, if need be + my $name = $entry->name; + $name = substr($name, 0, 100) if length $name > 100; + $name =~ s/\n/ /g; + + $self->_error( $name . qq[: checksum error] ); + next LOOP; + } + + my $block = BLOCK_SIZE->( $entry->size ); + + $data = $entry->get_content_by_ref; + + ### just read everything into memory + ### can't do lazy loading since IO::Zlib doesn't support 'seek' + ### this is because Compress::Zlib doesn't support it =/ + ### this reads in the whole data in one read() call. + if( $handle->read( $$data, $block ) < $block ) { + $self->_error( qq[Read error on tarfile (missing data) ']. + $entry->full_path ."' at offset $offset" ); + next LOOP; + } + + ### throw away trailing garbage ### + substr ($$data, $entry->size) = "" if defined $$data; + + ### part II of the @LongLink munging -- need to do /after/ + ### the checksum check. + if( $entry->is_longlink ) { + ### weird thing in tarfiles -- if the file is actually a + ### @LongLink, the data part seems to have a trailing ^@ + ### (unprintable) char. to display, pipe output through less. + ### but that doesn't *always* happen.. so check if the last + ### character is a control character, and if so remove it + ### at any rate, we better remove that character here, or tests + ### like 'eq' and hashlook ups based on names will SO not work + ### remove it by calculating the proper size, and then + ### tossing out everything that's longer than that size. + + ### count number of nulls + my $nulls = $$data =~ tr/\0/\0/; + + ### cut data + size by that many bytes + $entry->size( $entry->size - $nulls ); + substr ($$data, $entry->size) = ""; + } + } + + ### clean up of the entries.. posix tar /apparently/ has some + ### weird 'feature' that allows for filenames > 255 characters + ### they'll put a header in with as name '././@LongLink' and the + ### contents will be the name of the /next/ file in the archive + ### pretty crappy and kludgy if you ask me + + ### set the name for the next entry if this is a @LongLink; + ### this is one ugly hack =/ but needed for direct extraction + if( $entry->is_longlink ) { + $real_name = $data; + next LOOP; + } elsif ( defined $real_name ) { + $entry->name( $$real_name ); + $entry->prefix(''); + undef $real_name; + } + + ### skip this entry if we're filtering + if ($filter && $entry->name !~ $filter) { + next LOOP; + + ### skip this entry if it's a pax header. This is a special file added + ### by, among others, git-generated tarballs. It holds comments and is + ### not meant for extracting. See #38932: pax_global_header extracted + } elsif ( $entry->name eq PAX_HEADER ) { + next LOOP; + } + + $self->_extract_file( $entry ) if $extract + && !$entry->is_longlink + && !$entry->is_unknown + && !$entry->is_label; + + ### Guard against tarfiles with garbage at the end + last LOOP if $entry->name eq ''; + + ### push only the name on the rv if we're extracting + ### -- for extract_archive + push @$tarfile, ($extract ? $entry->name : $entry); + + if( $limit ) { + $count-- unless $entry->is_longlink || $entry->is_dir; + last LOOP unless $count; + } + } continue { + undef $data; + } + + return $tarfile; +} + +=head2 $tar->contains_file( $filename ) + +Check if the archive contains a certain file. +It will return true if the file is in the archive, false otherwise. + +Note however, that this function does an exact match using C +on the full path. So it cannot compensate for case-insensitive file- +systems or compare 2 paths to see if they would point to the same +underlying file. + +=cut + +sub contains_file { + my $self = shift; + my $full = shift; + + return unless defined $full; + + ### don't warn if the entry isn't there.. that's what this function + ### is for after all. + local $WARN = 0; + return 1 if $self->_find_entry($full); + return; +} + +=head2 $tar->extract( [@filenames] ) + +Write files whose names are equivalent to any of the names in +C<@filenames> to disk, creating subdirectories as necessary. This +might not work too well under VMS. +Under MacPerl, the file's modification time will be converted to the +MacOS zero of time, and appropriate conversions will be done to the +path. However, the length of each element of the path is not +inspected to see whether it's longer than MacOS currently allows (32 +characters). + +If C is called without a list of file names, the entire +contents of the archive are extracted. + +Returns a list of filenames extracted. + +=cut + +sub extract { + my $self = shift; + my @args = @_; + my @files; + + # use the speed optimization for all extracted files + local($self->{cwd}) = cwd() unless $self->{cwd}; + + ### you requested the extraction of only certian files + if( @args ) { + for my $file ( @args ) { + + ### it's already an object? + if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) { + push @files, $file; + next; + + ### go find it then + } else { + + my $found; + for my $entry ( @{$self->_data} ) { + next unless $file eq $entry->full_path; + + ### we found the file you're looking for + push @files, $entry; + $found++; + } + + unless( $found ) { + return $self->_error( + qq[Could not find '$file' in archive] ); + } + } + } + + ### just grab all the file items + } else { + @files = $self->get_files; + } + + ### nothing found? that's an error + unless( scalar @files ) { + $self->_error( qq[No files found for ] . $self->_file ); + return; + } + + ### now extract them + for my $entry ( @files ) { + unless( $self->_extract_file( $entry ) ) { + $self->_error(q[Could not extract ']. $entry->full_path .q['] ); + return; + } + } + + return @files; +} + +=head2 $tar->extract_file( $file, [$extract_path] ) + +Write an entry, whose name is equivalent to the file name provided to +disk. Optionally takes a second parameter, which is the full native +path (including filename) the entry will be written to. + +For example: + + $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' ); + + $tar->extract_file( $at_file_object, 'name/i/want/to/give/it' ); + +Returns true on success, false on failure. + +=cut + +sub extract_file { + my $self = shift; + my $file = shift; return unless defined $file; + my $alt = shift; + + my $entry = $self->_find_entry( $file ) + or $self->_error( qq[Could not find an entry for '$file'] ), return; + + return $self->_extract_file( $entry, $alt ); +} + +sub _extract_file { + my $self = shift; + my $entry = shift or return; + my $alt = shift; + + ### you wanted an alternate extraction location ### + my $name = defined $alt ? $alt : $entry->full_path; + + ### splitpath takes a bool at the end to indicate + ### that it's splitting a dir + my ($vol,$dirs,$file); + if ( defined $alt ) { # It's a local-OS path + ($vol,$dirs,$file) = File::Spec->splitpath( $alt, + $entry->is_dir ); + } else { + ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name, + $entry->is_dir ); + } + + my $dir; + ### is $name an absolute path? ### + if( $vol || File::Spec->file_name_is_absolute( $dirs ) ) { + + ### absolute names are not allowed to be in tarballs under + ### strict mode, so only allow it if a user tells us to do it + if( not defined $alt and not $INSECURE_EXTRACT_MODE ) { + $self->_error( + q[Entry ']. $entry->full_path .q[' is an absolute path. ]. + q[Not extracting absolute paths under SECURE EXTRACT MODE] + ); + return; + } + + ### user asked us to, it's fine. + $dir = File::Spec->catpath( $vol, $dirs, "" ); + + ### it's a relative path ### + } else { + my $cwd = (ref $self and defined $self->{cwd}) + ? $self->{cwd} + : cwd(); + + my @dirs = defined $alt + ? File::Spec->splitdir( $dirs ) # It's a local-OS path + : File::Spec::Unix->splitdir( $dirs ); # it's UNIX-style, likely + # straight from the tarball + + if( not defined $alt and + not $INSECURE_EXTRACT_MODE + ) { + + ### paths that leave the current directory are not allowed under + ### strict mode, so only allow it if a user tells us to do this. + if( grep { $_ eq '..' } @dirs ) { + + $self->_error( + q[Entry ']. $entry->full_path .q[' is attempting to leave ]. + q[the current working directory. Not extracting under ]. + q[SECURE EXTRACT MODE] + ); + return; + } + + ### the archive may be asking us to extract into a symlink. This + ### is not sane and a possible security issue, as outlined here: + ### https://rt.cpan.org/Ticket/Display.html?id=30380 + ### https://bugzilla.redhat.com/show_bug.cgi?id=295021 + ### https://issues.rpath.com/browse/RPL-1716 + my $full_path = $cwd; + for my $d ( @dirs ) { + $full_path = File::Spec->catdir( $full_path, $d ); + + ### we've already checked this one, and it's safe. Move on. + next if ref $self and $self->{_link_cache}->{$full_path}; + + if( -l $full_path ) { + my $to = readlink $full_path; + my $diag = "symlinked directory ($full_path => $to)"; + + $self->_error( + q[Entry ']. $entry->full_path .q[' is attempting to ]. + qq[extract to a $diag. This is considered a security ]. + q[vulnerability and not allowed under SECURE EXTRACT ]. + q[MODE] + ); + return; + } + + ### XXX keep a cache if possible, so the stats become cheaper: + $self->{_link_cache}->{$full_path} = 1 if ref $self; + } + } + + ### '.' is the directory delimiter on VMS, which has to be escaped + ### or changed to '_' on vms. vmsify is used, because older versions + ### of vmspath do not handle this properly. + ### Must not add a '/' to an empty directory though. + map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS; + + my ($cwd_vol,$cwd_dir,$cwd_file) + = File::Spec->splitpath( $cwd ); + my @cwd = File::Spec->splitdir( $cwd_dir ); + push @cwd, $cwd_file if length $cwd_file; + + ### We need to pass '' as the last elemant to catpath. Craig Berry + ### explains why (msgid ): + ### The root problem is that splitpath on UNIX always returns the + ### final path element as a file even if it is a directory, and of + ### course there is no way it can know the difference without checking + ### against the filesystem, which it is documented as not doing. When + ### you turn around and call catpath, on VMS you have to know which bits + ### are directory bits and which bits are file bits. In this case we + ### know the result should be a directory. I had thought you could omit + ### the file argument to catpath in such a case, but apparently on UNIX + ### you can't. + $dir = File::Spec->catpath( + $cwd_vol, File::Spec->catdir( @cwd, @dirs ), '' + ); + + ### catdir() returns undef if the path is longer than 255 chars on + ### older VMS systems. + unless ( defined $dir ) { + $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] ); + return; + } + + } + + if( -e $dir && !-d _ ) { + $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] ); + return; + } + + unless ( -d _ ) { + eval { File::Path::mkpath( $dir, 0, 0777 ) }; + if( $@ ) { + my $fp = $entry->full_path; + $self->_error(qq[Could not create directory '$dir' for '$fp': $@]); + return; + } + + ### XXX chown here? that might not be the same as in the archive + ### as we're only chown'ing to the owner of the file we're extracting + ### not to the owner of the directory itself, which may or may not + ### be another entry in the archive + ### Answer: no, gnu tar doesn't do it either, it'd be the wrong + ### way to go. + #if( $CHOWN && CAN_CHOWN ) { + # chown $entry->uid, $entry->gid, $dir or + # $self->_error( qq[Could not set uid/gid on '$dir'] ); + #} + } + + ### we're done if we just needed to create a dir ### + return 1 if $entry->is_dir; + + my $full = File::Spec->catfile( $dir, $file ); + + if( $entry->is_unknown ) { + $self->_error( qq[Unknown file type for file '$full'] ); + return; + } + + if( length $entry->type && $entry->is_file ) { + my $fh = IO::File->new; + $fh->open( '>' . $full ) or ( + $self->_error( qq[Could not open file '$full': $!] ), + return + ); + + if( $entry->size ) { + binmode $fh; + syswrite $fh, $entry->data or ( + $self->_error( qq[Could not write data to '$full'] ), + return + ); + } + + close $fh or ( + $self->_error( qq[Could not close file '$full'] ), + return + ); + + } else { + $self->_make_special_file( $entry, $full ) or return; + } + + ### only update the timestamp if it's not a symlink; that will change the + ### timestamp of the original. This addresses bug #33669: Could not update + ### timestamp warning on symlinks + if( not -l $full ) { + utime time, $entry->mtime - TIME_OFFSET, $full or + $self->_error( qq[Could not update timestamp] ); + } + + if( $CHOWN && CAN_CHOWN->() ) { + chown $entry->uid, $entry->gid, $full or + $self->_error( qq[Could not set uid/gid on '$full'] ); + } + + ### only chmod if we're allowed to, but never chmod symlinks, since they'll + ### change the perms on the file they're linking too... + if( $CHMOD and not -l $full ) { + my $mode = $entry->mode; + unless ($SAME_PERMISSIONS) { + $mode &= ~(oct(7000) | umask); + } + chmod $mode, $full or + $self->_error( qq[Could not chown '$full' to ] . $entry->mode ); + } + + return 1; +} + +sub _make_special_file { + my $self = shift; + my $entry = shift or return; + my $file = shift; return unless defined $file; + + my $err; + + if( $entry->is_symlink ) { + my $fail; + if( ON_UNIX ) { + symlink( $entry->linkname, $file ) or $fail++; + + } else { + $self->_extract_special_file_as_plain_file( $entry, $file ) + or $fail++; + } + + $err = qq[Making symbolic link '$file' to '] . + $entry->linkname .q[' failed] if $fail; + + } elsif ( $entry->is_hardlink ) { + my $fail; + if( ON_UNIX ) { + link( $entry->linkname, $file ) or $fail++; + + } else { + $self->_extract_special_file_as_plain_file( $entry, $file ) + or $fail++; + } + + $err = qq[Making hard link from '] . $entry->linkname . + qq[' to '$file' failed] if $fail; + + } elsif ( $entry->is_fifo ) { + ON_UNIX && !system('mknod', $file, 'p') or + $err = qq[Making fifo ']. $entry->name .qq[' failed]; + + } elsif ( $entry->is_blockdev or $entry->is_chardev ) { + my $mode = $entry->is_blockdev ? 'b' : 'c'; + + ON_UNIX && !system('mknod', $file, $mode, + $entry->devmajor, $entry->devminor) or + $err = qq[Making block device ']. $entry->name .qq[' (maj=] . + $entry->devmajor . qq[ min=] . $entry->devminor . + qq[) failed.]; + + } elsif ( $entry->is_socket ) { + ### the original doesn't do anything special for sockets.... ### + 1; + } + + return $err ? $self->_error( $err ) : 1; +} + +### don't know how to make symlinks, let's just extract the file as +### a plain file +sub _extract_special_file_as_plain_file { + my $self = shift; + my $entry = shift or return; + my $file = shift; return unless defined $file; + + my $err; + TRY: { + my $orig = $self->_find_entry( $entry->linkname ); + + unless( $orig ) { + $err = qq[Could not find file '] . $entry->linkname . + qq[' in memory.]; + last TRY; + } + + ### clone the entry, make it appear as a normal file ### + my $clone = $entry->clone; + $clone->_downgrade_to_plainfile; + $self->_extract_file( $clone, $file ) or last TRY; + + return 1; + } + + return $self->_error($err); +} + +=head2 $tar->list_files( [\@properties] ) + +Returns a list of the names of all the files in the archive. + +If C is passed an array reference as its first argument +it returns a list of hash references containing the requested +properties of each file. The following list of properties is +supported: name, size, mtime (last modified date), mode, uid, gid, +linkname, uname, gname, devmajor, devminor, prefix. + +Passing an array reference containing only one element, 'name', is +special cased to return a list of names rather than a list of hash +references, making it equivalent to calling C without +arguments. + +=cut + +sub list_files { + my $self = shift; + my $aref = shift || [ ]; + + unless( $self->_data ) { + $self->read() or return; + } + + if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) { + return map { $_->full_path } @{$self->_data}; + } else { + + #my @rv; + #for my $obj ( @{$self->_data} ) { + # push @rv, { map { $_ => $obj->$_() } @$aref }; + #} + #return @rv; + + ### this does the same as the above.. just needs a +{ } + ### to make sure perl doesn't confuse it for a block + return map { my $o=$_; + +{ map { $_ => $o->$_() } @$aref } + } @{$self->_data}; + } +} + +sub _find_entry { + my $self = shift; + my $file = shift; + + unless( defined $file ) { + $self->_error( qq[No file specified] ); + return; + } + + ### it's an object already + return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' ); + + for my $entry ( @{$self->_data} ) { + my $path = $entry->full_path; + return $entry if $path eq $file; + } + + $self->_error( qq[No such file in archive: '$file'] ); + return; +} + +=head2 $tar->get_files( [@filenames] ) + +Returns the C objects matching the filenames +provided. If no filename list was passed, all C +objects in the current Tar object are returned. + +Please refer to the C documentation on how to +handle these objects. + +=cut + +sub get_files { + my $self = shift; + + return @{ $self->_data } unless @_; + + my @list; + for my $file ( @_ ) { + push @list, grep { defined } $self->_find_entry( $file ); + } + + return @list; +} + +=head2 $tar->get_content( $file ) + +Return the content of the named file. + +=cut + +sub get_content { + my $self = shift; + my $entry = $self->_find_entry( shift ) or return; + + return $entry->data; +} + +=head2 $tar->replace_content( $file, $content ) + +Make the string $content be the content for the file named $file. + +=cut + +sub replace_content { + my $self = shift; + my $entry = $self->_find_entry( shift ) or return; + + return $entry->replace_content( shift ); +} + +=head2 $tar->rename( $file, $new_name ) + +Rename the file of the in-memory archive to $new_name. + +Note that you must specify a Unix path for $new_name, since per tar +standard, all files in the archive must be Unix paths. + +Returns true on success and false on failure. + +=cut + +sub rename { + my $self = shift; + my $file = shift; return unless defined $file; + my $new = shift; return unless defined $new; + + my $entry = $self->_find_entry( $file ) or return; + + return $entry->rename( $new ); +} + +=head2 $tar->remove (@filenamelist) + +Removes any entries with names matching any of the given filenames +from the in-memory archive. Returns a list of C +objects that remain. + +=cut + +sub remove { + my $self = shift; + my @list = @_; + + my %seen = map { $_->full_path => $_ } @{$self->_data}; + delete $seen{ $_ } for @list; + + $self->_data( [values %seen] ); + + return values %seen; +} + +=head2 $tar->clear + +C clears the current in-memory archive. This effectively gives +you a 'blank' object, ready to be filled again. Note that C +only has effect on the object, not the underlying tarfile. + +=cut + +sub clear { + my $self = shift or return; + + $self->_data( [] ); + $self->_file( '' ); + + return 1; +} + + +=head2 $tar->write ( [$file, $compressed, $prefix] ) + +Write the in-memory archive to disk. The first argument can either +be the name of a file or a reference to an already open filehandle (a +GLOB reference). + +The second argument is used to indicate compression. You can either +compress using C or C. If you pass a digit, it's assumed +to be the C compression level (between 1 and 9), but the use of +constants is prefered: + + # write a gzip compressed file + $tar->write( 'out.tgz', COMPRESS_GZIP ); + + # write a bzip compressed file + $tar->write( 'out.tbz', COMPRESS_BZIP ); + +Note that when you pass in a filehandle, the compression argument +is ignored, as all files are printed verbatim to your filehandle. +If you wish to enable compression with filehandles, use an +C or C filehandle instead. + +The third argument is an optional prefix. All files will be tucked +away in the directory you specify as prefix. So if you have files +'a' and 'b' in your archive, and you specify 'foo' as prefix, they +will be written to the archive as 'foo/a' and 'foo/b'. + +If no arguments are given, C returns the entire formatted +archive as a string, which could be useful if you'd like to stuff the +archive into a socket or a pipe to gzip or something. + + +=cut + +sub write { + my $self = shift; + my $file = shift; $file = '' unless defined $file; + my $gzip = shift || 0; + my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; + my $dummy = ''; + + ### only need a handle if we have a file to print to ### + my $handle = length($file) + ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) ) + or return ) + : $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h } + : $HAS_IO_STRING ? IO::String->new + : __PACKAGE__->no_string_support(); + + ### Addresses: #41798: Nonempty $\ when writing a TAR file produces a + ### corrupt TAR file. Must clear out $\ to make sure no garbage is + ### printed to the archive + local $\; + + for my $entry ( @{$self->_data} ) { + ### entries to be written to the tarfile ### + my @write_me; + + ### only now will we change the object to reflect the current state + ### of the name and prefix fields -- this needs to be limited to + ### write() only! + my $clone = $entry->clone; + + + ### so, if you don't want use to use the prefix, we'll stuff + ### everything in the name field instead + if( $DO_NOT_USE_PREFIX ) { + + ### you might have an extended prefix, if so, set it in the clone + ### XXX is ::Unix right? + $clone->name( length $ext_prefix + ? File::Spec::Unix->catdir( $ext_prefix, + $clone->full_path) + : $clone->full_path ); + $clone->prefix( '' ); + + ### otherwise, we'll have to set it properly -- prefix part in the + ### prefix and name part in the name field. + } else { + + ### split them here, not before! + my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path ); + + ### you might have an extended prefix, if so, set it in the clone + ### XXX is ::Unix right? + $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix ) + if length $ext_prefix; + + $clone->prefix( $prefix ); + $clone->name( $name ); + } + + ### names are too long, and will get truncated if we don't add a + ### '@LongLink' file... + my $make_longlink = ( length($clone->name) > NAME_LENGTH or + length($clone->prefix) > PREFIX_LENGTH + ) || 0; + + ### perhaps we need to make a longlink file? + if( $make_longlink ) { + my $longlink = Archive::Tar::File->new( + data => LONGLINK_NAME, + $clone->full_path, + { type => LONGLINK } + ); + + unless( $longlink ) { + $self->_error( qq[Could not create 'LongLink' entry for ] . + qq[oversize file '] . $clone->full_path ."'" ); + return; + }; + + push @write_me, $longlink; + } + + push @write_me, $clone; + + ### write the one, optionally 2 a::t::file objects to the handle + for my $clone (@write_me) { + + ### if the file is a symlink, there are 2 options: + ### either we leave the symlink intact, but then we don't write any + ### data OR we follow the symlink, which means we actually make a + ### copy. if we do the latter, we have to change the TYPE of the + ### clone to 'FILE' + my $link_ok = $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK; + my $data_ok = !$clone->is_symlink && $clone->has_content; + + ### downgrade to a 'normal' file if it's a symlink we're going to + ### treat as a regular file + $clone->_downgrade_to_plainfile if $link_ok; + + ### get the header for this block + my $header = $self->_format_tar_entry( $clone ); + unless( $header ) { + $self->_error(q[Could not format header for: ] . + $clone->full_path ); + return; + } + + unless( print $handle $header ) { + $self->_error(q[Could not write header for: ] . + $clone->full_path); + return; + } + + if( $link_ok or $data_ok ) { + unless( print $handle $clone->data ) { + $self->_error(q[Could not write data for: ] . + $clone->full_path); + return; + } + + ### pad the end of the clone if required ### + print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK + } + + } ### done writing these entries + } + + ### write the end markers ### + print $handle TAR_END x 2 or + return $self->_error( qq[Could not write tar end markers] ); + + ### did you want it written to a file, or returned as a string? ### + my $rv = length($file) ? 1 + : $HAS_PERLIO ? $dummy + : do { seek $handle, 0, 0; local $/; <$handle> }; + + ### make sure to close the handle; + close $handle; + + return $rv; +} + +sub _format_tar_entry { + my $self = shift; + my $entry = shift or return; + my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; + my $no_prefix = shift || 0; + + my $file = $entry->name; + my $prefix = $entry->prefix; $prefix = '' unless defined $prefix; + + ### remove the prefix from the file name + ### not sure if this is still neeeded --kane + ### no it's not -- Archive::Tar::File->_new_from_file will take care of + ### this for us. Even worse, this would break if we tried to add a file + ### like x/x. + #if( length $prefix ) { + # $file =~ s/^$match//; + #} + + $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix) + if length $ext_prefix; + + ### not sure why this is... ### + my $l = PREFIX_LENGTH; # is ambiguous otherwise... + substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH; + + my $f1 = "%06o"; my $f2 = "%11o"; + + ### this might be optimizable with a 'changed' flag in the file objects ### + my $tar = pack ( + PACK, + $file, + + (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]), + (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]), + + "", # checksum field - space padded a bit down + + (map { $entry->$_() } qw[type linkname magic]), + + $entry->version || TAR_VERSION, + + (map { $entry->$_() } qw[uname gname]), + (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]), + + ($no_prefix ? '' : $prefix) + ); + + ### add the checksum ### + substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar)); + + return $tar; +} + +=head2 $tar->add_files( @filenamelist ) + +Takes a list of filenames and adds them to the in-memory archive. + +The path to the file is automatically converted to a Unix like +equivalent for use in the archive, and, if on MacOS, the file's +modification time is converted from the MacOS epoch to the Unix epoch. +So tar archives created on MacOS with B can be read +both with I on Unix and applications like I or +I on MacOS. + +Be aware that the file's type/creator and resource fork will be lost, +which is usually what you want in cross-platform archives. + +Instead of a filename, you can also pass it an existing C +object from, for example, another archive. The object will be clone, and +effectively be a copy of the original, not an alias. + +Returns a list of C objects that were just added. + +=cut + +sub add_files { + my $self = shift; + my @files = @_ or return; + + my @rv; + for my $file ( @files ) { + + ### you passed an Archive::Tar::File object + ### clone it so we don't accidentally have a reference to + ### an object from another archive + if( UNIVERSAL::isa( $file,'Archive::Tar::File' ) ) { + push @rv, $file->clone; + next; + } + + unless( -e $file || -l $file ) { + $self->_error( qq[No such file: '$file'] ); + next; + } + + my $obj = Archive::Tar::File->new( file => $file ); + unless( $obj ) { + $self->_error( qq[Unable to add file: '$file'] ); + next; + } + + push @rv, $obj; + } + + push @{$self->{_data}}, @rv; + + return @rv; +} + +=head2 $tar->add_data ( $filename, $data, [$opthashref] ) + +Takes a filename, a scalar full of data and optionally a reference to +a hash with specific options. + +Will add a file to the in-memory archive, with name C<$filename> and +content C<$data>. Specific properties can be set using C<$opthashref>. +The following list of properties is supported: name, size, mtime +(last modified date), mode, uid, gid, linkname, uname, gname, +devmajor, devminor, prefix, type. (On MacOS, the file's path and +modification times are converted to Unix equivalents.) + +Valid values for the file type are the following constants defined in +Archive::Tar::Constants: + +=over 4 + +=item FILE + +Regular file. + +=item HARDLINK + +=item SYMLINK + +Hard and symbolic ("soft") links; linkname should specify target. + +=item CHARDEV + +=item BLOCKDEV + +Character and block devices. devmajor and devminor should specify the major +and minor device numbers. + +=item DIR + +Directory. + +=item FIFO + +FIFO (named pipe). + +=item SOCKET + +Socket. + +=back + +Returns the C object that was just added, or +C on failure. + +=cut + +sub add_data { + my $self = shift; + my ($file, $data, $opt) = @_; + + my $obj = Archive::Tar::File->new( data => $file, $data, $opt ); + unless( $obj ) { + $self->_error( qq[Unable to add file: '$file'] ); + return; + } + + push @{$self->{_data}}, $obj; + + return $obj; +} + +=head2 $tar->error( [$BOOL] ) + +Returns the current errorstring (usually, the last error reported). +If a true value was specified, it will give the C +equivalent of the error, in effect giving you a stacktrace. + +For backwards compatibility, this error is also available as +C<$Archive::Tar::error> although it is much recommended you use the +method call instead. + +=cut + +{ + $error = ''; + my $longmess; + + sub _error { + my $self = shift; + my $msg = $error = shift; + $longmess = Carp::longmess($error); + if (ref $self) { + $self->{_error} = $error; + $self->{_longmess} = $longmess; + } + + ### set Archive::Tar::WARN to 0 to disable printing + ### of errors + if( $WARN ) { + carp $DEBUG ? $longmess : $msg; + } + + return; + } + + sub error { + my $self = shift; + if (ref $self) { + return shift() ? $self->{_longmess} : $self->{_error}; + } else { + return shift() ? $longmess : $error; + } + } +} + +=head2 $tar->setcwd( $cwd ); + +C needs to know the current directory, and it will run +C I time it extracts a I entry from the +tarfile and saves it in the file system. (As of version 1.30, however, +C will use the speed optimization described below +automatically, so it's only relevant if you're using C). + +Since C doesn't change the current directory internally +while it is extracting the items in a tarball, all calls to C +can be avoided if we can guarantee that the current directory doesn't +get changed externally. + +To use this performance boost, set the current directory via + + use Cwd; + $tar->setcwd( cwd() ); + +once before calling a function like C and +C will use the current directory setting from then on +and won't call C internally. + +To switch back to the default behaviour, use + + $tar->setcwd( undef ); + +and C will call C internally again. + +If you're using C's C method, C will +be called for you. + +=cut + +sub setcwd { + my $self = shift; + my $cwd = shift; + + $self->{cwd} = $cwd; +} + +=head1 Class Methods + +=head2 Archive::Tar->create_archive($file, $compressed, @filelist) + +Creates a tar file from the list of files provided. The first +argument can either be the name of the tar file to create or a +reference to an open file handle (e.g. a GLOB reference). + +The second argument is used to indicate compression. You can either +compress using C or C. If you pass a digit, it's assumed +to be the C compression level (between 1 and 9), but the use of +constants is prefered: + + # write a gzip compressed file + Archive::Tar->create_archive( 'out.tgz', COMPRESS_GZIP, @filelist ); + + # write a bzip compressed file + Archive::Tar->create_archive( 'out.tbz', COMPRESS_BZIP, @filelist ); + +Note that when you pass in a filehandle, the compression argument +is ignored, as all files are printed verbatim to your filehandle. +If you wish to enable compression with filehandles, use an +C or C filehandle instead. + +The remaining arguments list the files to be included in the tar file. +These files must all exist. Any files which don't exist or can't be +read are silently ignored. + +If the archive creation fails for any reason, C will +return false. Please use the C method to find the cause of the +failure. + +Note that this method does not write C as it were; it +still reads all the files into memory before writing out the archive. +Consult the FAQ below if this is a problem. + +=cut + +sub create_archive { + my $class = shift; + + my $file = shift; return unless defined $file; + my $gzip = shift || 0; + my @files = @_; + + unless( @files ) { + return $class->_error( qq[Cowardly refusing to create empty archive!] ); + } + + my $tar = $class->new; + $tar->add_files( @files ); + return $tar->write( $file, $gzip ); +} + +=head2 Archive::Tar->iter( $filename, [ $compressed, {opt => $val} ] ) + +Returns an iterator function that reads the tar file without loading +it all in memory. Each time the function is called it will return the +next file in the tarball. The files are returned as +C objects. The iterator function returns the +empty list once it has exhausted the files contained. + +The second argument can be a hash reference with options, which are +identical to the arguments passed to C. + +Example usage: + + my $next = Archive::Tar->iter( "example.tar.gz", 1, {filter => qr/\.pm$/} ); + + while( my $f = $next->() ) { + print $f->name, "\n"; + + $f->extract or warn "Extraction failed"; + + # .... + } + +=cut + + +sub iter { + my $class = shift; + my $filename = shift or return; + my $compressed = shift or 0; + my $opts = shift || {}; + + ### get a handle to read from. + my $handle = $class->_get_handle( + $filename, + $compressed, + READ_ONLY->( ZLIB ) + ) or return; + + my @data; + return sub { + return shift(@data) if @data; # more than one file returned? + return unless $handle; # handle exhausted? + + ### read data, should only return file + my $tarfile = $class->_read_tar($handle, { %$opts, limit => 1 }); + @data = @$tarfile if ref $tarfile && ref $tarfile eq 'ARRAY'; + + ### return one piece of data + return shift(@data) if @data; + + ### data is exhausted, free the filehandle + undef $handle; + return; + }; +} + +=head2 Archive::Tar->list_archive($file, $compressed, [\@properties]) + +Returns a list of the names of all the files in the archive. The +first argument can either be the name of the tar file to list or a +reference to an open file handle (e.g. a GLOB reference). + +If C is passed an array reference as its third +argument it returns a list of hash references containing the requested +properties of each file. The following list of properties is +supported: full_path, name, size, mtime (last modified date), mode, +uid, gid, linkname, uname, gname, devmajor, devminor, prefix. + +See C for details about supported properties. + +Passing an array reference containing only one element, 'name', is +special cased to return a list of names rather than a list of hash +references. + +=cut + +sub list_archive { + my $class = shift; + my $file = shift; return unless defined $file; + my $gzip = shift || 0; + + my $tar = $class->new($file, $gzip); + return unless $tar; + + return $tar->list_files( @_ ); +} + +=head2 Archive::Tar->extract_archive($file, $compressed) + +Extracts the contents of the tar file. The first argument can either +be the name of the tar file to create or a reference to an open file +handle (e.g. a GLOB reference). All relative paths in the tar file will +be created underneath the current working directory. + +C will return a list of files it extracted. +If the archive extraction fails for any reason, C +will return false. Please use the C method to find the cause +of the failure. + +=cut + +sub extract_archive { + my $class = shift; + my $file = shift; return unless defined $file; + my $gzip = shift || 0; + + my $tar = $class->new( ) or return; + + return $tar->read( $file, $gzip, { extract => 1 } ); +} + +=head2 $bool = Archive::Tar->has_io_string + +Returns true if we currently have C support loaded. + +Either C or C support is needed to support writing +stringified archives. Currently, C is the preferred method, if +available. + +See the C section to see how to change this preference. + +=cut + +sub has_io_string { return $HAS_IO_STRING; } + +=head2 $bool = Archive::Tar->has_perlio + +Returns true if we currently have C support loaded. + +This requires C or higher, compiled with C + +Either C or C support is needed to support writing +stringified archives. Currently, C is the preferred method, if +available. + +See the C section to see how to change this preference. + +=cut + +sub has_perlio { return $HAS_PERLIO; } + +=head2 $bool = Archive::Tar->has_zlib_support + +Returns true if C can extract C compressed archives + +=cut + +sub has_zlib_support { return ZLIB } + +=head2 $bool = Archive::Tar->has_bzip2_support + +Returns true if C can extract C compressed archives + +=cut + +sub has_bzip2_support { return BZIP } + +=head2 Archive::Tar->can_handle_compressed_files + +A simple checking routine, which will return true if C +is able to uncompress compressed archives on the fly with C +and C or false if not both are installed. + +You can use this as a shortcut to determine whether C +will do what you think before passing compressed archives to its +C method. + +=cut + +sub can_handle_compressed_files { return ZLIB && BZIP ? 1 : 0 } + +sub no_string_support { + croak("You have to install IO::String to support writing archives to strings"); +} + +1; + +__END__ + +=head1 GLOBAL VARIABLES + +=head2 $Archive::Tar::FOLLOW_SYMLINK + +Set this variable to C<1> to make C effectively make a +copy of the file when extracting. Default is C<0>, which +means the symlink stays intact. Of course, you will have to pack the +file linked to as well. + +This option is checked when you write out the tarfile using C +or C. + +This works just like C's C<-h> option. + +=head2 $Archive::Tar::CHOWN + +By default, C will try to C your files if it is +able to. In some cases, this may not be desired. In that case, set +this variable to C<0> to disable C-ing, even if it were +possible. + +The default is C<1>. + +=head2 $Archive::Tar::CHMOD + +By default, C will try to C your files to +whatever mode was specified for the particular file in the archive. +In some cases, this may not be desired. In that case, set this +variable to C<0> to disable C-ing. + +The default is C<1>. + +=head2 $Archive::Tar::SAME_PERMISSIONS + +When, C<$Archive::Tar::CHMOD> is enabled, this setting controls whether +the permissions on files from the archive are used without modification +of if they are filtered by removing any setid bits and applying the +current umask. + +The default is C<1> for the root user and C<0> for normal users. + +=head2 $Archive::Tar::DO_NOT_USE_PREFIX + +By default, C will try to put paths that are over +100 characters in the C field of your tar header, as +defined per POSIX-standard. However, some (older) tar programs +do not implement this spec. To retain compatibility with these older +or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX> +variable to a true value, and C will use an alternate +way of dealing with paths over 100 characters by using the +C feature. + +Note that clients who do not support the C +feature will not be able to read these archives. Such clients include +tars on C, C and C. + +The default is C<0>. + +=head2 $Archive::Tar::DEBUG + +Set this variable to C<1> to always get the C output +of the warnings, instead of the regular C. This is the same +message you would get by doing: + + $tar->error(1); + +Defaults to C<0>. + +=head2 $Archive::Tar::WARN + +Set this variable to C<0> if you do not want any warnings printed. +Personally I recommend against doing this, but people asked for the +option. Also, be advised that this is of course not threadsafe. + +Defaults to C<1>. + +=head2 $Archive::Tar::error + +Holds the last reported error. Kept for historical reasons, but its +use is very much discouraged. Use the C method instead: + + warn $tar->error unless $tar->extract; + +Note that in older versions of this module, the C method +would return an effectively global value even when called an instance +method as above. This has since been fixed, and multiple instances of +C now have separate error strings. + +=head2 $Archive::Tar::INSECURE_EXTRACT_MODE + +This variable indicates whether C should allow +files to be extracted outside their current working directory. + +Allowing this could have security implications, as a malicious +tar archive could alter or replace any file the extracting user +has permissions to. Therefor, the default is to not allow +insecure extractions. + +If you trust the archive, or have other reasons to allow the +archive to write files outside your current working directory, +set this variable to C. + +Note that this is a backwards incompatible change from version +C<1.36> and before. + +=head2 $Archive::Tar::HAS_PERLIO + +This variable holds a boolean indicating if we currently have +C support loaded. This will be enabled for any perl +greater than C<5.8> compiled with C. + +If you feel strongly about disabling it, set this variable to +C. Note that you will then need C installed +to support writing stringified archives. + +Don't change this variable unless you B know what you're +doing. + +=head2 $Archive::Tar::HAS_IO_STRING + +This variable holds a boolean indicating if we currently have +C support loaded. This will be enabled for any perl +that has a loadable C module. + +If you feel strongly about disabling it, set this variable to +C. Note that you will then need C support from +your perl to be able to write stringified archives. + +Don't change this variable unless you B know what you're +doing. + +=head1 FAQ + +=over 4 + +=item What's the minimum perl version required to run Archive::Tar? + +You will need perl version 5.005_03 or newer. + +=item Isn't Archive::Tar slow? + +Yes it is. It's pure perl, so it's a lot slower then your C +However, it's very portable. If speed is an issue, consider using +C instead. + +=item Isn't Archive::Tar heavier on memory than /bin/tar? + +Yes it is, see previous answer. Since C and therefore +C doesn't support C on their filehandles, there is little +choice but to read the archive into memory. +This is ok if you want to do in-memory manipulation of the archive. + +If you just want to extract, use the C class method +instead. It will optimize and write to disk immediately. + +Another option is to use the C class method to iterate over +the files in the tarball without reading them all in memory at once. + +=item Can you lazy-load data instead? + +In some cases, yes. You can use the C class method to iterate +over the files in the tarball without reading them all in memory at once. + +=item How much memory will an X kb tar file need? + +Probably more than X kb, since it will all be read into memory. If +this is a problem, and you don't need to do in memory manipulation +of the archive, consider using the C class method, or C +instead. + +=item What do you do with unsupported filetypes in an archive? + +C has a few filetypes that aren't supported on other platforms, +like C. If we encounter a C or C we'll just +try to make a copy of the original file, rather than throwing an error. + +This does require you to read the entire archive in to memory first, +since otherwise we wouldn't know what data to fill the copy with. +(This means that you cannot use the class methods, including C +on archives that have incompatible filetypes and still expect things +to work). + +For other filetypes, like C and C we'll warn that +the extraction of this particular item didn't work. + +=item I'm using WinZip, or some other non-POSIX client, and files are not being extracted properly! + +By default, C is in a completely POSIX-compatible +mode, which uses the POSIX-specification of C to store files. +For paths greather than 100 characters, this is done using the +C. Non-POSIX-compatible clients may not support +this part of the specification, and may only support the C functionality. To facilitate those clients, you can set the +C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C. See the +C section for details on this variable. + +Note that GNU tar earlier than version 1.14 does not cope well with +the C. If you use such a version, consider setting +the C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C. + +=item How do I extract only files that have property X from an archive? + +Sometimes, you might not wish to extract a complete archive, just +the files that are relevant to you, based on some criteria. + +You can do this by filtering a list of C objects +based on your criteria. For example, to extract only files that have +the string C in their title, you would use: + + $tar->extract( + grep { $_->full_path =~ /foo/ } $tar->get_files + ); + +This way, you can filter on any attribute of the files in the archive. +Consult the C documentation on how to use these +objects. + +=item How do I access .tar.Z files? + +The C module can optionally use C (via +the C module) to access tar files that have been compressed +with C. Unfortunately tar files compressed with the Unix C +utility cannot be read by C and so cannot be directly +accesses by C. + +If the C or C programs are available, you can use +one of these workarounds to read C<.tar.Z> files from C + +Firstly with C + + use Archive::Tar; + + open F, "uncompress -c $filename |"; + my $tar = Archive::Tar->new(*F); + ... + +and this with C + + use Archive::Tar; + + open F, "gunzip -c $filename |"; + my $tar = Archive::Tar->new(*F); + ... + +Similarly, if the C program is available, you can use this to +write a C<.tar.Z> file + + use Archive::Tar; + use IO::File; + + my $fh = new IO::File "| compress -c >$filename"; + my $tar = Archive::Tar->new(); + ... + $tar->write($fh); + $fh->close ; + +=item How do I handle Unicode strings? + +C uses byte semantics for any files it reads from or writes +to disk. This is not a problem if you only deal with files and never +look at their content or work solely with byte strings. But if you use +Unicode strings with character semantics, some additional steps need +to be taken. + +For example, if you add a Unicode string like + + # Problem + $tar->add_data('file.txt', "Euro: \x{20AC}"); + +then there will be a problem later when the tarfile gets written out +to disk via C<$tar->write()>: + + Wide character in print at .../Archive/Tar.pm line 1014. + +The data was added as a Unicode string and when writing it out to disk, +the C<:utf8> line discipline wasn't set by C, so Perl +tried to convert the string to ISO-8859 and failed. The written file +now contains garbage. + +For this reason, Unicode strings need to be converted to UTF-8-encoded +bytestrings before they are handed off to C: + + use Encode; + my $data = "Accented character: \x{20AC}"; + $data = encode('utf8', $data); + + $tar->add_data('file.txt', $data); + +A opposite problem occurs if you extract a UTF8-encoded file from a +tarball. Using C on the C object +will return its content as a bytestring, not as a Unicode string. + +If you want it to be a Unicode string (because you want character +semantics with operations like regular expression matching), you need +to decode the UTF8-encoded content and have Perl convert it into +a Unicode string: + + use Encode; + my $data = $tar->get_content(); + + # Make it a Unicode string + $data = decode('utf8', $data); + +There is no easy way to provide this functionality in C, +because a tarball can contain many files, and each of which could be +encoded in a different way. + +=back + +=head1 CAVEATS + +The AIX tar does not fill all unused space in the tar archive with 0x00. +This sometimes leads to warning messages from C. + + Invalid header block at offset nnn + +A fix for that problem is scheduled to be released in the following levels +of AIX, all of which should be coming out in the 4th quarter of 2009: + + AIX 5.3 TL7 SP10 + AIX 5.3 TL8 SP8 + AIX 5.3 TL9 SP5 + AIX 5.3 TL10 SP2 + + AIX 6.1 TL0 SP11 + AIX 6.1 TL1 SP7 + AIX 6.1 TL2 SP6 + AIX 6.1 TL3 SP3 + +The IBM APAR number for this problem is IZ50240 (Reported component ID: +5765G0300 / AIX 5.3). It is possible to get an ifix for that problem. +If you need an ifix please contact your local IBM AIX support. + +=head1 TODO + +=over 4 + +=item Check if passed in handles are open for read/write + +Currently I don't know of any portable pure perl way to do this. +Suggestions welcome. + +=item Allow archives to be passed in as string + +Currently, we only allow opened filehandles or filenames, but +not strings. The internals would need some reworking to facilitate +stringified archives. + +=item Facilitate processing an opened filehandle of a compressed archive + +Currently, we only support this if the filehandle is an IO::Zlib object. +Environments, like apache, will present you with an opened filehandle +to an uploaded file, which might be a compressed archive. + +=back + +=head1 SEE ALSO + +=over 4 + +=item The GNU tar specification + +C + +=item The PAX format specication + +The specifcation which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html> + +=item A comparison of GNU and POSIX tar standards; C + +=item GNU tar intends to switch to POSIX compatibility + +GNU Tar authors have expressed their intention to become completely +POSIX-compatible; C + +=item A Comparison between various tar implementations + +Lists known issues and incompatibilities; C + +=back + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +Please reports bugs to Ebug-archive-tar@rt.cpan.orgE. + +=head1 ACKNOWLEDGEMENTS + +Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney, Gisle Aas, +Rainer Tammer and especially Andrew Savige for their help and suggestions. + +=head1 COPYRIGHT + +This module is copyright (c) 2002 - 2009 Jos Boumans +Ekane@cpan.orgE. All rights reserved. + +This library is free software; you may redistribute and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm new file mode 100644 index 00000000000..aef1d623fa8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm @@ -0,0 +1,86 @@ +package Archive::Tar::Constant; + +BEGIN { + require Exporter; + + $VERSION = '0.02'; + @ISA = qw[Exporter]; + + require Time::Local if $^O eq "MacOS"; +} + +use Package::Constants; +@EXPORT = Package::Constants->list( __PACKAGE__ ); + +use constant FILE => 0; +use constant HARDLINK => 1; +use constant SYMLINK => 2; +use constant CHARDEV => 3; +use constant BLOCKDEV => 4; +use constant DIR => 5; +use constant FIFO => 6; +use constant SOCKET => 8; +use constant UNKNOWN => 9; +use constant LONGLINK => 'L'; +use constant LABEL => 'V'; + +use constant BUFFER => 4096; +use constant HEAD => 512; +use constant BLOCK => 512; + +use constant COMPRESS_GZIP => 9; +use constant COMPRESS_BZIP => 'bzip2'; + +use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK }; +use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) }; +use constant TAR_END => "\0" x BLOCK; + +use constant READ_ONLY => sub { shift() ? 'rb' : 'r' }; +use constant WRITE_ONLY => sub { $_[0] ? 'wb' . shift : 'w' }; +use constant MODE_READ => sub { $_[0] =~ /^r/ ? 1 : 0 }; + +# Pointless assignment to make -w shut up +my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); }; +my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); }; +use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' }; +use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' }; +use constant UID => $>; +use constant GID => (split ' ', $) )[0]; + +use constant MODE => do { 0666 & (0777 & ~umask) }; +use constant STRIP_MODE => sub { shift() & 0777 }; +use constant CHECK_SUM => " "; + +use constant UNPACK => 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12'; +use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12'; +use constant NAME_LENGTH => 100; +use constant PREFIX_LENGTH => 155; + +use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0; +use constant MAGIC => "ustar"; +use constant TAR_VERSION => "00"; +use constant LONGLINK_NAME => '././@LongLink'; +use constant PAX_HEADER => 'pax_global_header'; + + ### allow ZLIB to be turned off using ENV: DEBUG only +use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and + eval { require IO::Zlib }; + $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1 + }; + + ### allow BZIP to be turned off using ENV: DEBUG only +use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and + eval { require IO::Uncompress::Bunzip2; + require IO::Compress::Bzip2; }; + $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1 + }; + +use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/; +use constant BZIP_MAGIC_NUM => qr/^BZh\d/; + +use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") }; +use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS'); +use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS'); +use constant ON_VMS => $^O eq 'VMS'; + +1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm new file mode 100644 index 00000000000..0815bb67620 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm @@ -0,0 +1,660 @@ +package Archive::Tar::File; +use strict; + +use Carp (); +use IO::File; +use File::Spec::Unix (); +use File::Spec (); +use File::Basename (); + +### avoid circular use, so only require; +require Archive::Tar; +use Archive::Tar::Constant; + +use vars qw[@ISA $VERSION]; +#@ISA = qw[Archive::Tar]; +$VERSION = '0.02'; + +### set value to 1 to oct() it during the unpack ### +my $tmpl = [ + name => 0, # string + mode => 1, # octal + uid => 1, # octal + gid => 1, # octal + size => 1, # octal + mtime => 1, # octal + chksum => 1, # octal + type => 0, # character + linkname => 0, # string + magic => 0, # string + version => 0, # 2 bytes + uname => 0, # string + gname => 0, # string + devmajor => 1, # octal + devminor => 1, # octal + prefix => 0, + +### end UNPACK items ### + raw => 0, # the raw data chunk + data => 0, # the data associated with the file -- + # This might be very memory intensive +]; + +### install get/set accessors for this object. +for ( my $i=0; $i[$i]; + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + my $self = shift; + $self->{$key} = $_[0] if @_; + + ### just in case the key is not there or undef or something ### + { local $^W = 0; + return $self->{$key}; + } + } +} + +=head1 NAME + +Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar + +=head1 SYNOPSIS + + my @items = $tar->get_files; + + print $_->name, ' ', $_->size, "\n" for @items; + + print $object->get_content; + $object->replace_content('new content'); + + $object->rename( 'new/full/path/to/file.c' ); + +=head1 DESCRIPTION + +Archive::Tar::Files provides a neat little object layer for in-memory +extracted files. It's mostly used internally in Archive::Tar to tidy +up the code, but there's no reason users shouldn't use this API as +well. + +=head2 Accessors + +A lot of the methods in this package are accessors to the various +fields in the tar header: + +=over 4 + +=item name + +The file's name + +=item mode + +The file's mode + +=item uid + +The user id owning the file + +=item gid + +The group id owning the file + +=item size + +File size in bytes + +=item mtime + +Modification time. Adjusted to mac-time on MacOS if required + +=item chksum + +Checksum field for the tar header + +=item type + +File type -- numeric, but comparable to exported constants -- see +Archive::Tar's documentation + +=item linkname + +If the file is a symlink, the file it's pointing to + +=item magic + +Tar magic string -- not useful for most users + +=item version + +Tar version string -- not useful for most users + +=item uname + +The user name that owns the file + +=item gname + +The group name that owns the file + +=item devmajor + +Device major number in case of a special file + +=item devminor + +Device minor number in case of a special file + +=item prefix + +Any directory to prefix to the extraction path, if any + +=item raw + +Raw tar header -- not useful for most users + +=back + +=head1 Methods + +=head2 Archive::Tar::File->new( file => $path ) + +Returns a new Archive::Tar::File object from an existing file. + +Returns undef on failure. + +=head2 Archive::Tar::File->new( data => $path, $data, $opt ) + +Returns a new Archive::Tar::File object from data. + +C<$path> defines the file name (which need not exist), C<$data> the +file contents, and C<$opt> is a reference to a hash of attributes +which may be used to override the default attributes (fields in the +tar header), which are described above in the Accessors section. + +Returns undef on failure. + +=head2 Archive::Tar::File->new( chunk => $chunk ) + +Returns a new Archive::Tar::File object from a raw 512-byte tar +archive chunk. + +Returns undef on failure. + +=cut + +sub new { + my $class = shift; + my $what = shift; + + my $obj = ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) : + ($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) : + ($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) : + undef; + + return $obj; +} + +### copies the data, creates a clone ### +sub clone { + my $self = shift; + return bless { %$self }, ref $self; +} + +sub _new_from_chunk { + my $class = shift; + my $chunk = shift or return; # 512 bytes of tar header + my %hash = @_; + + ### filter any arguments on defined-ness of values. + ### this allows overriding from what the tar-header is saying + ### about this tar-entry. Particularly useful for @LongLink files + my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash; + + ### makes it start at 0 actually... :) ### + my $i = -1; + my %entry = map { + $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ + } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); + + my $obj = bless { %entry, %args }, $class; + + ### magic is a filetype string.. it should have something like 'ustar' or + ### something similar... if the chunk is garbage, skip it + return unless $obj->magic !~ /\W/; + + ### store the original chunk ### + $obj->raw( $chunk ); + + $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) ); + $obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) ); + + + return $obj; + +} + +sub _new_from_file { + my $class = shift; + my $path = shift; + + ### path has to at least exist + return unless defined $path; + + my $type = __PACKAGE__->_filetype($path); + my $data = ''; + + READ: { + unless ($type == DIR ) { + my $fh = IO::File->new; + + unless( $fh->open($path) ) { + ### dangling symlinks are fine, stop reading but continue + ### creating the object + last READ if $type == SYMLINK; + + ### otherwise, return from this function -- + ### anything that's *not* a symlink should be + ### resolvable + return; + } + + ### binmode needed to read files properly on win32 ### + binmode $fh; + $data = do { local $/; <$fh> }; + close $fh; + } + } + + my @items = qw[mode uid gid size mtime]; + my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9]; + + if (ON_VMS) { + ### VMS has two UID modes, traditional and POSIX. Normally POSIX is + ### not used. We currently do not have an easy way to see if we are in + ### POSIX mode. In traditional mode, the UID is actually the VMS UIC. + ### The VMS UIC has the upper 16 bits is the GID, which in many cases + ### the VMS UIC will be larger than 209715, the largest that TAR can + ### handle. So for now, assume it is traditional if the UID is larger + ### than 0x10000. + + if ($hash{uid} > 0x10000) { + $hash{uid} = $hash{uid} & 0xFFFF; + } + + ### The file length from stat() is the physical length of the file + ### However the amount of data read in may be more for some file types. + ### Fixed length files are read past the logical EOF to end of the block + ### containing. Other file types get expanded on read because record + ### delimiters are added. + + my $data_len = length $data; + $hash{size} = $data_len if $hash{size} < $data_len; + + } + ### you *must* set size == 0 on symlinks, or the next entry will be + ### though of as the contents of the symlink, which is wrong. + ### this fixes bug #7937 + $hash{size} = 0 if ($type == DIR or $type == SYMLINK); + $hash{mtime} -= TIME_OFFSET; + + ### strip the high bits off the mode, which we don't need to store + $hash{mode} = STRIP_MODE->( $hash{mode} ); + + + ### probably requires some file path munging here ... ### + ### name and prefix are set later + my $obj = { + %hash, + name => '', + chksum => CHECK_SUM, + type => $type, + linkname => ($type == SYMLINK and CAN_READLINK) + ? readlink $path + : '', + magic => MAGIC, + version => TAR_VERSION, + uname => UNAME->( $hash{uid} ), + gname => GNAME->( $hash{gid} ), + devmajor => 0, # not handled + devminor => 0, # not handled + prefix => '', + data => $data, + }; + + bless $obj, $class; + + ### fix up the prefix and file from the path + my($prefix,$file) = $obj->_prefix_and_file( $path ); + $obj->prefix( $prefix ); + $obj->name( $file ); + + return $obj; +} + +sub _new_from_data { + my $class = shift; + my $path = shift; return unless defined $path; + my $data = shift; return unless defined $data; + my $opt = shift; + + my $obj = { + data => $data, + name => '', + mode => MODE, + uid => UID, + gid => GID, + size => length $data, + mtime => time - TIME_OFFSET, + chksum => CHECK_SUM, + type => FILE, + linkname => '', + magic => MAGIC, + version => TAR_VERSION, + uname => UNAME->( UID ), + gname => GNAME->( GID ), + devminor => 0, + devmajor => 0, + prefix => '', + }; + + ### overwrite with user options, if provided ### + if( $opt and ref $opt eq 'HASH' ) { + for my $key ( keys %$opt ) { + + ### don't write bogus options ### + next unless exists $obj->{$key}; + $obj->{$key} = $opt->{$key}; + } + } + + bless $obj, $class; + + ### fix up the prefix and file from the path + my($prefix,$file) = $obj->_prefix_and_file( $path ); + $obj->prefix( $prefix ); + $obj->name( $file ); + + return $obj; +} + +sub _prefix_and_file { + my $self = shift; + my $path = shift; + + my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir ); + my @dirs = File::Spec->splitdir( $dirs ); + + ### so sometimes the last element is '' -- probably when trailing + ### dir slashes are encountered... this is of course pointless, + ### so remove it + pop @dirs while @dirs and not length $dirs[-1]; + + ### if it's a directory, then $file might be empty + $file = pop @dirs if $self->is_dir and not length $file; + + ### splitting ../ gives you the relative path in native syntax + map { $_ = '..' if $_ eq '-' } @dirs if ON_VMS; + + my $prefix = File::Spec::Unix->catdir( + grep { length } $vol, @dirs + ); + return( $prefix, $file ); +} + +sub _filetype { + my $self = shift; + my $file = shift; + + return unless defined $file; + + return SYMLINK if (-l $file); # Symlink + + return FILE if (-f _); # Plain file + + return DIR if (-d _); # Directory + + return FIFO if (-p _); # Named pipe + + return SOCKET if (-S _); # Socket + + return BLOCKDEV if (-b _); # Block special + + return CHARDEV if (-c _); # Character special + + ### shouldn't happen, this is when making archives, not reading ### + return LONGLINK if ( $file eq LONGLINK_NAME ); + + return UNKNOWN; # Something else (like what?) + +} + +### this method 'downgrades' a file to plain file -- this is used for +### symlinks when FOLLOW_SYMLINKS is true. +sub _downgrade_to_plainfile { + my $entry = shift; + $entry->type( FILE ); + $entry->mode( MODE ); + $entry->linkname(''); + + return 1; +} + +=head2 $bool = $file->extract( [ $alternative_name ] ) + +Extract this object, optionally to an alternative name. + +See C<< Archive::Tar->extract_file >> for details. + +Returns true on success and false on failure. + +=cut + +sub extract { + my $self = shift; + + local $Carp::CarpLevel += 1; + + return Archive::Tar->_extract_file( $self, @_ ); +} + +=head2 $path = $file->full_path + +Returns the full path from the tar header; this is basically a +concatenation of the C and C fields. + +=cut + +sub full_path { + my $self = shift; + + ### if prefix field is emtpy + return $self->name unless defined $self->prefix and length $self->prefix; + + ### or otherwise, catfile'd + return File::Spec::Unix->catfile( $self->prefix, $self->name ); +} + + +=head2 $bool = $file->validate + +Done by Archive::Tar internally when reading the tar file: +validate the header against the checksum to ensure integer tar file. + +Returns true on success, false on failure + +=cut + +sub validate { + my $self = shift; + + my $raw = $self->raw; + + ### don't know why this one is different from the one we /write/ ### + substr ($raw, 148, 8) = " "; + + ### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar + ### like GNU tar does. See here for details: + ### http://www.gnu.org/software/tar/manual/tar.html#SEC139 + ### so we do both a signed AND unsigned validate. if one succeeds, that's + ### good enough + return ( (unpack ("%16C*", $raw) == $self->chksum) + or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0; +} + +=head2 $bool = $file->has_content + +Returns a boolean to indicate whether the current object has content. +Some special files like directories and so on never will have any +content. This method is mainly to make sure you don't get warnings +for using uninitialized values when looking at an object's content. + +=cut + +sub has_content { + my $self = shift; + return defined $self->data() && length $self->data() ? 1 : 0; +} + +=head2 $content = $file->get_content + +Returns the current content for the in-memory file + +=cut + +sub get_content { + my $self = shift; + $self->data( ); +} + +=head2 $cref = $file->get_content_by_ref + +Returns the current content for the in-memory file as a scalar +reference. Normal users won't need this, but it will save memory if +you are dealing with very large data files in your tar archive, since +it will pass the contents by reference, rather than make a copy of it +first. + +=cut + +sub get_content_by_ref { + my $self = shift; + + return \$self->{data}; +} + +=head2 $bool = $file->replace_content( $content ) + +Replace the current content of the file with the new content. This +only affects the in-memory archive, not the on-disk version until +you write it. + +Returns true on success, false on failure. + +=cut + +sub replace_content { + my $self = shift; + my $data = shift || ''; + + $self->data( $data ); + $self->size( length $data ); + return 1; +} + +=head2 $bool = $file->rename( $new_name ) + +Rename the current file to $new_name. + +Note that you must specify a Unix path for $new_name, since per tar +standard, all files in the archive must be Unix paths. + +Returns true on success and false on failure. + +=cut + +sub rename { + my $self = shift; + my $path = shift; + + return unless defined $path; + + my ($prefix,$file) = $self->_prefix_and_file( $path ); + + $self->name( $file ); + $self->prefix( $prefix ); + + return 1; +} + +=head1 Convenience methods + +To quickly check the type of a C object, you can +use the following methods: + +=over 4 + +=item $file->is_file + +Returns true if the file is of type C + +=item $file->is_dir + +Returns true if the file is of type C + +=item $file->is_hardlink + +Returns true if the file is of type C + +=item $file->is_symlink + +Returns true if the file is of type C + +=item $file->is_chardev + +Returns true if the file is of type C + +=item $file->is_blockdev + +Returns true if the file is of type C + +=item $file->is_fifo + +Returns true if the file is of type C + +=item $file->is_socket + +Returns true if the file is of type C + +=item $file->is_longlink + +Returns true if the file is of type C. +Should not happen after a successful C. + +=item $file->is_label + +Returns true if the file is of type C