#!/usr/bin/perl
require 5.008;
our $VERSION = "0.09"; # 2011-01-07
our $THIS = "http://jrf.cocolog-nifty.com/archive/example_oo/example_oo.pl";

## License:
##
##   I in a provincial state made this program intended to be public-domain. 
##   But it might be better for you like me to treat this program as such 
##   under the BSD-License or under the Artistic License.
##
## Author's Link:
##
##   http://jrf.cocolog-nifty.com/software/2010/12/post.html
##   (The page is in Japanese.)
##

use strict;
use warnings;
use utf8; # Japanese

##
## このコードは、上の Author's Link の記事に書いた「Perl で C++ 風のオ
## ブジェクト指向プログラミング」を行うためのサンプル。
##
## 最初に記事を書いたあと、主に補足のため少し手を入れた。
##

BEGIN {
  my @mypackage = qw(
		    Main
		    Main::_Simple
		    Main::_A
		    Main::_B
		 );
  foreach my $p (@mypackage) {
    eval <<"EOM"; # eval the string til "End Of Macro".
    {
      package $p;
      use Math::Trig; # for pi
      use Storable qw(dclone);
    }
EOM
    die $@ if $@; # check error of eval.
  }
}

package Main;
## Main はシステムで使われている名前 main にすべきなのかもしれないが、
## その必要はないので、こうしておいたほうが拡張性があるだろう。

our $DEBUG = 0;

{
  package Main::_Simple;

  my %template = ("Main::_Simple" => {});

  ## $template{$class} は template of structure やスケルトンといった感
  ## じで、C++ の template とはまったく異なるもの。クラス変数とメンバ
  ## 変数の両方を保持するイメージ。

  ## extend_template は temlate のないクラス定義を補いつつ、「クラス」
  ## 用のメンバ変数を template に足す。

  sub extend_template {
    my $class = shift;
    my @hash = @_;
    if (exists $template{$class}) {
      $template{$class} = {%{$template{$class}}, @hash} if @hash;
    } else {
      $template{$class} = 
	{(map {
	        $_->extend_template() if ! exists $template{$_};
	        %{$template{$_}};
	      } (eval '@{' . $class . '::ISA}')),
	 @hash
	};
    }
    return $template{$class};
  }

  ## extend_template があれば下の set_template は使うべきじゃないかな？
  ## get_template は読みやすさのため残したが、実体はほぼ 
  ## extend_template である。

#  sub set_template {
#    my $class = shift;
#    my ($temp) = @_;
#    $template{$class} = $temp;
#  }
#

  ## 「クラス変数」は、__PACKAGE__->get_template()->{varname} = "..." 
  ## などとして使うことを予定。ただし、「継承」を考えないなら、our で
  ## 十分である。「クラス変数」に「オブジェクト」を代入するのは好まし
  ## くなく、環境変数的な利用を想定。詳しくは example_oo_c1.pl、
  ## example_oo_c2.pl を。

  sub get_template {
    my $class = shift;
    return $class->extend_template();
  }

  sub new {
    my $class = shift;
    my $obj = dclone($class->get_template());
    bless $obj, $class;
    return $obj;
  }
}


{
  package Main::_A;
  use base qw(Main::_Simple);

  ## クラス変数とメンバ変数の両方の意味を持つ $template{$class} を初期
  ## 化する。親クラスの $template{$class} をすべて含むように定義する必
  ## 要があるが、extend_template を使えば簡単である。

  __PACKAGE__->extend_template
    (
     ## 以下に基礎となる structure を書く。

     data => 0.0, # ここに data の説明を書こう！
     data2 => 2.0, # ここに data2 の説明を書こう！

    );

  ## 上は汎用にするために __PACKAGE__ などを使ったが、意味は以前の記事
  ## の例のほうがわかりやすかったかもしれない。この直前の節は、この直
  ## 後のコメントアウトした節と同じことをしている。

#   Main::_A->set_template({%{Main::_Simple->get_template()},
# 			  data => 0.0,
# 			  data2 => 2.0,
# 			 });

  ## メソッド内で、pi や dclone などの関数が使えるのがうれしいというの
  ## が元の記事の内容だった。

  sub method_1 {
    my $self = shift;
    my ($arg1) = @_;
    $self->{data} = $self->{data} + pi / $arg1;
    return $self->{data};
  }

  ## 親クラスを利用したコンストラクタの例。

  sub new {
    my $class = shift;
    my $obj = $class->SUPER::new(@_);
    $obj->{data} = $obj->{data} + 2 * pi;
    print "new data = $obj->{data}\n" if $DEBUG;
    return $obj;
  }
}

{
  package Main::_B;
  use base qw(Main::_Simple);

  ## この「クラス」は Main::_A とほぼ同じで、コンストラクタが 
  ## Main::_Simple のままで、data の初期値が違うだけ。

  __PACKAGE__->extend_template
    (
     data => 1.0, # ここに data の説明を書こう！
    );

  sub method_1 {
    my $self = shift;
    my ($arg1) = @_;
    $self->{data} = $self->{data} + pi / $arg1;
    return $self->{data};
  }
}

## 下の MAIN: はラベルで、特に必要はない。私のクセ。

MAIN:
{
  ## Main::_Simple から new を継承した二つの「クラス」のオブジェクトが
  ## 意図通りに別の結果を示す。

  my $a = Main::_A->new();
  my $b = Main::_B->new();

  print $a->method_1(7.0) . "\n";
  print $b->method_1(7.0) . "\n";
}

__END__

=pod

=head1	NAME

example_oo.pl - a sample of C++-like object oriented programming in Perl.

=head1	SYNOPSIS

perl B<example_oo.pl>

=head1	OPTIONS

NONE.

=head1	DESCRIPTION

A sample code to demonstrate such a trick that you can use functions
imported into the "package" in "class"es i.e. in local packages.

=head1	AUTHOR

JRF E<lt>http://jrf.cocolog-nifty.com/softwareE<gt>

=head1	LICENSE

Public Domain.

=cut