Bigtop
view release on metacpan or search on metacpan
lib/Bigtop/Parser.pm view on Meta::CPAN
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(
{
lib/Bigtop/Parser.pm view on Meta::CPAN
}
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 {
lib/Bigtop/Parser.pm view on Meta::CPAN
$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;
lib/Bigtop/Parser.pm view on Meta::CPAN
}
( 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, '';
lib/Bigtop/Parser.pm view on Meta::CPAN
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' } ]
);
lib/Bigtop/Parser.pm view on Meta::CPAN
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;
( run in 1.973 second using v1.01-cache-2.11-cpan-9581c071862 )