babelkit.pm

BabelKit是一个通用多语言数据库代码表的接口。它接收维护使用多语言的多个数据库代码定义集中的所有编程工作。代码管理和翻译页可以让开发人员定义新的虚拟代码表

    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 GNU General Public License
(GPL) of the Free Software Foundation.

As a practical matter this means that you can use this
software in house or as part of your web site.  If you
want to distribute this as part of a proprietary package
ask me for a commercial license.