File Coverage

blib/lib/Code/Embeddable.pm

Criterion	Covered	Total	%
statement	35	43	81.4
branch	10	14	71.4
condition			n/a
subroutine	9	9	100.0
pod	4	4	100.0
total	58	70	82.8

package Code::Embeddable;

our $DATE = '2015-06-18'; # DATE
our $VERSION = '0.04'; # VERSION

use 5.010001;
use strict;
use warnings;

# BEGIN_BLOCK: import
sub import {
    no strict 'refs';
    my $pkg = shift;
    my $caller = caller;
    my @imp = @_ ? @_ : @{__PACKAGE__.'::EXPORT'};
    for my $imp (@imp) {
        if (grep {$_ eq $imp} (@{__PACKAGE__.'::EXPORT'},
                               @{__PACKAGE__.'::EXPORT_OK'})) {
            *{"$caller\::$imp"} = \&{$imp};
        } else {
            die "$imp is not exported by ".__PACKAGE__;
        }
    }
}
# END_BLOCK: import

# BEGIN_BLOCK: pick
sub pick {
    return undef unless @_;
    return $_[@_*rand];
}
# END_BLOCK: pick

# BEGIN_BLOCK: pick_n
sub pick_n {
    my $n = shift;
    my @res;
    while (1) {
        last if @res >= $n;
        last unless @_;
        push @res, splice(@_, @_*rand(), 1);
    }
    @res;
}
# END_BLOCK: pick_n

# BEGIN_BLOCK: shuffle
sub shuffle {
    my @res;
    while (1) {
        last unless @_;
        push @res, splice(@_, @_*rand(), 1);
    }
    @res;
}
# END_BLOCK: shuffle

# copy-pasted from List::MoreUtils
# BEGIN_BLOCK: uniq
sub uniq (@) {
    my %seen = ();
    my $k;
    my $seen_undef;
    grep { defined $_ ? not $seen{ $k = $_ }++ : not $seen_undef++ } @_;
}
# END_BLOCK: uniq

if (0) { <<'_' }
# BEGIN_BLOCK: stacktrace_printer
my %OLD_SIG;
BEGIN {
    @OLD_SIG{qw/__DIE__ __WARN__/} = @SIG{qw/__DIE__ __WARN__/};
    my $longmess = sub {
        my $mess = '';
        my $i = 2;
        {
            package DB;
            while (my @caller = caller($i)) {
                if ($i == 2) { $mess .= $_[0] }
                $mess .= "\t";
                if ($caller[3]) { # subroutine
                    $mess .= "$caller[3](";
                    if ($caller[4]) { # has_args
                        my $j = 0;
                        for my $arg0 (@DB::args) {
                            my $arg = $arg0; # copy
                            if ($j++) { $mess .= ", " }
                            if (!defined($arg)) { $arg = "undef" }
                            elsif (ref($arg)) { }
                            else { $arg =~ s/([\\'])/\\$1/g; $arg = "'$arg'" }
                            $mess .= $arg;
                        }
                    }
                    $mess .= ") called ";
                }
                $mess .= "at $caller[1] line $caller[2]\n";
                $i++;
            }
        }
        $mess;
    };
    $SIG{__DIE__}  = sub { die &$longmess };
    $SIG{__WARN__} = sub { warn &$longmess };
}
END {
    @SIG{qw/__DIE__ __WARN__/} = @OLD_SIG{qw/__DIE__ __WARN__/};
}
# END_BLOCK: stacktrace_printer
_

1;
# ABSTRACT: Collection of routines that can be embedded e.g. using Dist::Zilla plugin

__END__