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

package Shika;

use strict;
use warnings;
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});
        }
    }

    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(@_)
            };
        }
    }
    
    _has_install($pkg, $n, %attr);
}

sub _has_install {
    my($pkg, $n, %attr) = @_;
    my $has = \%attr;
    no strict 'refs';
    my $code = qq!sub {!;
    $code .= qq!  if (\@_ == 1) {!;
    if ($attr{lazy}) {
    $code .= qq!    unless (exists \$_[0]->{$n} && exists \$has->{default}) {!;
    $code .= qq!       my \$code = \$has->{default};!;
    $code .= qq!       return \$_[0]->{$n} = ref(\$code) eq 'CODE' ? \$code->() : \$code;!;
    $code .= qq!    }!;
    $code .= qq!    return \$_[0]->{$n};!;
    } elsif ($attr{lazy_build}) {
    $code .= qq!    unless (exists \$_[0]->{$n}) {!;
    $code .= qq!        die "$pkg does not support builder method '_build_$n' for attribute '$n'"!;
    $code .= qq!            unless my \$code = \$pkg->can("_build_$n");!;
    $code .= qq!        return \$_[0]->{$n} = \$code->();!;
    $code .= qq!    }!;
    $code .= qq!    return \$_[0]->{$n};!;
    } else {
    $code .= qq!    return \$_[0]->{$n};!;
    }
    $code .= qq!  }!;
    $code .= qq!  return \$_[0]->{$n} = \$_[1] if \@_ == 2;!;
    $code .= qq!  shift->{$n} = \\\@_;!;
    $code .= qq!}!;
    *{"$pkg\::$n"} = eval $code; ## no critic.
    die $@ if $@;
}

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

    - coerce for attributes
    - method modifiers
    - isa?

=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