├── .gitignore ├── .perlcriticrc ├── .perltidyrc ├── .travis.yml ├── Build.PL ├── Changes ├── INSTALL.SKIP ├── LICENSE ├── MANIFEST ├── MANIFEST.SKIP ├── META.json ├── META.yml ├── PATCHING ├── README ├── admin ├── change_version └── new_major_version ├── appveyor.yml ├── bin ├── perl5i.bat.PL ├── perl5i.c ├── perl5i.h.PL └── perl5i.plx ├── img ├── perl5i camel with a machine gun.jpg └── radical_onion.png ├── inc └── MyBuild.pm ├── lib ├── perl5i.pm ├── perl5i │ ├── 0 │ │ ├── ARRAY.pm │ │ ├── DEFAULT.pm │ │ ├── DateTime.pm │ │ ├── HASH.pm │ │ ├── Meta.pm │ │ ├── Meta │ │ │ ├── Class.pm │ │ │ └── Instance.pm │ │ └── SCALAR.pm │ ├── 1 │ │ ├── ARRAY.pm │ │ ├── CODE.pm │ │ ├── DateTime.pm │ │ ├── HASH.pm │ │ ├── Meta.pm │ │ ├── Meta │ │ │ ├── Class.pm │ │ │ └── Instance.pm │ │ ├── SCALAR.pm │ │ ├── UNIVERSAL.pm │ │ └── autobox.pm │ ├── 2 │ │ ├── ARRAY.pm │ │ ├── CODE.pm │ │ ├── DateTime.pm │ │ ├── HASH.pm │ │ ├── Meta.pm │ │ ├── Meta │ │ │ ├── Class.pm │ │ │ └── Instance.pm │ │ ├── RequireMessage.pm │ │ ├── SCALAR.pm │ │ ├── Signature.pm │ │ ├── Signature │ │ │ ├── Function │ │ │ │ └── None.pm │ │ │ ├── Method │ │ │ │ └── None.pm │ │ │ ├── None.pm │ │ │ └── Real.pm │ │ ├── Signatures.pm │ │ ├── UNIVERSAL.pm │ │ ├── autobox.pm │ │ └── equal.pm │ ├── 0.pm │ ├── 1.pm │ ├── 2.pm │ ├── Meta.pod │ ├── Signature.pod │ ├── VERSION.pm │ ├── cmd.pm │ └── latest.pm └── perl5ifaq.pod ├── local-lib-rc └── t ├── 00_TEST_TEMPLATE.t ├── ARGV.t ├── ARGV_twice.t ├── CLASS.t ├── Child.t ├── English.t ├── File-stat.t ├── List-MoreUtils ├── all.t ├── any.t ├── false.t ├── mesh.t ├── minmax.t ├── none.t ├── true.t └── uniq.t ├── List-Util ├── first.t ├── max.t ├── maxstr.t ├── min.t ├── minstr.t ├── reduce.t ├── shuffle.t └── sum.t ├── Meta ├── ISA.t ├── checksum.t ├── class.t ├── id.t ├── is-equal.t ├── linear_isa.t ├── methods.t ├── reftype.t ├── super.t └── symbol_table.t ├── Want.t ├── alias.t ├── as_hash.t ├── autobox.t ├── autodie.t ├── autovivification.t ├── caller.t ├── can.t ├── capture.t ├── carp.t ├── center.t ├── chdir.t ├── command_line_wrapper.t ├── commify.t ├── datetime.t ├── die.t ├── diff.t ├── dump ├── array.t ├── code.t ├── formats.t ├── hash.t ├── obj.t └── scalar.t ├── each.t ├── equal.t ├── everything_is_an_object.t ├── flip.t ├── foreach.t ├── github164.t ├── grep.t ├── hash-diff.t ├── hash-intersect.t ├── hash-merge.t ├── intersect.t ├── io-handle.t ├── is_module_name.t ├── lexical.t ├── lib ├── Test │ └── perl5i.pm └── ThisIsTrue.pm ├── list-trim.t ├── list.t ├── load_together.t ├── map.t ├── method_leaking.t ├── modern_perl.t ├── module2path.t ├── no_indirect.t ├── number.t ├── path └── base.t ├── perl5i.t ├── pick.t ├── popn.t ├── require.t ├── require_message.t ├── say.t ├── scalar.t ├── shiftn.t ├── signature.t ├── signatures.t ├── skip.t ├── taint.t ├── time_compat.t ├── true.t ├── try-tiny.t ├── uniq.t ├── utf8.t ├── version_0 └── 00_compile.t ├── version_1 └── 00_compile.t ├── vs_listmoreutils.t ├── wrap.t └── y2038.t /.gitignore: -------------------------------------------------------------------------------- 1 | *.bak 2 | *~ 3 | *.old 4 | Makefile 5 | blib/ 6 | pm_to_blib 7 | Build 8 | _build 9 | Build.bat 10 | cover_db/ 11 | nytprof* 12 | *.patch 13 | .DS_Store 14 | MYMETA.* 15 | *.o 16 | bin/perl5i 17 | bin/perl5i.h 18 | bin/perl5i.bat 19 | .prove 20 | *.swp 21 | *.dSYM/ -------------------------------------------------------------------------------- /.perlcriticrc: -------------------------------------------------------------------------------- 1 | ## 2 | ### Configure perlcritic display behavior. 3 | ### 4 | 5 | # Change the default message to show the policy name so we can shut it up if necessary 6 | verbose = %m [%p] at %f line %l, near '%r'\n 7 | 8 | # Force perlcritic to use color, even when run through a pager. 9 | color = 1 10 | 11 | # Use a pager. 12 | pager = $PAGER 13 | 14 | 15 | ### 16 | ### Turn off policies. 17 | ### 18 | 19 | # Nuthin wrong with the expression form of map and grep. 20 | [-BuiltinFunctions::RequireBlockMap] 21 | [-BuiltinFunctions::RequireBlockGrep] 22 | 23 | # We realize that localizing a variable does not retain it's original value, 24 | # thanks. 25 | [-Variables::RequireInitializationForLocalVars] 26 | 27 | # I'd rather use a few unnecessary "" then forget to interpolate. 28 | [-ValuesAndExpressions::ProhibitInterpolationOfLiterals] 29 | 30 | # Inline POD is more worthwhile than the dubious optimization of putting it 31 | # after the __END__ block 32 | [-Documentation::RequirePodAtEnd] 33 | 34 | # No, we're not going to use English. 35 | [-Variables::ProhibitPunctuationVars] 36 | 37 | # That's just rediculous 38 | [-ControlStructures::ProhibitPostfixControls] 39 | [-ValuesAndExpressions::ProhibitEmptyQuotes] 40 | [-ValuesAndExpressions::ProhibitNoisyQuotes] 41 | 42 | # Test::Builder makes heavy use of local() 43 | [-Variables::ProhibitLocalVars] 44 | 45 | # Nuthin wrong with @$foo 46 | [-References::ProhibitDoubleSigils] 47 | 48 | # We're going to be doing this a lot 49 | [-Modules::ProhibitMultiplePackages] 50 | [-Modules::RequireFilenameMatchesPackage] 51 | 52 | ### 53 | ### Configure policies 54 | ### 55 | 56 | # Extend the ability to play with @_ to 3 line subroutines. 57 | [Subroutines::RequireArgUnpacking] 58 | short_subroutine_statements = 3 59 | 60 | # No tabs ever 61 | [CodeLayout::ProhibitHardTabs] 62 | allow_leading_tabs = 0 63 | 64 | # 'no strict "refs"' is ok 65 | [TestingAndDebugging::ProhibitNoStrict] 66 | allow = refs 67 | 68 | ### 69 | ### New policies and options which are not released yet. 70 | ### 71 | 72 | # "no warnings" is fine as long as it's restricted to one or more categories 73 | [TestingAndDebugging::ProhibitNoWarnings] 74 | allow_with_category_restriction = 1 75 | 76 | # Don't need /x on small regexes. 77 | [RegularExpressions::RequireExtendedFormatting] 78 | minimum_regex_length_to_complain_about = 12 79 | -------------------------------------------------------------------------------- /.perltidyrc: -------------------------------------------------------------------------------- 1 | --maximum-line-length=100 # we have widescreen now 2 | --indent-columns=4 3 | --continuation-indentation=2 4 | --no-opening-sub-brace-on-new-line 5 | --paren-tightness=1 6 | --square-bracket-tightness=1 7 | --brace-tightness=1 8 | --no-space-for-semicolon 9 | --no-outdent-long-quotes 10 | --output-line-ending=unix 11 | --no-outdent-labels 12 | --no-blanks-before-comments 13 | --blanks-before-subs 14 | --blanks-before-blocks 15 | --maximum-consecutive-blank-lines=2 # Allow two blanks between subroutines 16 | --nospace-after-keyword="my local our and or eq ne if else elsif until unless while for foreach return switch case given when" 17 | --want-break-before="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" 18 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | perl: 3 | - "5.22" 4 | - "5.20" 5 | - "5.18" 6 | - "5.16" 7 | - "5.14" 8 | - "5.12" 9 | - "5.10" 10 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | 5 | # Include 'lib' so it sees our perl5i::VERSION when version checking 6 | use lib 'inc', 'lib'; 7 | use MyBuild; 8 | 9 | use 5.010; 10 | 11 | my $builder = MyBuild->new( 12 | module_name => 'perl5i', 13 | license => 'perl', 14 | dist_author => 'Michael G Schwern ', 15 | dist_version => "v2.13.2", 16 | 17 | requires => { 18 | 'perl' => '5.10.0', 19 | 'Modern::Perl' => '1.03', 20 | 'CLASS' => '1.00', 21 | # Windows fixes 22 | 'Child' => '0.013', 23 | 'DateTime' => '0.47', 24 | 'DateTime::Format::Epoch' => '0.11', 25 | 'DateTime::TimeZone::Tzfile' => '0.002', 26 | # for perl5i::1 27 | 'Module::Load' => '0.16', 28 | 'Text::Wrap' => '2009.0305', 29 | 'Try::Tiny' => '0.02', 30 | # plays nice with open pragma, Debian stable version 31 | 'autodie' => '2.12', 32 | # Needed for autodie :system 33 | 'IPC::System::Simple' => '1.18', 34 | 'autobox' => '2.80', 35 | 'autobox::Core' => '1.0', 36 | parent => '0.221', 37 | 'File::chdir' => '0.1002', 38 | # for perl5i::1 39 | 'autobox::dump' => '20090426', 40 | 'autobox::List::Util' => '20090629', 41 | 'Want' => '0.18', 42 | 'autovivification' => '0.06', 43 | 'version' => '0.77', 44 | 'Perl6::Caller' => '0.100', 45 | "Taint::Util" => '0.06', 46 | 'Hash::Merge::Simple' => '0.04', 47 | 'List::MoreUtils' => '0.22', 48 | indirect => '0.24', 49 | 'JSON::MaybeXS' => '1.003005', 50 | 'YAML::Any' => '0.70', 51 | 'Digest::SHA' => '5.45', 52 | 'Digest::MD5' => '2.36', 53 | 'Object::ID' => '0.1.0', 54 | "Devel::Declare::MethodInstaller::Simple" => '0.006009', 55 | 'true::VERSION' => '0.16', 56 | # Various Windows fixes 57 | 'Capture::Tiny' => '0.32', 58 | # Fixes utf8 + threads (and fork emulation on Windows) 59 | 'utf8::all' => '0.015', 60 | 'Carp::Fix::1_25' => '1.000000', 61 | 'Hash::StoredIterator' => '0.007', 62 | 'Hash::FieldHash' => '0.06', 63 | 'Path::Tiny' => '0.036', 64 | 'Import::Into' => '1.002003', 65 | 'Sub::Name' => '0', 66 | }, 67 | build_requires => { 68 | 'ExtUtils::CBuilder' => '0.26', 69 | 'Test::More' => '0.88', 70 | 'Test::Warn' => '0.11', 71 | 'IPC::Open3' => '0', 72 | 'Test::Output' => '0.16', 73 | 'Test::Most' => '0', 74 | }, 75 | configure_requires => { 76 | # MB's auto configure requires only puts it in the META.yml 77 | # so some CPAN shells won't see it. 78 | "Module::Build" => '0.36', 79 | }, 80 | recommends => { 81 | # Significant performance improvements 82 | autodie => '2.26', 83 | }, 84 | 85 | meta_merge => { 86 | resources => { 87 | repository => 'http://github.com/evalEmpire/perl5i/tree/master', 88 | bugtracker => 'http://github.com/evalEmpire/perl5i/issues', 89 | IRC => "irc://irc.perl.org/#perl5i", 90 | }, 91 | no_index => { 92 | file => [qw( 93 | lib/perl5i/0/DateTime.pm 94 | lib/perl5i/0/ARRAY.pm 95 | lib/perl5i/0/DEFAULT.pm 96 | lib/perl5i/0/HASH.pm 97 | lib/perl5i/0/Meta.pm 98 | lib/perl5i/0/Meta/Class.pm 99 | lib/perl5i/0/Meta/Instance.pm 100 | lib/perl5i/0/SCALAR.pm 101 | lib/perl5i/VERSION.pm 102 | )], 103 | }, 104 | }, 105 | 106 | PL_files => { 107 | 'bin/perl5i.h.PL' => 'bin/perl5i.h', 108 | 'bin/perl5i.bat.PL' => 'bin/perl5i.bat', 109 | }, 110 | 111 | recursive_test_files => 1, 112 | 113 | create_readme => 1, 114 | create_license => 1, 115 | ); 116 | 117 | $builder->requires->{"Time::y2038"} = "20100218" if $builder->needs_y2038; 118 | 119 | $builder->create_build_script(); 120 | -------------------------------------------------------------------------------- /INSTALL.SKIP: -------------------------------------------------------------------------------- 1 | \.PL$ 2 | \.c$ 3 | \.o$ 4 | 5 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | .perlcriticrc 2 | .perltidyrc 3 | bin/perl5i.bat.PL 4 | bin/perl5i.c 5 | bin/perl5i.h.PL 6 | bin/perl5i.plx 7 | Build.PL 8 | Changes 9 | inc/MyBuild.pm 10 | INSTALL.SKIP 11 | lib/perl5i.pm 12 | lib/perl5i/0.pm 13 | lib/perl5i/0/ARRAY.pm 14 | lib/perl5i/0/DateTime.pm 15 | lib/perl5i/0/DEFAULT.pm 16 | lib/perl5i/0/HASH.pm 17 | lib/perl5i/0/Meta.pm 18 | lib/perl5i/0/Meta/Class.pm 19 | lib/perl5i/0/Meta/Instance.pm 20 | lib/perl5i/0/SCALAR.pm 21 | lib/perl5i/1.pm 22 | lib/perl5i/1/ARRAY.pm 23 | lib/perl5i/1/autobox.pm 24 | lib/perl5i/1/CODE.pm 25 | lib/perl5i/1/DateTime.pm 26 | lib/perl5i/1/HASH.pm 27 | lib/perl5i/1/Meta.pm 28 | lib/perl5i/1/Meta/Class.pm 29 | lib/perl5i/1/Meta/Instance.pm 30 | lib/perl5i/1/SCALAR.pm 31 | lib/perl5i/1/UNIVERSAL.pm 32 | lib/perl5i/2.pm 33 | lib/perl5i/2/ARRAY.pm 34 | lib/perl5i/2/autobox.pm 35 | lib/perl5i/2/CODE.pm 36 | lib/perl5i/2/DateTime.pm 37 | lib/perl5i/2/equal.pm 38 | lib/perl5i/2/HASH.pm 39 | lib/perl5i/2/Meta.pm 40 | lib/perl5i/2/Meta/Class.pm 41 | lib/perl5i/2/Meta/Instance.pm 42 | lib/perl5i/2/RequireMessage.pm 43 | lib/perl5i/2/SCALAR.pm 44 | lib/perl5i/2/Signature.pm 45 | lib/perl5i/2/Signature/Function/None.pm 46 | lib/perl5i/2/Signature/Method/None.pm 47 | lib/perl5i/2/Signature/None.pm 48 | lib/perl5i/2/Signature/Real.pm 49 | lib/perl5i/2/Signatures.pm 50 | lib/perl5i/2/UNIVERSAL.pm 51 | lib/perl5i/cmd.pm 52 | lib/perl5i/latest.pm 53 | lib/perl5i/Meta.pod 54 | lib/perl5i/Signature.pod 55 | lib/perl5i/VERSION.pm 56 | lib/perl5ifaq.pod 57 | LICENSE 58 | local-lib-rc 59 | MANIFEST This list of files 60 | MANIFEST.SKIP 61 | META.json 62 | META.yml 63 | PATCHING 64 | README 65 | t/alias.t 66 | t/ARGV.t 67 | t/ARGV_twice.t 68 | t/as_hash.t 69 | t/autobox.t 70 | t/autodie.t 71 | t/autovivification.t 72 | t/caller.t 73 | t/can.t 74 | t/capture.t 75 | t/carp.t 76 | t/center.t 77 | t/chdir.t 78 | t/Child.t 79 | t/CLASS.t 80 | t/command_line_wrapper.t 81 | t/commify.t 82 | t/datetime.t 83 | t/die.t 84 | t/diff.t 85 | t/dump/array.t 86 | t/dump/code.t 87 | t/dump/formats.t 88 | t/dump/hash.t 89 | t/dump/obj.t 90 | t/dump/scalar.t 91 | t/each.t 92 | t/English.t 93 | t/equal.t 94 | t/everything_is_an_object.t 95 | t/File-stat.t 96 | t/flip.t 97 | t/foreach.t 98 | t/github164.t 99 | t/grep.t 100 | t/hash-diff.t 101 | t/hash-intersect.t 102 | t/hash-merge.t 103 | t/intersect.t 104 | t/io-handle.t 105 | t/is_module_name.t 106 | t/lexical.t 107 | t/lib/Test/perl5i.pm 108 | t/lib/ThisIsTrue.pm 109 | t/List-MoreUtils/all.t 110 | t/List-MoreUtils/any.t 111 | t/List-MoreUtils/false.t 112 | t/List-MoreUtils/mesh.t 113 | t/List-MoreUtils/minmax.t 114 | t/List-MoreUtils/none.t 115 | t/List-MoreUtils/true.t 116 | t/List-MoreUtils/uniq.t 117 | t/list-trim.t 118 | t/List-Util/first.t 119 | t/List-Util/max.t 120 | t/List-Util/maxstr.t 121 | t/List-Util/min.t 122 | t/List-Util/minstr.t 123 | t/List-Util/reduce.t 124 | t/List-Util/shuffle.t 125 | t/List-Util/sum.t 126 | t/list.t 127 | t/load_together.t 128 | t/map.t 129 | t/Meta/checksum.t 130 | t/Meta/class.t 131 | t/Meta/id.t 132 | t/Meta/is-equal.t 133 | t/Meta/ISA.t 134 | t/Meta/linear_isa.t 135 | t/Meta/methods.t 136 | t/Meta/reftype.t 137 | t/Meta/super.t 138 | t/Meta/symbol_table.t 139 | t/method_leaking.t 140 | t/modern_perl.t 141 | t/module2path.t 142 | t/no_indirect.t 143 | t/number.t 144 | t/path/base.t 145 | t/perl5i.t 146 | t/pick.t 147 | t/popn.t 148 | t/require.t 149 | t/require_message.t 150 | t/say.t 151 | t/scalar.t 152 | t/shiftn.t 153 | t/signature.t 154 | t/signatures.t 155 | t/skip.t 156 | t/taint.t 157 | t/time_compat.t 158 | t/true.t 159 | t/try-tiny.t 160 | t/uniq.t 161 | t/utf8.t 162 | t/version_0/00_compile.t 163 | t/version_1/00_compile.t 164 | t/vs_listmoreutils.t 165 | t/Want.t 166 | t/wrap.t 167 | t/y2038.t 168 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | 2 | #!start included /Users/schwern/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/ExtUtils/MANIFEST.SKIP 3 | # Avoid version control files. 4 | \bRCS\b 5 | \bCVS\b 6 | \bSCCS\b 7 | ,v$ 8 | \B\.svn\b 9 | \B\.git\b 10 | \B\.gitignore\b 11 | \b_darcs\b 12 | \B\.cvsignore$ 13 | 14 | # Avoid VMS specific MakeMaker generated files 15 | \bDescrip.MMS$ 16 | \bDESCRIP.MMS$ 17 | \bdescrip.mms$ 18 | 19 | # Avoid Makemaker generated and utility files. 20 | \bMANIFEST\.bak 21 | \bMakefile$ 22 | \bblib/ 23 | \bMakeMaker-\d 24 | \bpm_to_blib\.ts$ 25 | \bpm_to_blib$ 26 | \bblibdirs\.ts$ # 6.18 through 6.25 generated this 27 | 28 | # Avoid Module::Build generated and utility files. 29 | \bBuild$ 30 | \b_build/ 31 | \bBuild.bat$ 32 | \bBuild.COM$ 33 | \bBUILD.COM$ 34 | \bbuild.com$ 35 | 36 | # Avoid temp and backup files. 37 | ~$ 38 | \.old$ 39 | \#$ 40 | \b\.# 41 | \.bak$ 42 | \.tmp$ 43 | \.# 44 | \.rej$ 45 | 46 | # Avoid OS-specific files/dirs 47 | # Mac OSX metadata 48 | \B\.DS_Store 49 | # Mac OSX SMB mount metadata files 50 | \B\._ 51 | 52 | # Avoid Devel::Cover and Devel::CoverX::Covered files. 53 | \bcover_db\b 54 | \bcovered\b 55 | 56 | # Avoid MYMETA files 57 | ^MYMETA\. 58 | #!end included /Users/schwern/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/ExtUtils/MANIFEST.SKIP 59 | 60 | 61 | # Avoid Devel::NYTProf files 62 | ^nytprof 63 | 64 | # Don't ship perl5i 65 | ^bin/perl5i$ 66 | ^bin/perl5i.h$ 67 | ^bin/perl5i.bat$ 68 | 69 | # Ignore C object files 70 | \.o$ 71 | ^MYMETA.yml$ 72 | 73 | # Ignore emacs temp files 74 | ^\.# 75 | 76 | # Ignore our own dist dir 77 | ^perl5i- 78 | 79 | # Don't ship admin scripts 80 | ^admin/ 81 | 82 | # Don't ship our motivational images 83 | ^img/ 84 | 85 | # Don't ship patch files 86 | \.patch$ 87 | \.diff$ 88 | 89 | # Don't ship the test template 90 | t/00_TEST_TEMPLATE.t 91 | 92 | # Don't ship Travis-CI config 93 | ^\.travis\.yml -------------------------------------------------------------------------------- /PATCHING: -------------------------------------------------------------------------------- 1 | Patching policy for perl5i. 2 | 3 | For the really impatient: 4 | ------------------------- 5 | 6 | * Rule 1: When in doubt, open a ticket. 7 | http://github.com/evalEmpire/perl5i/issues 8 | 9 | Found a bug? Not sure if its a bug or a weird feature? Have an idea? 10 | Found something unpleasent? Had trouble using something? Open a ticket. 11 | Don't worry, we won't yell at you. We'd rather get 10 duplicates than 12 | lose one good report because somebody wasn't sure. 13 | 14 | * We prefer if you use github, but you can always email a patch 15 | to perl5i@googlegroups.com. 16 | 17 | * Don't know if your code is up to our standard? Send it in and 18 | we'll work it out. 19 | 20 | * perl5i is about making Perl 5 better. A good rule of thumb is if 21 | it takes more than one line to do a simple thing, you might be on to 22 | something. If a newbie asks a simple question and the "right answer" 23 | takes a full page, you've probably found a candidate for perl5i. 24 | 25 | 26 | Here's the preferred way to make a patch: 27 | ---------------------------------------- 28 | 29 | 0) We'd rather you participate than follow all the rules, especially 30 | if its your first patch. Don't worry, be crappy. 31 | 32 | 1) Put an issue in the tracker for your problem. Then it can be 33 | discussed before you put a whole lot of effort into it. 34 | http://github.com/evalEmpire/perl5i/issues 35 | 36 | 1a) If its a bug, report the bug BEFORE work on it. This ensures the 37 | bug gets reported. Mention that you're working on it. 38 | 39 | 1b) If its a feature, we like to hear about your idea even if 40 | you don't have a patch. 41 | 42 | 2) You can either work from the CPAN version or the repository. 43 | We'd prefer you worked from the repository. 44 | http://github.com/evalEmpire/perl5i 45 | 46 | 2a) Ideally, make a fork on github and work on that. 47 | 48 | 3) DO add any new dependencies in Build.PL 49 | 50 | 3a) If you're not sure what version to depend on, pick the version 51 | you have installed. That's safest. 52 | 53 | 4) DON'T update MANIFEST. Its automated and will just cause 54 | conflicts. 55 | 56 | 5) DON'T update Changes. It will cause conflicts when merging. 57 | The release manager will handle it. 58 | 59 | 6) DO write tests. Otherwise the release manager has to. 60 | 61 | 7) DO write documentation. Otherwise the release manager has to. 62 | 63 | 8) Commit ONE THING AT A TIME. Preferrably use a branch for each 64 | feature. It makes it much easier to integrate. 65 | 66 | 9) You can either send patches to schwern+perl5i@pobox.com or 67 | (preferred) issue a github pull request. 68 | 69 | Thanks for patching! 70 | -------------------------------------------------------------------------------- /admin/change_version: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | my $version = shift; 4 | die "$0 \n" unless $version; 5 | system qq[perl -i -pe 's{(dist_version \\s* => \\s*) \\S+ (.*)}{\$1"v$version",}x' Build.PL]; 6 | system qq[perl -i -pe 's{v[.\\d_]+}{v$version}' lib/perl5i/VERSION.pm]; 7 | 8 | -------------------------------------------------------------------------------- /admin/new_major_version: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | $new_version = shift || die "$0 \n"; 4 | $old_version = $new_version - 1; 5 | 6 | # Copy the old version to the new version. 7 | run("cp lib/perl5i/$old_version.pm lib/perl5i/$new_version.pm"); 8 | run("cp -r lib/perl5i/$old_version lib/perl5i/$new_version"); 9 | 10 | # Change all instances of perl5i::$old to perl5i::$new, but leave the old files alone 11 | my $change_version = qq[perl -i -pe 's{perl5i::$old_version}{perl5i::$new_version}g']; 12 | run(qq[find lib/perl5i/$new_version -type f -print0 | xargs -0 $change_version]); 13 | run("$change_version lib/perl5i/{Meta,VERSION,latest,$new_version}.pm lib/*.pm lib/*.pod"); 14 | 15 | # Change the distribution version number to $new.0.0 16 | run(qq[perl -i -pe 's{v$old_version [.\\d]+}{v$new_version.0.0}x' lib/perl5i/VERSION.pm Build.PL]); 17 | 18 | sub run { 19 | my @cmd = @_; 20 | @cmd == 1 ? system $cmd[0] : system @cmd; 21 | die "@cmd exited with $?" if $?; 22 | return 1; 23 | } 24 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | branches: 2 | except: 3 | - /travis/ 4 | skip_tags: true 5 | 6 | cache: 7 | - C:\strawberry 8 | 9 | install: 10 | - if not exist "C:\strawberry" cinst strawberryperl -y 11 | - set PATH=C:\strawberry\perl\bin;C:\strawberry\perl\site\bin;C:\strawberry\c\bin;%PATH% 12 | - cd C:\projects\%APPVEYOR_PROJECT_NAME% 13 | - cpanm --installdeps . 14 | 15 | build_script: 16 | - perl Build.PL 17 | - ./Build 18 | 19 | test_script: 20 | - ./Build test 21 | 22 | -------------------------------------------------------------------------------- /bin/perl5i.bat.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | my $file = shift; 4 | open my $fh, ">", $file or die "Can't open $file: $!"; 5 | printf $fh <<'END', $^X; 6 | @echo off 7 | %s -Mperl5i::cmd=perl5i.bat %%* 8 | END 9 | -------------------------------------------------------------------------------- /bin/perl5i.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Meant to mimic the shell command 3 | * exec perl -Mperl5i::latest "$@" 4 | * 5 | * This is a C program so it works in a #! line with minimal overhead. 6 | */ 7 | 8 | #define DEBUG 0 9 | 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include "perl5i.h" 16 | 17 | char *safe_cat(char *a, char*b) { 18 | char *new = malloc(sizeof(char) * (strlen(a) + strlen(b) + 1)); 19 | 20 | strcpy(new, a); 21 | strcat(new, b); 22 | 23 | return new; 24 | } 25 | 26 | int main (int argc, char* argv[]) { 27 | int i; 28 | 29 | char **exec_args = malloc(sizeof(char*) * (argc + 2)); 30 | int num_exec_args = argc + 1; 31 | 32 | /* Insert -Mperl5i::cmd=... into a copy of argv */ 33 | exec_args[0] = argv[0]; 34 | exec_args[1] = safe_cat("-Mperl5i::cmd=", argv[0]); 35 | for( i = 1; i < argc; i++ ) { 36 | exec_args[i+1] = argv[i]; 37 | } 38 | 39 | exec_args[num_exec_args] = NULL; 40 | 41 | execv(Perl_Path, exec_args ); 42 | 43 | fprintf(stderr, "Executing %s failed: %s\n", Perl_Path, strerror(errno)); 44 | } 45 | -------------------------------------------------------------------------------- /bin/perl5i.h.PL: -------------------------------------------------------------------------------- 1 | # Write out a header config file for the perl5i C wrapper. 2 | 3 | use strict; 4 | use warnings; 5 | use File::Spec; 6 | 7 | my $file = shift; 8 | 9 | # Its going inside double quotes. 10 | my $perl_path = $^X; 11 | $perl_path =~ s{ ([\\"]) }{\\$1}gx; 12 | 13 | my $tempdir = File::Spec->tmpdir || "/tmp"; 14 | 15 | open my $fh, ">", $file or die $!; 16 | printf $fh <<"END"; 17 | /* THIS FILE IS GENERATED BY $0 18 | * Any changes here will be wiped out. Edit it there instead. 19 | */ 20 | 21 | const char Perl_Path[] = "$perl_path"; 22 | const char Temp_Template[] = "$tempdir/perl5i.XXXXXXXX"; 23 | END 24 | -------------------------------------------------------------------------------- /bin/perl5i.plx: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | exec $^X, "-Mperl5i::cmd=$0", @ARGV; 4 | -------------------------------------------------------------------------------- /img/perl5i camel with a machine gun.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/evalEmpire/perl5i/aa1124b89f38eed793e2b9f2d2b2ba5d80a27a20/img/perl5i camel with a machine gun.jpg -------------------------------------------------------------------------------- /img/radical_onion.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/evalEmpire/perl5i/aa1124b89f38eed793e2b9f2d2b2ba5d80a27a20/img/radical_onion.png -------------------------------------------------------------------------------- /inc/MyBuild.pm: -------------------------------------------------------------------------------- 1 | package MyBuild; 2 | 3 | use 5.010; 4 | use base 'Module::Build'; 5 | 6 | # Override default 'code' action 7 | # to allow compilation of perl5i.c 8 | sub ACTION_code { 9 | my $self = shift; 10 | 11 | # This has to be run first so the PL files are run to generate 12 | # the C code for us to compile. 13 | $self->process_PL_files; 14 | 15 | if ( $self->is_windowsish ) { 16 | # Writing a C wrapper is too hard on Windows 17 | # Don't need it as there's no #! anyway 18 | # Just do a bat file 19 | $self->script_files("bin/perl5i.bat"); 20 | } 21 | elsif ( $self->have_c_compiler() ) { 22 | my $b = $self->cbuilder(); 23 | 24 | my $obj_file = $b->compile( 25 | source => 'bin/perl5i.c', 26 | extra_compiler_flags => $self->extra_compiler_flags, 27 | ); 28 | my $exe_file = $b->link_executable(objects => $obj_file); 29 | 30 | # script_files is set here as the resulting compiled 31 | # executable name varies based on operating system 32 | $self->script_files($exe_file); 33 | 34 | # Cleanup files from compilation 35 | $self->add_to_cleanup($obj_file, $exe_file); 36 | } 37 | else { 38 | # No C compiler, Unix style operating system. 39 | # Just use the Perl wrapper. 40 | File::Copy::copy("bin/perl5i.plx", "bin/perl5i"); 41 | 42 | $self->script_files("bin/perl5i"); 43 | $self->add_to_cleanup("bin/perl5i"); 44 | } 45 | 46 | return $self->SUPER::ACTION_code; 47 | } 48 | 49 | 50 | # Run perltidy over all the Perl code 51 | # Borrowed from Test::Harness 52 | sub ACTION_tidy { 53 | my $self = shift; 54 | 55 | my %found_files = map { %$_ } $self->find_pm_files, 56 | $self->_find_file_by_type( 'pm', 't' ), 57 | $self->_find_file_by_type( 'pm', 'inc' ), 58 | $self->_find_file_by_type( 't', 't' ), 59 | $self->_find_file_by_type( 'PL', '.' ); 60 | 61 | my @files = ( keys %found_files, map { $self->localize_file_path($_) } @extra ); 62 | 63 | 64 | print "Running perltidy on @{[ scalar @files ]} files...\n"; 65 | for my $file ( sort { $a cmp $b } @files ) { 66 | print " $file\n"; 67 | system( 'perltidy', '-b', $file ); 68 | unlink("$file.bak") if $? == 0; 69 | } 70 | } 71 | 72 | sub ACTION_critic { 73 | my $self = shift; 74 | 75 | my @files = keys %{ $self->find_pm_files }; 76 | 77 | print "Running perlcritic on @{[ scalar @files ]} files...\n"; 78 | system( "perlcritic", @files ); 79 | } 80 | 81 | # Check if the built in local/gmtime work for a reasonable set of 82 | # time. Some systems fail at 2**47 or beyond, and a lot fail at year 83 | # 0, so those are good boundaries. 84 | # This allows us to avoid depending on Time::y2038 which is a bit 85 | # unreliable. 86 | sub needs_y2038 { 87 | my $self = shift; 88 | 89 | state $limits = { 90 | # time year 91 | 2**47-1 => 4461763, 92 | -62135510400 => 1, 93 | }; 94 | 95 | for my $time (keys %$limits) { 96 | my $year = $limits->{$time}; 97 | 98 | return 1 if (gmtime($time))[5] + 1900 != $year; 99 | return 1 if (localtime($time))[5] + 1900 != $year; 100 | } 101 | 102 | return 0; 103 | } 104 | 105 | 1; 106 | -------------------------------------------------------------------------------- /lib/perl5i/0.pm: -------------------------------------------------------------------------------- 1 | # vi: set ts=4 sw=4 ht=4 et : 2 | package perl5i::0; 3 | 4 | use 5.010; 5 | 6 | use strict; 7 | use warnings; 8 | use Module::Load; 9 | use IO::Handle; 10 | use Carp; 11 | use perl5i::0::DateTime; 12 | use perl5i::0::SCALAR; 13 | use perl5i::0::ARRAY; 14 | use perl5i::0::HASH; 15 | use perl5i::0::DEFAULT; 16 | use Want; 17 | use Try::Tiny; 18 | use perl5i::0::Meta; 19 | use autobox; 20 | use Encode (); 21 | 22 | use perl5i::VERSION; our $VERSION = perl5i::VERSION->VERSION; 23 | 24 | our $Latest = 'perl5i::0'; 25 | 26 | 27 | # This works around their lexical nature. 28 | use parent 'autodie'; 29 | # List::Util needs to be before Core to get the C version of sum 30 | use parent 'autobox::List::Util'; 31 | use parent 'autobox::Core'; 32 | use parent 'autobox::dump'; 33 | use parent 'autovivification'; 34 | use parent 'utf8'; 35 | use parent 'open'; 36 | 37 | ## no critic (Subroutines::RequireArgUnpacking) 38 | sub import { 39 | my $class = shift; 40 | 41 | require File::stat; 42 | 43 | require Modern::Perl; 44 | Modern::Perl->import; 45 | 46 | my $caller = caller; 47 | 48 | # Modern::Perl won't pass this through to our caller. 49 | require mro; 50 | mro::set_mro( $caller, 'c3' ); 51 | 52 | load_in_caller( $caller => ( 53 | ["CLASS"], ["File::chdir"], 54 | [English => qw(-no_match_vars)], 55 | ["Want" => qw(want)], ["Try::Tiny"], ["Perl6::Caller"], 56 | ) ); 57 | 58 | # Have to call both or it won't work. 59 | autobox::import($class); 60 | autobox::List::Util::import($class); 61 | autobox::Core::import($class); 62 | autobox::dump::import($class); 63 | autovivification::unimport($class); 64 | utf8::import($class); 65 | 66 | open::import($class, ":encoding(utf8)"); 67 | open::import($class, ":std"); 68 | 69 | # Export our gmtime() and localtime() 70 | (\&{$Latest .'::DateTime::dt_gmtime'})->alias($caller, 'gmtime'); 71 | (\&{$Latest .'::DateTime::dt_localtime'})->alias($caller, 'localtime'); 72 | (\&{$Latest .'::DateTime::dt_time'})->alias($caller, 'time'); 73 | (\&alias)->alias( $caller, 'alias' ); 74 | (\&stat)->alias( $caller, 'stat' ); 75 | (\&lstat)->alias( $caller, 'lstat' ); 76 | (\&utf8_open)->alias($caller, 'open'); 77 | 78 | # fix die so that it always returns 255 79 | *CORE::GLOBAL::die = sub { 80 | # Leave a single ref be 81 | local $! = 255; 82 | return CORE::die(@_) if @_ == 1 and ref $_[0]; 83 | 84 | my $error = join '', @_; 85 | unless ($error =~ /\n$/) { 86 | my ($file, $line) = (caller)[1,2]; 87 | $error .= " at $file line $line.\n"; 88 | } 89 | 90 | local $! = 255; 91 | return CORE::die($error); 92 | }; 93 | 94 | 95 | # utf8ify @ARGV 96 | $_ = Encode::decode('utf8', $_) for @ARGV; 97 | 98 | 99 | $^H{perl5i} = 1; 100 | 101 | # autodie needs a bit more convincing 102 | @_ = ( $class, ":all" ); 103 | goto &autodie::import; 104 | } 105 | 106 | sub unimport { $^H{perl5i} = 0 } 107 | 108 | sub utf8_open(*;$@) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) 109 | my $ret; 110 | if( @_ == 1 ) { 111 | $ret = CORE::open $_[0]; 112 | } 113 | else { 114 | $ret = CORE::open $_[0], $_[1], @_[2..$#_]; 115 | } 116 | 117 | # Don't try to binmode an unopened filehandle 118 | return $ret unless $ret; 119 | 120 | my $h = (caller 1)[10]; 121 | binmode $_[0], ":encoding(utf8)" if $h->{perl5i}; 122 | return $ret; 123 | } 124 | 125 | 126 | sub load_in_caller { 127 | my $caller = shift; 128 | my @modules = @_; 129 | 130 | for my $spec (@modules) { 131 | my( $module, @args ) = @$spec; 132 | 133 | load($module); 134 | ## no critic (BuiltinFunctions::ProhibitStringyEval) 135 | eval qq{ 136 | package $caller; 137 | \$module->import(\@args); 138 | 1; 139 | } or die "Error while perl5i loaded $module => @args: $@"; 140 | } 141 | 142 | return; 143 | } 144 | 145 | 146 | # File::stat does not play nice in list context 147 | sub stat { 148 | return CORE::stat(@_) if wantarray; 149 | return File::stat::stat(@_); 150 | } 151 | 152 | sub lstat { 153 | return CORE::lstat(@_) if wantarray; 154 | return File::stat::lstat(@_); 155 | } 156 | 157 | 1; 158 | 159 | -------------------------------------------------------------------------------- /lib/perl5i/0/DEFAULT.pm: -------------------------------------------------------------------------------- 1 | package perl5i::0::DEFAULT; 2 | 3 | # Methods which apply to all autoboxed objects 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Carp; 9 | 10 | BEGIN { 11 | @SCALAR::ISA = qw(DEFAULT); 12 | @ARRAY::ISA = qw(DEFAULT); 13 | @HASH::ISA = qw(DEFAULT); 14 | @CODE::ISA = qw(DEFAULT); 15 | } 16 | 17 | sub DEFAULT::alias { 18 | my $self = shift; 19 | 20 | croak "Not enough arguments given to alias()" unless @_; 21 | 22 | my @name = @_; 23 | unshift @name, (caller)[0] unless @name > 1 or grep /::/, @name; 24 | 25 | my $name = join "::", @name; 26 | 27 | no strict 'refs'; 28 | *{$name} = $self; 29 | return 1; 30 | } 31 | 32 | sub DEFAULT::is_number { return } 33 | sub DEFAULT::is_positive { return } 34 | sub DEFAULT::is_negative { return } 35 | sub DEFAULT::is_int { return } 36 | sub DEFAULT::is_integer { return } 37 | sub DEFAULT::is_decimal { return } 38 | 39 | 1; 40 | -------------------------------------------------------------------------------- /lib/perl5i/0/DateTime.pm: -------------------------------------------------------------------------------- 1 | package perl5i::0::DateTime; 2 | 3 | # A file to contain the Datetime work for perl5i to get it out of perl5i.pm 4 | 5 | use 5.010; 6 | use strict; 7 | use warnings; 8 | use Time::y2038; 9 | 10 | 11 | ## no critic (Subroutines::ProhibitSubroutinePrototypes) 12 | sub dt_gmtime (;$) { 13 | my $time = @_ ? shift : time; 14 | return gmtime($time) if wantarray; 15 | 16 | my($sec, $min, $hour, $mday, $mon, $year) = gmtime($time); 17 | $mon++; 18 | $year += 1900; 19 | 20 | require DateTime; 21 | return perl5i::0::DateTime::y2038->new( 22 | year => $year, 23 | month => $mon, 24 | day => $mday, 25 | hour => $hour, 26 | minute => $min, 27 | second => $sec, 28 | formatter => "perl5i::0::DateTime::Format::CTime" 29 | ); 30 | } 31 | 32 | 33 | ## no critic (Subroutines::ProhibitSubroutinePrototypes) 34 | sub dt_localtime (;$) { 35 | my $time = @_ ? shift : time; 36 | return localtime($time) if wantarray; 37 | 38 | my($sec, $min, $hour, $mday, $mon, $year) = localtime($time); 39 | $mon++; 40 | $year += 1900; 41 | 42 | require DateTime; 43 | return perl5i::0::DateTime::y2038->new( 44 | year => $year, 45 | month => $mon, 46 | day => $mday, 47 | hour => $hour, 48 | minute => $min, 49 | second => $sec, 50 | time_zone => "local", 51 | formatter => "perl5i::0::DateTime::Format::CTime" 52 | ); 53 | } 54 | 55 | 56 | ## no critic (Subroutines::ProhibitSubroutinePrototypes) 57 | sub dt_time () { 58 | require DateTime::Format::Epoch; 59 | state $formatter = DateTime::Format::Epoch->new( epoch => DateTime->from_epoch( epoch => 0 ) ); 60 | 61 | require DateTime; 62 | return perl5i::0::DateTime::time->from_epoch( 63 | epoch => time, 64 | formatter => $formatter 65 | ); 66 | } 67 | 68 | 69 | { 70 | package perl5i::0::DateTime::y2038; 71 | 72 | # Don't load DateTime until we need it. 73 | our @ISA = qw(DateTime); 74 | 75 | use overload 76 | "eq" => sub { 77 | my($dt1, $dt2) = @_; 78 | return "$dt1" eq "$dt2" if !eval { $dt2->isa("DateTime") }; 79 | return $dt1 eq $dt2; 80 | }; 81 | 82 | sub from_epoch { 83 | my $class = shift; 84 | 85 | require Time::y2038; 86 | no warnings 'redefine'; 87 | local *CORE::GLOBAL::gmtime = \&Time::y2038::gmtime; 88 | local *CORE::GLOBAL::localtime = \&Time::y2038::localtime; 89 | 90 | return $class->SUPER::from_epoch(@_); 91 | } 92 | 93 | 94 | # Copy of DateTime's own epoch() function. 95 | sub epoch { 96 | my $self = shift; 97 | 98 | my $zone = $self->time_zone; 99 | $self->set_time_zone("UTC"); 100 | 101 | require Time::y2038; 102 | my $time = Time::y2038::timegm( 103 | $self->sec, $self->min, $self->hour, $self->mday, 104 | $self->mon - 1, 105 | $self->year - 1900, 106 | ); 107 | 108 | $self->set_time_zone($zone); 109 | 110 | return $time; 111 | } 112 | } 113 | 114 | { 115 | 116 | package perl5i::0::DateTime::time; 117 | 118 | use parent -norequire, qw(perl5i::0::DateTime::y2038); 119 | 120 | use overload 121 | "0+" => sub { $_[0]->epoch }, 122 | "-" => sub { 123 | my( $a, $b, $reverse ) = @_; 124 | 125 | if($reverse) { 126 | ( $b, $a ) = ( $a, $b ); 127 | } 128 | 129 | my $time_a = eval { $a->isa("DateTime") } ? $a->epoch : $a; 130 | my $time_b = eval { $b->isa("DateTime") } ? $b->epoch : $b; 131 | 132 | return $time_a - $time_b; 133 | }, 134 | 135 | "+" => sub { 136 | my( $a, $b, $reverse ) = @_; 137 | 138 | if($reverse) { 139 | ( $b, $a ) = ( $a, $b ); 140 | } 141 | 142 | my $time_a = eval { $a->isa("DateTime") } ? $a->epoch : $a; 143 | my $time_b = eval { $b->isa("DateTime") } ? $b->epoch : $b; 144 | 145 | return $time_a + $time_b; 146 | }, 147 | 148 | "==" => sub { 149 | my($a, $b) = @_; 150 | return $a+0 == $b+0 if !eval { $b->isa("DateTime") }; 151 | return $a == $b; 152 | }, 153 | 154 | fallback => 1; 155 | } 156 | 157 | 158 | { 159 | 160 | package perl5i::0::DateTime::Format::CTime; 161 | 162 | use CLASS; 163 | 164 | sub new { 165 | return bless {}, $CLASS; 166 | } 167 | 168 | sub format_datetime { 169 | my $self = shift; 170 | my $dt = shift; 171 | 172 | # Straight from the Open Group asctime() docs. 173 | return sprintf "%.3s %.3s%3d %.2d:%.2d:%.2d %d", 174 | $dt->day_abbr, 175 | $dt->month_abbr, 176 | $dt->mday, 177 | $dt->hour, 178 | $dt->min, 179 | $dt->sec, 180 | $dt->year, 181 | ; 182 | } 183 | } 184 | 185 | 186 | 1; 187 | -------------------------------------------------------------------------------- /lib/perl5i/0/HASH.pm: -------------------------------------------------------------------------------- 1 | # vi: set ts=4 sw=4 ht=4 et : 2 | package perl5i::0::HASH; 3 | use 5.010; 4 | 5 | use strict; 6 | use warnings; 7 | use Carp; 8 | 9 | sub HASH::flip { 10 | croak "Can't flip hash with references as values" 11 | if grep { ref } values %{$_[0]}; 12 | 13 | my %flipped = reverse %{$_[0]}; 14 | 15 | return wantarray ? %flipped : \%flipped; 16 | } 17 | 18 | sub HASH::merge { 19 | require Hash::Merge::Simple; 20 | my $merged = Hash::Merge::Simple::merge(@_); 21 | 22 | return wantarray ? %$merged : $merged; 23 | } 24 | 25 | 1; 26 | -------------------------------------------------------------------------------- /lib/perl5i/0/Meta.pm: -------------------------------------------------------------------------------- 1 | package perl5i::0::Meta; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # Be very careful not to import anything. 7 | require Carp; 8 | require mro; 9 | 10 | require perl5i::0::Meta::Instance; 11 | require perl5i::0::Meta::Class; 12 | 13 | sub UNIVERSAL::mo { 14 | return perl5i::0::Meta->new($_[0]); 15 | } 16 | 17 | sub new { 18 | my($class, $thing) = @_; 19 | return bless \$thing, ref $thing ? "perl5i::0::Meta::Instance" : "perl5i::0::Meta::Class"; 20 | } 21 | 22 | sub ISA { 23 | my $class = $_[0]->class; 24 | 25 | no strict 'refs'; 26 | return @{$class.'::ISA'}; 27 | } 28 | 29 | sub linear_isa { 30 | my $self = shift; 31 | my $class = $self->class; 32 | 33 | # get_linear_isa() does not return UNIVERSAL 34 | my @extra; 35 | @extra = qw(UNIVERSAL) unless $class eq 'UNIVERSAL'; 36 | 37 | return @{mro::get_linear_isa($class)}, @extra; 38 | } 39 | 40 | 41 | # A single place to put the "method not found" error. 42 | my $method_not_found = sub { 43 | my $class = shift; 44 | my $method = shift; 45 | 46 | Carp::croak sprintf q[Can't locate object method "%s" via package "%s"], 47 | $method, $class; 48 | }; 49 | 50 | 51 | # caller() will return if its inside an eval, need to skip over those. 52 | my $find_method = sub { 53 | my $method; 54 | my $height = 2; 55 | do { 56 | $method = (caller($height))[3]; 57 | $height++; 58 | } until( !defined $method or $method ne '(eval)' ); 59 | 60 | return $method; 61 | }; 62 | 63 | 64 | sub super { 65 | my $self = shift; 66 | my $class = $self->class; 67 | 68 | my $fq_method = $find_method->(); 69 | Carp::croak "super() called outside a method" unless $fq_method; 70 | 71 | my($parent, $method) = $fq_method =~ /^(.*)::(\w+)$/; 72 | 73 | Carp::croak sprintf qq["%s" is not a parent class of "%s"], $parent, $class 74 | unless $class->isa($parent); 75 | 76 | my @isa = $self->linear_isa(); 77 | 78 | while(@isa) { 79 | my $class = shift @isa; 80 | last if $class eq $parent; 81 | } 82 | 83 | for (@isa) { 84 | my $code = $_->can($method); 85 | @_ = ($$self, @_); 86 | goto &$code if $code; 87 | } 88 | 89 | $class->$method_not_found($method); 90 | } 91 | 92 | 1; 93 | -------------------------------------------------------------------------------- /lib/perl5i/0/Meta/Class.pm: -------------------------------------------------------------------------------- 1 | package perl5i::0::Meta::Class; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent qw(perl5i::0::Meta); 7 | 8 | sub class { 9 | return ${$_[0]}; 10 | } 11 | 12 | sub reftype { 13 | return; 14 | } 15 | 16 | 1; 17 | -------------------------------------------------------------------------------- /lib/perl5i/0/Meta/Instance.pm: -------------------------------------------------------------------------------- 1 | package perl5i::0::Meta::Instance; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | require Scalar::Util; 7 | require overload; 8 | require Carp; 9 | 10 | use parent qw(perl5i::0::Meta); 11 | 12 | sub class { 13 | return ref ${$_[0]}; 14 | } 15 | 16 | sub reftype { 17 | return Scalar::Util::reftype(${$_[0]}); 18 | } 19 | 20 | 21 | # Only instances can be tainted 22 | 23 | # Returns the code which will run when the object is used as a string 24 | my $has_string_overload = sub { 25 | return overload::Method(${$_[0]}, q[""]) || overload::Method(${$_[0]}, q[0+]) 26 | }; 27 | 28 | sub is_tainted { 29 | my $code; 30 | 31 | if( $code = $_[0]->$has_string_overload ) { 32 | require Taint::Util; 33 | return Taint::Util::tainted( $code->(${$_[0]}) ); 34 | } 35 | else { 36 | return 0; 37 | } 38 | 39 | die "Never should be reached"; 40 | } 41 | 42 | 43 | sub taint { 44 | if( $_[0]->$has_string_overload ) { 45 | Carp::croak "Untainted overloaded objects cannot normally be made tainted" if 46 | !$_[0]->is_tainted; 47 | return 1; 48 | } 49 | else { 50 | Carp::croak "Only scalars can normally be made tainted"; 51 | } 52 | 53 | Carp::confess "Should not be reached"; 54 | } 55 | 56 | 57 | sub untaint { 58 | if( $_[0]->$has_string_overload && $_[0]->is_tainted ) { 59 | Carp::croak "Tainted overloaded objects cannot normally be untainted"; 60 | } 61 | else { 62 | return 1; 63 | } 64 | 65 | Carp::confess "Should never be reached"; 66 | } 67 | 68 | 1; 69 | -------------------------------------------------------------------------------- /lib/perl5i/0/SCALAR.pm: -------------------------------------------------------------------------------- 1 | # vi: set ts=4 sw=4 ht=4 et : 2 | package perl5i::0::SCALAR; 3 | use 5.010; 4 | 5 | use strict; 6 | use warnings; 7 | use Carp; 8 | use autobox; 9 | 10 | sub SCALAR::title_case { 11 | my ($string) = @_; 12 | $string =~ s/\b(\w)/\U$1/g; 13 | return $string; 14 | } 15 | 16 | 17 | sub SCALAR::center { 18 | my ($string, $size, $char) = @_; 19 | carp "Use of uninitialized value for size in center()" if !defined $size; 20 | $size //= 0; 21 | $char //= ' '; 22 | 23 | if (length $char > 1) { 24 | my $bad = $char; 25 | $char = substr $char, 0, 1; 26 | carp "'$bad' is longer than one character, using '$char' instead"; 27 | } 28 | 29 | my $len = length $string; 30 | 31 | return $string if $size <= $len; 32 | 33 | my $padlen = $size - $len; 34 | 35 | # pad right with half the remaining characters 36 | my $rpad = int( $padlen / 2 ); 37 | 38 | # bias the left padding to one more space, if $size - $len is odd 39 | my $lpad = $padlen - $rpad; 40 | 41 | return $char x $lpad . $string . $char x $rpad; 42 | } 43 | 44 | 45 | sub SCALAR::ltrim { 46 | my ($string,$trim_charset) = @_; 47 | $trim_charset = '\s' unless defined $trim_charset; 48 | my $re = qr/^[$trim_charset]*/; 49 | $string =~ s/$re//; 50 | return $string; 51 | } 52 | 53 | 54 | sub SCALAR::rtrim { 55 | my ($string,$trim_charset) = @_; 56 | $trim_charset = '\s' unless defined $trim_charset; 57 | my $re = qr/[$trim_charset]*$/; 58 | $string =~ s/$re//; 59 | return $string; 60 | } 61 | 62 | 63 | sub SCALAR::trim { 64 | my $charset = $_[1]; 65 | 66 | return SCALAR::rtrim(SCALAR::ltrim($_[0], $charset), $charset); 67 | } 68 | 69 | 70 | sub SCALAR::wrap { 71 | my ($string, %args) = @_; 72 | 73 | my $width = $args{width} // 76; 74 | my $separator = $args{separator} // "\n"; 75 | 76 | return $string if $width <= 0; 77 | 78 | require Text::Wrap; 79 | local $Text::Wrap::separator = $separator; 80 | local $Text::Wrap::columns = $width; 81 | 82 | return Text::Wrap::wrap('', '', $string); 83 | 84 | } 85 | 86 | 87 | # untaint the scalar itself, not the reference 88 | sub SCALAR::untaint { 89 | return $_[0]->mo->untaint if ref $_[0]; 90 | 91 | require Taint::Util; 92 | Taint::Util::untaint($_[0]); 93 | return 1; 94 | } 95 | 96 | 97 | # untaint the scalar itself, not the reference 98 | sub SCALAR::taint { 99 | return $_[0]->mo->taint if ref $_[0]; 100 | 101 | require Taint::Util; 102 | Taint::Util::taint($_[0]); 103 | return 1; 104 | } 105 | 106 | # Could use the version in Meta but this removes the need to check 107 | # for overloading. 108 | sub SCALAR::is_tainted { 109 | require Taint::Util; 110 | return ref $_[0] ? Taint::Util::tainted(${$_[0]}) : Taint::Util::tainted($_[0]); 111 | } 112 | 113 | 114 | sub SCALAR::load { 115 | require Module::Load; 116 | goto &Module::Load::load; 117 | } 118 | 119 | 120 | sub SCALAR::alias { 121 | croak <is_number && $_[0] > 0 } 143 | sub SCALAR::is_negative { $_[0]->is_number && $_[0] < 0 } 144 | sub SCALAR::is_integer { $_[0]->is_number && ((int($_[0]) - $_[0]) == 0) } 145 | *SCALAR::is_int = \&SCALAR::is_integer; 146 | sub SCALAR::is_decimal { $_[0]->is_number && ((int($_[0]) - $_[0]) != 0) } 147 | 148 | 1; 149 | -------------------------------------------------------------------------------- /lib/perl5i/1.pm: -------------------------------------------------------------------------------- 1 | # vi: set ts=4 sw=4 ht=4 et : 2 | package perl5i::1; 3 | 4 | use 5.010; 5 | 6 | use strict; 7 | use warnings; 8 | use Module::Load; 9 | use IO::Handle; 10 | use Carp; 11 | use perl5i::1::DateTime; 12 | use Want; 13 | use Try::Tiny; 14 | use perl5i::1::Meta; 15 | use Encode (); 16 | use perl5i::1::autobox; 17 | 18 | use perl5i::VERSION; our $VERSION = perl5i::VERSION->VERSION; 19 | 20 | our $Latest = 'perl5i::1'; 21 | 22 | 23 | # This works around their lexical nature. 24 | use parent 'autodie'; 25 | use parent 'perl5i::1::autobox'; 26 | use parent 'autovivification'; 27 | use parent 'utf8'; 28 | use parent 'open'; 29 | 30 | ## no critic (Subroutines::RequireArgUnpacking) 31 | sub import { 32 | my $class = shift; 33 | 34 | require File::stat; 35 | 36 | require Modern::Perl; 37 | Modern::Perl->import; 38 | 39 | my $caller = caller; 40 | 41 | # Modern::Perl won't pass this through to our caller. 42 | require mro; 43 | mro::set_mro( $caller, 'c3' ); 44 | 45 | load_in_caller( $caller => ( 46 | ["CLASS"], ["File::chdir"], 47 | [English => qw(-no_match_vars)], 48 | ["Want" => qw(want)], ["Try::Tiny"], ["Perl6::Caller"], ["Carp"] 49 | ) ); 50 | 51 | # Have to call both or it won't work. 52 | perl5i::1::autobox::import($class); 53 | autovivification::unimport($class); 54 | utf8::import($class); 55 | 56 | open::import($class, ":encoding(utf8)"); 57 | open::import($class, ":std"); 58 | 59 | # Export our gmtime() and localtime() 60 | (\&{$Latest .'::DateTime::dt_gmtime'})->alias($caller, 'gmtime'); 61 | (\&{$Latest .'::DateTime::dt_localtime'})->alias($caller, 'localtime'); 62 | (\&{$Latest .'::DateTime::dt_time'})->alias($caller, 'time'); 63 | (\&stat)->alias( $caller, 'stat' ); 64 | (\&lstat)->alias( $caller, 'lstat' ); 65 | (\&utf8_open)->alias($caller, 'open'); 66 | 67 | # fix die so that it always returns 255 68 | *CORE::GLOBAL::die = sub { 69 | # Leave a single ref be 70 | local $! = 255; 71 | return CORE::die(@_) if @_ == 1 and ref $_[0]; 72 | 73 | my $error = join '', @_; 74 | unless ($error =~ /\n$/) { 75 | my ($file, $line) = (caller)[1,2]; 76 | $error .= " at $file line $line.\n"; 77 | } 78 | 79 | local $! = 255; 80 | return CORE::die($error); 81 | }; 82 | 83 | 84 | # utf8ify @ARGV 85 | $_ = Encode::decode('utf8', $_) for @ARGV; 86 | 87 | 88 | $^H{perl5i} = 1; 89 | 90 | # autodie needs a bit more convincing 91 | @_ = ( $class, ":all" ); 92 | goto &autodie::import; 93 | } 94 | 95 | sub unimport { $^H{perl5i} = 0 } 96 | 97 | sub utf8_open(*;$@) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) 98 | my $ret; 99 | if( @_ == 1 ) { 100 | $ret = CORE::open $_[0]; 101 | } 102 | else { 103 | $ret = CORE::open $_[0], $_[1], @_[2..$#_]; 104 | } 105 | 106 | # Don't try to binmode an unopened filehandle 107 | return $ret unless $ret; 108 | 109 | my $h = (caller 1)[10]; 110 | binmode $_[0], ":encoding(utf8)" if $h->{perl5i}; 111 | return $ret; 112 | } 113 | 114 | 115 | sub load_in_caller { 116 | my $caller = shift; 117 | my @modules = @_; 118 | 119 | for my $spec (@modules) { 120 | my( $module, @args ) = @$spec; 121 | 122 | load($module); 123 | ## no critic (BuiltinFunctions::ProhibitStringyEval) 124 | eval qq{ 125 | package $caller; 126 | \$module->import(\@args); 127 | 1; 128 | } or die "Error while perl5i loaded $module => @args: $@"; 129 | } 130 | 131 | return; 132 | } 133 | 134 | 135 | # File::stat does not play nice in list context 136 | sub stat { 137 | return CORE::stat(@_) if wantarray; 138 | return File::stat::stat(@_); 139 | } 140 | 141 | sub lstat { 142 | return CORE::lstat(@_) if wantarray; 143 | return File::stat::lstat(@_); 144 | } 145 | 146 | 1; 147 | 148 | -------------------------------------------------------------------------------- /lib/perl5i/1/CODE.pm: -------------------------------------------------------------------------------- 1 | package perl5i::1::CODE; 2 | use strict; 3 | use warnings; 4 | 5 | 1; 6 | -------------------------------------------------------------------------------- /lib/perl5i/1/HASH.pm: -------------------------------------------------------------------------------- 1 | # vi: set ts=4 sw=4 ht=4 et : 2 | package perl5i::1::HASH; 3 | use 5.010; 4 | 5 | use strict; 6 | use warnings; 7 | require Carp; 8 | 9 | sub flip { 10 | Carp::croak("Can't flip hash with references as values") 11 | if grep { ref } values %{$_[0]}; 12 | 13 | my %flipped = reverse %{$_[0]}; 14 | 15 | return wantarray ? %flipped : \%flipped; 16 | } 17 | 18 | sub merge { 19 | require Hash::Merge::Simple; 20 | my $merged = Hash::Merge::Simple::merge(@_); 21 | 22 | return wantarray ? %$merged : $merged; 23 | } 24 | 25 | sub print { 26 | my $hash = shift; 27 | print join(" ", map { "$_ => $hash->{$_}" } keys %$hash); 28 | } 29 | 30 | sub say { 31 | my $hash = shift; 32 | print join(" ", map { "$_ => $hash->{$_}" } keys %$hash), "\n"; 33 | } 34 | 35 | 1; 36 | -------------------------------------------------------------------------------- /lib/perl5i/1/Meta.pm: -------------------------------------------------------------------------------- 1 | package perl5i::1::Meta; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # Be very careful not to import anything. 7 | require Carp; 8 | require mro; 9 | 10 | require perl5i::1::Meta::Instance; 11 | require perl5i::1::Meta::Class; 12 | 13 | sub UNIVERSAL::mo { 14 | return perl5i::1::Meta->new($_[0]); 15 | } 16 | 17 | sub new { 18 | my($class, $thing) = @_; 19 | return bless \$thing, ref $thing ? "perl5i::1::Meta::Instance" : "perl5i::1::Meta::Class"; 20 | } 21 | 22 | sub ISA { 23 | my $class = $_[0]->class; 24 | 25 | no strict 'refs'; 26 | return @{$class.'::ISA'}; 27 | } 28 | 29 | sub linear_isa { 30 | my $self = shift; 31 | my $class = $self->class; 32 | 33 | # get_linear_isa() does not return UNIVERSAL 34 | my @extra; 35 | @extra = qw(UNIVERSAL) unless $class eq 'UNIVERSAL'; 36 | 37 | return @{mro::get_linear_isa($class)}, @extra; 38 | } 39 | 40 | 41 | # A single place to put the "method not found" error. 42 | my $method_not_found = sub { 43 | my $class = shift; 44 | my $method = shift; 45 | 46 | Carp::croak sprintf q[Can't locate object method "%s" via package "%s"], 47 | $method, $class; 48 | }; 49 | 50 | 51 | # caller() will return if its inside an eval, need to skip over those. 52 | my $find_method = sub { 53 | my $method; 54 | my $height = 2; 55 | do { 56 | $method = (caller($height))[3]; 57 | $height++; 58 | } until( !defined $method or $method ne '(eval)' ); 59 | 60 | return $method; 61 | }; 62 | 63 | 64 | sub super { 65 | my $self = shift; 66 | my $class = $self->class; 67 | 68 | my $fq_method = $find_method->(); 69 | Carp::croak "super() called outside a method" unless $fq_method; 70 | 71 | my($parent, $method) = $fq_method =~ /^(.*)::(\w+)$/; 72 | 73 | Carp::croak sprintf qq["%s" is not a parent class of "%s"], $parent, $class 74 | unless $class->isa($parent); 75 | 76 | my @isa = $self->linear_isa(); 77 | 78 | while(@isa) { 79 | my $class = shift @isa; 80 | last if $class eq $parent; 81 | } 82 | 83 | for (@isa) { 84 | my $code = $_->can($method); 85 | @_ = ($$self, @_); 86 | goto &$code if $code; 87 | } 88 | 89 | $class->$method_not_found($method); 90 | } 91 | 92 | 1; 93 | -------------------------------------------------------------------------------- /lib/perl5i/1/Meta/Class.pm: -------------------------------------------------------------------------------- 1 | package perl5i::1::Meta::Class; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent qw(perl5i::1::Meta); 7 | 8 | sub class { 9 | return ${$_[0]}; 10 | } 11 | 12 | sub reftype { 13 | return; 14 | } 15 | 16 | 1; 17 | -------------------------------------------------------------------------------- /lib/perl5i/1/Meta/Instance.pm: -------------------------------------------------------------------------------- 1 | package perl5i::1::Meta::Instance; 2 | 3 | use strict; 4 | use warnings; 5 | no if $] > 5.018000, warnings => 'experimental::smartmatch'; 6 | 7 | require Scalar::Util; 8 | require overload; 9 | require Carp; 10 | 11 | use perl5i::1::autobox; 12 | 13 | use parent qw(perl5i::1::Meta); 14 | 15 | sub class { 16 | return ref ${$_[0]}; 17 | } 18 | 19 | sub reftype { 20 | return Scalar::Util::reftype(${$_[0]}); 21 | } 22 | 23 | 24 | # Only instances can be tainted 25 | 26 | # Returns the code which will run when the object is used as a string 27 | my $has_string_overload = sub { 28 | return overload::Method(${$_[0]}, q[""]) || overload::Method(${$_[0]}, q[0+]) 29 | }; 30 | 31 | sub is_tainted { 32 | my $code; 33 | 34 | if( $code = $_[0]->$has_string_overload ) { 35 | require Taint::Util; 36 | return Taint::Util::tainted( $code->(${$_[0]}) ); 37 | } 38 | else { 39 | return 0; 40 | } 41 | 42 | die "Never should be reached"; 43 | } 44 | 45 | 46 | sub taint { 47 | if( $_[0]->$has_string_overload ) { 48 | Carp::croak "Untainted overloaded objects cannot normally be made tainted" if 49 | !$_[0]->is_tainted; 50 | return 1; 51 | } 52 | else { 53 | Carp::croak "Only scalars can normally be made tainted"; 54 | } 55 | 56 | Carp::confess "Should not be reached"; 57 | } 58 | 59 | 60 | sub untaint { 61 | if( $_[0]->$has_string_overload && $_[0]->is_tainted ) { 62 | Carp::croak "Tainted overloaded objects cannot normally be untainted"; 63 | } 64 | else { 65 | return 1; 66 | } 67 | 68 | Carp::confess "Should never be reached"; 69 | } 70 | 71 | 72 | sub checksum { 73 | my( $thing, %args ) = @_; 74 | 75 | my $algorithms = [qw(sha1 md5)]; 76 | $args{algorithm} //= 'sha1'; 77 | $args{algorithm} ~~ $algorithms or 78 | Carp::croak("algorithm must be @{[ $algorithms->join(' or ' ) ]}"); 79 | 80 | my $algorithm2module = { sha1 => "Digest::SHA", md5 => "Digest::MD5" }; 81 | 82 | my $format = [qw(hex base64 binary)]; 83 | $args{format} //= 'hex'; 84 | $args{format} ~~ $format or 85 | Carp::croak("format must be @{[ $format->join(' or ') ]}"); 86 | 87 | my %prefix = ( hex => 'hex', base64 => 'b64', binary => undef ); 88 | 89 | my $module = $algorithm2module->{ $args{algorithm} }; 90 | my $digest = defined $prefix{ $args{format} } ? $prefix{ $args{format} } . 'digest' : 'digest'; 91 | 92 | Module::Load::load($module); 93 | my $digestor = $module->new; 94 | 95 | require Data::Dumper; 96 | 97 | my $d = Data::Dumper->new( [ ${$thing} ] ); 98 | $d->Deparse(1)->Terse(1)->Sortkeys(1)->Indent(0); 99 | 100 | $digestor->add( $d->Dump ); 101 | return $digestor->$digest; 102 | } 103 | 104 | 1; 105 | -------------------------------------------------------------------------------- /lib/perl5i/1/SCALAR.pm: -------------------------------------------------------------------------------- 1 | # vi: set ts=4 sw=4 ht=4 et : 2 | package perl5i::1::SCALAR; 3 | use 5.010; 4 | 5 | use strict; 6 | use warnings; 7 | require Carp; 8 | use autobox; 9 | use perl5i::1::autobox; 10 | 11 | sub title_case { 12 | my ($string) = @_; 13 | $string =~ s/\b(\w)/\U$1/g; 14 | return $string; 15 | } 16 | 17 | 18 | sub center { 19 | my ($string, $size, $char) = @_; 20 | Carp::carp("Use of uninitialized value for size in center()") if !defined $size; 21 | $size //= 0; 22 | $char //= ' '; 23 | 24 | if (length $char > 1) { 25 | my $bad = $char; 26 | $char = substr $char, 0, 1; 27 | Carp::carp("'$bad' is longer than one character, using '$char' instead"); 28 | } 29 | 30 | my $len = length $string; 31 | 32 | return $string if $size <= $len; 33 | 34 | my $padlen = $size - $len; 35 | 36 | # pad right with half the remaining characters 37 | my $rpad = int( $padlen / 2 ); 38 | 39 | # bias the left padding to one more space, if $size - $len is odd 40 | my $lpad = $padlen - $rpad; 41 | 42 | return $char x $lpad . $string . $char x $rpad; 43 | } 44 | 45 | 46 | sub ltrim { 47 | my ($string,$trim_charset) = @_; 48 | $trim_charset = '\s' unless defined $trim_charset; 49 | my $re = qr/^[$trim_charset]*/; 50 | $string =~ s/$re//; 51 | return $string; 52 | } 53 | 54 | 55 | sub rtrim { 56 | my ($string,$trim_charset) = @_; 57 | $trim_charset = '\s' unless defined $trim_charset; 58 | my $re = qr/[$trim_charset]*$/; 59 | $string =~ s/$re//; 60 | return $string; 61 | } 62 | 63 | 64 | sub trim { 65 | my $charset = $_[1]; 66 | 67 | return rtrim(ltrim($_[0], $charset), $charset); 68 | } 69 | 70 | 71 | sub wrap { 72 | my ($string, %args) = @_; 73 | 74 | my $width = $args{width} // 76; 75 | my $separator = $args{separator} // "\n"; 76 | 77 | return $string if $width <= 0; 78 | 79 | require Text::Wrap; 80 | local $Text::Wrap::separator = $separator; 81 | local $Text::Wrap::columns = $width; 82 | 83 | return Text::Wrap::wrap('', '', $string); 84 | 85 | } 86 | 87 | 88 | # untaint the scalar itself, not the reference 89 | sub untaint { 90 | return $_[0]->mo->untaint if ref $_[0]; 91 | 92 | require Taint::Util; 93 | Taint::Util::untaint($_[0]); 94 | return 1; 95 | } 96 | 97 | 98 | # untaint the scalar itself, not the reference 99 | sub taint { 100 | return $_[0]->mo->taint if ref $_[0]; 101 | 102 | require Taint::Util; 103 | Taint::Util::taint($_[0]); 104 | return 1; 105 | } 106 | 107 | # Could use the version in Meta but this removes the need to check 108 | # for overloading. 109 | sub is_tainted { 110 | require Taint::Util; 111 | return ref $_[0] ? Taint::Util::tainted(${$_[0]}) : Taint::Util::tainted($_[0]); 112 | } 113 | 114 | 115 | sub load { 116 | require Module::Load; 117 | goto &Module::Load::load; 118 | } 119 | 120 | 121 | sub alias { 122 | Carp::croak(<is_number && $_[0] > 0 } 144 | sub is_negative { $_[0]->is_number && $_[0] < 0 } 145 | sub is_integer { $_[0]->is_number && ((int($_[0]) - $_[0]) == 0) } 146 | *is_int = \&is_integer; 147 | sub is_decimal { $_[0]->is_number && ((int($_[0]) - $_[0]) != 0) } 148 | 149 | 150 | sub path2module { 151 | my $path = shift; 152 | 153 | my($vol, $dirs, $file) = File::Spec->splitpath($path); 154 | my @dirs = grep length, File::Spec->splitdir($dirs); 155 | 156 | Carp::croak("'$path' does not look like a Perl module path") 157 | if $file !~ m{\.pm$} or File::Spec->file_name_is_absolute($path); 158 | 159 | $file =~ s{\.pm$}{}; 160 | 161 | return join "::", @dirs, $file; 162 | } 163 | 164 | 165 | sub module2path { 166 | my $module = shift; 167 | 168 | my @parts = split /::/, $module; 169 | $parts[-1] .= ".pm"; 170 | 171 | return join "/", @parts; 172 | } 173 | 174 | 1; 175 | -------------------------------------------------------------------------------- /lib/perl5i/1/UNIVERSAL.pm: -------------------------------------------------------------------------------- 1 | package perl5i::1::UNIVERSAL; 2 | 3 | # Methods which apply to all autoboxed objects 4 | 5 | use strict; 6 | use warnings; 7 | 8 | require Carp; 9 | 10 | sub alias { 11 | my $self = shift; 12 | 13 | Carp::croak("Not enough arguments given to alias()") unless @_; 14 | 15 | my @name = @_; 16 | unshift @name, (caller)[0] unless @name > 1 or grep /::/, @name; 17 | 18 | my $name = join "::", @name; 19 | 20 | no strict 'refs'; 21 | *{$name} = $self; 22 | return 1; 23 | } 24 | 25 | sub is_number { return } 26 | sub is_positive { return } 27 | sub is_negative { return } 28 | sub is_int { return } 29 | sub is_integer { return } 30 | sub is_decimal { return } 31 | 32 | 1; 33 | -------------------------------------------------------------------------------- /lib/perl5i/1/autobox.pm: -------------------------------------------------------------------------------- 1 | package perl5i::1::autobox; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # Load these after we're fully compiled because they 7 | # use us internally. 8 | require perl5i::1::SCALAR; 9 | require perl5i::1::ARRAY; 10 | require perl5i::1::HASH; 11 | require perl5i::1::UNIVERSAL; 12 | require perl5i::1::CODE; 13 | 14 | # List::Util needs to be before Core to get the C version of sum 15 | use parent 'autobox::List::Util'; 16 | use parent 'autobox::Core'; 17 | use parent 'autobox::dump'; 18 | 19 | sub import { 20 | my $class = shift; 21 | $class->autobox::import(); 22 | $class->autobox::import( 23 | UNIVERSAL => 'perl5i::1::UNIVERSAL', 24 | DEFAULT => 'perl5i::1::' 25 | ); 26 | autobox::List::Util::import($class); 27 | autobox::Core::import($class); 28 | autobox::dump::import($class); 29 | } 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /lib/perl5i/2/CODE.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::CODE; 2 | use 5.010; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | # Can't use signatures here, Signatures needs CODE. 8 | 9 | use Hash::FieldHash qw(fieldhashes); 10 | fieldhashes \my(%Signatures); 11 | 12 | sub __set_signature { 13 | $Signatures{$_[0]} = $_[1]; 14 | } 15 | 16 | sub signature { 17 | return $Signatures{$_[0]}; 18 | } 19 | 20 | 1; 21 | -------------------------------------------------------------------------------- /lib/perl5i/2/HASH.pm: -------------------------------------------------------------------------------- 1 | # vi: set ts=4 sw=4 ht=4 et : 2 | package perl5i::2::HASH; 3 | use 5.010; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | # Don't accidentally turn carp/croak into methods. 9 | require Carp::Fix::1_25; 10 | require Hash::StoredIterator; 11 | 12 | use perl5i::2::Signatures; 13 | 14 | method each($callback) { 15 | return Hash::StoredIterator::hmap( $callback, $self ); 16 | } 17 | 18 | sub flip { 19 | Carp::Fix::1_25::croak("Can't flip hash with references as values") 20 | if grep { ref } values %{$_[0]}; 21 | 22 | my %flipped = reverse %{$_[0]}; 23 | 24 | return wantarray ? %flipped : \%flipped; 25 | } 26 | 27 | sub merge { 28 | require Hash::Merge::Simple; 29 | my $merged = Hash::Merge::Simple::merge(@_); 30 | 31 | return wantarray ? %$merged : $merged; 32 | } 33 | 34 | sub print { 35 | my $hash = shift; 36 | print join(" ", map { "$_ => $hash->{$_}" } keys %$hash); 37 | } 38 | 39 | sub say { 40 | my $hash = shift; 41 | print join(" ", map { "$_ => $hash->{$_}" } keys %$hash), "\n"; 42 | } 43 | 44 | my $common = sub { 45 | # Return all things in first array that are also present in second. 46 | my ($c, $d) = @_; 47 | 48 | no warnings 'uninitialized'; 49 | my %seen = map { $_ => 1 } @$d; 50 | 51 | my @common = grep { $seen{$_} } @$c; 52 | 53 | return \@common; 54 | }; 55 | 56 | sub diff { 57 | my ($base, @rest) = @_; 58 | unless (@rest) { 59 | return wantarray ? %$base : $base; 60 | } 61 | 62 | die "Arguments must be hash references" if grep { ref $_ ne 'HASH' } @rest; 63 | 64 | # make a copy so that we can delete kv pairs without modifying the 65 | # original hashref. 66 | my %base = %$base; 67 | 68 | require perl5i::2::equal; 69 | 70 | foreach my $hash (@rest) { 71 | 72 | my $common_keys = $common->( [ keys %$base ], [ keys %$hash ] ); 73 | 74 | next unless @$common_keys; 75 | 76 | # Keys are equal, are values also equal? 77 | foreach my $key (@$common_keys) { 78 | delete $base{$key} if perl5i::2::equal::are_equal( $base->{$key}, $hash->{$key} ); 79 | } 80 | 81 | } 82 | 83 | return wantarray ? %base : \%base; 84 | } 85 | 86 | my $different = sub { 87 | # Return all things in first array that are not present in second. 88 | my ($c, $d) = @_; 89 | 90 | no warnings 'uninitialized'; 91 | my %seen = map { $_ => 1 } @$d; 92 | 93 | my @different = grep { not $seen{$_} } @$c; 94 | 95 | return \@different; 96 | }; 97 | 98 | sub intersect { 99 | my ($base, @rest) = @_; 100 | 101 | unless (@rest) { 102 | return wantarray ? %$base : $base; 103 | } 104 | 105 | die "Arguments must be hash references" if grep { ref $_ ne 'HASH' } @rest; 106 | 107 | # make a copy so that we can delete kv pairs without modifying the 108 | # original hashref. 109 | my %base = %$base; 110 | 111 | require perl5i::2::equal; 112 | 113 | foreach my $hash (@rest) { 114 | 115 | my $different_keys = $different->( [ keys %$base ], [ keys %$hash ] ); 116 | 117 | delete @base{@$different_keys}; 118 | 119 | return wantarray ? () : {} unless %base; 120 | 121 | my $common_keys = $common->( [ keys %$base ], [ keys %$hash ] ); 122 | 123 | # Keys are equal, are values also equal? 124 | foreach my $key (@$common_keys) { 125 | delete $base{$key} unless perl5i::2::equal::are_equal( $base->{$key}, $hash->{$key} ); 126 | } 127 | 128 | } 129 | 130 | return wantarray ? %base : \%base; 131 | } 132 | 133 | 1; 134 | -------------------------------------------------------------------------------- /lib/perl5i/2/Meta.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::Meta; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.010_000; 6 | 7 | # Be very careful not to import anything. 8 | require Carp::Fix::1_25; 9 | require mro; 10 | 11 | require perl5i::2::Meta::Instance; 12 | require perl5i::2::Meta::Class; 13 | use perl5i::2::autobox; 14 | 15 | sub UNIVERSAL::mo { 16 | # Be careful to pass through an alias, not a copy 17 | return perl5i::2::Meta::Instance->new($_[0]); 18 | } 19 | 20 | sub UNIVERSAL::mc { 21 | return perl5i::2::Meta::Class->new($_[0]); 22 | } 23 | 24 | sub new { 25 | my $class = shift; 26 | # Be careful to take a reference to an alias, not a copy 27 | return bless \\$_[0], $class; 28 | } 29 | 30 | sub ISA { 31 | my $class = $_[0]->class; 32 | 33 | no strict 'refs'; 34 | return wantarray ? @{$class.'::ISA'} : \@{$class.'::ISA'}; 35 | } 36 | 37 | sub linear_isa { 38 | my $self = shift; 39 | my $class = $self->class; 40 | 41 | # get_linear_isa() does not return UNIVERSAL 42 | my @extra; 43 | @extra = qw(UNIVERSAL) unless $class eq 'UNIVERSAL'; 44 | 45 | my $isa = [@{mro::get_linear_isa($class)}, @extra]; 46 | return wantarray ? @$isa : $isa; 47 | } 48 | 49 | sub methods { 50 | my $self = shift; 51 | my $opts = shift // {}; 52 | my $top = $self->class; 53 | 54 | my %exclude; 55 | 56 | state $defaults = { 57 | with_UNIVERSAL => 0, 58 | just_mine => 0, 59 | }; 60 | 61 | $opts = { %$defaults, %$opts }; 62 | $exclude{UNIVERSAL} = !$opts->{with_UNIVERSAL}; 63 | 64 | my @classes = $opts->{just_mine} ? $self->class : $self->linear_isa; 65 | 66 | my %all_methods; 67 | for my $class (@classes) { 68 | next if $exclude{$class} && $class ne $top; 69 | 70 | my $sym_table = $class->mc->symbol_table; 71 | for my $name (keys %$sym_table) { 72 | my $glob = $sym_table->{$name}; 73 | next unless ref \$glob eq "GLOB"; 74 | next unless my $code = *{$glob}{CODE}; 75 | my $sig = $code->signature; 76 | next if $sig and !$sig->is_method; 77 | $all_methods{$name} = $class; 78 | } 79 | } 80 | 81 | return wantarray ? keys %all_methods : [keys %all_methods]; 82 | } 83 | 84 | sub symbol_table { 85 | my $self = shift; 86 | my $class = $self->class; 87 | 88 | no strict 'refs'; 89 | return \%{$class.'::'}; 90 | } 91 | 92 | # A single place to put the "method not found" error. 93 | my $method_not_found = sub { 94 | my $class = shift; 95 | my $method = shift; 96 | 97 | Carp::Fix::1_25::croak( 98 | sprintf q[Can't locate object method "%s" via package "%s"], 99 | $method, $class 100 | ); 101 | }; 102 | 103 | 104 | # caller() will return if its inside an eval, need to skip over those. 105 | my $find_method = sub { 106 | my $method; 107 | my $height = 2; 108 | do { 109 | $method = (caller($height))[3]; 110 | $height++; 111 | } until( !defined $method or $method ne '(eval)' ); 112 | 113 | return $method; 114 | }; 115 | 116 | 117 | sub super { 118 | my $self = shift; 119 | my $class = $self->class; 120 | 121 | my $fq_method = $find_method->(); 122 | Carp::Fix::1_25::croak("super() called outside a method") unless $fq_method; 123 | 124 | my($parent, $method) = $fq_method =~ /^(.*)::(\w+)$/; 125 | 126 | Carp::Fix::1_25::croak( 127 | sprintf qq["%s" is not a parent class of "%s"], 128 | $parent, $class 129 | ) unless $class->isa($parent); 130 | 131 | my @isa = $self->linear_isa(); 132 | 133 | while(@isa) { 134 | my $class = shift @isa; 135 | last if $class eq $parent; 136 | } 137 | 138 | for (@isa) { 139 | my $code = $_->can($method); 140 | @_ = ($$$self, @_); 141 | goto &$code if $code; 142 | } 143 | 144 | $class->$method_not_found($method); 145 | } 146 | 147 | 1; 148 | -------------------------------------------------------------------------------- /lib/perl5i/2/Meta/Class.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::Meta::Class; 2 | 3 | # Methods here are for $thing->mc->method. 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use parent qw(perl5i::2::Meta); 9 | 10 | sub class { 11 | return ref ${${$_[0]}} ? ref ${${$_[0]}} : ${${$_[0]}}; 12 | } 13 | 14 | sub reftype { 15 | return; 16 | } 17 | 18 | 1; 19 | -------------------------------------------------------------------------------- /lib/perl5i/2/Meta/Instance.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::Meta::Instance; 2 | 3 | # Methods here are for $thing->mo->method. 4 | 5 | use 5.010_000; 6 | use strict; 7 | use warnings; 8 | no if $] >= 5.018000, warnings => 'experimental::smartmatch'; 9 | 10 | # Don't import anything that might be misinterpreted as a method 11 | require Scalar::Util; 12 | require overload; 13 | require Carp::Fix::1_25; 14 | 15 | use perl5i::2::autobox; 16 | 17 | use parent qw(perl5i::2::Meta); 18 | 19 | sub id { 20 | require Object::ID; 21 | 22 | # Hash::FieldHash cannot handle non-references 23 | return Object::ID::object_id(ref ${${$_[0]}} ? ${${$_[0]}} : ${$_[0]}); 24 | } 25 | 26 | sub class { 27 | return ref ${${$_[0]}}; 28 | } 29 | 30 | sub reftype { 31 | return Scalar::Util::reftype(${${$_[0]}}); 32 | } 33 | 34 | 35 | # Only instances can be tainted 36 | 37 | # Returns the code which will run when the object is used as a string 38 | my $has_string_overload = sub { 39 | return overload::Method(${${$_[0]}}, q[""]) || overload::Method(${${$_[0]}}, q[0+]) 40 | }; 41 | 42 | sub is_tainted { 43 | my $code; 44 | 45 | require Taint::Util; 46 | 47 | if( !ref ${${$_[0]}} ) { 48 | # Its a plain scalar 49 | return Taint::Util::tainted(${${$_[0]}}); 50 | } 51 | elsif( ref ${${$_[0]}} eq 'SCALAR' ) { 52 | # Unblessed scalar 53 | return Taint::Util::tainted(${${$_[0]}}); 54 | } 55 | elsif( $code = $_[0]->$has_string_overload ) { 56 | return Taint::Util::tainted( $code->(${${$_[0]}}) ); 57 | } 58 | else { 59 | return 0; 60 | } 61 | 62 | die "Never should be reached"; 63 | } 64 | 65 | 66 | sub taint { 67 | require Taint::Util; 68 | 69 | if( !ref ${${$_[0]}} ) { 70 | # Its a plain scalar 71 | return Taint::Util::taint(${${$_[0]}}); 72 | } 73 | elsif( $_[0]->$has_string_overload ) { 74 | Carp::Fix::1_25::croak("Untainted overloaded objects cannot normally be made tainted") if 75 | !$_[0]->is_tainted; 76 | return 1; 77 | } 78 | else { 79 | Carp::Fix::1_25::croak("Only scalars can normally be made tainted"); 80 | } 81 | 82 | Carp::Fix::1_25::confess("Should not be reached"); 83 | } 84 | 85 | 86 | sub untaint { 87 | require Taint::Util; 88 | 89 | if( !ref ${${$_[0]}} ) { 90 | # Its a plain scalar 91 | return Taint::Util::untaint(${${$_[0]}}); 92 | } 93 | elsif( $_[0]->$has_string_overload && $_[0]->is_tainted ) { 94 | Carp::Fix::1_25::croak("Tainted overloaded objects cannot normally be untainted"); 95 | } 96 | else { 97 | return 1; 98 | } 99 | 100 | Carp::Fix::1_25::confess("Should never be reached"); 101 | } 102 | 103 | 104 | sub checksum { 105 | my( $thing, %args ) = @_; 106 | 107 | state $algorithms = [qw(sha1 md5)]; 108 | $args{algorithm} //= 'sha1'; 109 | $args{algorithm} ~~ $algorithms or 110 | Carp::Fix::1_25::croak("algorithm must be @{[ $algorithms->join(' or ' ) ]}"); 111 | 112 | state $algorithm2module = { sha1 => "Digest::SHA", md5 => "Digest::MD5" }; 113 | 114 | state $format = [qw(hex base64 binary)]; 115 | $args{format} //= 'hex'; 116 | $args{format} ~~ $format or 117 | Carp::Fix::1_25::croak("format must be @{[ $format->join(' or ') ]}"); 118 | 119 | state $prefix = { hex => 'hex', base64 => 'b64', binary => undef }; 120 | 121 | my $module = $algorithm2module->{ $args{algorithm} }; 122 | my $digest = defined $prefix->{ $args{format} } ? $prefix->{ $args{format} } . 'digest' : 'digest'; 123 | 124 | $module->require; 125 | my $digestor = $module->new; 126 | 127 | require Data::Dumper; 128 | 129 | my $d = Data::Dumper->new( [ ${$thing} ] ); 130 | $d->Deparse(1)->Terse(1)->Sortkeys(1)->Indent(0); 131 | 132 | $digestor->add( $d->Dump ); 133 | return $digestor->$digest; 134 | } 135 | 136 | 137 | sub is_equal { 138 | my ($self, $other) = @_; 139 | require perl5i::2::equal; 140 | 141 | return perl5i::2::equal::are_equal($$$self, $other); 142 | } 143 | 144 | *perl = \&as_perl; 145 | sub as_perl { 146 | require Data::Dumper; 147 | 148 | state $options = [qw(Terse Sortkeys Deparse)]; 149 | 150 | my $self = shift; 151 | my $dumper = Data::Dumper->new([$$$self]); 152 | for my $option (@$options) { 153 | $dumper->$option(1); 154 | } 155 | 156 | $dumper->Indent(1); 157 | 158 | return $dumper->Dump; 159 | } 160 | 161 | 162 | sub dump { 163 | my $self = shift; 164 | my %args = @_; 165 | 166 | my $format = $args{format} // "perl"; 167 | state $dumpers = { 168 | json => "as_json", 169 | yaml => "as_yaml", 170 | perl => "as_perl", 171 | }; 172 | 173 | my $dumper = $dumpers->{$format}; 174 | Carp::Fix::1_25::croak("Unknown format '$format' for dump()") unless $dumper; 175 | 176 | return $self->$dumper(%args); 177 | } 178 | 179 | sub as_json { 180 | require JSON::MaybeXS; 181 | my $json = JSON::MaybeXS->new 182 | ->utf8 183 | ->pretty 184 | ->allow_unknown 185 | ->allow_blessed 186 | ->convert_blessed; 187 | 188 | # JSON doesn't seem to have an easy way to say 189 | # "just dump objects as references please". This is their 190 | # recommended way to do it (yarf). 191 | local *UNIVERSAL::TO_JSON = sub { 192 | require B; 193 | my $b_obj = B::svref_2object( $_[0] ); 194 | return $b_obj->isa('B::HV') ? { %{ $_[0] } } 195 | : $b_obj->isa('B::AV') ? [ @{ $_[0] } ] 196 | : undef 197 | ; 198 | } unless defined &UNIVERSAL::TO_JSON; 199 | 200 | return $json->encode(${${$_[0]}}); 201 | } 202 | 203 | sub as_yaml { 204 | require YAML::Any; 205 | return YAML::Any::Dump(${${$_[0]}}); 206 | } 207 | 208 | 1; 209 | -------------------------------------------------------------------------------- /lib/perl5i/2/RequireMessage.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::RequireMessage; 2 | use strict; 3 | use warnings; 4 | 5 | # This is the sub that displays the message 6 | my $diesub = sub { 7 | my ( $sub, $mod ) = @_; 8 | 9 | my $hints = (caller(0))[10]; 10 | return unless $hints->{perl5i}; 11 | die( < sub { 20 | return if ref($INC[-1]) && $INC[-1] == $diesub; 21 | @INC = grep { !(ref($_) && $_ == $diesub) } @INC; 22 | push @INC => $diesub; 23 | }; 24 | push @INC => $diesub; 25 | 26 | 1; 27 | -------------------------------------------------------------------------------- /lib/perl5i/2/Signature.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::Signature; 2 | 3 | use 5.010_000; 4 | use strict; 5 | use warnings; 6 | 7 | use perl5i::2::Signature::Method::None; 8 | use perl5i::2::Signature::Function::None; 9 | 10 | # A proxy class to hold a method's signature until its actually used. 11 | 12 | use overload 13 | q[""] => sub { return $_[0]->as_string }, 14 | fallback => 1 15 | ; 16 | 17 | 18 | sub new { 19 | my $class = shift; 20 | my %args = @_; 21 | 22 | my $string = $args{signature} // ''; 23 | my $is_method = $args{is_method} // 0; 24 | 25 | my $no_params = !$string || $string !~ /\S/; 26 | if( $no_params ) { 27 | return $is_method ? perl5i::2::Signature::Method::None->new( signature => $string ) 28 | : perl5i::2::Signature::Function::None->new( signature => $string ); 29 | } 30 | else { 31 | return bless { signature => $string, is_method => $is_method }, $class; 32 | } 33 | } 34 | 35 | sub as_string { 36 | my $self = shift; 37 | return $self->{signature}; 38 | } 39 | 40 | sub make_real { 41 | my $self = shift; 42 | 43 | require perl5i::2::Signature::Real; 44 | bless $self, "perl5i::2::Signature::Real"; 45 | 46 | $self->__parse_signature; 47 | } 48 | 49 | # Upgrade to a real signature object 50 | # and call the original method. 51 | # This should only be called once per object. 52 | our $AUTOLOAD; 53 | sub AUTOLOAD { 54 | my($method) = reverse split /::/, $AUTOLOAD; 55 | return if $method eq 'DESTROY'; 56 | 57 | my $self = $_[0]; # leave @_ alone 58 | 59 | # Upgrade to a real object 60 | $self->make_real; 61 | 62 | goto $self->can($method); 63 | } 64 | 65 | 1; 66 | -------------------------------------------------------------------------------- /lib/perl5i/2/Signature/Function/None.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::Signature::Function::None; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'perl5i::2::Signature::None'; 7 | 8 | sub invocant { return '' } 9 | sub is_method { return 0 } 10 | 11 | 1; 12 | -------------------------------------------------------------------------------- /lib/perl5i/2/Signature/Method/None.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::Signature::Method::None; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'perl5i::2::Signature::None'; 7 | 8 | sub invocant { return '$self' } 9 | sub is_method { return 1 } 10 | 11 | 1; 12 | -------------------------------------------------------------------------------- /lib/perl5i/2/Signature/None.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::Signature::None; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use overload 7 | q[""] => sub { return $_[0]->as_string }, 8 | q[bool] => sub { 1 }, # always true, regardless of the actual signature string 9 | fallback => 1 10 | ; 11 | 12 | sub new { 13 | my $class = shift; 14 | my %args = @_; 15 | return bless { signature => $args{signature} }, $class; 16 | } 17 | 18 | sub num_positional_params { 0 } 19 | sub positional_params { return []; } 20 | sub params { return []; } 21 | sub make_real {} 22 | 23 | sub as_string { 24 | my $self = shift; 25 | return $self->{signature}; 26 | } 27 | 28 | 1; 29 | -------------------------------------------------------------------------------- /lib/perl5i/2/Signature/Real.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::Signature::Real; 2 | use perl5i::2; 3 | 4 | use overload 5 | q[""] => sub { return $_[0]->as_string }, 6 | fallback => 1 7 | ; 8 | 9 | method new($class: %args) { 10 | bless \%args, $class; 11 | } 12 | 13 | sub make_real () {} 14 | 15 | method __parse_signature { 16 | my $string = $self->{signature}->trim; 17 | 18 | if( $string =~ s{^ (\$\w+) : \s*}{}x ) { 19 | $self->{invocant} = $1 // ''; 20 | } 21 | elsif( $self->is_method ) { 22 | $self->{invocant} = '$self'; 23 | } 24 | else { 25 | $self->{invocant} = ''; 26 | } 27 | 28 | my @args = split /\s*,\s*/, $string; 29 | 30 | $self->{params} = \@args; 31 | $self->{positional_params} = \@args; 32 | $self->{num_positional_params} = @args; 33 | 34 | return; 35 | } 36 | 37 | method num_positional_params() { 38 | return $self->{num_positional_params}; 39 | } 40 | 41 | method positional_params() { 42 | return $self->{positional_params}; 43 | } 44 | 45 | method params() { 46 | return $self->{params}; 47 | } 48 | 49 | method as_string() { 50 | return $self->{signature}; 51 | } 52 | 53 | method invocant() { 54 | return $self->{invocant}; 55 | } 56 | 57 | method is_method() { 58 | return $self->{is_method}; 59 | } 60 | 61 | 1; 62 | -------------------------------------------------------------------------------- /lib/perl5i/2/Signatures.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::Signatures; 2 | use strict; 3 | use warnings; 4 | 5 | use perl5i::2::Signature; 6 | 7 | # Can't load full autoboxing or signatures would not be available to the 8 | # autoboxed definitions 9 | use perl5i::2::CODE; 10 | 11 | use base q/Devel::Declare::MethodInstaller::Simple/; 12 | use Sub::Name; 13 | 14 | sub import { 15 | my $class = shift; 16 | 17 | my %opts = @_; 18 | $opts{into} ||= caller; 19 | $opts{invocant} ||= '$self'; 20 | 21 | my %def_opts = %opts; 22 | delete $def_opts{invocant}; 23 | 24 | # Define "method" 25 | $class->install_methodhandler( 26 | name => 'method', 27 | %opts 28 | ); 29 | 30 | # Define "func" 31 | $class->install_methodhandler( 32 | name => 'func', 33 | %def_opts 34 | ); 35 | } 36 | 37 | sub parse_proto { 38 | my $self = shift; 39 | my ($proto) = @_; 40 | $proto ||= ''; 41 | 42 | # Save it for attaching to the code ref later 43 | $self->{perl5i}{signature} = $proto; 44 | 45 | $proto =~ s/[\r\n]//g; 46 | my $invocant = $self->{invocant}; 47 | 48 | my $inject = ''; 49 | if( $invocant ) { 50 | $invocant = $1 if $proto =~ s{^(\$\w+):\s*}{}; 51 | $inject .= "my ${invocant} = shift;"; 52 | } 53 | $inject .= "my ($proto) = \@_;" if defined $proto and length $proto; 54 | 55 | return $inject; 56 | } 57 | 58 | 59 | sub code_for { 60 | my ($self, $name) = @_; 61 | 62 | my $signature = $self->{perl5i}{signature}; 63 | my $is_method = $self->{invocant} ? 1 : 0; 64 | 65 | if (defined $name) { 66 | my $pkg = $self->get_curstash_name; 67 | $name = join( '::', $pkg, $name ) 68 | unless( $name =~ /::/ ); 69 | return sub (&) { 70 | my $code = shift; 71 | # So caller() gets the subroutine name 72 | no strict 'refs'; 73 | *{$name} = subname $name => $code; 74 | 75 | $self->set_signature( 76 | code => $code, 77 | signature => $signature, 78 | is_method => $is_method, 79 | ); 80 | 81 | return; 82 | }; 83 | } else { 84 | return sub (&) { 85 | my $code = shift; 86 | 87 | $self->set_signature( 88 | code => $code, 89 | signature => $signature, 90 | is_method => $is_method, 91 | ); 92 | return $code; 93 | }; 94 | } 95 | } 96 | 97 | 98 | sub set_signature { 99 | my $self = shift; 100 | my %args = @_; 101 | 102 | my $sig = perl5i::2::CODE::signature($args{code}); 103 | return $sig if $sig; 104 | 105 | $sig = perl5i::2::Signature->new( 106 | signature => $args{signature}, 107 | is_method => $args{is_method}, 108 | ); 109 | 110 | perl5i::2::CODE::__set_signature($args{code}, $sig); 111 | 112 | return $sig; 113 | } 114 | 115 | 1; 116 | -------------------------------------------------------------------------------- /lib/perl5i/2/UNIVERSAL.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::UNIVERSAL; 2 | 3 | # Methods which apply to all autoboxed objects. 4 | # 5 | # They do NOT apply to blessed objects. That should go into perl5i::2::Meta::Instance. 6 | 7 | use strict; 8 | use warnings; 9 | 10 | require Carp::Fix::1_25; 11 | 12 | sub alias { 13 | my $self = shift; 14 | 15 | Carp::Fix::1_25::croak('Not enough arguments given to alias()') unless @_; 16 | 17 | my @name = @_; 18 | unshift @name, (caller)[0] unless @name > 1 or grep /::/, @name; 19 | 20 | my $name = join '::', @name; 21 | 22 | # If this redefines something, assume the user wanted to 23 | no warnings 'redefine'; 24 | no strict 'refs'; 25 | *{$name} = $self; 26 | return 1; 27 | } 28 | 29 | sub is_number { return } 30 | sub is_positive { return } 31 | sub is_negative { return } 32 | sub is_even { return } 33 | sub is_odd { return } 34 | sub is_int { return } 35 | sub is_integer { return } 36 | sub is_decimal { return } 37 | 38 | 1; 39 | -------------------------------------------------------------------------------- /lib/perl5i/2/autobox.pm: -------------------------------------------------------------------------------- 1 | package perl5i::2::autobox; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # Load these after we're fully compiled because they 7 | # use us internally. 8 | require perl5i::2::SCALAR; 9 | require perl5i::2::ARRAY; 10 | require perl5i::2::HASH; 11 | require perl5i::2::UNIVERSAL; 12 | require perl5i::2::CODE; 13 | 14 | # List::Util needs to be before Core to get the C version of sum 15 | use parent 'autobox::List::Util'; 16 | use parent 'autobox::Core'; 17 | 18 | sub import { 19 | my $class = shift; 20 | $class->autobox::import(); 21 | $class->autobox::import( 22 | UNIVERSAL => 'perl5i::2::UNIVERSAL', 23 | DEFAULT => 'perl5i::2::' 24 | ); 25 | autobox::List::Util::import($class); 26 | autobox::Core::import($class); 27 | } 28 | 29 | 1; 30 | -------------------------------------------------------------------------------- /lib/perl5i/Signature.pod: -------------------------------------------------------------------------------- 1 | =encoding utf8 2 | 3 | =head1 NAME 4 | 5 | perl5i::Signature - Representing what parameters a subroutine accepts 6 | 7 | =head1 SYNOPSIS 8 | 9 | func hello( $greeting, $place ) { say "$greeting, $place" } 10 | 11 | my $code = \&hello; 12 | my $signature = $code->signature; 13 | 14 | say $signature->num_positional_params; # 2 15 | say $signature->is_method; # false 16 | 17 | =head1 DESCRIPTION 18 | 19 | A Signature is a representation of what parameters a subroutine 20 | accepts. Each subroutine defined with C or C 21 | will have a signature associated with it. You can get at it by 22 | calling the C method on the code reference. See 23 | L for more details. 24 | 25 | Subroutines declared with Perl's built in C will have no 26 | signature. 27 | 28 | =head1 METHODS 29 | 30 | =head3 params 31 | 32 | my $params = $sig->params; 33 | 34 | An array ref of the parameters a subroutine takes in the order it 35 | takes them. Currently they are just strings. In the future they will 36 | be string overloaded objects. 37 | 38 | =head3 positional_params 39 | 40 | my $params = $sig->positional_params; 41 | 42 | Like C<< $sig->params >> but it is just the positional parameters. 43 | 44 | In the future there will be named parameters. 45 | 46 | =head3 num_positional_params 47 | 48 | my $num_positional_params = $sig->num_positional_params; 49 | 50 | The number of named parameters the subroutine takes. 51 | 52 | In the future there will be named parameters. For the purposes of 53 | determining how many arguments a function takes, it is most useful to 54 | look just at the positional ones. 55 | 56 | This is mostly an optimization for C<< $sig->positional_params->size >>. 57 | 58 | =head3 as_string 59 | 60 | my $params = $sig->as_string; 61 | 62 | The original signature string. 63 | 64 | =head3 invocant 65 | 66 | my $invocant = $sig->invocant; 67 | 68 | The invocant is the object or class a method is called on. 69 | C will return the parameter which contains this, by default 70 | it is C<$self> on a method, and nothing a regular subroutine. 71 | 72 | =head3 is_method 73 | 74 | my $is_method = $sig->is_method; 75 | 76 | Returns if the subroutine was declared as a method. 77 | 78 | =head1 OVERLOADING 79 | 80 | Signature objects are string overloaded to return C. They 81 | are also I to avoid objects taking no parameters from 82 | being confused with subroutines with no signatures. 83 | -------------------------------------------------------------------------------- /lib/perl5i/VERSION.pm: -------------------------------------------------------------------------------- 1 | package perl5i::VERSION; 2 | 3 | # Just a package to hold the version number and latest major version. 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use version 0.77; our $VERSION = qv("v2.13.2"); 9 | 10 | sub latest { "perl5i::2" }; # LATEST HERE (for automated update) 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /lib/perl5i/cmd.pm: -------------------------------------------------------------------------------- 1 | package perl5i::cmd; 2 | 3 | # This is a shim for the perl5i command line utility to use. 4 | 5 | use strict; 6 | use parent 'perl5i::latest'; 7 | 8 | sub import { 9 | my $class = $_[0]; 10 | 11 | # Remove the name from the import list before passing it along to perl5i. 12 | my $name = splice(@_, 1, 1); 13 | 14 | # Make the program identify as perl5i 15 | $^X = $name; 16 | 17 | goto &perl5i::latest::import; 18 | } 19 | 20 | 1; 21 | -------------------------------------------------------------------------------- /lib/perl5i/latest.pm: -------------------------------------------------------------------------------- 1 | package perl5i::latest; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use perl5i::VERSION; our $VERSION = perl5i::VERSION->VERSION; 7 | 8 | my $Latest; 9 | BEGIN { $Latest = perl5i::VERSION->latest; } 10 | 11 | use parent ($Latest); 12 | sub import { goto &{$Latest .'::import'} } 13 | 14 | 1; 15 | 16 | __END__ 17 | 18 | =encoding utf8 19 | 20 | =head1 NAME 21 | 22 | perl5i::latest - Use the latest version of perl5i 23 | 24 | =head1 SYNOPSIS 25 | 26 | use perl5i::latest; 27 | 28 | =head1 DESCRIPTION 29 | 30 | Because perl5i is designed to break compatibility, you must declare 31 | which major version you're writing your code with to preserve 32 | compatibility. If you want to be more daring, you can C and it will load the newest major version of perl5i 34 | you have installed. 35 | 36 | perl5i B, believe it. This is mostly useful 37 | for one-off scripts and one-liners and digital thrill seekers. 38 | 39 | =cut 40 | -------------------------------------------------------------------------------- /local-lib-rc: -------------------------------------------------------------------------------- 1 | # Write to $HOME/.local-lib-rc and then add 2 | # "source ~/.local-lib-rc" to $HOME/.bashrc 3 | export PERL_MB_OPT="--install_base $HOME/perl5" 4 | export PERL_MM_OPT="INSTALL_BASE=$HOME/perl5" 5 | export PERL5LIB="$HOME/perl5/lib/perl5/i386-linux:$HOME/perl5/lib/perl5" 6 | export PATH="$HOME/perl5/bin:$PATH" 7 | -------------------------------------------------------------------------------- /t/00_TEST_TEMPLATE.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # This is a template for writing new test files. 4 | # In this place should be an overall description of what the test file is about. 5 | # Test files should ideally be about one method or group of methods, 6 | # or a single, complicated bug. 7 | # 8 | # See https://github.com/evalEmpire/perl5i/wiki/Coding-Standards 9 | 10 | use perl5i::latest; 11 | use Test::Most; 12 | 13 | note "Describe what this block is doing, use as many blocks as you need"; { 14 | my $lexical = "Keep variables in narrow scopes"; 15 | 16 | is 1+1, 2, "Addition"; 17 | } 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /t/ARGV.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Test that perl5i makes @ARGV utf8 4 | 5 | BEGIN { 6 | @ARGV = qw(føø bar bāz); 7 | } 8 | 9 | use perl5i::latest; 10 | use Test::More; 11 | 12 | is_deeply \@ARGV, [qw(føø bar bāz)]; 13 | 14 | done_testing(); 15 | -------------------------------------------------------------------------------- /t/ARGV_twice.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Test that perl5i doesn't double encode @ARGV [github 176] 4 | 5 | BEGIN { 6 | @ARGV = qw(føø bar bāz); 7 | } 8 | 9 | { 10 | package Foo; 11 | use perl5i::latest; 12 | } 13 | 14 | use perl5i::latest; 15 | use Test::More; 16 | 17 | is_deeply \@ARGV, [qw(føø bar bāz)]; 18 | 19 | done_testing(); 20 | -------------------------------------------------------------------------------- /t/CLASS.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More 'no_plan'; 4 | use perl5i::latest; 5 | 6 | is CLASS, __PACKAGE__, "CLASS keyword"; 7 | is $CLASS, __PACKAGE__, '$CLASS'; 8 | -------------------------------------------------------------------------------- /t/Child.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use warnings; 4 | 5 | use perl5i::latest; 6 | use Test::More; 7 | 8 | ############################################################################ 9 | # These are copied from the Child tests. 10 | # Only the works as advertised tests are copied here, not the how it does it 11 | # tests. 12 | ############################################################################ 13 | 14 | our $CLASS = 'Child'; 15 | 16 | can_ok( __PACKAGE__, 'child' ); 17 | 18 | my $child = $CLASS->new( sub { 19 | my $self = shift; 20 | $self->say( "Have self" ); 21 | $self->say( "parent: " . $self->pid ); 22 | my $in = $self->read(); 23 | $self->say( $in ); 24 | }, pipe => 1 ); 25 | 26 | my $proc = $child->start; 27 | is( $proc->read(), "Have self\n", "child has self" ); 28 | is( $proc->read(), "parent: $$\n", "child has parent PID" ); 29 | { 30 | local $SIG{ALRM} = sub { die "non-blocking timeout" }; 31 | alarm 5; 32 | ok( !$proc->is_complete, "Not Complete" ); 33 | alarm 0; 34 | } 35 | $proc->say("XXX"); 36 | is( $proc->read(), "XXX\n", "Full IPC" ); 37 | ok( $proc->wait, "wait" ); 38 | ok( $proc->is_complete, "Complete" ); 39 | is( $proc->exit_status, 0, "Exit clean" ); 40 | 41 | $proc = $CLASS->new( sub { sleep 15 } )->start; 42 | 43 | my $ret = eval { $proc->say("XXX"); 1 }; 44 | ok( !$ret, "Died, no IPC" ); 45 | like( $@, qr/Child was created without IPC support./, "No IPC" ); 46 | if ( $^O eq 'MSWin32' ) { 47 | diag( "on win32 we must wait on this process (15 seconds)" ); 48 | $proc->wait; 49 | } 50 | else { 51 | $proc->kill(2); 52 | } 53 | 54 | $proc = $CLASS->new( sub { 55 | my $self = shift; 56 | $SIG{INT} = sub { exit( 2 ) }; 57 | $self->say( "go" ); 58 | sleep 15; 59 | exit 2; 60 | }, pipe => 1 )->start; 61 | 62 | $proc->read; 63 | sleep 1; 64 | 65 | if ( $^O eq 'MSWin32' ) { 66 | diag( "on win32 we must wait on this process (15 seconds)" ); 67 | $proc->wait; 68 | } 69 | else { 70 | ok( $proc->kill(2), "Send signal" ); 71 | ok( !$proc->wait, "wait" ); 72 | } 73 | ok( $proc->is_complete, "Complete" ); 74 | is( $proc->exit_status, 2, "Exit 2" ); 75 | ok( $proc->unix_exit > 2, "Real exit" ); 76 | 77 | $child = $CLASS->new( sub { 78 | my $self = shift; 79 | $self->autoflush(0); 80 | $self->say( "A" ); 81 | $self->flush; 82 | $self->say( "B" ); 83 | sleep 5; 84 | $self->flush; 85 | }, pipe => 1 ); 86 | 87 | $proc = $child->start; 88 | is( $proc->read(), "A\n", "A" ); 89 | my $start = time; 90 | is( $proc->read(), "B\n", "B" ); 91 | my $end = time; 92 | 93 | ok( $end - $start > 2, "No autoflush" ); 94 | 95 | SKIP: { 96 | if ($^O eq 'MSWin32') { 97 | skip "detach is not available on win32", 1; 98 | } 99 | else { 100 | $proc = $CLASS->new( sub { 101 | my $self = shift; 102 | $self->detach; 103 | $self->say( $self->detached ); 104 | }, pipe => 1 )->start; 105 | is( $proc->read(), $proc->pid . "\n", "Child detached" ); 106 | } 107 | } 108 | 109 | done_testing; 110 | -------------------------------------------------------------------------------- /t/English.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | eval { die }; 7 | ok $EVAL_ERROR; 8 | is $EVAL_ERROR, $@; 9 | 10 | ok !eval q{ $PREMATCH; 1 }; 11 | ok !eval q{ $MATCH; 1 }; 12 | ok !eval q{ $POSTMATCH; 1 }; 13 | 14 | done_testing; 15 | -------------------------------------------------------------------------------- /t/File-stat.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | use Test::More 'no_plan'; 5 | 6 | my $stat = stat("MANIFEST"); 7 | isa_ok $stat, "File::stat"; 8 | cmp_ok $stat->size, ">", 0; 9 | 10 | is_deeply [stat("MANIFEST")], [CORE::stat("MANIFEST")], 'stat() in array context'; 11 | is_deeply [lstat("MANIFEST")], [CORE::lstat("MANIFEST")], 'lstat() in array context'; 12 | -------------------------------------------------------------------------------- /t/List-MoreUtils/all.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my @numbers = ( 1 .. 10 ); 7 | 8 | ok( @numbers->all( sub { $_ < 100 } ) ); 9 | ok( not ( @numbers->all( sub { $_ > 100 } ) ) ); 10 | 11 | done_testing(); 12 | -------------------------------------------------------------------------------- /t/List-MoreUtils/any.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my @numbers = ( 1 .. 10 ); 7 | 8 | ok( @numbers->any( sub { $_ < 5 } ) ); 9 | ok( not ( @numbers->any( sub { $_ > 100 } ) ) ); 10 | 11 | done_testing(); 12 | -------------------------------------------------------------------------------- /t/List-MoreUtils/false.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my @numbers = ( 1 .. 10 ); 7 | 8 | is( @numbers->false( sub { $_ < 5 } ), 6 ); 9 | is( @numbers->false( sub { $_ > 9 } ), 9 ); 10 | 11 | done_testing(); 12 | -------------------------------------------------------------------------------- /t/List-MoreUtils/mesh.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my @numbers = ( 1 .. 3 ); 7 | my @letters = ( 'a' .. 'c' ); 8 | my @words = qw(foo bar baz); 9 | 10 | my $m; 11 | 12 | is_deeply( $m = @numbers->mesh(\@letters), [ 1, 'a', 2, 'b', 3, 'c' ] ); 13 | 14 | is_deeply( 15 | $m = @numbers->mesh(\@letters, \@words), 16 | [ 1, 'a', 'foo', 2, 'b', 'bar', 3, 'c', 'baz' ], 17 | ); 18 | 19 | my @m = @numbers->mesh(\@letters); 20 | 21 | is scalar @m, 6, "Returns an array in list context"; 22 | 23 | done_testing(); 24 | -------------------------------------------------------------------------------- /t/List-MoreUtils/minmax.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my @numbers = ( 1 .. 10 ); 7 | my $m; 8 | 9 | is_deeply( $m = @numbers->minmax, [1, 10] ); 10 | is_deeply( $m = [@numbers, 20]->minmax, [1, 20] ); 11 | 12 | my @m = @numbers->minmax; 13 | 14 | is scalar @m, 2, "Returns an array in list context"; 15 | 16 | done_testing(); 17 | -------------------------------------------------------------------------------- /t/List-MoreUtils/none.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my @numbers = ( 1 .. 10 ); 7 | 8 | ok( @numbers->none( sub { $_ < 0 } ) ); 9 | ok( not @numbers->none( sub { $_ > 5 } ) ); 10 | 11 | done_testing(); 12 | -------------------------------------------------------------------------------- /t/List-MoreUtils/true.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my @numbers = ( 1 .. 10 ); 7 | 8 | is( @numbers->true( sub { $_ < 5 } ), 4 ); 9 | is( @numbers->true( sub { $_ > 9 } ), 1 ); 10 | 11 | done_testing(); 12 | -------------------------------------------------------------------------------- /t/List-MoreUtils/uniq.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my @numbers = ( 1 .. 10 ); 7 | my $u; 8 | 9 | is_deeply( $u = @numbers->uniq, \@numbers ); 10 | is_deeply( $u = [@numbers, @numbers]->uniq, \@numbers ); 11 | 12 | my @u = @numbers->uniq; 13 | 14 | is scalar @u, 10, "Returns an array in list context"; 15 | 16 | done_testing(); 17 | -------------------------------------------------------------------------------- /t/List-Util/first.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More tests => 14; 6 | 7 | my $v = [ 9, 4, 5, 6 ]->first( sub { 8 == ( $_ - 1 ) } ); 8 | 9 | is( $v, 9, 'one more than 8' ); 10 | 11 | $v = [ 1, 2, 3, 4 ]->first( sub { 0 } ); 12 | is( $v, undef, 'none match' ); 13 | 14 | $v = []->first( sub { 0 } ); 15 | is( $v, undef, 'no args' ); 16 | 17 | $v = [ [qw(a b c)], [qw(d e f)], [qw(g h i)] ]->first( sub { $_->[1] le "e" and "e" le $_->[2] } ); 18 | is_deeply( $v, [qw(d e f)], 'reference args' ); 19 | 20 | # Check that eval{} inside the block works correctly 21 | my $i = 0; 22 | $v = [ 0, 1, 2, 3, 4, 5, 5 ]->first( 23 | sub { 24 | eval { die }; 25 | ( $i == 5, $i = $_ )[0]; 26 | } 27 | ); 28 | is( $v, 5, 'use of eval' ); 29 | 30 | $v = eval { 31 | [ 0, 0, 1 ]->first( sub { die if $_ } ); 32 | }; 33 | is( $v, undef, 'use of die' ); 34 | 35 | sub foobar { 36 | [ "not ", "not ", "not " ]->first( sub { !defined(wantarray) || wantarray } ); 37 | } 38 | 39 | ($v) = foobar(); 40 | is( $v, undef, 'wantarray' ); 41 | 42 | # Can we leave the sub with 'return'? 43 | $v = [ 2, 4, 6, 12 ]->first( sub { return( $_ > 6 ) } ); 44 | is( $v, 12, 'return' ); 45 | 46 | # ... even in a loop? 47 | $v = [ 2, 4, 6, 12 ]->first( 48 | sub { 49 | while(1) { return( $_ > 6 ) } 50 | } 51 | ); 52 | is( $v, 12, 'return from loop' ); 53 | 54 | # Does it work from another package? 55 | { 56 | 57 | package Foo; 58 | use autobox::List::Util; 59 | ::is( [ 1 .. 4, 24 ]->first( sub { $_ > 4 } ), 24, 'other package' ); 60 | } 61 | 62 | # Can we undefine a first sub while it's running? 63 | sub self_immolate { undef &self_immolate; 1 } 64 | eval { $v = [ 1, 2 ]->first( \&self_immolate ) }; 65 | like( $@, qr/^Can't undef active subroutine/, "undef active sub" ); 66 | 67 | # Redefining an active sub should not fail, but whether the 68 | # redefinition takes effect immediately depends on whether we're 69 | # running the Perl or XS implementation. 70 | 71 | { 72 | 73 | sub self_updating { 74 | no warnings 'redefine'; 75 | *self_updating = sub { 1 }; 76 | return; 77 | } 78 | eval { $v = [ 1, 2 ]->first( \&self_updating ) }; 79 | is( $@, '', 'redefine self' ); 80 | } 81 | 82 | { 83 | my $failed = 0; 84 | 85 | sub rec { 86 | my $n = shift; 87 | if( !defined($n) ) { # No arg means we're being called by first() 88 | return 1; 89 | } 90 | if( $n < 5 ) { rec( $n + 1 ); } 91 | else { $v = [ 1, 2 ]->first( \&rec ) } 92 | $failed = 1 if !defined $n; 93 | } 94 | 95 | rec(1); 96 | ok( !$failed, 'from active sub' ); 97 | } 98 | 99 | # Works with Regexp 100 | 101 | is [ qw(foo bar baz) ]->first(qr/^ba/), 'bar', "Works with Regexp"; 102 | -------------------------------------------------------------------------------- /t/List-Util/max.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More tests => 4; 6 | 7 | my $v; 8 | 9 | $v = [1]->max; 10 | is( $v, 1, 'single arg' ); 11 | 12 | $v = [ 1, 2 ]->max; 13 | is( $v, 2, '2-arg ordered' ); 14 | 15 | $v = [ 2, 1 ]->max; 16 | is( $v, 2, '2-arg reverse ordered' ); 17 | 18 | my @a = map { rand() } 1 .. 20; 19 | my @b = sort { $a <=> $b } @a; 20 | $v = @a->max; 21 | is( $v, $b[-1], '20-arg random order' ); 22 | -------------------------------------------------------------------------------- /t/List-Util/maxstr.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More tests => 4; 6 | 7 | my $v; 8 | 9 | $v = ['a']->maxstr; 10 | is( $v, 'a', 'single arg' ); 11 | 12 | $v = [ 'a', 'b' ]->maxstr; 13 | is( $v, 'b', '2-arg ordered' ); 14 | 15 | $v = [ 'B', 'A' ]->maxstr; 16 | is( $v, 'B', '2-arg reverse ordered' ); 17 | 18 | my @a = map { 19 | pack( "u", pack( "C*", map { int( rand(256) ) } ( 0 .. int( rand(10) + 2 ) ) ) ) 20 | } 0 .. 20; 21 | my @b = sort { $a cmp $b } @a; 22 | $v = @a->maxstr; 23 | is( $v, $b[-1], 'random ordered' ); 24 | -------------------------------------------------------------------------------- /t/List-Util/min.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More tests => 4; 6 | 7 | my $v; 8 | 9 | $v = [ (9) ]->min; 10 | is( $v, 9, 'single arg' ); 11 | 12 | $v = [ 1, 2 ]->min; 13 | is( $v, 1, '2-arg ordered' ); 14 | 15 | $v = [ ( 2, 1 ) ]->min; 16 | is( $v, 1, '2-arg reverse ordered' ); 17 | 18 | my @a = map { rand() } 1 .. 20; 19 | my @b = sort { $a <=> $b } @a; 20 | $v = [ (@a) ]->min; 21 | is( $v, $b[0], '20-arg random order' ); 22 | -------------------------------------------------------------------------------- /t/List-Util/minstr.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More tests => 4; 6 | 7 | my $v; 8 | 9 | $v = [ ('a') ]->minstr; 10 | is( $v, 'a', 'single arg' ); 11 | 12 | $v = [ ( 'a', 'b' ) ]->minstr; 13 | is( $v, 'a', '2-arg ordered' ); 14 | 15 | $v = [ ( 'B', 'A' ) ]->minstr; 16 | is( $v, 'A', '2-arg reverse ordered' ); 17 | 18 | my @a = map { 19 | pack( "u", pack( "C*", map { int( rand(256) ) } ( 0 .. int( rand(10) + 2 ) ) ) ) 20 | } 0 .. 20; 21 | my @b = sort { $a cmp $b } @a; 22 | $v = [ (@a) ]->minstr; 23 | is( $v, $b[0], 'random ordered' ); 24 | -------------------------------------------------------------------------------- /t/List-Util/reduce.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More tests => 20; 6 | 7 | my $v = []->reduce( sub { } ); 8 | 9 | is( $v, undef, 'no args' ); 10 | 11 | $v = [ 756, 3, 7, 4 ]->reduce( sub { $a / $b } ); 12 | is( $v, 9, '4-arg divide' ); 13 | 14 | $v = [6]->reduce( sub { $a / $b } ); 15 | is( $v, 6, 'one arg' ); 16 | 17 | my @a = map { rand } 0 .. 20; 18 | $v = @a->reduce( sub { $a < $b ? $a : $b } ); 19 | is( $v, @a->min, 'min' ); 20 | 21 | @a = map { pack( "C", int( rand(256) ) ) } 0 .. 20; 22 | $v = @a->reduce( sub { $a . $b } ); 23 | is( $v, join( "", @a ), 'concat' ); 24 | 25 | sub add { 26 | my( $aa, $bb ) = @_; 27 | return $aa + $bb; 28 | } 29 | 30 | $v = [ 3, 2, 1 ]->reduce( sub { my $t = "$a $b\n"; 0 + add( $a, $b ) } ); 31 | is( $v, 6, 'call sub' ); 32 | 33 | # Check that eval{} inside the block works correctly 34 | $v = [ 0, 1, 2, 3, 4 ]->reduce( 35 | sub { 36 | eval { die }; 37 | $a + $b; 38 | } 39 | ); 40 | is( $v, 10, 'use eval{}' ); 41 | 42 | $v = !defined eval { 43 | [ 0 .. 4 ]->reduce( sub { die if $b > 2; $a + $b } ); 44 | }; 45 | ok( $v, 'die' ); 46 | 47 | sub foobar { 48 | [ 0 .. 3 ]->reduce( sub { ( defined(wantarray) && !wantarray ) ? $a + 1 : 0 } ); 49 | } 50 | ($v) = foobar(); 51 | is( $v, 3, 'scalar context' ); 52 | 53 | sub add2 { $a + $b } 54 | 55 | $v = [ 1, 2, 3 ]->reduce( \&add2 ); 56 | is( $v, 6, 'sub reference' ); 57 | 58 | $v = [ 3, 4, 5 ]->reduce( sub { add2() } ); 59 | is( $v, 12, 'call sub' ); 60 | 61 | 62 | $v = [ 1, 2, 3 ]->reduce( sub { eval "$a + $b" } ); 63 | is( $v, 6, 'eval string' ); 64 | 65 | $a = 8; 66 | $b = 9; 67 | $v = [ 1, 2, 3 ]->reduce( sub { $a * $b } ); 68 | is( $a, 8, 'restore $a' ); 69 | is( $b, 9, 'restore $b' ); 70 | 71 | 72 | # Can we leave the sub with 'return'? 73 | $v = [ 2, 4, 6 ]->reduce( sub { return $a + $b } ); 74 | is( $v, 12, 'return' ); 75 | 76 | # ... even in a loop? 77 | $v = [ 2, 4, 6 ]->reduce( 78 | sub { 79 | while(1) { return $a + $b } 80 | } 81 | ); 82 | is( $v, 12, 'return from loop' ); 83 | 84 | 85 | # Does it work from another package? 86 | # FIXME: this doesn't work 87 | #{ 88 | # package Foo; 89 | # $a = $b; 90 | # ::is([1..4]->reduce( sub {$a*$b} ), 24, 'other package'); 91 | #} 92 | 93 | 94 | # Can we undefine a reduce sub while it's running? 95 | sub self_immolate { undef &self_immolate; 1 } 96 | eval { $v = [ 1, 2 ]->reduce( \&self_immolate ) }; 97 | like( $@, qr/^Can't undef active subroutine/, "undef active sub" ); 98 | 99 | # Redefining an active sub should not fail, but whether the 100 | # redefinition takes effect immediately depends on whether we're 101 | # running the Perl or XS implementation. 102 | 103 | { 104 | my $warn; 105 | local $SIG{__WARN__} = sub { $warn = shift }; 106 | 107 | sub self_updating { 108 | local $^W; 109 | *self_updating = sub { 1 }; 110 | 1; 111 | } 112 | my $l = "line " . ( __LINE__ - 3 ) . ".\n"; 113 | eval { $v = [ 1, 2 ]->reduce( \&self_updating ) }; 114 | is( $@, '', 'redefine self' ); 115 | is( $warn, "Subroutine main::self_updating redefined at $0 $l" ); 116 | } 117 | 118 | { 119 | my $failed = 0; 120 | 121 | sub rec { 122 | # No arg means we're being called by reduce() 123 | return 1 unless @_; 124 | 125 | my $n = shift; 126 | 127 | if( $n < 5 ) { 128 | rec( $n + 1 ); 129 | } 130 | else { 131 | $v = [ 1, 2 ]->reduce( \&rec ); 132 | } 133 | 134 | $failed = 1 if !defined $n; 135 | } 136 | 137 | rec(1); 138 | ok( !$failed, 'from active sub' ); 139 | } 140 | 141 | -------------------------------------------------------------------------------- /t/List-Util/shuffle.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More tests => 6; 6 | 7 | 8 | my @r; 9 | 10 | @r = []->shuffle; 11 | ok( !@r, 'no args' ); 12 | 13 | @r = [9]->shuffle; 14 | is( 0 + @r, 1, '1 in 1 out' ); 15 | is( $r[0], 9, 'one arg' ); 16 | 17 | my @in = 1 .. 100; 18 | @r = @in->shuffle; 19 | is( 0 + @r, 0 + @in, 'arg count' ); 20 | 21 | isnt( "@r", "@in", 'result different to args' ); 22 | 23 | my @s = sort { $a <=> $b } @r; 24 | is( "@in", "@s", 'values' ); 25 | -------------------------------------------------------------------------------- /t/List-Util/sum.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More tests => 6; 6 | 7 | my $v = []->sum; 8 | is( $v, undef, 'no args' ); 9 | 10 | $v = [ (9) ]->sum; 11 | is( $v, 9, 'one arg' ); 12 | 13 | $v = [ ( 1, 2, 3, 4 ) ]->sum; 14 | is( $v, 10, '4 args' ); 15 | 16 | $v = [ (-1) ]->sum; 17 | is( $v, -1, 'one -1' ); 18 | 19 | my $x = -3; 20 | 21 | $v = [ ( $x, 3 ) ]->sum; 22 | is( $v, 0, 'variable arg' ); 23 | 24 | $v = [ ( -3.5, 3 ) ]->sum; 25 | is( $v, -0.5, 'real numbers' ); 26 | 27 | -------------------------------------------------------------------------------- /t/Meta/ISA.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | 7 | # Test the basics 8 | { 9 | is_deeply [UNIVERSAL->mo->ISA], []; 10 | is_deeply [DoesNotExist->mo->ISA], []; 11 | } 12 | 13 | { 14 | package Parent; 15 | 16 | package MyChild; 17 | our @ISA = qw(Parent); 18 | sub new { bless {}, $_[0] } 19 | } 20 | 21 | 22 | # Single inheritance 23 | { 24 | is_deeply [MyChild->mc->ISA], ["Parent"]; 25 | 26 | my $obj = MyChild->new; 27 | is_deeply [$obj->mo->ISA], ["Parent"]; 28 | } 29 | 30 | 31 | # Multiple inheritance 32 | { 33 | package Foo; 34 | package Bar; 35 | package Baz; 36 | 37 | package Multiple; 38 | our @ISA = qw(Foo Bar Baz); 39 | } 40 | 41 | is_deeply [Multiple->mc->ISA], [qw(Foo Bar Baz)]; 42 | 43 | is_deeply scalar Multiple->mc->ISA, [qw(Foo Bar Baz)], "scalar context"; 44 | 45 | done_testing(); 46 | -------------------------------------------------------------------------------- /t/Meta/checksum.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | use Scalar::Util 'refaddr'; 10 | 11 | 12 | my $foo = bless {}, 'Foo'; 13 | my $foo2 = bless {}, 'Foo'; 14 | my $bar = bless {}, 'Bar'; 15 | 16 | ok $foo->mo->checksum; 17 | 18 | is $foo->mo->checksum, $foo2->mo->checksum; 19 | isnt $foo->mo->checksum, $bar->mo->checksum; 20 | 21 | throws_ok { $foo->mo->checksum( algorithm => 'foo' ) } qr/^algorithm must be/; 22 | throws_ok { $foo->mo->checksum( format => 'foo' ) } qr/^format must be/; 23 | 24 | my %digests; 25 | 26 | my @formats = qw(hex base64 binary); 27 | my @algos = qw(md5 sha1); 28 | my @refs = ( $foo, $foo2, $bar ); 29 | 30 | foreach my $algorithm (@algos) { 31 | foreach my $format (@formats) { 32 | foreach my $ref (@refs) { 33 | $digests{ refaddr $ref }{$format}{$algorithm} 34 | = $digests{$format}{$algorithm}{ refaddr $ref } 35 | = $ref->mo->checksum( algorithm => $algorithm, format => $format ); 36 | } 37 | } 38 | } 39 | 40 | # All checksums of equivalent objects should be identical 41 | is_deeply( [ $digests{ refaddr $foo} ], [ $digests{ refaddr $foo2 } ] ); 42 | 43 | my %length = ( 44 | binary => { md5 => 16, sha1 => 20 }, 45 | base64 => { md5 => 22, sha1 => 27 }, 46 | hex => { md5 => 32, sha1 => 40 }, 47 | ); 48 | 49 | # Checksums should have the expected character length 50 | # (this is mostly to test we're passing the options correctly) 51 | foreach my $algorithm (@algos) { 52 | foreach my $format (@formats) { 53 | is( length $_, $length{$format}{$algorithm} ) for values %{ $digests{$format}{$algorithm} }; 54 | } 55 | } 56 | 57 | # Method should work fine with non-blessed references and scalars 58 | my $ref = { this => "is some reference" }; 59 | my $ref2 = { this => "is some reference" }; 60 | my $ref3 = [qw( this is some reference )]; 61 | 62 | ok $ref->mo->checksum; 63 | is $ref->mo->checksum, $ref2->mo->checksum; 64 | isnt $ref->mo->checksum, $ref3->mo->checksum; 65 | 66 | ok 42->mo->checksum; 67 | isnt 42->mo->checksum, "foo"->mo->checksum; 68 | 69 | done_testing(); 70 | -------------------------------------------------------------------------------- /t/Meta/class.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Test Meta->class 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use perl5i::latest; 9 | 10 | use Test::More; 11 | 12 | my $obj = bless {}, "Foo"; 13 | is $obj->mc->class, "Foo"; 14 | 15 | is 42->mc->class, 42; 16 | 17 | my @array; 18 | is @array->mc->class, "ARRAY"; 19 | 20 | my %hash; 21 | is %hash->mc->class, "HASH"; 22 | 23 | my $ref = \42; 24 | is $ref->mc->class, "SCALAR"; 25 | 26 | is []->mc->class, "ARRAY"; 27 | 28 | is {}->mc->class, "HASH"; 29 | 30 | done_testing(); 31 | -------------------------------------------------------------------------------- /t/Meta/id.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | 7 | sub id_ok { 8 | state $seen = {}; 9 | 10 | local $Test::Builder::Level = $Test::Builder::Level + 1; 11 | 12 | # Use the alias to the object so strings and numbers are not copied. 13 | my $class = $_[0]->mc->class; 14 | my $id = $_[0]->mo->id; 15 | 16 | my $ok = 1; 17 | $ok &&= ok $id, "$class has an id"; 18 | $ok &&= ok !$seen->{$id}++, " its unique"; 19 | 20 | return $id; 21 | } 22 | 23 | # Double up everything to make sure the ID is not based on content 24 | { 25 | my @objs = ( 26 | bless({}, "Foo"), 27 | bless({}, "Foo"), 28 | qr/foo/, 29 | qr/foo/, 30 | sub { 42 }, 31 | sub { 42 }, 32 | \"string", 33 | \"string", 34 | ["foo"], 35 | ["foo"], 36 | 42, 37 | 42, 38 | "string", 39 | "string", 40 | ); 41 | 42 | for my $obj (@objs) { 43 | my $id = id_ok( $obj ); 44 | is $obj->mo->id, $id, " second call the same"; 45 | } 46 | } 47 | 48 | 49 | # Test that the id is independent of content 50 | { 51 | my $thing = 42; 52 | my $id = $thing->mo->id; 53 | $thing = 23; 54 | is $thing->mo->id, $id, "ID remains the same for a scalar with changed content"; 55 | } 56 | 57 | { 58 | my $obj = bless {}, "Foo"; 59 | my $id = $obj->mo->id; 60 | $obj->{key} = "value"; 61 | is $obj->mo->id, $id, "ID remains the same even if an object's contents change"; 62 | } 63 | 64 | 65 | done_testing(); 66 | -------------------------------------------------------------------------------- /t/Meta/is-equal.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use Test::More; 3 | use perl5i::latest; 4 | 5 | { 6 | my @things = ( [ 42 ], { 4 => 2 }, \42, sub { 42 }, \*STDIN, bless({}, 'Foo') ); 7 | 8 | ok $_->mo->is_equal($_) for @things; 9 | 10 | 11 | for my $i ( 0 .. $#things ) { 12 | 13 | my @others = grep { $_ ne $i } (0 .. $#things); 14 | 15 | ok( !$things[$i]->mo->is_equal( $things[$_] ) ) for @others; 16 | } 17 | 18 | 19 | ok 42->mo->is_equal(42), "Number is equal to itself"; 20 | 21 | ok !42->mo->is_equal($_) for @things; 22 | } 23 | 24 | done_testing(); 25 | -------------------------------------------------------------------------------- /t/Meta/linear_isa.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | is_deeply [UNIVERSAL->mc->linear_isa], ["UNIVERSAL"]; 7 | is_deeply [DoesNotExist->mc->linear_isa], [qw(DoesNotExist UNIVERSAL)]; 8 | 9 | # Set up a good ol diamond inheritance. 10 | { 11 | package Child; 12 | use perl5i::latest; 13 | our @ISA = qw(Mom Dad); 14 | 15 | package Mom; 16 | our @ISA = qw(GrandParents); 17 | 18 | package Dad; 19 | our @ISA = qw(GrandParents); 20 | 21 | package GrandParents; 22 | } 23 | 24 | is_deeply [Mom->mc->linear_isa], [qw(Mom GrandParents UNIVERSAL)]; 25 | is_deeply [Child->mc->linear_isa], [qw(Child Mom Dad GrandParents UNIVERSAL)] 26 | or diag explain( [Child->mc->linear_isa] ); 27 | 28 | is_deeply scalar Mom->mc->linear_isa, [qw(Mom GrandParents UNIVERSAL)], "scalar context"; 29 | 30 | done_testing(); 31 | -------------------------------------------------------------------------------- /t/Meta/methods.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | 7 | { 8 | package My::Child; 9 | 10 | our @ISA = qw(My::Parent); 11 | 12 | sub child1 {} 13 | sub child2 {} 14 | sub parent1 {} # don't count this twice 15 | } 16 | 17 | { 18 | package My::Parent; 19 | 20 | sub parent1 {} 21 | sub parent2 {} 22 | } 23 | 24 | note "methods of a class with no parent"; { 25 | my $class = "My::Parent"; 26 | 27 | my $want = [qw(parent1 parent2)]; 28 | 29 | is_deeply 30 | scalar $class->mc->methods->sort, 31 | scalar $want->sort, 32 | "methods on a simple class"; 33 | 34 | my $obj = bless {}, "My::Parent"; 35 | 36 | is_deeply 37 | scalar $obj->mo->methods->sort, 38 | scalar $want->sort, 39 | "methods on a simple object"; 40 | } 41 | 42 | 43 | note "methods of a class on a child"; { 44 | my $class = "My::Child"; 45 | 46 | my $want = [qw(child1 child2 parent1 parent2)]; 47 | 48 | is_deeply 49 | scalar $class->mc->methods->sort, 50 | scalar $want->sort, 51 | "inherited methods on a class"; 52 | 53 | my $obj = bless {}, "My::Child"; 54 | 55 | is_deeply 56 | scalar $obj->mo->methods->sort, 57 | scalar $want->sort, 58 | "inherited method on a class"; 59 | } 60 | 61 | 62 | note "just_mine => 1"; { 63 | my $child = bless {}, "My::Child"; 64 | my $methods = $child->mo->methods({ 65 | just_mine => 1 66 | }); 67 | 68 | is_deeply 69 | scalar $methods->sort, 70 | [sort qw(child1 child2 parent1)], 71 | "just_mine does not show inherited methods"; 72 | } 73 | 74 | 75 | note "with_UNIVERSAL => 1"; { 76 | my $child = bless {}, "My::Child"; 77 | my %methods = $child->mo->methods({ 78 | with_UNIVERSAL => 1 79 | })->map(sub { $_ => 1 }); 80 | 81 | my $want = [qw(child1 child2 parent1 isa can VERSION mc mo)]; 82 | for my $method (@$want) { 83 | ok $methods{$method}, "My::Child->$method"; 84 | } 85 | } 86 | 87 | 88 | note "UNIVERSAL still works"; { 89 | # We're not sure what's going to be in UNIVERSAL 90 | # but we know what should be there at minimum 91 | 92 | my %methods = UNIVERSAL->mc->methods->map(sub { $_ => 1}); 93 | 94 | my @min_want = qw(can isa VERSION mc mo); 95 | for my $method (@min_want) { 96 | ok $methods{$method}, "UNIVERSAL->$method"; 97 | } 98 | } 99 | 100 | 101 | # Fcntl has scalar refs in its symbol table probably due to some XS wackiness 102 | SKIP: { 103 | note "Weird things in the symbol table"; 104 | skip "Need Fcntl", 1 unless eval { "Fcntl"->require }; 105 | 106 | my @methods = Fcntl->mc->methods({ just_mine => 1 }); 107 | can_ok "Fcntl", @methods; 108 | } 109 | 110 | { 111 | package My::MixedDefs; 112 | use perl5i::latest; 113 | 114 | sub as_sub {} 115 | func as_func {} 116 | method as_method {} 117 | } 118 | { 119 | package My::MixedDefs::Child; 120 | our @ISA = qw(My::MixedDefs); 121 | use perl5i::latest; 122 | 123 | sub as_sub2 {} 124 | func as_func2 {} 125 | method as_method2 {} 126 | } 127 | 128 | 129 | note "func gets filtered out of methods list"; { 130 | my( @methods, @expected, @not_expected ); 131 | 132 | my $class = "My::MixedDefs"; 133 | 134 | @methods = $class->mc->methods; 135 | @expected = qw( as_method as_sub ); 136 | @not_expected = qw( as_func inexistant ); 137 | is_deeply 138 | scalar @methods->intersect( [ @expected, @not_expected ] )->sort, 139 | scalar @expected->sort, 140 | 'on a class'; 141 | 142 | my $obj = bless {}, $class; 143 | 144 | @methods = $obj->mo->methods; 145 | @expected = qw( as_method as_sub ); 146 | @not_expected = qw( as_func inexistant ); 147 | is_deeply 148 | scalar @methods->intersect( [ @expected, @not_expected ] )->sort, 149 | scalar @expected->sort, 150 | 'on an object'; 151 | 152 | $class = "My::MixedDefs::Child"; 153 | 154 | @methods = $class->mc->methods; 155 | @expected = qw( as_method as_sub as_method2 as_sub2 ); 156 | @not_expected = qw( as_func as_func2 inexistant ); 157 | is_deeply 158 | scalar @methods->intersect( [ @expected, @not_expected ] )->sort, 159 | scalar @expected->sort, 160 | 'on a child class'; 161 | 162 | $obj = bless {}, $class; 163 | 164 | @methods = $obj->mo->methods; 165 | @expected = qw( as_method as_sub as_method2 as_sub2 ); 166 | @not_expected = qw( as_func as_func2 inexistant ); 167 | is_deeply 168 | scalar @methods->intersect( [ @expected, @not_expected ] )->sort, 169 | scalar @expected->sort, 170 | 'on a child object'; 171 | 172 | can_ok( $class, 'as_func'); # sanity check 173 | } 174 | 175 | done_testing; 176 | -------------------------------------------------------------------------------- /t/Meta/reftype.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use perl5i::latest; 7 | 8 | use Test::More; 9 | 10 | my $obj = bless {}, "Foo"; 11 | is $obj->mo->reftype, "HASH"; 12 | 13 | is 42->mo->reftype, undef; 14 | is []->mo->reftype, "ARRAY"; 15 | is sub {}->mo->reftype, "CODE"; 16 | 17 | TODO: { 18 | local $TODO = "bare hashes and arrays give the wrong reftype"; 19 | 20 | my @array; 21 | is @array->mo->reftype, undef, "bare array"; 22 | 23 | my %hash; 24 | is %hash->mo->reftype, undef, "bare hash"; 25 | } 26 | 27 | done_testing(); 28 | -------------------------------------------------------------------------------- /t/Meta/super.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | { 10 | package Child; 11 | our @ISA = qw(Parent); 12 | 13 | sub bar { 14 | my $self = shift; 15 | $self->mo->super("super", @_); 16 | } 17 | 18 | # Watch out! An eval BLOCK will show up in caller(). 19 | sub with_eval { 20 | my $self = shift; 21 | return eval { $self->mo->super("super", @_) }; 22 | } 23 | } 24 | 25 | { 26 | package Parent; 27 | our @ISA = qw(GrandParent); 28 | 29 | sub bar { 30 | my $self = shift; 31 | return $self->mo->super(@_); 32 | } 33 | 34 | sub with_eval { 35 | my $self = shift; 36 | return $self->mo->super(@_); 37 | } 38 | } 39 | 40 | 41 | # Have a grand parent to make sure we dont' just keep looping 42 | { 43 | package GrandParent; 44 | 45 | sub new { 46 | my $class = shift; 47 | return bless {}, $class; 48 | } 49 | 50 | sub bar { 51 | my $self = shift; 52 | return "bar: @_"; 53 | } 54 | 55 | sub with_eval { 56 | my $self = shift; 57 | return "with_eval: @_"; 58 | } 59 | } 60 | 61 | 62 | # Try the basics 63 | { 64 | my $obj = Child->new; 65 | is $obj->bar(), "bar: super"; 66 | is $obj->bar(23, 42), "bar: super 23 42"; 67 | 68 | is $obj->with_eval(), "with_eval: super"; 69 | is $obj->with_eval(23, 42), "with_eval: super 23 42"; 70 | } 71 | 72 | 73 | # What happens when called outside a method? 74 | { 75 | my $obj = Child->new; 76 | ok !eval { $obj->mo->super(); }; 77 | is $@, sprintf "super() called outside a method at $0 line %d.\n", __LINE__ - 1; 78 | } 79 | 80 | 81 | # How about inside an unrelated class? 82 | { 83 | package NotAGrandparent; 84 | sub bar { "wibble" } 85 | 86 | package NotAParent; 87 | our @ISA = qw(NotAGrandparent); 88 | sub bar { 89 | my $obj = Child->new; 90 | return $obj->mo->super(42); 91 | } 92 | 93 | package main; 94 | 95 | ok !eval { NotAParent->bar; }; 96 | is $@, sprintf qq["NotAParent" is not a parent class of "Child" at $0 line %d.\n], __LINE__ - 6; 97 | } 98 | 99 | 100 | done_testing(); 101 | -------------------------------------------------------------------------------- /t/Meta/symbol_table.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | 7 | { 8 | package Foo; 9 | 10 | our %hash; 11 | our @array; 12 | our $scalar; 13 | sub function {} 14 | 15 | our %thing = ( foo => 42 ); 16 | sub thing { return 23 } 17 | } 18 | 19 | note "symbol_table"; { 20 | my $table = "Foo"->mc->symbol_table; 21 | 22 | is_deeply [$table->keys->sort], 23 | [sort qw(hash array scalar function thing)], 24 | "symbol_table"; 25 | 26 | my $glob = $table->{thing}; 27 | 28 | is_deeply *{$glob}{HASH}, { foo => 42 }, "glob contains a hash"; 29 | 30 | my $code = *{$glob}{CODE}; 31 | is $code->(), 23, "glob contains a code ref"; 32 | 33 | ok !*{$glob}{ARRAY}, "glob does not contain an array"; 34 | } 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /t/Want.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | sub foo { 7 | if( want('LIST') ) { 8 | return 1, 2, 3; 9 | } 10 | elsif (want('BOOL')) { 11 | return 0; 12 | } 13 | elsif (want(qw'SCALAR !REF')) { 14 | return 23; 15 | } 16 | elsif (want('HASH')) { 17 | return { foo => 17, bar => 23 }; 18 | } 19 | return; # You have to put this at the end to keep the compiler happy 20 | } 21 | 22 | 23 | { 24 | my @list = foo(3, 2, 1); 25 | for(1..3){ 26 | is( $list[$_-1], $_); 27 | } 28 | } 29 | 30 | { 31 | ok(!foo()); 32 | } 33 | 34 | TODO: { 35 | local $TODO = "want() with prototypes is busted, thinks its CODE"; 36 | is(foo(), 23 ); 37 | } 38 | 39 | { 40 | my %foo = %{foo()}; 41 | 42 | is($foo{foo}, 17); 43 | is($foo{bar}, 23); 44 | } 45 | 46 | 47 | # Don't export any of Want's other functions 48 | { 49 | ok !defined &rreturn; 50 | ok !defined &lnoreturn; 51 | } 52 | 53 | done_testing(); 54 | -------------------------------------------------------------------------------- /t/alias.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | use Test::Warn; 7 | 8 | # Test name construction 9 | { 10 | sub { 42 }->alias("foo"); 11 | is foo(), 42; 12 | 13 | sub { 23 }->alias("Local::Class", "foo"); 14 | is Local::Class->foo, 23; 15 | 16 | sub { 99 }->alias(qw(This Is A Little Silly)); 17 | is This::Is::A::Little::Silly(), 99; 18 | 19 | sub { 123 }->alias("Some::thing"); 20 | is Some::thing(), 123, "caller only prepended if there's no ::"; 21 | 22 | sub { 234 }->alias("this", "that"); 23 | is this::that(), 234, "caller not prepended if there's more than one"; 24 | 25 | sub bar { "wibble" } 26 | (\&bar)->alias("that"); 27 | is that(), "wibble"; 28 | } 29 | 30 | 31 | # Things other than code. 32 | { 33 | our $foo; 34 | (\23)->alias('foo'); 35 | is $foo, 23; 36 | 37 | our @bar; 38 | [1,2,3]->alias('bar'); 39 | is_deeply \@bar, [1,2,3]; 40 | 41 | our %baz; 42 | { foo => 23, bar => 42 }->alias('baz'); 43 | is_deeply \%baz, { foo => 23, bar => 42 }; 44 | } 45 | 46 | 47 | # Make sure its an alias and not a copy 48 | { 49 | my @src = qw(1 2 3); 50 | our @dest; 51 | @src->alias("dest"); 52 | is \@src, \@dest; 53 | 54 | my $src = \23; 55 | our $dest; 56 | 57 | $src->alias("dest"); 58 | is $src, \$dest; 59 | } 60 | 61 | 62 | # Errors 63 | { 64 | ok !eval { 65 | sub{}->alias(); 66 | 1; 67 | }; 68 | like $@, qr{^\QNot enough arguments given to alias()}; 69 | 70 | ok !eval { 71 | 23->alias("bar"); 72 | 1; 73 | }; 74 | like $@, qr{scalars cannot be aliased}; 75 | } 76 | 77 | 78 | # No redefine warnings: 79 | { 80 | sub egg { 42 } 81 | sub ham { 10 } 82 | warning_is { 83 | (\&egg)->alias('ham'); 84 | } undef, 'no warning'; 85 | } 86 | 87 | done_testing; 88 | -------------------------------------------------------------------------------- /t/as_hash.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | note 'array to hash'; { 7 | my @array = qw(a b c); 8 | my %hash = @array->as_hash; 9 | is_deeply \%hash, {a=>1, b=>1, c=>1}; 10 | 11 | @array = (4, 3, 2, 1); 12 | my $hash = @array->as_hash; 13 | is_deeply $hash, {4=>1, 3=>1, 2=>1, 1=>1}; 14 | } 15 | 16 | done_testing; 17 | -------------------------------------------------------------------------------- /t/autobox.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | use perl5i::latest; 4 | use Test::More 'no_plan'; 5 | 6 | my @array = ( 1, 2, 3 ); 7 | is @array->pop, 3; 8 | 9 | sub SCALAR::my_strip { 10 | $_[0] =~ s/^\s+//; 11 | $_[0] =~ s/\s+$//; 12 | } 13 | 14 | my $string = " foo "; 15 | $string->my_strip; 16 | is $string, "foo"; 17 | -------------------------------------------------------------------------------- /t/autodie.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | use Test::More "no_plan"; 5 | 6 | ok !eval { open my $fh, "hlaglaghlaghlagh"; 1 }; 7 | 8 | # Quiet "is not recognized as an internal or external command" on Windows. 9 | # Good candidate for a perl5i method to control redirection portably. 10 | if( $^O eq 'MSWin32' ) { 11 | ok !eval { system "haljlkjadlkjflajdf 2>NUL"; 1; }; 12 | } else { 13 | ok !eval { system "haljlkjadlkjflajdf"; 1; }; 14 | } 15 | -------------------------------------------------------------------------------- /t/autovivification.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | 7 | # Test with a hash ref 8 | { 9 | my $hash; 10 | my $val = $hash->{key}; 11 | is $hash, undef, "hash ref does not autoviv"; 12 | 13 | $val = $hash->{key1}{key2}; 14 | is $hash, undef, "hash ref does not autoviv"; 15 | } 16 | 17 | 18 | # And a regular hash 19 | { 20 | my %hash; 21 | my $val = $hash{key}; 22 | is_deeply scalar %hash->keys, [], "hash key does not autoviv"; 23 | 24 | $val = $hash{key1}{key2}; 25 | is_deeply scalar %hash->keys, [], "hash key does not autoviv"; 26 | } 27 | 28 | done_testing(); 29 | -------------------------------------------------------------------------------- /t/caller.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use perl5i::latest; 7 | 8 | use Test::More; 9 | 10 | sub test_caller { 11 | my $caller = caller(0); 12 | my @want = CORE::caller(0); 13 | 14 | cmp_ok @want, ">=", 9, "CORE::caller() sane"; 15 | is_deeply [caller(0)], \@want, "caller() in list context"; 16 | 17 | # Perl6::Caller doesn't do hints or bitmask and that's fine by me. 18 | for my $key (qw(package filename line subroutine 19 | hasargs wantarray evaltext is_require)) 20 | { 21 | my $have = $caller->$key(); 22 | my $want = shift @want; 23 | 24 | is $have, $want, "caller->$key"; 25 | } 26 | 27 | is caller(), CORE::caller(), "stringified caller"; 28 | } 29 | 30 | test_caller(); 31 | 32 | done_testing(); 33 | -------------------------------------------------------------------------------- /t/can.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | { 7 | package Foo; 8 | sub bar { 42 } 9 | } 10 | 11 | my $class = "Foo"; 12 | ok $class->can("bar"), "autoboxing vs can()"; 13 | 14 | ok $class->UNIVERSAL::can("bar"), " no really, it should work"; 15 | 16 | done_testing(); 17 | -------------------------------------------------------------------------------- /t/capture.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | 7 | note "scalar context"; { 8 | is capture { print "Hello" }, "Hello"; 9 | 10 | is capture { 11 | print "Hello"; 12 | warn "you should not see this"; 13 | }, "Hello", "stderr is silenced"; 14 | } 15 | 16 | 17 | note "tee"; { 18 | my($out, $err) = capture { 19 | capture { 20 | print "out"; 21 | warn "err"; 22 | } tee => 1; 23 | }; 24 | is $out, "out"; 25 | like $err, qr/^err\b/; 26 | } 27 | 28 | 29 | note "merge"; { 30 | my $out = capture { 31 | print "out"; 32 | print STDERR "err"; 33 | } merge => 1; 34 | 35 | is $out, "outerr"; 36 | } 37 | 38 | done_testing; 39 | -------------------------------------------------------------------------------- /t/carp.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | use Test::Warn; 9 | 10 | warnings_like { 11 | carp("foo"); 12 | } qr/^foo/; 13 | 14 | throws_ok { 15 | croak("bar"); 16 | } qr/^bar/; 17 | 18 | eval { croak "wibble" }; 19 | like $@, qr/^wibble at @{[ __FILE__ ]} line @{[ __LINE__ - 1 ]}.\n/; 20 | 21 | done_testing(); 22 | -------------------------------------------------------------------------------- /t/center.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | use Test::Warn; 7 | 8 | my $hello = 'hello'; 9 | 10 | is( $hello->center(7), ' hello ', 11 | '->center() with even length has equal whitespace on both sides' ); 12 | is( $hello->center(7,'-'), '-hello-', 13 | '->center() with even length has equal whitespace on both sides' ); 14 | 15 | is( $hello->center(8), ' hello ', 16 | '->center() with odd length pads left' ); 17 | 18 | is( $hello->center(4), 'hello', 19 | '->center() with too-short length returns the string unmodified' ); 20 | 21 | is( $hello->center(0), 'hello', 22 | '->center(0)' ); 23 | 24 | is( $hello->center(-1), 'hello', 25 | '->center(-1)' ); 26 | 27 | warning_like { 28 | is( $hello->center(undef), 'hello', 29 | '->center(undef)' ); 30 | } qr/^Use of uninitialized value for size in center\(\) at \Q$0\E line /; 31 | 32 | is( "even"->center(6, "-"), '-even-', 33 | '->center(6, "-")' ); 34 | 35 | is( "even"->center(7, "-"), '--even-', 36 | '->center(7, "-")' ); 37 | 38 | is( "even"->center(0, "-"), 'even', 39 | '->center(0, "-")' ); 40 | 41 | warning_like { 42 | is( $hello->center(10, "-=-"), '---hello--', 43 | '->center(undef)' ); 44 | } qr/^'-=-' is longer than one character, using '-' instead at \Q$0\E line /; 45 | 46 | # Test that center() always returns the correct length 47 | for my $size ($hello->length..20) { 48 | is( $hello->center($size)->length, $size, "center($size) returns that size" ); 49 | } 50 | 51 | done_testing(); 52 | -------------------------------------------------------------------------------- /t/chdir.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | { 7 | ok -e "t/chdir.t"; 8 | 9 | { 10 | local $CWD = "t"; 11 | ok -e "chdir.t"; 12 | } 13 | 14 | ok -e "t/chdir.t"; 15 | } 16 | 17 | { 18 | { 19 | local $CWD; 20 | push @CWD, 't'; 21 | ok -e 'chdir.t'; 22 | } 23 | ok -e 't/chdir.t'; 24 | } 25 | 26 | done_testing(); 27 | -------------------------------------------------------------------------------- /t/command_line_wrapper.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use Config; 6 | use ExtUtils::CBuilder; 7 | use File::Spec; 8 | use File::Temp qw(tempdir tempfile); 9 | 10 | use Test::More; 11 | 12 | my $perl5i; 13 | my $script_dir = File::Spec->catdir("blib", "script"); 14 | for my $wrapper (qw(perl5i perl5i.bat)) { 15 | $perl5i = File::Spec->catfile($script_dir, $wrapper); 16 | last if -e $perl5i; 17 | } 18 | my $perl5icmd = qq[$perl5i "-Ilib"]; 19 | my @perl5icmd = ($perl5i, "-Ilib"); 20 | 21 | ok -e $perl5i, "perl5i command line wrapper was built"; 22 | 23 | ok system(qq[$perl5icmd -e 1]) == 0, " and it runs"; 24 | 25 | is capture { system @perl5icmd, "-e", "say 'Hello'" }, "Hello\n", "Hello perl5i!"; 26 | 27 | like `$perl5icmd -h`, qr/disable all warnings/, 'perl5i -h works as expected'; 28 | 29 | like capture { system @perl5icmd, "-e", '$^X->say' }, qr/perl5i/, '$^X is perl5i'; 30 | 31 | is capture { system @perl5icmd, "-e", 'say @ARGV', 'foo', 'bar' }, "foobar\n", "-e with args"; 32 | 33 | is capture { system @perl5icmd, "-e", 'func foo() { say 42 } foo()' }, "42\n", "-e with Devel::Declare"; 34 | 35 | is capture { system @perl5icmd, '-wle', q[print 'Hello'] }, "Hello\n", "compound -e"; 36 | 37 | is capture { system @perl5icmd, "-Minteger", "-e", q[say 'Hello'] }, "Hello\n", 38 | "not fooled by -Module"; 39 | 40 | # Make sure it thinks its a one liner. 41 | is capture { system @perl5icmd, "-e", q[print $0] }, "-e", '$0 preserved'; 42 | is capture { system @perl5icmd, "-e", q[print __LINE__] }, 1, '__LINE__ preserved'; 43 | is capture { system @perl5icmd, "-e", q[print __FILE__] }, "-e", '__FILE__ preserved'; 44 | 45 | # Check it takes code from STDIN 46 | { 47 | my $out = capture { 48 | open( my $in, "|-", $perl5icmd ); 49 | print $in qq[say "Hello"\n]; 50 | close $in; 51 | }; 52 | 53 | is $out, "Hello\n", "reads code from stdin"; 54 | } 55 | 56 | # And from a file 57 | { 58 | my $dir = tempdir("perl5i-turd-XXXX", CLEANUP => 1, TMPDIR => 1); 59 | my($fh, $file) = tempfile(DIR => $dir); 60 | print $fh "say 'Hello';"; 61 | close $fh; 62 | 63 | is `$perl5icmd $file`, "Hello\n", "program in a file"; 64 | } 65 | 66 | # Check it doesn't have strict vars on 67 | is capture {system @perl5icmd, '-e', q($fun="yay"; say $fun;)}, "yay\n", 'no strict vars for perl5i'; 68 | is capture {system ($^X, '-Ilib', '-Mperl5i::latest', '-e', q|$fun="yay"; say $fun;|)}, 69 | "yay\n", q{no strict vars for perl -Mperl5i::latest -e '...'}; 70 | 71 | # It acts like Perl when given weird arguments. 72 | { 73 | # We expect these system calls to return non-zero 74 | no autodie "system"; 75 | 76 | my %tests = ( 77 | "-e with no code" => ["-e"], 78 | "null byte" => ["\\000", "-e"], 79 | ); 80 | 81 | %tests->each(func($test_name,$args) { 82 | is capture {system @perl5icmd, $args}, 83 | capture {system $^X, $args}, 84 | $test_name; 85 | }); 86 | } 87 | 88 | done_testing; 89 | -------------------------------------------------------------------------------- /t/commify.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | 7 | my @tests = ( 8 | { have => 1, want => 1 }, 9 | { have => 1234, want => "1,234" }, 10 | { have => 123456789, want => "123,456,789" }, 11 | { have => "123456789.1234", want => "123,456,789.1234" }, 12 | { have => -12345, want => "-12,345" }, 13 | { have => 123456789, want => "123.456.789", 14 | opts => { separator => ".", grouping => 3 } 15 | }, 16 | { have => 123456789, want => "1,23,45,67,89", 17 | opts => { grouping => 2, separator => "," } 18 | }, 19 | { have => 123456789, want => "123456789", 20 | opts => { grouping => 0, separator => "," } 21 | }, 22 | { have => "123456789.987", want => "123.456.789,987", 23 | opts => { separator => ".", decimal_point => "," } 24 | }, 25 | { have => "123456789", want => "123.456.789", 26 | opts => { separator => ".", decimal_point => "," } 27 | }, 28 | # Preserve the trailing dot 29 | { have => "123456789.", want => "123.456.789,", 30 | opts => { separator => ".", decimal_point => "," } 31 | }, 32 | { have => "123456789.0", want => "123.456.789,0", 33 | opts => { separator => ".", decimal_point => "," } 34 | }, 35 | { have => 12345.678, want => "12,345.678" }, 36 | { have => 0, want => "0" }, 37 | { have => 0.12, want => "0.12" }, 38 | ); 39 | 40 | 41 | for my $test (@tests) { 42 | my $have = $test->{have}; 43 | my $want = $test->{want}; 44 | my $opts = $test->{opts} || {}; 45 | 46 | # Format and flatten the options 47 | my $opts_string = $opts->mo->perl; 48 | $opts_string =~ s/\n/ /g; 49 | $opts_string =~ s/^\s*{//; 50 | $opts_string =~ s/}\s*$//; 51 | 52 | is $have->commify($opts), $want, "$have->commify($opts_string)"; 53 | } 54 | 55 | 56 | done_testing(); 57 | -------------------------------------------------------------------------------- /t/datetime.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More 'no_plan'; 6 | 7 | sub is_about { 8 | my( $a, $b, $name ) = @_; 9 | 10 | my $tb = Test::More->builder; 11 | 12 | my $test = ( abs( $a - $b ) <= 1 ); 13 | my $ret = $tb->ok( $test, $name ); 14 | if( !$ret ) { 15 | $tb->diag(< sub { CORE::localtime( $_[0] ) }, 33 | gmtime => sub { CORE::gmtime( $_[0] ) }, 34 | ); 35 | 36 | for my $name ( keys %funcs ) { 37 | my $have = \&{$name}; 38 | my $want = $funcs{$name}; 39 | 40 | my $date = $have->($time); 41 | isa_ok $date, 'DateTime', "$name returns a DateTime"; 42 | 43 | is $date, $want->($time), " scalar context"; 44 | is $date->year, ( $want->($time) )[5] + 1900, " method call"; 45 | is $date->epoch, $time, " epoch"; 46 | 47 | is_deeply [ $have->($time) ], [ $want->($time) ], " array context"; 48 | 49 | cmp_ok $have->()->year, ">=", 2009, " no args"; 50 | 51 | my @args = ($time); 52 | is $have->(@args), $want->(@args), " array argument"; 53 | 54 | like $date. " wibble", qr/ wibble$/, "DateTime doesn't bitch on concatenation"; 55 | } 56 | 57 | 58 | # Test time. 59 | { 60 | is_about time, CORE::time, "time"; 61 | isa_ok time, "DateTime", " is DateTime"; 62 | cmp_ok time->year, ">=", 2009; 63 | 64 | # Tests for subtraction, because DateTime doesn't like that. 65 | is_about time, time; 66 | is_about time - time - time, -CORE::time(); 67 | is_about 0 - time(), -CORE::time(); 68 | is_about time - 0, CORE::time(); 69 | 70 | # Test for addition 71 | is_about time + time, CORE::time + CORE::time; 72 | 73 | # Multiplication 74 | is_about time * 1, CORE::time; 75 | 76 | # Division 77 | is_about time / time, 1; 78 | } 79 | 80 | 81 | # test the object nature we are adding 82 | { 83 | my @methods1 = qw/sec min hour day month year day_of_week day_of_year is_dst/; 84 | my @methods2 = qw/second minute hour mday mon year dow doy is_dst/; 85 | my @methods3 = qw/sec min hour day_of_month mon year wday doy is_dst/; 86 | 87 | my $obj = gmtime($time); 88 | my @date = gmtime($time); 89 | 90 | # adjust for object's niceties 91 | $date[4]++; # month is 1 - 12 not 0 - 11 92 | $date[5] += 1900; # full year, not years since 1900 93 | $date[6] = 7 if $date[6] == 0; # In DateTime, Sunday is 7 94 | $date[7]++; # julian is 1 .. 365|366 not 0 .. 354|355 95 | 96 | for my $methods ( \( @methods1, @methods2, @methods3 ) ) { 97 | is_deeply [@date], [ map { $obj->$_ } @$methods ], "DateTime methods: @$methods"; 98 | } 99 | } 100 | -------------------------------------------------------------------------------- /t/die.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | use File::Temp qw(tempdir tempfile); 7 | use IPC::Open3; 8 | 9 | sub run_code { 10 | my $code = shift; 11 | 12 | # IPC::Open3, or more specifically waitpid(), will hang on Windows 13 | # if we pass the code in on STDIN. So use a temp file. 14 | my $dir = tempdir("perl5i-turd-XXXX", CLEANUP => 1, TMPDIR => 1); 15 | my($temp_fh, $tempfile) = tempfile(DIR => $dir); 16 | print $temp_fh <<"END"; 17 | use lib "lib"; 18 | use perl5i::latest; 19 | 20 | #line 1 test.plx 21 | $code; 22 | END 23 | close $temp_fh; 24 | 25 | #work around for open3 wierdness surrounding lexical filehandles 26 | #and stderr, $err must be true or stderr will go to stdout 27 | my $err = 1; 28 | my $pid = open3 my $in, my $out, $err, $^X, $tempfile 29 | or die "could not execute $^X: $!"; 30 | close $in; 31 | 32 | waitpid $pid, 0; 33 | 34 | # Normalize newlines 35 | binmode $out, ":crlf"; 36 | binmode $err, ":crlf"; 37 | 38 | my $rc = $? >> 8; 39 | my $output = join '', <$out>; 40 | my $error = join '', <$err>; 41 | return ($rc, $output, $error); 42 | } 43 | 44 | sub test { 45 | my ($code, $error, $test) = @_; 46 | my ($rc, $out, $err) = run_code $code; 47 | is $rc, 255, "$test exit code"; 48 | is $out, "", "$test stdout"; 49 | is $err, $error, "$test stderr"; 50 | } 51 | 52 | test 'die "a noble death"', "a noble death at test.plx line 1.\n", 'normal die'; 53 | test 'die "a noble death\n"', "a noble death\n", 'die without line'; 54 | test '$! = 5; die "a noble death\n"', "a noble death\n", 'die with $! = 5'; 55 | test '$! = 0; $? = 5 << 8; die "a noble death\n"', "a noble death\n", 'die with $! = 0 and $? = 5'; 56 | test '$! = 6; $? = 5 << 8; die "a noble death\n"', "a noble death\n", 'die with $! = 6 and $? = 5'; 57 | 58 | eval { die "oops\n" }; 59 | is $@, "oops\n", "die in block eval"; 60 | 61 | eval { die 1 .. 9, "\n" }; 62 | is $@, "123456789\n", "die in block eval with multiple arguments"; 63 | 64 | eval { die { found => 1 } }; 65 | is_deeply $@, { found => 1 }, "die with a reference is unaltered"; 66 | 67 | { 68 | my $error; 69 | local $SIG{__DIE__} = sub { $error = join '', @_ }; 70 | local $! = 0; 71 | eval { die "trigger\n" }; 72 | is $error, "trigger\n", "__DIE__ signal handler"; 73 | cmp_ok $!, '==', 0, "die() did not set errno"; 74 | } 75 | 76 | test 'package Foo; die "a noble death\n"', "a noble death\n", 'die in a different package'; 77 | 78 | done_testing(); 79 | -------------------------------------------------------------------------------- /t/diff.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | my @a = ( 0 .. 5 ); 10 | my @b = ( 3 .. 8 ); 11 | 12 | my $d; 13 | 14 | is_deeply( $d = @a->diff(\@b), [ 0, 1, 2 ], 'Simple number diff' ); 15 | is_deeply( $d = @b->diff(\@a), [ 6, 7, 8 ], 'Simple number diff' ); 16 | 17 | # No arguments 18 | is_deeply( $d = @a->diff, \@a, 'No arguments' ); 19 | 20 | # Empty array 21 | is_deeply( $d = @a->diff([]), \@a, 'Diff with an empty array'); 22 | is_deeply( $d = []->diff, [], 'Diff an empty array' ); 23 | 24 | # Context 25 | my @d = @a->diff(\@b); 26 | is scalar @d, 3, "Returns array in list context"; 27 | 28 | # Dies when called with non-arrayref arguments 29 | 30 | throws_ok { @a->diff('foo') } qr/Arguments must be/; 31 | throws_ok { @a->diff({ foo => 1 }) } qr/Arguments must be/; 32 | throws_ok { []->diff(\'foo') } qr/Arguments must be/; 33 | throws_ok { @a->diff(undef, \@a) } qr/Arguments must be/; 34 | 35 | # Works with strings also 36 | is_deeply( $d = [qw(foo bar)]->diff(['bar']), ['foo'], 'Works ok with strings' ); 37 | 38 | # Mix strings and numbers 39 | is_deeply( $d = [qw(foo bar)]->diff(\@a), [qw(foo bar)], 'Mix strings and numbers' ); 40 | 41 | # Mix numbers and strings 42 | is_deeply( $d = @a->diff([qw(foo bar)]), \@a, 'Mix numbers and strings' ); 43 | 44 | # Ordering shouldn't matter in the top level array 45 | is_deeply( $d = [ 1, 2 ]->diff([ 2, 1 ]), [] ); 46 | 47 | # ... but it matters for there down ( see [ github 96 ] ) 48 | is_deeply( $d = [ [ 1, 2 ] ]->diff([ [ 2, 1 ] ]), [ [ 1, 2 ] ] ); 49 | 50 | # Diff more than two arrays 51 | is_deeply( $d = @a->diff(\@b, [ 'foo' ] ), [ 0, 1, 2 ], 'Diff more than two arrays' ); 52 | is_deeply( $d = @a->diff(\@b, [ 1, 2 ] ), [ 0 ], 'Diff more than two arrays' ); 53 | 54 | is_deeply( 55 | $d = [ { foo => 1 }, { foo => \2 } ]->diff( [ { foo => \2 } ] ), 56 | [ { foo => 1 } ], 57 | 'Works for nested data structures', 58 | ); 59 | 60 | # Test undef 61 | { 62 | my @array = (1,2,undef,4); 63 | is_deeply( $d = @array->diff([1,2,4,undef]), [] ); 64 | is_deeply( $d = @array->diff([1,2,4]), [undef] ); 65 | } 66 | 67 | # Test REF 68 | { 69 | my $ref1 = \42; 70 | my $ref2 = \42; 71 | my @array = (1,2,\$ref1,4); 72 | is_deeply( $d = @array->diff([4,\$ref2,2,1]), [] ); 73 | 74 | my $ref3 = \23; 75 | is_deeply( $d = @array->diff([1,2,\$ref3,4]), [\$ref1] ); 76 | } 77 | 78 | # Stress test deep comparison 79 | 80 | my $code = sub { 'foo' }; 81 | 82 | my $foo = [ 83 | qw( foo bar baz ), # plain elements 84 | { foo => 2 }, # hash reference 85 | { bar => 1 }, # hash reference 86 | [ # array reference of ... 87 | qw( foo bar baz ), # plain elements and ... 88 | { foo => { foo => $code } } # hash reference with hash ref as value 89 | ] # with code ref as value 90 | ]; 91 | 92 | my $bar = [ 93 | qw( foo baz ), # bar is missing 94 | { foo => 1 }, # 1 != 2, bar =! foo 95 | [ # this arrayref is identical 96 | qw( foo bar baz ), 97 | { foo => { foo => $code } } 98 | ], 99 | [ qw( foo baz ), \'gorch' ] # this is unique to $bar 100 | ]; 101 | 102 | is_deeply( $d = $foo->diff($bar), [ 'bar', { foo => 2 }, { bar => 1 } ], "stress test 1" ); 103 | is_deeply( $d = $bar->diff($foo), [ { foo => 1 }, [qw(foo baz), \'gorch'] ], "stress test 2" ); 104 | 105 | is_deeply( $d = [ $code ]->diff([ sub { 'bar' }]), [ $code ] ); 106 | 107 | # Test overloading 108 | { 109 | package Number; 110 | use overload 111 | '0+' => sub { 42 }, 112 | fallback => 1; 113 | 114 | sub new { bless {} } 115 | } 116 | 117 | { 118 | package String; 119 | use overload 120 | '""' => sub { 'foo' }, 121 | fallback => 1; 122 | 123 | sub new { bless {} } 124 | } 125 | 126 | my $answer = Number->new; 127 | my $string = String->new; 128 | 129 | # Minimal testing of overloaded classes 130 | ok( $answer == 42 ); 131 | ok( $string eq 'foo' ); 132 | 133 | is_deeply( $d = [ $answer, $string ]->diff([ 'foo', 42 ]), [] ); 134 | 135 | # Overloaded objects vs. scalars 136 | is_deeply( $d = [ $answer, $string ]->diff([ 'foo' ]), [ $answer ] ); 137 | is_deeply( $d = [ $answer, $string ]->diff([ 42 ]), [ $string ] ); 138 | is_deeply( $d = [ $answer, $string ]->diff([ 42 ]), [ 'foo' ] ); 139 | is_deeply( $d = [ 42, 'foo' ]->diff([ $answer ]), [ 'foo' ] ); 140 | is_deeply( $d = [ 42, 'foo' ]->diff([ $string ]), [ 42 ] ); 141 | 142 | # Overloaded objects vs. overloaded objects. 143 | is_deeply( $d = [ $answer, $string ]->diff([ $string ]), [ $answer ] ); 144 | is_deeply( $d = [ $answer, $string ]->diff([ $answer ]), [ $string ] ); 145 | is_deeply( $d = [ $answer, $string ]->diff([ $answer ]), [ 'foo' ] ); 146 | 147 | 148 | # Objects vs. objects 149 | my $object = bless {}, 'Object'; 150 | 151 | is_deeply( $d = [ $object ]->diff( [ $object ] ), [ ] ); 152 | is_deeply( $d = [ $object ]->diff( [ ] ), [ $object ] ); 153 | 154 | # Overloaded objects vs. non-overloaded objects 155 | is_deeply( $d = [ $object ]->diff( [ $answer ] ), [ $object ] ); 156 | is_deeply( $d = [ $answer ]->diff( [ $object ] ), [ $answer ] ); 157 | 158 | done_testing(); 159 | -------------------------------------------------------------------------------- /t/dump/array.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | use perl5i::latest; 4 | use Test::More tests => 3; 5 | 6 | my @a = ( 1 .. 10 ); 7 | my $ref = \@a; 8 | 9 | is_deeply eval [@a]->mo->perl, [@a]; 10 | 11 | is_deeply eval @a->mo->perl, \@a; 12 | 13 | is_deeply eval $ref->mo->perl, $ref; 14 | -------------------------------------------------------------------------------- /t/dump/code.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Test dumping code refs 4 | 5 | use perl5i::latest; 6 | use Test::More; 7 | 8 | sub code_dump_ok($$;$) { 9 | my( $code, $want, $name ) = @_; 10 | 11 | my $ref = eval( $code->mo->perl ); 12 | ok( $ref, "dump eval'd" ) or do { diag $@; return; }; 13 | is_deeply [ $ref->() ], $want, $name; 14 | } 15 | 16 | 17 | # Test closures 18 | { 19 | my $foo = 42; 20 | 21 | sub closure { 22 | return $foo; 23 | } 24 | } 25 | 26 | my $closure = \&closure; 27 | TODO: { 28 | local $TODO = "closures aren't dumped properly"; 29 | code_dump_ok $closure, [42], "scalar code ref dump"; 30 | } 31 | 32 | code_dump_ok sub { 23 }, [23], "anon sub dump"; 33 | 34 | done_testing(); 35 | -------------------------------------------------------------------------------- /t/dump/formats.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my $ref = [1..10]; 7 | 8 | is_deeply $ref->mo->as_perl, $ref->mo->perl, 'perl'; 9 | is_deeply $ref->mo->as_json, $ref->mo->dump(format=>'json'), 'json'; 10 | is_deeply $ref->mo->as_yaml, $ref->mo->dump(format=>'yaml'), 'yaml'; 11 | 12 | done_testing; 13 | 14 | -------------------------------------------------------------------------------- /t/dump/hash.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | use perl5i::latest; 4 | use Test::More tests => 5; 5 | 6 | my %h = ( 7 | a => 1, 8 | b => 2, 9 | c => 3 10 | ); 11 | my $ref = \%h; 12 | 13 | is_deeply eval( {%h}->mo->perl ), {%h}; 14 | 15 | is_deeply eval %h->mo->perl, \%h; 16 | 17 | is_deeply eval $ref->mo->perl, $ref; 18 | 19 | { 20 | use JSON::MaybeXS; 21 | is_deeply decode_json( %h->mo->dump( format => "json" ) ), \%h; 22 | } 23 | 24 | { 25 | use YAML::Any; 26 | is_deeply Load( %h->mo->dump( format => "yaml" ) ), \%h, "dump as yaml"; 27 | } 28 | -------------------------------------------------------------------------------- /t/dump/obj.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | { 7 | package Foo; 8 | sub new { 9 | my $class = shift; 10 | my $thing = shift; 11 | return bless $thing, $class; 12 | } 13 | } 14 | 15 | my $hash = { foo => 42 }; 16 | my $obj = Foo->new($hash); 17 | is_deeply eval $obj->mo->perl, $hash; 18 | isa_ok( eval $obj->mo->perl, "Foo"); 19 | 20 | is_deeply eval $obj->mo->dump, $hash; 21 | is_deeply eval $obj->mo->dump( format => "perl" ), $hash; 22 | 23 | { 24 | use JSON::MaybeXS; 25 | is_deeply decode_json( $obj->mo->dump( format => "json" ) ), $hash; 26 | } 27 | 28 | { 29 | use YAML::Any; 30 | is_deeply Load( $obj->mo->dump( format => "yaml" ) ), $obj, "dump as yaml"; 31 | } 32 | 33 | done_testing(); 34 | -------------------------------------------------------------------------------- /t/dump/scalar.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | use perl5i::latest; 4 | use Test::More tests => 4; 5 | 6 | my $str = "bar"; 7 | my $num = 0.1; 8 | 9 | is eval "foo"->mo->perl, "foo"; 10 | 11 | is eval 5->mo->perl, 5; 12 | 13 | is eval $str->mo->perl, $str; 14 | 15 | is eval $num->mo->perl, $num; 16 | -------------------------------------------------------------------------------- /t/each.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | note "each with no signature"; { 7 | my %want = (foo => 23, bar => 42); 8 | 9 | my %have; 10 | %want->each( sub { $have{$_[0]} = $_[1] } ); 11 | 12 | is_deeply \%have, \%want; 13 | } 14 | 15 | 16 | note "each with one arg"; { 17 | my %want = (foo => 23, bar => 42); 18 | 19 | my %have; 20 | %want->each( func($k) { $have{$k} = 1 } ); 21 | 22 | is_deeply \%have, { foo => 1, bar => 1 }; 23 | } 24 | 25 | 26 | note "each with two args"; { 27 | my %want = (foo => 23, bar => 42); 28 | 29 | my %have; 30 | %want->each( func($k,$v) { $have{$k} = $v } ); 31 | 32 | is_deeply \%have, \%want; 33 | } 34 | 35 | 36 | note "each call is safe"; { 37 | my %want = (foo => 23, bar => 42, baz => 99, biff => 66); 38 | 39 | # Call each once on %want to start the iterator attached to %want 40 | my($k,$v) = each %want; 41 | 42 | my %have; 43 | %want->each( func($k,$v) { $have{$k} = $v } ); 44 | 45 | is_deeply \%have, \%want; 46 | } 47 | 48 | note "Tests adapted from Hash::StoredIterator"; 49 | 50 | my @want_outer = ( 51 | [a => 1], 52 | [b => 2], 53 | [c => 3], 54 | ); 55 | 56 | my @want_inner = ( 57 | [a => 1], 58 | [a => 1], 59 | [a => 1], 60 | [b => 2], 61 | [b => 2], 62 | [b => 2], 63 | [c => 3], 64 | [c => 3], 65 | [c => 3], 66 | ); 67 | 68 | my %hash = ( a => 1, b => 2, c => 3 ); 69 | 70 | sub interference { 71 | my @garbage = keys(%hash), values(%hash); 72 | while ( my ( $k, $v ) = each(%hash) ) { 73 | # Effectively do nothing 74 | my $foo = $k . $v; 75 | } 76 | }; 77 | 78 | { 79 | my @inner; 80 | my @outer; 81 | 82 | %hash->each( func( $k, $v ) { 83 | ok( $k, "Got key" ); 84 | ok( $v, "Got val" ); 85 | is( $k, $_, '$_ is set to key' ); 86 | is( $k, $a, '$a is set to key' ); 87 | is( $v, $b, '$b is set to val' ); 88 | 89 | push @outer => [$k, $v]; 90 | interference(); 91 | 92 | %hash->each( func( $k2, $v2 ) { 93 | is( $k2, $_, '$_ is set to key' ); 94 | is( $k2, $a, '$a is set to key' ); 95 | is( $v2, $b, '$b is set to val' ); 96 | 97 | push @inner => [$k, $v]; 98 | 99 | interference(); 100 | }); 101 | 102 | is( $k, $_, '$_ is not squashed by inner loop' ); 103 | is( $k, $a, '$a is not squashed by inner loop' ); 104 | is( $v, $b, '$a is not squashed by inner loop' ); 105 | }); 106 | 107 | is_deeply( 108 | [sort { $a->[0] cmp $b->[0] } @outer], 109 | \@want_outer, 110 | "Outer loop got all keys" 111 | ); 112 | 113 | is_deeply( 114 | [sort { $a->[0] cmp $b->[0] } @inner], 115 | \@want_inner, 116 | "Inner loop got all keys multiple times" 117 | ); 118 | } 119 | 120 | done_testing; 121 | -------------------------------------------------------------------------------- /t/equal.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # Glassbox test of the internal are_equal function. 4 | 5 | use perl5i::latest; 6 | use Test::More; 7 | 8 | # Load the latest version of equal.pm and alias are_equal() to equal 9 | # for convenience 10 | { 11 | my $equal_class = perl5i::VERSION->latest . "::equal"; 12 | $equal_class->require; 13 | 14 | # autobox hijacks can() to look at the autobox SCALAR class 15 | $equal_class->UNIVERSAL::can("are_equal")->alias("equal"); 16 | } 17 | 18 | { 19 | package Number; 20 | use overload 21 | '0+' => sub { 42 }, 22 | fallback => 1; 23 | 24 | sub new { bless {} } 25 | } 26 | 27 | { 28 | package String; 29 | use overload 30 | '""' => sub { 'foo' }, 31 | fallback => 1; 32 | 33 | sub new { bless {} } 34 | } 35 | 36 | # Minimal testing of overloaded classes 37 | ok( Number->new == 42, "Number class" ); 38 | ok( String->new eq 'foo', "String class" ); 39 | 40 | my %reftype = ( 41 | array => [42], 42 | hash => { 4 => 2 }, 43 | scalar => \42, 44 | code => sub { 42 }, 45 | number => 42, 46 | string => 'foo', 47 | undef => undef, 48 | object => bless({}, 'Object'), 49 | ref => \\'lol', 50 | glob => \*STDIN, 51 | ); 52 | 53 | { 54 | # Everything should be equal to itself 55 | ok( equal( $reftype{$_}, $reftype{$_} ), "$_ equals itself" ) for keys %reftype; 56 | 57 | # ... and different from everything else 58 | for my $reftype ( keys %reftype ) { 59 | 60 | my @other_refs = grep { $_ ne $reftype } keys %reftype; 61 | 62 | ok( !equal( $reftype{$reftype}, $reftype{$_} ), $reftype . ' not equal ' . $_ ) 63 | for @other_refs; 64 | } 65 | 66 | } 67 | 68 | # Nested data structures 69 | { 70 | my $nested1 = [ qw( foo bar baz ), { foo => { foo => $reftype{code} } } ]; 71 | my $nested2 = [ qw( foo bar baz ), { foo => { foo => $reftype{code} } } ]; 72 | my $nested3 = [ qw( foo baz ), { foo => { foo => $reftype{code} } } ]; 73 | 74 | ok equal($nested1, $nested2), "Two equivalent nested data structures"; 75 | ok !equal($nested1, $nested3), "Two non-equal nested data structures"; 76 | } 77 | 78 | # Overloaded objects 79 | { 80 | 81 | my $number = Number->new; 82 | 83 | ok equal($number, $number), "OBJ== equal OBJ=="; 84 | ok equal($number, $reftype{number}), "OBJ== equals number"; 85 | 86 | my @other_refs = grep { $_ ne 'number' } keys %reftype; 87 | ok( !equal( $number, $reftype{$_} ), "OBJ== not equal to $_" ) for @other_refs; 88 | 89 | my $string = String->new; 90 | 91 | ok equal($string, $string), qq{OBJ"" equal OBJ""}; 92 | ok equal($string, $reftype{string}), qq{OBJ"" equal string}; 93 | 94 | @other_refs = grep { $_ ne 'string' } keys %reftype; 95 | ok( !equal( $string, $reftype{$_} ), qq{OBJ"" not equal to $_} ) for @other_refs; 96 | } 97 | 98 | done_testing(); 99 | -------------------------------------------------------------------------------- /t/everything_is_an_object.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use perl5i::latest; 7 | 8 | use Test::More; 9 | 10 | { 11 | package Foo; 12 | sub bar {} 13 | } 14 | 15 | isa_ok "Foo", "UNIVERSAL"; 16 | 17 | # autobox changed the way isa() works and now this fails 18 | TODO: { 19 | local $TODO = '42->isa("UNIVERSAL") and autobox conflict, see [github #114]'; 20 | ok 42->isa("UNIVERSAL"), "autoboxed things are objects"; 21 | } 22 | 23 | done_testing(); 24 | -------------------------------------------------------------------------------- /t/flip.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | my %hash = ( 1 => 'foo', 2 => 'bar' ); 10 | my $f; 11 | 12 | is_deeply( $f = %hash->flip, { foo => 1, bar => 2 } ); 13 | 14 | my %f = %hash->flip; 15 | 16 | is_deeply( \%f, { foo => 1, bar => 2 }, "Returns hash in list context" ); 17 | 18 | my %nested = ( 1 => { foo => 'bar' }, 2 => 'bar' ); 19 | 20 | dies_ok { %nested->flip } 'Dies if values are not valid hash keys'; 21 | 22 | done_testing; 23 | -------------------------------------------------------------------------------- /t/foreach.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | 7 | # Subroutine, empty array 8 | { 9 | my @result; 10 | my @array = (); 11 | @array->foreach(sub { push @result, $_[0] }); 12 | 13 | is_deeply \@result, []; 14 | } 15 | 16 | # Subroutine, no signature 17 | { 18 | my @result; 19 | my @array = (1,2,3,4); 20 | @array->foreach(sub { push @result, $_[0] }); 21 | 22 | is_deeply \@result, [1,2,3,4]; 23 | } 24 | 25 | 26 | # Subroutine with signature 27 | { 28 | my @result; 29 | my @array = (1,2,3,4); 30 | @array->foreach(func($a,$b) { push @result, $a.$b }); 31 | 32 | is_deeply \@result, ["12","34"]; 33 | } 34 | 35 | 36 | # Subroutine with signature, wrong scale of arguments 37 | # XXX Should this die? 38 | { 39 | my @result; 40 | my @array = (1,2,3,4,5); 41 | @array->foreach(func($a,$b) { 42 | $b //= ''; 43 | push @result, $a.$b 44 | }); 45 | 46 | is_deeply \@result, ["12","34", "5"]; 47 | } 48 | 49 | 50 | # Subroutine that takes no arguments 51 | { 52 | my @result; 53 | my @array = (1,2,3,4,5); 54 | ok !eval { @array->foreach(func() {}); 1 }; 55 | is $@, sprintf "Function passed to foreach takes no arguments at %s line %d.\n", 56 | __FILE__, __LINE__-2; 57 | } 58 | 59 | done_testing; 60 | -------------------------------------------------------------------------------- /t/github164.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # This tests that a bug in indirect.pm which could cause a segfault does not 4 | # come back. See github 164 and rt.cpan.org 60378. 5 | 6 | use perl5i::latest; 7 | use Test::More; 8 | 9 | eval { 10 | no warnings; 11 | my $x; my $y; "@{[ $x->$y ]}"; 12 | }; 13 | pass("Did not segfault"); 14 | 15 | done_testing(1); 16 | -------------------------------------------------------------------------------- /t/grep.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | my @array = qw( foo bar baz ); 10 | my $d; 11 | 12 | lives_ok { @array->grep( sub { 42 } ) } "Should accept code refs"; 13 | lives_ok { @array->grep( qr/foo/ ) } "Should accept Regexps"; 14 | 15 | is_deeply( $d = @array->grep('foo'), [qw( foo )], "Works with SCALAR" ); 16 | is_deeply( $d = @array->grep('zar'), [], "Works with SCALAR" ); 17 | is_deeply( $d = @array->grep(qr/^ba/), [qw( bar baz )], "Works with Regexp" ); 18 | is_deeply( $d = @array->grep(+{ boo => 'boy' }), [], "Works with HASH" ); 19 | is_deeply( $d = @array->grep([qw(boo boy)]), [], "Works with ARRAY" ); 20 | is_deeply( $d = @array->grep([qw(foo baz)]), [qw(foo baz)], "Works with ARRAY" ); 21 | is_deeply( $d = @array->grep(sub { /^ba/ }), [qw( bar baz )], "... as with Code refs" ); 22 | 23 | # context 24 | my @d = @array->grep(qr/^ba/); 25 | 26 | is scalar @d, 2, "Returns an array in list context"; 27 | 28 | done_testing(); 29 | -------------------------------------------------------------------------------- /t/hash-diff.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | 7 | use Test::More; 8 | use Test::perl5i; 9 | 10 | { 11 | # Error checking 12 | 13 | my $h; 14 | 15 | is_deeply $h = { a => 1 }->diff, { a => 1 }; 16 | is_deeply $h = {}->diff(), {}; 17 | is_deeply $h = {}->diff( {} ), {}; 18 | throws_ok { $h = {}->diff('foo') } qr/Arguments must be/; 19 | } 20 | 21 | { 22 | my %first = ( foo => 1, bar => 2, baz => 3 ); 23 | 24 | my %second = (foo => 1, baz => 2); 25 | 26 | my %diff = %first->diff(\%second); 27 | 28 | is_deeply \%diff, { bar => 2, baz => 3 }; 29 | } 30 | 31 | { 32 | my %first = ( foo => { bar => 1 }, baz => 3 ); 33 | my %second = ( foo => 2, baz => 3 ); 34 | my %third = ( foo => { bar => 2 }, quux => [ 'hai' ] ); 35 | 36 | my %diff = %first->diff(\%second, \%third); 37 | 38 | is_deeply \%diff, { foo => { bar => 1 } }; 39 | } 40 | 41 | done_testing; 42 | -------------------------------------------------------------------------------- /t/hash-intersect.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | 7 | use Test::More; 8 | use Test::perl5i; 9 | 10 | { 11 | # Error checking 12 | 13 | my $h; 14 | 15 | is_deeply $h = { a => 1 }->intersect, { a => 1 }; 16 | is_deeply $h = {}->intersect(), {}; 17 | is_deeply $h = {}->intersect( {} ), {}; 18 | throws_ok { $h = {}->intersect('foo') } qr/Arguments must be/; 19 | } 20 | 21 | { 22 | my %first = ( foo => 1, bar => 2, baz => 3 ); 23 | 24 | my %second = (foo => 1, baz => 2); 25 | 26 | my %intersect = %first->intersect(\%second); 27 | 28 | is_deeply \%intersect, { foo => 1 }; 29 | } 30 | 31 | { 32 | my %first = ( foo => { bar => 1 }, baz => 3 ); 33 | my %second = ( foo => { bar => 1 }, baz => 3 ); 34 | my %third = ( foo => { bar => 1 }, quux => [ 'hai' ] ); 35 | 36 | my %intersect = %first->intersect(\%second, \%third); 37 | 38 | is_deeply \%intersect, { foo => { bar => 1 } }; 39 | } 40 | 41 | done_testing; 42 | -------------------------------------------------------------------------------- /t/hash-merge.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use Test::More; 3 | use perl5i::latest; 4 | 5 | my $a = { a => 1 }; 6 | my $b = { a => 100, b => 2 }; 7 | my $m; 8 | 9 | is_deeply( $m = $a->merge($b), { a => 100, b => 2 } ); 10 | 11 | is_deeply( $m = $b->merge($a), { a => 1, b => 2 }, "Rightmost precedence" ); 12 | 13 | is_deeply( $m = $a->merge( $b, { a => 0 } ), { a => 0, b => 2 }, "Three arguments" ); 14 | 15 | is_deeply( 16 | $m = { 100 => { 1 => 2 } }->merge( { 100 => 'foo' } ), 17 | { 100 => 'foo' }, 18 | 'Works for nested hashes also' 19 | ); 20 | my %merged = $a->merge($b); 21 | 22 | is_deeply( \%merged, { a => 100, b => 2 }, "Returns hash in list context" ); 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /t/intersect.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | my @a = ( 0 .. 5 ); 10 | my @b = ( 3 .. 8 ); 11 | my $i; 12 | 13 | is_deeply( $i = @a->intersect(\@b), [ 3, 4, 5 ], 'Simple number intersect' ); 14 | is_deeply( $i = @b->intersect(\@a), [ 3, 4, 5 ], 'Simple number intersect' ); 15 | 16 | my @i = @b->intersect(\@a); 17 | 18 | is scalar @i, 3, "Returns an array in list context"; 19 | 20 | # No arguments 21 | is_deeply( $i = @a->intersect, \@a, 'No arguments' ); 22 | 23 | # Empty array 24 | is_deeply( $i = @a->intersect([]), [], 'Intersect with an empty array'); 25 | 26 | is_deeply( $i = []->diff, [], 'Diff an empty array' ); 27 | 28 | # Dies when called with non-arrayref arguments 29 | 30 | throws_ok { @a->intersect('foo') } qr/Arguments must be/; 31 | throws_ok { @a->intersect({ foo => 1 }) } qr/Arguments must be/; 32 | throws_ok { []->intersect(\'foo') } qr/Arguments must be/; 33 | throws_ok { @a->intersect(undef, \@a) } qr/Arguments must be/; 34 | 35 | # Works with strings also 36 | is_deeply( $i = [qw(foo bar)]->intersect(['bar']), ['bar'], 'Works ok with strings' ); 37 | 38 | # Mix strings and numbers 39 | is_deeply( $i = [qw(foo bar)]->intersect(\@a), [], 'Mix strings and numbers' ); 40 | 41 | # Mix numbers and strings 42 | is_deeply( $i = @a->intersect([qw(foo bar)]), [], 'Mix numbers and strings' ); 43 | 44 | # Ordering shouldn't matter in the top level array 45 | is_deeply( $i = [ 1, 2 ]->intersect([ 2, 1 ]), [ 1, 2, ] ); 46 | 47 | # ... but it matters for there down ( see [ github 96 ] ) 48 | is_deeply( $i = [ [ 1, 2 ] ]->intersect([ [ 2, 1 ] ]), [ ] ); 49 | 50 | # Diff more than two arrays 51 | is_deeply( $i = @a->intersect(\@b, [ 4, 'foo' ] ), [ 4 ], 'Intersect more than two arrays' ); 52 | is_deeply( $i = @a->intersect(\@b, [ 3, 5, 12 ] ), [ 3, 5 ], 'Intersect more than two arrays' ); 53 | 54 | is_deeply( 55 | $i = [ { foo => 1 }, { foo => \2 } ]->intersect( [ { foo => \2 } ] ), 56 | [ { foo => \2 } ], 57 | 'Works for nested data structures', 58 | ); 59 | 60 | # Test undef 61 | { 62 | my @array = (1,2,undef,4); 63 | is_deeply( $i = @array->intersect([1,2,4,undef]), [ 1, 2, undef, 4 ] ); 64 | is_deeply( $i = @array->intersect([1,2,4]), [ 1, 2, 4 ] ); 65 | } 66 | 67 | # Test REF 68 | { 69 | my $ref1 = \42; 70 | my $ref2 = \42; 71 | my @array = (1,2,\$ref1,4); 72 | is_deeply( $i = @array->intersect([4,\$ref2,2,1]), \@array ); 73 | 74 | my $ref3 = \23; 75 | is_deeply( $i = @array->intersect([1,2,\$ref3,4]), [1, 2, 4] ); 76 | } 77 | 78 | # Stress test deep comparison 79 | 80 | my $code = sub { 'foo' }; 81 | 82 | my $foo = [ 83 | qw( foo bar baz ), # plain elements 84 | { foo => 2 }, # hash reference 85 | { bar => 1 }, # hash reference 86 | [ # array reference of ... 87 | qw( foo bar baz ), # plain elements and ... 88 | { foo => { foo => $code } } # hash reference with hash ref as value 89 | ] # with code ref as value 90 | ]; 91 | 92 | my $bar = [ 93 | qw( foo baz ), # bar is missing 94 | { foo => 1 }, # 1 != 2, bar =! foo 95 | [ # this arrayref is identical 96 | qw( foo bar baz ), 97 | { foo => { foo => $code } } 98 | ], 99 | [ qw( foo baz ), \'gorch' ] # this is unique to $bar 100 | ]; 101 | 102 | is_deeply( 103 | $i = $foo->intersect($bar), 104 | [ 'foo', 'baz', [ qw(foo bar baz), { foo => { foo => $code } } ] ], 105 | "stress test 1" 106 | ); 107 | is_deeply( 108 | $i = $bar->intersect($foo), 109 | [ 'foo', 'baz', [ qw(foo bar baz), { foo => { foo => $code } } ] ], 110 | "stress test 2" 111 | ); 112 | 113 | is_deeply( $i = [ $code ]->intersect([ sub { 'bar' }]), [ ] ); 114 | is_deeply( $i = [ $code ]->intersect([ $code ]), [ $code ] ); 115 | 116 | # Test overloading 117 | { 118 | package Number; 119 | use overload 120 | '0+' => sub { 42 }, 121 | fallback => 1; 122 | 123 | sub new { bless {} } 124 | } 125 | 126 | { 127 | package String; 128 | use overload 129 | '""' => sub { 'foo' }, 130 | fallback => 1; 131 | 132 | sub new { bless {} } 133 | } 134 | 135 | my $answer = Number->new; 136 | my $string = String->new; 137 | 138 | # Minimal testing of overloaded classes 139 | ok( $answer == 42 ); 140 | ok( $string eq 'foo' ); 141 | 142 | is_deeply( $i = [ $answer, $string ]->intersect([ 'foo', 42 ]), [ $answer, $string ] ); 143 | 144 | # Overloaded objects vs. scalars 145 | is_deeply( $i = [ $answer, $string ]->intersect([ 'foo' ]), [ $string ] ); 146 | is_deeply( $i = [ $answer, $string ]->intersect([ 42 ]), [ $answer ] ); 147 | is_deeply( $i = [ 42, 'foo' ]->intersect([ $answer ]), [ 42 ] ); 148 | is_deeply( $i = [ 42, 'foo' ]->intersect([ $string ]), [ 'foo' ] ); 149 | 150 | # Overloaded objects vs. overloaded objects. 151 | is_deeply( $i = [ $answer, $string ]->diff([ $string ]), [ $answer ] ); 152 | is_deeply( $i = [ $answer, $string ]->diff([ $answer ]), [ $string ] ); 153 | is_deeply( $i = [ $answer, $string ]->diff([ $answer ]), [ 'foo' ] ); 154 | 155 | 156 | # Objects vs. objects 157 | my $object = bless {}, 'Object'; 158 | 159 | is_deeply( $i = [ $object ]->intersect( [ $object ]), [ $object ] ); 160 | 161 | # Overloaded objects vs. non-overloaded objects 162 | is_deeply( $i = [ $object ]->intersect( [ $answer ] ), [ ] ); 163 | is_deeply( $i = [ $answer ]->intersect( [ $object ] ), [ ] ); 164 | 165 | done_testing(); 166 | -------------------------------------------------------------------------------- /t/io-handle.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | open my $fh, "<", $0; 7 | ok eval { $fh->autoflush(1); 1; } or die $@; 8 | 9 | done_testing(); 10 | -------------------------------------------------------------------------------- /t/is_module_name.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Before Test::More is loaded so it is utf8'd. 4 | use perl5i::latest; 5 | use Test::More; 6 | 7 | my @valid_names = ( 8 | "foo", 9 | "bar123", 10 | "Foo213::456", 11 | "f", 12 | "a::b", 13 | "öø::bår", 14 | ); 15 | 16 | my @invalid_names = ( 17 | "::a::c", 18 | "123", 19 | "1abc", 20 | 'foo$bar', 21 | '$foo::bar', 22 | 'foo/bar' 23 | ); 24 | 25 | for my $name (@valid_names) { 26 | ok $name->is_module_name, "valid: $name"; 27 | } 28 | 29 | for my $name (@invalid_names) { 30 | ok !$name->is_module_name, "invalid: $name"; 31 | } 32 | 33 | done_testing; 34 | -------------------------------------------------------------------------------- /t/lexical.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | # perl5i should have lexical effect, ideally 4 | 5 | use Test::More 'no_plan'; 6 | 7 | # use perl5i::latest in a narrow lexical scope. 8 | # It shouldn't effect the rest of the program. 9 | { use perl5i::latest } 10 | 11 | 12 | # lexical strict 13 | { 14 | ok eval q{$bar = 42}; 15 | } 16 | 17 | 18 | # lexical File::stat? 19 | TODO: { 20 | local $TODO = "lexical File::stat"; 21 | 22 | my $stat = stat("MANIFEST"); 23 | ok !ref $stat; 24 | } 25 | 26 | 27 | # lexical autodie? 28 | { 29 | ok eval { open my $fh, "dlkfjal;kdj"; 1 } or diag $@; 30 | } 31 | 32 | 33 | # lexical autovivification 34 | { 35 | my $hash; 36 | my $val = $hash->{key}; 37 | is_deeply $hash, {}, "no autovivification is lexical"; 38 | } 39 | 40 | 41 | # lexical autobox 42 | { 43 | my $thing = []; 44 | ok !eval { []->isa("ARRAY"); }; 45 | } 46 | 47 | 48 | # lexical no indirect 49 | { 50 | package Some::Thing; 51 | sub method { 42 } 52 | ::is( method Some::Thing, 42 ); 53 | } 54 | -------------------------------------------------------------------------------- /t/lib/Test/perl5i.pm: -------------------------------------------------------------------------------- 1 | package Test::perl5i; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More (); 7 | 8 | use base qw(Exporter); 9 | our @EXPORT = qw(throws_ok dies_ok lives_ok); 10 | 11 | # This is a replacement for Test::Exception which messes with caller() 12 | # and screws up Carp. 13 | # See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2010-03/msg00520.html 14 | # Could use Test::Exception::LessClever but that's not testing on Windows 15 | sub throws_ok(&$;$) { 16 | my($code, $regex, $name) = @_; 17 | 18 | my $tb = Test::More->builder; 19 | 20 | my $lived = eval { $code->(); 1 }; 21 | if( $lived ) { 22 | $tb->ok(0, $name); 23 | $tb->diag("It lived when it should have died"); 24 | } 25 | return $tb->like($@, $regex, $name); 26 | } 27 | 28 | sub dies_ok(&;$) { 29 | my($code, $name) = @_; 30 | 31 | my $lived = eval { $code->(); 1 }; 32 | 33 | my $tb = Test::More->builder; 34 | $tb->ok( !$lived, $name ); 35 | } 36 | 37 | sub lives_ok(&;$) { 38 | my($code, $name) = @_; 39 | my $lived = eval { $code->(); 1 }; 40 | 41 | my $tb = Test::More->builder; 42 | $tb->ok( $lived, $name ); 43 | } 44 | 45 | 1; 46 | -------------------------------------------------------------------------------- /t/lib/ThisIsTrue.pm: -------------------------------------------------------------------------------- 1 | package ThisIsTrue; 2 | 3 | use perl5i::2; 4 | 5 | sub bar { return 42 } 6 | -------------------------------------------------------------------------------- /t/list-trim.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | my @a = ( ' foo', 'bar ', ' baz ' ); 10 | my @b = ( '-->foo', 'bar<--', '-->baz<--' ); 11 | 12 | # Default option 13 | is_deeply( 14 | scalar @a->ltrim, 15 | [ 'foo', 'bar ', 'baz ' ], 16 | 'Left array trim' 17 | ); 18 | 19 | is_deeply( 20 | scalar @a->rtrim, 21 | [ ' foo', 'bar', ' baz' ], 22 | 'Right array trim' 23 | ); 24 | 25 | is_deeply( 26 | scalar @a->trim, 27 | [ 'foo', 'bar', 'baz' ], 28 | 'Array trim' 29 | ); 30 | 31 | # Character set argument 32 | is_deeply( 33 | scalar @b->ltrim('-><'), 34 | [ 'foo', 'bar<--', 'baz<--' ], 35 | 'Left array trim with argument' 36 | ); 37 | 38 | is_deeply( 39 | scalar @b->rtrim('-><'), 40 | [ '-->foo', 'bar', '-->baz' ], 41 | 'Right array trim with argument' 42 | ); 43 | 44 | is_deeply( 45 | scalar @b->trim('-><'), 46 | [ 'foo', 'bar', 'baz' ], 47 | 'Array trim with argument' 48 | ); 49 | 50 | # Literal array ref 51 | is_deeply( 52 | scalar [ ' foo', 'bar ', ' baz ' ]->trim, 53 | [ 'foo', 'bar', 'baz' ], 54 | 'Array ref trim' 55 | ); 56 | 57 | # Chaining 58 | is_deeply( 59 | scalar @a->ltrim->rtrim, 60 | [ 'foo', 'bar', 'baz' ], 61 | 'Chained trim' 62 | ); 63 | 64 | # Empty array 65 | is_deeply( scalar []->trim, [], 'Empty array trim' ); 66 | 67 | # Context 68 | is_deeply( 69 | [@a->trim], 70 | [ 'foo', 'bar', 'baz' ], 71 | 'Array trim, list context' 72 | ); 73 | 74 | is_deeply( 75 | [@a->ltrim], 76 | [ 'foo', 'bar ', 'baz ' ], 77 | 'Left array trim, list context' 78 | ); 79 | 80 | is_deeply( 81 | [@a->rtrim], 82 | [ ' foo', 'bar', ' baz' ], 83 | 'Right array trim, list context' 84 | ); 85 | 86 | 87 | done_testing(); 88 | -------------------------------------------------------------------------------- /t/list.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use perl5i::latest; 5 | 6 | note 'list context'; { 7 | my $thing = 'hello'; 8 | my @list = list($thing); 9 | 10 | is $thing, 'hello', q{The universe didn't implode}; 11 | isa_ok \@list, 'ARRAY', q{list returns array}; 12 | is_deeply \@list, [$thing], q{list turned the thing into a list!}; 13 | } 14 | 15 | note 'scalar context'; { 16 | my $thing = 'hello'; 17 | my $list_thing = list $thing; 18 | 19 | like $list_thing, qr/\d/, q{in scalar context, returns array size}; 20 | is $list_thing, scalar @{[$thing]}, q{returns the right array size}; 21 | } 22 | 23 | note 'all together now'; { 24 | my $thing = 'hello'; 25 | my $scalar_list = scalar list $thing; 26 | is $scalar_list, 1, 'scalar list $thing is the size'; 27 | }; 28 | 29 | note 'list list'; { 30 | my @list = qw(one two three); 31 | 32 | my @stuff = list @list; 33 | is_deeply \@stuff, \@list, 'using list on a list gives you a list'; 34 | 35 | my $thing = list @list; 36 | is_deeply $thing, scalar @list, 'force scalar context, even with list'; 37 | } 38 | 39 | note 'wantarray'; { 40 | my $code = sub { ok( wantarray, "list triggers wantarray" ); }; 41 | 42 | list $code->(); 43 | } 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /t/load_together.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | my @warnings; 4 | BEGIN { 5 | $SIG{__WARN__} = sub { 6 | push @warnings, @_; 7 | }; 8 | } 9 | 10 | use Test::More; 11 | 12 | { 13 | package Foo; 14 | use perl5i::1; 15 | } 16 | { 17 | package Bar; 18 | use perl5i::2; 19 | } 20 | 21 | TODO:{ 22 | local $TODO = "loading perl5i::1 and perl5i::2 together not entirely safe"; 23 | is @warnings, 0, "no warnings" or diag explain \@warnings; 24 | } 25 | 26 | done_testing; 27 | -------------------------------------------------------------------------------- /t/map.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | my @array = (4,5,6); 7 | is_deeply [@array->map(sub { $_[0] + 1 })], [5,6,7], "map in list context"; 8 | is_deeply scalar @array->map(sub { $_[0] + 1 }), [5,6,7], "map in scalar context"; 9 | 10 | is_deeply [@array->map( func($item) { $item + 1 } )], [5,6,7], "map with named arguments"; 11 | 12 | done_testing(); 13 | -------------------------------------------------------------------------------- /t/method_leaking.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | # Test methods and functions aren't leaking. 4 | 5 | use perl5i::latest; 6 | use Test::More; 7 | 8 | ok( !SCALAR->can("croak") ); 9 | ok !defined &main::alias; 10 | 11 | done_testing(); 12 | -------------------------------------------------------------------------------- /t/modern_perl.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Test the basic Modern::Perl functionality works. 4 | 5 | use Test::More 'no_plan'; 6 | use Test::Warn; 7 | use perl5i::latest; 8 | no if $] >= 5.018000, warnings => 'experimental::smartmatch'; 9 | 10 | # strict? 11 | { 12 | ok !eval '$foo = 42', "strict is on"; 13 | like $@, qr/^Global symbol "\$foo" requires explicit package name/; 14 | } 15 | 16 | 17 | # warnings? 18 | { 19 | my $foo; 20 | warning_like { 21 | $foo + 4; 22 | } 23 | qr/^Use of uninitialized value/; 24 | } 25 | 26 | 27 | # 5.10 features? 28 | { 29 | my $thing = 42; 30 | given($thing) { 31 | when(42) { 32 | pass("given/when enabled"); 33 | } 34 | default { 35 | fail("shouldn't reach here"); 36 | } 37 | } 38 | } 39 | 40 | 41 | # C3? 42 | { 43 | is mro::get_mro(__PACKAGE__), "c3", "C3 on"; 44 | } 45 | -------------------------------------------------------------------------------- /t/module2path.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | 10 | note "Test some simple symetrical conversions"; { 11 | my %mod2path = ( 12 | CGI => "CGI.pm", 13 | "File::Spec" => "File/Spec.pm", 14 | "A::B::C" => "A/B/C.pm", 15 | "å::1::2" => "å/1/2.pm", 16 | ); 17 | 18 | for my $mod (keys %mod2path) { 19 | my $path = $mod2path{$mod}; 20 | 21 | is $mod->module2path, $path; 22 | is $path->path2module, $mod; 23 | } 24 | } 25 | 26 | 27 | note "Invalid module paths"; { 28 | my @bad_paths = ( 29 | "/foo/bar/baz.pm", 30 | "Not/A/Module", 31 | "Foo/Bar/Baz.pm/", 32 | ); 33 | 34 | for my $path (@bad_paths) { 35 | throws_ok { $path->path2module } qr/^'$path' does not look like a Perl module path/; 36 | } 37 | } 38 | 39 | 40 | note "Invalid module names"; { 41 | my @bad_modules = ( 42 | "::tmp::owned", 43 | "f/../../owned", 44 | "/tmp::LOL::PWNED", 45 | ); 46 | 47 | for my $module (@bad_modules) { 48 | throws_ok { $module->module2path } qr/^'\Q$module\E' is not a valid module name/; 49 | } 50 | } 51 | 52 | done_testing(); 53 | -------------------------------------------------------------------------------- /t/no_indirect.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | 7 | # "no indirect" happens at compile time 8 | ok !eval q{ 9 | my $foo = 42; 10 | foo $foo; 11 | }; 12 | like $@, qr[^Indirect call of method "foo" on object "\$foo"]; 13 | 14 | done_testing(); 15 | -------------------------------------------------------------------------------- /t/number.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More; 4 | use perl5i::latest; 5 | 6 | is( 12.34->ceil, 13); 7 | is( 12.34->round_up, 13); 8 | is( 12.34->floor, 12); 9 | is( 12.34->round_down, 12); 10 | is( 12.34->int, 12); 11 | 12 | is( (-12.34)->ceil, -12); 13 | is( (-12.34)->round_up, -12); 14 | is( (-12.34)->floor, -13); 15 | is( (-12.34)->round_down, -13); 16 | is( (-12.34)->int, -12); 17 | 18 | is( 2.5->round, 3 ); 19 | is( 2->round, 2 ); 20 | is( 0->round, 0 ); 21 | is( 2.51->round, 3 ); 22 | is( (-3.51)->round, -4 ); 23 | is( (-3.5)->round, -4 ); 24 | is( (-3.49)->round, -3 ); 25 | 26 | ok( 12->is_number ); 27 | ok(!'FF'->is_number ); 28 | 29 | ok( 12->is_positive ); 30 | ok( "+12"->is_positive ); 31 | ok( 12.34->is_positive ); 32 | ok( !"foo"->is_positive ); 33 | ok( !"-12.2"->is_positive ); 34 | 35 | ok( !12->is_negative ); 36 | ok( "-12"->is_negative ); 37 | ok( (-12.34)->is_negative ); 38 | ok( !"foo"->is_negative ); 39 | ok( "-12.2"->is_negative ); 40 | 41 | ok !0->is_negative, "zero is not negative"; 42 | ok !0->is_positive, "zero is not positive"; 43 | 44 | ok( !11->is_even ); 45 | ok( 11->is_odd ); 46 | ok( 12->is_even ); 47 | ok( !12->is_odd ); 48 | ok( "12"->is_even ); 49 | ok( !"12"->is_odd ); 50 | ok( "-12"->is_even ); 51 | ok( !"-12"->is_odd ); 52 | ok( !12.34->is_even ); 53 | ok( !12.34->is_odd ); 54 | 55 | ok( 12->is_integer ); 56 | ok( (-12)->is_integer ); 57 | ok( "+12"->is_integer ); 58 | ok(!12.34->is_integer ); 59 | ok(!"1.0"->is_integer ); 60 | ok(!"1."->is_integer ); 61 | ok( 0->is_integer ); 62 | 63 | ok( 12->is_int ); 64 | ok(!12.34->is_int ); 65 | 66 | ok( 12.34->is_decimal ); 67 | ok( ".34"->is_decimal ); 68 | ok( "+1."->is_decimal ); 69 | ok( "-.0"->is_decimal ); 70 | ok( !12->is_decimal ); 71 | ok(!'abc'->is_decimal ); 72 | ok("1.0"->is_decimal); 73 | ok( !0->is_decimal ); 74 | 75 | is( '123'->reverse, '321' ); 76 | 77 | TODO: { 78 | local $TODO = q{ hex is weird }; 79 | 80 | is( 255->hex, 'FF'); 81 | is( 'FF'->dec, 255); 82 | is( 0xFF->dec, 255); 83 | 84 | }; 85 | 86 | for my $ref ([ 'foo' ], { bar => 1 }, \'baz', sub { 'gorch' }) { 87 | for my $method (qw(is_decimal is_integer is_int is_negative is_positive)) { 88 | ok(!$ref->$method); 89 | } 90 | } 91 | 92 | 93 | done_testing(); 94 | -------------------------------------------------------------------------------- /t/path/base.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # Basic testing of path() and Path::Tiny 4 | 5 | use perl5i::latest; 6 | use Test::Most; 7 | 8 | note "is Path::Tiny working?"; { 9 | my $file = $0->path; 10 | isa_ok $file, "Path::Tiny"; 11 | 12 | my $content = $file->slurp; 13 | like $content, qr/slurp/; 14 | 15 | ok $file->exists; 16 | } 17 | 18 | done_testing; 19 | -------------------------------------------------------------------------------- /t/perl5i.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | # requiring perl5i is ok 7 | require_ok "perl5i"; 8 | 9 | # using it is not 10 | ok !eval "use perl5i"; 11 | like $@, qr/perl5i will break compatibility/; 12 | 13 | # but -Mperl5i on the command line means -Mperl5i::latest, and it A-OK 14 | is capture {system ($^X, '-Ilib', '-Mperl5i', '-e', q|say 'OK!'|)}, 15 | "OK!\n", q{perl -Mperl5i -e '...' means -Mperl5i::latest}; 16 | 17 | done_testing(); 18 | -------------------------------------------------------------------------------- /t/pick.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib 't/lib'; 4 | use perl5i::latest; 5 | use Test::More; 6 | use Test::perl5i; 7 | 8 | func pick_ok($array, $num) { 9 | local $Test::Builder::Level = $Test::Builder::Level +1; 10 | my @rand = $array->pick($num); 11 | if($num <= @$array){ 12 | is @rand, $num; 13 | } 14 | else{ 15 | is @rand, @$array; 16 | } 17 | ok (is_subset($array, \@rand)) or diag sprintf <pick_one; 40 | ok grep safe_key($_) eq safe_key($elem), @$array; 41 | } 42 | 43 | func safe_key($val){ 44 | return defined $val ? $val : "__UNDEFINED__"; 45 | } 46 | 47 | note 'is_subset';{ 48 | ok !(is_subset([1,2,3,4] , [1,1,1])); 49 | 50 | ok !(is_subset([1,1,1,1] , [1,2])); 51 | 52 | ok is_subset([1,2,3,4] , [1,2]); 53 | } 54 | note 'pick()'; { 55 | my @arr = qw(a b c d e f g h i); 56 | pick_ok(\@arr, 5); 57 | 58 | pick_ok(\@arr, 9); 59 | 60 | pick_ok(\@arr, 100); 61 | 62 | pick_ok(\@arr, 0); 63 | } 64 | 65 | note 'pick with undefined elements';{ 66 | pick_ok([undef,undef,undef] => 2); 67 | 68 | } 69 | 70 | note 'pick method with duplicate elements';{ 71 | pick_ok([1,1,2,2,3,3] => 6); 72 | } 73 | 74 | note "pick with no args"; { 75 | my @array = (1, 2, 3); 76 | throws_ok { @array->pick(); } 77 | qr{^\Qpick() takes the number of elements to pick at $0 line }; 78 | } 79 | 80 | note "pick with negative arg"; { 81 | my @array = (1, 2, 3); 82 | throws_ok { @array->pick(-20); } 83 | qr{^\Qpick() takes a positive integer or zero, not '-20' at $0 line }; 84 | } 85 | 86 | note "pick with non-numerical argument"; { 87 | my @array = (1, 2, 3); 88 | throws_ok { @array->pick("rawr"); } 89 | qr{^\Qpick() takes a positive integer or zero, not 'rawr' at $0 line }; 90 | } 91 | 92 | note "pick_one method";{ 93 | pick_one_ok([1,2,3,4,4]); 94 | 95 | pick_one_ok(["a","b","c","d","e"]); 96 | 97 | pick_one_ok([undef, undef, undef, undef]); 98 | } 99 | 100 | note "pick shuffles the result"; { 101 | my $not_in_order = 0; 102 | my @array = (1..10); 103 | 104 | # Since @array is in ascending order, we should, eventually, 105 | # get two picks where the first is larger than the second. 106 | # There's a 50/50 chance for each pick, and with 1000 tries 107 | # the odds of this failing are something like 1 in 1^300. 108 | for(1..1000) { 109 | my @picks = @array->pick(2); 110 | next if $picks[0] < $picks[1]; 111 | 112 | $not_in_order = 1; 113 | last; 114 | } 115 | 116 | ok $not_in_order; 117 | } 118 | 119 | done_testing; 120 | -------------------------------------------------------------------------------- /t/popn.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib 't/lib'; 4 | use perl5i::latest; 5 | use Test::perl5i; 6 | use Test::More; 7 | 8 | note "popn with no args"; { 9 | my @array = (1, 2, 3); 10 | throws_ok { @array->popn(); } 11 | qr{^\Qpopn() takes the number of elements to pop at $0 line }; 12 | } 13 | 14 | note "popn with negative arg"; { 15 | my @array = (1, 2, 3); 16 | throws_ok { @array->popn(-20); } 17 | qr{^\Qpopn() takes a positive integer or zero, not '-20' at $0 line }; 18 | } 19 | 20 | note "popn with non-numerical argument"; { 21 | my @array = (1, 2, 3); 22 | throws_ok { @array->popn("rawr"); } 23 | qr{^\Qpopn() takes a positive integer or zero, not 'rawr' at $0 line }; 24 | } 25 | 26 | note "popn with arg == 0"; { 27 | my @array = (1, 2, 3); 28 | my @newarray = @array->popn(0); 29 | 30 | my @want = (1, 2, 3); 31 | my @newwant = (); 32 | 33 | is_deeply \@array, \@want; 34 | is_deeply \@newarray, \@newwant; 35 | } 36 | 37 | note "popn with arg > 0"; { 38 | my @array = (1, 2, 3, 4, 5); 39 | my @newarray = @array->popn(3); 40 | 41 | my @want = (1, 2); 42 | my @newwant = (3, 4, 5); 43 | 44 | is_deeply \@array, \@want; 45 | is_deeply \@newarray, \@newwant; 46 | } 47 | 48 | note "popn with arg > length of array"; { 49 | my @array = (1, 2, 3, 4); 50 | my @newarray = @array->popn(10); 51 | 52 | my @want = (); 53 | my @newwant = (1, 2, 3, 4); 54 | 55 | is_deeply \@array, \@want; 56 | is_deeply \@newarray, \@newwant; 57 | } 58 | 59 | note "popn in scalar context"; { 60 | my $array = [1,2,3,4,5]; 61 | my $new = $array->popn(3); 62 | 63 | is_deeply $array, [1,2]; 64 | is_deeply $new, [3,4,5]; 65 | } 66 | 67 | done_testing; 68 | -------------------------------------------------------------------------------- /t/require.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | note "Successful require"; { 7 | local $!; 8 | local $@ = "hubba bubba"; 9 | 10 | is "Text::ParseWords"->require, "Text::ParseWords"; 11 | ok !$!, "errno didn't leak out"; 12 | is $@, "hubba bubba", '$@ not overwritten'; 13 | 14 | ok $INC{"Text/ParseWords.pm"}, "require"; 15 | ok !defined &shellwords, "nothing imported"; 16 | 17 | "Text::ParseWords"->require->import; 18 | ok defined &shellwords, " default import"; 19 | } 20 | 21 | 22 | note "Module doesn't exist"; { 23 | local $!; 24 | local @INC = qw(no thing); 25 | ok !eval { "I::Sure::Dont::Exist"->require; }; 26 | my $pat = q[^Can't locate I/Sure/Dont/Exist\.pm in \@INC]; 27 | $pat .= q[(?: \(you may need to install the I::Sure::Dont::Exist module\))?]; 28 | $pat .= sprintf(' \(@INC contains: no thing\) at %s line %d\.$', 29 | __FILE__, __LINE__-4); 30 | like $@, qr/$pat/; 31 | ok !$!, "errno didn't leak out"; 32 | } 33 | 34 | note "Invalid module name"; { 35 | ok !eval { "/tmp::LOL::PWNED"->require }; 36 | like $@, qr{^'/tmp::LOL::PWNED' is not a valid module name }; 37 | } 38 | 39 | 40 | done_testing; 41 | -------------------------------------------------------------------------------- /t/require_message.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | is( ref($INC[-1]), 'CODE', "Sub is at end" ); 10 | push @INC => './.././'; 11 | ok( !ref($INC[-1]), "Something is after our sub." ); 12 | 13 | lives_ok { 14 | require Data::Dumper; 15 | } "Require things that are installed works"; 16 | 17 | throws_ok { 18 | require Fake::Thing; 19 | } 20 | qr/Can't locate Fake\/Thing\.pm in your Perl library\./, 21 | "Useful message"; 22 | 23 | is( ref($INC[-1]), 'CODE' , "sub at end" ); 24 | 25 | { 26 | package NoFile; 27 | sub foo { 42 } 28 | } 29 | 30 | lives_ok { 31 | package Foo; 32 | eval <<' EOT' || die $@; 33 | use perl5i::2; 34 | use base 'NoFile'; 35 | 1; 36 | EOT 37 | } "same file base"; 38 | 39 | 40 | { 41 | no perl5i::latest; 42 | 43 | throws_ok { 44 | require Fake::Thing; 45 | } 46 | qr/^Can't locate Fake\/Thing\.pm in \@INC/, 47 | "Special message turned off out of scope"; 48 | } 49 | 50 | done_testing; 51 | -------------------------------------------------------------------------------- /t/say.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use Test::More; 6 | use Test::Output; 7 | 8 | { 9 | my %hash = (foo => 23, bar => 42); 10 | my $as_string = join " ", map { "$_ => $hash{$_}" } keys %hash; 11 | stdout_is { %hash->say } "$as_string\n", "%hash->say"; 12 | stdout_is { %hash->print } $as_string, "%hash->print"; 13 | } 14 | 15 | done_testing(); 16 | -------------------------------------------------------------------------------- /t/scalar.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More 'no_plan'; 4 | use perl5i::latest; 5 | 6 | is( "this is a test"->title_case, 'This Is A Test'); 7 | is( "this is a test"->lc->title_case, 'This Is A Test'); 8 | 9 | is( "thIS is a teST"->title_case, 'ThIS Is A TeST'); 10 | is( "thIS is a teST"->lc->title_case, 'This Is A Test'); 11 | 12 | is( ' testme'->ltrim, 'testme' ); 13 | is( ' testme'->rtrim, ' testme' ); 14 | is( ' testme'->trim, 'testme' ); 15 | 16 | is( 'testme '->ltrim, 'testme ' ); 17 | is( 'testme '->rtrim, 'testme' ); 18 | is( 'testme '->trim, 'testme' ); 19 | 20 | is( ' testme '->ltrim, 'testme ' ); 21 | is( ' testme '->rtrim, ' testme' ); 22 | is( ' testme '->trim, 'testme' ); 23 | 24 | is( '--> testme <--'->ltrim("-><"), ' testme <--' ); 25 | is( '--> testme <--'->rtrim("-><"), '--> testme ' ); 26 | is( '--> testme <--'->trim("-><"), ' testme ' ); 27 | 28 | is( ' --> testme <--'->trim("-><"), ' --> testme ' ); 29 | 30 | 31 | note "reverse"; { 32 | my @list = "foo"->reverse; 33 | is $list[0], "oof", "string->reverse always reverses the string"; 34 | } 35 | -------------------------------------------------------------------------------- /t/shiftn.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib 't/lib'; 4 | use Test::perl5i; 5 | use perl5i::2; 6 | use Test::More; 7 | 8 | note "shiftn with no args"; { 9 | my @array = (1, 2, 3); 10 | throws_ok { @array->shiftn(); } 11 | qr{^\Qshiftn() takes the number of elements to shift at $0 line }; 12 | } 13 | 14 | note "shiftn with negative arg"; { 15 | my @array = (1, 2, 3); 16 | throws_ok { @array->shiftn(-20); } 17 | qr{^\Qshiftn() takes a positive integer or zero, not '-20' at $0 line }; 18 | } 19 | 20 | note "shiftn with non-numerical argument"; { 21 | my @array = (1, 2, 3); 22 | throws_ok { @array->shiftn("meow"); } 23 | qr{^\Qshiftn() takes a positive integer or zero, not 'meow' at $0 line }; 24 | } 25 | 26 | note "shiftn with arg == 0"; { 27 | my @array = (1, 2, 3); 28 | my @newarray = @array->shiftn(0); 29 | 30 | my @want = (1, 2, 3); 31 | my @newwant = (); 32 | 33 | is_deeply \@array, \@want; 34 | is_deeply \@newarray, \@newwant; 35 | } 36 | 37 | note "shiftn with arg > 0"; { 38 | my @array = (1, 2, 3, 4, 5); 39 | my @newarray = @array->shiftn(3); 40 | 41 | my @want = (4, 5); 42 | my @newwant = (1, 2, 3); 43 | 44 | is_deeply \@array, \@want; 45 | is_deeply \@newarray, \@newwant; 46 | } 47 | 48 | note "shiftn with arg > length of array"; { 49 | my @array = (1, 2, 3, 4); 50 | my @newarray = @array->shiftn(50); 51 | 52 | my @want = (); 53 | my @newwant = (1, 2, 3, 4); 54 | 55 | is_deeply \@array, \@want; 56 | is_deeply \@newarray, \@newwant; 57 | } 58 | 59 | note "shiftn in scalar context"; { 60 | my $array = [1,2,3,4,5]; 61 | my $new = $array->shiftn(3); 62 | 63 | is_deeply $array, [4,5]; 64 | is_deeply $new, [1,2,3]; 65 | } 66 | 67 | done_testing(); 68 | -------------------------------------------------------------------------------- /t/signature.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | # Empty signature 7 | { 8 | my $sig = perl5i::2::Signature->new( signature => "" ); 9 | isa_ok $sig, "perl5i::2::Signature::None"; 10 | is $sig->num_positional_params, 0; 11 | is_deeply $sig->params, []; 12 | is_deeply $sig->positional_params, []; 13 | is $sig, ""; 14 | ok $sig; 15 | is $sig->invocant, ''; 16 | ok !$sig->is_method; 17 | } 18 | 19 | 20 | # Empty signature with spaces 21 | { 22 | my $sig = perl5i::2::Signature->new( signature => " " ); 23 | isa_ok $sig, "perl5i::2::Signature::None"; 24 | is $sig->num_positional_params, 0; 25 | is_deeply $sig->params, []; 26 | is_deeply $sig->positional_params, []; 27 | is $sig, " "; 28 | is $sig->invocant, ''; 29 | ok !$sig->is_method; 30 | } 31 | 32 | 33 | # Empty signature on a method 34 | { 35 | my $sig = perl5i::2::Signature->new( signature => " ", is_method => 1 ); 36 | isa_ok $sig, "perl5i::2::Signature::None"; 37 | is $sig->num_positional_params, 0; 38 | is_deeply $sig->params, []; 39 | is_deeply $sig->positional_params, []; 40 | is $sig, " "; 41 | is $sig->invocant, '$self'; 42 | ok $sig->is_method; 43 | } 44 | 45 | 46 | # One arg signature 47 | { 48 | my $sig = perl5i::2::Signature->new( signature => '$foo' ); 49 | isa_ok $sig, "perl5i::2::Signature"; 50 | is $sig->num_positional_params, 1; 51 | is_deeply $sig->params, ['$foo']; 52 | is $sig, '$foo'; 53 | isa_ok $sig, "perl5i::2::Signature::Real"; 54 | is $sig->invocant, ''; 55 | ok !$sig->is_method; 56 | } 57 | 58 | 59 | # Two arg signature 60 | { 61 | my $sig = perl5i::2::Signature->new( signature => '$foo , @bar' ); 62 | is $sig->num_positional_params, 2; 63 | is_deeply $sig->params, ['$foo', '@bar']; 64 | is $sig, '$foo , @bar'; 65 | is $sig->invocant, ''; 66 | ok !$sig->is_method; 67 | } 68 | 69 | 70 | # With leading and trailing spaces 71 | { 72 | my $sig = perl5i::2::Signature->new( signature => ' $foo , @bar ' ); 73 | is $sig->num_positional_params, 2; 74 | is_deeply $sig->params, ['$foo', '@bar']; 75 | is $sig, ' $foo , @bar '; # an exact reproduction 76 | is $sig->invocant, ''; 77 | ok !$sig->is_method; 78 | } 79 | 80 | 81 | # With an invocant 82 | { 83 | my $sig = perl5i::2::Signature->new( signature => '$class: @bar', is_method => 1 ); 84 | is $sig->num_positional_params, 1; 85 | is_deeply $sig->params, ['@bar']; 86 | is $sig, '$class: @bar'; 87 | is $sig->invocant, '$class'; 88 | ok $sig->is_method; 89 | } 90 | 91 | 92 | # Method, implied invocant 93 | { 94 | my $sig = perl5i::2::Signature->new( signature => '@bar', is_method => 1 ); 95 | is $sig->num_positional_params, 1; 96 | is_deeply $sig->params, ['@bar']; 97 | is $sig, '@bar'; 98 | is $sig->invocant, '$self'; 99 | ok $sig->is_method; 100 | } 101 | 102 | 103 | # Try setting a signature on a code reference 104 | { 105 | my $sig = perl5i::2::Signature->new( signature => '$arg', is_method => 1 ); 106 | my $echo = sub { 107 | my $self = shift; 108 | my($arg) = @_; 109 | 110 | return $arg; 111 | }; 112 | 113 | $echo->__set_signature($sig); 114 | is $echo->signature, $sig; 115 | } 116 | 117 | 118 | # And now bring it all together 119 | { 120 | func echo($arg) { 121 | return $arg; 122 | } 123 | 124 | my $sig = (\&echo)->signature; 125 | isa_ok $sig, "perl5i::2::Signature"; 126 | ok $sig, '$arg'; 127 | is $sig->num_positional_params, 1; 128 | } 129 | 130 | 131 | # An anon code ref 132 | { 133 | my $echo = func ($arg) { 134 | }; 135 | 136 | my $sig = $echo->signature; 137 | isa_ok $sig, "perl5i::2::Signature"; 138 | ok $sig, '$arg'; 139 | is $sig->num_positional_params, 1; 140 | } 141 | 142 | 143 | # An anon method 144 | { 145 | my $echo = method ($arg) { 146 | }; 147 | 148 | my $sig = $echo->signature; 149 | isa_ok $sig, "perl5i::2::Signature"; 150 | ok $sig, '$arg'; 151 | is $sig->num_positional_params, 1; 152 | is $sig->invocant, '$self'; 153 | ok $sig->is_method; 154 | } 155 | 156 | 157 | # A normal subroutine 158 | { 159 | my $code = sub { return @_ }; 160 | 161 | ok !$code->signature; 162 | } 163 | 164 | 165 | # Stringification 166 | { 167 | my $signature = '$foo, $bar'; 168 | my $sig = perl5i::2::Signature->new( signature => $signature ); 169 | is $sig, $signature; 170 | 171 | # Make it real. 172 | is $sig->num_positional_params, 2; 173 | is $sig, $signature; 174 | } 175 | 176 | 177 | done_testing; 178 | -------------------------------------------------------------------------------- /t/signatures.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::2; 4 | use Test::More; 5 | 6 | 7 | # Test func 8 | { 9 | func minus($this, $that) { return $this - $that } 10 | is minus(2, 3), -1; 11 | } 12 | 13 | 14 | # Test method 15 | { 16 | { 17 | package Foo; 18 | use perl5i::2; 19 | 20 | method new ($class: %args) { 21 | return bless \%args, $class; 22 | } 23 | method get ($thing) { 24 | return unless @_; # just to shut up warnings 25 | return $self->{$thing}; 26 | } 27 | } 28 | 29 | my $obj = Foo->new( this => 42, that => 23 ); 30 | isa_ok $obj, "Foo"; 31 | is $obj->get("this"), 42; 32 | is $obj->get("wibble"), undef; 33 | 34 | # When we get required parameters this should use them. 35 | is $obj->get(), undef; 36 | } 37 | 38 | 39 | # Anonymous 40 | { 41 | my $code = func($this, @these) { 42 | return $this, \@these; 43 | }; 44 | 45 | is_deeply [$code->(42, 1, 2, 3)], [42, [1,2,3]]; 46 | 47 | my $method = method($arg) { 48 | return $self, $arg; 49 | }; 50 | 51 | is_deeply [Foo->$method(23)], ["Foo", 23]; 52 | } 53 | 54 | 55 | # Test an anonymous function keeps the same signature 56 | { 57 | my %last; 58 | for(1..3) { 59 | my $code = func($this, $that) { return "$this, $that"; }; 60 | 61 | if( $last{code} ) { 62 | is $code->signature->mo->id, $last{sig}->mo->id, "same signature"; 63 | is $code->mo->id, $last{code}->mo->id, "same code ref"; 64 | } 65 | 66 | $last{code} = $code; 67 | $last{sig} = $code->signature; 68 | } 69 | } 70 | 71 | 72 | done_testing(); 73 | -------------------------------------------------------------------------------- /t/skip.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use Test::More; 4 | 5 | note "skipping a feature"; 6 | { 7 | # Needs its own package because perl5i is not always lexical 8 | package Foo1; 9 | 10 | use perl5i::latest -skip => ['Signatures']; 11 | 12 | ::ok !eval q[method foo { 42 }; 1]; 13 | ::ok !defined &foo; 14 | } 15 | 16 | note "skipping autodie"; 17 | { 18 | # Needs its own package because perl5i is not always lexical 19 | package Foo2; 20 | 21 | use perl5i::latest -skip => ["autodie"]; 22 | open my $fh, "/i/do/not/exist/alfkjaldjlf"; 23 | ::pass("autodie is disabled"); 24 | } 25 | 26 | note "unknown feature error"; 27 | { 28 | my $feature = 'Orbital Mind Control Lasers'; 29 | ok !eval { 30 | perl5i::latest->import( -skip => [$feature] ); 31 | }; 32 | is $@, sprintf "Unknown feature '%s' in skip list at %s line %d.\n", $feature, $0, __LINE__-2; 33 | } 34 | 35 | note "unknown import parameter"; 36 | { 37 | ok !eval { 38 | perl5i::latest->import( wibble => "what" ); 39 | }; 40 | is $@, sprintf "Unknown parameters 'wibble => what' in import list at %s line %d.\n", $0, __LINE__-2; 41 | } 42 | 43 | done_testing; 44 | -------------------------------------------------------------------------------- /t/taint.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -T 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | use Scalar::Util qw(tainted); 10 | 11 | # Check an already tainted global 12 | { 13 | note "Already tainted global"; 14 | 15 | ok $^X->mo->is_tainted; 16 | 17 | $^X->mo->untaint; 18 | ok !$^X->mo->is_tainted; 19 | ok !tainted($^X); 20 | 21 | $^X->mo->taint; 22 | ok $^X->mo->is_tainted; 23 | ok tainted($^X); 24 | } 25 | 26 | # Check 2.0 compat 27 | { 28 | note "2.0 compat"; 29 | 30 | ok $^X->is_tainted; 31 | 32 | $^X->untaint; 33 | ok !$^X->is_tainted; 34 | 35 | $^X->taint; 36 | ok $^X->is_tainted; 37 | } 38 | 39 | 40 | # Check a scalar 41 | { 42 | note "simple scalar"; 43 | 44 | my $foo = "foo"; 45 | ok !$foo->mo->is_tainted; 46 | 47 | $foo->mo->taint; 48 | ok $foo->mo->is_tainted; 49 | ok tainted($foo); # just to be sure. 50 | 51 | $foo->mo->untaint; 52 | ok !$foo->mo->is_tainted; 53 | ok !tainted($foo); # just to be sure. 54 | } 55 | 56 | 57 | # What about a scalar ref? 58 | # Would be nice if we could un/taint the contents, but that's not 59 | # possible due to how Taint::Util works and its not worth fixing. 60 | { 61 | note "scalar ref"; 62 | 63 | my $foo = \42; 64 | ok !$foo->mo->is_tainted; 65 | 66 | $foo->mo->untaint; # does nothing 67 | ok !$foo->mo->is_tainted; 68 | ok !tainted(\$foo); # just to be sure. 69 | 70 | throws_ok { $foo->mo->taint; } qr/^Only scalars can normally be made tainted/; 71 | ok !$foo->mo->is_tainted; 72 | ok !tainted(\$foo); # just to be sure. 73 | } 74 | 75 | 76 | # A regular hash cannot be tainted 77 | { 78 | note "hash"; 79 | 80 | my %foo; 81 | ok !%foo->mo->is_tainted; 82 | 83 | %foo->mo->untaint; # does nothing 84 | ok !%foo->mo->is_tainted; 85 | ok !tainted(\%foo); # just to be sure. 86 | 87 | throws_ok { %foo->mo->taint; } qr/^Only scalars can normally be made tainted/; 88 | ok !%foo->mo->is_tainted; 89 | ok !tainted(\%foo); # just to be sure. 90 | } 91 | 92 | 93 | # A blessed hash ref object cannot be tainted 94 | { 95 | note "blessed hash ref"; 96 | 97 | my $obj = bless {}, "Foo"; 98 | ok !$obj->mo->is_tainted; 99 | 100 | $obj->mo->untaint; # does nothing 101 | ok !$obj->mo->is_tainted; 102 | 103 | throws_ok { $obj->mo->taint; } qr/^Only scalars can normally be made tainted/; 104 | ok !$obj->mo->is_tainted; 105 | ok !tainted($obj); # just to be sure. 106 | } 107 | 108 | 109 | # A blessed scalar ref object cannot be untainted... though we could. 110 | { 111 | note "blessed scalar ref"; 112 | 113 | my $thing = 42; 114 | my $obj = bless \$thing, "Foo"; 115 | ok !$obj->mo->is_tainted; 116 | 117 | $obj->mo->untaint; # does nothing 118 | ok !$obj->mo->is_tainted; 119 | 120 | throws_ok { $obj->mo->taint; } qr/^Only scalars can normally be made tainted/; 121 | ok !$obj->mo->is_tainted; 122 | ok !tainted($obj); # just to be sure. 123 | } 124 | 125 | 126 | # How about a string overloaded object? 127 | # Since its stringified value is what's important to tainting, 128 | # we should check that. But there's no way to reliably taint or untaint it. 129 | { 130 | note "string overloaded object"; 131 | 132 | package Bar; 133 | use Test::More; 134 | use Test::perl5i; 135 | 136 | use overload q[""] => sub { return ${$_[0]} }, fallback => 1; 137 | 138 | # Try it when its overloaded and tainted 139 | { 140 | my $thing = $^X; 141 | my $obj = bless \$thing, "Bar"; 142 | is $obj, $^X; 143 | 144 | ok $obj->mo->is_tainted; 145 | ok ::tainted("$obj"); 146 | 147 | throws_ok { $obj->mo->untaint; } qr/^Tainted overloaded objects cannot normally be untainted/; 148 | ok $obj->mo->taint; # this is cool, its already tainted. 149 | } 150 | 151 | # Overloaded and not tainted 152 | { 153 | my $thing = "wibble"; 154 | my $obj = bless \$thing, "Bar"; 155 | is $obj, $thing; 156 | 157 | ok !$obj->mo->is_tainted; 158 | ok !::tainted("$obj"); 159 | 160 | ok $obj->mo->untaint; # this is cool, its already untainted. 161 | throws_ok { $obj->mo->taint; } qr/^Untainted overloaded objects cannot normally be made tainted/; 162 | } 163 | } 164 | 165 | 166 | # DateTime is notoriously picky about its overloading 167 | # In particular $date+0, the usual way to numify, will die. 168 | { 169 | note "DateTime"; 170 | 171 | require DateTime; 172 | my $date = DateTime->now; 173 | 174 | ok !$date->mo->is_tainted; 175 | } 176 | 177 | done_testing(); 178 | -------------------------------------------------------------------------------- /t/time_compat.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | # Test compatibility with Perl's time stuff. 4 | 5 | use perl5i::latest; 6 | 7 | use Test::More 'no_plan'; 8 | use Test::Output; 9 | 10 | 11 | #localtime in scalar context 12 | like localtime(), qr{ 13 | ^(Sun|Mon|Tue|Wed|Thu|Fri|Sat)[ ] 14 | (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ] 15 | ([ \d]\d)\ (\d\d):(\d\d):(\d\d)\ (\d{4})$ 16 | }x; 17 | 18 | my $beg = time(); 19 | 20 | SKIP: { 21 | local $ENV{TZ}; 22 | 23 | # Two time zones, different and likely to exist 24 | my $tz1 = "America/Los_Angeles"; 25 | my $tz2 = "America/Chicago"; 26 | 27 | # If the core localtime doesn't respond to TZ, we don't have to. 28 | skip "localtime does not respect TZ env", 1 29 | unless do { 30 | # check that localtime respects changes to $ENV{TZ} 31 | $ENV{TZ} = $tz1; 32 | my $hour = (CORE::localtime($beg))[2]; 33 | $ENV{TZ} = $tz2; 34 | my $hour2 = (CORE::localtime($beg))[2]; 35 | $hour != $hour2; 36 | }; 37 | 38 | # check that localtime respects changes to $ENV{TZ} 39 | $ENV{TZ} = $tz1; 40 | my $hour = (localtime($beg))[2]; 41 | $ENV{TZ} = $tz2; 42 | my $hour2 = (localtime($beg))[2]; 43 | isnt $hour, $hour2, "localtime() honors TZ"; 44 | } 45 | 46 | 47 | sleep 1; 48 | my $now = time(); 49 | 50 | { 51 | my( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = gmtime($beg); 52 | my( $xsec, $foo ) = localtime($now); 53 | 54 | isnt( $sec, $xsec ); 55 | ok $mday; 56 | ok $year; 57 | 58 | my $localyday = (localtime)[7]; 59 | my $day_diff = $localyday - $yday; 60 | ok( 61 | grep( { $day_diff == $_ } ( 0, 1, -1, 364, 365, -364, -365 ) ), 62 | 'gmtime() and localtime() agree what day of year' 63 | ); 64 | 65 | 66 | # This could be stricter. 67 | like( 68 | gmtime(), qr/^(Sun|Mon|Tue|Wed|Thu|Fri|Sat)[ ] 69 | (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ] 70 | ([ \d]\d)\ (\d\d):(\d\d):(\d\d)\ (\d{4})$ 71 | /x, 72 | 'gmtime(), scalar context' 73 | ); 74 | } 75 | 76 | 77 | # Make sure the return from gmtime() compares as a string 78 | { 79 | my $dt = gmtime(123); 80 | my $string = CORE::gmtime(123); 81 | 82 | # Don't use is() or cmp_ok() as they can strip off overloading. 83 | # We want to explicitly check eq 84 | ok $dt eq $string, 'gmtime eq'; 85 | } 86 | 87 | 88 | # Make sure time compares as a number 89 | { 90 | my $dt = time; 91 | my $num = $dt+0; 92 | 93 | ok $dt == $num; 94 | } 95 | 96 | 97 | # Test times honor say and print 98 | { 99 | # Due to a bug in 5.10's tie, the newline on say gets lost, but 100 | # it will be back in 5.12. So we can't test for it. 101 | stdout_like { time->say; } qr/^\d+$/; 102 | stdout_like { time->print; } qr/^\d+$/; 103 | 104 | my $time = int rand 2**31; 105 | my $date = gmtime($time); 106 | stdout_like { gmtime($time)->say; } qr{^\Q$date\E$}; 107 | stdout_like { gmtime($time)->print; } qr{^\Q$date\E$}; 108 | } 109 | -------------------------------------------------------------------------------- /t/true.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use lib 't/lib'; 4 | use perl5i::latest; 5 | 6 | use Test::More; 7 | 8 | use_ok "ThisIsTrue"; 9 | is ThisIsTrue->bar, 42; 10 | 11 | done_testing; 12 | -------------------------------------------------------------------------------- /t/try-tiny.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | 5 | use lib 't/lib'; 6 | use Test::More; 7 | use Test::perl5i; 8 | 9 | lives_ok { 10 | try { 11 | die "This should not die"; 12 | } catch { 13 | "this worked"; 14 | }; 15 | } 'Dying inside a try {} block is captured via Try::Tiny'; 16 | 17 | done_testing(); 18 | -------------------------------------------------------------------------------- /t/uniq.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use perl5i::latest; 4 | use Test::More; 5 | 6 | note "perl5ifaq entry"; { 7 | my %hash1 = (foo => 23, bar => 42, biff => 99); 8 | my %hash2 = ( bar => 99, biff => 42, yiff => 23); 9 | 10 | my @keys = (%hash1->keys, %hash2->keys); 11 | my @uniq = @keys->uniq; 12 | 13 | is_deeply scalar @uniq->sort, scalar [qw(foo bar biff yiff)]->sort; 14 | } 15 | 16 | done_testing; 17 | -------------------------------------------------------------------------------- /t/utf8.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # perl5i turns on utf8 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use PerlIO; 9 | use Test::More; 10 | 11 | 12 | # Test with it on 13 | { 14 | use perl5i::latest; 15 | 16 | is "perl5i is MËTÁŁ"->length, 15; 17 | 18 | # Test the standard handles and all newly opened handles are utf8 19 | ok open my $test_fh, ">", "perlio_test"; 20 | END { unlink "perlio_test" } 21 | for my $fh (*STDOUT, *STDIN, *STDERR, $test_fh) { 22 | my @layers = PerlIO::get_layers($fh); 23 | ok(@layers->grep(qr/utf8/)->flatten) or diag explain { $fh => \@layers }; 24 | } 25 | } 26 | 27 | 28 | # And off 29 | { 30 | ok open my $test_fh, ">", "perlio_test2"; 31 | END { unlink "perlio_test2" } 32 | 33 | my @layers = PerlIO::get_layers($test_fh); 34 | ok( !grep /utf8/, @layers ) or diag explain { $test_fh => \@layers }; 35 | } 36 | 37 | done_testing; 38 | -------------------------------------------------------------------------------- /t/version_0/00_compile.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More; 4 | 5 | plan skip_all => "Needs Time::y2038" unless eval { require Time::y2038 }; 6 | 7 | use_ok 'perl5i::0'; 8 | 9 | done_testing(); 10 | -------------------------------------------------------------------------------- /t/version_1/00_compile.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More; 4 | 5 | plan skip_all => "Needs Time::y2038" unless eval { require Time::y2038 }; 6 | 7 | use_ok 'perl5i::1'; 8 | 9 | done_testing(); 10 | -------------------------------------------------------------------------------- /t/vs_listmoreutils.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # perl5i was violating List::MoreUtils' prototypes and so would not 4 | # load after it. 5 | 6 | use List::MoreUtils; 7 | use perl5i::latest; 8 | 9 | use Test::More tests => 1; 10 | 11 | pass("perl5i can load after List::MoreUtils"); 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /t/wrap.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use perl5i::latest; 3 | use Test::More; 4 | 5 | foreach my $word ("hello", "goodbye!") { 6 | foreach my $separator ("\n", '!!', '@') { 7 | test_wrap($word, $separator); 8 | } 9 | }; 10 | 11 | done_testing(); 12 | 13 | sub test_wrap { 14 | my ($word, $sep) = @_; 15 | my $txt = ($word . ' ') x 14; 16 | 17 | is num_lines($txt), 1, "Unmodified string is one line long"; 18 | is num_lines($txt->wrap(separator => $sep), $sep), 2, "Default wrapping gives two lines"; 19 | 20 | is num_lines( 21 | $txt->wrap(width => length($word) + 1, separator => $sep), 22 | $sep 23 | ), 14, "One word per line"; 24 | 25 | is num_lines( 26 | $txt->wrap(width => length($txt) + 1, separator => $sep), 27 | $sep 28 | ), 1, "Excessive wrap length"; 29 | 30 | is $txt->wrap(width => 0, separator => $sep), $txt, "Zero wrap length"; 31 | is $txt->wrap(width => -1, separator => $sep), $txt, "Negative wrap length"; 32 | } 33 | 34 | sub num_lines { 35 | my ($txt, $separator) = @_; 36 | $separator //= "\n"; 37 | 38 | my @lines = split($separator, $txt); 39 | 40 | return scalar @lines; 41 | } 42 | -------------------------------------------------------------------------------- /t/y2038.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use perl5i::latest; 4 | use Test::More 'no_plan'; 5 | 6 | my $time = gmtime( 2**35 ); 7 | is $time->year, 3058; 8 | is $time->epoch, 2**35; 9 | --------------------------------------------------------------------------------