File Coverage

blib/lib/DBIx/BabelKit.pm

Criterion	Covered	Total	%
statement	15	327	4.5
branch	0	156	0.0
condition	0	63	0.0
subroutine	5	30	16.6
pod	2	19	10.5
total	22	595	3.7

package DBIx::BabelKit;

use strict;
use warnings;
use Carp;

use vars qw( $VERSION );
$VERSION = '1.07';

=head1 NAME

DBIx::BabelKit - Universal Multilingual Code Table Interface

=head1 SYNOPSIS

  use DBIx::BabelKit;

  my $bk = new DBIx::BabelKit($dbh,
                 table     => 'bk_code',
                 getparam  => sub { $cgi->param(shift) },
                 getparams => sub { $cgi->param(shift.'[]') }
                 );

=cut

###  See the rest of the pod documentation at the end of this file.  ###

sub new {
    my $class = shift;
    my $dbh = shift;
    my $args = ref($_[0]) ? shift : { @_ };
    my $self = {};
    bless $self, $class;

    croak 'DBIx::BabelKit->new($dbh): $dbh is not an object' unless ref $dbh;
    $self->{dbh} = $dbh;

    $self->{table}     = $args->{table} || 'bk_code';
    $self->{getparam}  = $args->{getparam};
    $self->{getparams} = $args->{getparams};
    $self->{native}    = $self->_find_native;
    croak "DBIx::BabelKit::new: unable to determine native language" .
          " Check table '$self->{table}' for code_admin/code_admin record."
        unless $self->{native};

    return $self;
}


# # #  HTML display methods.

sub desc {
    my $self = shift;
    return &htmlspecialchars( $self->render(@_) );
}

sub ucfirst {
    my $self = shift;
    return CORE::ucfirst( $self->desc(@_) );
}

sub ucwords {
    my $self = shift;
    my $str = $self->desc(@_);
    $str =~ s/(^|\s)([a-z])/$1\u$2/g;
    return $str;
}


# # #  Data methods.

sub render {
    my $self = shift;
    my $code_desc = $self->data(@_);
    if ($code_desc eq '') {
        $code_desc = $self->data($_[0], $self->{native}, $_[2]);
        if ($code_desc eq '') {
            $code_desc = $_[2] || '';
        }
    }
    return $code_desc;
}

sub data {
    my $self = shift;
    my $code_set = shift;
    my $code_lang = shift;
    my $code_code = shift;
    $code_code .= '';   # DBI needs strings here.
    $self->{data_sth} = $self->{dbh}->prepare("
        select  code_desc
        from    $self->{table}
        where   code_set  = ?
        and     code_lang = ?
        and     code_code = ?
    ") unless $self->{data_sth};
    $self->{data_sth}->execute($code_set, $code_lang, $code_code);
    my $code_desc = $self->{data_sth}->fetchrow;
    $code_desc = '' unless defined $code_desc; # Avoid warnings.
    return $code_desc;
}

sub param {
    my $self = shift;
    return $self->data($_[0], $self->{native}, $_[1]);
}


# # #  HTML select single value methods:

sub select {
    my $self = shift;
    my $code_set = shift;
    my $code_lang = shift;
    my $args = ref($_[0]) ? shift : { @_ };

    my $var_name      = $args->{var_name} || $code_set;
    my $value         = $args->{value};
    my $default       = $args->{default};
    my $subset        = $args->{subset};
    my $options       = $args->{options};
    my $select_prompt = $args->{select_prompt};
    my $blank_prompt  = $args->{blank_prompt};

    # Variable setup.
    $value            = $self->_getparam($var_name, $value, $default);
    my $Subset        = &keyme($subset);
    $options          = $options ? " $options" : '';
    $select_prompt    = '' unless defined $select_prompt;
    $blank_prompt     = '' unless defined $blank_prompt;

    # Drop down box.
    my $select = "\n";

    # Blank options.
    my $selected = '';
    if ($value eq '') {
        if ($select_prompt eq '') {
            $select_prompt =
                $self->ucwords('code_set', $code_lang, $code_set) . '?';
        }
        $select .= "$select_prompt\n";
        $selected = 1;
    } elsif ($blank_prompt ne '') {
        $select .= "$blank_prompt\n";
    }

    # Show code set options.
    my $set_list = $self->full_set($code_set, $code_lang);
    for my $row ( @$set_list ) {
        my ($code_code, $code_desc) = @$row;
        next if ($Subset && !$Subset->{$code_code} && $code_code ne $value);
        $code_desc = htmlspecialchars(CORE::ucfirst($code_desc));

        if ($code_code eq $value) {
            $selected = 1;
            $select .= "$code_desc\n";
        } elsif ($row->[3] ne 'd') {
            $select .= "$code_desc\n";
        }
    }

    # Show a missing value.
    if (!$selected) {
        $select .= "$value\n";
    }

    $select .= "\n";
    return $select;
}

sub radio {
    my $self = shift;
    my $code_set = shift;
    my $code_lang = shift;
    my $args = ref($_[0]) ? shift : { @_ };

    my $var_name      = $args->{var_name} || $code_set;
    my $value         = $args->{value};
    my $default       = $args->{default};
    my $subset        = $args->{subset};
    my $options       = $args->{options};
    my $blank_prompt  = $args->{blank_prompt};
    my $sep           = $args->{sep};

    # Variable setup.
    $value            = $self->_getparam($var_name, $value, $default);
    my $Subset        = &keyme($subset);
    $options          = $options ? " $options" : '';
    $blank_prompt     = '' unless defined $blank_prompt;
    $sep              = "\n" unless defined $sep;

    # Blank options.
    my $select = '';
    my $selected = '';
    if ($value eq '') {
        $selected = 1;
        if ($blank_prompt ne '') {
            $select .= "
            $select .= " value=\"\" checked>$blank_prompt";
        }
    } else {
        if ($blank_prompt ne '') {
            $select .= "
            $select .= " value=\"\">$blank_prompt";
        }
    }

    # Show code set options.
    my $set_list = $self->full_set($code_set, $code_lang);
    for my $row ( @$set_list ) {
        my ($code_code, $code_desc) = @$row;
        next if ($Subset && !$Subset->{$code_code} && $code_code ne $value);
        $code_desc = htmlspecialchars(CORE::ucfirst($code_desc));
        if ( $code_code eq $value ) {
            $selected = 1;
            $select .= $sep if $select;
            $select .= "
            $select .= " value=\"$code_code\" checked>$code_desc";
        } elsif ($row->[3] ne 'd') {
            $select .= $sep if $select;
            $select .= "
            $select .= " value=\"$code_code\">$code_desc";
        }
    }

    # Show missing values.
    if (!$selected) {
        $select .= $sep if $select;
        $select .= "
        $select .= " value=\"$value\" checked>$value";
    }

    return $select;
}


# # #  HTML select multiple value methods:

sub multiple {
    my $self = shift;
    my $code_set = shift;
    my $code_lang = shift;
    my $args = ref($_[0]) ? shift : { @_ };

    my $var_name      = $args->{var_name} || $code_set;
    my $value         = $args->{value};
    my $default       = $args->{default};
    my $subset        = $args->{subset};
    my $options       = $args->{options};
    my $size          = $args->{size};

    # Variable setup.
    my $Value         = $self->_getparams($var_name, $value, $default);
    my $Subset        = &keyme($subset);
    $options          = $options ? " $options" : '';

    # Select multiple box.
    my $select = "
    $select .= " size=\"$size\"" if ($size);
    $select .= ">\n";

    # Show code set options.
    my $set_list = $self->full_set($code_set, $code_lang);
    for my $row ( @$set_list ) {
        my ($code_code, $code_desc) = @$row;
        next if ($Subset && !$Subset->{$code_code} && !$Value->{$code_code});
        $code_desc = htmlspecialchars(CORE::ucfirst($code_desc));
        if ( $Value->{$code_code} ) {
            $select .= "$code_desc\n";
            delete $Value->{$code_code};
        } elsif ($row->[3] ne 'd') {
            $select .= "$code_desc\n";
        }
    }

    # Show missing values.
    for my $code_code ( keys %$Value ) {
        $select .= "$code_code\n";
    }

    $select .= "\n";
    return $select;
}

sub checkbox {
    my $self = shift;
    my $code_set = shift;
    my $code_lang = shift;
    my $args = ref($_[0]) ? shift : { @_ };

    my $var_name      = $args->{var_name} || $code_set;
    my $value         = $args->{value};
    my $default       = $args->{default};
    my $subset        = $args->{subset};
    my $options       = $args->{options};
    my $sep           = $args->{sep};

    # Variable setup.
    my $Value         = $self->_getparams($var_name, $value, $default);
    my $Subset        = &keyme($subset);
    $options          = $options ? " $options" : '';
    $sep              = "\n" unless defined $sep;

    # Show code set options.
    my $select;
    my $set_list = $self->full_set($code_set, $code_lang);
    for my $row ( @$set_list ) {
        my ($code_code, $code_desc) = @$row;
        next if ($Subset && !$Subset->{$code_code} && !$Value->{$code_code});
        $code_desc = htmlspecialchars(CORE::ucfirst($code_desc));
        if ( $Value->{$code_code} ) {
            $select .= $sep if $select;
            $select .= "
            $select .= "$options value=\"$code_code\" checked>$code_desc";
            delete $Value->{$code_code};
        } elsif ($row->[3] ne 'd') {
            $select .= $sep if $select;
            $select .= "
            $select .= "$options value=\"$code_code\">$code_desc";
        }
    }

    # Show missing values.
    for my $code_code ( keys %$Value ) {
        $select .= $sep if $select;
        $select .= "
        $select .= "$options value=\"$code_code\" checked>$code_code";
    }

    return $select;
}


# # #  Code Set Methods.

sub lang_set {
    my $self = shift;
    my $code_set = shift;
    my $code_lang = shift;
    $self->{set_sth} = $self->{dbh}->prepare("
        select  code_code,
                code_desc,
                code_order,
                code_flag
        from    $self->{table}
        where   code_set = ?
        and     code_lang = ?
        order by code_order, code_code
    ") unless $self->{set_sth};
    $self->{set_sth}->execute($code_set, $code_lang);
    return $self->{set_sth}->fetchall_arrayref;
}

sub full_set {
    my $self = shift;
    my $code_set = shift;
    my $code_lang = shift;

    my $native = $self->lang_set($code_set, $self->{native});
    return $native if ($code_lang eq $self->{native});

    my $other = $self->lang_set($code_set, $code_lang);
    my $lookup = {};
    for my $row ( @$other ) { $lookup->{$row->[0]} = $row->[1]; }

    for ( my $i = 0; $i < @$native; $i++ ) {
        my $code_desc = $lookup->{$native->[$i][0]};
        $native->[$i][1] = $code_desc if defined $code_desc;
    }

    return $native;
}


# # #  Code Table Updates.

sub slave {
    my $self       = shift;
    my $code_set   = shift;
    my $code_code  = shift;
    my $code_desc  = shift;
    $code_desc = '' unless defined $code_desc;
    my @old = $self->get($code_set, $self->{native}, $code_code);
    if (@old) {
        my ( $old_desc, $old_order, $old_flag ) = @old;
        if ($code_desc ne $old_desc) {
            $self->put($code_set, $self->{native}, $code_code, $code_desc,
                    $old_order, $old_flag);
        }
    } else {
        $self->put($code_set, $self->{native}, $code_code, $code_desc);
    }
}

sub remove {
    my $self       = shift;
    my $code_set   = shift;
    my $code_code  = shift;
    $code_code .= '';   # DBI needs strings here.
    $self->{remove_sth} = $self->{dbh}->prepare("
        delete from $self->{table}
        where   code_set  = ?
        and     code_code = ?
    ") unless $self->{remove_sth};
    $self->{remove_sth}->execute($code_set, $code_code);
}

sub get {
    my $self       = shift;
    my $code_set   = shift;
    my $code_lang  = shift;
    my $code_code  = shift;
    $self->{get_sth} = $self->{dbh}->prepare("
        select  code_desc,
                code_order,
                code_flag
        from    $self->{table}
        where   code_set  = ?
        and     code_lang = ?
        and     code_code = ?
    ") unless $self->{get_sth};
    $self->{get_sth}->execute($code_set, $code_lang, $code_code);
    my @info = $self->{get_sth}->fetchrow_array;
    return @info;
}

sub put {
    my $self       = shift;
    my $code_set   = shift;
    my $code_lang  = shift;
    my $code_code  = shift;
    my $code_desc  = shift;
    my $code_order = shift;
    my $code_flag  = shift;

    # Get the existing code info, if any.
    my @old = $self->get($code_set, $code_lang, $code_code);

    # Field work.
    $code_code  .= '';   # DBI needs strings here.
    $code_desc  .= '';
    if ($code_lang eq $self->{native}) {
        if (  !@old and $code_code =~ /^\d+$/ and
            ( not defined($code_order) or $code_order eq '' ) ) {
            $code_order = $code_code;
        }
        { # Argument "" isn't numeric in int.  Isn't that int's job?
            no warnings;
            $code_order  = int($code_order);
        }
        $code_flag  .= '';
    } else {
        $code_order  = 0;
        $code_flag   = '';
    }

    # Make it so: add, update, or delete.
    if (@old) {
        my ( $old_desc, $old_order, $old_flag ) = @old;
        if ($code_desc ne '') {
            if ($code_desc  ne $old_desc ||
                $code_order ne $old_order ||
                $code_flag  ne $old_flag) {
                $self->_update($code_set, $code_lang, $code_code,
                            $code_desc, $code_order, $code_flag);
            }
        }
        else {
            if ($code_lang eq $self->{native}) {
                $self->remove($code_set, $code_code);
            } else {
                $self->_delete($code_set, $code_lang, $code_code);
            }
        }
    }
    elsif ($code_desc ne '') {
        $self->_insert($code_set, $code_lang, $code_code,
                    $code_desc, $code_order, $code_flag);
    }
}


# # #  Private methods.

sub _find_native {
    my $self = shift;
    my $sth = $self->{dbh}->prepare("
        select  code_lang
        from    $self->{table}
        where   code_set  = 'code_admin'
        and     code_code = 'code_admin'
    ");
    $sth->execute;
    my $native = $sth->fetchrow;
    return $native;
}

sub _insert {
    my $self = shift;
    $self->{insert_sth} = $self->{dbh}->prepare("
        insert into $self->{table} set
            code_set   = ?,
            code_lang  = ?,
            code_code  = ?,
            code_desc  = ?,
            code_order = ?,
            code_flag  = ?
    ") unless $self->{insert_sth};
    $self->{insert_sth}->execute(@_);
}

sub _update {
    my $self       = shift;
    my $code_set   = shift;
    my $code_lang  = shift;
    my $code_code  = shift;
    my $code_desc  = shift;
    my $code_order = shift;
    my $code_flag  = shift;
    $self->{update_sth} = $self->{dbh}->prepare("
        update $self->{table} set
                code_desc  = ?,
                code_order = ?,
                code_flag  = ?
        where   code_set   = ?
        and     code_lang  = ?
        and     code_code  = ?
    ") unless $self->{update_sth};
    $self->{update_sth}->execute(
        $code_desc,
        $code_order,
        $code_flag,
        $code_set,
        $code_lang,
        $code_code
    );
}

sub _delete {
    my $self = shift;
    $self->{delete_sth} = $self->{dbh}->prepare("
        delete from $self->{table}
        where   code_set  = ?
        and     code_lang = ?
        and     code_code = ?
    ") unless $self->{delete_sth};
    $self->{delete_sth}->execute(@_);
}

sub _getparam {
    my $self = shift;
    my $var_name = shift;
    my $value = shift;
    my $default = shift;
    if ( not defined $value ) {
        if ( $self->{getparam} ) {
            $value = &{$self->{getparam}}($var_name);
        }
        $value = $default unless defined $value;
        $value = '' unless defined $value;
    }
    return $value;
}

sub _getparams {
    my $self = shift;
    my $var_name = shift;
    my $value = shift;
    my $default = shift;
    if ( not defined $value ) {
        my $call = $self->{getparams} ? $self->{getparams} : $self->{getparam};
        if ( $call ) {
            $value = [ grep { defined $_ } &$call($var_name) ];
            $value = $value->[0] if ref $value->[0];
        }
        $value = $default unless defined $value;
        $value = '' unless defined $value;
    }
    return &keyme($value) || {};
}

sub keyme {
    my $value = shift;
    return $value if ref($value) eq 'HASH';
    my $Keyhash;
    if (ref($value) eq 'ARRAY') {
        for my $val ( @$value ) { $Keyhash->{$val} = 1; }
    } elsif (defined($value) && $value ne '' && !ref($value)) {
        $Keyhash->{$value} = 1;
    }
    return $Keyhash;
}

sub htmlspecialchars {
    my $str = shift;
    $str =~ s/&/\&/g;
    $str =~ s/"/\"/g;
    $str =~ s/
    $str =~ s/>/\>/g;
    return $str;
}

1;

__END__