├── minil.toml ├── cpanfile ├── xt ├── changes.t └── pod.t ├── t ├── import-as.t ├── chaining.t ├── functions.t ├── utility.t ├── objects.t ├── arrays.t └── collections.t ├── .gitignore ├── Changes ├── LICENSE └── lib └── UnderscoreJS.pm /minil.toml: -------------------------------------------------------------------------------- 1 | name = "UnderscoreJS" 2 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'List::MoreUtils'; 2 | requires 'B'; 3 | 4 | requires 'Test::Spec'; 5 | -------------------------------------------------------------------------------- /xt/changes.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | eval 'use Test::CPAN::Changes'; 7 | 8 | plan skip_all => 'Test::CPAN::Changes required for this test' if $@; 9 | 10 | changes_ok(); 11 | -------------------------------------------------------------------------------- /xt/pod.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | # Ensure a recent version of Test::Pod 7 | my $min_tp = 1.22; 8 | eval "use Test::Pod $min_tp"; 9 | plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; 10 | 11 | all_pod_files_ok(); 12 | -------------------------------------------------------------------------------- /t/import-as.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::Spec; 5 | 6 | use UnderscoreJS -as => 'X'; 7 | 8 | describe 'import' => sub { 9 | it 'must import as X' => sub { 10 | is(X->first([1, 2, 3]), 1); 11 | }; 12 | }; 13 | 14 | runtests unless caller; 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Dancer Specific 2 | *.old 3 | *~ 4 | example/logs 5 | t/*/logs 6 | t/*/sessions 7 | logs 8 | TestApp 9 | t/sessions/ 10 | tags 11 | MYMETA.yml 12 | 13 | 14 | # From: https://github.com/github/gitignore/blob/master/Global/Linux.gitignore 15 | .* 16 | !.gitignore 17 | *~ 18 | *.sw[a-p] 19 | .directory 20 | 21 | 22 | # From: https://github.com/github/gitignore/blob/master/Global/Windows.gitignore 23 | Thumbs.db 24 | Desktop.ini 25 | 26 | 27 | # From https://github.com/github/gitignore/blob/master/Global/OSX.gitignore 28 | .DS_Store 29 | Icon? 30 | ._* 31 | .Spotlight-V100 32 | .Trashes 33 | 34 | 35 | # From https://github.com/github/gitignore/blob/master/Perl.gitignore 36 | blib/ 37 | _build/ 38 | cover_db/ 39 | inc/ 40 | Build 41 | Build.bat 42 | .last_cover_stats 43 | Makefile 44 | Makefile.old 45 | MANIFEST.bak 46 | META.yml 47 | MYMETA.yml 48 | nytprof.out 49 | pm_to_blib 50 | 51 | Build.PL 52 | META.json 53 | README.md 54 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for perl module Underscore 2 | 3 | {{$NEXT}} 4 | 5 | 0.07 2014-01-06T08:38:55Z 6 | 7 | - Fix hash ordering in tests (AGAIN) 8 | 9 | 0.06 2014-01-05T07:18:24Z 10 | 11 | - Do not rely on hash ordering in tests 12 | 13 | 0.05 2014-01-03T10:44:45Z 14 | 15 | - Rename to UnderscoreJS 16 | 17 | 0.04 2014-01-03T10:28:48Z 18 | 19 | - Release fixes 20 | 21 | 0.03 2013-07-17T15:09:49Z 22 | 23 | - Add test for count_by alias 24 | - Add test for sort used in chain 25 | - Fix commented out tests 26 | - Implement after 27 | - Implement computed min 28 | - Implement countBy 29 | - Implemented computed max 30 | - Implement initial, shuffle, object 31 | - Implement omit 32 | - Implement pairs 33 | - Implement pick 34 | - Implement Python test for range 35 | - Implement result 36 | - Reduce/reduceRight now mimic the JS impl 37 | - Remove for_each alias 38 | - Update to underscore.js 1.4.3 API 39 | 40 | 0.02 2012-02-08 41 | 42 | - Import _ function by an arbitrary name 43 | 44 | 0.01 2012-02-02 45 | 46 | - Initial release 47 | -------------------------------------------------------------------------------- /t/chaining.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::Spec; 5 | 6 | use UnderscoreJS; 7 | 8 | describe 'value' => sub { 9 | it 'must return value' => sub { 10 | is(_(1)->value, 1); 11 | is_deeply(_([1, 2, 3])->value, [1, 2, 3]); 12 | }; 13 | }; 14 | 15 | describe 'map/flatten/reduce' => sub { 16 | it 'must count all the letters in the song' => sub { 17 | my $lyrics = [ 18 | "I'm a lumberjack and I'm okay", 19 | "I sleep all night and I work all day", 20 | "He's a lumberjack and he's okay", 21 | "He sleeps all night and he works all day" 22 | ]; 23 | my $counts = 24 | _($lyrics)->chain->map(sub { my ($line) = @_; split '', $line; }) 25 | ->flatten->reduce( 26 | sub { 27 | my ($hash, $l) = @_; 28 | $hash->{$l} = $hash->{$l} || 0; 29 | $hash->{$l}++; 30 | return $hash; 31 | }, 32 | {} 33 | )->value; 34 | ok($counts->{a} == 16 && $counts->{e} == 10); 35 | }; 36 | }; 37 | 38 | describe 'select/reject/sortBy' => sub { 39 | my $numbers = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]; 40 | $numbers = _($numbers)->chain->select( 41 | sub { 42 | my ($n) = @_; 43 | return $n % 2 == 0; 44 | } 45 | )->reject( 46 | sub { 47 | my ($n) = @_; 48 | return $n % 4 == 0; 49 | } 50 | )->sortBy( 51 | sub { 52 | my ($n) = @_; 53 | return -$n; 54 | } 55 | )->value; 56 | is_deeply($numbers, [10, 6, 2]); 57 | }; 58 | 59 | describe 'reverse/concat/unshift/pop/map' => sub { 60 | my $numbers = [1, 2, 3, 4, 5]; 61 | $numbers = _($numbers) 62 | ->chain 63 | ->reverse 64 | ->concat([5, 5, 5]) 65 | ->unshift(17) 66 | ->pop 67 | ->map(sub { my ($n) = @_; return $n * 2; }) 68 | ->value; 69 | is_deeply($numbers, [34, 10, 8, 6, 4, 2, 10, 10]); 70 | }; 71 | 72 | describe 'select/pluck' => sub { 73 | my $people = [ 74 | {name => 'curly', age => 31}, 75 | {name => 'rab', age => 10}, 76 | {name => 'moe', age => 50} 77 | ]; 78 | 79 | my $result = _($people)->chain->select( 80 | sub { 81 | my $person = shift; 82 | return ($person->{age} % 2) == 0; 83 | } 84 | )->pluck('name')->value; 85 | 86 | is(join(', ', @{$result}), 'rab, moe'); 87 | }; 88 | 89 | describe 'sort/map' => sub { 90 | my $result = _([1, 2, 3, 4])->chain->sort->map(sub{ $_[0] + 1 })->value; 91 | is(join(', ', @{$result}), '2, 3, 4, 5'); 92 | }; 93 | 94 | runtests unless caller; 95 | -------------------------------------------------------------------------------- /t/functions.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::Spec; 5 | 6 | use UnderscoreJS; 7 | 8 | describe 'bind' => sub { 9 | it 'can bind a function to a context' => sub { 10 | my $context = {name => 'moe'}; 11 | my $func = sub { 12 | my ($this, $arg) = @_; 13 | return "name: " . ($this->{name} || $arg); 14 | }; 15 | my $bound = _->bind($func, $context); 16 | is($bound->(), 'name: moe'); 17 | 18 | $bound = _($func)->bind($context); 19 | is($bound->(), 'name: moe', 'can do OO-style binding'); 20 | }; 21 | 22 | it 'can bind without specifying a context' => sub { 23 | my $func = sub { 24 | my ($this, $arg) = @_; 25 | return "name: " . ($this->{name} || $arg); 26 | }; 27 | my $bound = _->bind($func, undef, 'curly'); 28 | is($bound->(), 'name: curly'); 29 | }; 30 | 31 | it 'the function was partially applied in advance' => sub { 32 | my $func = sub { 33 | my ($this, $salutation, $name) = @_; 34 | return $salutation . ': ' . $name; 35 | }; 36 | $func = _->bind($func, {}, 'hello'); 37 | is($func->('moe'), 'hello: moe', ); 38 | }; 39 | 40 | it 41 | 'the function was partially applied in advance and can accept multiple arguments' 42 | => sub { 43 | my $func = sub { 44 | my ($this, $salutation, $firstname, $lastname) = @_; 45 | return $salutation . ': ' . $firstname . ' ' . $lastname; 46 | }; 47 | $func = _->bind($func, {}, 'hello', 'moe', 'curly'); 48 | is($func->(), 'hello: moe curly'); 49 | }; 50 | 51 | describe 'edge cases' => sub { 52 | my $func = sub { 53 | my ($this, $context) = @_; 54 | 55 | is($this, $context); 56 | }; 57 | 58 | it 'can bind a function to 0' => sub { 59 | _->bind($func, 0, 0)->(); 60 | }; 61 | 62 | it 'can bind a function to empty string' => sub { 63 | _->bind($func, '', '')->(); 64 | }; 65 | 66 | it 'can bind a function to false' => sub { 67 | _->bind($func, _->false, _->false)->(); 68 | }; 69 | }; 70 | }; 71 | 72 | describe 'once' => sub { 73 | it 'must be called once' => sub { 74 | my $num = 0; 75 | my $increment = _->once(sub { $num++; }); 76 | $increment->(); 77 | $increment->(); 78 | is($num, 1); 79 | }; 80 | }; 81 | 82 | describe 'wrap' => sub { 83 | it 'wrapped the saluation function' => sub { 84 | my $greet = sub { my ($name) = @_; "hi: " . $name; }; 85 | my $backwards = _->wrap( 86 | $greet => sub { 87 | my ($func, $name) = @_; 88 | return $func->($name) . ' ' 89 | . join('', reverse(split('', $name))); 90 | } 91 | ); 92 | is($backwards->('moe'), 'hi: moe eom'); 93 | }; 94 | 95 | it 'inner' => sub { 96 | my $inner = sub { return "Hello "; }; 97 | my $obj = {name => "Moe"}; 98 | $obj->{hi} = _->wrap( 99 | $inner => sub { 100 | my ($fn, $name) = @_; 101 | return $fn->() . $name; 102 | } 103 | ); 104 | is($obj->{hi}->($obj->{name}), "Hello Moe"); 105 | }; 106 | }; 107 | 108 | describe 'compose' => sub { 109 | my $greet = sub { my ($name) = @_; return "hi: " . $name; }; 110 | my $exclaim = sub { my ($sentence) = @_; return $sentence . '!'; }; 111 | 112 | it 'can compose a function that takes another' => sub { 113 | my $composed = _->compose($exclaim, $greet); 114 | is($composed->('moe'), 'hi: moe!'); 115 | }; 116 | 117 | it 'otherway around' => sub { 118 | my $composed = _->compose($greet, $exclaim); 119 | is($composed->('moe'), 'hi: moe!'); 120 | }; 121 | }; 122 | 123 | describe 'after' => sub { 124 | my $invoke_after = sub { 125 | my ($after_amount, $times_called) = @_; 126 | my $after_called = 0; 127 | my $after = _->after($after_amount, sub { ++$after_called; }); 128 | while ($times_called--) { $after->(); } 129 | return $after_called; 130 | }; 131 | 132 | it 'does call the subroutine after the threshold is reached' => sub { 133 | is($invoke_after->(5, 5), 1); 134 | }; 135 | 136 | it 'does not call the subroutine if the threshold is not reached' => sub { 137 | is($invoke_after->(5, 4), 0); 138 | }; 139 | 140 | it 'does continue to call the subroutine after the threshold is reached' => sub { 141 | is($invoke_after->(5, 10), 6); 142 | }; 143 | }; 144 | 145 | runtests unless caller; 146 | -------------------------------------------------------------------------------- /t/utility.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::Spec; 5 | 6 | use UnderscoreJS; 7 | 8 | describe 'uniqueId' => sub { 9 | it 'can generate a globally-unique stream of ids' => sub { 10 | my $ids = []; 11 | my $i = 0; 12 | while ($i++ < 100) { push @$ids, _->uniqueId } 13 | is(@{_->uniq($ids)}, @$ids); 14 | }; 15 | }; 16 | 17 | describe 'result' => sub { 18 | it 'calls a subroutine reference' => sub { 19 | my $expected = 'yay'; 20 | my $o = { code => sub { return $expected } }; 21 | is(_->result($o, 'code'), $expected); 22 | }; 23 | it 'returns the value of a non-subroutine key' => sub { 24 | my $expected = 'yay'; 25 | my $o = { key => $expected }; 26 | is(_->result($o, 'key'), $expected); 27 | }; 28 | }; 29 | 30 | describe 'times' => sub { 31 | it 'is 0 indexed' => sub { 32 | my $vals = []; 33 | _->times(3, sub { my ($i) = @_; push @$vals, $i; }); 34 | is_deeply($vals, [0, 1, 2]); 35 | }; 36 | 37 | it 'works as a wrapper' => sub { 38 | my $vals = []; 39 | _(3)->times(sub { my ($i) = @_; push @$vals, $i; }); 40 | is_deeply($vals, [0, 1, 2]); 41 | }; 42 | }; 43 | 44 | describe 'mixin' => sub { 45 | before each => sub { 46 | _->mixin( 47 | myReverse => sub { 48 | my ($string) = @_; 49 | 50 | return join '', reverse split '', $string; 51 | } 52 | ); 53 | }; 54 | 55 | it 'mixed in a function to _' => sub { 56 | is(_->myReverse('panacea'), 'aecanap'); 57 | }; 58 | 59 | it 'mixed in a function to the OOP wrapper' => sub { 60 | is(_('champ')->myReverse, 'pmahc'); 61 | }; 62 | }; 63 | 64 | describe 'template' => sub { 65 | it 'can do basic attribute interpolation' => sub { 66 | my $basicTemplate = 67 | _->template(q{<%= $thing %> is gettin' on my noives!}); 68 | my $result = $basicTemplate->({thing => 'This'}); 69 | is($result, "This is gettin' on my noives!"); 70 | }; 71 | 72 | it 'backslashes' => sub { 73 | my $backslashTemplate = 74 | _->template("<%= \$thing %> is \\ridanculous"); 75 | is($backslashTemplate->({thing => 'This'}), "This is \\ridanculous"); 76 | }; 77 | 78 | it 'can run arbitrary javascript in templates' => sub { 79 | my $fancyTemplate = _->template( 80 | '' 81 | ); 82 | my $result = $fancyTemplate->( 83 | {people => {moe => "Moe", larry => "Larry", curly => "Curly"}}); 84 | is($result, "",); 85 | }; 86 | 87 | it 'simple' => sub { 88 | my $noInterpolateTemplate = _->template( 89 | "

Just some text. Hey, I know this is silly but it aids consistency.

" 90 | ); 91 | my $result = $noInterpolateTemplate->(); 92 | is($result, 93 | "

Just some text. Hey, I know this is silly but it aids consistency.

" 94 | ); 95 | }; 96 | 97 | it 'quotes' => sub { 98 | my $quoteTemplate = _->template("It's its, not it's"); 99 | is($quoteTemplate->({}), "It's its, not it's"); 100 | }; 101 | 102 | it 'quotes in statemets and body' => sub { 103 | my $quoteInStatementAndBody = _->template( 104 | q!<% if($foo eq 'bar'){ %>Statement quotes and 'quotes'.<% } %>!); 105 | is($quoteInStatementAndBody->({foo => "bar"}), 106 | "Statement quotes and 'quotes'."); 107 | }; 108 | 109 | it 'newlines and tabs' => sub { 110 | my $withNewlinesAndTabs = 111 | _->template('This\n\t\tis: <%= $x %>.\n\tok.\nend.'); 112 | is( $withNewlinesAndTabs->({x => 'that'}), 113 | 'This\n\t\tis: that.\n\tok.\nend.' 114 | ); 115 | }; 116 | 117 | describe 'template with custom settings' => sub { 118 | my $u = _; 119 | $u->template_settings( 120 | evaluate => qr/\{\{([\s\S]+?)\}\}/, 121 | interpolate => qr/\{\{=([\s\S]+?)\}\}/ 122 | ); 123 | 124 | it 'can run arbitrary javascript in templates' => sub { 125 | my $custom = $u->template( 126 | q!! 127 | ); 128 | my $result = $custom->( 129 | { people => 130 | {moe => "Moe", larry => "Larry", curly => "Curly"} 131 | } 132 | ); 133 | is($result, ""); 134 | }; 135 | 136 | it 'quotes' => sub { 137 | my $customQuote = $u->template("It's its, not it's"); 138 | is($customQuote->({}), "It's its, not it's"); 139 | }; 140 | 141 | it 'quote in statement and body' => sub { 142 | my $quoteInStatementAndBody = $u->template( 143 | q!{{ if($foo eq 'bar'){ }}Statement quotes and 'quotes'.{{ } }}! 144 | ); 145 | is($quoteInStatementAndBody->({foo => "bar"}), 146 | "Statement quotes and 'quotes'."); 147 | }; 148 | }; 149 | 150 | describe 'template with custom settings and special chars' => sub { 151 | my $u = _; 152 | $u->template_settings( 153 | evaluate => qr/<\?([\s\S]+?)\?>/, 154 | interpolate => qr/<\?=([\s\S]+?)\?>/ 155 | ); 156 | 157 | it 'can run arbitrary javascript in templates' => sub { 158 | my $customWithSpecialChars = $u->template(q!!); 159 | my $result = $customWithSpecialChars->({people => {moe => "Moe", larry => "Larry", curly => "Curly"}}); 160 | is($result, ""); 161 | }; 162 | 163 | it 'quotes' => sub { 164 | my $customWithSpecialCharsQuote = $u->template("It's its, not it's"); 165 | is($customWithSpecialCharsQuote->({}), "It's its, not it's"); 166 | }; 167 | 168 | it 'quote in statement and body' => sub { 169 | my $quoteInStatementAndBody = $u->template(q!Statement quotes and 'quotes'.!); 170 | is($quoteInStatementAndBody->({foo => "bar"}), "Statement quotes and 'quotes'."); 171 | }; 172 | }; 173 | 174 | describe 'mustache' => sub { 175 | my $u = _; 176 | $u->template_settings(interpolate => qr/\{\{(.+?)\}\}/); 177 | 178 | it 'can mimic mustache.js' => sub { 179 | my $mustache = $u->template(q/Hello {{$planet}}!/); 180 | is($mustache->({planet => "World"}), "Hello World!"); 181 | }; 182 | }; 183 | }; 184 | 185 | runtests unless caller; 186 | -------------------------------------------------------------------------------- /t/objects.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::Spec; 5 | 6 | use UnderscoreJS; 7 | 8 | describe 'keys' => sub { 9 | it 'can extract the keys from an object' => sub { 10 | is_deeply([sort @{_->keys({one => 1, two => 2})}], ['one', 'two']); 11 | }; 12 | 13 | it 'throws an error for undefined values' => sub { 14 | eval { _->keys(undef) }; 15 | ok $@; 16 | }; 17 | 18 | it 'throws an error for number primitives' => sub { 19 | eval { _->keys(1) }; 20 | ok $@; 21 | }; 22 | 23 | it 'throws an error for string primitives' => sub { 24 | eval { _->keys('foo') }; 25 | ok $@; 26 | }; 27 | 28 | it 'throws an error for boolean primitives' => sub { 29 | eval { _->keys(_->true) }; 30 | ok $@; 31 | }; 32 | }; 33 | 34 | describe 'values' => sub { 35 | it 'can extract the values from an object' => sub { 36 | is_deeply([sort @{_->values({one => 1, two => 2})}], [1, 2]); 37 | }; 38 | }; 39 | 40 | describe 'pairs' => sub { 41 | it 'can convert a hash into pairs' => sub { 42 | is_deeply( 43 | [sort { $a->[0] cmp $b->[0] } @{_->pairs({one => 1, two => 2})}], 44 | [['one', 1], ['two', 2]]); 45 | }; 46 | }; 47 | 48 | describe 'pick' => sub { 49 | it 'can restrict properties to those named' => sub { 50 | is_deeply(_->pick({a => 1, b => 2, c => 3}, 'a', 'c'), 51 | {a => 1, c => 3}); 52 | }; 53 | it 'can restrict properties to those named in an array' => sub { 54 | is_deeply(_->pick({a => 1, b => 2, c => 3}, ['a', 'c']), 55 | {a => 1, c => 3}); 56 | }; 57 | it 'can restrict properties to those named in a mix' => sub { 58 | is_deeply(_->pick({a => 1, b => 2, c => 3}, ['a'], 'c'), 59 | {a => 1, c => 3}); 60 | }; 61 | }; 62 | 63 | describe 'omit' => sub { 64 | it 'can omit a single key' => sub { 65 | is_deeply(_->omit({a => 1, b => 2, c => 3}, 'b'), {a => 1, c => 3}); 66 | }; 67 | it 'can omit many keys' => sub { 68 | is_deeply(_->omit({a => 1, b => 2, c => 3}, 'b', 'a'), {c => 3}); 69 | }; 70 | it 'can omit many keys in an array' => sub { 71 | is_deeply(_->omit({a => 1, b => 2, c => 3}, ['b', 'a']), {c => 3}); 72 | }; 73 | it 'can omit many keys in a mix' => sub { 74 | is_deeply(_->omit({a => 1, b => 2, c => 3}, ['b'], 'a'), {c => 3}); 75 | }; 76 | }; 77 | 78 | describe 'functions' => sub { 79 | it 'can grab the function names of any passed-in object' => sub { 80 | my $cb = sub { }; 81 | my $result = _->functions( 82 | { 83 | a => 'dash', 84 | b => sub { }, 85 | c => qr//, 86 | d => sub { } 87 | } 88 | ); 89 | is_deeply([sort @$result], ['b', 'd']); 90 | }; 91 | }; 92 | 93 | describe 'extend' => sub { 94 | it 'can extend an object with the attributes of another' => sub { 95 | is_deeply(_->extend({}, {a => 'b'}), {a => 'b'}); 96 | }; 97 | 98 | it 'properties in source override destination' => sub { 99 | is_deeply(_->extend({a => 'x'}, {a => 'b'}), {a => 'b'}); 100 | }; 101 | 102 | it 'properties not in source dont get overriden' => sub { 103 | is_deeply(_->extend({x => 'x'}, {a => 'b'}), {x => 'x', a => 'b'}); 104 | }; 105 | 106 | it 'can extend from multiple source objects' => sub { 107 | is_deeply(_->extend({x => 'x'}, {a => 'a'}, {b => 'b'}), 108 | {x => 'x', a => 'a', b => 'b'}); 109 | }; 110 | 111 | it 'extending from multiple source objects last property trumps' => sub { 112 | is_deeply(_->extend({x => 'x'}, {a => 'a', x => 2}, {a => 'b'}), 113 | {x => '2', a => 'b'}); 114 | }; 115 | 116 | it 'does not copy undefined values' => sub { 117 | is_deeply(_->extend({}, {a => 0, b => undef}), {a => 0}); 118 | }; 119 | }; 120 | 121 | describe 'defaults' => sub { 122 | my $options; 123 | 124 | before each => sub { 125 | $options = {zero => 0, one => 1, empty => "", string => "string"}; 126 | }; 127 | 128 | it 'must set defaults values' => sub { 129 | _->defaults($options, {zero => 1, one => 10, twenty => 20}); 130 | is($options->{zero}, 0); 131 | is($options->{one}, 1); 132 | is($options->{twenty}, 20); 133 | }; 134 | 135 | it 'must set multiple defaults' => sub { 136 | _->defaults( 137 | $options, 138 | {empty => "full"}, 139 | {word => "word"}, 140 | {word => "dog"} 141 | ); 142 | is($options->{empty}, ""); 143 | is($options->{word}, "word"); 144 | }; 145 | }; 146 | 147 | describe 'clone' => sub { 148 | it 'must make a shallow copy' => sub { 149 | my $moe = {name => 'moe', lucky => [13, 27, 34]}; 150 | my $clone = _->clone($moe); 151 | is($clone->{name}, 'moe'); 152 | 153 | $clone->{name} = 'curly'; 154 | ok($clone->{name} eq 'curly' && $moe->{name} eq 'moe'); 155 | 156 | push @{$clone->{lucky}}, 101; 157 | is($moe->{lucky}->[-1], 101); 158 | }; 159 | }; 160 | 161 | # TODO 162 | describe 'isEqual' => sub { 163 | it 'must compare object deeply' => sub { 164 | my $moe = {name => 'moe', lucky => [13, 27, 34]}; 165 | my $clone = {name => 'moe', lucky => [13, 27, 34]}; 166 | ok($moe ne $clone); 167 | ok(_->isEqual($moe, $clone)); 168 | ok(_($moe)->isEqual($clone)); 169 | }; 170 | }; 171 | 172 | describe 'isEmpty' => sub { 173 | it 'must check if value is empty' => sub { 174 | ok(!_([1])->isEmpty()); 175 | ok(_->isEmpty([])); 176 | ok(!_->isEmpty({one => 1})); 177 | ok(_->isEmpty({})); 178 | ok(_->isEmpty(qr//)); 179 | ok(_->isEmpty(undef)); 180 | ok(_->isEmpty()); 181 | ok(_->isEmpty('')); 182 | ok(!_->isEmpty('moe')); 183 | }; 184 | }; 185 | 186 | describe 'isArray' => sub { 187 | it 'must check if value is an array' => sub { 188 | ok(_->isArray([1, 2, 3])); 189 | }; 190 | }; 191 | 192 | describe 'isString' => sub { 193 | it 'must check if value is a string' => sub { 194 | ok(_->isString('hello')); 195 | ok(!_->isString(1)); 196 | }; 197 | }; 198 | 199 | describe 'isNumber' => sub { 200 | it 'must check if value is a number' => sub { 201 | ok(!_->isNumber('string')); 202 | ok(!_->isNumber(undef)); 203 | ok(_->isNumber(3 * 4 - 7 / 10)); 204 | }; 205 | }; 206 | 207 | describe 'isBoolean' => sub { 208 | it 'must check if value is boolean' => sub { 209 | ok(!_->isBoolean(2), 'a number is not a boolean'); 210 | ok(!_->isBoolean("string"), 'a string is not a boolean'); 211 | ok(!_->isBoolean("false"), 'the string "false" is not a boolean'); 212 | ok(!_->isBoolean("true"), 'the string "true" is not a boolean'); 213 | ok(!_->isBoolean(undef), 'undefined is not a boolean'); 214 | ok(_->isBoolean(_->true), 'but true is'); 215 | ok(_->isBoolean(_->false), 'and so is false'); 216 | }; 217 | }; 218 | 219 | describe 'isFunction' => sub { 220 | it 'must check if value is a function' => sub { 221 | ok(!_->isFunction([1, 2, 3])); 222 | ok(!_->isFunction('moe')); 223 | ok(_->isFunction(sub { })); 224 | }; 225 | }; 226 | 227 | describe 'isRegExp' => sub { 228 | it 'must check if value is a regexp' => sub { 229 | ok(!_->isRegExp(sub { })); 230 | ok(_->isRegExp(qr/identity/)); 231 | }; 232 | }; 233 | 234 | describe 'isUndefined' => sub { 235 | it 'must check if value is undefined' => sub { 236 | ok(!_->isUndefined(1), 'numbers are defined'); 237 | ok(!_->isUndefined(_->false), 'false is defined'); 238 | ok(!_->isUndefined(0), '0 is defined'); 239 | ok(_->isUndefined(), 'nothing is undefined'); 240 | ok(_->isUndefined(undef), 'undefined is undefined'); 241 | }; 242 | }; 243 | 244 | runtests unless caller; 245 | -------------------------------------------------------------------------------- /t/arrays.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::Spec; 5 | 6 | use UnderscoreJS; 7 | 8 | describe 'first' => sub { 9 | it 'can pull out the first element of an array' => sub { 10 | is(_->first([1, 2, 3]), 1); 11 | }; 12 | 13 | it 'can perform OO-style "first()"' => sub { 14 | is(_([1, 2, 3])->first(), 1); 15 | }; 16 | 17 | it 'can pass an index to first' => sub { 18 | is(join(', ', @{_->first([1, 2, 3], 0)}), ""); 19 | }; 20 | 21 | it 'can pass an index to first' => sub { 22 | is(join(', ', @{_->first([1, 2, 3], 2)}), '1, 2'); 23 | }; 24 | 25 | it 'works on an arguments object.' => sub { 26 | my $cb = sub { return _->first([@_]) }; 27 | my $result = $cb->(4, 3, 2, 1); 28 | is($result, 4); 29 | }; 30 | 31 | it 'aliased as "head"' => sub { 32 | is(_->head([1, 2, 3]), 1); 33 | }; 34 | 35 | it 'aliased as "take"' => sub { 36 | is(join(', ', @{_->take([1, 2, 3], 2)}), '1, 2'); 37 | }; 38 | }; 39 | 40 | describe 'initial' => sub { 41 | it 'can pull out all but the last element of an array' => sub { 42 | is(join(', ', @{_->initial([1, 2, 3, 4, 5])}), '1, 2, 3, 4'); 43 | }; 44 | 45 | it 'can take an index' => sub { 46 | is(join(', ', @{_->initial([1, 2, 3, 4, 5], 3)}), '1, 2, 3'); 47 | }; 48 | 49 | it 'handles the case of an empty array gracefully' => sub { 50 | ok(!@{_->initial([])}); 51 | }; 52 | 53 | it 'handles the case of a zero index gracefully' => sub { 54 | is(join(', ', @{_->initial([1, 2, 3], 0)}), ''); 55 | }; 56 | 57 | it 'handles the case of a negative index gracefully' => sub { 58 | is(join(', ', @{_->initial([1, 2, 3], -1)}), ''); 59 | }; 60 | }; 61 | 62 | describe 'object' => sub { 63 | it 'zips two arrays into a single hash' => sub { 64 | my $result = _->object(['moe', 'larry', 'curly'], [30, 40, 50]); 65 | my $expected = {moe => 30, larry => 40, curly => 50}; 66 | is_deeply($result, $expected); 67 | }; 68 | 69 | it 'zips an array of key=value pairs into a single hash' => sub { 70 | my $result = _->object([['one', 1], ['two', 2], ['three', 3]]); 71 | my $expected = {one => 1, two => 2, three => 3}; 72 | is_deeply($result, $expected); 73 | }; 74 | }; 75 | 76 | describe 'rest' => sub { 77 | it 'working rest()' => sub { 78 | my $numbers = [1, 2, 3, 4]; 79 | is(join(', ', @{_->rest($numbers)}), '2, 3, 4'); 80 | is(join(', ', @{_->rest($numbers, 0)}), '1, 2, 3, 4'); 81 | is(join(', ', @{_->rest($numbers, 2)}), '3, 4'); 82 | }; 83 | 84 | it 'aliased as tail and works on arguments object' => sub { 85 | my $cb = sub { _([@_])->tail; }; 86 | my $result = $cb->(1, 2, 3, 4); 87 | is(join(', ', @$result), '2, 3, 4'); 88 | }; 89 | }; 90 | 91 | describe 'last' => sub { 92 | it 'can pull out the last element of an array' => sub { 93 | is(_->last([1, 2, 3]), 3); 94 | }; 95 | 96 | it 'works on an arguments object' => sub { 97 | my $cb = sub { _([@_])->last }; 98 | my $result = $cb->(1, 2, 3, 4); 99 | is($result, 4); 100 | }; 101 | }; 102 | 103 | describe 'compact' => sub { 104 | it 'can trim out all falsy values' => sub { 105 | 106 | is(@{_->compact([0, 1, _->false, 2, '', 3])}, 3); 107 | }; 108 | 109 | it 'works on an arguments object' => sub { 110 | my $cb = sub { _([@_])->compact }; 111 | 112 | my $result = $cb->(0, 1, _->false, 2, '', 3); 113 | is(scalar @$result, 3); 114 | }; 115 | }; 116 | 117 | describe 'flatten' => sub { 118 | it 'can flatten nested arrays' => sub { 119 | my $list = [1, [2], [3, [[[4]]]]]; 120 | is(join(', ', @{_->flatten($list)}), '1, 2, 3, 4'); 121 | }; 122 | 123 | it 'works on an arguments object' => sub { 124 | my $cb = sub { _([@_])->flatten }; 125 | my $result = $cb->([1, [2], [3, [[[4]]]]]); 126 | is(join(', ', @$result), '1, 2, 3, 4'); 127 | }; 128 | }; 129 | 130 | describe 'without' => sub { 131 | it 'can remove all instances of an object' => sub { 132 | my $list = [1, 2, 1, 0, 3, 1, 4]; 133 | is(join(', ', @{_->without($list, 0, 1)}), '2, 3, 4'); 134 | }; 135 | 136 | it 'works on an arguments object' => sub { 137 | my $cb = sub { _->without(@_, 0, 1) }; 138 | my $result = $cb->([1, 2, 1, 0, 3, 1, 4]); 139 | is(join(', ', @$result), '2, 3, 4'); 140 | }; 141 | 142 | it 'uses real object identity for comparisons.' => sub { 143 | my $list = [{one => 1}, {two => 2}]; 144 | is(@{_->without($list, {one => 1})}, 2); 145 | is(@{_->without($list, $list->[0])}, 1); 146 | }; 147 | }; 148 | 149 | describe 'uniq' => sub { 150 | it 'can find the unique values of an unsorted array' => sub { 151 | my $list = [1, 2, 1, 3, 1, 4]; 152 | is(join(', ', @{_->uniq($list)}), '1, 2, 3, 4'); 153 | }; 154 | 155 | it 'can find the unique values of a sorted array faster' => sub { 156 | my $list = [1, 1, 1, 2, 2, 3]; 157 | is(join(', ', @{_->uniq($list, _->true)}), '1, 2, 3',); 158 | }; 159 | 160 | it 'works on an arguments object' => sub { 161 | my $cb = sub { _->uniq([@_]) }; 162 | my $result = $cb->(1, 2, 3, 4); 163 | is(join(', ', @$result), '1, 2, 3, 4'); 164 | }; 165 | 166 | it 'aliased as "unique"' => sub { 167 | my $list = [1, 2, 1, 3, 1, 4]; 168 | is(join(', ', @{_->unique($list)}), '1, 2, 3, 4'); 169 | }; 170 | }; 171 | 172 | describe 'intersection' => sub { 173 | my $stooges; 174 | my $leaders; 175 | 176 | before each => sub { 177 | $stooges = ['moe', 'curly', 'larry']; 178 | $leaders = ['moe', 'groucho']; 179 | }; 180 | 181 | it 'can take the set intersection of two arrays' => sub { 182 | is_deeply(_->intersection($stooges, $leaders), ['moe']); 183 | }; 184 | 185 | it 'can perform an OO-style intersection' => sub { 186 | is_deeply(_($stooges)->intersection($leaders), ['moe']); 187 | }; 188 | 189 | it 'works on an arguments object' => sub { 190 | my $cb = sub { _->intersection(@_, $leaders) }; 191 | is_deeply($cb->($stooges), ['moe']); 192 | }; 193 | }; 194 | 195 | describe 'union' => sub { 196 | it 'takes the union of a list of arrays' => sub { 197 | my $result = _->union([1, 2, 3], [2, 30, 1], [1, 40]); 198 | is_deeply([sort @$result], [1, 2, 3, 30, 40]); 199 | }; 200 | }; 201 | 202 | describe 'difference' => sub { 203 | it 'takes the difference of two arrays' => sub { 204 | my $result = _->difference([1, 2, 3], [2, 30, 40]); 205 | is_deeply([sort @$result], [1, 3]); 206 | }; 207 | }; 208 | 209 | describe 'zip' => sub { 210 | it 'zipped together arrays of different lengths' => sub { 211 | my $names = ['moe', 'larry', 'curly']; 212 | my $ages = [30, 40, 50]; 213 | my $leaders = [_->true]; 214 | my $stooges = _->zip($names, $ages, $leaders); 215 | is_deeply($stooges, 216 | ['moe', 30, _->true, 'larry', 40, undef, 'curly', 50, undef]); 217 | }; 218 | }; 219 | 220 | describe 'indexOf' => sub { 221 | 222 | it 'can compute indexOf' => sub { 223 | my $numbers = [1, 2, 3]; 224 | is(_->indexOf($numbers, 2), 1); 225 | }; 226 | 227 | it 'works on an arguments object' => sub { 228 | my $cb = sub { _->indexOf([@_], 2) }; 229 | is($cb->(1, 2, 3), 1); 230 | }; 231 | 232 | it 'handles nulls properly' => sub { 233 | is(_->indexOf(undef, 2), -1); 234 | }; 235 | 236 | it '35 is not in the list' => sub { 237 | my $numbers = [10, 20, 30, 40, 50]; 238 | my $num = 35; 239 | my $index = _->indexOf($numbers, $num, _->true); 240 | is($index, -1); 241 | }; 242 | 243 | it '40 is in the list' => sub { 244 | my $numbers = [10, 20, 30, 40, 50]; 245 | my $num = 40; 246 | my $index = _->indexOf($numbers, $num, _->true); 247 | is($index, 3); 248 | }; 249 | 250 | it '40 is in the list' => sub { 251 | my $numbers = [1, 40, 40, 40, 40, 40, 40, 40, 50, 60, 70]; 252 | my $num = 40; 253 | my $index = _->indexOf($numbers, $num, _->true); 254 | is($index, 1); 255 | }; 256 | }; 257 | 258 | describe 'lastIndexOf' => sub { 259 | it 'computes last index of the element in array' => sub { 260 | my $numbers = [1, 0, 1, 0, 0, 1, 0, 0, 0]; 261 | is(_->lastIndexOf($numbers, 1), 5); 262 | is(_->lastIndexOf($numbers, 0), 8); 263 | }; 264 | 265 | it 'works on an arguments object' => sub { 266 | my $cb = sub { _->lastIndexOf([@_], 1) }; 267 | my $result = $cb->(1, 0, 1, 0, 0, 1, 0, 0, 0); 268 | is($result, 5); 269 | }; 270 | 271 | it 'handles nulls properly' => sub { 272 | is(_->indexOf(undef, 2), -1); 273 | }; 274 | }; 275 | 276 | describe 'range' => sub { 277 | it 'range with 0 as a first argument generates an empty array' => sub { 278 | is_deeply(_->range(0), []); 279 | }; 280 | 281 | it 'range with a single positive argument generates an array of elements 0,1,2,...,n-1' => sub { 282 | is_deeply(_->range(4), [0, 1, 2, 3]); 283 | }; 284 | 285 | it 'range with two arguments a & b, a sub { 286 | is_deeply(_->range(5, 8), [5, 6, 7]); 287 | }; 288 | 289 | it 'range with two arguments a & b, b sub { 290 | is_deeply(_->range(8, 5), []); 291 | }; 292 | 293 | it 'range with three arguments a & b & c, c < b-a, a < b generates an array of elements a,a+c,a+2c,...,b - (multiplier of a) < c' => sub { 294 | is_deeply(_->range(3, 10, 3), [3, 6, 9]); 295 | }; 296 | 297 | it 'range with three arguments a & b & c, c > b-a, a < b generates an array with a single element, equal to a' => sub { 298 | is_deeply(_->range(3, 10, 15), [3]); 299 | }; 300 | 301 | it 'range with three arguments a & b & c, a > b, c < 0 generates an array of elements a,a-c,a-2c and ends with the number not less than b' => sub { 302 | is_deeply(_->range(12, 7, -2), [12, 10, 8]); 303 | }; 304 | 305 | it 'final example in the Python docs' => sub { 306 | is_deeply(_->range(0, -10, -1), [0, -1, -2, -3, -4, -5, -6, -7, -8, -9]); 307 | }; 308 | }; 309 | 310 | runtests unless caller; 311 | -------------------------------------------------------------------------------- /t/collections.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::Spec; 5 | use Try::Tiny; 6 | 7 | use UnderscoreJS; 8 | 9 | describe 'Each iterators' => sub { 10 | they "provide value and iteration count" => sub { 11 | _->each( 12 | [1, 2, 3] => sub { 13 | my ($num, $i) = @_; 14 | is($num, $i + 1); 15 | } 16 | ); 17 | }; 18 | 19 | it "context object property accessed" => sub { 20 | my $answers = []; 21 | 22 | _->each( 23 | [1, 2, 3] => sub { 24 | my ($num, undef, $ctx) = @_; 25 | push @$answers, $num * $ctx->{multiplier}; 26 | }, 27 | {multiplier => 5} 28 | ); 29 | 30 | is(join(', ', @$answers), '5, 10, 15'); 31 | }; 32 | 33 | 34 | it 'aliased as "forEach"' => sub { 35 | my $answers = []; 36 | 37 | _->forEach( 38 | [1, 2, 3] => sub { 39 | my ($num) = @_; 40 | 41 | push @$answers, $num; 42 | } 43 | ); 44 | is(join(', ', @$answers), '1, 2, 3'); 45 | }; 46 | 47 | it 'iterating over objects works, and ignores the object prototype.'; 48 | 49 | it 'can reference the original collection from inside the iterator' => 50 | sub { 51 | my $answer = undef; 52 | 53 | _->each( 54 | [1, 2, 3] => sub { 55 | my ($num, $index, $arr) = @_; 56 | 57 | if (_->include($arr, $num)) { 58 | $answer = 1; 59 | } 60 | } 61 | ); 62 | 63 | ok($answer); 64 | }; 65 | 66 | it 'handles a null properly' => sub { 67 | my $answers = 0; 68 | _->each( 69 | undef, 70 | sub { 71 | ++$answers; 72 | } 73 | ); 74 | is($answers, 0); 75 | }; 76 | }; 77 | 78 | describe 'A map' => sub { 79 | it 'doubled numbers' => sub { 80 | my $doubles = _->map( 81 | [1, 2, 3] => sub { 82 | my ($num) = @_; 83 | 84 | return $num * 2; 85 | } 86 | ); 87 | 88 | is(join(', ', @$doubles), '2, 4, 6'); 89 | }; 90 | 91 | it 'multiplied by index' => sub { 92 | my $result = _->map( 93 | [1, 2, 3] => sub { 94 | my ($num, $index) = @_; 95 | 96 | return $num * $index; 97 | } 98 | ); 99 | 100 | is(join(', ', @$result), '1, 4, 9'); 101 | }; 102 | 103 | it 'tripled numbers with context' => sub { 104 | my $triples = _->map( 105 | [1, 2, 3] => sub { 106 | my ($num, $index, $context) = @_; 107 | 108 | return $num * $context->{multiplier}; 109 | }, 110 | {multiplier => 3} 111 | ); 112 | 113 | is(join(', ', @$triples), '3, 6, 9'); 114 | }; 115 | 116 | it 'OO-style doubled numbers' => sub { 117 | my $doubled = 118 | _([1, 2, 3])->map(sub { my ($num) = @_; return $num * 2; }); 119 | is(join(', ', @$doubled), '2, 4, 6'); 120 | }; 121 | 122 | it 'aliased as "collect"' => sub { 123 | my $doubled = 124 | _([1, 2, 3])->collect(sub { my ($num) = @_; return $num * 2; }); 125 | is(join(', ', @$doubled), '2, 4, 6'); 126 | }; 127 | 128 | it 'handles a null properly' => sub { 129 | my $ifnull = _->map(undef, sub { }); 130 | ok(_->isArray($ifnull) && @$ifnull == 0); 131 | }; 132 | 133 | it 'if context is undefined then list becomes context' => sub { 134 | my $list_as_ctx = undef; 135 | my $list = [1, 2, 3]; 136 | my $triples = _->map( 137 | $list => sub { 138 | my ($num, $index, $context) = @_; 139 | $list_as_ctx = $context unless defined $list_as_ctx; 140 | return $num * 3; 141 | } 142 | # no explicit context 143 | ); 144 | 145 | is(join(', ', @$triples), '3, 6, 9'); 146 | is_deeply($list_as_ctx, $list); 147 | }; 148 | }; 149 | 150 | describe 'Reduce' => sub { 151 | it 'can sum up an array' => sub { 152 | my $sum = _->reduce( 153 | [1, 2, 3] => sub { 154 | my ($sum, $num) = @_; 155 | 156 | return $sum + $num; 157 | } => 0 158 | ); 159 | is($sum, 6); 160 | }; 161 | 162 | it 'can reduce with a context object' => sub { 163 | my $context = {multiplier => 3}; 164 | my $sum = _->reduce( 165 | [1, 2, 3] => sub { 166 | my ($sum, $num, $context) = @_; 167 | return $sum + $num * $context->{multiplier}; 168 | } => 0, 169 | $context 170 | ); 171 | is($sum, 18); 172 | }; 173 | 174 | it 'aliased as "inject"' => sub { 175 | my $sum = _->inject( 176 | [1, 2, 3] => sub { 177 | my ($sum, $num) = @_; 178 | 179 | return $sum + $num; 180 | } => 0 181 | ); 182 | is($sum, 6); 183 | }; 184 | 185 | it 'OO-style reduce' => sub { 186 | my $sum = _([1, 2, 3])->reduce( 187 | sub { 188 | my ($sum, $num) = @_; 189 | 190 | return $sum + $num; 191 | } => 0 192 | ); 193 | is($sum, 6); 194 | }; 195 | 196 | it 'default initial value' => sub { 197 | my $sum = _->reduce( 198 | [1, 2, 3] => sub { 199 | my ($sum, $num) = @_; 200 | return $sum + $num; 201 | } 202 | ); 203 | is($sum, 6); 204 | }; 205 | 206 | it 'handles a null (without inital value) properly' => sub { 207 | my $ifnull; 208 | 209 | try { 210 | _->reduce(undef, sub { }); 211 | } 212 | catch { 213 | $ifnull = $_; 214 | }; 215 | 216 | ok($ifnull); 217 | }; 218 | 219 | it 'handles a null (with initial value) properly' => sub { 220 | is(_->reduce(undef, sub { }, 138), 138); 221 | }; 222 | 223 | it 'initially-sparse arrays with no memo' => sub { 224 | my $sparseArray = []; 225 | $sparseArray->[100] = 10; 226 | $sparseArray->[200] = 20; 227 | 228 | my $result = _->reduce( 229 | $sparseArray => sub { my ($a, $b) = @_; return $a + $b } 230 | ); 231 | is($result, 30); 232 | }; 233 | }; 234 | 235 | describe 'rightReduce' => sub { 236 | it 'can perform right folds' => sub { 237 | my $list = _->reduceRight( 238 | ['foo', 'bar', 'baz'] => sub { 239 | my ($memo, $str) = @_; 240 | 241 | return $memo . $str; 242 | } => '' 243 | ); 244 | is($list, 'bazbarfoo'); 245 | }; 246 | 247 | it 'aliased as "foldr"' => sub { 248 | my $list = _->foldr( 249 | ['foo', 'bar', 'baz'] => sub { 250 | my ($memo, $str) = @_; 251 | 252 | return $memo . $str; 253 | } => '' 254 | ); 255 | is($list, 'bazbarfoo'); 256 | }; 257 | 258 | it 'default initial value' => sub { 259 | my $list = _->foldr( 260 | ['foo', 'bar', 'baz'] => sub { 261 | my ($memo, $str) = @_; 262 | return $memo . $str; 263 | } 264 | ); 265 | is($list, 'bazbarfoo'); 266 | }; 267 | 268 | it 'handles a null (without inital value) properly' => sub { 269 | my $ifnull; 270 | try { 271 | _->reduceRight(undef, sub { }); 272 | } 273 | catch { 274 | $ifnull = @_; 275 | }; 276 | ok($ifnull); 277 | }; 278 | 279 | it 'handles a null (with initial value) properly' => sub { 280 | is(_->reduceRight(undef, sub { }, 138), 138); 281 | }; 282 | }; 283 | 284 | describe 'detect' => sub { 285 | it 'found the first "2" and broke the loop' => sub { 286 | my $result = 287 | _->detect([1, 2, 3] => sub { my ($num) = @_; return $num * 2 == 4 } 288 | ); 289 | is($result, 2); 290 | }; 291 | it 'aliased as find' => sub { 292 | my $result = 293 | _->find([1, 2, 3] => sub { my ($num) = @_; return $num % 2 == 0 } 294 | ); 295 | is($result, 2); 296 | }; 297 | }; 298 | 299 | describe 'select' => sub { 300 | it 'selected each even number' => sub { 301 | my $evens = 302 | _->select([1, 2, 3, 4, 5, 6] => 303 | sub { my ($num) = @_; return $num % 2 == 0; }); 304 | is(join(', ', @$evens), '2, 4, 6'); 305 | }; 306 | 307 | it 'aliased as filter' => sub { 308 | my $evens = 309 | _->filter([1, 2, 3, 4, 5, 6] => 310 | sub { my ($num) = @_; return $num % 2 == 0; }); 311 | is(join(', ', @$evens), '2, 4, 6'); 312 | }; 313 | }; 314 | 315 | describe 'reject' => sub { 316 | it 'rejected each even number' => sub { 317 | my $odds = _->reject( 318 | [1, 2, 3, 4, 5, 6] => sub { 319 | my ($num) = @_; 320 | 321 | return $num % 2 == 0; 322 | } 323 | ); 324 | is(join(', ', @$odds), '1, 3, 5'); 325 | }; 326 | }; 327 | 328 | describe 'shuffle' => sub { 329 | it 'returns a list with the same number of elements' => sub { 330 | my $source = [ 1, 2, 3 ]; 331 | is(scalar @{_->shuffle($source)}, scalar @$source); 332 | }; 333 | }; 334 | 335 | describe 'all' => sub { 336 | 337 | it 'given an empty array returns 1' => sub { 338 | ok(_->all([], sub { die 'Iterator must not be called for the empty array.' })); 339 | }; 340 | 341 | it 'even numbers' => sub { 342 | ok( _->all( 343 | [0, 10, 28] => sub { $_ % 2 == 0 } 344 | ) 345 | ); 346 | }; 347 | 348 | it 'odd number' => sub { 349 | ok( !_->all( 350 | [0, 11, 28] => sub { my ($num) = @_; return $num % 2 == 0 } 351 | ) 352 | ); 353 | }; 354 | 355 | it 'aliased every' => sub { 356 | ok(_->every([1, 1, 1], sub { shift == 1; })); 357 | }; 358 | }; 359 | 360 | describe 'any' => sub { 361 | it 'the empty set' => sub { 362 | ok(!_->any([])); 363 | }; 364 | 365 | it 'all false values' => sub { 366 | ok(!_->any([0, 0, 0])); 367 | }; 368 | 369 | it 'one true value' => sub { 370 | ok(_->any([0, 0, 1])); 371 | }; 372 | 373 | it 'all odd numbers' => sub { 374 | ok( !_->any( 375 | [1, 11, 29] => sub { my ($num) = @_; return $num % 2 == 0 } 376 | ) 377 | ); 378 | }; 379 | 380 | it 'all even numbers' => sub { 381 | ok( _->any( 382 | [1, 10, 29] => sub { my ($num) = @_; return $num % 2 == 0 } 383 | ) 384 | ); 385 | }; 386 | 387 | it 'aliased as "some"' => sub { 388 | ok(_->some([0, 0, 1])); 389 | }; 390 | }; 391 | 392 | describe 'include' => sub { 393 | it 'two is in the array' => sub { 394 | ok(_->include([1, 2, 3], 2)); 395 | }; 396 | 397 | it 'two is not in the array' => sub { 398 | ok(!_->include([1, 3, 9], 2)); 399 | }; 400 | 401 | it '_->include on objects checks their values' => sub { 402 | ok(_->contains({moe => 1, larry => 3, curly => 9}, 3)); 403 | }; 404 | 405 | it 'OO-style include' => sub { 406 | ok(_([1, 2, 3])->include(2)); 407 | }; 408 | }; 409 | 410 | describe 'invoke w/ function reference' => sub { 411 | my $list; 412 | my $result; 413 | 414 | before each => sub { 415 | $list = [[5, 1, 7], [3, 2, 1]]; 416 | $result = _->invoke($list, sub { sort(@_) }); 417 | }; 418 | 419 | it 'first array sorted' => sub { 420 | is(join(', ', @{$result->[0]}), '1, 5, 7'); 421 | }; 422 | 423 | it 'second array sorted' => sub { 424 | is(join(', ', @{$result->[1]}), '1, 2, 3'); 425 | }; 426 | }; 427 | 428 | describe 'pluck' => sub { 429 | it 'pulls names out of objects' => sub { 430 | my $people = 431 | [{name => 'moe', age => 30}, {name => 'curly', age => 50}]; 432 | is(join(', ', @{_->pluck($people, 'name')}), 'moe, curly'); 433 | }; 434 | }; 435 | 436 | describe 'max' => sub { 437 | it 'can perform a regular Math.max' => sub { 438 | is(_->max([1, 2, 3]), 3); 439 | }; 440 | 441 | it 'can perform a computation-based max' => sub { 442 | my $neg = _->max([1, 2, 3], sub { my ($num) = @_; return -$num; }); 443 | is($neg, 1); 444 | }; 445 | }; 446 | 447 | describe 'min' => sub { 448 | it 'can perform a regular Math.min' => sub { 449 | is(_->min([1, 2, 3]), 1); 450 | }; 451 | 452 | it 'can perform a computation-based min' => sub { 453 | my $neg = _->min([1, 2, 3], sub { my ($num) = @_; return -$num; }); 454 | is($neg, 3); 455 | }; 456 | }; 457 | 458 | describe 'sort' => sub { 459 | it 'sorts regularly' => sub { 460 | my $list = [3, 2, 1]; 461 | is_deeply(_($list)->sort, [1, 2, 3]); 462 | }; 463 | }; 464 | 465 | describe 'sortBy' => sub { 466 | my $people = 467 | [{name => 'curly', age => 30}, {name => 'rab', age => 10}, {name => 'moe', age => 50}]; 468 | it 'stooges sorted by age' => sub { 469 | $people = _->sortBy($people, 470 | sub { my ($person) = @_; return $person->{age}; }); 471 | is(join(', ', @{_->pluck($people, 'name')}), 'rab, curly, moe'); 472 | }; 473 | it 'stooges sorted by name' => sub { 474 | $people = _->sortBy($people, 475 | sub { my ($person) = @_; return $person->{name}; }, 476 | undef, 477 | sub { my ($a, $b) = @_; $a cmp $b; }); 478 | is(join(', ', @{_->pluck($people, 'name')}), 'curly, moe, rab'); 479 | }; 480 | }; 481 | 482 | describe 'groupBy' => sub { 483 | it 'put each even number in the right group' => sub { 484 | my $parity = _->groupBy([1, 2, 3, 4, 5, 6], 485 | sub { my ($num) = @_; return $num % 2; }); 486 | is(join(', ', @{$parity->{0}}), '2, 4, 6'); 487 | }; 488 | }; 489 | 490 | describe 'countBy' => sub { 491 | it 'returns a count for the number of objects in each group' => sub { 492 | my $parity = _->countBy([1, 2, 3, 4, 5], 493 | sub { my ($num) = @_; return $num % 2 == 0 ? 'true' : 'false'; }); 494 | is($parity->{true}, 2); 495 | is($parity->{false}, 3); 496 | }; 497 | it 'is aliased as count_by' => sub { 498 | my $parity = _->count_by([1, 2, 3, 4, 5], 499 | sub { my ($num) = @_; return $num == 3 ? 'true' : 'false'; }); 500 | is($parity->{true}, 1); 501 | is($parity->{false}, 4); 502 | }; 503 | }; 504 | 505 | describe 'sortedIndex' => sub { 506 | it '35 must be inserted at index 3' => sub { 507 | my $numbers = [10, 20, 30, 40, 50]; 508 | my $num = 35; 509 | my $index = _->sortedIndex($numbers, $num); 510 | is($index, 3); 511 | }; 512 | }; 513 | 514 | describe 'toArray' => sub { 515 | it 'arguments object is not an array' => sub { 516 | ok(!_->isArray(my $arguments)); 517 | }; 518 | 519 | it 'arguments object converted into array' => sub { 520 | ok(_->isArray(_->toArray(my $arguments))); 521 | }; 522 | 523 | it 'cloned array contains same elements' => sub { 524 | my $a = [1, 2, 3]; 525 | ok(_->toArray($a) ne $a); 526 | is(join(', ', @{_->toArray($a)}), '1, 2, 3'); 527 | }; 528 | 529 | it 'object flattened into array' => sub { 530 | my $numbers = _->toArray({one => 1, two => 2, three => 3}); 531 | is(join(', ', sort @$numbers), '1, 2, 3'); 532 | }; 533 | }; 534 | 535 | describe 'size' => sub { 536 | it 'can compute the size of an object' => sub { 537 | is(_->size({one => 1, two => 2, three => 3}), 3); 538 | }; 539 | }; 540 | 541 | runtests unless caller; 542 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This software is copyright (c) 2011-2012 by Viacheslav Tykhanovskyi 2 | . (c) 2013 by Rich Douglas Evans 3 | C 4 | 5 | This is free software; you can redistribute it and/or modify it under 6 | the same terms as the Perl 5 programming language system itself. 7 | 8 | Terms of the Perl programming language system itself 9 | 10 | a) the GNU General Public License as published by the Free 11 | Software Foundation; either version 1, or (at your option) any 12 | later version, or 13 | b) the "Artistic License" 14 | 15 | --- The GNU General Public License, Version 1, February 1989 --- 16 | 17 | This software is copyright (c) 2011-2012 by Viacheslav Tykhanovskyi 18 | . (c) 2013 by Rich Douglas Evans 19 | C 20 | 21 | This is free software, licensed under: 22 | 23 | The GNU General Public License, Version 1, February 1989 24 | 25 | GNU GENERAL PUBLIC LICENSE 26 | Version 1, February 1989 27 | 28 | Copyright (C) 1989 Free Software Foundation, Inc. 29 | 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA 30 | 31 | Everyone is permitted to copy and distribute verbatim copies 32 | of this license document, but changing it is not allowed. 33 | 34 | Preamble 35 | 36 | The license agreements of most software companies try to keep users 37 | at the mercy of those companies. By contrast, our General Public 38 | License is intended to guarantee your freedom to share and change free 39 | software--to make sure the software is free for all its users. The 40 | General Public License applies to the Free Software Foundation's 41 | software and to any other program whose authors commit to using it. 42 | You can use it for your programs, too. 43 | 44 | When we speak of free software, we are referring to freedom, not 45 | price. Specifically, the General Public License is designed to make 46 | sure that you have the freedom to give away or sell copies of free 47 | software, that you receive source code or can get it if you want it, 48 | that you can change the software or use pieces of it in new free 49 | programs; and that you know you can do these things. 50 | 51 | To protect your rights, we need to make restrictions that forbid 52 | anyone to deny you these rights or to ask you to surrender the rights. 53 | These restrictions translate to certain responsibilities for you if you 54 | distribute copies of the software, or if you modify it. 55 | 56 | For example, if you distribute copies of a such a program, whether 57 | gratis or for a fee, you must give the recipients all the rights that 58 | you have. You must make sure that they, too, receive or can get the 59 | source code. And you must tell them their rights. 60 | 61 | We protect your rights with two steps: (1) copyright the software, and 62 | (2) offer you this license which gives you legal permission to copy, 63 | distribute and/or modify the software. 64 | 65 | Also, for each author's protection and ours, we want to make certain 66 | that everyone understands that there is no warranty for this free 67 | software. If the software is modified by someone else and passed on, we 68 | want its recipients to know that what they have is not the original, so 69 | that any problems introduced by others will not reflect on the original 70 | authors' reputations. 71 | 72 | The precise terms and conditions for copying, distribution and 73 | modification follow. 74 | 75 | GNU GENERAL PUBLIC LICENSE 76 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 77 | 78 | 0. This License Agreement applies to any program or other work which 79 | contains a notice placed by the copyright holder saying it may be 80 | distributed under the terms of this General Public License. The 81 | "Program", below, refers to any such program or work, and a "work based 82 | on the Program" means either the Program or any work containing the 83 | Program or a portion of it, either verbatim or with modifications. Each 84 | licensee is addressed as "you". 85 | 86 | 1. You may copy and distribute verbatim copies of the Program's source 87 | code as you receive it, in any medium, provided that you conspicuously and 88 | appropriately publish on each copy an appropriate copyright notice and 89 | disclaimer of warranty; keep intact all the notices that refer to this 90 | General Public License and to the absence of any warranty; and give any 91 | other recipients of the Program a copy of this General Public License 92 | along with the Program. You may charge a fee for the physical act of 93 | transferring a copy. 94 | 95 | 2. You may modify your copy or copies of the Program or any portion of 96 | it, and copy and distribute such modifications under the terms of Paragraph 97 | 1 above, provided that you also do the following: 98 | 99 | a) cause the modified files to carry prominent notices stating that 100 | you changed the files and the date of any change; and 101 | 102 | b) cause the whole of any work that you distribute or publish, that 103 | in whole or in part contains the Program or any part thereof, either 104 | with or without modifications, to be licensed at no charge to all 105 | third parties under the terms of this General Public License (except 106 | that you may choose to grant warranty protection to some or all 107 | third parties, at your option). 108 | 109 | c) If the modified program normally reads commands interactively when 110 | run, you must cause it, when started running for such interactive use 111 | in the simplest and most usual way, to print or display an 112 | announcement including an appropriate copyright notice and a notice 113 | that there is no warranty (or else, saying that you provide a 114 | warranty) and that users may redistribute the program under these 115 | conditions, and telling the user how to view a copy of this General 116 | Public License. 117 | 118 | d) You may charge a fee for the physical act of transferring a 119 | copy, and you may at your option offer warranty protection in 120 | exchange for a fee. 121 | 122 | Mere aggregation of another independent work with the Program (or its 123 | derivative) on a volume of a storage or distribution medium does not bring 124 | the other work under the scope of these terms. 125 | 126 | 3. You may copy and distribute the Program (or a portion or derivative of 127 | it, under Paragraph 2) in object code or executable form under the terms of 128 | Paragraphs 1 and 2 above provided that you also do one of the following: 129 | 130 | a) accompany it with the complete corresponding machine-readable 131 | source code, which must be distributed under the terms of 132 | Paragraphs 1 and 2 above; or, 133 | 134 | b) accompany it with a written offer, valid for at least three 135 | years, to give any third party free (except for a nominal charge 136 | for the cost of distribution) a complete machine-readable copy of the 137 | corresponding source code, to be distributed under the terms of 138 | Paragraphs 1 and 2 above; or, 139 | 140 | c) accompany it with the information you received as to where the 141 | corresponding source code may be obtained. (This alternative is 142 | allowed only for noncommercial distribution and only if you 143 | received the program in object code or executable form alone.) 144 | 145 | Source code for a work means the preferred form of the work for making 146 | modifications to it. For an executable file, complete source code means 147 | all the source code for all modules it contains; but, as a special 148 | exception, it need not include source code for modules which are standard 149 | libraries that accompany the operating system on which the executable 150 | file runs, or for standard header files or definitions files that 151 | accompany that operating system. 152 | 153 | 4. You may not copy, modify, sublicense, distribute or transfer the 154 | Program except as expressly provided under this General Public License. 155 | Any attempt otherwise to copy, modify, sublicense, distribute or transfer 156 | the Program is void, and will automatically terminate your rights to use 157 | the Program under this License. However, parties who have received 158 | copies, or rights to use copies, from you under this General Public 159 | License will not have their licenses terminated so long as such parties 160 | remain in full compliance. 161 | 162 | 5. By copying, distributing or modifying the Program (or any work based 163 | on the Program) you indicate your acceptance of this license to do so, 164 | and all its terms and conditions. 165 | 166 | 6. Each time you redistribute the Program (or any work based on the 167 | Program), the recipient automatically receives a license from the original 168 | licensor to copy, distribute or modify the Program subject to these 169 | terms and conditions. You may not impose any further restrictions on the 170 | recipients' exercise of the rights granted herein. 171 | 172 | 7. The Free Software Foundation may publish revised and/or new versions 173 | of the General Public License from time to time. Such new versions will 174 | be similar in spirit to the present version, but may differ in detail to 175 | address new problems or concerns. 176 | 177 | Each version is given a distinguishing version number. If the Program 178 | specifies a version number of the license which applies to it and "any 179 | later version", you have the option of following the terms and conditions 180 | either of that version or of any later version published by the Free 181 | Software Foundation. If the Program does not specify a version number of 182 | the license, you may choose any version ever published by the Free Software 183 | Foundation. 184 | 185 | 8. If you wish to incorporate parts of the Program into other free 186 | programs whose distribution conditions are different, write to the author 187 | to ask for permission. For software which is copyrighted by the Free 188 | Software Foundation, write to the Free Software Foundation; we sometimes 189 | make exceptions for this. Our decision will be guided by the two goals 190 | of preserving the free status of all derivatives of our free software and 191 | of promoting the sharing and reuse of software generally. 192 | 193 | NO WARRANTY 194 | 195 | 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 196 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 197 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 198 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 199 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 200 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 201 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 202 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 203 | REPAIR OR CORRECTION. 204 | 205 | 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 206 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 207 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 208 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 209 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 210 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 211 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 212 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 213 | POSSIBILITY OF SUCH DAMAGES. 214 | 215 | END OF TERMS AND CONDITIONS 216 | 217 | Appendix: How to Apply These Terms to Your New Programs 218 | 219 | If you develop a new program, and you want it to be of the greatest 220 | possible use to humanity, the best way to achieve this is to make it 221 | free software which everyone can redistribute and change under these 222 | terms. 223 | 224 | To do so, attach the following notices to the program. It is safest to 225 | attach them to the start of each source file to most effectively convey 226 | the exclusion of warranty; and each file should have at least the 227 | "copyright" line and a pointer to where the full notice is found. 228 | 229 | 230 | Copyright (C) 19yy 231 | 232 | This program is free software; you can redistribute it and/or modify 233 | it under the terms of the GNU General Public License as published by 234 | the Free Software Foundation; either version 1, or (at your option) 235 | any later version. 236 | 237 | This program is distributed in the hope that it will be useful, 238 | but WITHOUT ANY WARRANTY; without even the implied warranty of 239 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 240 | GNU General Public License for more details. 241 | 242 | You should have received a copy of the GNU General Public License 243 | along with this program; if not, write to the Free Software 244 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA 245 | 246 | 247 | Also add information on how to contact you by electronic and paper mail. 248 | 249 | If the program is interactive, make it output a short notice like this 250 | when it starts in an interactive mode: 251 | 252 | Gnomovision version 69, Copyright (C) 19xx name of author 253 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 254 | This is free software, and you are welcome to redistribute it 255 | under certain conditions; type `show c' for details. 256 | 257 | The hypothetical commands `show w' and `show c' should show the 258 | appropriate parts of the General Public License. Of course, the 259 | commands you use may be called something other than `show w' and `show 260 | c'; they could even be mouse-clicks or menu items--whatever suits your 261 | program. 262 | 263 | You should also get your employer (if you work as a programmer) or your 264 | school, if any, to sign a "copyright disclaimer" for the program, if 265 | necessary. Here a sample; alter the names: 266 | 267 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 268 | program `Gnomovision' (a program to direct compilers to make passes 269 | at assemblers) written by James Hacker. 270 | 271 | , 1 April 1989 272 | Ty Coon, President of Vice 273 | 274 | That's all there is to it! 275 | 276 | 277 | --- The Artistic License 1.0 --- 278 | 279 | This software is copyright (c) 2013 by Viacheslav Tykhanovskyi 280 | . 281 | 282 | This is free software, licensed under: 283 | 284 | The Artistic License 1.0 285 | 286 | The Artistic License 287 | 288 | Preamble 289 | 290 | The intent of this document is to state the conditions under which a Package 291 | may be copied, such that the Copyright Holder maintains some semblance of 292 | artistic control over the development of the package, while giving the users of 293 | the package the right to use and distribute the Package in a more-or-less 294 | customary fashion, plus the right to make reasonable modifications. 295 | 296 | Definitions: 297 | 298 | - "Package" refers to the collection of files distributed by the Copyright 299 | Holder, and derivatives of that collection of files created through 300 | textual modification. 301 | - "Standard Version" refers to such a Package if it has not been modified, 302 | or has been modified in accordance with the wishes of the Copyright 303 | Holder. 304 | - "Copyright Holder" is whoever is named in the copyright or copyrights for 305 | the package. 306 | - "You" is you, if you're thinking about copying or distributing this Package. 307 | - "Reasonable copying fee" is whatever you can justify on the basis of media 308 | cost, duplication charges, time of people involved, and so on. (You will 309 | not be required to justify it to the Copyright Holder, but only to the 310 | computing community at large as a market that must bear the fee.) 311 | - "Freely Available" means that no fee is charged for the item itself, though 312 | there may be fees involved in handling the item. It also means that 313 | recipients of the item may redistribute it under the same conditions they 314 | received it. 315 | 316 | 1. You may make and give away verbatim copies of the source form of the 317 | Standard Version of this Package without restriction, provided that you 318 | duplicate all of the original copyright notices and associated disclaimers. 319 | 320 | 2. You may apply bug fixes, portability fixes and other modifications derived 321 | from the Public Domain or from the Copyright Holder. A Package modified in such 322 | a way shall still be considered the Standard Version. 323 | 324 | 3. You may otherwise modify your copy of this Package in any way, provided that 325 | you insert a prominent notice in each changed file stating how and when you 326 | changed that file, and provided that you do at least ONE of the following: 327 | 328 | a) place your modifications in the Public Domain or otherwise make them 329 | Freely Available, such as by posting said modifications to Usenet or an 330 | equivalent medium, or placing the modifications on a major archive site 331 | such as ftp.uu.net, or by allowing the Copyright Holder to include your 332 | modifications in the Standard Version of the Package. 333 | 334 | b) use the modified Package only within your corporation or organization. 335 | 336 | c) rename any non-standard executables so the names do not conflict with 337 | standard executables, which must also be provided, and provide a separate 338 | manual page for each non-standard executable that clearly documents how it 339 | differs from the Standard Version. 340 | 341 | d) make other distribution arrangements with the Copyright Holder. 342 | 343 | 4. You may distribute the programs of this Package in object code or executable 344 | form, provided that you do at least ONE of the following: 345 | 346 | a) distribute a Standard Version of the executables and library files, 347 | together with instructions (in the manual page or equivalent) on where to 348 | get the Standard Version. 349 | 350 | b) accompany the distribution with the machine-readable source of the Package 351 | with your modifications. 352 | 353 | c) accompany any non-standard executables with their corresponding Standard 354 | Version executables, giving the non-standard executables non-standard 355 | names, and clearly documenting the differences in manual pages (or 356 | equivalent), together with instructions on where to get the Standard 357 | Version. 358 | 359 | d) make other distribution arrangements with the Copyright Holder. 360 | 361 | 5. You may charge a reasonable copying fee for any distribution of this 362 | Package. You may charge any fee you choose for support of this Package. You 363 | may not charge a fee for this Package itself. However, you may distribute this 364 | Package in aggregate with other (possibly commercial) programs as part of a 365 | larger (possibly commercial) software distribution provided that you do not 366 | advertise this Package as a product of your own. 367 | 368 | 6. The scripts and library files supplied as input to or produced as output 369 | from the programs of this Package do not automatically fall under the copyright 370 | of this Package, but belong to whomever generated them, and may be sold 371 | commercially, and may be aggregated with this Package. 372 | 373 | 7. C or perl subroutines supplied by you and linked into this Package shall not 374 | be considered part of this Package. 375 | 376 | 8. The name of the Copyright Holder may not be used to endorse or promote 377 | products derived from this software without specific prior written permission. 378 | 379 | 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 380 | WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 381 | MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 382 | 383 | The End 384 | -------------------------------------------------------------------------------- /lib/UnderscoreJS.pm: -------------------------------------------------------------------------------- 1 | package UnderscoreJS; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '0.07'; 7 | 8 | use B (); 9 | use List::MoreUtils (); 10 | use List::Util (); 11 | use Scalar::Util (); 12 | 13 | our $UNIQUE_ID = 0; 14 | 15 | sub import { 16 | my $class = shift; 17 | my (%options) = @_; 18 | 19 | my $name = $options{-as} || '_'; 20 | 21 | my $package = caller; 22 | no strict; 23 | *{"$package\::$name"} = \&_; 24 | } 25 | 26 | sub _ { 27 | return new(__PACKAGE__, args => [@_]); 28 | } 29 | 30 | sub new { 31 | my $class = shift; 32 | 33 | my $self = {@_}; 34 | bless $self, $class; 35 | 36 | $self->{template_settings} = { 37 | evaluate => qr/<\%([\s\S]+?)\%>/, 38 | interpolate => qr/<\%=([\s\S]+?)\%>/ 39 | }; 40 | 41 | return $self; 42 | } 43 | 44 | sub true { UnderscoreJS::_True->new } 45 | sub false { UnderscoreJS::_False->new } 46 | 47 | sub forEach {&each} 48 | 49 | sub each { 50 | my $self = shift; 51 | my ($array, $cb, $context) = $self->_prepare(@_); 52 | 53 | return unless defined $array; 54 | 55 | $context = $array unless defined $context; 56 | 57 | my $i = 0; 58 | foreach (@$array) { 59 | $cb->($_, $i, $context); 60 | $i++; 61 | } 62 | } 63 | 64 | sub collect {&map} 65 | 66 | sub map { 67 | my $self = shift; 68 | my ($array, $cb, $context) = $self->_prepare(@_); 69 | 70 | $context = $array unless defined $context; 71 | 72 | my $index = 0; 73 | my $result = [map { $cb->($_, ++$index, $context) } @$array]; 74 | 75 | return $self->_finalize($result); 76 | } 77 | 78 | sub contains {&include} 79 | 80 | sub include { 81 | my $self = shift; 82 | my ($list, $value) = $self->_prepare(@_); 83 | 84 | if (ref $list eq 'ARRAY') { 85 | return (List::Util::first { $_ eq $value } @$list) ? 1 : 0; 86 | } 87 | elsif (ref $list eq 'HASH') { 88 | return (List::Util::first { $_ eq $value } values %$list) ? 1 : 0; 89 | } 90 | 91 | die 'include only supports arrays and hashes'; 92 | } 93 | 94 | sub inject {&reduce} 95 | sub foldl {&reduce} 96 | 97 | sub reduce { 98 | my $self = shift; 99 | my ($array, $iterator, $memo, $context) = $self->_prepare(@_); 100 | 101 | die 'No list or memo' if !defined $array && !defined $memo; 102 | 103 | return $memo unless defined $array; 104 | 105 | my $initial = defined $memo; 106 | 107 | foreach (@$array) { 108 | if (!$initial && defined $_) { 109 | $memo = $_; 110 | $initial = 1; 111 | } else { 112 | $memo = $iterator->($memo, $_, $context) if defined $_; 113 | } 114 | } 115 | die 'No memo' if !$initial; 116 | return $self->_finalize($memo); 117 | } 118 | 119 | sub foldr {&reduce_right} 120 | sub reduceRight {&reduce_right} 121 | 122 | sub reduce_right { 123 | my $self = shift; 124 | my ($array, $iterator, $memo, $context) = $self->_prepare(@_); 125 | 126 | die 'No list or memo' if !defined $array && !defined $memo; 127 | 128 | return $memo unless defined $array; 129 | 130 | return _->reduce([reverse @$array], $iterator, $memo, $context); 131 | } 132 | 133 | sub find {&detect} 134 | 135 | sub detect { 136 | my $self = shift; 137 | my ($list, $iterator, $context) = $self->_prepare(@_); 138 | 139 | return List::Util::first { $iterator->($_) } @$list; 140 | } 141 | 142 | sub filter {&select} 143 | 144 | sub select { 145 | my $self = shift; 146 | my ($list, $iterator, $context) = $self->_prepare(@_); 147 | 148 | my $result = [grep { $iterator->($_) } @$list]; 149 | 150 | $self->_finalize($result); 151 | } 152 | 153 | sub reject { 154 | my $self = shift; 155 | my ($list, $iterator, $context) = $self->_prepare(@_); 156 | 157 | my $result = [grep { !$iterator->($_) } @$list]; 158 | 159 | $self->_finalize($result); 160 | } 161 | 162 | sub every {&all} 163 | 164 | sub all { 165 | my $self = shift; 166 | my ($list, $iterator, $context) = $self->_prepare(@_); 167 | 168 | foreach (@$list) { 169 | return 0 unless $iterator->($_); 170 | } 171 | 172 | return 1; 173 | } 174 | 175 | sub some {&any} 176 | 177 | sub any { 178 | my $self = shift; 179 | my ($list, $iterator, $context) = $self->_prepare(@_); 180 | 181 | return 0 unless @$list; 182 | 183 | foreach (@$list) { 184 | return 1 if $iterator ? $iterator->($_) : $_; 185 | } 186 | 187 | return 0; 188 | } 189 | 190 | sub invoke { 191 | my $self = shift; 192 | my ($list, $method, @args) = $self->_prepare(@_); 193 | 194 | my $result = []; 195 | 196 | foreach (@$list) { 197 | push @$result, 198 | [ref $method eq 'CODE' ? $method->(@$_) : $self->$method(@$_)]; 199 | } 200 | 201 | return $result; 202 | } 203 | 204 | sub pluck { 205 | my $self = shift; 206 | my ($list, $key) = $self->_prepare(@_); 207 | 208 | my $result = []; 209 | 210 | foreach (@$list) { 211 | push @$result, $_->{$key}; 212 | } 213 | 214 | return $self->_finalize($result); 215 | } 216 | 217 | sub _minmax { 218 | my $self = shift; 219 | my ($list, $iterator, $context, $behaviour) = $self->_prepare(@_); 220 | 221 | my $computed_list = [map { 222 | { original => $_, computed => $iterator->($_, $context) } 223 | } @$list]; 224 | 225 | return _->reduce( 226 | $computed_list 227 | , sub { 228 | my ($memo, $e) = @_; 229 | return $behaviour->($memo, $e); 230 | } 231 | , $computed_list->[0] 232 | )->{original}; 233 | } 234 | 235 | sub max { 236 | my $self = shift; 237 | my ($list, $iterator, $context) = $self->_prepare(@_); 238 | 239 | return List::Util::max(@$list) unless defined $iterator; 240 | 241 | return _->_minmax($list, $iterator, $context, sub { 242 | my ($max, $e) = @_; 243 | return ($e->{computed} > $max->{computed}) ? $e: $max; 244 | }); 245 | } 246 | 247 | sub min { 248 | my $self = shift; 249 | my ($list, $iterator, $context) = $self->_prepare(@_); 250 | 251 | return List::Util::min(@$list) unless defined $iterator; 252 | 253 | return _->_minmax($list, $iterator, $context, sub { 254 | my ($min, $e) = @_; 255 | return ($e->{computed} < $min->{computed}) ? $e: $min; 256 | }); 257 | } 258 | 259 | sub sort : method { 260 | my $self = shift; 261 | my ($list) = $self->_prepare(@_); 262 | 263 | return $self->_finalize([sort @$list]); 264 | } 265 | 266 | sub sortBy {&sort_by} 267 | 268 | sub sort_by { 269 | my $self = shift; 270 | my ($list, $iterator, $context, $comparator) = $self->_prepare(@_); 271 | 272 | my $cmp = defined $comparator ? $comparator : sub { my ($x, $y) = @_; $x <=> $y } ; 273 | 274 | my $result = [sort { $cmp->($iterator->($a, $context), $iterator->($b, $context)) } @$list]; 275 | 276 | return $self->_finalize($result); 277 | } 278 | 279 | sub reverse : method { 280 | my $self = shift; 281 | my ($list) = $self->_prepare(@_); 282 | 283 | my $result = [reverse @$list]; 284 | 285 | return $self->_finalize($result); 286 | } 287 | 288 | sub concat { 289 | my $self = shift; 290 | my ($list, $other) = $self->_prepare(@_); 291 | 292 | my $result = [@$list, @$other]; 293 | 294 | return $self->_finalize($result); 295 | } 296 | 297 | sub unshift : method { 298 | my $self = shift; 299 | my ($list, @elements) = $self->_prepare(@_); 300 | 301 | unshift @$list, @elements; 302 | my $result = $list; 303 | 304 | return $self->_finalize($result); 305 | } 306 | 307 | sub pop : method { 308 | my $self = shift; 309 | my ($list) = $self->_prepare(@_); 310 | 311 | pop @$list; 312 | my $result = $list; 313 | 314 | return $self->_finalize($result); 315 | } 316 | 317 | sub _partition { 318 | my $self = shift; 319 | my ($list, $iterator, $behaviour) = $self->_prepare(@_); 320 | 321 | my $result = {}; 322 | foreach (@{$list}) { 323 | my $group = $iterator->($_); 324 | $behaviour->($result, $group, $_); 325 | } 326 | return $self->_finalize($result); 327 | } 328 | 329 | sub groupBy {&group_by} 330 | 331 | sub group_by { 332 | my $self = shift; 333 | return $self->_partition(@_, sub { 334 | my ($result, $group, $o) = @_; 335 | if (exists $result->{$group}) { 336 | push @{$result->{$group}}, $o; 337 | } 338 | else { 339 | $result->{$group} = [$o]; 340 | } 341 | }); 342 | } 343 | 344 | sub countBy {&count_by} 345 | 346 | sub count_by { 347 | my $self = shift; 348 | return $self->_partition(@_, sub { 349 | my ($result, $group, $o) = @_; 350 | if (exists $result->{$group}) { 351 | $result->{$group} = $result->{$group} + 1; 352 | } 353 | else { 354 | $result->{$group} = 1; 355 | } 356 | }); 357 | } 358 | 359 | sub sortedIndex {&sorted_index} 360 | 361 | sub sorted_index { 362 | my $self = shift; 363 | my ($list, $value, $iterator) = $self->_prepare(@_); 364 | 365 | # TODO $iterator 366 | 367 | my $min = 0; 368 | my $max = @$list; 369 | my $mid; 370 | 371 | do { 372 | $mid = int(($min + $max) / 2); 373 | if ($value > $list->[$mid]) { 374 | $min = $mid + 1; 375 | } 376 | else { 377 | $max = $mid - 1; 378 | } 379 | } while ($list->[$mid] == $value || $min > $max); 380 | 381 | if ($list->[$mid] == $value) { 382 | return $mid; 383 | } 384 | 385 | return $mid + 1; 386 | } 387 | 388 | sub toArray {&to_array} 389 | 390 | sub to_array { 391 | my $self = shift; 392 | my ($list) = $self->_prepare(@_); 393 | 394 | return [values %$list] if ref $list eq 'HASH'; 395 | 396 | return [$list] unless ref $list eq 'ARRAY'; 397 | 398 | return [@$list]; 399 | } 400 | 401 | sub size { 402 | my $self = shift; 403 | my ($list) = $self->_prepare(@_); 404 | 405 | return scalar @$list if ref $list eq 'ARRAY'; 406 | 407 | return scalar keys %$list if ref $list eq 'HASH'; 408 | 409 | return 1; 410 | } 411 | 412 | sub head {&first} 413 | sub take {&first} 414 | 415 | sub first { 416 | my $self = shift; 417 | my ($array, $n) = $self->_prepare(@_); 418 | 419 | return $array->[0] unless defined $n; 420 | 421 | return [@{$array}[0 .. $n - 1]]; 422 | } 423 | 424 | sub initial { 425 | my $self = shift; 426 | my ($array, $n) = $self->_prepare(@_); 427 | 428 | $n = scalar @$array - 1 unless defined $n; 429 | 430 | return $self->take($array, $n); 431 | } 432 | 433 | sub tail {&rest} 434 | 435 | sub rest { 436 | my $self = shift; 437 | my ($array, $index) = $self->_prepare(@_); 438 | 439 | $index = 1 unless defined $index; 440 | 441 | return [@{$array}[$index .. $#$array]]; 442 | } 443 | 444 | sub last { 445 | my $self = shift; 446 | my ($array) = $self->_prepare(@_); 447 | 448 | return $array->[-1]; 449 | } 450 | 451 | sub shuffle { 452 | my $self = shift; 453 | my ($array) = $self->_prepare(@_); 454 | 455 | return [List::Util::shuffle @$array]; 456 | } 457 | 458 | sub compact { 459 | my $self = shift; 460 | my ($array) = $self->_prepare(@_); 461 | 462 | my $new_array = []; 463 | foreach (@$array) { 464 | push @$new_array, $_ if $_; 465 | } 466 | 467 | return $new_array; 468 | } 469 | 470 | sub flatten { 471 | my $self = shift; 472 | my ($array) = $self->_prepare(@_); 473 | 474 | my $cb; 475 | $cb = sub { 476 | my $result = []; 477 | foreach (@{$_[0]}) { 478 | if (ref $_ eq 'ARRAY') { 479 | push @$result, @{$cb->($_)}; 480 | } 481 | else { 482 | push @$result, $_; 483 | } 484 | } 485 | return $result; 486 | }; 487 | 488 | my $result = $cb->($array); 489 | 490 | return $self->_finalize($result); 491 | } 492 | 493 | sub without { 494 | my $self = shift; 495 | my ($array, @values) = $self->_prepare(@_); 496 | 497 | # Nice hack comparing hashes 498 | 499 | my $new_array = []; 500 | foreach my $el (@$array) { 501 | push @$new_array, $el 502 | unless defined List::Util::first { $el eq $_ } @values; 503 | } 504 | 505 | return $new_array; 506 | } 507 | 508 | sub unique {&uniq} 509 | 510 | sub uniq { 511 | my $self = shift; 512 | my ($array, $is_sorted) = $self->_prepare(@_); 513 | 514 | return [List::MoreUtils::uniq(@$array)] unless $is_sorted; 515 | 516 | # We can push first value to prevent unneeded -1 check 517 | my $new_array = [shift @$array]; 518 | foreach (@$array) { 519 | push @$new_array, $_ unless $_ eq $new_array->[-1]; 520 | } 521 | 522 | return $new_array; 523 | } 524 | 525 | sub intersection { 526 | my $self = shift; 527 | my (@arrays) = $self->_prepare(@_); 528 | 529 | my $seen = {}; 530 | foreach my $array (@arrays) { 531 | $seen->{$_}++ for @$array; 532 | } 533 | 534 | my $intersection = []; 535 | foreach (keys %$seen) { 536 | push @$intersection, $_ if $seen->{$_} == @arrays; 537 | } 538 | return $intersection; 539 | } 540 | 541 | sub union { 542 | my $self = shift; 543 | my (@arrays) = $self->_prepare(@_); 544 | 545 | my $seen = {}; 546 | foreach my $array (@arrays) { 547 | $seen->{$_}++ for @$array; 548 | } 549 | 550 | return [keys %$seen]; 551 | } 552 | 553 | sub difference { 554 | my $self = shift; 555 | my ($array, $other) = $self->_prepare(@_); 556 | 557 | my $new_array = []; 558 | foreach my $el (@$array) { 559 | push @$new_array, $el unless List::Util::first { $el eq $_ } @$other; 560 | } 561 | 562 | return $new_array; 563 | } 564 | 565 | sub object { 566 | my $self = shift; 567 | my (@arrays) = $self->_prepare(@_); 568 | 569 | my $object = {}; 570 | my $arrays_length = scalar @arrays; 571 | if ($arrays_length == 2) { 572 | my ($keys, $values) = @arrays; 573 | foreach my $i (0..scalar @$keys - 1) { 574 | my $key = $keys->[$i]; 575 | my $value = $values->[$i]; 576 | $object->{$key} = $value; 577 | } 578 | } elsif ($arrays_length == 1) { 579 | _->reduce($arrays[0] 580 | , sub { 581 | my ($o, $pair) = @_; 582 | $o->{$pair->[0]} = $pair->[1]; 583 | return $o; 584 | } 585 | , $object 586 | ); 587 | } 588 | return $object; 589 | } 590 | 591 | sub pairs { 592 | my $self = shift; 593 | my ($hash) = $self->_prepare(@_); 594 | 595 | return [map { [ $_ => $hash->{$_} ] } keys %$hash ]; 596 | } 597 | 598 | sub pick { 599 | my $self = shift; 600 | my ($hash, @picks) = $self->_prepare(@_); 601 | 602 | return _->reduce( 603 | _->flatten(\@picks) 604 | , sub { 605 | my ($o, $pick) = @_; 606 | $o->{$pick} = $hash->{$pick}; 607 | return $o; 608 | } 609 | , {} 610 | ); 611 | } 612 | 613 | sub omit { 614 | my $self = shift; 615 | my ($hash, @omits) = $self->_prepare(@_); 616 | 617 | my %omit_these = map { $_ => $_ } @{_->flatten(\@omits)}; 618 | return _->reduce( 619 | [keys %$hash] 620 | , sub { 621 | my ($o, $key) = @_; 622 | $o->{$key} = $hash->{$key} unless exists $omit_these{$key}; 623 | return $o; 624 | } 625 | , {} 626 | ); 627 | } 628 | 629 | sub zip { 630 | my $self = shift; 631 | my (@arrays) = $self->_prepare(@_); 632 | 633 | # This code is from List::MoreUtils 634 | # (can't use it here directly because of the prototype!) 635 | my $max = -1; 636 | $max < $#$_ && ($max = $#$_) foreach @arrays; 637 | return [ 638 | map { 639 | my $ix = $_; 640 | map $_->[$ix], @_; 641 | } 0 .. $max 642 | ]; 643 | } 644 | 645 | sub indexOf {&index_of} 646 | 647 | sub index_of { 648 | my $self = shift; 649 | my ($array, $value, $is_sorted) = $self->_prepare(@_); 650 | 651 | return -1 unless defined $array; 652 | 653 | return List::MoreUtils::first_index { $_ eq $value } @$array; 654 | } 655 | 656 | sub lastIndexOf {&last_index_of} 657 | 658 | sub last_index_of { 659 | my $self = shift; 660 | my ($array, $value, $is_sorted) = $self->_prepare(@_); 661 | 662 | return -1 unless defined $array; 663 | 664 | return List::MoreUtils::last_index { $_ eq $value } @$array; 665 | } 666 | 667 | sub range { 668 | my $self = shift; 669 | my ($start, $stop, $step) = 670 | @_ == 3 ? @_ : @_ == 2 ? @_ : (undef, @_, undef); 671 | 672 | return [] unless $stop; 673 | 674 | $start = 0 unless defined $start; 675 | 676 | return [$start .. $stop - 1] unless defined $step; 677 | 678 | my $test = ($start < $stop) 679 | ? sub { $start < $stop } 680 | : sub { $start > $stop }; 681 | 682 | my $new_array = []; 683 | while ($test->()) { 684 | push @$new_array, $start; 685 | $start += $step; 686 | } 687 | return $new_array; 688 | } 689 | 690 | sub mixin { 691 | my $self = shift; 692 | my (%functions) = $self->_prepare(@_); 693 | 694 | no strict 'refs'; 695 | no warnings 'redefine'; 696 | foreach my $name (keys %functions) { 697 | *{__PACKAGE__ . '::' . $name} = sub { 698 | my $self = shift; 699 | 700 | unshift @_, @{$self->{args}} 701 | if defined $self->{args} && @{$self->{args}}; 702 | $functions{$name}->(@_); 703 | }; 704 | } 705 | } 706 | 707 | sub uniqueId {&unique_id} 708 | 709 | sub unique_id { 710 | my $self = shift; 711 | my ($prefix) = $self->_prepare(@_); 712 | 713 | $prefix = '' unless defined $prefix; 714 | 715 | return $prefix . ($UNIQUE_ID++); 716 | } 717 | 718 | sub result { 719 | my $self = shift; 720 | my ($hash, $key, @args) = $self->_prepare(@_); 721 | 722 | my $value = $hash->{$key}; 723 | return ref $value eq 'CODE' ? $value->(@args) : $value; 724 | } 725 | 726 | sub times { 727 | my $self = shift; 728 | my ($n, $iterator) = $self->_prepare(@_); 729 | 730 | for (0 .. $n - 1) { 731 | $iterator->($_); 732 | } 733 | } 734 | 735 | sub after { 736 | my $self = shift; 737 | my ($n, $func, @args) = $self->_prepare(@_); 738 | 739 | my $invocation_count = 0; 740 | return sub { 741 | return ++$invocation_count >= $n ? $func->(@args) : undef; 742 | }; 743 | } 744 | 745 | sub template_settings { 746 | my $self = shift; 747 | my (%args) = @_; 748 | 749 | for (qw/interpolate evaluate/) { 750 | if (my $value = $args{$_}) { 751 | $self->{template_settings}->{$_} = $value; 752 | } 753 | } 754 | } 755 | 756 | sub template { 757 | my $self = shift; 758 | my ($template) = $self->_prepare(@_); 759 | 760 | my $evaluate = $self->{template_settings}->{evaluate}; 761 | my $interpolate = $self->{template_settings}->{interpolate}; 762 | 763 | return sub { 764 | my ($args) = @_; 765 | 766 | my $code = q!sub {my ($args) = @_; my $_t = '';!; 767 | foreach my $arg (keys %$args) { 768 | $code .= "my \$$arg = \$args->{$arg};"; 769 | } 770 | 771 | $template =~ s{$interpolate}{\}; \$_t .= $1; \$_t .= q\{}g; 772 | $template =~ s{$evaluate}{\}; $1; \$_t .= q\{}g; 773 | 774 | $code .= '$_t .= q{'; 775 | $code .= $template; 776 | $code .= '};'; 777 | $code .= 'return $_t};'; 778 | 779 | my $sub = eval $code; 780 | 781 | return $sub->($args); 782 | }; 783 | } 784 | 785 | our $ONCE; 786 | 787 | sub once { 788 | my $self = shift; 789 | my ($func) = @_; 790 | 791 | return sub { 792 | return if $ONCE; 793 | 794 | $ONCE++; 795 | $func->(@_); 796 | }; 797 | } 798 | 799 | sub wrap { 800 | my $self = shift; 801 | my ($function, $wrapper) = $self->_prepare(@_); 802 | 803 | return sub { 804 | $wrapper->($function, @_); 805 | }; 806 | } 807 | 808 | sub compose { 809 | my $self = shift; 810 | my (@functions) = @_; 811 | 812 | return sub { 813 | my @args = @_; 814 | foreach (reverse @functions) { 815 | @args = $_->(@args); 816 | } 817 | 818 | return wantarray ? @args : $args[0]; 819 | }; 820 | } 821 | 822 | sub bind { 823 | my $self = shift; 824 | my ($function, $object, @args) = $self->_prepare(@_); 825 | 826 | return sub { 827 | $function->($object, @args, @_); 828 | }; 829 | } 830 | 831 | sub keys : method { 832 | my $self = shift; 833 | my ($object) = $self->_prepare(@_); 834 | 835 | die 'Not a hash reference' unless ref $object && ref $object eq 'HASH'; 836 | 837 | return [keys %$object]; 838 | } 839 | 840 | sub values { 841 | my $self = shift; 842 | my ($object) = $self->_prepare(@_); 843 | 844 | die 'Not a hash reference' unless ref $object && ref $object eq 'HASH'; 845 | 846 | return [values %$object]; 847 | } 848 | 849 | sub functions { 850 | my $self = shift; 851 | my ($object) = $self->_prepare(@_); 852 | 853 | die 'Not a hash reference' unless ref $object && ref $object eq 'HASH'; 854 | 855 | my $functions = []; 856 | foreach (keys %$object) { 857 | push @$functions, $_ 858 | if ref $object->{$_} && ref $object->{$_} eq 'CODE'; 859 | } 860 | return $functions; 861 | } 862 | 863 | sub extend { 864 | my $self = shift; 865 | my ($destination, @sources) = $self->_prepare(@_); 866 | 867 | foreach my $source (@sources) { 868 | foreach my $key (keys %$source) { 869 | next unless defined $source->{$key}; 870 | $destination->{$key} = $source->{$key}; 871 | } 872 | } 873 | 874 | return $destination; 875 | } 876 | 877 | sub defaults { 878 | my $self = shift; 879 | my ($object, @defaults) = $self->_prepare(@_); 880 | 881 | foreach my $default (@defaults) { 882 | foreach my $key (keys %$default) { 883 | next if exists $object->{$key}; 884 | $object->{$key} = $default->{$key}; 885 | } 886 | } 887 | 888 | return $object; 889 | } 890 | 891 | sub clone { 892 | my $self = shift; 893 | my ($object) = $self->_prepare(@_); 894 | 895 | # Scalars will be copied, everything deeper not 896 | my $cloned = {}; 897 | foreach my $key (keys %$object) { 898 | $cloned->{$key} = $object->{$key}; 899 | } 900 | 901 | return $cloned; 902 | } 903 | 904 | sub isEqual {&is_equal} 905 | 906 | sub is_equal { 907 | my $self = shift; 908 | my ($object, $other) = $self->_prepare(@_); 909 | } 910 | 911 | sub isEmpty {&is_empty} 912 | 913 | sub is_empty { 914 | my $self = shift; 915 | my ($object) = $self->_prepare(@_); 916 | 917 | return 1 unless defined $object; 918 | 919 | if (!ref $object) { 920 | return 1 if $object eq ''; 921 | } 922 | elsif (ref $object eq 'HASH') { 923 | return 1 if !(keys %$object); 924 | } 925 | elsif (ref $object eq 'ARRAY') { 926 | return 1 if @$object == 0; 927 | } 928 | elsif (ref $object eq 'Regexp') { 929 | return 1 if $object eq qr//; 930 | } 931 | 932 | return 0; 933 | } 934 | 935 | sub isArray {&is_array} 936 | 937 | sub is_array { 938 | my $self = shift; 939 | my ($object) = $self->_prepare(@_); 940 | 941 | return 1 if defined $object && ref $object && ref $object eq 'ARRAY'; 942 | 943 | return 0; 944 | } 945 | 946 | sub isString {&is_string} 947 | 948 | sub is_string { 949 | my $self = shift; 950 | my ($object) = $self->_prepare(@_); 951 | 952 | return 0 unless defined $object && !ref $object; 953 | 954 | return 0 if $self->is_number($object); 955 | 956 | return 1; 957 | } 958 | 959 | sub isNumber {&is_number} 960 | 961 | sub is_number { 962 | my $self = shift; 963 | my ($object) = $self->_prepare(@_); 964 | 965 | return 0 unless defined $object && !ref $object; 966 | 967 | # From JSON::PP 968 | my $flags = B::svref_2object(\$object)->FLAGS; 969 | my $is_number = $flags & (B::SVp_IOK | B::SVp_NOK) 970 | and !($flags & B::SVp_POK) ? 1 : 0; 971 | 972 | return 1 if $is_number; 973 | 974 | return 0; 975 | } 976 | 977 | sub isFunction {&is_function} 978 | 979 | sub is_function { 980 | my $self = shift; 981 | my ($object) = $self->_prepare(@_); 982 | 983 | return 1 if defined $object && ref $object && ref $object eq 'CODE'; 984 | 985 | return 0; 986 | } 987 | 988 | sub isRegExp {&is_regexp} 989 | 990 | sub is_regexp { 991 | my $self = shift; 992 | my ($object) = $self->_prepare(@_); 993 | 994 | return 1 if defined $object && ref $object && ref $object eq 'Regexp'; 995 | 996 | return 0; 997 | } 998 | 999 | sub isUndefined {&is_undefined} 1000 | 1001 | sub is_undefined { 1002 | my $self = shift; 1003 | my ($object) = $self->_prepare(@_); 1004 | 1005 | return 1 unless defined $object; 1006 | 1007 | return 0; 1008 | } 1009 | 1010 | sub isBoolean {&is_boolean} 1011 | 1012 | sub is_boolean { 1013 | my $self = shift; 1014 | my ($object) = @_; 1015 | 1016 | return 1 1017 | if Scalar::Util::blessed($object) 1018 | && ( $object->isa('UnderscoreJS::_True') 1019 | || $object->isa('UnderscoreJS::_False')); 1020 | 1021 | return 0; 1022 | } 1023 | 1024 | sub chain { 1025 | my $self = shift; 1026 | 1027 | $self->{chain} = 1; 1028 | 1029 | return $self; 1030 | } 1031 | 1032 | sub value { 1033 | my $self = shift; 1034 | 1035 | return wantarray ? @{$self->{args}} : $self->{args}->[0]; 1036 | } 1037 | 1038 | sub _prepare { 1039 | my $self = shift; 1040 | unshift @_, @{$self->{args}} if defined $self->{args} && @{$self->{args}}; 1041 | return @_; 1042 | } 1043 | 1044 | sub _finalize { 1045 | my $self = shift; 1046 | 1047 | return 1048 | $self->{chain} ? do { $self->{args} = [@_]; $self } 1049 | : wantarray ? @_ 1050 | : $_[0]; 1051 | } 1052 | 1053 | package UnderscoreJS::_True; 1054 | 1055 | use overload '""' => sub {'true'}, fallback => 1; 1056 | use overload 'bool' => sub {1}, fallback => 1; 1057 | use overload 'eq' => sub { $_[1] eq 'true' ? 1 : 0; }, fallback => 1; 1058 | use overload '==' => sub { $_[1] == 1 ? 1 : 0; }, fallback => 1; 1059 | 1060 | sub new { bless {}, $_[0] } 1061 | 1062 | package UnderscoreJS::_False; 1063 | 1064 | use overload '""' => sub {'false'}, fallback => 1; 1065 | use overload 'bool' => sub {0}, fallback => 1; 1066 | use overload 'eq' => sub { $_[1] eq 'false' ? 1 : 0; }, fallback => 1; 1067 | use overload '==' => sub { $_[1] == 0 ? 1 : 0; }, fallback => 1; 1068 | 1069 | sub new { bless {}, $_[0] } 1070 | 1071 | 1; 1072 | __END__ 1073 | 1074 | =head1 NAME 1075 | 1076 | UnderscoreJS - Perl port of Underscore.js 1077 | 1078 | =head1 SYNOPSIS 1079 | 1080 | use UnderscoreJS; 1081 | 1082 | _([3, 2, 1])->sort; 1083 | 1084 | =head1 DESCRIPTION 1085 | 1086 | L Perl is a clone of a popular JavaScript library 1087 | L. Why? Because Perl 1088 | is awesome. And because we can! 1089 | 1090 | /\ \ 1091 | __ __ ___ \_\ \ __ _ __ ____ ___ ___ _ __ __ 1092 | /\ \/\ \ /' _ `\ /'_` \ /'__`\/\`'__\/',__\ /'___\ / __`\/\`'__\/'__`\ 1093 | \ \ \_\ \/\ \/\ \/\ \ \ \/\ __/\ \ \//\__, `\/\ \__//\ \ \ \ \ \//\ __/ 1094 | \ \____/\ \_\ \_\ \___,_\ \____\\ \_\\/\____/\ \____\ \____/\ \_\\ \____\ 1095 | \/___/ \/_/\/_/\/__,_ /\/____/ \/_/ \/___/ \/____/\/___/ \/_/ \/____/ 1096 | ___ 1097 | __ /\_ \ 1098 | /\_\ ___ _____ __ _ __\//\ \ 1099 | \/\ \ /' _ `\ /\ '__`\ /'__`\/\`'__\\ \ \ 1100 | \ \ \/\ \/\ \ \ \ \ \ \/\ __/\ \ \/ \_\ \_ 1101 | \ \_\ \_\ \_\ \ \ ,__/\ \____\\ \_\ /\____\ 1102 | \/_/\/_/\/_/ \ \ \/ \/____/ \/_/ \/____/ 1103 | \ \_\ 1104 | \/_/ 1105 | 1106 | This document describes the differences. For the full introduction see original 1107 | page of L. 1108 | 1109 | The test suite is compatible with the original one, except for those functions 1110 | that were not ported. 1111 | 1112 | =head2 The main differences 1113 | 1114 | All the methods have CamelCase aliases. Use whatever you like. I 1115 | personally prefer underscores. 1116 | 1117 | Objects are simply hashes, not Perl objects. Maybe objects will be added 1118 | later. 1119 | 1120 | Of course not everything was ported. Some things don't make any sense 1121 | for Perl, other are impossible to implement without depending on event 1122 | loops and async programming. 1123 | 1124 | =head2 Implementation details 1125 | 1126 | Most of the functions are just wrappers around built-in functions. Others use 1127 | L and L modules. 1128 | 1129 | Numeric/String detection is done the same way L does it: by using 1130 | L hacks. 1131 | 1132 | Boolean values are implemented as overloaded methods, that return numbers or 1133 | strings depending on the context. 1134 | 1135 | _->true; 1136 | _->false; 1137 | 1138 | =head2 Object-Oriented and Functional Styles 1139 | 1140 | You can use Perl version in either an object-oriented or a functional style, 1141 | depending on your preference. The following two lines of code are identical 1142 | ways to double a list of numbers. 1143 | 1144 | _->map([1, 2, 3], sub { my ($n) = @_; $n * 2; }); 1145 | _([1, 2, 3])->map(sub { my ($n) = @_; $n * 2; }); 1146 | 1147 | =head1 DEVELOPMENT 1148 | 1149 | =head2 Repository 1150 | 1151 | http://github.com/vti/underscore-perl 1152 | 1153 | =head1 CREDITS 1154 | 1155 | Undescore.js authors and contributors 1156 | 1157 | =head1 AUTHORS 1158 | 1159 | Viacheslav Tykhanovskyi, C 1160 | Rich Douglas Evans, C 1161 | 1162 | =head1 COPYRIGHT AND LICENSE 1163 | 1164 | Copyright (C) 2011-2012, Viacheslav Tykhanovskyi 1165 | Copyright (C) 2013 Rich Douglas Evans 1166 | 1167 | This program is free software, you can redistribute it and/or modify it under 1168 | the terms of the Artistic License version 2.0. 1169 | 1170 | =cut 1171 | --------------------------------------------------------------------------------