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};
    }
    else
    {
        my $x = 0;
        do
        {
            $class_root = caller($x++);
            die "No base class could be determined\n" unless $class_root;
        } while ( $class_root->isa(__PACKAGE__) );
    }

    my $self;

    $p{name_maker} = sub { $self->name(@_) } unless ref $p{name_maker};

    $self = bless { opts => \%p,
                    class_root => $class_root,
                    schema => $s,
                  }, $class;

    return $self;
}

sub make
{
    my $self = shift;

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

    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 => 'row_column',
              class => $self->{row_class},
              returns => 'scalar value/takes new value',
              code => sub { my $self = shift;
                            if (@_)
                            {
                                $self->update( $col_name => $_[0] );
                            }
                            return $self->select($col_name); },
              column => $c,
            ) or next;

        $self->{row_class}->add_method_docs
            ( Alzabo::MethodDocs->new
              ( name  => $name,
                group => 'Methods that update/return a column value',
                spec  => [ { type => SCALAR } ],
                description =>
                "returns the value of the " . $c->name . " column for a row.  Given a value, it will also update the row first.",
              ) );
    }
}

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

    foreach my $other_t ( sort { $a->name cmp $b->name  } $t->schema->tables )
    {
        my @fk = $t->foreign_keys_by_table($other_t)
            or next;

        if ( @fk == 2 && $fk[0]->table_from eq $fk[0]->table_to &&
             $fk[1]->table_from eq $fk[1]->table_to )
        {
            unless ($fk[0]->is_one_to_one)
            {
                $self->make_self_relation($fk[0]) if $self->{opts}{self_relations};
            }
            next;
        }

        foreach my $fk (@fk)
        {
            $self->_make_fk_method($fk);
        }
    }
}

sub _make_method
{
    my $self = shift;
    my %p = validate @_, { type => { type => SCALAR },
                           class => { type => SCALAR },
                           returns => { type => SCALAR, optional => 1 },
                           code => { type => CODEREF },

                           # Stuff we can pass through to name_maker
                           foreign_key => { optional => 1 },
                           foreign_key_2 => { optional => 1 },
                           column => { optional => 1 },
                           table => { optional => 1 },
                           parent => { optional => 1 },
                           plural => { optional => 1 },
                         };

    my $name = $self->{opts}{name_maker}->( %p )
        or return;

    my ($code_name, $debug_name) = ("$p{class}::$name",
                                    "$p{class}\->$name");

    if ( $p{class}->can($name) )
    {
        warn "MethodMaker: Creating $p{type} method $debug_name will override"
             . " the method of the same name in the parent class\n";
    }

    no strict 'refs';  # We use symbolic references here
    if ( defined &$code_name )
    {
        # This should probably always be shown to the user, not just
        # when debugging mode is turned on, because name clashes can
        # cause confusion - whichever subroutine happens first will
        # arbitrarily win.

        warn "MethodMaker: skipping $p{type} method $debug_name, subroutine already exists\n";
        return;
    }

    if (Alzabo::Debug::METHODMAKER)
    {
        my $message = "Making $p{type} method $debug_name";
        $message .= ": returns $p{returns}" if $p{returns};
        print STDERR "$message\n";
    }

    *$code_name = $p{code};
    return $name;
}

sub _make_fk_method
{
    my $self = shift;
    my $fk = shift;
    my $table_to = $fk->table_to->name;

    # The table may be a linking or lookup table.  If we are
    # supposed to make that kind of method we will and then we'll
    # skip to the next foreign table.
    $self->make_linking_table_method($fk)
        if $self->{opts}{linking_tables};

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

        foreach my $method ( $class->methods_by_group($group) )
        {
            $pod .= $method->as_pod;
        }
    }

    $pod .= $_ foreach $self->contained_docs;

    $pod .= "=cut\n\n" unless $contained;

    return $pod;
}

sub contained_docs
{
    my $self = shift;

    return map { $_->docs_as_pod(1) } $self->contained_classes;
}

package Alzabo::Docs;

sub group { shift->{group} }
sub description { shift->{description} }

# copied from Params::ValidatePP
{
    my %type_to_string =
        ( Params::Validate::SCALAR()    => 'scalar',
          Params::Validate::ARRAYREF()  => 'arrayref',
          Params::Validate::HASHREF()   => 'hashref',
          Params::Validate::CODEREF()   => 'coderef',
          Params::Validate::GLOB()      => 'glob',
          Params::Validate::GLOBREF()   => 'globref',
          Params::Validate::SCALARREF() => 'scalarref',
          Params::Validate::UNDEF()     => 'undef',
          Params::Validate::OBJECT()    => 'object',
        );

    sub _typemask_to_strings
    {
        shift;
        my $mask = shift;

        my @types;
        foreach ( Params::Validate::SCALAR, Params::Validate::ARRAYREF,
                  Params::Validate::HASHREF, Params::Validate::CODEREF,
                  Params::Validate::GLOB, Params::Validate::GLOBREF,
                  Params::Validate::SCALARREF, Params::Validate::UNDEF,
                  Params::Validate::OBJECT )
        {
            push @types, $type_to_string{$_} if $mask & $_;
        }
        return @types ? @types : ('unknown');
    }
}

package Alzabo::MethodDocs;

use Params::Validate qw( validate SCALAR ARRAYREF HASHREF );

use base qw(Alzabo::Docs);

sub new
{
    my $class = shift;
    my %p = validate( @_, { name    => { type => SCALAR },
                            group   => { type => SCALAR },
                            description => { type => SCALAR },
                            spec    => { type => SCALAR | ARRAYREF | HASHREF,
                                         default => undef },
                          } );

    return bless \%p, $class;
}

sub name { shift->{name} }
sub spec { shift->{spec} }

sub as_pod
{
    my $self = shift;

    my $desc = ucfirst $self->{description};

    my $spec = $self->spec;

    my $params;
    if ( defined $spec )
    {
        if ( Alzabo::Utils::is_arrayref( $spec ) )
        {
            $params = "=over 4\n\n";

            foreach my $p (@$spec)
            {
                $params .= "=item * ";
                if ( exists $p->{type} )
                {
                    # hack!
                    my $types =
                        join ', ', $self->_typemask_to_strings( $p->{type} );
                    $params .= "($types)";
                }
                $params .= "\n\n";
            }

            $params .= "=back\n\n";
        }
        elsif ( Alzabo::Utils::is_hashref($spec) )
        {
            $params = "=over 4\n\n";

            while ( my ($name, $p) = each %$spec )
            {
                $params .= "=item * $name ";
                if ( exists $p->{type} )
                {
                    # hack!
                    my $types =
                        join ', ', $self->_typemask_to_strings( $p->{type} );
                    $params .= "($types)";
                }
                $params .= "\n\n";
            }

            $params .= "=back\n\n";
        }
        else
        {
            $params = "Parameters: $spec\n\n";
        }
    }

    my $pod = <<"EOF";
=head3 $self->{name}

$desc

EOF
    $pod .= $params if $params;

    return $pod;
}


package Alzabo::ClassDocs;

use Params::Validate qw( validate SCALAR );

use base qw(Alzabo::Docs);

sub new
{
    my $class = shift;
    my %p = validate( @_, { group   => { type => SCALAR },
                            description => { type => SCALAR },
                          } );

    return bless \%p, $class;
}

sub as_pod
{
    my $self = shift;

    return ucfirst "$self->{description}\n\n";
}

1;


__END__

=head1 NAME

Alzabo::MethodMaker - Auto-generate useful methods based on an existing schema

=head1 SYNOPSIS

  use Alzabo::MethodMaker ( schema => 'schema_name', all => 1 );

=head1 DESCRIPTION

This module can take an existing schema and generate a number of
useful methods for this schema and its tables and rows.  The method
making is controlled by the parameters given along with the use
statement, as seen in the L<SYNOPSIS
section|Alzabo::MethodMaker/SYNOPSIS>.

=head1 PARAMETERS

These parameters are all passed to the module when it is imported via
C<use>.

=over 4

=item * schema => $schema_name

This parameter is B<required>.

=item * class_root => $class_name

If given, this will be used as the root of the class names generated
by this module.  This root should not end in '::'.  If none is given,
then the calling module's name is used as the root.  See L<New Class
Names|"New Class Names"> for more information.

=item * all => $bool

This tells this module to make all of the methods it possibly can.
See L<METHOD CREATION OPTIONS|"METHOD CREATION OPTIONS"> for more
details.

If individual method creation options are set as false, then that
setting will be respected, so you could use