File Coverage

blib/lib/Bigtop/ScriptHelp.pm

Criterion	Covered	Total	%
statement	20	302	6.6
branch	0	62	0.0
condition	0	13	0.0
subroutine	7	23	30.4
pod	6	6	100.0
total	33	406	8.1

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;

=head1 NAME

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

=head1 SYNOPSIS

    #!/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 );

=head1 DESCRIPTION

This module is used by the bigtop and tentmaker scripts.  It provides
convenience functions for them.

=head1 Styles

Whenever a user is building or augmenting a bigtop file, they can
specify new tables and their relationships via a script help style of their
choice.  All the styles are modules in the Bigtop::ScriptHelp::Style::
namespace.  See C for general information about
styles and individual modules under its namespace for how each style
works.  That said, here is a list of the styles available when this was
written.

=head2 Kickstart

This is the default style.

It allows short text descriptions of database relationships.
For example:

    bigtop -n App 'contact<-birth_day'

But recent versions allow you to specify column names, their types, whether
they are optional, and to give them literal default values.  See
C for details.  This is my favorite
style (so it's no surprise that it is the default).

=head2 Pg8Live

This style must be requested:

    bigtop -n App -s Pg8Live dsninfo username password

It will connect to the database described by the dsninfo with the supplied
username and password and create a bigtop file from it.  This will create
a full AutoCRUD app for the database.  The bigtop file will have all the
tables, their columns including types and defaults.  It will also know about
all primary and foreign keys in the original database.  Depending on how
exotic the input database is, it will also know to autoincrement the primary
key.

Writing your own style is easy.  See C for
the requirements and the two existing styles for examples.

=head1 METHODS

All methods are class methods.

=over 4

=item get_minimal_default

Params: app_name (optional, defaults to Sample)

Returns: a little default bigtop string suitable for initial building.
It has everything you need for your app except tables and controllers.

=item get_big_default

Params:

    script help style
    app name
    a list of data for the style

Returns: a bigtop file suitable for immediately creating an app and
starting it.

=item augment_tree

Params:

    script help style
    a Bigtop::Parser syntax tree (what you got from a parse_* method)
    a string of data for the style (join all elements with spaces)

Returns: nothing, but the tree you passed will be updated.

=item default_label

Params: a new name

Returns: a default label for that name

Example of conversion: if name is birth_date, the label becomes 'Birth Date'.

=item default_controller

Params: a new table name

Returns: a default label for that table's controller

Example of conversion: if table name is birth_date, the controller
becomes 'BirthDate'.

=back

=head1 FUNCTIONS

The following functions are meant for internal use, but you might like
them too.  Don't call them through the class, call them as functions.

=over 4

=item valid_ident

Exported by default.

Params: a proposed ident

Returns: true if the ident looks good, false otherwise.  Note that the
regex is not perfect.  For instance, it will allow leading numbers.
Further it absolutely will not notice if a table or controller name is
reserved.

=back

=head1 AUTHOR

Phil Crow, [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006-7, Phil Crow

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.

=cut