File Coverage

blib/lib/Alzabo/MethodMaker.pm

Criterion	Covered	Total	%
statement	39	460	8.4
branch	0	192	0.0
condition	0	34	0.0
subroutine	13	70	18.5
pod	0	19	0.0
total	52	775	6.7

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;

    $self->{schema_class} = join '::', $self->{class_root}, 'Schema';
    bless $self->{schema}, $self->{schema_class};

    $self->eval_schema_class;
    $self->load_class( $self->{schema_class} );

   {
       # Users can add methods to these superclasses
       no strict 'refs';
       foreach my $thing ( qw( Table Row ) )
       {
           @{ "$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",
              ) );
    }
}

sub make_row_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 => '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};

    $self->make_lookup_columns_methods($fk)
        if $self->{opts}{lookup_columns};

    return unless $self->{opts}{foreign_keys};

    if ($fk->is_one_to_many)
    {
        my $name = $self->_make_method
            ( type => 'foreign_key',
              class => $self->{row_class},
              returns => 'row cursor',
              code => sub { my $self = shift;
                            return $self->rows_by_foreign_key( foreign_key => $fk, @_ ); },
              foreign_key => $fk,
              plural => 1,
            ) or return;

        $self->{row_class}->add_method_docs
            ( Alzabo::MethodDocs->new
              ( name  => $name,
                group => 'Methods that return cursors for foreign keys',
                description =>
                "returns a cursor containing related rows from the " . $fk->table_to->name . " table",
                spec  => 'same as Alzabo::Runtime::Table->rows_where',
              ) );
    }
    # Singular method name
    else
    {
        my $name = $self->_make_method
            ( type => 'foreign_key',
              class => $self->{row_class},
              returns => 'single row',
              code => sub { my $self = shift;
                            return $self->rows_by_foreign_key( foreign_key => $fk, @_ ); },
              foreign_key => $fk,
              plural => 0,
            ) or return;

        $self->{row_class}->add_method_docs
            ( Alzabo::MethodDocs->new
              ( name  => $name,
                group => 'Methods that return a single row for foreign keys',
                description =>
                "returns a single related row from the " . $fk->table_to->name . " table",
                spec  => 'same as Alzabo::Runtime::Table->one_row',
              ) );
    }
}

sub make_self_relation
{
    my $self = shift;
    my $fk = shift;

    my (@pairs, @reverse_pairs);
    if ($fk->is_one_to_many)
    {
        @pairs = map { [ $_->[0], $_->[1]->name ] } $fk->column_pairs;
        @reverse_pairs = map { [ $_->[1], $_->[0]->name ] } $fk->column_pairs;
    }
    else
    {
        @pairs = map { [ $_->[1], $_->[0]->name ] } $fk->column_pairs;
        @reverse_pairs = map { [ $_->[0], $_->[1]->name ] } $fk->column_pairs;
    }

    my $table = $fk->table_from;

    my $name = $self->_make_method
        ( type => 'self_relation',
          class => $self->{row_class},
          returns => 'single row',
          code => sub { my $self = shift;
                        my @where = map { [ $_->[0], '=', $self->select( $_->[1] ) ] } @pairs;
                        return $table->one_row( where => \@where, @_ ); },
          foreign_key => $fk,
          parent => 1,
        ) or last;

    if ($name)
    {
        $self->{row_class}->add_method_docs
            ( Alzabo::MethodDocs->new
              ( name  => $name,
                group => 'Methods that return a parent row',
                description =>
                "a single parent row from the same table",
                spec  => 'same as Alzabo::Runtime::Table->one_row',
              ) );
    }

    $name = $self->_make_method
        ( type => 'self_relation',
          class => $self->{row_class},
          returns => 'row cursor',
          code =>
          sub { my $self = shift;
                my %p = @_;
                my @where = map { [ $_->[0], '=', $self->select( $_->[1] ) ] } @reverse_pairs;
                if ( $p{where} )
                {
                    @where = ( '(', @where, ')' );

                    push @where,
                        Alzabo::Utils::is_arrayref( $p{where}->[0] ) ? @{ $p{where} } : $p{where};

                    delete $p{where};
                }
                return $table->rows_where( where => \@where,
                                           %p ); },
          foreign_key => $fk,
          parent => 0,
        ) or return;

    $self->{row_class}->add_method_docs
        ( Alzabo::MethodDocs->new
          ( name  => $name,
            group => 'Methods that return child rows',
            description =>
            "a row cursor of child rows from the same table",
            spec  => 'same as Alzabo::Runtime::Table->rows_where',
          ) );
}

sub make_linking_table_method
{
    my $self = shift;
    my $fk = shift;

    return unless $fk->table_to->primary_key_size == 2;

    # Find the foreign key from the linking table to the _other_ table
    my $fk_2;
    {
        my @fk = $fk->table_to->all_foreign_keys;
        return unless @fk == 2;

        # Get the foreign key that's not the one we already have
        $fk_2 = $fk[0]->is_same_relationship_as($fk) ? $fk[1] : $fk[0];
    }

    return unless $fk_2;

    # Not a linking table unless all the PK columns in the linking
    # table are part of the link.
    return unless $fk->table_to->primary_key_size == $fk->table_to->columns;

    # Not a linking table unless the PK in the middle table is the
    # same size as the sum of the two table's PK sizes
    return unless ( $fk->table_to->primary_key_size ==
                    ( $fk->table_from->primary_key_size + $fk_2->table_to->primary_key_size ) );

    my $s = $fk->table_to->schema;
    my @t = ( $fk->table_to, $fk_2->table_to );
    my $select = [ $t[1] ];

    my $name = $self->_make_method
        ( type => 'linking_table',
          class => $self->{row_class},
          returns => 'row cursor',
          code =>
          sub { my $self = shift;
                my %p = @_;
                if ( $p{where} )
                {
                    $p{where} = [ $p{where} ] unless Alzabo::Utils::is_arrayref( $p{where}[0] );
                }
                foreach my $pair ( $fk->column_pairs )
                {
                    push @{ $p{where} }, [ $pair->[1], '=', $self->select( $pair->[0]->name ) ];
                }

                return $s->join( tables => [[@t, $fk_2]],
                                 select => $select,
                                 %p ); },
          foreign_key => $fk,
          foreign_key_2 => $fk_2,
        ) or return;

    $self->{row_class}->add_method_docs
        ( Alzabo::MethodDocs->new
          ( name  => $name,
            group => 'Methods that follow a linking table',
            description =>
            "a row cursor of related rows from the " . $fk_2->table_to->name . " table, " .
            "via the " . $fk->table_to->name . " linking table",
            spec  => 'same as Alzabo::Runtime::Table->rows_where',
          ) );
}

sub make_lookup_columns_methods
{
    my $self = shift;
    my $fk = shift;

    return if $fk->is_one_to_many;

    # Make sure the relationship is to the foreign table's primary key
    my @to = $fk->columns_to;
    return unless ( ( scalar grep { $_->is_primary_key } @to ) == @to &&
                    ( $fk->table_to->primary_key_size == @to ) );

    foreach ( sort { $a->name cmp $b->name  } $fk->table_to->columns )
    {
        next if $_->is_primary_key;

        my $col_name = $_->name;

        my $name = $self->_make_method
            ( type => 'lookup_columns',
              class => $self->{row_class},
              returns => 'scalar value of column',
              code =>
              sub { my $self = shift;
                    my $row = $self->rows_by_foreign_key( foreign_key => $fk, @_ );
                    return unless $row;
                    return $row->select($col_name) },
              foreign_key => $fk,
              column => $_,
            ) or next;

        $self->{row_class}->add_method_docs
            ( Alzabo::MethodDocs->new
              ( name  => $name,
                group => 'Methods that follow a lookup table',
                description =>
                "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;
    my $name = $docs->name;

    $store->{methods}{by_group}{$group} ||= Tie::IxHash->new;
    $store->{methods}{by_group}{$group}->Push( $name => $docs );

    $store->{methods}{by_name} ||= Tie::IxHash->new;
    $store->{methods}{by_name}->Push( $name => $docs );
}

sub add_class_docs
{
    my $class = shift;

    my $docs = shift;

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

    my $group = $docs->group;

    $store->{class}{by_group}{$group} ||= [];
    push @{ $store->{class}{by_group}{$group} }, $docs;
}

sub add_contained_class
{
    my $class = shift;

    my ($type, $contained) = @_;

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

    push @{ $store->{contained_classes}{by_name} }, $contained;

    push @{ $store->{contained_classes}{by_type}{$type} }, $contained;
}

sub _get_store
{
    my $class = shift;
    $class = ref $class || $class;

    $store{$class} ||= {};

    return $store{$class};
}

sub method_names
{
    my $class = shift;

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

    return $store->{methods}{by_name}->Keys;
}

sub methods_by_name
{
    my $class = shift;

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

    return $store->{methods}{by_name}->Values;
}

sub method_groups
{
    my $class = shift;

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

    return keys %{ $store->{methods}{by_group} };
}

sub methods_by_group
{
    my $class = shift;

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

    my $group = shift;

    return $store->{methods}{by_group}{$group}->Values
        if exists $store->{methods}{by_group}{$group};
}

sub class_groups
{
    my $class = shift;

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

    return keys %{ $store->{class}{by_group} };
}

sub class_docs_by_group
{
    my $class = shift;

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

    my $group = shift;

    return @{ $store->{class}{by_name}{$group} }
        if exists $store->{class}{by_name}{$group};
}

sub class_docs
{
    my $class = shift;

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

    my $group = shift;

    return map { @{ $store->{class}{by_group}{$_} } }
        keys %{ $store->{class}{by_group} };
}

sub contained_classes
{
    my $class = shift;

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

    return @{ $store->{contained_classes}{by_name} }
        if exists $store->{contained_classes}{by_name};

    return;
}

sub method
{
    my $class = shift;

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

    my $name = shift;

    return $store->{methods}{by_name}->FETCH($name)
        if exists $store->{methods}{by_name};
}

sub docs_as_pod
{
    my $self = shift;
    my $class = ref $self || $self;
    my $contained = shift;

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

    my $pod;

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

    $pod .= "=head1 $class\n\n";

    foreach my $class_doc ( $class->class_docs )
    {
        $pod .= $class_doc->as_pod;
    }

    foreach my $group ( $class->method_groups )
    {
        $pod .= "=head2 $group\n\n";

        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__