File Coverage

blib/lib/mcoder.pm

Criterion	Covered	Total	%
statement	95	97	97.9
branch	45	56	80.3
condition			n/a
subroutine	21	22	95.4
pod	0	4	0.0
total	161	179	89.9

package mcoder;

our $VERSION = '0.10';

use strict;
use warnings;
use Carp;

our $debug;

my %mcoder;

sub import {
    shift;
    while (@_) {
	my $kind=shift;
	my @kind=(ref $kind eq 'ARRAY') ? @$kind : ($kind);
	my $args=shift;
	my @args=(ref $args eq 'ARRAY') ? @$args : ($args);

	for my $k (@kind) {
	    exists $mcoder{$k} or
		croak "unknow mcoder type '$k'";
	    &{$mcoder{$k}}($k, @args)
	}
    }
}

sub export_proxy {
    shift;
    my $delegate=shift;
    my $caller=caller(1);
    foreach my $m (@_) {
	my @m=(ref($m) eq 'HASH') ? %$m : ($m, $m);
	while (@m) {
	    my $name=shift @m;
	    my $method=shift @m;
	    $method=~/^\w+$/ and $method.='(@_)';
	    my $def=
		"sub ${caller}::${name} { shift->$delegate->$method }";
	    carp "mcoder def>> $def" if $debug;
	    eval $def;
	    $@ and croak "proxy method definition failed: $@";
	}
    }
}

sub export_accessor {
    my $type=shift;
    my $caller=caller(1);
    foreach my $m (@_) {
	my @m=(ref($m) eq 'HASH') ? %$m : ($m, $m);
	while (@m) {
	    my $name=shift @m;
	    my $attr=shift @m;
	    $attr=~/^\w+$/ and $attr="{q(".$attr.")}";
	    my $def;
	    # if ($type eq 'accessor') {
	    #     $def="\@_ > 1 ? shift->$attr=\$_[0] : shift->$attr";
	    # }
	    # elsif
	    if ($type eq 'get') {
		$def="\$_[0]->$attr";
	    }
	    elsif ($type eq 'array_get') {
		$def="\@{(\$_[0]->$attr)||[]}";
	    }
	    elsif ($type eq 'set') {
		$name='set_'.$name;
		$def="\$_[0]->$attr=\$_[1]";
	    }
	    elsif ($type eq 'array_set') {
		$name='set_'.$name;
		$def="my \$t=shift; \$t->$attr=\\\@_";
	    }
	    elsif ($type eq 'bool_set') {
		$name='set_'.$name;
		$def="\$_[0]->$attr=(\@_>1 ? \$_[1] : 1)";
	    }
	    elsif ($type eq 'calculated') {
		$def="my \$t=shift; "
		    ."if (defined \$t->$attr) { \$t->$attr } "
			."else { \$t->$attr=\$t->_calculate_$name }";
	    }
	    elsif ($type eq 'array_calculated') {
		$def="my \$t=shift; "
		    ."if (defined \$t->$attr) { \@{\$t->$attr} } "
			."else { my \@a=\$t->_calculate_$name; \$t->$attr=\\\@a; \@a }";
	    }
	    elsif ($type eq 'delete') {
		$name='delete_'.$name;
		$def="my \$t=shift; exists \$t->$attr and delete \$t->$attr";
	    }
	    elsif ($type eq 'undef') {
		$name='undef_'.$name;
		$def="\$_[0]->$attr=undef";
	    }
	    elsif ($type eq 'bool_unset') {
		$name='unset_'.$name;
		$def="\$_[0]->$attr=undef";
	    }
	    elsif ($type eq 'virtual') {
		$def=qq(Carp::croak("undefined virtual method called (".\$_[0]."->$name)"))
	    }
	    else {
		die "internal error (unknow type $type)"
	    }
	    my $def1= "sub ${caller}::${name} { $def }";
	    carp "mcoder def >> $def1" if $debug;
	    eval $def1;
	    $@ and croak "$type method definition failed $@";
	}
    }
}

sub export_new {
    shift;
    my $caller=caller(1);
    foreach my $name (@_) {
	my $def="sub ${caller}::${name} { my \$c=shift; "
	    ."\@_ & 1 "
		."and croak q(Odd number of elements passed to constructor); "
		    ."bless {\@_}, \$c }";
	carp "mcoder def >> $def" if $debug;
	eval $def;
	$@ and croak "constructor method definition failed $@";
    }
}

sub export_virtual {
    shift;

}

%mcoder=( proxy => \&export_proxy,
	  # accesor => \&export_accesor,
	  set => \&export_accessor,
	  array_set => \&export_accessor,
	  get => \&export_accessor,
	  array_get => \&export_accessor,
	  bool_unset => \&export_accessor,
	  bool_set => \&export_accessor,
	  calculated => \&export_accessor,
	  array_calculated => \&export_accessor,
	  delete => \&export_accessor,
	  undef => \&export_accessor,
	  new => \&export_new,
	  virtual => \&export_accessor );

1;
__END__