File Coverage

lib/SQL/Admin/Driver/Base/Producer.pm

Criterion	Covered	Total	%
statement	86	133	64.6
branch	14	32	43.7
condition	5	11	45.4
subroutine	39	64	60.9
pod	0	52	0.0
total	144	292	49.3

package SQL::Admin::Driver::Base::Producer;

use strict;
use warnings;

our $VERSION = v0.5.0;

######################################################################

use SQL::Admin::Utils qw( refarray refhash );

######################################################################

our $AUTOLOAD;
our $STATEMENT_SEPARATOR = ";\n\n";

######################################################################

my %numbers = (
    int2 => 1,
    int4 => 1,
    int8 => 1,
    real => 1,
);

######################################################################
######################################################################
sub new {                                # ;
    my ($class, %param) = @_;

    bless \ %param, ref $class || $class;
}


######################################################################
######################################################################
sub produce {                            # ;
    my $self = shift;
    local $, = ' ';

    join '', (
        map +($_,  $STATEMENT_SEPARATOR),
        map $self->__process ($_),
        map refarray ($_) ? @$_ : $_,
        @_
    );
}


######################################################################
######################################################################
sub __process {                          # ;
    my ($self, $def) = @_;

    return $def
      unless ref $def;

    return map $self->__apply (%$_), @$def
      if refarray $def;

    return map $self->__call ($_, $def), keys %$def
      if refhash $def;
}


######################################################################
######################################################################
sub __apply {                            # ;
    my ($self, $method, $def, @param) = @_;

    my $retval = join $,, do {
        local $, = ' ';
        local $_ = $def;
        $self->$method ($def, @param)
    };

    ##################################################################

    return $retval unless wantarray;
    grep length $_, $retval;
}


######################################################################
######################################################################
sub __call {                             # ;
    my ($self, $method, $def, @param) = @_;

    return unless refhash $def;
    return unless exists $def->{$method};

    my $retval = join $,, do {
        local $, = ' ';
        local $_ = $def->{$method};
        $self->$method ($def->{$method}, $def)
    };

    ##################################################################

    return $retval unless wantarray;
    grep length $_, $retval;
}


######################################################################
######################################################################
sub __values {                           # ;
    my ($self, $def) = @_;

    join $,, sort $self->__process ($def || {});
}


######################################################################
######################################################################

sub _escape_identifier {                 # ;
    $_[1];
}


######################################################################
######################################################################
sub identifier {                         # ;
    shift->_escape_identifier (@_);
}


######################################################################
######################################################################
sub integer {                            # ;
    $_[1];
}


######################################################################
######################################################################
sub numeric_constant {                   # ;
    $_[1];
}


######################################################################
######################################################################
sub string {                             # ;
    my ($self, $def) = @_;

    $def =~ s/(?=\')/\'/;
    '\'' . $def . '\'';
}


######################################################################
######################################################################
sub data_type {                          # ;
    my ($self, $type, $parent) = @_;

    if (refhash $parent and $parent->{size}) {
        $type .= '(' . $parent->{size};
        $type .= ',' . $parent->{scale} if defined $parent->{scale};
        $type .= ')';
    }

    $type;
}


######################################################################
######################################################################
sub column_name {                        # ;
    shift->identifier (@_);
}


######################################################################
######################################################################
sub column_order {                       # ;
    map uc, grep defined $_, $_[1];
}


######################################################################
######################################################################
sub ordered_column_name {                # ;
    my ($self, $def) = @_;

    join ' ', grep $_, (
        $self->__call (column_name  => $def),
        $self->__call (column_order => $def),
    )
}


######################################################################
######################################################################
sub ordered_column_names {               # ;
    my ($self, $def) = @_;

    join ', ', map $self->ordered_column_name ($_), @$def;
}


######################################################################
######################################################################
sub schema_qualified_name {              # ;
    my ($self, $def) = @_;

    join '.',
      map $self->identifier ($_),
      grep $_,
      @$def{qw{ schema name }};
}


######################################################################
######################################################################
sub index_name {                         # ; alias: schema_qualified_name
    shift->schema_qualified_name (@_);
}


######################################################################
######################################################################
sub sequence_name {                      # ; alias: schema_qualified_name
    shift->schema_qualified_name (@_);
}


######################################################################
######################################################################
sub table_name {                         # ; alias: schema_qualified_name
    shift->schema_qualified_name (@_);
}


######################################################################
######################################################################
sub view_name {                          # ; alias: schema_qualified_name
    shift->schema_qualified_name (@_);
}


######################################################################
######################################################################

sub index_unique {                       # ;
    grep $_[1], 'UNIQUE';
}


######################################################################
######################################################################
sub index_column_list {                  # ;
    my ($self, $def) = @_;

    '(' . $self->__apply (ordered_column_names => $def) . ')';
}

######################################################################
######################################################################
sub index_options {                      # ;
    shift->__values (@_);
}


######################################################################
######################################################################

sub not_null {                           # ;
    grep $_[1], ('NOT', 'NULL');
}


######################################################################
######################################################################
sub column_not_null {                    # ; alias: not_null
    shift->not_null (@_);
}


######################################################################
######################################################################
sub column_definition {                  # ;
    my ($self, $def) = @_;

    my @retval = (
        ' ',
        (map $self->__call ($_ => $def, $def), (
            'column_name',
            'data_type',
            'column_not_null',
            'column_primary_key',
            'column_unique',
            'default_clause',
            'autoincrement',
        ))
    );

    $retval[1] .= ' ' x (22 - length $retval[1]) if @retval > 2;
    $retval[2] .= ' ' x (15 - length $retval[2]) if @retval > 3;

    @retval;
}


######################################################################
######################################################################
sub column_primary_key {                 # ;
    grep $_[1], ('PRIMARY', 'KEY');
}


######################################################################
######################################################################
sub column_unique {                      # ;
    grep $_[1], ('UNIQUE');
}


######################################################################
######################################################################
sub table_content {                      # ;
    my ($self, $def) = @_;
    my $key = 'column_definition';

    my $cols = join ",\n", map '  ' . $_, (
        (map $self->__apply (%$_), grep exists $_->{$key}, @$def),
        (map $self->__apply (%$_), grep !exists $_->{$key}, @$def),
    );

    join "\n", '(', $cols, ')';
}


######################################################################
######################################################################
sub table_options {                      # ;
    shift->__values (@_);
}


######################################################################
######################################################################
sub add_constraint {                     # ;
    my ($self, $def) = @_;

    "\n  ",'ADD', $self->__apply (%$def);
}


######################################################################
######################################################################
sub add_column {                         # ;
    my ($self, $def) = @_;

    'ADD', 'COLUMN', $self->__process ($def);
}


######################################################################
######################################################################
sub alter_column {                       # ;
    my ($self, $def) = @_;
    my @action;

    if (exists $def->{default_clause}) {
        push @action,
          defined $def->{default_clause}
            ? ('SET', $self->__call (default_clause => $def, $def))
            : ('DROP', 'DEFAULT')
            ;
    } elsif (exists $def->{not_null}) {
        push @action, ($def->{not_null} ? 'SET' : 'DROP'), 'NOT', 'NULL';
    }

    ##################################################################

    'ALTER', 'COLUMN', $self->__call (column_name => $def, $def), @action;
}


######################################################################
######################################################################
sub primary_key_constraint {             # ;
    my ($self, $def) = @_;

    (
        $self->__call (constraint_name => $def),
        'PRIMARY',
        'KEY',
        $self->__call (column_list => $def),
    );
}


######################################################################
######################################################################
sub unique_constraint {                  # ;
    my ($self, $def) = @_;

    (
        $self->__call (constraint_name => $def),
        'UNIQUE',
        $self->__call (column_list => $def),
    );
}


######################################################################
######################################################################
sub foreign_key_constraint {             # ;
    my ($self, $def) = @_;

    (
        $self->__call (constraint_name => $def),
        'FOREIGN', 'KEY',
        $self->__call (referencing_column_list => $def),
        "\n  ", 'REFERENCES',
        $self->__call (referenced_table => $def),
        $self->__call (referenced_column_list => $def),
        $self->__call (delete_rule => $def),
        $self->__call (update_rule => $def),
    );
}


######################################################################
######################################################################
sub constraint_name {                    # ;
    my ($self, $def) = @_;

    'CONSTRAINT', $self->identifier ($def), "\n  ";
}


######################################################################
######################################################################
sub column_list {                        # ;
    my ($self, $def) = @_;

    '(' . join (', ', map $self->column_name ($_), @$def) . ')';
}

######################################################################
######################################################################
sub referencing_column_list {            # ; alias: column_list
    shift->column_list (@_);
}


######################################################################
######################################################################
sub referenced_column_list {             # ; alias: column_list
    shift->column_list (@_);
}


######################################################################
######################################################################
sub referenced_table {                   # ; alias: table_name
    shift->table_name (@_);
}


######################################################################
######################################################################

sub statement_insert {                   # ;
    my ($self, $def) = @_;

    join ' ', (
        'INSERT',
        'INTO',
        $self->__call (table_name  => $def),
        $self->__call (column_list => $def),
        (
               $self->__call (insert_value_list => $def)
            || $self->__call (statement_select  => $def)
        )
    );
}


######################################################################
######################################################################
sub insert_value_list {                  # ;
    my ($self, $def) = @_;

    (
        'VALUES', '(',
        join ("),\n  (", (
            map join (', ', map $self->__apply (%$_), @$_), @$def
        )),
        ')',
    )
}


######################################################################
######################################################################
sub insert_values {                      # ;
}

sub statement_select {                   # ;
    my ($self, $def) = @_;

    (
        $self->__call ('select_what', $def),
        $self->__call ('select_from', $def),
        $self->__call ('select_where', $def),
    );
}


######################################################################
######################################################################
sub select_what {                        # ;
    my ($self, $def) = @_;

    'SELECT', join ', ', $self->__process ($def);
}


######################################################################
######################################################################
sub select_from {                        # ;
    my ($self, $def) = @_;

    'FROM', join ', ', $self->__process ($def);
}


######################################################################
######################################################################
sub select_where {                       # ;
    my ($self, $def) = @_;

    'WHERE', join ', ', $self->__apply (%$def);
}


######################################################################
######################################################################
sub subselect {                          # ;
    my ($self, $def) = @_;

    '(', (
        $self->statement_select ($def),
    ), ')', $self->__call ('select_name', $def);
}


######################################################################
######################################################################
sub select_name {                        # ; alias: identifier
    shift->identifier (@_);
}


######################################################################
######################################################################
sub _unary_operator {                    # ;
    my ($self, $name, $def) = @_;

    $name, $self->__process ($def);
}


######################################################################
######################################################################
sub _binary_operator {                   # ;
    my ($self, $name, $def) = @_;

    my @retval = map +($name, $self->__process ($_)), @$def;
    $retval[0] = '(';

    @retval, ')';
}


######################################################################
######################################################################
sub operator_not {                       # ;
    shift->_unary_operator ('NOT', @_);
}


######################################################################
######################################################################
sub operator_exists {                    # ;
    shift->_unary_operator ('EXISTS', @_);
}

######################################################################
######################################################################
sub operator_and {                       # ;
    shift->_binary_operator ('AND', @_);
}


######################################################################
######################################################################
sub operator_equal {                     # ;
    shift->_binary_operator ('=', @_);
}


######################################################################
######################################################################

sub null {                               # ;
    'NULL';
}


######################################################################
######################################################################
sub default {                            # ;
    'DEFAULT';
}


######################################################################
######################################################################

sub DESTROY {                            # ;
}


######################################################################
######################################################################
sub AUTOLOAD {                           # ;
    warn $AUTOLOAD;
    ();
}


######################################################################
######################################################################

package SQL::Admin::Driver::Base::Producer;

1;

__END__