Alzabo

 view release on metacpan or  search on metacpan

lib/Alzabo/MethodMaker.pm  view on Meta::CPAN

package Alzabo::MethodMaker;

use strict;
use vars qw($VERSION);

use Alzabo::Exceptions;
use Alzabo::Runtime;
use Alzabo::Utils;

use Params::Validate qw( :all );
Params::Validate::validation_options( on_fail => sub { Alzabo::Exception::Params->throw( error => join '', @_ ) } );

$VERSION = 2.0;

# types of methods that can be made - only ones that haven't been
# deprecated
my @options = qw( foreign_keys
                  linking_tables
                  lookup_columns
                  row_columns
                  self_relations

                  tables
                  table_columns

                  insert_hooks
                  update_hooks
                  select_hooks
                  delete_hooks
                );

sub import
{
    my $class = shift;

    validate( @_, { schema     => { type => SCALAR },
                    class_root => { type => SCALAR,
                                    optional => 1 },
                    name_maker => { type => CODEREF,
                                    optional => 1 },
                    ( map { $_ => { optional => 1 } } 'all', @options ) } );
    my %p = @_;

    return unless exists $p{schema};
    return unless grep { exists $p{$_} && $p{$_} } 'all', @options;

    my $maker = $class->new(%p);

    $maker->make;
}

sub new
{
    my $class = shift;
    my %p = @_;

    if ( delete $p{all} )
    {
        foreach (@options)
        {
            $p{$_} = 1 unless exists $p{$_} && ! $p{$_};
        }
    }

    my $s = Alzabo::Runtime::Schema->load_from_file( name => delete $p{schema} );

    my $class_root;
    if ( $p{class_root} )
    {
        $class_root = $p{class_root};
    }

lib/Alzabo/MethodMaker.pm  view on Meta::CPAN

       {
           @{ "$self->{class_root}::${thing}::ISA" }
               = ( "Alzabo::Runtime::$thing", "Alzabo::DocumentationContainer" );
       }
    }

    foreach my $t ( sort { $a->name cmp $b->name  } $self->{schema}->tables )
    {
        $self->{table_class} = join '::', $self->{class_root}, 'Table', $t->name;
        $self->{row_class} = join '::', $self->{class_root}, 'Row', $t->name;

        bless $t, $self->{table_class};
        $self->eval_table_class;
        $self->{schema}->add_contained_class( table => $self->{table_class} );

        $self->eval_row_class;
        $t->add_contained_class( row => $self->{row_class} );

        if ( $self->{opts}{tables} )
        {
            $self->make_table_method($t);
        }

        $self->load_class( $self->{table_class} );
        $self->load_class( $self->{row_class} );

        if ( $self->{opts}{table_columns} )
        {
            $self->make_table_column_methods($t);
        }

        if ( $self->{opts}{row_columns} )
        {
            $self->make_row_column_methods($t);
        }
        if ( grep { $self->{opts}{$_} } qw( foreign_keys linking_tables lookup_columns ) )
        {
            $self->make_foreign_key_methods($t);
        }

        foreach ( qw( insert update select delete ) )
        {
            if ( $self->{opts}{"$_\_hooks"} )
            {
                $self->make_hooks($t, $_);
            }
        }
    }
}

sub eval_schema_class
{
    my $self = shift;

    eval <<"EOF";
package $self->{schema_class};

use base qw( Alzabo::Runtime::Schema Alzabo::DocumentationContainer );
EOF

    Alzabo::Exception::Eval->throw( error => $@ ) if $@;
}

sub eval_table_class
{
    my $self = shift;

    eval <<"EOF";
package $self->{table_class};

use base qw( $self->{class_root}::Table );

sub _row_class { '$self->{row_class}' }

EOF

    Alzabo::Exception::Eval->throw( error => $@ ) if $@;
}

sub eval_row_class
{
    my $self = shift;

    # Need to load this so that ->can checks can see them
    require Alzabo::Runtime;

    eval <<"EOF";
package $self->{row_class};

use base qw( $self->{class_root}::Row Alzabo::DocumentationContainer );

EOF

    Alzabo::Exception::Eval->throw( error => $@ ) if $@;
}

sub make_table_method
{
    my $self = shift;
    my $t = shift;

    my $name = $self->_make_method
        ( type => 'table',
          class => $self->{schema_class},
          returns => 'table object',
          code =>  sub { return $t; },
          table => $t,
        ) or return;

    $self->{schema_class}->add_method_docs
        ( Alzabo::MethodDocs->new
          ( name  => $name,
            group => 'Methods that return table objects',
            description => "returns the " . $t->name . " table object",
          ) );
}

sub load_class
{
    my $self = shift;
    my $class = shift;

    eval "use $class;";

    die $@ if $@ && $@ !~ /^Can\'t locate .* in \@INC/;
}

sub make_table_column_methods
{
    my $self = shift;
    my $t = shift;

    foreach my $c ( sort { $a->name cmp $b->name  } $t->columns )
    {
        my $col_name = $c->name;

        my $name = $self->_make_method
            ( type => 'table_column',
              class => $self->{table_class},
              returns => 'column_object',

              # We can't just return $c because we may need to go
              # through the alias bits.  And we need to use $_[0] for
              # the same reason.
              code => sub { return $_[0]->column($col_name) },
              column => $c,
            ) or next;

        $self->{table_class}->add_method_docs
            ( Alzabo::MethodDocs->new
              ( name  => $name,
                group => 'Methods that return column objects',
                description => "returns the " . $c->name . " column object",
              ) );

lib/Alzabo/MethodMaker.pm  view on Meta::CPAN

                "returns the value of " . (join '.', $fk->table_to->name, $col_name) . " for the given row by following the foreign key relationship",
                spec  => 'same as Alzabo::Runtime::Table->rows_where',
              ) );
    }
}

sub make_hooks
{
    my $self = shift;
    my $table = shift;
    my $type = shift;

    my $class = $type eq 'insert' ? $self->{table_class} : $self->{row_class};

    my $pre = "pre_$type";
    my $post = "post_$type";

    return unless $class->can($pre) || $class->can($post);

    my $method = join '::', $class, $type;

    {
        no strict 'refs';
        return if *{$method}{CODE};
    }

    print STDERR "Making $type hooks method $class\->$type\n"
        if Alzabo::Debug::METHODMAKER;

    my $meth = "make_$type\_hooks";
    $self->$meth($table);
}

sub make_insert_hooks
{
    my $self = shift;

    my $code = '';
    $code .= "        return \$s->schema->run_in_transaction( sub {\n";
    $code .= "            my \$new;\n";
    $code .= "            \$s->pre_insert(\\\%p);\n" if $self->{table_class}->can('pre_insert');
    $code .= "            \$new = \$s->SUPER::insert(\%p);\n";
    $code .= "            \$s->post_insert({\%p, row => \$new});\n" if $self->{table_class}->can('post_insert');
    $code .= "            return \$new;\n";
    $code .= "        } );\n";

    eval <<"EOF";
{
    package $self->{table_class};
    sub insert
    {
        my \$s = shift;
        my \%p = \@_;

$code

    }
}
EOF

    Alzabo::Exception::Eval->throw( error => $@ ) if $@;

    my $hooks =
        $self->_hooks_doc_string( $self->{table_class}, 'pre_insert', 'post_insert' );

    $self->{table_class}->add_class_docs
        ( Alzabo::ClassDocs->new
          ( group => 'Hooks',
            description => "$hooks",
          ) );
}

sub _hooks_doc_string
{
    my $self = shift;
    my ($class, $hook1, $hook2) = @_;

    my @hooks;
    push @hooks, $hook1 if $class->can($hook1);

    push @hooks, $hook2 if $class->can($hook2);

    my $hooks = 'has';
    $hooks .= @hooks > 1 ? '' : ' a ';
    $hooks .= join ' and ', @hooks;
    $hooks .= @hooks > 1 ? ' hooks' : ' hook';

    return $hooks;
}

sub make_update_hooks
{
    my $self = shift;

    my $code = '';
    $code .= "        \$s->schema->run_in_transaction( sub {\n";
    $code .= "            \$s->pre_update(\\\%p);\n" if $self->{row_class}->can('pre_update');
    $code .= "            \$s->SUPER::update(\%p);\n";
    $code .= "            \$s->post_update(\\\%p);\n" if $self->{row_class}->can('post_update');
    $code .= "        } );\n";

    eval <<"EOF";
{
    package $self->{row_class};

    sub update
    {
        my \$s = shift;
        my \%p = \@_;

$code

    }
}
EOF

    Alzabo::Exception::Eval->throw( error => $@ ) if $@;

    my $hooks =
        $self->_hooks_doc_string( $self->{row_class}, 'pre_update', 'post_update' );

    $self->{row_class}->add_class_docs
        ( Alzabo::ClassDocs->new
          ( group => 'Hooks',
            description => "$hooks",
          ) );
}

sub make_select_hooks
{
    my $self = shift;

    my ($pre, $post) = ('', '');
    $pre  = "            \$s->pre_select(\\\@cols);\n"
        if $self->{row_class}->can('pre_update');

    $post = "            \$s->post_select(\\\%r);\n"
        if $self->{row_class}->can('post_update');

    eval <<"EOF";
{
    package $self->{row_class};

    sub select
    {
        my \$s = shift;
        my \@cols = \@_;

        return \$s->schema->run_in_transaction( sub {

$pre

            my \@r;
            my %r;

            if (wantarray)
            {
                \@r{ \@cols } = \$s->SUPER::select(\@cols);
            }
            else
            {
                \$r{ \$cols[0] } = (scalar \$s->SUPER::select(\$cols[0]));
            }
$post
            return wantarray ? \@r{\@cols} : \$r{ \$cols[0] };
        } );
    }

    sub select_hash
    {
        my \$s = shift;
        my \@cols = \@_;

        return \$s->schema->run_in_transaction( sub {

$pre

            my \%r = \$s->SUPER::select_hash(\@cols);

$post

            return \%r;
        } );
    }
}
EOF

    Alzabo::Exception::Eval->throw( error => $@ ) if $@;

    my $hooks =
        $self->_hooks_doc_string( $self->{row_class}, 'pre_select', 'post_select' );

    $self->{row_class}->add_class_docs
        ( Alzabo::ClassDocs->new
          ( group => 'Hooks',
            description => "$hooks",
          ) );
}

sub make_delete_hooks
{
    my $self = shift;

    my $code = '';
    $code .= "        \$s->schema->run_in_transaction( sub {\n";
    $code .= "            \$s->pre_delete(\\\%p);\n" if $self->{row_class}->can('pre_delete');
    $code .= "            \$s->SUPER::delete(\%p);\n";
    $code .= "            \$s->post_delete(\\\%p);\n" if $self->{row_class}->can('post_delete');
    $code .= "        } );\n";

    eval <<"EOF";
package $self->{row_class};

sub delete
{
    my \$s = shift;
    my \%p = \@_;

$code

}
EOF

    Alzabo::Exception::Eval->throw( error => $@ ) if $@;

    my $hooks =
        $self->_hooks_doc_string( $self->{row_class}, 'pre_delete', 'post_delete' );

    $self->{row_class}->add_class_docs
        ( Alzabo::ClassDocs->new
          ( group => 'Hooks',
            description => "$hooks",
          ) );
}

sub name
{
    my $self = shift;
    my %p = @_;

    return $p{table}->name if $p{type} eq 'table';

    return $p{column}->name if $p{type} eq 'table_column';

    return $p{column}->name if $p{type} eq 'row_column';

    if ( $p{type} eq 'foreign_key' )
    {
        return $p{foreign_key}->table_to->name;
    }

    if ( $p{type} eq 'linking_table' )
    {
        my $method = $p{foreign_key}->table_to->name;
        my $tname = $p{foreign_key}->table_from->name;
        $method =~ s/^$tname\_?//;
        $method =~ s/_?$tname$//;

        return $method;
    }

    return join '_', map { lc $_->name } $p{foreign_key}->table_to, $p{column}
        if $p{type} eq 'lookup_columns';

    return $p{column}->name if $p{type} eq 'lookup_columns';

    return $p{parent} ? 'parent' : 'children'
        if $p{type} eq 'self_relation';

    die "unknown type in call to naming sub: $p{type}\n";
}

package Alzabo::DocumentationContainer;

my %store;
sub add_method_docs
{
    my $class = shift;

    my $docs = shift;

    my $store = $class->_get_store($class);

    my $group = $docs->group;