root/lang/perl/Shika/trunk/lib/Shika.pm @ 25118

package Shika;

use strict;
use warnings;
use Carp;
our $VERSION = '0.01';
eval "use mro; 1;" or eval "use MRO::Compat; 1;"; ## no critic

sub import {
    my $pkg = caller(0);
    strict->import;
    warnings->import;

    my $meta = +{
        has      => {},
        default  => {},
    };

    no strict 'refs';
    *{"$pkg\::new"}     = \&_new;
    *{"$pkg\::has"}     = \&_has;
    *{"$pkg\::extends"} = \&_extends;
    *{"$pkg\::with"}    = \&_with;
    *{"$pkg\::meta"}    = sub { $meta };
}

sub _new {
    my $class = shift;
    my %attr = @_;

    for my $klass ($class, @{mro::get_linear_isa($class)}) {
        next unless $klass->can('meta');
        # set default values
        while (my ($name, $has) = each %{ $klass->meta->{has} }) {
            next if     exists $attr{$name};
            next unless exists $has->{default} && $has->{default};
            next if     exists $has->{lazy} && $has->{lazy};
            next if     exists $has->{lazy_build} && $has->{lazy_build};
            my $code = $has->{default};
            $attr{$name} = ref($code) eq 'CODE' ? $code->() : $code;
        }
        # process coerce
        while (my ($name, $has) = each %{ $klass->meta->{has} }) {
            next unless exists $attr{$name};
            next unless exists $has->{coerce} && $has->{coerce};
            $attr{$name} = $has->{coerce}->($attr{$name});
        }
        # process 'required'
        while (my ($name, $has) = each %{ $klass->meta->{has} }) {
            next unless $has->{required};
            next if     exists $attr{$name};
            Carp::croak "missing parameter $name for $class";
        }
    }

    my $self = bless { %attr }, $class;
    if ($self->can('BUILD')) {
        $self->BUILD(\%attr);
    }
    $self;
}

sub _has {
    my $pkg = caller(0);
    my $n = shift;
    my %attr = @_;
    $pkg->meta->{has}->{$n} = \%attr;

    if (my $handles = $attr{handles}) {
        $handles = [$handles] unless ref $handles;
        for my $handle (@$handles) {
            no strict 'refs';
            *{"$pkg\::$handle"} = sub {
                shift->$n->$handle(@_)
            };
        }
    }
    
    my $f1 =       $attr{lazy} ? 'lazy'
                               :
             $attr{lazy_build} ? 'lazy_build'
                               : 'normal';
    my $f2 = $attr{coerce} ? '_coerce' : '';
    my $meth = "_has_install_${f1}${f2}";
    __PACKAGE__->can($meth)->( $pkg, $n );
}

### START HAS_INSTALL

sub _has_install_normal {
    my ($pkg, $n, ) = @_;
    my $has = $pkg->meta->{has}->{$n};
    no strict "refs";
    *{"$pkg\::$n"} = sub {
        if (@_ == 1) { 
            return $_[0]->{$n};
        }

        if (@_==2) {
            return $_[0]->{$n} = $_[1];
        }
        shift->{$n} = \@_;
    };
}
sub _has_install_normal_coerce {
    my ($pkg, $n, ) = @_;
    my $has = $pkg->meta->{has}->{$n};
    no strict "refs";
    *{"$pkg\::$n"} = sub {
        if (@_ == 1) { 
            return $_[0]->{$n};
        }

        if (@_==2) {
            return $_[0]->{$n} = $has->{coerce}->($_[1]);
        }
        shift->{$n} = \@_;
    };
}
sub _has_install_lazy {
    my ($pkg, $n, ) = @_;
    my $has = $pkg->meta->{has}->{$n};
    no strict "refs";
    *{"$pkg\::$n"} = sub {
        if (@_ == 1) { 
            unless (exists $_[0]->{$n} && exists $has->{default}) {
                my $code = $has->{default};
                return $_[0]->{$n} = ref($code) eq 'CODE' ? $code->($_[0]) : $code;
            }
            return $_[0]->{$n};
        }

        if (@_==2) {
            return $_[0]->{$n} = $_[1];
        }
        shift->{$n} = \@_;
    };
}
sub _has_install_lazy_coerce {
    my ($pkg, $n, ) = @_;
    my $has = $pkg->meta->{has}->{$n};
    no strict "refs";
    *{"$pkg\::$n"} = sub {
        if (@_ == 1) { 
            unless (exists $_[0]->{$n} && exists $has->{default}) {
                my $code = $has->{default};
                return $_[0]->{$n} = ref($code) eq 'CODE' ? $code->($_[0]) : $code;
            }
            return $_[0]->{$n};
        }

        if (@_==2) {
            return $_[0]->{$n} = $has->{coerce}->($_[1]);
        }
        shift->{$n} = \@_;
    };
}
sub _has_install_lazy_build {
    my ($pkg, $n, ) = @_;
    my $has = $pkg->meta->{has}->{$n};
    no strict "refs";
    *{"$pkg\::$n"} = sub {
        if (@_ == 1) { 
            unless (exists $_[0]->{$n}) {
                die "$pkg does not support builder method '_build_$n' for attribute '$n'"
                    unless my $code = $pkg->can("_build_$n");
                return $_[0]->{$n} = $code->();
            }
            return $_[0]->{$n};
        }

        if (@_==2) {
            return $_[0]->{$n} = $_[1];
        }
        shift->{$n} = \@_;
    };
}
sub _has_install_lazy_build_coerce {
    my ($pkg, $n, ) = @_;
    my $has = $pkg->meta->{has}->{$n};
    no strict "refs";
    *{"$pkg\::$n"} = sub {
        if (@_ == 1) { 
            unless (exists $_[0]->{$n}) {
                die "$pkg does not support builder method '_build_$n' for attribute '$n'"
                    unless my $code = $pkg->can("_build_$n");
                return $_[0]->{$n} = $code->();
            }
            return $_[0]->{$n};
        }

        if (@_==2) {
            return $_[0]->{$n} = $has->{coerce}->($_[1]);
        }
        shift->{$n} = \@_;
    };
}

### END HAS_INSTALL

sub _extends {
    my $pkg = caller(0);
    my @parents = @_;
    no strict 'refs';
    unshift @{"$pkg\::ISA"}, @parents;
}

sub _with {
    my $pkg = caller(0);
    my @roles = @_;

    for my $role (@roles) {
        Shika::_load_class($role) unless $role->can('meta');
        next unless $role->can('meta');

        for my $method (@{ _get_functions($role) }) {
            next if $method eq 'has' || $method eq 'requires' || $method eq 'meta';
            next if $pkg->can($method);
            no strict 'refs';
            *{"$pkg\::$method"} = *{"$role\::$method"};
        }
    }
}

sub _load_class {
    my $role = shift;
    eval "require $role" ## no critic ### too bad
}

# copied from Class::Inspector
sub _get_functions {
    my $name = shift;

    no strict 'refs';
    # Get all the CODE symbol table entries
    my @functions = sort grep { /\A[^\W\d]\w*\z/o }
        grep { defined &{"${name}::$_"} }
            keys %{"${name}::"};
    \@functions;
}

1;
__END__

=head1 NAME

Shika - Lightweight class builder with DSL

=head1 SYNOPSIS

  package Point;
  use Shika; # automatically turns on strict and warnings

  has 'x';
  has 'y';

  sub clear {
      my $self = shift;
      $self->x(0);
      $self->y(0);
  }

  package Point3D;
  use Shika;

  extends 'Point';

  has 'z';

  after 'clear' => sub {
      my $self = shift;
      $self->z(0);
  };

=head1 DESCRIPTION

Shika is

=head1 AUTHOR

tokuhirom

yappo

lestrrat

typester

charsbar

miyagawa

kan

walf443

kazuho

hidek

mattn

=head1 TODO

    - method modifiers
    - isa?
    - make coerce as dsl

=head1 SEE ALSO

=head1 REPOSITORY

  svn co http://svn.coderepos.org/share/lang/perl/Shika/trunk Shika

Shika is Subversion repository is hosted at L<http://coderepos.org/share/>.
patches and collaborators are welcome.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut