view release on metacpan or  search on metacpan

lib/Bigtop/Backend/Model/GantryDBIxClass.pm  view on Meta::CPAN

                authors      => $bigtop_tree->get_authors(),

                year             => $year,
                copyright_holder => $bigtop_tree->get_copyright_holder(),
                license_text     => $bigtop_tree->get_license_text(),
            }
        );

    my $base_model = Bigtop::Backend::Model::GantryDBIxClass::stub_base_model(
        {
            app_name     => $app_base_name,
            table_models => $child_models,
            authors      => $bigtop_tree->get_authors(),

            year             => $year,
            copyright_holder => $bigtop_tree->get_copyright_holder(),
            license_text     => $bigtop_tree->get_license_text(),
        }
    );

    my ( $base_dir ) = Bigtop::make_module_path( $build_dir, $app_base_name );
    my $base_file    = File::Spec->catfile( $base_dir, 'Model.pm' );
    my $gen_file     = File::Spec->catfile( $base_dir, 'GENModel.pm' );

    Bigtop::write_file( $gen_file, $gen_base_model );

    no warnings qw( Bigtop );
    Bigtop::write_file( $base_file, $base_model, 'no overwrite' );
}

#-----------------------------------------------------------------
#   Packages named in the grammar
#-----------------------------------------------------------------

package # table_block
    table_block;
use strict; use warnings;

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

    my @option_fields;
    while ( @{ $child_output } ) {
        my $field_name = shift @{ $child_output };
        my $options    = shift @{ $child_output };

        push @option_fields, {
            name    => $field_name,
            options => $options,
        };
    }

    # Skip sequences, etc.
    return unless ( $self->{__TYPE__} =~ /tables/ );

    my $table_lookup = $data->{lookup}{tables}{ $self->{__NAME__} };
    my $grand_parent = $self->{__PARENT__}{__PARENT__};

    if ( $table_lookup->{not_for} ) {
        foreach my $skipped_type ( @{ $table_lookup->{not_for}{__ARGS__} } ) {
            return if ( $skipped_type eq 'Model' );
        }
    }

    # get columns sets
    my $lookup       = $table_lookup->{fields};

    my $regular_accessor_columns = $self->walk_postorder(
            'output_regular_accessors_dbix', $lookup
    );
    my $special_accessor_columns = $self->walk_postorder(
            'output_special_accessors_dbix', $lookup
    );
    my $add_columns = $self->walk_postorder(
            'output_add_columns_dbix', $lookup
    );
    my $essentials = $self->walk_postorder(
            'output_essential_fields_dbix', $lookup
    );

    # deal with foreign keys
    my $foreign_tables = $self->walk_postorder(
            'output_foreign_tables_dbix',       $lookup
    );

    # deal with foreign keys pointing toward this table
    my $has_manys = $self->walk_postorder(
            'output_has_manys', $data->{lookup}->{tables}
    );

    my @foreign_table_names;
    my @has_a_list;

    foreach my $entry ( @{ $foreign_tables } ) {
        my $entry_hash = { @{ $entry } };
        push @foreign_table_names, $entry_hash->{table};
        push @has_a_list,          $entry_hash;
    }

    # deal with 3 way joins
    my $three_ways = $grand_parent->walk_postorder(
            'output_has_manys_dbix',
            {
                lookup => $data->{lookup}{join_tables},
                model  => $data->{model_name},
                table  => $self->{__NAME__},
            }
    );

    # Gone Fishing.
    my $table           = $self->{__NAME__};
    $table              =~ s/\./_/;
    my $module_name     = $data->{model_name} . '::' . $table;
    my $gen_pack_name   = $data->{model_name} . '::GEN::' . $table;
    my $alias           = uc $table;
    my $sequence        = $table_lookup->{sequence};
    my $foreign_display = $table_lookup->{foreign_display};

    my $sequence_name;

lib/Bigtop/Backend/Model/GantryDBIxClass.pm  view on Meta::CPAN

        Bigtop::Backend::Model::GantryDBIxClass::gen_table_module(
        {
            base_class_default      => $data->{model_base_class},
            base_package_name       => $data->{model_name},
            package_name            => $module_name,
            gen_package_name        => $gen_pack_name,
            package_alias           => $alias,
            table_name              => $table,
            sequence_name           => $sequence_name,
            primary_key             => $primary_key,
            unique_name             => $unique_name,
            load_components         => $load_components,
            foreign_display_columns => $foreign_display_columns,
            foreign_display_body    => $foreign_display_body,
            regular_accessor_columns=> $regular_accessor_columns,
            special_accessor_columns=> $special_accessor_columns,
            add_columns             => $add_columns,
            essential_columns       => $essentials,
            has_a_list              => \@has_a_list,
            has_manys               => $has_manys,
            three_ways              => $three_ways,
            foreign_tables          => \@foreign_table_names,
            app_name                => $data->{ app_name },
            real_table_name         => $self->{__NAME__},
            option_fields           => \@option_fields,
        }
    );

    # store it
    my $module_file = File::Spec->catfile( $data->{module_dir}, "$table.pm" );
    my $gen_dir     = File::Spec->catdir ( $data->{module_dir}, 'GEN' );
    my $gen_file    = File::Spec->catfile( $gen_dir, "$table.pm" );

    eval {
        no warnings qw( Bigtop );
        Bigtop::write_file( $module_file, $stub_content, 'no overwrite' );
    };
    warn $@ if $@;

    eval {
        Bigtop::write_file( $gen_file, $gen_content );
    };
    warn $@ if $@;

    return [ $table ];
}

package # table_element_block
    table_element_block;
use strict; use warnings;

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

    return unless ( ref( $self->{__BODY__} ) );

    my $field  = $data->{ $self->{__NAME__} };

    return if ( _not_for_model( $field ) );

    return if $field->{ pseudo_value };

    return if ( defined $field->{ accessor }
                    or
                defined $field->{ add_columns } );

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

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

    return unless ( ref( $self->{__BODY__} ) );

    my $field  = $data->{ $self->{__NAME__} };

    return unless ( defined $field->{ accessor } );

    my $special_accessor_name = $field->{ accessor }{ args }->get_first_arg();

    return [
        {
            name     => $self->{__NAME__},
            accessor => $special_accessor_name,
        }
    ];

}

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

    return unless ( ref( $self->{__BODY__} ) );

    my $field  = $data->{ $self->{__NAME__} };

    return unless ( defined $field->{ add_columns } );

    my $args = $field->{ add_columns }{ args };

    my @pairs;
    foreach my $col ( @{ $args } ) {
        my ( $key, $value ) = %{ $col };
        push @pairs, { key => $key, value => $value };
    }

    return [
        {
            name  => $self->{__NAME__},
            pairs => \@pairs,
        }
    ];
}

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

    return unless ( ref( $self->{__BODY__} ) );

    my $field  = $data->{ $self->{__NAME__} };

    if ( $field->{non_essential} ) {
        my $non_essential_value = $field->{non_essential}{args}[0];

        return if ( $non_essential_value );
    }

    return if ( _not_for_model( $field ) );

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

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

    return unless ( ref( $self->{__BODY__} ) );

    my $field  = $data->{ $self->{__NAME__} };

    if ( $field->{refers_to} ) {
        my $foreign_table_name = $field->{refers_to}{args}[0];
        if ( ref( $foreign_table_name ) eq 'HASH' ) {
            ( $foreign_table_name ) = %{ $foreign_table_name };
        }
        $foreign_table_name    =~ s/\./_/;

        return [
            [ column => $self->{__NAME__}, table => $foreign_table_name ]
        ];
    }
    return;
}

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

    return unless ( $self->{__TYPE__} eq 'refered_to_by' );

    my @retval;
    foreach my $arg ( @{ $self->{__ARGS__} } ) {
        my ( $refering_table, $has_many_name, $field_name );

        if ( ref( $arg ) eq 'HASH' ) {
            ( $refering_table, $has_many_name ) = %{ $arg };
        }
        else {
            ( $refering_table, $has_many_name ) = ( $arg, $arg . 's' );
        }

        # Get the name of the field in the table that is refering to this one.
        FIELD_SEARCH:
        foreach my $field ( %{ $data->{$refering_table}->{fields} } ) {
            if ( $data->{$refering_table}->{fields}->{$field}->{refers_to} ) {
                foreach my $refers_to_arg ( @{ $data->{$refering_table}->{fields}->{$field}->{refers_to}->{args} } ) {
                    my $refered_to_table;

                    if ( ref( $refers_to_arg ) eq 'HASH' ) {
                        ( $refered_to_table, undef ) = %{ $refers_to_arg };
                    }
                    else {
                        $refered_to_table = $refers_to_arg;
                    }

                    if ( $refered_to_table eq $self->{__PARENT__}->{__NAME__}) {