Perl Advent Calender 2014 . 17th

can.pl

use strict;
use warnings;
use utf8;
use feature qw/say/;

my $dog = bless {}, 'Dog';

if (can $dog 'bow') {
    say 'can bow';
}
else {
    say 'cannot bow';
} # => cannot bow

=pod

use utf8;
use warnings;
use strict;
use feature 'say';
my $dog = bless({}, 'Dog');
if ($dog->can('bow')) {
    say 'can bow';
}
else {
    say 'cannot bow';
}

can2.pl

use strict;
use warnings;
use utf8;
use feature qw/say/;

my $dog = bless {}, 'Dog';

sub can { 1 }

if (can $dog 'bow') { # XXX => syntax error
    say 'can bow';
}
else {
    say 'cannot bow';
}

=pod

syntax error at can2.pl line 10, near "$dog 'bow'"
can2.pl had compilation errors.
use utf8;
use warnings;
use strict;
use feature 'say';
my $dog = bless({}, 'Dog');
sub can {
    use warnings;
    use strict;
    use feature 'say';
    1;
}

can3.pl

use strict;
use warnings;
use utf8;
use feature qw/say/;

my $dog = bless {}, 'Dog';

sub can { 1 }

if (can $dog, 'bow') { # リストにするため、カンマを入れた
    say 'can bow';
}
else {
    say 'cannot bow';
} # => can bow

can4.pl

use strict;
use warnings;
use utf8;

package Dog;

sub new { bless {}, shift };

package main;

use Test::More;

my $dog = Dog->new;

subtest 'isa' => sub {
    isa_ok $dog, 'Dog';
    isa_ok $dog, 'UNIVERSAL';
};

subtest 'methods' => sub {

    # http://perldoc.perl.org/UNIVERSAL.html
    ok $dog->can('can');
    ok $dog->can('isa');
    ok $dog->can('VERSION');
    ok $dog->can('DOES');
};

subtest 'methods count' => sub {

    require Class::Inspector;
    is scalar @{Class::Inspector->methods('UNIVERSAL')}, 4;

    is_deeply(Class::Inspector->methods('Dog'), [qw/new/]);
};


done_testing;

can5.pl

use strict;
use warnings;
use utf8;

package Dog;

sub new { bless {}, shift };

package main;
use Test::More;
use Class::Inspector;

is_deeply Class::Inspector->methods('Dog'), [qw/new/];
# XXX failed!!
# => Can't locate object method "is_deeply" via package "Class::Inspector" at can5.pl line 12

=pod
use utf8;
package Dog;
sub new {
    use warnings;
    use strict;
    bless {}, shift();
}
package main;
sub BEGIN {
    use warnings;
    use strict;
    require Test::More;
    do {
        'Test::More'->import
    };
}
use Class::Inspector;
use warnings;
use strict;
'Class::Inspector'->is_deeply->methods('Dog'), ['new'];
can5.pl syntax OK

constant.pl

use strict;
use warnings;
use utf8;
use feature 'say';

package A;

use constant FOO => 'foo';
use constant BAR => 'bar';

say FOO; # => foo
say BAR; # => bar

package B;

BEGIN {
    require constant;
    constant->import( FOO => 'foofoo' );
    constant->import( BAR => 'barbar' );
}

say FOO; # => foofoo
say BAR; # => barbar


package C;

BEGIN {
    require constant;
    import constant FOO => 'foofoofoo';
    import constant BAR => 'barbarbar';
}

say FOO; # => foofoofoo
say BAR; # => barbarbar

package D;

BEGIN {
    require constant;
    for my $key (qw/foo bar/) {
        import constant uc $key => $key x 4;
    }
}

say FOO; # => foofoofoofoo
say BAR; # => barbarbarbar

prototype.pl

use strict;
use warnings;
use utf8;
use Test::More;
use Test::Exception;
use Test::Perl::Critic;
use List::Util qw/sum/;

sub sum_map {
    my $cb = shift;
    sum map { $cb->($_); } @_;
}

subtest 'basic' => sub {

    is sum_map(sub { $_[0] * 10 }, 1..10), 550;
};

subtest 'dies' => sub {

    dies_ok { sum_map { $_ * 10 }, 1..10; }

    # =>
    # Use of uninitialized value $_ in multiplication (*) at proto.pl line 23.
    # Odd number of elements in anonymous hash at proto.pl line 23.
    # Not a CODE reference at proto.pl line 10.
};

subtest 'critic' => sub {
    critic_ok($0);
};

done_testing;

prototype2.pl

use strict;
use warnings;
use utf8;
use Test::More;
use Test::Exception;
use Test::Perl::Critic;
use List::Util qw/sum/;

sub sum_map (&@) {
    my $cb = shift;
    sum map { $cb->($_) } @_;
}

subtest 'basic' => sub {

    my $ret = sum_map { $_ * 10 } 1..10;
    is $ret, 550;
};

subtest 'other use case' => sub {

    my $ret = sum_map(sub { $_[0] * 10 }, 1..10);
    is $ret, 550;
};

subtest 'critic' => sub {
    critic_ok($0); ## failed!!

    # not ok 1 - Test::Perl::Critic for "proto2.pl"
    # Failed test 'Test::Perl::Critic for "proto2.pl"'
    #   at proto2.pl line 27.
    #
    # Perl::Critic found these violations in "proto2.pl":
    # Subroutine prototypes used at line 9, column 1.  See page 194 of PBP.  (Severity: 5)
};

done_testing;

prototype3.pl

use strict;
use warnings;
use utf8;
use Test::More;
use Test::Exception;
use Test::Perl::Critic;
use List::Util qw/sum/;

sub sum_map (&@) { ## no critic
    my $cb = shift;
    sum map { $cb->($_) } @_;
}

subtest 'critic' => sub {
    critic_ok($0), '注釈をつけることで回避';
    # ref http://search.cpan.org/~thaljef/Perl-Critic-1.123/lib/Perl/Critic.pm#BENDING_THE_RULES
};

done_testing;

try.pl

use strict;
use warnings;
use utf8;
use feature 'say';

#use Try::Tiny;

try {
    say 'foo';
    say 'bar';
}
# =>
# foo
# bar
# Can't locate object method "try" via package "1" (perhaps you forgot to load "1"?) at try2.pl line 6.

=pod

# perl -MO=Deparse %

use utf8;
use warnings;
use strict;
use feature 'say';
do {
    say 'foo';
    say 'bar'
}->try;
try2.pl syntax OK

=cut

try2.pl

use strict;
use warnings;
use utf8;
use feature 'say';

#use Try::Tiny;

try {
    say 'foo';
    bless {}, 'foo';
}
# =>
# foo
# Can't locate object method "try" via package "foo" at try2.pl line 6.

=pod

# perl -MO=Deparse %

use utf8;
use warnings;
use strict;
use feature 'say';
do {
    say 'foo';
    bless {}, 'foo'
}->try;
try2.pl syntax OK

=cut

try3.pl

use strict;
use warnings;
use utf8;
use feature 'say';

use Try::Tiny;

try {
    say 'foo';
    bless {}, 'foo';
}
# => foo

=pod

# perl -MO=Deparse %

use utf8;
use Try::Tiny;
use warnings;
use strict;
use feature 'say';
try sub {
    say 'foo';
    bless {}, 'foo';
}
;
try3.pl syntax OK

=cut