Perlのオブジェクト指向なコードを書いてみる

gistfile1.pl

#
# Perlのオブジェクト指向なコードを書いてみる
# http://codepad.org/z5axBdJP
#
use strict;
use warnings;

# 名前空間(パッケージ)の宣言。
# すべてのパッケージは暗黙のルートパッケージ main に属する。
package PerlOop;

# コンストラクタ。
# 名前は慣例でつけているので new でなくても create_instance とかでも動く。
# でも読みづらいので new を使うのが無難。
sub new {

    # 現在のクラス(パッケージ)を取得する。
    my $class = shift;

    # 引数はハッシュで受けたほうが移植性は高くなる。
    my %param = @_;

    # 無名ハッシュを bless してクラス(パッケージ)と結びつける。
    # bless の第二引数がないとカレントパッケージと結びつくが、
    # コンストラクタを継承することを考慮してこのように書く。
    my $self = bless {
        # ハッシュに初期値を設定する。
        msg => $param{msg},
    }, $class;
    
    # さらに初期処理が必要な場合はここに書く。

    # 生成したハッシュのリファレンスを返す。
    return $self;
}

# インスタンスメソッド。
# new しないで呼ぶとエラーになる。
sub instance_method {

    # パッケージ配下のサブルーチンは、第一引数がちょっと異なり
    #   コンストラクタが返したリファレンスから呼ぶ: そのリファレンス
    #   パッケージ名で修飾して直接呼ぶ: パッケージ名(ただの文字列)
    # となる。
    my $self = shift;

    # インスタンス変数(コンストラクタで生成してblessしたハッシュ)へはこのようにアクセスする。
    print $self->{msg}, "\n";
}

# クラスメソッド。
# new してもしなくても呼べる。
sub class_method {
    my $class = shift;
    my $msg = 'I want to go home !!!';

    # 第一引数を調べる
    if (ref($class)) {
        # リファレンスならインスタンスメソッドだろう。
        print 'instance> ', $msg, "\n";
    } else {
        # リファレンスでなければただの文字列だろう。クラスメソッド。
        print 'class> ', $msg, "\n";
    }
}

# デストラクタ。
# リファンレスが無くなると自動的に呼ばれる。必ずこの名前。
sub DESTROY {
    print "destroy now.";
}

# 継承の例。めんどい
#
# 親クラス
package Base;
sub new {
    my $class = shift;
    my %param = @_;
    my $self = bless {
        basemsg => $param{basemsg},
    }, $class;
    return $self;
}
# 子クラス
package Child;
sub new {
    my $class = shift;
    my %param = @_;

    # 親クラスを作成。ハッシュは共有になる。
    my $self = Base->new( basemsg => 'base' );

    # 子クラスとして bless する。
    $self = bless $self, $class;

    # 子クラスのインスタンス変数をセット。
    $self->{childmsg} = 'child';

    return $self;
}
sub childs_method {
    my $self = shift;
    # 親、子の値にアクセスできる。
    print $self->{basemsg}, " ", $self->{childmsg}, "\n";
}

# tie を使ったオブジェクトの例
#
package Dice;
use Carp;
sub TIESCALAR {
    my ($class, $face) = @_;
    unless ($face =~ /[0-9]+/) {
        carp 'Dice::TIESCALAR: argument is invalid. (not number) ';
        return undef;
    }
    return bless \$face, $class;
}
sub FETCH($) {
    my $self = shift;
    confess 'wrong type!' unless ref $self;
    croak 'too many arguments.' if @_;
    return int(rand($$self)) + 1;
}
sub STORE($$) {
    my ($self, $face) = @_;
    unless ($face =~ /[0-9]+/) {
        carp 'Dice::STORE: argument is invalid. (not number) ';
        return $self;
    }
    $$self = $face;
}
sub DESTROY {
    carp 'Dice::DESTROY was executed.';
}

# お約束的なもののようだが
1;