Bigtop::Parser - the Parse::RecDescent grammar driven parser for bigtop files

    config {
        base_dir `/home/username`;
        Type1 Backend {}
        Type2 Backend {}
        Type3 Backend {}
    }
    app App::Name {
        table name { }
        controller SomeController {}
    }

    bigtop my.bigtop all

package Bigtop::Parser;
use strict; use warnings;

use File::Find;
use File::Spec;
use Data::Dumper;
use Carp;

use Bigtop::Grammar;
use Bigtop::Keywords;
use Bigtop::ScriptHelp;

# These don't work since we moved grammar to bigtop.grammar.
        # $::RD_TRACE = 1;
        # $::RD_HINT = 1;
# Set them in Grammar.pm directly under the use Parse::RecDescent statement.

my $ident_counter = 0;
my $parser;
my %valid_keywords;
my %keyword_for;

#---------------------------------------------------------------------
#   Methods which add and validate keywords in the grammar
#---------------------------------------------------------------------

sub add_valid_keywords {
    my $class    = shift;
    my $type     = shift;
    my $caller   = caller( 0 );

    my %callers;

    KEYWORD:
    foreach my $statement ( @_ ) {
        my $keyword = $statement->{keyword};

        my $seen_it = $valid_keywords{ $type }{ $keyword };

        $valid_keywords{ $type }{ $keyword }++;

        next KEYWORD if ( defined $statement->{type}
                            and   $statement->{type} eq 'deprecated' );

        push @{ $keyword_for{ $type }{ $keyword }{ callers } }, $caller;

        next KEYWORD if $seen_it;

        push @{ $keyword_for{ $type }{ statements } }, $statement;
    }
}

BEGIN {
    Bigtop::Parser->add_valid_keywords(
        Bigtop::Keywords->get_docs_for(
            'config',
            qw( engine template_engine plugins base_dir app_dir )
        )
    );

    # register no_gen as a keyword for (almost) all block types
    # sequence and table are not included since SQL happens all at once
    foreach my $keyword_type qw( app controller method ) {
        Bigtop::Parser->add_valid_keywords(
            Bigtop::Keywords->get_docs_for(
                $keyword_type,
                'no_gen',
            )
        );
    }

    # to allow a table to be described, but to be omitted from either
    # a Model or SQL output

    Bigtop::Parser->add_valid_keywords(
        Bigtop::Keywords->get_docs_for( 'table', 'not_for' )
    );

    Bigtop::Parser->add_valid_keywords(
        Bigtop::Keywords->get_docs_for( 'field', 'not_for' )
    );
}

sub is_valid_keyword {
    my $class   = shift;
    my $type    = shift;
    my $keyword = shift;

    return $valid_keywords{$type}{$keyword};
}

sub get_valid_keywords {
    my $class = shift;
    my $type  = shift;

    my %trailer_for = (
        config     => 'or a valid backend block',
        app        => 'or a valid block (controller, sequence, ' .
                                        'config, table, or join_table)',
        controller => 'or a valid method block',
        table      => 'or a valid field block',
    );

    my %extras_for = (
        app => [ 'literal' ],
    );

    my @extra_expected = @{ $extras_for{ $type } }
            if ( defined $extras_for{ $type } );

    my $trailer  = $trailer_for{ $type };

    my @expected = sort @extra_expected, keys %{ $valid_keywords{ $type } };
    push( @expected, $trailer ) if $trailer;

    return @expected;
}

sub get_keyword_docs {

    foreach my $type ( keys %keyword_for ) {
        my @sorted = sort { $a->{ sort_order } <=> $b->{ sort_order } }
                        @{ $keyword_for{ $type }{ statements } };

        $keyword_for{ $type }{ statements } = \@sorted;
    }

    return \%keyword_for;
}

#---------------------------------------------------------------------
#   The ident factory
#---------------------------------------------------------------------

sub get_ident {
    $ident_counter++;

    return "ident_$ident_counter";
}

#---------------------------------------------------------------------
#   The import method
#---------------------------------------------------------------------

sub import {
    my $class   = shift;
    my @modules = @_;

    foreach my $module ( @modules ) {
        my ( $type, $name, $template ) = split /=/, $module;

        # build full path to module and require it
        my $module_file = File::Spec->catfile(
            'Bigtop', 'Backend', $type, "$name.pm"
        );
        require $module_file;

        my $package = 'Bigtop::Backend::' . $type . '::' . $name;

        # allow caller to fill in a template file
        if ( $class->gen_mode && $package->can( 'setup_template' ) ) {
            $package->setup_template( $template );
        }
    }
}

my $gen_mode = 1;
sub gen_mode {
    my $class = shift;

    return $gen_mode;
}

sub set_gen_mode {
    my $class = shift;
    my $value = shift;

    $gen_mode = $value;

    return $gen_mode;
}

#---------------------------------------------------------------------
#   Methods which handle errors
#---------------------------------------------------------------------

sub fatal_keyword_error {
    my $class = shift;
    my $args  = shift;

    my $bad_keyword          = $args->{ bad_keyword   };
    my $diag_text            = $args->{ diag_text     };
    my $bigtop_input_linenum = $args->{ input_linenum };
    my $keyword_type         = $args->{ type          };
    my @expected             = @{ $args->{ expected } };

    $diag_text               =~ s/\n.*//sg;  # trim to one line

    # see if they forget a block name
    my %block_types = (
        config     => {},
        app        => { controller => 1,
                        sequence   => 1,
                        config     => 1,
                        table      => 1,
                        join_table => 1,
                      },
        controller => { method     => 1, },
        table      => { field      => 1, },
    );

    if ( $block_types{ $keyword_type }{ $bad_keyword } ) {
        die "Error: missing name for $bad_keyword block (line "
            .   "$bigtop_input_linenum) near:\n"
            .   "$diag_text\n";
    }

    my $expected             = join ', ', @expected;

    die "Error: invalid keyword '$bad_keyword' (line $bigtop_input_linenum) "           . "near:\n"
        . "$diag_text\n"
        . "I was expecting one of these: $expected.\n";
}

sub fatal_error_two_lines {
    my $class                = shift;
    my $message              = shift;
    my $diag_text            = shift;
    my $bigtop_input_linenum = shift;

    $diag_text               = substr $diag_text, 0, 65;

    die "Error: $message\n    "
        . "on line $bigtop_input_linenum near:\n$diag_text\n";
}

#---------------------------------------------------------------------
#   The grammar has been moved to the generated Bigtop::Grammar
#---------------------------------------------------------------------

#---------------------------------------------------------------------
#   The preprocessor (comment stripper)
#---------------------------------------------------------------------
#
# The single parameter should be a bigtop string.  It will be modified
# in place, by having all comments removed.  A comment is a line where
# the first non-whitespace char is #
#
# Returns: a hash each key is a line numbers whose value is the comment
# which was on that line of the source.
#
sub preprocess {

    # first capture all the comments
    my %retval;
    my $line_count = 0;
    foreach my $line ( split /\n/, $_[0] ) {
        if ( $line =~ /^\s*#.*/ ) {
            $retval{ $line_count } = $line;
        }
        $line_count++;
    }

    # then expunge all comments
    $_[0] =~ s/^\s*#.*//mg;

    return \%retval;
}

#---------------------------------------------------------------------
#   Methods which parse input
#---------------------------------------------------------------------

sub get_parser {
    $parser = Bigtop::Grammar->new() if ( not defined $parser );

    return $parser;
}

# This is the method that bigtop uses.
sub gen_from_file {
    my $class       = shift;
    my $bigtop_file = shift;
    my $create      = shift;
    my @gen_list    = shift;

    my $BIGTOP_FILE;
    open ( $BIGTOP_FILE, '<', $bigtop_file )
            or die "Couldn't read bigtop file $bigtop_file: $!\n";

    my $bigtop_string = join '', <$BIGTOP_FILE>;

    close $BIGTOP_FILE;

    my $flags;
    if ( $create ) {
        $flags = "-c $bigtop_file @gen_list";
    }

    return $class->gen_from_string(
        {
            bigtop_string => $bigtop_string,
            bigtop_file   => $bigtop_file,
            create        => $create,
            build_list    => \@gen_list,
            flags         => $flags,
        }
    );
}

# This is the method that gen_from_file uses.
sub gen_from_string {
    my $class         = shift;
    my $opts          = shift;

    my $bigtop_string =    $opts->{ bigtop_string };
    my $bigtop_file   =    $opts->{ bigtop_file   };
    my $create        =    $opts->{ create        };
    my $flags         =    $opts->{ flags         };
    my @args          = @{ $opts->{ build_list    } };

    my $config        = $class->parse_config_string( $bigtop_string );

    my $build_types   = $class->load_backends( $bigtop_string, $config );

    # build the whole parse tree
    my $bigtop_tree   = $class->parse_string( $bigtop_string );

    # check to see if an app wide no_gen is in effect
    my $lookup = $bigtop_tree->{application}{lookup};

    if ( defined $lookup->{app_statements}{no_gen}
            and
        $lookup->{app_statements}{no_gen}
    ) {
        warn "Warning: app level is marked no_gen, skipping generation\n";
        return;
    }

    # make the build directory (if needed)
    my $build_dir = _build_app_home_dir( $bigtop_tree, $create );

    # make sure we are in the right place
    # if there are init backends, ask the first one to verify build dir
    if ( $config->{__BACKENDS__}{ Init } ) {
        my $module = join '::', (
            'Bigtop',
            'Backend',
            'Init',
            $config->{__BACKENDS__}{ Init }[0]{__NAME__}
        );
        $module->validate_build_dir( $build_dir, $bigtop_tree, $create );
    }
    else {
        my $init_str = 'Init=Std';
        $class->import( $init_str );
        my $init_pack = 'Bigtop::Backend::Init::Std';
        $init_pack->validate_build_dir( $build_dir, $bigtop_tree, $create );
    }

    # replace all with a list of all available backends
    my @gen_list;
    foreach my $gen_type ( @args ) {
        if ( $gen_type eq 'all' ) { push @gen_list, @{ $build_types}; }
        else                      { push @gen_list, $gen_type;        }
    }

    # generate the files
    my @available_backends = sort keys %{ $config->{ __BACKENDS__ } };
    unshift @available_backends, 'all';
    my $backends_called    = 0;
    foreach my $gen_type ( @gen_list ) {

        BACKEND:
        foreach my $backend ( @{ $config->{__BACKENDS__}{ $gen_type } } ) {

            next BACKEND
                    if ( defined $backend->{no_gen} and $backend->{no_gen} );

            my $module = join '::', (
                'Bigtop', 'Backend', $gen_type, $backend->{__NAME__}
            );
            my $method = "gen_$gen_type";
            $module->$method( $build_dir, $bigtop_tree, $bigtop_file, $flags );

            $backends_called++;
        }
    }

    if ( $backends_called == 0 ) {
        rmdir $build_dir;
        _purge_inline();
        die "I didn't build anything, please check for no_gen in\n"
            .   "$bigtop_file and choose from:\n"
            .   "   @available_backends\n";
    }

    return ( $bigtop_tree->get_appname, $build_dir );
}

sub load_backends {
    my $class         = shift;
    my $bigtop_string = shift;
    my $config        = shift;

    # import the moudles mentioned in the config

    my @modules_to_require;
    my @build_types;
    my %seen_build_type;

    my $saw_init = 0;
    BACKEND:
    foreach my $backend_statement ( @{ $config->{__STATEMENTS__} } ) {
        my $backend_type = $backend_statement->[0];
        next BACKEND unless $config->{__BACKENDS__}{$backend_type};
        $saw_init = 1 if $backend_type eq 'Init';
        foreach my $backend ( @{ $config->{__BACKENDS__}{$backend_type} } ) {
            my $backend_name = $backend->{__NAME__};
            my $template     = $backend->{template} || '';

            my $module_str = join '=', $backend_type, $backend_name, $template;

            push @modules_to_require, $module_str;
            push @build_types, $backend_type
                    unless ( $seen_build_type{ $backend_type }++ );
        }
    }

    $class->import( @modules_to_require );

    push @build_types, 'Init' if $saw_init;

    return \@build_types;
}

sub _build_app_home_dir {
    my $tree     = shift;
    my $create   = shift;
    my $config   = $tree->get_config();

    my $base_dir = '.';
    
    if ( $create ) {
        $base_dir = $config->{base_dir} if defined $config->{base_dir};
    }
    elsif ( defined $config->{base_dir} ) {
        warn "Warning: config's base_dir ignored, "
                . "because we're not in create mode\n";
    }

    # make sure base_dir exists
    die "You must make the base directory $base_dir\n" unless ( -d $base_dir );

    # get app name and make a directory of it
    my $build_dir = _form_build_dir( $base_dir, $tree, $config, $create );

    if ( $create ) {
        if ( -d $build_dir ) {
            die "cowardly refusing to create,\n"
                .   "...build dir $build_dir already exists\n";
        }

        mkdir $build_dir;

        die "couldn't make directory $build_dir\n" unless ( -d $build_dir );
    }
    else {
        die "$build_dir is not a directory, perhaps you need to use --create\n"
                unless ( -d $base_dir );
    }

    $tree->{configuration}{build_dir} = $build_dir;

    return $build_dir;
}

sub _form_build_dir {
    my $base_dir = shift;
    my $tree     = shift;
    my $config   = shift;
    my $create   = shift;

    my $app_dir  = '';
    if ( $create ) {
        if ( defined $config->{app_dir} and $config->{app_dir} ) {
            $app_dir = $config->{app_dir};
        }
        else {
            $app_dir = $tree->get_appname();
            $app_dir    =~ s/::/-/g;
        }
    }
    else {
        if ( defined $config->{app_dir} ) {
            warn "config's app_dir ignored, because we're not in create mode\n";
        }
    }

    return File::Spec->catdir( $base_dir, $app_dir );
}

sub _purge_inline {
    my $doomed_dir = '_Inline';
    return unless -d $doomed_dir;

    my $purger = sub {
        my $name = $_;

        if    ( -f $name ) { unlink $name; }
        elsif ( -d $name ) { rmdir  $name; }
    };

    require File::Find;

    File::Find::finddepth( $purger, $doomed_dir );
    rmdir $doomed_dir;
}

sub parse_config_string {
    my $class  = shift;
    my $string = shift
        or croak "usage: Bigtop::Parser->parse_config_string(bigtop_string)";

    preprocess( $string );

    my $retval = $class->get_parser->config_only( $string );

    unless ( $retval ) {
        die "Couldn't parse config in your bigtop input.\n";
    }

    return $retval;
}

sub parse_string {
    my $class  = shift;
    my $string = shift
        or croak "usage: Bigtop::Parser->parse_string(bigtop_string)";

    # strip comments
    my $comments      = preprocess( $string );

    my $build_types   = $class->load_backends(
            $string,
            $class->parse_config_string( $string )
    );

    my $retval = $class->get_parser->bigtop_file( $string );

    $retval->set_comments( $comments );

    unless ( $retval ) {
        die "Couldn't parse your bigtop input.\n";
    }

    return $retval;
}

sub parse_file {
    my $class       = shift;
    my $bigtop_file = shift
        or croak "usage: BigtoP::Parser->parse_file(bigtop_file)";

    open my $BIGTOP_INPUT, "<", $bigtop_file
        or croak "Couldn't open $bigtop_file: $!\n";

    my $data = join '', <$BIGTOP_INPUT>;

    close $BIGTOP_INPUT;

    return $class->parse_string( $data );
}

#---------------------------------------------------------------------
#   Packages for each node type.  These can walk_postorder.
#   Start with $your_tree->walk_postorder( 'action', $data_object ).
#
#   Most of these have a useful dumpme which trims the Data::Dumper
#   output.  The closer you are to the bottom of the tree, the
#   better it looks relative to a regular dump.
#---------------------------------------------------------------------

package # application_ancestor
    application_ancestor;
use strict; use warnings;

sub set_parent {
    my $self   = shift;
    my $output = shift;
    my $data   = shift;
    my $parent = shift;

    $self->{__PARENT__} = $parent;

    return;
}

sub dumpme {
    my $self = shift;

    my $parent = delete $self->{__PARENT__};

    use Data::Dumper; warn Dumper( $self );

    $self->{__PARENT__} = $parent;
}

sub find_primary_key {
    my $self   = shift;
    my $table  = shift;
    my $lookup = shift;

    my $fields = $lookup->{ tables }{ $table }{ fields };

    my @primaries;

    FIELD:
    foreach my $field_name ( keys %{ $fields } ) {

        my $field = $fields->{$field_name};

        foreach my $statement_keyword ( keys %{ $field } ) {

            next unless $statement_keyword eq 'is';

            my $statement = $field->{ $statement_keyword };

            foreach my $arg ( @{ $statement->{args} } ) {
                if ( $arg eq 'primary_key' ) {
                    push @primaries, $field_name;
                }
            } # end of foreach argument
        } # end of foreach statement
    } # end of foreach field

    if ( @primaries > 1 ) {
        return \@primaries;
    }
    elsif ( @primaries == 1 ) {
        return $primaries[0];
    }
    else {
        return;
    }
}

sub find_unique_name {
    my $self   = shift;
    my $table  = shift;
    my $lookup = shift;

    my $fields = $lookup->{ tables }{ $table }{ fields };

    my $uniques;

    FIELD:
    foreach my $field_name ( keys %{ $fields } ) {

        my $field = $fields->{$field_name};

        foreach my $statement_keyword ( keys %{ $field } ) {

            next unless $statement_keyword eq 'unique_name';

            my $statement = $field->{ $statement_keyword };

            my $constraint_name = $statement->{args}[0];

            push( @{$uniques->{$constraint_name}}, $field_name );
        } # end of foreach statement
    } # end of foreach field

    if ( scalar(keys %{$uniques}) > 0 ) {
        return $uniques;
    }

    else {
        return;
    }
}

package # bigtop_file
    bigtop_file;
use strict; use warnings;

use Config;

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;

    return $self->{application}->walk_postorder( $action, $data );
}

sub get_comments {
    my $self     = shift;

    return $self->{comments};
}

sub set_comments {
    my $self     = shift;
    my $comments = shift;

    $self->{comments} = $comments;
}

sub get_app_configs {
    my $self = shift;

    my $app_configs = $self->walk_postorder( 'get_app_configs' );

    my %retval;

    foreach my $config_type ( @{ $app_configs } ) {
        $retval{ $config_type->{ type } } = $config_type->{ statements };
    }

    return \%retval;
}

sub get_controller_configs {
    my $self = shift;

    my $app_configs = $self->walk_postorder( 'get_controller_configs' );

    my %retval;

    foreach my $config_type ( @{ $app_configs } ) {
        $retval{ $config_type->{ controller } } = $config_type->{ configs };
    }

    return \%retval;
}

sub get_app_config_types {
    my $self = shift;

    return $self->walk_postorder( 'get_app_config_types' );
}

sub get_lookup {
    my $self = shift;

    return $self->{application}{lookup};
}

sub get_authors {
    my $self = shift;

    if ( defined $self->{application}{lookup}{app_statements}{authors} ) {
        my $authors = $self->{application}{lookup}{app_statements}{authors};

        my $retval  = [];

        foreach my $author ( @{ $authors } ) {
            if ( ref( $author ) eq 'HASH' ) {
                push @{ $retval }, [ %{ $author } ];
            }
            else {
                push @{ $retval }, [ $author, '' ];
            }
        }

        $retval;
    }
    else { # fall back on password file or local equivalent
        my $retval = [];
        # this eval was stolen from h2xs, but has been reformatted
        eval {
            my ( $username, $author_gcos ) = ( getpwuid($>) )[0,6];

            if ( defined $username && defined $author_gcos ) {

                $author_gcos =~ s/,.*$//; # in case of sub fields

                my $domain = $Config{ mydomain };
                $domain =~ s/^\.//;

                push @{ $retval }, [ $author_gcos, "$username\@$domain" ];
            }
        };
        return $retval;
    }
}

sub get_contact_us {
    my $self       = shift;
    my $statements = $self->{application}{lookup}{app_statements};

    if ( defined $statements->{contact_us} ) {
        return $statements->{contact_us}[0];
    }
    elsif ( defined $statements->{email} ) {
        return $statements->{email}[0];
    }
    else {
        return '';
    }
}

sub get_copyright_holder {
    my $self       = shift;
    my $statements = $self->{application}{lookup}{app_statements};

    if ( defined $statements->{copyright_holder} ) {
        return $statements->{copyright_holder}[0];
    }
    else {
        my $first_author = $self->get_authors->[0];
        return $first_author->[0] || '';
    }
}

sub get_license_text {
    my $self = shift;

    return $self->{application}{lookup}{app_statements}{license_text}[0];
}

sub get_config {
    my $tree = shift;

    return $tree->{configuration};
}

sub get_app {
    my $tree = shift;

    return $tree->{application};
}

sub get_app_blocks {
    my $tree = shift;

    return $tree->get_app()->get_blocks();
}

sub get_appname {
    my $tree = shift;

    return $tree->get_app()->get_name();
}

sub set_appname {
    my $tree     = shift;
    my $new_name = shift;

    $tree->{application}->set_name( $new_name );
}

sub get_top_level_configs {
    my $tree = shift;

    my %retval;

    STATEMENT:
    foreach my $statement ( @{ $tree->{ configuration }{__STATEMENTS__} } ) {
        my ( $name, $value ) = @{ $statement };
        next STATEMENT if ref( $value );

        $retval{ $name } = $value;
    }

    return \%retval;
}

sub set_top_level_config {
    my $tree      = shift;
    my $keyword   = shift;
    my $new_value = shift;

    $new_value    =~ s/^\s+//;
    $new_value    =~ s/\s+$//;

    if ( $new_value !~ /^\w[\w\d_:\.]*$/ ) {
        $new_value = "`$new_value`";
    }

    my $config    = $tree->{configuration};

    # change it in the quick lookup hash...
    $config->{ $keyword } = $new_value;

    # ... and in the __STATEMENTS__ list
    my $we_changed_it = 0;
    STATEMENT:
    foreach my $statement ( @{ $config->{__STATEMENTS__} } ) {
        my ( $candidate_keyword, $value ) = @{ $statement };
        if ( $candidate_keyword eq $keyword ) {
            $statement->[1] = $new_value;
            $we_changed_it++;
            last STATEMENT;
        }
    }

    # add the statement at the top if it wasn't already there
    unless ( $we_changed_it ) {
        unshift @{ $config->{__STATEMENTS__} }, [ $keyword, $new_value ];
    }
}

sub clear_top_level_config {
    my $tree      = shift;
    my $keyword   = shift;

    my $config    = $tree->{configuration};

    # clear it from the quick lookup hash...
    delete $config->{ $keyword };

    # ... and from the __STATEMENTS__ list
    my $doomed_index = -1;
    my $count        = 0;
    STATEMENT:
    foreach my $statement ( @{ $config->{__STATEMENTS__} } ) {
        my ( $candidate_keyword ) = @{ $statement };
        if ( $candidate_keyword eq $keyword ) {
            $doomed_index = $count;
            last STATEMENT;
        }

        $count++;
    }

    if ( $doomed_index >= 0 ) {
        splice @{ $config->{__STATEMENTS__} }, $doomed_index, 1;
    }
}

sub get_engine {
    my $tree = shift;

    return $tree->{configuration}{engine};
}

sub set_engine {
    my $tree       = shift;
    my $new_engine = shift;

    my $config = $tree->{configuration};

    # change it in the quick lookup hash...
    $config->{engine} = $new_engine;

    # ... and in the __STATEMENTS__ list
    my $we_changed_engines = 0;
    STATEMENT:
    foreach my $statement ( @{ $config->{__STATEMENTS__} } ) {
        my ( $keyword, $value ) = @{ $statement };
        if ( $keyword eq 'engine' ) {
            $statement->[1] = $new_engine;
            $we_changed_engines++;
            last STATEMENT;
        }
    }

    # add the statement at the top if it wasn't already there
    unless ( $we_changed_engines ) {
        unshift @{ $config->{__STATEMENTS__} }, [ 'engine', $new_engine ];
    }
}

sub get_template_engine {
    my $tree = shift;

    return $tree->{configuration}{template_engine};
}

sub set_template_engine {
    my $tree       = shift;
    my $new_engine = shift;

    my $config = $tree->{configuration};

    # change it in the quick lookup hash...
    $config->{template_engine} = $new_engine;

    # ... and in the __STATEMENTS__ list
    my $we_changed_engines = 0;
    STATEMENT:
    foreach my $statement ( @{ $config->{__STATEMENTS__} } ) {
        my ( $keyword, $value ) = @{ $statement };
        if ( $keyword eq 'template_engine' ) {
            $statement->[1] = $new_engine;
            $we_changed_engines++;
            last STATEMENT;
        }
    }

    # add the statement at the top if it wasn't already there
    unless ( $we_changed_engines ) {
        unshift @{ $config->{__STATEMENTS__} },
                [ 'template_engine', $new_engine ];
    }
}

sub change_statement {
    my $self   = shift;
    my $params = shift;

    $params->{ app } = $self->get_app;

    my ( undef, $doc_hash ) = Bigtop::Keywords->get_docs_for(
        $params->{type}, $params->{keyword}
    );

    $params->{ pair_required } = $doc_hash->{ pair_required };

    my $walk_action = "change_$params->{ type }_statement";

    my $result      = $self->walk_postorder( $walk_action, $params );

    if ( @{ $result } == 0 ) {
        die "Couldn't change $params->{type} statement "
            .   "'$params->{keyword}' for '$params->{ident}'\n";
    }

    return $result->[0];
}

sub data_statement_change {
    my $self   = shift;
    my $params = shift;

    return $self->walk_postorder( 'change_data_statement', $params );
}

sub get_statement {
    my $self   = shift;
    my $params = shift;

    my $walk_action = "get_$params->{ type }_statement";

    my $result = $self->walk_postorder( $walk_action, $params );

    return $result->[0];
}

sub remove_statement {
    my $self   = shift;
    my $params = shift;

    my $walk_action = "remove_$params->{ type }_statement";
    my $result      = $self->walk_postorder( $walk_action, $params );

    if ( @{ $result } == 0 ) {
        warn "Couldn't remove statement: couldn't find it with $walk_action\n";
        require Data::Dumper;
        Data::Dumper->import( 'Dumper' );
        warn Dumper( $params );
    }
}

sub change_name {
    my $self   = shift;
    my $params = shift;

    my $method            = "change_name_$params->{type}";

    $params->{__THE_TREE__} = $self;
    my $instructions = $self->walk_postorder( $method, $params );

    if ( $instructions->[1] ) { # Should this be 0?
        return $instructions;
    }
    else {
        return [];
    }
}

sub create_block {
    my $self     = shift;
    my $type     = shift;
    my $name     = shift;
    my $data     = shift;

    my $result   = $self->walk_postorder(
            'add_block', { type => $type, name => $name, %{ $data } }
    );

    return $result->[ 0 ];
}

sub delete_block {
    my $self         = shift;
    my $ident        = shift;

    my $instructions = $self->walk_postorder(
            'remove_block',
            {
                ident        => $ident,
                __THE_TREE__ => $self,
            }
    );

    if ( $instructions->[0] and defined $instructions->[1] ) {
        return $instructions;
    }
    else {
        return [];
    }
}

sub move_block {
    my $self   = shift;
    my $params = shift;

    $self->walk_postorder( 'block_move', $params );
}

sub create_subblock {
    my $self   = shift;
    my $params = shift;

    my $result = $self->walk_postorder( 'add_subblock', $params );

    if ( @{ $result } == 0 ) {
        die "Couldn't add subblock '$params->{new_child}{name}' "
            .   "to $params->{parent}{type} '$params->{parent}{ident}'\n";
    }

    return $result->[0];
}

sub type_change {
    my $self   = shift;
    my $params = shift;

    $self->walk_postorder( 'change_type', $params );
}

sub field_became_date {
    my $self   = shift;
    my $params = shift;

    my @retvals;

    my $table_name = $self->walk_postorder(
        'get_table_name_from_field_ident',
        $params
    )->[0];

    my $result = $self->walk_postorder(
            'use_date_plugin', { table => $table_name, }
    );

    push @retvals, @{ $result };

    # make sure field's type is text
    $self->walk_postorder(
            'change_field_statement',
            {
                type      => 'field',
                ident     => $params->{ ident },
                keyword   => 'html_form_type',
                new_value => 'text',
            },
    );

    push @retvals, $params->{ ident } . '::html_form_type', 'text';

    # based on the triggering event, update the other possible cause
    # ... if is became date, set date select text
    if ( $params->{ trigger } eq 'date' ) {
        $self->walk_postorder(
                'change_field_statement',
                {
                    type      => 'field',
                    ident     => $params->{ ident },
                    keyword   => 'date_select_text',
                    new_value => 'Select Date',
                },
        );
        push @retvals,
             $params->{ ident } . '::date_select_text',
             'Select Date';
    }
    # ... if date select text got a value, make the field type date
    else {
        $self->walk_postorder(
                'change_field_statement',
                {
                    type      => 'field',
                    ident     => $params->{ ident },
                    keyword   => 'is',
                    new_value => 'date',
                },
        );
        push @retvals, $params->{ ident } . '::is', 'date';
    }

    return \@retvals;
}

sub table_reset_bool {
    my $self   = shift;
    my $params = shift;

    return $self->walk_postorder( 'table_reset_bool', $params );
}

sub show_idents {
    my $self = shift;

    $self->walk_postorder( 'show_idents' );
}

package # application
    application;
use strict; use warnings;

sub get_blocks {
    my $self = shift;

    return $self->walk_postorder( 'app_block_hashes' );
}

sub get_name {
    my $self = shift;

    return $self->{__NAME__};
}

sub set_name {
    my $self     = shift;
    my $new_name = shift;

    $self->{__NAME__} = $new_name;
}

sub get_app_statement {
    my $self    = shift;
    my $keyword = shift;

    my $answer = $self->walk_postorder( 'get_statement', $keyword );

    return $answer;
}

sub set_app_statement {
    my $self    = shift;
    my $keyword = shift;
    my $value   = shift;

    my $success = $self->walk_postorder(
        'set_statement', { keyword => $keyword, value => $value }
    );

    unless ( defined $success->[0] ) { # no existing statement, make one
        $self->{__BODY__}->add_last_statement( $keyword, $value );
    }
}

sub set_app_statement_pairs {
    my $self    = shift;
    my $params  = shift;

    my ( undef, $doc_hash ) = Bigtop::Keywords->get_docs_for(
        'app', $params->{keyword}
    );

    $params->{ pair_required } = $doc_hash->{ pair_required };

    my $success = $self->walk_postorder( 'set_statement_pairs', $params );

    unless ( defined $success->[0] ) { # make a new statement
        $self->{__BODY__}->add_last_statement_pair( $params );
    }
}

sub remove_app_statement {
    my $self    = shift;
    my $keyword = shift;

    $self->walk_postorder( 'remove_statement', $keyword );
}

sub set_config_statement {
    my $self     = shift;
    my $ident    = shift;
    my $keyword  = shift;
    my $value    = shift;
    my $accessor = shift;

    my $success  = $self->walk_postorder(
        'update_config_statement',
        {
            ident   => $ident,
            keyword => $keyword,
            value   => $value,
        }
    );

    unless ( defined $success->[0] ) { # no such statement
        $self->{__BODY__}->add_last_config_statement(
                $ident, $keyword, $value, $accessor
        );
    }
}

sub get_config_statement {
    my $self             = shift;
    my $config_type_name = shift;
    my $keyword          = shift;

    return $self->walk_postorder(
        'get_config_value',
        {
            config_type_name => $config_type_name,
            keyword => $keyword,
        }
    );
}

sub get_config_ident {
    my $self              = shift;
    my $config_block_name = shift;

    my $idents = $self->walk_postorder(
            'get_config_idents', $config_block_name
    );

    return $idents->[0];
}

sub set_config_statement_status {
    my $self    = shift;
    my $ident   = shift;
    my $keyword = shift;
    my $value   = shift;

    $self->walk_postorder(
        'config_statement_status',
        {
            ident   => $ident,
            keyword => $keyword,
            value   => $value,
        }
    );
}

sub delete_config_statement {
    my $self    = shift;
    my $ident   = shift;
    my $keyword = shift;

    $self->walk_postorder(
        'remove_config_statement',
        {
            ident => $ident,
            keyword => $keyword,
        }
    );
}

sub get_config {
    my $self = shift;

    my $statements = $self->walk_postorder( 'get_config_statements' );

    return $statements;
}

sub show_idents {
    my $self         = shift;
    my $child_output = shift;

    require Data::Dumper;
    warn Data::Dumper::Dumper( $child_output );

    return;
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;

    my $output = $self->{__BODY__}->walk_postorder( $action, $data, $self );

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, undef );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

package # app_body
    app_body;
use strict; use warnings;

use base 'application_ancestor';

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

    foreach my $block ( @{ $self->{'block(s?)'} } ) {
        my $child_output = $block->walk_postorder( $action, $data, $self );

        push @{ $output }, @{ $child_output } if $child_output;
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub add_block {
    my $self = shift;
    shift;
    my $data = shift;

    my $new_block = block->new_block( $self, $data );

    push @{ $self->{ 'block(s?)' } }, $new_block;

    return [ $new_block ];
}

sub remove_block {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;
    my $doomed_ident = $data->{ ident };

    my $blocks       = $self->{ 'block(s?)' };
    my $doomed_index = get_block_index( $blocks, $doomed_ident );

    return $child_output if ( $doomed_index == -1 ); # must be for a subblock

    splice @{ $blocks }, $doomed_index, 1;

    return [ 1 ];
}

sub block_move {
    my $self   = shift;
    shift;
    my $data   = shift;
    my $blocks = $self->{ 'block(s?)' };

    my $mover_index  = get_block_index( $blocks, $data->{mover} );
    die "No such block: $data->{mover}\n" if ( $mover_index == -1 );
    my $moving_block = splice @{ $blocks }, $mover_index, 1;

    my $pivot_index  = get_block_index( $blocks, $data->{pivot} );

    if ( $pivot_index == -1 ) {
        splice @{ $blocks }, $mover_index, 0, $moving_block;

        die "No such pivot block: $data->{pivot}\n";
    }

    if ( defined $data->{after} and $data->{after} ) {
        splice @{ $blocks }, $pivot_index + 1, 0, $moving_block;
    }
    else {
        splice @{ $blocks }, $pivot_index, 0, $moving_block;
    }

    return [ 1 ];
}

sub get_block_index {
    my $blocks       = shift;
    my $target_ident = shift;

    my $target_index = -1;
    my $count        = 0;

    BLOCK:
    foreach my $block ( @{ $blocks } ) {
        next BLOCK if defined $block->{app_statement};

        if ( $block->matches( $target_ident ) ) {
            $target_index = $count;
            last BLOCK;
        }
    }
    continue {
        $count++;
    }

    return $target_index;
}

sub remove_statement {
    my $self    = shift;
    shift;
    my $keyword = shift;

    my $doomed_child = -1;
    my $count        = 0;

    BLOCK:
    foreach my $block ( @{ $self->{'block(s?)'} } ) {
        next BLOCK unless defined $block->{app_statement};

        my $child_keyword = $block->{app_statement}->get_keyword();
        if ( $keyword eq $child_keyword ) {
            $doomed_child = $count;
            last BLOCK;
        }
    }
    continue {
        $count++;
    }

    if ( $doomed_child >= 0 ) {
        # This probably leaks memory because children have parent pointers.
        # But the parent is me and I'm the app_body, so maybe not.
        splice @{ $self->{'block(s?)'} }, $doomed_child, 1;
    }
    # else, nothing to see here, move along quietly

    return [ 1 ];
}

sub add_last_config_statement {
    my $self     = shift;
    my $ident    = shift;
    my $keyword  = shift;
    my $value    = shift;
    my $accessor = shift;

    my $success  = $self->walk_postorder(
        'add_config_statement',
        {
            ident    => $ident,
            keyword  => $keyword,
            value    => $value,
            accessor => $accessor,
        }
    );

    # if there is not a config block, make one and try again
    unless ( defined $success->[0] ) {
        my $statement = app_config_statement->new(
            $keyword,
            $value,
            $accessor,
        );

        my $block = app_config_block->new(
            {
                parent     => $self,
                statements => [ $statement ],
            }
        );

        $statement->{__PARENT__} = $block;

        push @{ $self->{ 'block(s?)' } }, $block;
    }
}

sub add_last_statement {
    my $self          = shift;
    my $keyword       = shift;
    my $value         = shift;

    my @values        = split /\]\[/, $value;
    my $new_statement = block->new_statement( $self, $keyword, \@values );

    my $index         = $self->last_statement_index();

    if ( $index >= 0 ) {
        splice @{ $self->{ 'block(s?)' } }, $index + 1, 0, $new_statement;
    }
    else { # We're so excited, this is our first child!!!
        $self->{ 'block(s?)' } = [ $new_statement ];
    }

    # Untested, but should update the lookup hash, in case anyone cares
    my $lookup = $self->{__PARENT__}->{lookup};

    $lookup->{app_statements}{ $keyword } = arg_list->new( \@values );
}

sub add_last_statement_pair {
    my $self          = shift;
    my $params        = shift;

    my $new_statement = block->new_statement_pair( $self, $params );

    my $index         = $self->last_statement_index();

    if ( $index >= 0 ) {
        splice @{ $self->{ 'block(s?)' } }, $index, 0, $new_statement;
    }
    else { # We're so excited, this is our first child!!!
        $self->{ 'block(s?)' } = [ $new_statement ];
    }

    # Untested, but should update the lookup hash, in case anyone cares
    my $lookup = $self->{__PARENT__}->{lookup};

    $lookup->{app_statements}{ $params->{keyword} } = arg_list->new(
                    $params->{ new_value },
                    $params->{ pair_required },
    );
}

sub last_statement_index {
    my $self = shift;

    my $index = -1;
    my $count = 0;
    foreach my $block ( @{ $self->{ 'block(s?)' } } ) {
        if ( defined $block->{app_statement}
                or
             defined $block->{app_config_block}
        ) {
            $index = $count;
        }
        $count++;
    }

    return $index;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    my %output;

    foreach my $element ( @{ $child_output } ) {
        if ( $element->{__TYPE__} eq 'join_tables' ) {
            my $output_type                  = $element->{__TYPE__};
            my $name                         = $element->{__DATA__}[0];
            push @{ $output{ $output_type }{ $name } },
                 $element->{__DATA__}[1];

            $name                            = $element->{__DATA__}[2];
            push @{ $output{ $output_type }{ $name } },
                 $element->{__DATA__}[3];
        }
        else {
            my $output_type                  = $element->{__TYPE__};
            my $name                         = $element->{__DATA__}[0];
            $output{ $output_type }{ $name } = $element->{__DATA__}[1];
        }

    }

    return [ %output ];
}

package # block
    block;
use strict; use warnings;

use base 'application_ancestor';

sub new_statement {
    my $class   = shift;
    my $parent  = shift;
    my $keyword = shift;
    my $values  = shift;

    my $self = {
        __RULE__      => 'block',
        __PARENT__    => $parent,
    };

    $self->{app_statement} = app_statement->new( $self, $keyword, $values ),

    return bless $self, $class;
}

sub new_statement_pair {
    my $class  = shift;
    my $parent = shift;
    my $params = shift;

    my $self = {
        __RULE__    => 'block',
        __PARENT__  => $parent,
    };

    $self->{app_statement} = app_statement->new_pair( $self, $params );

    return bless $self, $class;
}

my %block_name_for = (
    table      => 'table_block',
    sequence   => 'seq_block',
    controller => 'controller_block',
    literal    => 'literal_block',
    join_table => 'join_table',
    schema     => 'schema_block',
    config     => 'app_config_block',
);

sub new_block {
    my $class  = shift;
    my $parent = shift;
    my $data   = shift;

    my $self   = {
        __RULE__   => 'block',
        __PARENT__ => $parent,
    };

    bless $self, $class;

    my $constructing_class = $block_name_for{ $data->{type} };

    $self->{ $constructing_class } = $constructing_class->new_block(
        $self, $data
    );

    return $self;
}

sub matches {
    my $self  = shift;
    my $ident = shift;

    my @ident_block_types = qw(
            controller_block
            sql_block
            literal_block
            table_block
            seq_block
            schema_block
            join_table
    );

    my @keys = keys %{ $self };

    TYPE:
    foreach my $block_type_name ( @ident_block_types ) {
        next TYPE unless defined $self->{ $block_type_name };
        return 1 if ( $self->{ $block_type_name }{__IDENT__} eq $ident );
    }
}

sub get_ident {
    my $self = shift;

    foreach my $child_block ( keys %{ $self } ) {
        next unless ref $self->{ $child_block };
        return $self->{ $child_block }->get_ident();
    }
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

    foreach my $block_type ( keys %$self ) {
        next unless (
            $block_type =~ /_block$/
                or
            $block_type =~ /_statement$/
                or
            $block_type eq 'join_table'
        );

        my $child_output = $self->{$block_type}->walk_postorder(
            $action, $data, $self
        );

        push @{ $output }, @{ $child_output } if $child_output;
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return $child_output;
}

package # app_statment
    app_statement;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class   = shift;
    my $parent  = shift;
    my $keyword = shift;
    my $values  = shift;

    my $self    = {
        __PARENT__  => $parent,
        __KEYWORD__ => $keyword,
        __ARGS__    => arg_list->new( $values ),
    };

    return bless $self, $class;
}

sub new_pair {
    my $class   = shift;
    my $parent  = shift;
    my $params  = shift;

    my $self    = {
        __PARENT__  => $parent,
        __KEYWORD__ => $params->{ keyword },
        __ARGS__    => arg_list->new(
                $params->{ new_value },
                $params->{ pair_required },
        ),
    };

    return bless $self, $class;
}

sub get_keyword {
    my $self = shift;

    return $self->{__KEYWORD__};
}

sub set_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $data->{keyword} eq $self->{__KEYWORD__} );

    $self->{__ARGS__}->set_args_from( $data->{value}, $data->{pair_required} );

    return [ 1 ];
}

sub set_statement_pairs {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $data->{keyword} eq $self->{__KEYWORD__} );

    $self->{__ARGS__}->set_args_from(
            $data->{new_value},
            $data->{pair_required},
    );

    return [ 1 ];
}

sub get_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $data eq $self->{__KEYWORD__} );

    return $self->{__ARGS__}->get_unquoted_args;

}

sub output_location {
    my $self = shift;

    return unless $self->{__KEYWORD__} eq 'location';

    my $location = $self->{__ARGS__}[0];

    return [ $location ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [
        {
            '__TYPE__' => 'app_statements',
            '__DATA__' => [
                $self->{__KEYWORD__} => $self->{__ARGS__}
            ]
        }
    ];
}

package # literal_block
     literal_block;
use strict; use warnings;

use base 'application_ancestor';

sub new_block {
    my $class  = shift;
    my $parent = shift;
    my $data   = shift;

    my $self = {
        __PARENT__      => $parent,
        __IDENT__       => Bigtop::Parser->get_ident(),
        __BACKEND__     => $data->{name} || 'None',
        __BODY__        => '',
    };

    return bless $self, $class;
}

sub set_type {
    my $self     = shift;
    my $new_type = shift;

    $self->{__BACKEND__} = $new_type;
}

sub set_value {
    my $self      = shift;
    my $new_value = shift;

    $self->{__BODY__} = $new_value;
}

sub change_type {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->get_ident eq $data->{ident} );

    $self->set_type( $data->{new_type} );

    return [ 1 ];
}

sub change_literal {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->get_ident eq $data->{ident} );

    $self->set_value( $data->{new_value} );

    return;
}

sub app_block_hashes {
    my $self         = shift;

    return [ {
        ident     => $self->get_ident,
        type      => 'literal',
        keyword   => $self->{__BACKEND__},
        value     => $self->{__BODY__},
    } ];
}

sub get_ident {
    my $self = shift;
    return $self->{__IDENT__};
}

sub get_backend {
    my $self = shift;

    return $self->{__BACKEND__};
}

sub show_idents {
    my $self         = shift;
    my $child_output = shift;

    push @{ $child_output },
            [ 'literal', $self->{ __NAME__ }, $self->{ __IDENT__ } ];

    return $child_output;
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub make_output {
    my $self      = shift;
    my $backend   = shift;
    my $want_hash = shift;

    if ( $backend eq $self->{__BACKEND__} ) {
        my $output = $self->{__BODY__};

        $output    =~ s/\Z/\n/ if ( $output !~ /\s\Z/ );

        return $want_hash ? [ { $backend => $output } ] : [ $output ];
    }
    else {
        return;
    }
}

package # table_block
    table_block;
use strict; use warnings;

use base 'application_ancestor';

use Bigtop::ScriptHelp;

sub new_block {
    my $class  = shift;
    my $parent = shift;
    my $data   = shift;

    my $self = {
        __IDENT__ => Bigtop::Parser->get_ident(),
        __NAME__  => $data->{name},
        __TYPE__  => 'tables',
        __BODY__  => [],
    };

    bless $self, $class;

    if ( defined $data->{ columns } ) {
        $self->_create_these_fields( $data->{ columns } );
    }
    else {
        $self->_create_default_fields();
    }

    if ( defined $data->{sequence} ) {
        my $seq_stmnt = table_element_block->new_statement(
            $self,
            'sequence',
            $data->{sequence},
        );
        push @{ $self->{__BODY__} }, $seq_stmnt;
    }

    $self->{__PARENT__} = $parent;

    return $self;
}

sub _create_default_fields {
    my $self = shift;

    my $id_field = table_element_block->new_field(
        $self, 'id'
    );

    $id_field->add_field_statement(
        {
            ident     => $id_field->get_ident,
            keyword   => 'is',
            new_value => 'int4][primary_key][auto',
        },
    );

    push @{ $self->{__BODY__} }, $id_field;

    my %values = (
        is             => 'varchar',
        html_form_type => 'text'
    );

    foreach my $field_name qw( ident description ) {

        $values{ label } = Bigtop::ScriptHelp->default_label( $field_name );

        my $field = table_element_block->new_field(
            $self, $field_name
        );

        foreach my $statement qw( is label html_form_type ) {
            $field->add_field_statement(
                {
                    ident     => $field->get_ident,
                    keyword   => $statement,
                    new_value => $values{ $statement },
                },
            );
        }
        push @{ $self->{__BODY__} }, $field;
    }

    foreach my $date_field qw( created modified ) {
        my $field = table_element_block->new_field(
                $self, $date_field
        );
        $field->add_field_statement(
            {
                ident     => $field->get_ident,
                keyword   => 'is',
                new_value => 'datetime',
            },
        );
        push @{ $self->{__BODY__} }, $field;
    }
}

sub _create_these_fields {
    my $self   = shift;
    my $fields = shift;

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

    foreach my $init_field ( @{ $fields } ) {

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

        my $type_string = join '][', @{ $init_field->{ types } };

        my $field = table_element_block->new_field(
            $self, $init_field->{ name }
        );

        $field->add_field_statement(
            {
                ident     => $field->get_ident,
                keyword   => 'is',
                new_value => $type_string,
            },
        );

        unless ( $non_entry{ $init_field->{ name } } ) {

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

            $field->add_field_statement(
                {
                    ident     => $field->get_ident,
                    keyword   => 'label',
                    new_value => $label,
                },
            );

            $field->add_field_statement(
                {
                    ident     => $field->get_ident,
                    keyword   => 'html_form_type',
                    new_value => 'text',
                },
            );

            if ( defined $init_field->{ optional } ) {
                $field->add_field_statement(
                    {
                        ident     => $field->get_ident,
                        keyword   => 'html_form_optional',
                        new_value => $init_field->{ optional },
                    },
                );
            }
            if ( $init_field->{ default } ) {
                $field->add_field_statement(
                    {
                        ident     => $field->get_ident,
                        keyword   => 'html_form_default_value',
                        new_value => $init_field->{ default },
                    },
                );
            }
        }

        push @{ $self->{__BODY__} }, $field;
    }
}

sub add_subblock {
    my $self   = shift;
    shift;
    my $data = shift;

    return unless ( $data->{parent}{type}    eq 'table'          );
    return unless ( $data->{parent}{ident}   eq $self->get_ident );
    return unless ( $data->{new_child}{type} eq 'field'          );

    my $new_field = table_element_block->new_field(
            $self, $data->{new_child}{name}
    );

    push @{ $self->{__BODY__} }, $new_field;

    return [ $new_field ];
}

sub remove_block {
    my $self         = shift;
    shift;
    my $data         = shift;
    my $doomed_ident = $data->{ ident };

    my $doomed_index = -1;
    my $count        = 0;

    my $children     = $self->{__BODY__};

    CHILD:
    foreach my $child ( @{ $children } ) {
        my $child_ident = $child->get_ident;

        next CHILD unless defined $child_ident;

        if ( $child_ident eq $doomed_ident ) {
            $doomed_index = $count;
        }
    }
    continue {
        $count++;
    }

    return if ( $doomed_index == -1 );

    my $deceased = splice @{ $children }, $doomed_index, 1;

    # do things if the we get this far
    my @retval;

    # remove name from foreign_display as needed
    my $result = $self->walk_postorder(
            'update_foreign_display',
            {
                old_value => $deceased->{__NAME__},
                new_value => '',
                ident     => $self->{__IDENT__},
            }
    );

    push @retval, @{ $result } if ( ref( $result ) eq 'ARRAY' );

    # remove from controller form fields or all_fields_but
    # remove from controller cols (and col_labels)

    my $tree = $data->{ __THE_TREE__ };

    $result = $tree->walk_postorder( 'field_removed', 
        {
            table_name      => $self->get_name(),
            dead_field_name => $deceased->{__NAME__},
        }
    );

    push @retval, @{ $result } if ( ref( $result ) eq 'ARRAY' );

    return \@retval;
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    my $body = {
        statements => {},
        fields     => [],
    };

    foreach my $child_item ( @{ $child_output } ) {
        if ( $child_item->{ type } eq 'statement' ) {
            if ( $child_item->{ keyword } eq 'data' ) {
                push @{ $body->{ statements }{ data } },
                     $child_item->{ value };
            }
            else {
                $body->{ statements }{ $child_item->{ keyword } } =
                        $child_item->{ value };
            }
        }
        else {
            push @{ $body->{ fields } }, $child_item;
        }
    }

    return [ {
        type  => 'table',
        body  => $body,
        name  => $self->get_name,
        ident => $self->get_ident,
    } ];
}

sub change_name_table {
    my $self   = shift;
    shift;
    my $data = shift;

    return unless $self->get_ident  eq $data->{ident};

    my $old_name = $self->get_name();
    $self->set_name( $data->{new_value} );

    return $data->{__THE_TREE__}->walk_postorder( 'table_name_changed',
        {
            old_name => $old_name,
            new_name => $data->{ new_value }
        }
    );
}

sub get_ident {
    my $self = shift;

    return $self->{__IDENT__};
}

sub get_name {
    my $self = shift;

    return $self->{__NAME__};
}

sub all_table_names {
    my $self = shift;

    return [ $self->{__NAME__} ];
}

sub set_name {
    my $self     = shift;
    my $new_name = shift;

    $self->{__NAME__} = $new_name;

    # update lookup hash?
}

sub show_idents {
    my $self = shift;
    my $child_output = shift;

    push @{ $child_output },
            [ $self->{ __TYPE__ }, $self->{ __NAME__ }, $self->{ __IDENT__ } ];

    return $child_output;
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

    foreach my $body_element ( @{ $self->{__BODY__} } ) {
        my $child_output = $body_element->walk_postorder(
            $action, $data, $self
        );

        push @{ $output }, @{ $child_output } if $child_output;
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    my %output;

    foreach my $element ( @{ $child_output } ) {
        my $output_type                  = $element->{__TYPE__};

        my $name                         = $element->{__DATA__}[0];

        if ( $output_type eq 'data' ) {
            push @{ $output{ data }{ $name } }, $element->{__DATA__}[1];
        }
        else {
            $output{ $output_type }{ $name } = $element->{__DATA__}[1];
        }
    }

    $output{ __IDENT__ } = $self->{ __IDENT__ };

    my $retval = [ 
        {
            __TYPE__ => $self->{__TYPE__},
            __DATA__ => [ $self->get_name() => \%output ],
        }
    ];

    return [ 
        {
            __TYPE__ => $self->{__TYPE__},
            __DATA__ => [ $self->get_name() => \%output ],
        }
    ];
}

sub change_table_statement {
    my $self         = shift;
    shift;
    my $data         = shift;

    return unless ( $self->{__TYPE__} eq 'tables'       );
    return unless ( $self->get_ident  eq $data->{ident} );

    my $success = $self->walk_postorder( 'change_table_keyword_value', $data );

    unless ( defined $success->[0] ) { # make new statement
        $self->add_table_statement( $data );
    }

    return [ 1 ];
}

sub add_table_statement {
    my $self = shift;
    my $data = shift;

    my $new_statement = table_element_block->new_statement(
        $self,
        $data->{keyword},
        $data->{new_value},
    );

    my $blocks = $self->{ __BODY__ };
    push @{ $blocks }, $new_statement;
}

sub remove_table_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->{__TYPE__} eq 'tables'       );
    return unless ( $self->get_ident  eq $data->{ident} );

    my $doomed_child = -1;
    my $count        = 0;

    BLOCK:
    foreach my $block ( @{ $self->{__BODY__} } ) {
        next BLOCK unless $block->{__TYPE__} eq $data->{keyword};

        $doomed_child = $count;
        last BLOCK;
    }
    continue {
        $count++;
    }

    if ( $doomed_child >= 0 ) {
        # This probably leaks memory because children have parent pointers.
        # But the parent is me and I'm the app_body, so maybe not.
        splice @{ $self->{__BODY__} },
                $doomed_child,
                1;
    }
    # else, nothing to see here, move along quietly

    return [ 1 ];
}

sub change_data_statement {
    my $self           = shift;
    my $child_output   = shift;
    my $data           = shift;

    return unless ( $self->{__IDENT__} eq $data->{ table } );

    my %field_names    = @{ $self->walk_postorder( 'get_field_names' ) };
    my $name_to_change = $field_names{ $data->{ field } };

    my $target         = $child_output->[ $data->{ st_number } - 1 ];

    if ( defined $target ) {
        my $found      = 0;
        my $remove_it  = -1;
        my $count      = -1;
        ARG:
        foreach my $arg ( @{ $target->{__ARGS__} } ) {
            $count++;

            next unless defined $arg->{ $name_to_change };

            if ( defined $data->{ value } ) {
                $arg->{ $name_to_change } = $data->{ value };
                $found++;
                last ARG;
            }
            else {
                $remove_it = $count;
            }
        }
        if ( $remove_it >= 0 ) {
            splice @{ $target->{__ARGS__} }, $remove_it, 1;

            if ( @{ $target->{__ARGS__} } == 0 ) { # no more keys, kill it
                my $doomed_child = -1;
                my $count        = -1;
                CHILD:
                foreach my $child ( @{ $self->{__BODY__} } ) {
                    $count++;
                    if ( $child eq $target ) {
                        $doomed_child = $count;
                        last CHILD;
                    }
                }
                if ( $doomed_child >= 0 ) {
                    splice @{ $self->{__BODY__} }, $doomed_child, 1;
                }
            }
        }
        elsif ( not $found ) {
            push @{ $target->{__ARGS__} },
                 { $name_to_change => $data->{ value } };
        }
    }
    else {
        $self->add_table_statement(
            {
                ident     => $self->get_ident,
                keyword   => 'data',
                new_value => {
                    keys   => $name_to_change,
                    values => $data->{value},
                }
            },
        );
    }

    return $self->walk_postorder( 'app_block_hashes' );
}

sub table_reset_bool {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->{ __IDENT__} eq $data->{ ident };

    return $self->walk_postorder( 'field_reset_bool', $data );
}

sub get_table_statement {
    my $self         = shift;
    shift;
    my $data         = shift;

    return unless ( $self->{__TYPE__} eq 'tables'       );
    return unless ( $self->get_ident  eq $data->{ident} );

    BLOCK:
    foreach my $block ( @{ $self->{__BODY__} } ) {
        next BLOCK unless $block->{__TYPE__} eq $data->{keyword};

        return [ $block->{__ARGS__}->get_unquoted_args ];
    }

    return;
}

package # seq_block
    seq_block;
use strict; use warnings;

use base 'application_ancestor';

sub new_block {
    my $class  = shift;
    my $parent = shift;
    my $data   = shift;

    my $self = {
        __IDENT__  => Bigtop::Parser->get_ident(),
        __NAME__   => $data->{name},
        __TYPE__   => 'sequences',
        __BODY__   => [],
        __PARENT__ => $parent,
    };

    return bless $self, $class;
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    return [ {
        type  => 'sequence',
        body  => undef,
        name  => $self->get_name,
        ident => $self->get_ident,
    } ];
}

sub get_ident {
    my $self = shift;

    return $self->{__IDENT__};
}

sub get_name {
    my $self = shift;

    return $self->{__NAME__};
}

sub set_name {
    my $self     = shift;
    my $new_name = shift;

    $self->{__NAME__} = $new_name;

    # update lookup hash?
}

sub change_name_sequence {
    my $self   = shift;
    shift;
    my $params = shift;

    return unless $self->get_ident  eq $params->{ident};

    $self->set_name( $params->{new_value} );

    return [ 1 ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

# This might be needed if sequence blocks ever have statements.
#
#    foreach my $seq_statement ( @{ $self->{__BODY__} } ) {
#        my $child_output = $seq_statement->walk_postorder(
#            $action, $data, $self
#        );
#
#        push @{ $output }, @{ $child_output } if $child_output;
#    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [
        {
            __TYPE__ => $self->{__TYPE__},
            __DATA__ => [ $self->{__NAME__} => $self->{__IDENT__} ],
        }
    ];
}

sub show_idents {
    my $self = shift;

    return [ $self->{ __TYPE__ }, $self->{ __NAME__ }, $self->{ __IDENT__ } ];
}

package # schema_block
    schema_block;
use strict; use warnings;

use base 'application_ancestor';

sub new_block {
    my $class  = shift;
    my $parent = shift;
    my $data   = shift;

    my $self = {
        __IDENT__  => Bigtop::Parser->get_ident(),
        __NAME__   => $data->{name},
        __PARENT__ => $parent,
    };

    return bless $self, $class;
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    return [ {
        type  => 'schema',
        body  => undef,
        name  => $self->get_name,
        ident => $self->get_ident,
    } ];
}

sub get_ident {
    my $self = shift;

    return $self->{__IDENT__};
}

sub set_name {
    my $self     = shift;
    my $new_name = shift;

    $self->{__NAME__} = $new_name;
}

sub get_name {
    my $self = shift;

    return $self->{__NAME__};
}

sub change_name_schema {
    my $self   = shift;
    shift;
    my $params = shift;

    return unless $self->get_ident  eq $params->{ident};

    $self->set_name( $params->{new_value} );

    return [ 1 ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self = shift;

    return [
        {
            __TYPE__ => 'schema',
            __DATA__ => [ $self->{__NAME__} => $self->{__IDENT__} ],
        }
    ];
}

sub show_idents {
    my $self = shift;

    return [ 'schema', $self->{__NAME__}, $self->{__IDENT__} ];
}

package # sequence_statement
    sequence_statement;
use strict; use warnings;

use base 'application_ancestor';

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [ 
        {
            '__TYPE__' => 'sequences',
            '__DATA__' => [
                $self->{__NAME__} => $self->{__ARGS__},
            ]
        }
    ];
}

package # table_element_block
    table_element_block;
use strict; use warnings;

use base 'application_ancestor';

sub new_statement {
    my $class   = shift;
    my $parent  = shift;
    my $keyword = shift;
    my $values  = shift;

    my $self    = {
        __PARENT__ => $parent,
        __BODY__   => $keyword,
        __TYPE__   => $keyword,
        __ARGS__   => arg_list->new( $values ),
    };

    return bless $self, $class;
}

sub new_field {
    my $class  = shift;
    my $parent = shift;
    my $name   = shift;

    my $self   = {
        __PARENT__ => $parent,
        __TYPE__   => 'field',
        __IDENT__  => Bigtop::Parser->get_ident(),
        __NAME__   => $name,
        __BODY__   => [],
    };

    return bless $self, $class;
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    my %statements;

    foreach my $child_item ( @{ $child_output } ) {
        $statements{ $child_item->{ keyword } } = $child_item->{ values };
    }

    if ( $self->{__TYPE__} eq 'field' ) {
        return [ {
            type       => 'field',
            name       => $self->get_name,
            ident      => $self->get_ident,
            statements => \%statements,
        } ];
    }
    else {
        return [ {
            ident     => $self->get_ident,
            type      => 'statement',
            keyword   => $self->{__BODY__},
            value     => $self->{__ARGS__},
        } ];
    }
}

sub get_name {
    my $self = shift;

    return $self->{__NAME__};
}

sub all_field_names {
    my $self          = shift;
    shift;
    my $desired_table = shift;

    return unless ( $self->get_table_name eq $desired_table );

    return [ $self->get_name ];
}

sub set_name {
    my $self     = shift;
    my $new_name = shift;

    $self->{__NAME__} = $new_name;
}

sub get_ident {
    my $self = shift;

    return $self->{__IDENT__};
}

sub get_table_name {
    my $self = shift;

    # does this still work for join_tables?
    return $self->{__PARENT__}{__NAME__};
}

sub get_table_ident {
    my $self = shift;

    return $self->{__PARENT__}{__IDENT__};
}

sub show_idents {
    my $self = shift;
    my $child_output = shift;

    return unless $self->{ __TYPE__ } eq 'field';

    push @{ $child_output },
            [ 'field', $self->{ __NAME__ }, $self->{ __IDENT__ } ];

    return $child_output;
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output;

    if ( $self->{__TYPE__} eq 'field' ) {
        foreach my $field_stmnt ( @{ $self->{__BODY__} } ) {
            my $child_output = $field_stmnt->walk_postorder(
                $action, $data, $self
            );
 
            push @{ $output }, @{ $child_output } if $child_output;
        }
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    my %output;

    if ( $child_output ) {
        my %sub_output;

        foreach my $element ( @{ $child_output } ) {
            my $output_type                      = $element->{__TYPE__};

            my $name                             = $element->{__DATA__}[0];

            $sub_output{ $output_type }{ $name } = $element->{__DATA__}[1];
        }

        $sub_output{ __IDENT__ } = $self->{ __IDENT__ };

        %output = (
            '__TYPE__' => 'fields',
            '__DATA__' => [
                $self->{__NAME__} => \%sub_output,
            ],
        );
    }
    # for non-field statements
    else {
        %output = (
            '__TYPE__' => $self->{__BODY__},
            '__DATA__' => [
                __ARGS__ => $self->{__ARGS__},
            ],
        );
    }

    return [ \%output ];
}

sub change_table_keyword_value {
    my $self = shift;
    shift;
    my $data = shift;

    return if ( defined $self->get_name ); # only fields have names

    return unless ( $self->{__BODY__} eq $data->{keyword} );

    $self->{__ARGS__}->set_args_from(
            $data->{new_value},
            $data->{pair_required},
    );

    return [ 1 ];
}

sub change_field_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->{__TYPE__}     eq 'field'        );
    return unless ( $self->get_ident      eq $data->{ident} );

    my $success = $self->walk_postorder( 'change_field_keyword_value', $data );

    unless ( defined $success->[0] ) { # make new statement

        $success = [ $self->add_field_statement( $data ) ];
    }

    # This array needs to be two levels deep.
    return [ $success ];
}

sub get_field_statement {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return unless ( $self->{__TYPE__}     eq 'field'        );
    return unless ( $self->get_ident      eq $data->{ident} );

    return $child_output;
}

sub add_field_statement {
    my $self = shift;
    my $data = shift;

    my $new_statement = field_statement->new_statement(
        {
            parent        => $self,
            keyword       => $data->{keyword},
            new_value     => $data->{new_value},
            pair_required => $data->{pair_required} || 0,
        }
    );

    my $blocks = $self->{ __BODY__ };
    push @{ $blocks }, $new_statement;

    if ( $data->{ keyword } eq 'is' ) {
        my %values = map { $_ => 1 } split /\]\[/, $data->{ new_value };
        return 'date' if ( $values{ date } );
    }
    elsif ( $data->{ keyword } eq 'date_select_text' ) {
        return 'date_select_text';
    }

    return 1;
}

sub remove_field_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->{__TYPE__}     eq 'field'        );
    return unless ( $self->get_ident      eq $data->{ident} );

    my $statements   = $self->{ __BODY__ };
    my $doomed_index = get_statement_index( $statements, $data->{keyword} );

    if ( $doomed_index >= 0 ) {
        splice @{ $statements }, $doomed_index, 1;
        return [ 1 ];
    }
    else {
        return [ 0 ];
    }
}

sub get_statement_index {
    my $statements   = shift;
    my $target_name  = shift;

    my $target_index = -1;
    my $count        = 0;

    STATEMENT:
    foreach my $statement ( @{ $statements } ) {
        if ( $statement->get_name eq $target_name ) {
            $target_index = $count;
            last STATEMENT;
        }
    }
    continue {
        $count++;
    }

    return $target_index;
}

sub change_name_field {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( defined $self->get_ident ); # only fields can change names

    return unless $self->get_ident eq $data->{ident};

    my @retval;

    my $old_name = $self->get_name(); # who were we fka
    $self->set_name( $data->{ new_value } );

    # update our label, if the old one was the default label
    my $result = $self->walk_postorder( 'update_label',
            { old_name => $old_name, new_name => $data->{ new_value } }
    );

    push @retval, @{ $result } if ( ref( $result ) eq 'ARRAY' );

    $data->{ old_value } = $old_name;
    $result = $self->{ __PARENT__ }->walk_postorder(
            'update_foreign_display', $data
    );

    push @retval, @{ $result } if ( ref( $result ) eq 'ARRAY' );

    my $tree = $data->{ __THE_TREE__ };

    $result = $tree->walk_postorder( 'field_name_changed', 
        {
            table_name     => $self->get_table_name(),
            old_field_name => $old_name,
            new_field_name => $data->{ new_value },
        }
    );

    push @retval, @{ $result } if ( ref( $result ) eq 'ARRAY' );

    return \@retval;
}

sub change_data_statement {
    my $self         = shift;
    shift;
    my $data         = shift;

    return if     ( defined $self->{__IDENT__}  );
    return unless ( $self->{__TYPE__} eq 'data' );

    return [ $self ];
}

sub get_field_names {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( defined $self->{__IDENT__} );

    return [ $self->{__IDENT__} => $self->{__NAME__} ];
}

# if a renamed field is in foreign_display, update it
sub update_foreign_display {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->{ __TYPE__ } eq 'foreign_display';

    my $display     = $self->{ __ARGS__ }->get_first_arg;
    my $old_display = $display;

    if ( $data->{ new_value } ) {
        $display        =~ s/%$data->{ old_value }/%$data->{ new_value }/g;
    }
    else {
        $display        =~ s/%$data->{ old_value }//g;
    }

    if ( $display =~ /^\s*$/ ) {
        $display = '';
        $self->{__PARENT__}->remove_table_statement(
                undef,
                {
                    ident   => $data->{ ident },
                    keyword => 'foreign_display',
                }
        );
    }
    else {
        $self->{ __ARGS__ }->set_args_from( $display );
    }

    if ( $display eq $old_display ) {
        return;
    }
    else {
        return [ $self->get_table_ident() . '::foreign_display' => $display ];
    }
}

sub get_table_name_from_field_ident {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->{ __TYPE__  } eq 'field';
    return unless $self->{ __IDENT__ } eq $data->{ ident };

    return [ $self->get_table_name ];
}

sub field_reset_bool {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return unless $self->{ __TYPE__ } eq 'field';
    return if $self->{ __NAME__ } eq 'id';

    unless ( $child_output->[0] ) {
        $self->add_field_statement(
            {
                keyword       => $data->{keyword},
                new_value     => $data->{new_value},
            }
        );
    }

    return [ $self->{ __IDENT__ } ];
}

package # field_statement
    field_statement;
use strict; use warnings;

use base 'application_ancestor';

sub new_statement {
    my $class   = shift;
    my $params  = shift;

    my $self = {
        __PARENT__  => $params->{ parent },
        __KEYWORD__ => $params->{ keyword },
        __DEF__     => field_statement_def->new(
            $params->{ new_value },
            $params->{ pair_required },
        ),
    };

    $self->{__DEF__}{__PARENT__} = $self;

    return bless $self, $class;
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    return [ {
        keyword => $self->get_name,
        values  => $self->get_values,
    } ];
}

sub get_table_name {
    my $self = shift;

    #       table_elemnt_block table_block
    return $self->{__PARENT__}{__PARENT__}{__NAME__};
}

sub get_field_ident {
    my $self = shift;

    return $self->{__PARENT__}{__IDENT__};
}

sub get_field_name {
    my $self = shift;

    return $self->{__PARENT__}{__NAME__};
}

sub get_name {
    my $self = shift;

    return $self->{__KEYWORD__};
}

sub get_values {
    my $self = shift;

    return $self->{__DEF__}{__ARGS__};
}

sub change_field_keyword_value {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $data->{type}         eq 'field'          );
    return unless ( $self->{__KEYWORD__}  eq $data->{keyword} );

    $self->{__DEF__}{__ARGS__}->set_args_from(
            $data->{new_value},
            $data->{pair_required},
    );

    # see if we changed the SQL type to date
    my %values = map { $_ => 1 } split /\]\[/, $data->{ new_value };
    if ( $data->{ keyword } eq 'is' and $values{ date } ) {
        return [ 'date' ];
    }
    elsif ( $data->{ keyword } eq 'date_select_text'
                and
            $data->{ new_value } )
    {
        return [ 'date_select_text' ];
    }

    return [ 1 ];
}

sub get_field_statement {
    my $self         = shift;
    shift;
    my $data         = shift;

    return unless ( $data->{ keyword } eq $self->{ __KEYWORD__ } );

    return [ $self->{ __DEF__ }{ __ARGS__ } ];
}

# If the old label was the default, the label will be changed to default
# for new name.
sub update_label {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return unless $self->{ __KEYWORD__ } eq 'label';

    my $field_ident = $self->get_field_ident();

    my $old_label         = $child_output->[0];
    my $old_default_label = Bigtop::ScriptHelp->default_label(
            $data->{ old_name }
    );

    if ( $old_label eq $old_default_label ) {
        my $new_label = Bigtop::ScriptHelp->default_label(
                $data->{ new_name }
        );
        $self->{__DEF__}{__ARGS__}->set_args_from( $new_label );

        return [ $field_ident . '::label' => $new_label ];
    }

    return;
}

sub table_name_changed {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->{ __KEYWORD__ } eq 'refers_to';

    my $current_foreigner = $self->{ __DEF__ }{ __ARGS__ }->get_first_arg;

    if ( $current_foreigner eq $data->{ old_name } ) {
        $self->{ __DEF__}{ __ARGS__ }->set_args_from( $data->{ new_name } );

        return [ $self->get_field_ident . '::refers_to', $data->{ new_name } ];
    }

    return;
}

sub field_reset_bool {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->{ __KEYWORD__ } eq $data->{ keyword };

    $self->{ __DEF__ }{ __ARGS__ }[0] = $data->{ new_value };

    return [ 1 ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output;
    
    if ( $self->{__DEF__}->can( 'walk_postorder' ) ) {
        $output = $self->{__DEF__}->walk_postorder( $action, $data, $self );
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [ 
        {
            '__TYPE__' => $self->{__KEYWORD__},
            '__DATA__' => [ @{ $child_output } ],
        }
    ];
}

package # field_statement_def
    field_statement_def;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class         = shift;
    my $values        = shift;
    my $pair_required = shift;

    my $self   = {
        __ARGS__ => arg_list->new( $values, $pair_required ),
    };

    return bless $self, $class;
}

sub update_label {
    my $self = shift;

    return [ $self->{ __ARGS__ }->get_first_arg ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [ 'args' => $self->{__ARGS__} ];
}

package # extra_sql_block
    extra_sql_block;
use strict; use warnings;

use base 'application_ancestor';

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output;

    # if we add more extra_sql types, we might need this:
    #if ( $self->{__TYPE__} eq 'extra_sql' ) {
    foreach my $stmnt ( @{ $self->{__BODY__} } ) {
        my $child_output = $stmnt->walk_postorder(
            $action, $data, $self
        );
 
        push @{ $output }, @{ $child_output } if $child_output;
    }
    #}

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    my %output;

    if ( $child_output ) {
        my %sub_output;

        foreach my $element ( @{ $child_output } ) {
            my $output_type                      = $element->{__TYPE__};
            my $name                             = $element->{__DATA__}[0];
            $sub_output{ $output_type }{ $name } = $element->{__DATA__}[1];
        }

        $sub_output{ __IDENT__ } = $self->{ __IDENT__ };

        %output = (
            '__TYPE__' => 'extra_sqls',
            '__DATA__' => [
                $self->{__NAME__} => \%sub_output,
            ],
        );
    }
    return [ \%output ];
}

package # extra_sql_statement
    extra_sql_statement;
use strict; use warnings;

use base 'application_ancestor';

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output;
    
    if ( $self->{__DEF__}->can( 'walk_postorder' ) ) {
        $output = $self->{__DEF__}->walk_postorder( $action, $data, $self );
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [ 
        {
            '__TYPE__' => $self->{__KEYWORD__},
            '__DATA__' => [ @{ $child_output } ],
        }
    ];
}

package # extra_sql_statement_def
    extra_sql_statement_def;
use strict; use warnings;

use base 'application_ancestor';

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [ 'args' => $self->{__ARGS__} ];
}

package # join_table
    join_table;
use strict; use warnings;

use base 'application_ancestor';

sub new_block {
    my $class  = shift;
    my $parent = shift;
    my $data   = shift;

    my $self;

    $self = {
        __IDENT__       => Bigtop::Parser->get_ident(),
        __NAME__        => $data->{name},
        __BODY__        => [],
    };

    $self->{__PARENT__} = $parent;

    return bless $self, $class;
}

sub change_join_table_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->get_ident      eq $data->{ident} );

    my $success = $self->walk_postorder(
            'change_join_table_statement_value', $data
    );

    unless ( defined $success->[0] ) { # make new statement

        $self->add_join_table_statement( $data );
    }

    return [ 1 ];
}

sub add_join_table_statement {
    my $self = shift;
    my $data = shift;

    my $new_statement = join_table_statement->new(
        $self, $data->{ keyword }, $data->{ new_value },
    );

    my $blocks = $self->{ __BODY__ };
    push @{ $blocks }, $new_statement;
}

sub remove_join_table_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->get_ident   eq $data->{ident} );

    my $doomed_child = -1;
    my $count        = 0;

    my $blocks = $self->{__BODY__};

    BLOCK:
    foreach my $block ( @{ $blocks } ) {
        next BLOCK unless $block->{__KEYWORD__} eq $data->{keyword};

        $doomed_child = $count;
        last BLOCK;
    }
    continue {
        $count++;
    }

    if ( $doomed_child >= 0 ) {
        splice @{ $blocks }, $doomed_child, 1;
    }
    # else, nothing to see here, move along quietly

    return [ 1 ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

    foreach my $field_stmnt ( @{ $self->{__BODY__} } ) {
        my $child_output = $field_stmnt->walk_postorder(
            $action, $data, $self
        );

        push @{ $output }, @{ $child_output } if $child_output;
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    my %child_hash;

    while ( my $output_type = shift @{ $child_output } ) {
        my $hash = shift @{ $child_output };

        if ( $output_type ne 'data' ) {
            if ( defined $child_hash{ $output_type } ) {
                die "join_table $self->{__NAME__} has multiple "
                    .   "$output_type statement.\n";
            }
            $child_hash{ $output_type } = $hash;
        }
    }

    if ( not defined $child_hash{ joins } ) {
        die "join_table $self->{__NAME__} has no joins statement.\n";
    }

    my ( $table1, $table2 ) = %{ $child_hash{ joins } };

    my ( $name1,  $name2  );
    if ( defined $child_hash{ names } ) {
        ( $name1, $name2 ) = %{ $child_hash{ names } };
    }
    else {
        ( $name1, $name2 ) = ( "${table1}s", "${table2}s" );
    }

    return [
        {
            '__TYPE__' => 'join_tables',
            '__DATA__' => [
                $table1 => {
                    joins => { $table2 => $self->{__NAME__} },
                    name  => $name2,
                },
                $table2 => {
                    joins => { $table1 => $self->{__NAME__} },
                    name  => $name1,
                },
                __IDENT__ => $self->{ __IDENT__ },
            ],
        }
    ];
}

sub get_ident {
    my $self = shift;
    return $self->{__IDENT__};
}

sub show_idents {
    my $self = shift;
    my $child_output = shift;

    push @{ $child_output },
            [ 'join_table', $self->{ __NAME__ }, $self->{ __IDENT__ } ];

    return $child_output;
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    my $body = {
        statements => {},
    };

    foreach my $child_item ( @{ $child_output } ) {
        $body->{ statements }{ $child_item->{ keyword } } =
            $child_item->{ value };
    }

    return [ {
        ident           => $self->get_ident,
        type            => 'join_table',
        body            => $body,
        name            => $self->{__NAME__},
    } ];
}

package # join_table_statement
    join_table_statement;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class   = shift;
    my $parent  = shift;
    my $keyword = shift;
    my $values  = shift;

    my $self    = {
        __PARENT__  => $parent,
        __KEYWORD__ => $keyword,
        __DEF__     => arg_list->new( $values ),
    };

    return bless $self, $class;
}

sub change_join_table_statement_value {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->{__KEYWORD__} eq $data->{keyword} );

    $self->{__DEF__}->set_args_from(
            $data->{new_value},
            $data->{pair_required},
    );

    return [ 1 ];
}

sub get_join_table_name {
    my $self = shift;

    return $self->{ __PARENT__ }{ __NAME__ };
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [ $self->{__KEYWORD__} => $self->{__DEF__}->get_first_arg() ];
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    return [ { keyword => $self->{__KEYWORD__}, value => $self->{__DEF__} } ];
}

package # controller_block
    controller_block;
use strict; use warnings;

use base 'application_ancestor';

sub new_block {
    my $class  = shift;
    my $parent = shift;
    my $data   = shift;

    my $self = {
        __IDENT__  => Bigtop::Parser->get_ident(),
        __NAME__   => $data->{name},
        __TYPE__   => $data->{subtype},
        __BODY__   => []
    };

    $self->{__PARENT__} = $parent;

    bless $self, $class;

    # if we were given a table name, use it and do other nice things
    if ( $data->{ table } ) {
        $self->add_controller_statement(
            { keyword   => 'controls_table',
              new_value => $data->{ table },
            }
        );
        $self->add_controller_statement(
            { keyword   => 'rel_location',
              new_value => $data->{ rel_loc } || $data->{ table },
            }
        );
        $self->add_controller_statement(
            { keyword   => 'text_description',
              new_value => $data->{ text_description } || $data->{ table },
            }
        );
        $self->add_controller_statement(
            { keyword   => 'page_link_label',
              new_value => $data->{ page_link_label } || $data->{ name },
            }
        );
    }

    # now add some clever defaults if we're a CRUD or AutoCRUD
    if ( defined $data->{ subtype }
            and
         $data->{ subtype } =~ /CRUD/
    ) {
        my $table_name = $data->{ table } || lc $data->{name};

        # make the do_main method
        my $cols     = $data->{ on_main_listing } || 'ident, description';
        $cols        =~ s/, /][/g;

        my $main_arr = $self->add_subblock(
            undef,
            {
                parent => {
                    type => 'controller',
                    ident => $self->get_ident,
                },
                new_child => {
                    type     => 'method',
                    sub_type => 'main_listing',
                    name     => 'do_main',
                },
            }
        );
        my $do_main = $main_arr->[0];
        my %values  = (
            cols           => $cols,
            header_options => 'Add',
            row_options    => 'Edit][Delete',
            title          => $data->{ page_link_label } || $self->{__NAME__},
        );

        foreach my $statement qw( cols header_options row_options title ) {
            $do_main->add_method_statement( {
                keyword   => $statement,
                new_value => $values{ $statement },
            } );
        }

        # make the form method
        my $form_method_name;
        if ( $data->{ subtype } eq 'AutoCRUD' ) {
            $form_method_name = 'form';
        }
        else {
            $form_method_name = 'my_crud_form';
        }
        my $form_arr = $self->add_subblock(
            undef,
            {
                parent => {
                    type => 'controller',
                    ident => $self->get_ident,
                },
                new_child => {
                    type     => 'method',
                    sub_type => $data->{ subtype } . '_form',
                    name     => $form_method_name,
                },
            }
        );
        my $form_method = $form_arr->[0];

        my $all_fields_but = $data->{ all_fields_but }
                          || 'id, created, modified';
        $all_fields_but    =~ s/, /][/g;

        $form_method->add_method_statement( {
            keyword   => 'all_fields_but',
            new_value => $all_fields_but,
        } );

        $form_method->add_method_statement( {
            keyword   => 'extra_keys',
            new_value => {
                keys   => 'legend',
                values => q{$self->path_info =~ /edit/i ? q!Edit! : q!Add!}
            }
        } );
    }
    # base controllers get nav link methods by default
    elsif ( defined $data->{ subtype }
                and
            $data->{ subtype } eq 'base_controller'
    ) {
        # first a do_main with nav links for default main page
        my $main_arr = $self->add_subblock(
            undef,
            {
                parent => {
                    type => 'controller',
                    ident => $self->get_ident,
                },
                new_child => {
                    type     => 'method',
                    sub_type => 'base_links',
                    name     => 'do_main',
                },
            }
        );

        my $do_main = $main_arr->[0];

        # then a site_links method for other controllers and their templates
        $self->add_subblock(
            undef,
            {
                parent => {
                    type => 'controller',
                    ident => $self->get_ident,
                },
                new_child => {
                    type     => 'method',
                    sub_type => 'links',
                    name     => 'site_links',
                },
            }
        );
    }

    return $self;
}

sub add_subblock {
    my $self   = shift;
    shift;
    my $params = shift;

    return unless ( $params->{parent}{type}    eq 'controller'     );
    return unless ( $params->{parent}{ident}   eq $self->get_ident );

    if ( $params->{new_child}{type} eq 'method' ) {
        my $new_method = controller_method->new(
                $self, $params
        );

        push @{ $self->{__BODY__} }, $new_method;

        return [ $new_method ];
    }
    elsif ( $params->{new_child}{type} eq 'config' ) {
        my $new_config = controller_config_block->new( $self, $params );

        push @{ $self->{__BODY__} }, $new_config;

        return [ $new_config ];
    }
}

sub remove_block {
    my $self         = shift;
    shift;
    my $data         = shift;
    my $doomed_ident = $data->{ ident };

    my $doomed_index = -1;
    my $count        = 0;

    my $children     = $self->{__BODY__};

    CHILD:
    foreach my $child ( @{ $children } ) {
        next CHILD unless $child->can( 'get_ident' );

        if ( $child->get_ident eq $doomed_ident ) {
            $doomed_index = $count;
        }
    }
    continue {
        $count++;
    }

    return if ( $doomed_index == -1 );

    splice @{ $children }, $doomed_index, 1;

    return [ 1 ];
}

sub get_ident {
    my $self = shift;
    return $self->{__IDENT__};
}

sub get_name {
    my $self = shift;
    return $self->{__NAME__};
}

sub set_name {
    my $self          = shift;
    $self->{__NAME__} = shift;
}

sub get_controller_type {
    my $self = shift;

    return $self->{__TYPE__} || 'stub';
}

sub set_type {
    my $self          = shift;
    $self->{__TYPE__} = shift;
}

sub is_base_controller {
    my $self = shift;

    return (
        defined $self->{__TYPE__}
            and
        $self->{__TYPE__} eq 'base_controller'
    );
}

sub output_location {
    my $self         = shift;
    my $child_output = shift;

    return unless $self->is_base_controller;

    return $child_output;
}

sub get_controlled_table {
    my $self = shift;
}

sub change_name_controller {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->get_ident  eq $data->{ident};

    $self->set_name( $data->{new_value} );

    return [ 1 ];
}

sub change_type {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->get_ident eq $data->{ident} );

    $self->set_type( $data->{new_type} );

    return [ 1 ];
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    my $body = {
        statements => {},
        blocks     => [],
    };

    foreach my $child_item ( @{ $child_output } ) {
        if ( $child_item->{ type } eq 'statement' ) {
            $body->{ statements }{ $child_item->{ keyword } } =
                $child_item->{ value };
        }
        else {
            push @{ $body->{ blocks } }, $child_item;
        }
    }

    my $controller_type = $self->get_controller_type || 'stub';

    return [ {
        ident           => $self->get_ident,
        type            => 'controller',
        body            => $body,
        name            => $self->get_name,
        controller_type => $controller_type,
    } ];
}

sub change_controller_statement {
    my $self         = shift;
    shift;
    my $data         = shift;

    return unless ( $self->get_ident   eq $data->{ident} );

    my $success = $self->walk_postorder(
                    'change_controller_keyword_value', $data
    );

    unless ( defined $success->[0] ) { # make new statement
        $self->add_controller_statement( $data );
    }

    return [ 1 ];
}

sub add_controller_statement {
    my $self = shift;
    my $data = shift;

    my $new_statement = controller_statement->new(
        $self, $data->{ keyword }, $data->{ new_value },
    );

    my $blocks = $self->{ __BODY__ };
    push @{ $blocks }, $new_statement;
}

sub remove_controller_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->get_ident   eq $data->{ident} );

    my $doomed_child = -1;
    my $count        = 0;

    my $blocks = $self->{__BODY__};

    BLOCK:
    foreach my $block ( @{ $blocks } ) {
        next BLOCK unless defined $block->{__KEYWORD__}; # skip methods
        next BLOCK unless $block->{__KEYWORD__} eq $data->{keyword};

        $doomed_child = $count;
        last BLOCK;
    }
    continue {
        $count++;
    }

    if ( $doomed_child >= 0 ) {
        # This probably leaks memory because children have parent pointers.
        # But the parent is me and I'm the app_body, so maybe not.
        splice @{ $blocks }, $doomed_child, 1;
    }
    # else, nothing to see here, move along quietly

    return [ 1 ];
}

sub get_controller_statement {
    my $self    = shift;
    my $keyword = shift;

    my $blocks  = $self->{__BODY__};

    BLOCK:
    foreach my $block ( @{ $blocks } ) {
        next BLOCK unless defined $block->{ __KEYWORD__ }; # no methods
        next BLOCK unless $block->{ __KEYWORD__ } eq $keyword;

        return $block;
    }

    return;
}

sub field_name_changed {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return unless defined $child_output->[0];

    return $self->walk_postorder( 'update_field_name', $data );
}

sub field_removed {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return unless defined $child_output->[0];

    return $self->walk_postorder( 'remove_field', $data );
}

sub show_idents {
    my $self = shift;
    my $child_output = shift;

    push @{ $child_output },
            [ 'controller', $self->{ __NAME__ }, $self->{ __IDENT__ } ];

    return $child_output;
}

sub get_controller_configs {
    my $self         = shift;
    my $child_output = shift;

    my $name         = $self->get_name();

    my %my_children;
    foreach my $child ( @{ $child_output } ) {
        $my_children{ $child->{ type } } = $child->{ statements };
    }

    return [ { controller => $name, configs => \%my_children } ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

    foreach my $controller_stmnt ( @{ $self->{__BODY__} } ) {
        my $child_output = $controller_stmnt->walk_postorder(
            $action, $data, $self
        );
        push @{ $output }, @{ $child_output } if $child_output;
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    my %output       = ( type => $self->get_controller_type );

    foreach my $element ( @{ $child_output } ) {
        my $output_type                  = $element->{__TYPE__};

        my $name                         = $element->{__DATA__}[0];

        $output{ $output_type }{ $name } = $element->{__DATA__}[1];
    }

    return [
        {
            '__TYPE__' => 'controllers',
            '__DATA__' => [
                $self->{__NAME__} => {
                        __IDENT__ => $self->{ __IDENT__ },
                        %output
                }
            ],
        }
    ];
}

sub use_date_plugin {
    my $self = shift;
    shift;
    my $data = shift;

    my $it_is_I = $self->walk_postorder(
            'do_I_control', $data->{ table }
    )->[0];

    my @retval;

    if ( $it_is_I ) {
        # first, update my uses
        my $current_uses = $self->get_controller_statement( 'uses' );

        if ( not defined $current_uses ) {
            $self->add_controller_statement(
                {
                    keyword   => 'uses',
                    new_value => 'Gantry::Plugins::Calendar',
                }
            );
            push @retval, $self->get_ident . '::uses',
                 $self->get_controller_statement( 'uses' )->{ __ARGS__ };
        }
        else { # see if its already there
            my %current_modules = map { $_ => 1 }
                                  @{ $current_uses->{ __ARGS__ } };

            unless ( defined $current_modules{ 'Gantry::Plugins::Calendar' } )
            {
                push @{ $current_uses->{ __ARGS__ } },
                     'Gantry::Plugins::Calendar';
            }
            push @retval,
                 $self->get_ident . '::uses',
                 $current_uses->{ __ARGS__ };
        }

        # then, tell update my form
        my $result = $self->walk_postorder(
                'add_date_popups', $data->{ table }
        );

        push @retval, @{ $result };

        return \@retval;
    }

    return;
}

package # controller_method
    controller_method;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class  = shift;
    my $parent = shift;
    my $params = shift;

    my $type   = $params->{new_child}{sub_type} || 'stub';

    my $self   = {
        __IDENT__  => Bigtop::Parser->get_ident(),
        __NAME__   => $params->{new_child}{name},
        __BODY__   => method_body->new(),
        __TYPE__   => $type,
        __PARENT__ => $parent,
    };

    $self->{__BODY__}{__PARENT__} = $self;

    return bless $self, $class;
}

sub get_ident {
    my $self = shift;

    return $self->{__IDENT__};
}

sub get_name {
    my $self = shift;

    return $self->{__NAME__};
}

sub set_name {
    my $self          = shift;
    $self->{__NAME__} = shift;
}

sub set_type {
    my $self          = shift;
    $self->{__TYPE__} = shift;
}

sub get_controller_ident {
    my $self = shift;

    return $self->{__PARENT__}{__PARENT__}->get_ident();
}

sub get_controller_name {
    my $self = shift;

    return $self->{__PARENT__}{__PARENT__}->get_name();
}

sub change_name_method {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->get_ident eq $data->{ident};

    $self->set_name( $data->{ new_value } );

    return;
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    my %statements;

    foreach my $child_item ( @{ $child_output } ) {
        $statements{ $child_item->{ keyword } } = $child_item->{ values };
    }

    return [ {
        ident       => $self->get_ident,
        type        => 'method',
        name        => $self->get_name,
        method_type => $self->{__TYPE__},
        statements  => \%statements,
    } ];
}

sub change_method_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $data->{ident} eq $self->get_ident() );

    my $old_value = $self->walk_postorder( 'get_method_keyword_value', $data );

    my $success   = $self->walk_postorder(
            'change_method_keyword_value', $data
    );

    unless ( defined $success->[0] ) {
        $self->add_method_statement( $data );
    }

    if ( $data->{ keyword } eq 'paged_conf' ) {
        my $current_value = $data->{ app }->get_config_statement(
                'base', $data->{ new_value }
        );

        unless ( defined $current_value->[0] and $current_value->[0] > 0 ) {
            my $config_ident = $data->{ app }->get_config_ident( 'base' );

            $data->{ app }->set_config_statement(
                    $config_ident, $data->{ new_value }, 20
            );
            return [ [ $config_ident . '::' . $data->{ new_value }, 20 ] ];
        }
    }

    return [ 1 ];
}

sub add_method_statement {
    my $self = shift;
    my $data = shift;

    my $new_statement = method_statement->new(
        $self->{__BODY__},
        $data->{keyword},
        $data->{new_value},
        $data->{pair_required},
    );

    my $blocks = $self->{ __BODY__ }{ 'method_statement(s?)' };
    push @{ $blocks }, $new_statement;
}

sub remove_method_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $data->{ident} eq $self->get_ident() );

    my $doomed_child = -1;
    my $count        = 0;

    my $statements = $self->{ __BODY__ }{'method_statement(s?)'};

    STATEMENT:
    foreach my $statement ( @{ $statements } ) {
        next STATEMENT unless $statement->{__KEYWORD__} eq $data->{keyword};

        $doomed_child = $count;
        last STATEMENT;
    }
    continue {
        $count++;
    }

    if ( $doomed_child >= 0 ) {
        # This probably leaks memory because children have parent pointers.
        # But the parent is me and I'm the app_body, so maybe not.
        splice @{ $statements }, $doomed_child, 1;
    }
    # else, nothing to see here, move along quietly

    return [ 1 ];
}

sub get_method_statement {
    my $self    = shift;
    my $keyword = shift;

    my $statements = $self->{ __BODY__ }{'method_statement(s?)'};

    STATEMENT:
    foreach my $statement ( @{ $statements} ) {
        next STATEMENT unless $statement->{__KEYWORD__} eq $keyword;
        return $statement;
    }
    return;
}

sub change_type {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->get_ident eq $data->{ident} );

    $self->set_type( $data->{new_type} );

    return [ 1 ];
}

sub add_date_popups {
    my $self  = shift;
    shift;
    my $table = shift;

    return unless $self->{ __TYPE__ } =~ /form/;

    # First, make sure the form is named for the table (or has a name)
    my $form_statement = $self->get_method_statement( 'form_name' );
    my $form_name      = $table;

    if ( defined $form_statement ) {
        $form_name     = $form_statement->{ __ARGS__ }->get_first_arg();
    }
    else { # create a form_name statement
        $self->add_method_statement(
            {
                keyword   => 'form_name',
                new_value => $table,
            }
        );
    }

    # Second, make sure that name is in javascript code for calendars.
    my $javascript_code = qq{\$self->calendar_month_js( '$table' )},
    my $keys_statement  = $self->get_method_statement( 'extra_keys' );
    my $extra_keys;

    if ( defined $keys_statement ) {
        push @{ $keys_statement->{ __ARGS__ } },
             { javascript => $javascript_code };

        $extra_keys = $keys_statement->{ __ARGS__ };
    }
    else {
        $self->add_method_statement(
            {
                keyword   => 'extra_keys',
                new_value => {
                    'keys'   => 'javascript',
                    'values' => $javascript_code,
                },
            }
        );

        $extra_keys = $self->get_method_statement( 'extra_keys' )->{__ARGS__};
    }

    my $ident = $self->get_ident;
    return [
        $ident . '::form_name'  => $table,
        $ident . '::extra_keys' => $extra_keys,
    ];
}

sub update_field_name {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    my $count = 0;
    # remember that foreach aliases, this loop alters child output
    foreach my $key_or_val ( @{ $child_output } ) {
        if ( $count % 2 == 0 ) {
            $key_or_val = $self->{__IDENT__} . '::' . $key_or_val;
        }
        $count++;
    }

    return $child_output;
}

sub remove_field {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    my $count = 0;
    # remember that foreach aliases, this loop alters child output
    foreach my $key_or_val ( @{ $child_output } ) {
        if ( $count % 2 == 0 ) {
            $key_or_val = $self->{__IDENT__} . '::' . $key_or_val;
        }
        $count++;
    }

    return $child_output;
}

sub show_idents {
    my $self = shift;
    my $child_output = shift;

    push @{ $child_output }, [
        'method',
        $self->{ __NAME__ },
        $self->{ __IDENT__ },
        'controller: ' . $self->get_controller_ident,
    ];

    return $child_output;
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = $self->{__BODY__}->walk_postorder( $action, $data, $self );

    if ( $self->can( $action ) ) {
        return $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    my $statements   = {};

    if ( $child_output ) {
        $statements  = { @{ $child_output } }
    }

    return [
        {
            '__TYPE__'        => 'methods',
            '__DATA__'        => [
                $self->{__NAME__} => {
                    type       => $self->{__TYPE__},
                    statements => $statements,
                    __IDENT__  => $self->{__IDENT__},
                },
            ],
        }
    ];
}

package # method_body
    method_body;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class  = shift;

    my $self  = {
        __RULE__               => 'method_body',
        'method_statement(s?)' => [],
    };

    return bless $self, $class;
}

sub get_method_name {
    my $self = shift;

    return $self->{__PARENT__}{__NAME__};
}

sub get_controller_name {
    my $self = shift;

    return $self->{__PARENT__}{__PARENT__}->get_name();
}

sub get_table_name {
    my $self   = shift;
    my $lookup = shift;

    my $controller = $self->get_controller_name();
    return $lookup->{controllers}{$controller}{statements}{controls_table}[0];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

    foreach my $child ( @{ $self->{'method_statement(s?)'} } ) {
        my $child_output = $child->walk_postorder( $action, $data, $self );
        push @{ $output }, @{ $child_output } if $child_output;
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

package # method_statement
    method_statement;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class     = shift;
    my $parent    = shift;
    my $keyword   = shift;
    my $new_value = shift;

    my $self      = {
        __PARENT__  => $parent,
        __KEYWORD__ => $keyword,
        __ARGS__    => arg_list->new( $new_value ),
    };

    return bless $self, $class;
}

sub change_method_keyword_value {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->{__KEYWORD__}     eq $data->{keyword} );

    $self->{__ARGS__}->set_args_from(
            $data->{new_value},
            $data->{pair_required},
    );

    return [ 1 ];
}

sub get_method_keyword_value {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->{__KEYWORD__}     eq $data->{keyword} );

    return $self->{__ARGS__};
}

sub app_block_hashes {
    my $self         = shift;

    return [ {
        keyword     => $self->{__KEYWORD__},
        values      => $self->{__ARGS__},
    } ];
}

sub update_field_name {
    my $self = shift;
    shift;
    my $data = shift;

    unless ( $self->{ __KEYWORD__ } eq 'cols'
                or
             $self->{ __KEYWORD__ } eq 'all_fields_but'
                or
             $self->{ __KEYWORD__ } eq 'fields' )
    {
        return;
    }

    my $we_did_something = 0;
    foreach my $arg ( @{ $self->{ __ARGS__ } } ) {
        if ( $arg eq $data->{ old_field_name } ) {
            $arg = $data->{ new_field_name };
            $we_did_something++;
        }
    }

    if ( $we_did_something ) {
        return [ $self->{ __KEYWORD__ }, $self->{ __ARGS__ } ];
    }
    else {
        return;
    }
}

sub remove_field {
    my $self = shift;
    shift;
    my $data = shift;

    unless ( $self->{ __KEYWORD__ } eq 'cols'
                or
             $self->{ __KEYWORD__ } eq 'all_fields_but'
                or
             $self->{ __KEYWORD__ } eq 'fields' )
    {
        return;
    }

    # we need to remove the arg if it matches the name of the deceased field
    my @new_args;

    # first, build a list of remaining args
    my $someone_died = 0;
    ARG:
    foreach my $arg ( @{ $self->{__ARGS__} } ) {
        if ( $arg eq $data->{ dead_field_name } ) { $someone_died++; }
        else                                      { push @new_args, $arg; }
    }

    return unless $someone_died;

    # second, install them in the object
    $self->{__ARGS__}->set_args_from( \@new_args );

    push @new_args, '';

    # third, return them as a full list for the statement
    return [ $self->{ __KEYWORD__ }, \@new_args ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [ $self->{__KEYWORD__} => $self->{__ARGS__} ];
}

package # controller_literal_block
    controller_literal_block;
use strict; use warnings;

use base 'application_ancestor';

sub get_backend {
    my $self = shift;

    return $self->{__BACKEND__};
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub make_output {
    my $self    = shift;
    my $backend = shift;

    if ( $backend eq $self->{__BACKEND__} ) {
        my $output = $self->{__BODY__};

        $output    =~ s/\Z/\n/ if ( $output !~ /\s\Z/ );

        return [ $output ];
    }
    else {
        return;
    }
}

package # controller_statement
    controller_statement;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class   = shift;
    my $parent  = shift;
    my $keyword = shift;
    my $values  = shift;

    my $self    = {
        __PARENT__  => $parent,
        __KEYWORD__ => $keyword,
        __ARGS__    => arg_list->new( $values ),
    };

    return bless $self, $class;
}

sub get_controller_ident {
    my $self = shift;

    return $self->{__PARENT__}{__IDENT__};
}

sub get_controller_name {
    my $self = shift;

    return $self->{__PARENT__}{__NAME__};
}

sub change_controller_keyword_value {
    my $self = shift;
    shift;
    my $data = shift;

    return unless ( $self->{__KEYWORD__} eq $data->{keyword} );

    $self->{__ARGS__}->set_args_from(
            $data->{new_value},
            $data->{pair_required},
    );

    return [ 1 ];
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    return [ {
        type    => 'statement',
        keyword => $self->{__KEYWORD__},
        value   => $self->{__ARGS__},
    } ];
}

sub table_name_changed {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->{ __KEYWORD__ } eq 'controls_table';

    my $controlled_table = $self->{ __ARGS__ }->get_first_arg();

    if ( $controlled_table eq $data->{ old_name } ) {
        $self->{ __ARGS__ }->set_args_from( $data->{ new_name } );

        return [
            $self->get_controller_ident . '::controls_table',
            $data->{ new_name }
        ];
    }

    return;
}

sub field_name_changed {
    my $self         = shift;
    shift;
    my $data         = shift;

    return unless $self->{ __KEYWORD__ } eq 'controls_table';
    return unless $self->{ __ARGS__ }->get_first_arg()
                        eq
                  $data->{ table_name };

    # Leave this return value alone, an ancestor checks it to see if the
    # name change is for this controller or not.
    return [ 1 ];
}

# Yes, I know this is the same as the code above.  They are in different
# walk stacks.

sub field_removed {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return unless $self->{ __KEYWORD__ } eq 'controls_table';
    return unless $self->{ __ARGS__ }->get_first_arg()
                        eq
                  $data->{ table_name };

    # Leave this return value alone, an ancestor checks it to see if the
    # name change is for this controller or not.
    return [ 1 ];
}

sub do_I_control {
    my $self  = shift;
    shift;
    my $table = shift;

    return unless $self->{ __KEYWORD__ } eq 'controls_table';
    my $controlled_table = $self->{ __ARGS__ }->get_first_arg();

    if ( $controlled_table eq $table ) {
        return [ 1 ];
    }
    else {
        return;
    }
}

sub output_location {
    my $self         = shift;
    my $child_output = shift;

    return unless $self->{__KEYWORD__} eq 'location';

    return $self->{__ARGS__};
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [
        {
            '__TYPE__' => 'statements',
            '__DATA__' => [
                $self->{__KEYWORD__} => $self->{__ARGS__}
            ]
        }
    ];
}

package # app_config_block
    app_config_block;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class  = shift;
    my $params = shift;

    return bless {
        __IDENT__  => Bigtop::Parser->get_ident(),
        __PARENT__ => $params->{parent},
        __BODY__   => $params->{statements},
        __TYPE__   => $params->{type},
    }, $class;
}

sub new_block {
    my $class  = shift;
    my $parent = shift;
    my $data   = shift;

    return $class->new(
        {
            parent     => $parent,
            statements => [],
            type       => $data->{ name },
        }
    );
}

sub change_name_config {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->{__IDENT__} eq $data->{ident};

    $self->set_name( $data->{ new_value } );

    return;
}

sub set_name {
    my $self          = shift;
    $self->{__TYPE__} = shift;
}

sub add_config_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $data->{ ident } eq $self->{__IDENT__};

    my $new_statement = app_config_statement->new(
        $data->{ keyword  },
        $data->{ value    },
        $data->{ accessor },
        $self,
    );

    push @{ $self->{ __BODY__ } }, $new_statement;

    return [ 1 ];
}

sub remove_config_statement {
    my $self    = shift;
    shift;
    my $data    = shift;
    my $ident   = $data->{ ident   };
    my $keyword = $data->{ keyword };

    return unless $self->{__IDENT__} eq $ident;

    my $doomed_child = -1;
    my $count        = 0;

    STATEMENT:
    foreach my $child ( @{ $self->{ __BODY__ } } ) {
        my $child_keyword = $child->get_keyword();
        if ( $keyword eq $child_keyword ) {
            $doomed_child = $count;
            last STATEMENT;
        }
        $count++;
    }

    if ( $doomed_child >= 0 ) {
        splice @{ $self->{ __BODY__ } }, $doomed_child, 1;
    }

    return [ 1 ];
}

sub get_app_configs {
    my $self         = shift;
    my $child_output = shift;

    my $type = $self->{__TYPE__} || 'base';

    my %my_children;
    foreach my $child ( @{ $child_output } ) {
        $my_children{ $child->{ var } } = $child->{ val };
    }

    return [ { type => $type, statements => \%my_children } ];
}

sub get_app_config_types {
    my $self = shift;

    my $type = $self->{__TYPE__} || 'base';

    return [ $type ];
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    my @statements;

    foreach my $child_item ( @{ $child_output } ) {
        my $no_accessor = 0;
        my $value       = $child_item->{ value };
        if ( ref( $value ) eq 'HASH' ) {
            ( $value, $no_accessor ) = %{ $value };
        }

        push @statements, {
            keyword     => $child_item->{ keyword },
            value       => $value,
            no_accessor => $no_accessor,
        };
    }

    return [ {
        ident       => $self->{__IDENT__},
        type        => 'config',
        name        => $self->{__TYPE__} || 'base',
        statements  => \@statements,
    } ];
}

sub get_ident {
    my $self = shift;

    return $self->{__IDENT__};
}

sub get_config_idents {
    my $self       = shift;
    shift;
    my $block_name = shift;

    if ( ( not defined $self->{__TYPE__} and $block_name eq 'base' )
                or
           $self->{__TYPE__} eq $block_name
    ) {
        return [ $self->{__IDENT__} ];
    }
    else {
        return;
    }
}

sub show_idents {
    my $self         = shift;
    my $child_output = shift;

    push @{ $child_output },
            [ 'config', $self->{ __NAME__ }, $self->{ __IDENT__ } ];

    return $child_output;
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

    foreach my $child ( @{ $self->{ __BODY__ } } ) {
        my $child_output = $child->walk_postorder( $action, $data, $self );
        push @{ $output }, @{ $child_output } if $child_output;
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return $child_output;
}

package # controller_config_block
    controller_config_block;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class  = shift;
    my $parent = shift;
    my $params = shift;

    my $self   = {
        __PARENT__ => $parent,
        __IDENT__  => Bigtop::Parser->get_ident(),
        __BODY__   => [],
        __TYPE__   => $params->{ new_child }{ name },
    };

    return bless $self, $class;
}

sub change_name_controller_config {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $self->get_ident  eq $data->{ident};

    $self->{__TYPE__} = $data->{new_value};

    return [ 1 ];
}

sub get_controller_name {
    my $self = shift;

    return $self->{__PARENT__}->get_name();
}

sub get_ident {
    my $self = shift;

    return $self->{__IDENT__};
}

sub get_controller_configs {
    my $self         = shift;
    my $child_output = shift;

    my $type = $self->{__TYPE__} || 'base';

    my %my_children;
    foreach my $child ( @{ $child_output } ) {
        $my_children{ $child->{ var } } = $child->{ val };
    }

    return [ { type => $type, statements => \%my_children } ];
}

sub add_config_statement {
    my $self = shift;
    shift;
    my $data = shift;

    return unless $data->{ ident } eq $self->{__IDENT__};

    my $new_statement = controller_config_statement->new(
        $data->{ keyword  },
        $data->{ value    },
        $self,
    );

    push @{ $self->{__BODY__} }, $new_statement;

    return [ 1 ];
}

sub remove_config_statement {
    my $self    = shift;
    shift;
    my $data    = shift;
    my $ident   = $data->{ ident   };
    my $keyword = $data->{ keyword };

    return unless $self->{__IDENT__} eq $ident;

    my $doomed_child = -1;
    my $count        = 0;

    STATEMENT:
    foreach my $child ( @{ $self->{__BODY__} } ) {
        my $child_keyword = $child->get_keyword();
        if ( $keyword eq $child_keyword ) {
            $doomed_child = $count;
            last STATEMENT;
        }
        $count++;
    }

    if ( $doomed_child >= 0 ) {
        splice @{ $self->{__BODY__} }, $doomed_child, 1;
    }

    return [ 1 ];
}

sub app_block_hashes {
    my $self         = shift;
    my $child_output = shift;

    my @statements;

    foreach my $child_item ( @{ $child_output } ) {
        my $no_accessor = 0;
        my $value       = $child_item->{ value };
        if ( ref( $value ) eq 'HASH' ) {
            ( $value, $no_accessor ) = %{ $value };
        }

        push @statements, {
            keyword     => $child_item->{ keyword },
            value       => $value,
            no_accessor => $no_accessor,
        };
    }

    return [ {
        ident       => $self->{__IDENT__},
        type        => 'config',
        name        => $self->{__TYPE__} || 'base',
        statements  => \@statements,
    } ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    my $output = [];

    foreach my $child ( @{ $self->{__BODY__} } ) {
        my $child_output = $child->walk_postorder( $action, $data, $self );
        push @{ $output }, @{ $child_output } if $child_output;
    }

    if ( $self->can( $action ) ) {
        $output = $self->$action( $output, $data, $parent );
    }

    ( ref( $output ) =~ /ARRAY/ ) ? return $output : return;
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return $child_output;
}

package # app_config_statement
    app_config_statement;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class    = shift;
    my $keyword  = shift;
    my $value    = shift;
    my $accessor = shift;
    my $parent   = shift;

    my $self = {
        __PARENT__  => $parent,
        __KEYWORD__ => $keyword,
    };
 
    if ( $accessor ) {
        $self->{__ARGS__} = arg_list->new( [ { $value => 'no_accessor' } ] );
    }
    else {
        $self->{__ARGS__} = arg_list->new( [ $value ] );
    }

    return bless $self, $class;
}

sub get_keyword {
    my $self = shift;

    return $self->{__KEYWORD__};
}

sub get_config_statements {
    my $self = shift;

    return [ $self->{__KEYWORD__} => $self->{__ARGS__} ];
}

sub update_config_statement {
    my $self   = shift;
    shift;
    my $data   = shift;

    return unless ( $data->{ ident } eq $self->{__PARENT__}->get_ident );

    return [] unless ( $data->{ keyword } eq $self->{ __KEYWORD__ } );

    my $arg = $self->{__ARGS__}->get_first_arg();

    if ( ref( $arg ) eq 'HASH' ) {
        my ( $value, $no_access ) = %{ $arg };

        $self->{__ARGS__} = arg_list->new(
            [ { $data->{value} => $no_access } ]
        );
    }
    else {
        $self->{__ARGS__} = arg_list->new(
            [ $data->{value} ]
        );
    }

    return [ 1 ];
}

sub get_config_value {
    my $self    = shift;
    shift;
    my $data    = shift;

    my $config_type_name = $data->{ config_type_name };
    my $keyword          = $data->{ keyword };

#    warn "I want the config value for:\n";
#    use Data::Dumper; warn Dumper( $data );
#    warn 'my config type: ' . $self->get_config_type_name() . "\n";
#    warn "my keyword: $self->{__KEYWORD__}\n";
    
    return [] unless ( $config_type_name eq $self->get_config_type_name() );
    return [] unless ( $keyword eq $self->{ __KEYWORD__ } );

    return $self->{__ARGS__};
}

sub config_statement_status {
    my $self   = shift;
    shift;
    my $data   = shift;

    return unless ( $data->{ ident } eq $self->{__PARENT__}->get_ident );

    return [] unless ( $data->{ keyword } eq $self->{ __KEYWORD__ } );

    my $arg = $self->{__ARGS__}->get_args();

    if ( $data->{ value } ) { # add no_accessor flag
        $self->{__ARGS__} = arg_list->new(
            [ { $arg => 'no_accessor' } ]
        );
    }
    else { # remove flag
        $self->{__ARGS__} = arg_list->new(
            [ $arg ]
        );
    }

    return [];
}

sub get_app_configs {
    my $self = shift;

    my $var  = $self->{__KEYWORD__};
    my $val  = $self->{__ARGS__}->get_first_arg;

    if ( ref( $val ) eq 'HASH' ) {
        ( $val ) = keys %{ $val };
    }

    return [ { var => $var, val => $val } ];
}

sub app_block_hashes {
    my $self         = shift;

    return [ {
        keyword     => $self->{__KEYWORD__},
        value       => $self->{__ARGS__}[0],
    } ];
}

sub get_config_type_name {
    my $self = shift;

    return $self->{__PARENT__}{__TYPE__} || 'base';
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [
        {
            '__TYPE__' => 'configs',
            '__DATA__' => [
                $self->{__KEYWORD__} => $self->{__ARGS__}
            ]
        }
    ];
}

package # controller_config_statement
    controller_config_statement;
use strict; use warnings;

use base 'application_ancestor';

sub new {
    my $class    = shift;
    my $keyword  = shift;
    my $value    = shift;
    my $parent   = shift;

    my $self = {
        __PARENT__  => $parent,
        __KEYWORD__ => $keyword,
    };
 
    $self->{__ARGS__} = arg_list->new( [ $value ] );

    return bless $self, $class;
}

sub get_keyword {
    my $self = shift;

    return $self->{__KEYWORD__};
}

sub get_controller_configs {
    my $self = shift;

    my $var  = $self->{__KEYWORD__};
    my $val  = $self->{__ARGS__}->get_first_arg;

    if ( ref( $val ) eq 'HASH' ) {
        ( $val ) = keys %{ $val };
    }

    return [ { var => $var, val => $val } ];
}

sub app_block_hashes {
    my $self         = shift;

    return [ {
        keyword     => $self->{__KEYWORD__},
        value       => $self->{__ARGS__}[0],
    } ];
}

sub update_config_statement {
    my $self   = shift;
    shift;
    my $data   = shift;

    return unless ( $data->{ ident } eq $self->{__PARENT__}->{__IDENT__} );

    return [] unless ( $data->{ keyword } eq $self->{ __KEYWORD__ } );

    my $arg = $self->{__ARGS__}->get_first_arg();

    $self->{__ARGS__} = arg_list->new(
        [ $data->{value} ]
    );

    return [ 1 ];
}

sub walk_postorder {
    my $self   = shift;
    my $action = shift;
    my $data   = shift;
    my $parent = shift;

    if ( $self->can( $action ) ) {
        return $self->$action( undef, $data, $parent );
    }
    else {
        return;
    }
}

sub build_lookup_hash {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;

    return [
        {
            '__TYPE__' => 'configs',
            '__DATA__' => [
                $self->{__KEYWORD__} => $self->{__ARGS__}
            ]
        }
    ];
}

package # arg_list
    arg_list;
use strict; use warnings;

sub new {
    my $class         = shift;
    my $values        = shift;
    my $pair_required = shift;

    return bless build_values( $values, $pair_required ), $class;
}

sub build_values {
    my $values        = shift;
    my $pair_required = shift;

    if ( ref( $values ) eq 'ARRAY' ) {
        return $values;
    }
    elsif ( ref( $values ) eq 'HASH' ) {
        my $value_str = $values->{ values } || '';
        my @keys      = split /\]\[/, $values->{ keys   };
        my @values    = split /\]\[/, $value_str;

        my @retvals;

        for ( my $i = 0; $i < @keys; $i++ ) {
            if ( $pair_required ) {
                my $push_value = defined ( $values[ $i ] )
                               ? $values[ $i ]
                               : '';

                push @retvals, { $keys[ $i ] => $push_value };
            }
            elsif ( defined $pair_required ) {
                if ( not defined $values[ $i ]
                        or
                     $values[ $i ] eq 'undefined'
                        or
                     not $values[ $i ]
                ) {
                    push @retvals, $keys[ $i ];
                }
                else {
                     push @retvals, { $keys[ $i ] => $values[ $i ] };
                }
            }
            else {
                if ( defined $values[ $i ] and $values[ $i ] ne 'undefined' ) {
                     push @retvals, { $keys[ $i ] => $values[ $i ] };
                }
                else {
                    push @retvals, $keys[ $i ];
                }
            }
        }

        return \@retvals;
    }
    else {
        my @values = split /\]\[/, $values;

        return \@values;
    }
}

sub get_first_arg {
    my $self = shift;

    return $self->[0];
}

sub get_args {
    my $self = shift;

    my @args;

    foreach my $arg ( @{ $self } ) {
        if ( ref( $arg ) =~ /HASH/ ) {
            my ( $name, $condition ) = %{ $arg };
            push @args, $name;
        }
        else {
            push @args, $arg;
        }
    }

    return join ', ', @args;
}

sub get_quoted_args {
    my $self = shift;

    my @args;

    foreach my $arg ( @{ $self } ) {
        if ( ref( $arg ) =~ /HASH/ ) {
            my ( $name, $condition ) = %{ $arg };

            unless ( $name =~ /^\w[\w\d_]*$/ ) {
                $name = "`$name`";
            }

            unless ( $condition =~ /^\w[\w\d_]*$/ ) {
                $condition = "`$condition`";
            }

            push @args, "$name => $condition";
        }
        else {
            my $value = $arg;
            if ( $value !~ /^\w[\w\d_:]*$/ ) {
                $value = "`$value`";
            }
            else {
                my @value_pieces = split /::/, $value;
                # if any of the pieces has a colon, quote the value
                VALUE_PIECE:
                foreach my $piece ( @value_pieces ) {
                    if ( $piece =~ /:/ ) {
                        $value = "`$value`";
                        last VALUE_PIECE;
                    }
                }
            }

            push @args, $value;
        }
    }

    return ( wantarray ) ? @args : join ', ', @args;
}

sub get_unquoted_args {
    my $self = shift;

    my @args;

    foreach my $arg ( @{ $self } ) {
        if ( ref( $arg ) =~ /HASH/ ) {
            my ( $name, $condition ) = %{ $arg };

            push @args, "$name => $condition";
        }
        else {
            push @args, $arg;
        }
    }

    return \@args;
}

sub set_args_from {
    my $self          = shift;
    my $new_values    = shift;
    my $pair_required = shift;

    pop  @{ $self } while ( @{ $self } );

    my $paired_values = build_values( $new_values, $pair_required );

    push @{ $self }, @{ $paired_values };
}

sub one_hash {
    my $self = shift;

    my %args;

    foreach my $arg ( @{ $self } ) {
        if ( ref( $arg ) =~ /HASH/ ) {
            my ( $key, $value ) = %{ $arg };
            $args{ $key } = $value;
        }
        else {
            $args{ $arg } = undef;
        }
    }

    return \%args;
}

sub unbless_args {
    my $self = shift;

    my @args;

    foreach my $arg ( @{ $self } ) {
        push @args, $arg;
    }

    return \@args;
}

1;