Bigtop::ScriptHelp - A helper modules for command line utilities

    #!/usr/bin/perl
    use Bigtop::ScriptHelp;

    my $default = Bigtop::ScriptHelp->get_minimal_default();
    my $tree    = Bigtop::Parser->parse_string( $default );
    # ...

    my $style   = 'SomeStyle';  # must live in Bigtop::ScriptHelp::Style::

    my $better_default = Bigtop::ScriptHelp->get_big_default(
            $style, $name, $art
    );
    my $better_tree    = Bigtop::Parser->parse_string( $better_default );

    Bigtop::ScriptHelp->augment_tree( $style, $bigtop_tree, $art );

    my $new_field_label = Bigtop::ScriptHelp->default_label( $name );

    bigtop -n App 'contact<-birth_day'

    bigtop -n App -s Pg8Live dsninfo username password

package Bigtop::ScriptHelp;
use strict; use warnings;

use base 'Exporter';

our @EXPORT = qw( valid_ident );

use File::HomeDir;
use File::Spec;
use Cwd;

my %non_entry   = (
    id       => 1,
    created  => 1,
    modified => 1,
);

sub _get_config_block {
    my $app_name  = shift;
    my $build_dir = shift;

    $app_name =~ s/::/_/g;
    $app_name = lc( $app_name );

    my $conf_file = File::Spec->catfile(
            $build_dir, 'docs', 'app.gantry.conf'
    );

    return << "EO_Config_Default";
config {
    engine          MP20;
    template_engine TT;
    Init            Std             {}
    Conf Gantry      { conffile `$conf_file`; instance $app_name; }
    HttpdConf Gantry { gantry_conf 1; }
    SQL             SQLite          {}
    SQL             Postgres        {}
    SQL             MySQL           {}
    CGI             Gantry          { with_server 1; flex_db 1; gantry_conf 1; }
    Control         Gantry          { dbix 1; }
    Model           GantryDBIxClass {}
    SiteLook        GantryDefault   {}
}
EO_Config_Default
}

sub get_minimal_default {
    my $class  = shift;
    my $name   = shift || 'Sample';

    my $cwd       = getcwd();
    my $dir_name  = $name;
    $dir_name     =~ s/::/-/g;

    my $cgi       = lc( $dir_name ) . '.cgi';

    my $build_dir = File::Spec->catfile( $cwd, $dir_name );
    my $app_db    = File::Spec->catfile( $build_dir, 'app.db' );

    # See if they have a bigtopdef or ~/.bigtopdef
    # If no .bigtopdef, whip something up from scratch
    my $def_file;
    my $home_dir = File::HomeDir->my_home();
    my $home_def = File::Spec->catfile( $home_dir, '.bigtopdef' );
    if ( -f 'bigtopdef' ) {
        $def_file = 'bigtopdef';
    }
    elsif ( -f $home_def ) {
        $def_file = $home_def;
    }

    if ( $def_file and not $ENV{ BIGTOP_REAL_DEF } ) {
        return _minimal_from_file( $def_file, $name );
    }

    my $config = _get_config_block( $name, $build_dir );

    return << "EO_Little_Default";
$config
app $name {
    config {
        dbconn `dbi:SQLite:dbname=app.db` => no_accessor;
        template_wrapper `genwrapper.tt` => no_accessor;
        doc_rootp `/static` => no_accessor;
        show_dev_navigation 1 => no_accessor;
    }
    config CGI {
        dbconn `dbi:SQLite:dbname=$app_db` => no_accessor;
        app_rootp `/cgi-bin/$cgi` => no_accessor;
    }
    controller is base_controller {
        method do_main is base_links {
        }
        method site_links is links {
        }
    }
}
EO_Little_Default
}

sub _minimal_from_file {
    my $file     = shift;
    my $app_name = shift;

    # form substitution names
    my $short_name = $app_name;
    $short_name    =~ s/.*:://;

    my $no_colon_name = $app_name;
    $no_colon_name    =~ s/::/_/g;
    $no_colon_name    = lc( $no_colon_name );

    my %subs = (
        app_name      => $app_name,
        no_colon_name => $no_colon_name,
        short_name    => $short_name,
    );

    # apply substitution names
    require Template;

    my $retval;
    my $tt = Template->new( { ABSOLUTE => 1 } );
    $tt->process( $file, \%subs, \$retval );

    # give it to 'em
    return $retval;
}

sub get_big_default {
    my $class    = shift;
    my $style    = shift;
    my $app_name = shift;
    my $extras   = join ' ', @_;

    my $starter_kit = $class->get_minimal_default( $app_name );
    my $tree        = Bigtop::Parser->parse_string( $starter_kit );

    $class->augment_tree( $style, $tree, $extras );

    return Bigtop::Deparser->deparse( $tree );
}

sub _transpose {
    my $foreign_key_for = shift;

    my %retval;

    foreach my $foreign_key ( keys %{ $foreign_key_for } ) {
        foreach my $table_info ( @{ $foreign_key_for->{ $foreign_key } } ) {
            push @{ $retval{ $table_info->{ table } } }, $foreign_key;
        }
    }

    return \%retval;
}

sub _correlate_columns {
    my $columns = shift;
    my $ast     = shift;

    my %correlation;

    # first walk existing tables in the tree
    if ( defined $ast ) {
        my $tables = $ast->walk_postorder( 'all_table_names' );

        foreach my $table ( @{ $tables } ) {

            my $columns = $ast->walk_postorder( 'all_field_names', $table );

            $correlation{ $table } = $columns;
        }
    }

    # then walk new columns
    foreach my $table ( keys %{ $columns } ) {
        my @table_columns;
        foreach my $col ( @{ $columns->{ $table } } ) {
            push @table_columns, $col->{ name };
        }
        $correlation{ $table } = \@table_columns;
    }

    return \%correlation;
}

sub _safely_order {
    my $requested_tables = shift;
    my $foreign_key_for  = shift;

    my @ordered_tables;
    my %requests = map { $_ => 1 } @{ $requested_tables };

    my %fk_tree;
    foreach my $fk ( keys %{ $foreign_key_for } ) {
        foreach my $f_table ( @{ $foreign_key_for->{ $fk } } ) {
            push @{ $fk_tree{ $fk } }, $f_table->{ table };
        }
    }

    my @chains;
    foreach my $chain_leaf ( keys %fk_tree ) {
        push @chains, [ _build_chain( $chain_leaf, \%fk_tree ) ];
    }

    my %handled;

    foreach my $chain ( @chains ) {
        LINK:
        foreach my $link ( @{ $chain } ) {
            next LINK unless $requests{ $link };
            next LINK if $handled{ $link }++;

            push @ordered_tables, $link;
        }
    }

    STRAY:
    foreach my $table ( @{ $requested_tables } ) {
        next STRAY unless $requests{ $table };
        next STRAY if $handled{ $table }++;
        push @ordered_tables, $table;
    }

    return \@ordered_tables;
}

sub _build_chain {
    my $chain_leaf = shift;
    my $fk_tree    = shift;

    my @retval = ( $chain_leaf );

    return @retval unless ( defined $fk_tree->{ $chain_leaf } );

    foreach my $parent ( @{ $fk_tree->{ $chain_leaf } } ) {
        unshift @retval, _build_chain( $parent, $fk_tree );
    }

    return @retval;
}

sub _make_native_fields {
    my $columns_for = shift;
    my $table       = shift;
    my $foreign_targets = shift;

    my $columns     = $columns_for->{ $table };
    my $foreign_display;
    my $second_main_col;
    my @exclude_from_form;

    # first handle the columns
    my $retval = '';
    my $space  = ' ';
    my $outer_indent = $space x 8;
    my $is_spacing   = $space x 12;

    foreach my $column ( @{ $columns } ) {

        if ( $column->{ default } ) {
            push @{ $column->{ types } }, "`DEFAULT '$column->{ default }'`";
        }

        my $type_string = join ', ', @{ $column->{ types } };

        my $decorations = '';
        if ( $non_entry{ $column->{ name } } ) {
            push @exclude_from_form, $column->{ name };
        }
        else {
            $second_main_col = $column->{ name }
                        if $foreign_display and not $second_main_col;

            $foreign_display = $column->{ name } unless $foreign_display;

            $type_string = "${is_spacing}$type_string";

            die "invalid column name $column->{ name }\n"
                    unless valid_ident( $column->{ name } );

            my $label = Bigtop::ScriptHelp->default_label( $column->{ name } );

            $label = "`$label`" if ( $label =~ /\s+/ );

            $decorations = << "EO_DEC";
            label          $label;
            html_form_type text;
EO_DEC
            if ( $column->{ optional } ) {
                $decorations .= << "EO_OPTIONAL";
            html_form_optional 1;
EO_OPTIONAL
            }
            if ( $column->{ default } ) {
                $decorations .= << "EO_DEFAULT";
            html_form_default_value `$column->{ default }`;
EO_DEFAULT
            }
        }

        $retval .= "${outer_indent}field $column->{ name } {\n";
        $retval .= "${outer_indent}    is $type_string;\n";
        $retval .= $decorations if $decorations;
        $retval .= "${outer_indent}}\n";
    }

    # finish by adding foreign_display
    $retval .= "${outer_indent}foreign_display `%$foreign_display`;";

    foreach my $foreign_target ( @{ $foreign_targets->{ $table } } ) {
        $retval .=
            "\n${outer_indent}refered_to_by `$foreign_target`;";
    }

    my $main_cols = $foreign_display;
    $main_cols   .= ", $second_main_col" if $second_main_col;

    return ( $retval, $main_cols, join( ', ', @exclude_from_form ) );
}

sub _make_foreign_key_fields {
    my $foreign_key_for = shift;
    my $model           = shift;
    my $col_num_2_name  = shift;

    my @foreign_fields;
    my $foreign_text = "\n";
    if ( defined $foreign_key_for->{ $model } ) {
        foreach my $foreign_key ( @{ $foreign_key_for->{ $model } } ) {

            my $label = Bigtop::ScriptHelp->default_label(
                    _strip_schema( $foreign_key->{ table } )
            );

            my $name  = $foreign_key->{ table };
            $name     =~ s/\./_/;

            my $reference_str = "`$foreign_key->{ table }`";
            if ( defined $foreign_key->{ col } ) {
                my $col_name = $col_num_2_name->{ $foreign_key->{ table } }
                                                [ $foreign_key->{ col } - 1 ];

                $reference_str .= " => $col_name" if $col_name;
            }

            my $new_foreigner = <<"EO_Foreign_Field";
        field $name {
            is             int4;
            label          `$label`;
            refers_to      $reference_str;
            html_form_type select;
        }
EO_Foreign_Field
            push @foreign_fields, $new_foreigner;
        }
        $foreign_text = join '', @foreign_fields;
    }

    chomp $foreign_text;

    return $foreign_text;
}

sub _strip_schema {
    my $input = shift;
    $input    =~ s/^[^\.]*\.//;

    return $input;
}

sub augment_tree {
    my $class = shift;
    my $style = shift;
    my $ast   = shift;
    my $art   = shift;

    # parse existing tree, get a list of all the extant tables
    my %initial_tables  = map { $_ => 1 }
                  keys %{ $ast->{application}{lookup}{tables} };
    my $joins   = $ast->{application}{lookup}{join_tables};

    foreach my $join_member ( keys %{ $joins } ) {

        foreach my $membership ( @{ $joins->{ $join_member } } ) {

            my ( $join_table ) = values %{ $membership->{ joins } };

            $initial_tables{ $join_table } = 1;
        }
    }

    my $parsed_art = $style->get_db_layout( $art, \%initial_tables );
    my ( $tables, $new_tables, $joiners, $foreign_key_for, $columns ) = (
        $parsed_art->{ all_tables },
        $parsed_art->{ new_tables },
        $parsed_art->{ joiners    },
        $parsed_art->{ foreigners },
        $parsed_art->{ columns    },
    );

    my $foreign_targets = _transpose( $foreign_key_for );

    my $col_num_2_name = _correlate_columns( $columns, $ast );

    $new_tables = _safely_order( $new_tables, $foreign_key_for );

    # make new tables with tentmaker hooks
    my %new_table;
    my %new_controller_for;
    foreach my $table ( @{ $new_tables } ) {
        my $controller  = Bigtop::ScriptHelp->default_controller( $table );

        my $schema_free = _strip_schema( $table );

        my $descr       = $schema_free;
        $descr          =~ s/_/ /g;

        my $model_label = Bigtop::ScriptHelp->default_label( $schema_free );

        my $rel_loc     = $table;
        $rel_loc        =~ s/\./_/;

        $new_table{ $table } = $ast->create_block(
                'table', $table, { columns => $columns->{ $table } }
        );

        my ( $foreign_display, $on_main_listing, $all_fields_but ) = 
                _get_controller_fields( $columns->{ $table } );

        # set a foreign display
        if ( defined $foreign_display ) {
            $ast->change_statement(
                {
                    type      => 'table',
                    ident     => $new_table{ $table }->get_ident,
                    keyword   => 'foreign_display',
                    new_value => "%$foreign_display",
                }
            );
        }

        # make a controller for the new table
        $new_controller_for{ $table } = $ast->create_block(
                'controller',
                $controller,
                { subtype          => 'AutoCRUD',
                  table            => $table,
                  text_description => $descr,
                  page_link_label  => $model_label,
                  rel_loc          => $rel_loc,
                  on_main_listing  => $on_main_listing,
                  all_fields_but   => $all_fields_but,
                }
        );
    }

    foreach my $point_from ( keys %{ $foreign_key_for } ) {
        my $ident = $ast->{application}
                          {lookup}
                          {tables}
                          {$point_from}
                          {__IDENT__};

        if ( not defined $ident ) {  # must be new
            $ident = $new_table{ $point_from }->get_ident();
        }

        foreach my $foreign_key ( @{ $foreign_key_for->{ $point_from } } ) {

            my $name  = $foreign_key->{ table };
            $name     =~ s/\./_/;

            my $label =
                    Bigtop::ScriptHelp->default_label(
                            _strip_schema( $foreign_key->{ table } )
                    );

            my $foreign_key_ref_str = $foreign_key->{ table };
            if ( defined $foreign_key->{ col } ) {
                my $col_name = $col_num_2_name->{ $foreign_key->{ table } }
                                                [ $foreign_key->{ col } - 1 ];

                $foreign_key_ref_str = {
                        keys   => $foreign_key->{ table },
                        values => $col_name
                } if $col_name;
            }

            my $refers_to_field = $ast->create_subblock(
                {
                    parent => {
                        type => 'table', ident => $ident
                    },
                    new_child => {
                        type => 'field',
                        name => $name,
                    },
                }
            );

            $ast->change_statement(
                {
                    type => 'field',
                    ident => $refers_to_field->{__IDENT__},
                    keyword => 'is',
                    new_value => 'int4',
                }
            );
            $ast->change_statement(
                {
                    type => 'field',
                    ident => $refers_to_field->{__IDENT__},
                    keyword => 'label',
                    new_value => $label,
                }
            );
            $ast->change_statement(
                {
                    type => 'field',
                    ident => $refers_to_field->{__IDENT__},
                    keyword => 'refers_to',
                    new_value => $foreign_key_ref_str,
                }
            );
            $ast->change_statement(
                {
                    type      => 'field',
                    ident     => $refers_to_field->{__IDENT__},
                    keyword   => 'html_form_type',
                    new_value => 'select',
                }
            );
        }
    }

    foreach my $point_to ( keys %{ $foreign_targets } ) {
        my $ident = $ast->{application}
                          {lookup} 
                          {tables}
                          {$point_to}
                          {__IDENT__};

        if ( not defined $ident ) {
            $ident = $new_table{ $point_to }->get_ident();
        }

        my @all_referrers;
        my @referrer_values;

        # find existing referrals
        my $original_referrers = $ast->get_statement(
            {
                type    => 'table',
                ident   => $ident,
                keyword => 'refered_to_by',
            }
        );

        foreach my $original_referrer ( @{ $original_referrers } ) {
            my ( $table, $has_many_name ) =
                    split /\s*=>\s*/, $original_referrer;

            $has_many_name ||= '';

            push @all_referrers, $table;
            push @referrer_values, $has_many_name;
        }

        # add new ones and set as new value
        push @all_referrers, @{ $foreign_targets->{ $point_to } };

        $ast->change_statement(
            {
                type => 'table',
                ident => $ident,
                keyword => 'refered_to_by',
                new_value => {
                    keys   => join( '][', @all_referrers ),
                    values => join( '][', @referrer_values ),
                }
            }
        );
    }

    # Make three ways.
    foreach my $joiner ( @{ $joiners } ) {
        my ( $table1, $table2 ) = @{ $joiner };
        my $second = $table2;
        $second    =~ s/.*\.//;
        my $join_name = "${table1}_${second}";
        my $join_table = $ast->create_block( 'join_table', $join_name, {} );

        $ast->change_statement(
            {
                type      => 'join_table',
                ident     => $join_table->{ join_table }{ __IDENT__ },
                keyword   => 'joins',
                new_value => {
                    keys => $table1,
                    values => $table2,
                }
            }
        );
    }

    return; # This is an in place tree modifier.
}

sub _get_controller_fields {
    my $columns = shift;

    my $foreign_display;
    my $second_main_col;
    my @exclude_from_form;

    foreach my $column ( @{ $columns } ) {
        if ( $non_entry{ $column->{ name } } ) {
            push @exclude_from_form, $column->{ name };
        }
        else {
            $second_main_col = $column->{ name }
                        if $foreign_display and not $second_main_col;

            $foreign_display = $column->{ name } unless $foreign_display;
        }
    }

    my $main_cols = $foreign_display;
    $main_cols   .= ", $second_main_col" if $second_main_col;

    return ( $foreign_display, $main_cols, join( ', ', @exclude_from_form ) );
}

sub valid_ident {
    my $candidate = shift;

    # XXX this regex is allowing leading digits
    return $candidate =~ /^\w[\w\d_:\.]*$/;
}

sub default_label {
    my $class  = shift;
    my $name   = shift;

    my @output_pieces = _name_breaker( $name, qr/_/ );

    return join ' ', @output_pieces;  # one space separator
}

sub default_controller {
    my $class = shift;
    my $table = shift;

    my $name = $class->default_label( $table );
    $name    =~ s/ //g;

    my @output_pieces = _name_breaker( $name, qr/\./ );

    return join '', @output_pieces;  # no space separator
}

sub _name_breaker {
    my $name     = shift;
    my $split_on = shift;

    my @output_pieces;

    foreach my $piece ( split $split_on, $name ) {
        $piece = ucfirst $piece;
        push @output_pieces, $piece;
    }

    return @output_pieces;
}

1;