package DBIx::BabelKit;

use strict;
use warnings;
use Carp;

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

=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 = "<select name=\"$var_name\"$options>\n";

    # Blank options.
    my $selected = '';
    if ($value eq '') {
        if ($select_prompt eq '') {
            $select_prompt =
                $self->ucwords('code_set', $code_lang, $code_set) . '?';
        }
        $select .= "<option value=\"\" selected>$select_prompt\n";
        $selected = 1;
    } elsif ($blank_prompt ne '') {
        $select .= "<option value=\"\">$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 .= "<option value=\"$code_code\" selected>$code_desc\n";
        } elsif ($row->[3] ne 'd') {
            $select .= "<option value=\"$code_code\">$code_desc\n";
        }
    }

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

    $select .= "</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              = "<br>\n" unless defined $sep;

    # Blank options.
    my $select = '';
    my $selected = '';
    if ($value eq '') {
        $selected = 1;
        if ($blank_prompt ne '') {
            $select .= "<input type=\"radio\" name=\"$var_name\"$options";
            $select .= " value=\"\" checked>$blank_prompt";
        }
    } else {
        if ($blank_prompt ne '') {
            $select .= "<input type=\"radio\" name=\"$var_name\"$options";
            $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 .= "<input type=\"radio\" name=\"$var_name\"$options";
            $select .= " value=\"$code_code\" checked>$code_desc";
        } elsif ($row->[3] ne 'd') {
            $select .= $sep if $select;
            $select .= "<input type=\"radio\" name=\"$var_name\"$options";
            $select .= " value=\"$code_code\">$code_desc";
        }
    }

    # Show missing values.
    if (!$selected) {
        $select .= $sep if $select;
        $select .= "<input type=\"radio\" name=\"$var_name\"$options";
        $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 multiple name=\"$var_name"."[]\"$options";
    $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 .= "<option value=\"$code_code\" selected>$code_desc\n";
            delete $Value->{$code_code};
        } elsif ($row->[3] ne 'd') {
            $select .= "<option value=\"$code_code\">$code_desc\n";
        }
    }

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

    $select .= "</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              = "<br>\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 .= "<input type=\"checkbox\" name=\"$var_name"."[]\"";
            $select .= "$options value=\"$code_code\" checked>$code_desc";
            delete $Value->{$code_code};
        } elsif ($row->[3] ne 'd') {
            $select .= $sep if $select;
            $select .= "<input type=\"checkbox\" name=\"$var_name"."[]\"";
            $select .= "$options value=\"$code_code\">$code_desc";
        }
    }

    # Show missing values.
    for my $code_code ( keys %$Value ) {
        $select .= $sep if $select;
        $select .= "<input type=\"checkbox\" name=\"$var_name"."[]\"";
        $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/&/\&amp;/g;
    $str =~ s/"/\&quot;/g;
    $str =~ s/</\&lt;/g;
    $str =~ s/>/\&gt;/g;
    return $str;
}

1;

__END__
 
=head2 Get code descriptions safe for HTML display
  
  $str = $bk->desc(   $code_set, $code_lang, $code_code);
  $str = $bk->ucfirst($code_set, $code_lang, $code_code);
  $str = $bk->ucwords($code_set, $code_lang, $code_code);
 
=head2 Get code descriptions not safe for HTML display
 
  $str = $bk->render($code_set, $code_lang, $code_code);
  $str = $bk->data(  $code_set, $code_lang, $code_code);
  $str = $bk->param( $code_set, $code_code)
 
=head2 HTML select common options
 
         var_name      => 'start_day'
         value         => $start_day
         default       => 1
         subset        => [ 1, 2, 3, 4, 5 ]
         options       => 'onchange="submit()"'
 
=head2 HTML select single value methods
  
  $str = $bk->select($code_set, $code_lang,
         select_prompt => "Code set description?",
         blank_prompt  => "None"
         );
 
  $str = $bk->radio($code_set, $code_lang,
         blank_prompt  => "None",
         sep           => "<br>\n"
         );
 
=head2 HTML select multiple value methods
 
  $str = $bk->multiple($code_set, $code_lang,
         size          => 10
         );
 
  $str = $bk->checkbox($code_set, $code_lang,
         sep           => "<br>\n"
         );
 
=head2 Code sets
 
  $rows = $bk->lang_set($code_set, $code_lang);
  $rows = $bk->full_set($code_set, $code_lang);
 
=head2 Code table updates
  
  $bk->slave($code_set, $code_code, $code_desc);
 
  $bk->remove($code_set, $code_code);
 
  ( $code_desc, $code_order, $code_flag ) =
    $bk->get($code_set, $code_lang, $code_code);
 
  $bk->put($code_set, $code_lang, $code_code,
           $code_desc, $code_order, $code_flag);
 
=head1 DESCRIPTION

BabelKit is an interface to a universal multilingual
database code table. BabelKit takes all of the
programming work out of maintaining multiple database
code definition sets in multiple languages.

The code administration and translation page lets you define
new virtual code tables, new languages, enter all codes
and their descriptions and then translate them into all
languages of interest.

Perl and PHP classes retrieve the code descriptions
and automatically generate HTML code selection elements
in the user's language.  This makes internationalization
and localization of web sites and database interfaces
much easier.

For news and updates visit the BabelKit home page:

http://www.webbysoft.com/babelkit

For a simpler unilingual universal code table visit the
CodeKit home page:

http://www.webbysoft.com/codekit
 
=head1 AUTHOR

Contact John Gorman at http://www.webbysoft.com
to report bugs, request features, or for database
design and programming assistance.
 
=head1 COPYRIGHT

Copyright (C) 2003 John Gorman.  All rights reserved.
This program is free software; you can redistribute
it and/or modify it under the Lesser GNU General Public
License (LGPL) of the Free Software Foundation.
This means that you can use it for any project.
If you do, send me a note saying how it went!