Perl entrance 07 no1

add_perl_monger.t

use warnings;
use strict;

use Test::Most;

sub add_monger {
    sub convert_to_monger {
        my $arg = shift;
        return 'yapc is perl conference!' if $arg eq 'yapc';
        return $arg . ' is perl monger!';
    }
    return map { convert_to_monger($_) } @_;
}

subtest "受け取った配列の全ての要素に 'is perl monger!' を追加する" => sub {
    my @input = ('Tom', 'Ken', 'Mary');
    my @mongers = add_monger(@input);
    is_deeply(\@mongers,
              ['Tom is perl monger!',
               'Ken is perl monger!',
               'Mary is perl monger!',
           ]);
};

subtest "配列中に 'yapc' という要素がある場合は、'is perl conference' を追加する" => sub {
    my @input = ('Tom', 'Ken', 'yapc', 'Mary');
    my @mongers = add_monger(@input);
    is_deeply(\@mongers,
              ['Tom is perl monger!',
               'Ken is perl monger!',
               'yapc is perl conference!',
               'Mary is perl monger!',
           ]);
};

done_testing;

add_tax.pl

#!/usr/bin/env perl

use warnings;
use strict;
use utf8;

use autodie;

binmode STDIN, ":encoding(UTF-8)";
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";

use Item;

sub read_price_file {
    my $file_name = shift;
    open my $fh, "<:utf8", $file_name;
    return map { Item->new($_) } <$fh>;
}

open my $out, ">:utf8", "price+.txt";
print $out "$_\n" for map { $_->with_tax } read_price_file('price.txt');
close $out;

echo_not_john.pl

#!/usr/bin/env perl

use warnings;
use strict;
use utf8;

use autodie;

binmode STDIN, ":encoding(UTF-8)";
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";

while (my $line = <STDIN>) {
    print $line unless $line =~ /[Jj]ohn/;
}

Item.pm

package Item;

use strict;
use warnings;
use utf8;

use constant TAX => 1.05;

sub new {
    my ($class, $item_string) = @_;
    $item_string =~ /([^:\s]+):(\d+)円/;
    my $self = {
        name => defined($1) ? $1 : '',
        price => defined($2) ? $2 : 0,
    };
    return bless $self, $class;
}

sub name {
    my $self = shift;
    return $self->{name};
}

sub price {
    my $self = shift;
    return $self->{price};
}

sub with_tax {
    my $self = shift;
    my $price_with_tax = int($self->price * TAX);
    return Item->new("$self->{name}:${price_with_tax}円");
}

sub to_s {
    my $self = shift;
    return "$self->{name}:$self->{price}円";
}
use overload
    qw("") => \&to_s;
1;

item.t

use warnings;
use strict;
use utf8;

use Test::Most;
#my $builder = Test::More->builder;
#binmode $builder->output,         ":utf8";
#binmode $builder->failure_output, ":utf8";
#binmode $builder->todo_output,    ":utf8";

use Item;

subtest '引数に与えた文字列でItemを作成できる' => sub {
    my $item = Item->new('ジュース:100円');
    is($item->name, 'ジュース');
    is($item->price, 100);
};

subtest 'Itemの文字列表現は「品名:○○円」である' => sub {
    my $item = Item->new('ジュース:100円');
    is("$item", 'ジュース:100円');
};

subtest '消費税の計算ができる' => sub {
    subtest '5%の税額を加算した新たなオブジェクトが得られる' => sub {
        my $item = Item->new('ジュース:100円');
        my $item_with_tax = $item->with_tax;
        is($item_with_tax->name, 'ジュース');
        is($item_with_tax->price, 105);
    };
    subtest '小数点は切り捨て' => sub {
        my $item = Item->new('ジュース:50円');
        my $item_with_tax = $item->with_tax;
        is($item_with_tax->name, 'ジュース');
        is($item_with_tax->price, 52);
    };
    subtest '元のオブジェクトは変更されない' => sub {
        my $item = Item->new('ジュース:50円');
        my $item_with_tax = $item->with_tax;
        is($item->name, 'ジュース');
        is($item->price, 50);
    };
};

done_testing;

make_price.pl

#!/usr/bin/env perl

use warnings;
use strict;
use utf8;

use autodie;
use YAML;

binmode STDIN, ":encoding(UTF-8)";
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";

open my $fh, "<:utf8", "price.txt";
my %price = map { ( $+{name} => $+{price} ) if /(?<name>[^:\s]+):(?<price>\d+)円/ } <$fh>;
close $fh;

print YAML::Dump(\%price);

we_love_perl.pl

#!/usr/bin/perl

use strict;
use warnings;
use utf8;

binmode STDIN, ":encoding(UTF-8)";
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";

until ( (my $line = <STDIN>) eq "END\n" ) {
    print "We love perl!\n" if $line =~ /perl/;
}