Rose::DBx::Garden - bootstrap Rose::DB::Object and Rose::HTML::Form classes

 use Rose::DBx::Garden;

 my $garden = Rose::DBx::Garden->new(

         garden_prefix   => 'MyRoseGarden',    # instead of class_prefix
         perltidy_opts   => '-pbp -nst -nse',  # Perl Best Practices
         db              => My::DB->new, # Rose::DB object
         find_schemas    => 0,           # set true if your db has schemas
         force_install   => 0,           # do not overwrite existing files
         debug           => 0,           # print actions on stderr
         skip_map_class_forms => 1,      # no Form classes for many2many map classes
         include_autoinc_form_fields => 1,
         # other Rose::DB::Object::Loader params here

 );

 # $garden ISA Rose::DB::Object::Loader

 $garden->plant('path/to/where/i/want/files');

    my $garden = Rose::DBx::Garden->new(
                    column_to_label => sub {
                           my ($garden_obj, $col_name) = @_;
                           return join(' ', 
                                       map { ucfirst($_) }
                                       split(m/_/, $col_name)
                                  );
                    }
                 );

 RDBO::Class => RHTMLO::Class

    perldoc Rose::DBx::Garden

package Rose::DBx::Garden;

use warnings;
use strict;
use base qw( Rose::DB::Object::Loader );
use Carp;
use Data::Dump qw( dump );
use Path::Class;
use File::Slurp;
use File::Basename;

my $MAX_FIELD_SIZE = 64;

use Rose::Object::MakeMethods::Generic (
    boolean => [
        'find_schemas'                => { default => 0 },
        'force_install'               => { default => 0 },
        'debug'                       => { default => 0 },
        'skip_map_class_forms'        => { default => 1 },
        'include_autoinc_form_fields' => { default => 1 },
    ],
    'scalar --get_set_init' => 'column_field_map',
    'scalar --get_set_init' => 'column_to_label',
    'scalar --get_set_init' => 'garden_prefix',
    'scalar --get_set_init' => 'perltidy_opts',
    'scalar --get_set_init' => 'base_code',
    'scalar --get_set_init' => 'base_form_class_code',
    'scalar --get_set_init' => 'text_field_size',
    'scalar --get_set_init' => 'limit_to_schemas',
    'scalar'                => 'use_db_name',
);

our $VERSION = '0.18';

# TODO better detection of the serial type on per-db basis
sub init_column_field_map {
    return {
        'varchar'          => 'text',
        'text'             => 'textarea',
        'character'        => 'text',
        'date'             => 'date',
        'datetime'         => 'datetime',
        'epoch'            => 'datetime',
        'integer'          => 'integer',
        'bigint'           => 'integer',
        'serial'           => 'serial',
        'time'             => 'time',
        'timestamp'        => 'datetime',
        'float'            => 'numeric',    # TODO nice to have ::Field::Float
        'numeric'          => 'numeric',
        'decimal'          => 'numeric',
        'double precision' => 'numeric',
        'boolean'          => 'boolean',
        'enum'             => 'menu',
    };
}

sub init_column_to_label {
    sub { return $_[1] }
}

sub init_garden_prefix {'MyRoseGarden'}

sub init_perltidy_opts {0}

sub init_text_field_size {$MAX_FIELD_SIZE}

sub init_base_code {''}

sub init_base_form_class_code {
    return <<EOF
use base qw( Rose::HTML::Form );

EOF
}

sub init_limit_to_schemas { [] }

*make_garden = \&plant;

sub plant {
    my $self = shift;
    my $path = shift or croak "path required";

    #carp "path = $path";

    my $path_obj = dir($path);

    $path_obj->mkpath(1);

    # make sure we can 'require' files we generate
    unshift( @INC, $path );

    # set in loader just in case
    $self->module_dir($path);

    my $garden_prefix = $self->garden_prefix;

    # setup the base RDBO class
    my $base_code  = $self->base_code;
    my $db         = $self->db or croak "db required";
    my $db_class   = $db->class;
    my $new_method = $db->can('new_or_cached') ? 'new_or_cached' : 'new';
    my $db_type    = $db->type;
    my $db_domain  = $db->domain;

    # make the base class unless it already exists
    my $base_template = <<EOF;
package $garden_prefix;
use strict;
use base qw( Rose::DB::Object );
use $db_class;

sub init_db { 
    ${db_class}->$new_method( type => '$db_type', domain => '$db_domain' ) 
}

=head2 garden_prefix

Returns the garden_prefix() value with which this class was created.

=cut

sub garden_prefix { '${garden_prefix}' }

$base_code

EOF

    # append metadata if we are using schemas
    if ( $self->find_schemas ) {

        $base_template .= <<EOF;

use ${garden_prefix}::Metadata;
sub meta_class { '${garden_prefix}::Metadata' }

EOF

    }

    # need a 1 no matter what
    $base_template .= "\n1;\n";

    $self->_make_file( $garden_prefix, $base_template )
        unless ( defined $base_code && $base_code eq '0' );

    # find all schemas if this db supports them
    my %schemas;
    if ( $self->find_schemas and !scalar @{ $self->limit_to_schemas } ) {
        my %native = ( information_schema => 1, pg_catalog => 1 );
        my $info = $db->dbh->table_info( undef, '%', undef, 'TABLE' )
            ->fetchall_arrayref;

        #carp dump $info;

        for my $row (@$info) {
            next if exists $native{ $row->[1] };
            $schemas{ $row->[1] }++;
        }

        # only need custom metadata if we are using schemas
        $self->_make_file( join( '::', $garden_prefix, 'Metadata' ),
            $self->_metadata_template );

    }

    # if we are using schemas and have explicitly named them already,
    # then use what was specified.
    elsif ( $self->find_schemas ) {

        $schemas{$_}++ for @{ $self->limit_to_schemas };

        $self->_make_file( join( '::', $garden_prefix, 'Metadata' ),
            $self->_metadata_template );

    }
    elsif ( $self->use_db_name ) {
        %schemas = ( $self->use_db_name => '' );
    }
    else {

        my $dbname = $db->database;
        $dbname =~ s!.*/!!;
        $dbname =~ s/\W/_/g;
        %schemas = ( $dbname => '' );
    }

    my (%created_classes);

    my $preamble  = $self->module_preamble;
    my $postamble = $self->module_postamble;

    $Rose::DB::Object::Loader::Debug = $self->debug || $ENV{PERL_DEBUG} || 0;

    my @classes;

    for my $schema ( keys %schemas ) {

        #carp "working on schema $schema";

        my $schema_class
            = $schema
            ? join( '::', $garden_prefix, ucfirst($schema) )
            : $garden_prefix;

        if ($schema) {
            my $schema_tmpl
                = $self->_schema_template( $garden_prefix, $schema_class,
                $schema );

            $self->_make_file( $schema_class, $schema_tmpl );
            $self->db_schema($schema) if $self->find_schemas;
        }

        #carp "schema_class: $schema_class";

        $self->class_prefix($schema_class);
        $self->base_class($schema_class);   # already wrote it, so can require

        push @classes, $self->make_classes;
    }

    #carp dump \@classes;

    for my $class (@classes) {

        #carp "class: $class";

        my $template       = '';
        my $this_preamble  = '';
        my $this_postamble = '';

        if ( $class->isa('Rose::DB::Object') ) {

            $template
                = $class->meta->perl_class_definition( indent => 4 ) . "\n";

            if ($preamble) {
                $this_preamble
                    = ref $preamble eq 'CODE'
                    ? $preamble->( $class->meta )
                    : $preamble;
            }

            if ($postamble) {
                $this_postamble
                    = ref $postamble eq 'CODE'
                    ? $postamble->( $class->meta )
                    : $postamble;
            }

            $created_classes{$class} = 1;
        }
        elsif ( $class->isa('Rose::DB::Object::Manager') ) {
            $template = $class->perl_class_definition( indent => 4 ) . "\n";

            if ($preamble) {
                $this_preamble
                    = ref $preamble eq 'CODE'
                    ? $preamble->( $class->object_class->meta )
                    : $preamble;
            }

            if ($postamble) {
                $this_postamble
                    = ref $postamble eq 'CODE'
                    ? $postamble->( $class->object_class->meta )
                    : $postamble;
            }
        }
        else {
            croak "class $class not supported";
        }

        $self->_make_file( $class,
            $this_preamble . $template . $this_postamble );
    }

    # RDBO classes all done. That was the easy part.
    # now create a RHTMLO::Form tree using the same model.

    # first create the base ::Form class.
    my $base_form_class      = join( '::', $garden_prefix, 'Form' );
    my $base_form_class_code = $self->base_form_class_code;
    my $base_form_template   = <<EOF;
package $base_form_class;
use strict;

$base_form_class_code

1;

# generated by Rose::DBx::Garden

EOF

    $self->_make_file( $base_form_class, $base_form_template );

    # second create a subclass of base ::Form for each RDBO class.
    for my $rdbo_class ( keys %created_classes ) {

        if (    $self->convention_manager->is_map_class($rdbo_class)
            and $self->skip_map_class_forms )
        {
            print " ... skipping map_class $rdbo_class\n";
            next;
        }
        my $form_class = join( '::', $rdbo_class, 'Form' );
        my $form_template = $self->_form_template( $rdbo_class, $form_class,
            $base_form_class );

        $created_classes{$rdbo_class} = $form_class;

        $self->_make_file( $form_class, $form_template );
    }

    return \%created_classes;
}

sub _metadata_template {
    my $self            = shift;
    my $base_rdbo_class = $self->garden_prefix;

    return <<EOF;
package ${base_rdbo_class}::Metadata;

use strict;
use warnings;

use base qw( Rose::DB::Object::Metadata );

sub setup {
    my \$self   = shift;
    my \$schema = \$self->class->schema;
    \$self->SUPER::setup( \@_, schema => \$schema );
}

1;

EOF
}

sub _form_template {
    my ( $self, $rdbo_class, $form_class, $base_form_class ) = @_;

    # load the rdbo class and examine its metadata.

    # make sure rdbo_class is loaded
    eval "require $rdbo_class";
    croak "can't load $rdbo_class: $@" if $@;

    my $object_name
        = $self->convention_manager->class_to_table_singular($rdbo_class);

    # create a form template using the column definitions
    # as seed for the form field definitions
    # use the convention manager to assign default field labels

    my $form = <<EOF;
package $form_class;
use strict;
use base qw( $base_form_class );

sub object_class { '$rdbo_class' }

sub init_with_${object_name} {
    my \$self = shift;
    \$self->init_with_object(\@_);
}

sub ${object_name}_from_form {
    my \$self = shift;
    \$self->object_from_form(\@_);
}

sub build_form {
    my \$self = shift;
    
    \$self->add_fields(
    
EOF

    my @fields;
    my $count = 0;
    for my $column ( sort __by_position $rdbo_class->meta->columns ) {
        push( @fields, $self->_column_to_field( $column, ++$count ) );
    }

    $form .= join( "\n", @fields );
    $form .= <<EOF;
    );
    
    return \$self->SUPER::build_form(\@_);
}

1;

EOF

    return $form;
}

# keep columns in same order they appear in db
sub __by_position {
    my $pos1 = $a->ordinal_position;
    my $pos2 = $b->ordinal_position;

    if ( defined $pos1 && defined $pos2 ) {
        return $pos1 <=> $pos2 || lc( $a->name ) cmp lc( $b->name );
    }

    return lc( $a->name ) cmp lc( $b->name );
}

sub _column_to_field {
    my ( $self, $column, $tabindex ) = @_;
    my $col_type    = $column->type;
    my $type        = $self->column_field_map->{$col_type} || 'text';
    my $field_maker = 'garden_' . $type . '_field';
    my $label_maker = $self->column_to_label;
    my $label       = $label_maker->( $self, $column->name );

    unless ( $self->can($field_maker) ) {
        $field_maker = 'garden_default_field';
    }

    if ( $col_type eq 'serial' and !$self->include_autoinc_form_fields ) {
        return '';
    }

    return $self->$field_maker( $column, $label, $tabindex );
}

sub garden_default_field {
    my ( $self, $column, $label, $tabindex ) = @_;
    my $col_type = $column->type;
    my $type     = $self->column_field_map->{$col_type} || 'text';
    my $name     = $column->name;
    my $desc     = $column->can('remarks') ? ( $column->remarks || '' ) : '';
    my $length   = $column->can('length') ? $column->length() : 0;
    my $maxlen   = $self->text_field_size;
    if ( defined $length ) {
        $maxlen = $length;
    }
    $length = 24 unless defined $length;    # 24 holds a timestamp

    if ( $length > $MAX_FIELD_SIZE ) {
        $length = $MAX_FIELD_SIZE;
    }

    return <<EOF;
    $name => {
        id          => '$name',
        type        => '$type',
        class       => '$col_type',
        label       => '$label',
        tabindex    => $tabindex,
        rank        => $tabindex,
        size        => $length,
        maxlength   => $maxlen,
        description => q{$desc},
        },
EOF
}

sub garden_numeric_field {
    my ( $self, $column, $label, $tabindex ) = @_;
    my $col_type = $column->type;
    my $type     = $self->column_field_map->{$col_type} || 'text';
    my $name     = $column->name;
    my $desc     = $column->can('remarks') ? ( $column->remarks || '' ) : '';

    return <<EOF;
    $name => {
        id          => '$name',
        type        => '$type',
        class       => '$col_type',
        label       => '$label',
        tabindex    => $tabindex,
        rank        => $tabindex,
        size        => 16,
        maxlength   => 32,
        description => q{$desc},
        },
EOF
}

sub garden_boolean_field {
    my ( $self, $column, $label, $tabindex ) = @_;
    my $col_type = $column->type;
    my $name     = $column->name;
    my $desc     = $column->can('remarks') ? ( $column->remarks || '' ) : '';

    return <<EOF;
    $name => {
        id          => '$name',
        type        => 'boolean',
        label       => '$label',
        tabindex    => $tabindex,
        rank        => $tabindex,
        class       => '$col_type',
        description => q{$desc},
        },
EOF
}

sub garden_text_field {
    my ( $self, $column, $label, $tabindex ) = @_;
    my $col_type = $column->type;
    my $name     = $column->name;
    my $length   = $column->can('length') ? $column->length() : 0;
    $length = 0 unless defined $length;
    my $maxlen = $self->text_field_size;
    if ( defined $length ) {
        $maxlen = $length;
    }
    if ( $length > $MAX_FIELD_SIZE ) {
        $length = $MAX_FIELD_SIZE;
    }
    my $desc = $column->can('remarks') ? ( $column->remarks || '' ) : '';

    return <<EOF;
    $name => {
        id          => '$name',
        type        => 'text',
        class       => '$col_type',
        label       => '$label',
        tabindex    => $tabindex,
        rank        => $tabindex,
        size        => $length,
        maxlength   => $maxlen,
        description => q{$desc},
        },
EOF
}

sub garden_menu_field {
    my ( $self, $column, $label, $tabindex ) = @_;
    my $col_type = $column->type;
    my $name     = $column->name;
    my $options  = dump $column->values;
    my $desc     = $column->can('remarks') ? ( $column->remarks || '' ) : '';

    #dump $column;

    return <<EOF;
    $name => {
        id          => '$name',
        type        => 'menu',
        class       => '$col_type',
        label       => '$label',
        tabindex    => $tabindex,
        rank        => $tabindex,
        options     => $options,
        description => q{$desc},
        },
EOF
}

sub garden_textarea_field {
    my ( $self, $column, $label, $tabindex ) = @_;
    my $col_type = $column->type;
    my $name     = $column->name;
    my $desc     = $column->can('remarks') ? ( $column->remarks || '' ) : '';

    return <<EOF;
    $name => {
        id          => '$name',
        type        => 'textarea',
        class       => '$col_type',
        label       => '$label',
        tabindex    => $tabindex,
        rank        => $tabindex,
        size        => $MAX_FIELD_SIZE . 'x8',
        description => q{$desc},
        },
EOF
}

sub garden_hidden_field {
    my ( $self, $column, $label, $tabindex ) = @_;
    my $col_type = $column->type;
    my $name     = $column->name;
    my $desc     = $column->can('remarks') ? ( $column->remarks || '' ) : '';
    return <<EOF;
    $name => {
        id      => '$name',
        type    => 'hidden',
        class   => '$col_type',
        label   => '$label',
        rank    => $tabindex,
        description => q{$desc},
        },
EOF
}

sub garden_serial_field {
    my ( $self, $column, $label, $tabindex ) = @_;
    my $col_type = $column->type;
    my $name     = $column->name;
    my $desc     = $column->can('remarks') ? ( $column->remarks || '' ) : '';

    return <<EOF;
    $name => {
        id      => '$name',
        type    => 'serial',
        class   => '$col_type',
        label   => '$label',
        rank    => $tabindex,
        description => q{$desc},
        },
EOF
}

sub _schema_template {
    my ( $self, $base, $package, $schema ) = @_;

    return <<EOF;
package $package;
use strict;
use base qw( $base );

sub schema { '$schema' }

1;
EOF
}

sub _make_file {
    my ( $self, $class, $buffer ) = @_;
    ( my $file = $class ) =~ s,::,/,g;
    $file .= '.pm';

    my ( $name, $path, $suffix ) = fileparse( $file, qr{\.pm} );

    my $fullpath = dir( $self->module_dir, $path );

    unless ( $self->force_install ) {
        if ( -s $file ) {
            print " ... skipping $class ($file)\n";
            return;
        }
    }

    $fullpath->mkpath(1) if $path;

    if ( $self->perltidy_opts ) {
        require Perl::Tidy;
        my $newbuf;
        Perl::Tidy::perltidy(
            source      => \$buffer,
            destination => \$newbuf,
            argv        => $self->perltidy_opts
        );
        $buffer = $newbuf;
    }

    write_file( file( $self->module_dir, $file )->stringify, $buffer )
        or die "$!\n";

    print "$class written to $file\n";
}

1;    # End of Rose::DBx::Garden