package ObjectTemplate;
# $Id: ObjectTemplate.pm,v 1.2 2000/12/14 17:45:36 tom Exp $
################################################################

=head1 NAME

ObjectTemplate - オブジェクトテンプレートクラス

=head1 SYNOPSIS

 use ObjectTemplate;
 @ISA = qw(ObjectTemplate);
 attributes qw(content method);

=head1 DESCRIPTION

オブジェクト志向プログラミングの補助ツール。
このクラスから派生することを前提とする基本クラス。

=cut

require Exporter;
@ObjectTemplate::ISA = qw(Exporter);
@ObjectTemplate::EXPORT = qw(attributes);

$ObjectTemplate::debugging = 0; # assign 1 to it to see code generated on the fly 

# Create accessor functions, and new()

=head2 attributes @member_variables

使用するメンバ変数名の配列を渡す。

    attributes qw(content method);

とした場合、

    $obj->content(3); 

で値のセット、

    print $obj->content;

で値の取得が可能になる。

=cut

sub attributes {
    my ($pkg) = caller;
    @{"${pkg}::_ATTRIBUTES_"} = @_;

    my $code = "";
    foreach my $attr (get_attribute_names($pkg)) {
        # If a field name is "color", create a global list in the
        # calling package called @color
        @{"${pkg}::_$attr"} = ();

        # Define accessor only if it is not already present
#        unless ($pkg->can("$attr")) {
            $code .= _define_accessor ($pkg, $attr);
#        } 
    }
    $code .= _define_constructor($pkg);
#    print $code if $debugging;
    eval $code;
    if ($@) {
       die  "ERROR defining constructor and attributes for '$pkg':" 
            . "\n\t$@\n" 
            . "-----------------------------------------------------"
            . $code;
    }
}

# $obj->set_attributes (name => 'John', age => 23);     
# Or, $obj->set_attributes (['name', 'age'], ['John', 23]);
sub set_attributes {
    my $obj = shift;
    my $attr_name;
    if (ref($_[0])) {
       my ($attr_name_list, $attr_value_list) = @_;
       my $i = 0;
       foreach $attr_name (@$attr_name_list) {
            $obj->$attr_name($attr_value_list->[$i++]);
       }
    } else {
       my ($attr_name, $attr_value);
       while (@_) {
           $attr_name = shift;
           $attr_value = shift;
           $obj->$attr_name($attr_value);
       }
    }
}


# @attrs = $obj->get_attributes (qw(name age));
sub get_attributes {
    my $obj = shift;
    my (@retval);
    map $obj->${_}(), @_;
}


sub get_attribute_names {
    my $pkg = shift;
    $pkg = ref($pkg) if ref($pkg);
    my @result = @{"${pkg}::_ATTRIBUTES_"};
    if (defined (@{"${pkg}::ISA"})) {
        foreach my $base_pkg (@{"${pkg}::ISA"}) {
           push (@result, get_attribute_names($base_pkg));
        }
    }
    @result;
}

sub set_attribute {
    my ($obj, $attr_name, $attr_value) = @_;
    my ($pkg) = ref($obj);
    ${"${pkg}::_$attr_name"}[$$obj] = $attr_value;
}

sub get_attribute {
    my ($obj, $attr_name, $attr_value) = @_;
    my ($pkg) = ref($obj);
    return ${"${pkg}::_$attr_name"}[$$obj];
}


sub DESTROY {
    # release id back to free list
    my $obj = $_[0];
    my $pkg = ref($obj);
    local *_free = *{"${pkg}::_free"};
    my $inst_id = $$obj;
    # Release all the attributes in that row
    local(*attributes) = *{"${pkg}::_ATTRIBUTES_"};
    foreach my $attr (@attributes) {
        undef ${"${pkg}::_$attr"}[$inst_id];
    }
    $_free[$inst_id] = $_free;
    $_free = $inst_id;
}


=head2 $obj->initialize;

初期化関数。
本クラスから派生したクラスで実装する場合は、

    $obj->SUPER::initialize();

と親クラスの初期化関数を呼び出すこと。

=cut

sub initialize { }; # dummy method, if subclass doesn't define one.

#################################################################

sub _define_constructor {
    my $pkg = shift;
    my $code = qq {
        package $pkg;
        sub new {
            my \$class = shift;
            my \$inst_id;
            if (defined(\$_free[\$_free])) {
                \$inst_id = \$_free;
                \$_free = \$_free[\$_free];
                undef \$_free[\$inst_id];
            } else {
                \$inst_id = \$_free++;
            }
            my \$obj = bless \\\$inst_id, \$class;
            \$obj->set_attributes(\@_) if \@_;
            \$obj->initialize;
            \$obj;

        }
    };
    $code;
}

sub _define_accessor {
    my ($pkg, $attr) = @_;

    # This code creates an accessor method for a given
    # attribute name. This method  returns the attribute value 
    # if given no args, and modifies it if given one arg.
    # Either way, it returns the latest value of that attribute


    # qq makes this block behave like a double-quoted string
    my $code = qq{
        package $pkg;
        sub $attr {                                      # Accessor ...
            \@_ > 1 ? \$_${attr} \[\${\$_[0]}] = \$_[1]  # set
                    : \$_${attr} \[\${\$_[0]}];          # get
        }
        if (!defined \$_free) {
            # Alias the first attribute column to _free
            \*_free = \*_$attr;
            \$_free = 0;
        };

    };
    $code;
}

1;

