Perl - オブジェクトのデストラクション(dbmopen関数)

続・初めてのPerl 改訂版
Randal L. Schwartz
brian d foy, Tom Phoenix 著

開発環境

• OS X Lion - Apple(OS)
• TextWrangler(Text Editor) (BBEditの機能制限無料版、light版)
• Script言語:Perl

『続・初めてのPerl 改訂版』(Randal L. Schwartz, brian d foy, Tom Phoenix 著、伊藤 直也、田中 慎司、吉川 英興 監訳、株式会社ロングテール/長尾 高弘 訳、オライリー・ジャパン、2006年、ISBN4-87311-305-9) の13章(オブジェクトのデストラクション),　13.8(練習問題)1を解いてみる。

その他参考書籍

• プログラミングPerl〈VOLUME1〉
• プログラミングPerl〈VOLUME2〉
• Perlクックブック〈VOLUME1〉
• Perlクックブック〈VOLUME2〉

1.

コード(TextWrangler)

sample.pl

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use 5.016;
binmode STDIN, ':utf8';
binmode STDOUT, ':utf8';

{package Animal;
  use Carp qw(croak);
  our %REGISTRY;
  sub named{
    ref(my $class = shift) and croak "class name needed";
    my $name = shift;
    my $self = {Name => $name, Color => $class->default_color};
    bless $self, $class;
    $REGISTRY{$self} = $self;
  }
  sub default_color {"brown" }
  sub sound{croak "subclass must deinfe a sound"}
  sub registered{
    return map{'a ' . ref($_). " named " . $_->name} values %REGISTRY;
  }
  sub speak{
    my $either = shift;
    print $either->name, " goes ", $either->sound, "\n";
  }
  sub name{
    my $either = shift;
    ref $either
      ? $either->{Name}
      : "an unnamed $either";
  }
  sub color{
    my $either = shift;
    ref $either
      ? $either->{Color}
      : $either->default_color;
  }
}

{package Horse;
  our @ISA = qw(Animal);
  sub sound { "neigh" }
}
{package RaceHorse;
  our @ISA = qw(Horse);
  dbmopen(our %STANDINGS, "standings", 0666) or die "can't open dbm: $!";
  sub named{
    my $self = shift->SUPER::named(@_);
    my $name = $self->name;
    my @standings = split " ", $STANDINGS{$name} || "0 0 0 0";
    @$self{qw(wins places shows losses)} = @standings;
    $self;
  }
  sub DESTROY{
    my $self = shift;
    $STANDINGS{$self->name} = "@$self{qw(wins places shows losses)}";
    $self->SUPER::DESTROY;
  }
  sub won {shift->{wins}++;}
  sub placed { shift->{places}++;}
  sub shows { shift->{shows}++;}
  sub loses { shift->{loses}++;}
  sub standings{
    my $self = shift;
    join ",", map "$self->{$_} $_", qw(wins places shows losses);
  }
}
my $runner = RaceHorse->named('Billy Boy');
$runner->won;
print $runner->name, ' has standings ', $runner->standings, ".\n";kamimuras

入出力結果(Terminal)

$ ./sample.pl
Billy Boy has standings 1 wins,0 places,0 shows,0 losses.
$ ./sample.pl
Billy Boy has standings 2 wins,0 places,0 shows,0 losses.
$ ./sample.pl
Billy Boy has standings 3 wins,0 places,0 shows,0 losses.
$ ./sample.pl
Billy Boy has standings 4 wins,0 places,0 shows,0 losses.
$ ls -l standings.db
-rw-r--r--  1 kamimura  staff  16384 11  7 17:53 standings.db
$

メモ: 今のところ、この章あたりからすらすらと書けなくなってくる。