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

package Shika;

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

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

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

my $default = {};

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

    # set default values
    for my $klass ($class, @{mro::get_linear_isa($class)}) {
        while (my ($name, $code) = each %{$default->{$klass}}) {
            unless (exists $attr{$name}) {
                $attr{$name} = $code->();
            }
        }
    }

    bless { %attr }, $class
}

sub _has {
    my $pkg = caller(0);
    my $n = shift;
    my %attr = @_;
    no strict 'refs';
    *{"$pkg\::$n"} = sub {
        return $_[0]->{$n} if @_ == 1;
        return $_[0]->{$n} = $_[1] if @_ == 2;
        shift->{$n} = \@_;
    };
    if (my $handles = $attr{handles}) {
        for my $handle (@$handles) {
            *{"$pkg\::$handle"} = sub {
                shift->$n->$handle(@_)
            };
        }
    }
    if (my $def = $attr{default}) {
        $default->{$pkg}->{$n} = $def;
    }
}

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) {
        eval "require $role" unless $role->can('meta');## no critic ### too bad
        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"};
        }
    }
}

# 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
    - method modifiers
    - role support
    - isa?
    - set default value lazily

=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