Permalink
Browse files

Merge remote-tracking branch 'upstream/master'

Conflicts:
	Build.PL
  • Loading branch information...
2 parents c77d437 + 6a51af0 commit fd5d2d347a16c592f34e4b0ed9726e2fa987d8b2 @doherty committed Jan 14, 2012
Showing with 406 additions and 32 deletions.
  1. +1 −1 Build.PL
  2. +7 −1 Changes
  3. +57 −6 lib/perl5i.pm
  4. +9 −0 lib/perl5i/2.pm
  5. +66 −2 lib/perl5i/2/ARRAY.pm
  6. +3 −1 lib/perl5i/2/DateTime.pm
  7. +7 −2 lib/perl5i/2/RequireMessage.pm
  8. +15 −15 t/as_hash.t
  9. +7 −4 t/lib/Test/perl5i.pm
  10. +100 −0 t/pick.t
  11. +67 −0 t/popn.t
  12. +67 −0 t/shiftn.t
View
@@ -50,7 +50,7 @@ my $builder = MyBuild->new(
'true::VERSION' => '0.16',
'Capture::Tiny' => '0.06',
'utf8::all' => '0.002',
- 'bareword::filehandles' => '0.003',
+ 'circular::require' => '0.09',
},
build_requires => {
'ExtUtils::CBuilder' => '0.26',
View
@@ -1,7 +1,13 @@
-2.9.2
+2.10.0
Test Fixes
* Removed a use of Test::Exception, which we don't depend on.
+ New Features
+ * %hash = @array->as_hash; will turn all the values in @array to
+ keys in %hash. [github 172] (Prashan Dharmasena)
+ * @array->popn($n) and @array->shiftn() pop() and shift() multiple
+ elements off an array. [github 149] (Tanner Hobson)
+
2.9.1 Fri Nov 11 16:13:32 PST 2011
Bug Fixes
View
@@ -622,17 +622,42 @@ If @array is not a multiple of the iteration (for example, @array has
=head3 as_hash
- %hash = @array->as_hash;
+ my %hash = @array->as_hash;
-This method returns an array with the original elements of @array mapped to 1.
-Its functionality is the exact same as:
+This method returns a %hash where each element of @array is a key.
+The values are all true. Its functionality is similar to:
- %hash = map{ $_ => 1 } @array;
+ my %hash = map { $_ => 1 } @array;
Example usage:
- my @array = ("a", "b", "c");
- my %hash = @array->as_hash;
+ my @array = ("a", "b", "c");
+ my %hash = @array->as_hash;
+ say q[@array contains 'a'] if $hash{"a"};
+
+=head3 pick
+
+ my @rand = @array->pick($number);
+
+The pick() method returns a list of $number elements in @array.
+If $number is larger than the size of the list, it returns the entire list shuffled.
+
+Example usage:
+
+ my @array = (1, 2, 3, 4);
+ my @rand = @array->pick(2);
+
+=head3 pick_one
+
+ my $rand = @array->pick_one;
+
+The pick_one() method returns a random element in @array.
+It is similar to @array->pick(1), except that it does not return a list.
+
+Example usage:
+
+ my @array = (1,2,3,4);
+ my $rand = @array->pick_one;
=head3 diff
@@ -673,6 +698,32 @@ L<Path::Class>, etc.), it tries its best to treat them as strings or numbers.
[ $uri ]->diff( [ $uri2 ] ); # empty, they are equal
+=head3 popn
+
+ my @newarray = @array->popn($n);
+
+L<Pops|perlfunc/pop> C<$n> values from the C<@array>.
+
+If C<$n> is greater than the length of C<@array>, it will return the
+whole C<@array>. If C<$n> is 0, it will return an empty array.
+
+A negative C<$n> or non-integer is an error.
+
+ my @array = (1, 2, 3, 4, 5);
+ my @newarray = @array->popn(3); # (3, 4, 5)
+
+
+=head3 shiftn
+
+ my @newarray = @array->shiftn($n);
+
+Works like L<popn>, but it L<shifts|perlfunc/shift> off the front of
+the array instead of popping off the end.
+
+ my @array = (1, 2, 3, 4, 5);
+ my @newarray = @array->shiftn(3); # (1, 2, 3)
+
+
=head3 intersect
my @a = (1 .. 10);
View
@@ -7,6 +7,9 @@ use strict;
use warnings;
#This should come first
+use circular::require;
+
+# A few of the following modules have cycles, so turn off detection for now.
use perl5i::2::RequireMessage;
use IO::Handle;
@@ -32,6 +35,9 @@ use parent 'indirect';
use parent 'utf8::all';
use parent 'bareword::filehandles';
+# Enable cycle detection.
+no circular::require;
+
## no critic (Subroutines::RequireArgUnpacking)
sub import {
my $class = shift;
@@ -94,6 +100,9 @@ sub import {
# Current lexically active major version of perl5i.
$^H{perl5i} = 2;
+ # enable cycle detection
+ circular::require->unimport();
+
# autodie needs a bit more convincing
@_ = ( $class, ":all" );
goto &autodie::import;
View
@@ -45,16 +45,80 @@ method map( $code ) {
}
method as_hash{
- my @result = CORE::map{ $_ => 1 } @$self;
- return wantarray ? @result : \@result;
+ my %result = CORE::map { $_ => 1 } @$self;
+ return wantarray ? %result : \%result;
}
+
+method pick ( $num ){
+ Carp::croak("pick() takes the number of elements to pick")
+ unless defined $num;
+ Carp::croak("pick() takes a positive integer or zero, not '$num'")
+ unless $num->is_integer && ($num->is_positive or $num == 0);
+
+ if($num >= @$self){
+ my @result = List::Util::shuffle(@$self);
+ return wantarray ? @result : \@result;
+ }
+
+ # for the first position in the array, generate a random number that gives
+ # that element an n/N chance of being picked (where n is the number of elements to pick and N is the total array size);
+ # repeat for the rest of the array, each time altering the probability of
+ # the element being picked to reflect the number of elements picked so far and the number left.
+ my $num_left = @$self;
+ my @result;
+ my $i=0;
+ while($num > 0){
+ my $rand = int(rand($num_left));
+ if($rand < $num){
+ push(@result, $self->[$i]);
+ $num--;
+ }
+ $num_left--;
+ $i++;
+ }
+
+ return wantarray ? @result : \@result;
+}
+
+
+method pick_one() {
+ return @$self[int rand @$self];
+}
+
+
method grep($filter) {
my @result = CORE::grep { $_ ~~ $filter } @$self;
return wantarray ? @result : \@result;
}
+method popn($times) {
+ Carp::croak("popn() takes the number of elements to pop")
+ unless defined $times;
+ Carp::croak("popn() takes a positive integer or zero, not '$times'")
+ unless $times->is_integer && ($times->is_positive or $times == 0);
+
+ # splice() will choke if you walk off the array, so rein it in
+ $times = scalar(@$self) if ($times > scalar(@$self));
+
+ my @result = splice(@$self, -$times, $times);
+ return wantarray ? @result : \@result;
+}
+
+method shiftn($times) {
+ Carp::croak("shiftn() takes the number of elements to shift")
+ unless defined $times;
+ Carp::croak("shiftn() takes a positive integer or zero, not '$times'")
+ unless $times->is_integer && ($times->is_positive or $times == 0);
+
+ # splice() will choke if you walk off the array, so rein it in
+ $times = scalar(@$self) if ($times > scalar(@$self));
+
+ my @result = splice(@$self, 0, $times);
+ return wantarray ? @result : \@result;
+}
+
sub all {
require List::MoreUtils;
return &List::MoreUtils::all($_[1], @{$_[0]});
View
@@ -6,6 +6,9 @@ use 5.010;
use strict;
use warnings;
+use circular::require;
+use DateTime;
+
# Determine if we need Time::y2038 and only load if necessary.
# XXX This is a bit of a hack and should go into a config file.
use constant NEEDS_y2038 => (
@@ -29,7 +32,6 @@ sub dt_gmtime (;$) {
$mon++;
$year += 1900;
- require DateTime;
return perl5i::2::DateTime::y2038->new(
year => $year,
month => $mon,
@@ -6,8 +6,13 @@ use warnings;
my $diesub = sub {
my ( $sub, $mod ) = @_;
- my $hints = (caller(0))[10];
- return unless $hints->{perl5i};
+ my @caller;
+ my $count = 0;
+ @caller = caller($count++)
+ while !$caller[0] || $caller[0] eq 'circular::require';
+
+ return unless $caller[10]->{perl5i};
+
die( <<EOT );
Can't locate $mod in your Perl library. You may need to install it
from CPAN or another repository. Your library paths are:
View
@@ -1,16 +1,16 @@
- #!/usr/bin/perl
-
- use perl5i::latest;
- use Test::More;
-
- note 'array to hash'; {
- my @array = qw(a b c);
- my %hash = @array->as_hash;
-
- is_deeply \%hash, {a=>1, b=>1, c=>1};
- @array = (4, 3, 2, 1);
- %hash = @array->as_hash;
- is_deeply \%hash, {4=>1, 3=>1, 2=>1, 1=>1};
+#!/usr/bin/perl
+
+use perl5i::latest;
+use Test::More;
+
+note 'array to hash'; {
+ my @array = qw(a b c);
+ my %hash = @array->as_hash;
+ is_deeply \%hash, {a=>1, b=>1, c=>1};
+
+ @array = (4, 3, 2, 1);
+ my $hash = @array->as_hash;
+ is_deeply $hash, {4=>1, 3=>1, 2=>1, 1=>1};
}
-
- done_testing(2);
+
+done_testing;
View
@@ -3,7 +3,7 @@ package Test::perl5i;
use strict;
use warnings;
-use Test::More;
+use Test::More ();
use base qw(Exporter);
our @EXPORT = qw(throws_ok dies_ok lives_ok);
@@ -14,17 +14,20 @@ our @EXPORT = qw(throws_ok dies_ok lives_ok);
# Could use Test::Exception::LessClever but that's not testing on Windows
sub throws_ok(&$;$) {
my($code, $regex, $name) = @_;
+
+ my $tb = Test::More->builder;
+
my $lived = eval { $code->(); 1 };
if( $lived ) {
- fail($name);
- diag("It lived when it should have died");
+ $tb->ok(0, $name);
+ $tb->diag("It lived when it should have died");
}
- my $tb = Test::More->builder;
return $tb->like($@, $regex, $name);
}
sub dies_ok(&;$) {
my($code, $name) = @_;
+
my $lived = eval { $code->(); 1 };
my $tb = Test::More->builder;
Oops, something went wrong.

0 comments on commit fd5d2d3

Please sign in to comment.