# # # # # # bk_admin.pl # # BabelKit Universal Multilingual Code Table translation page. # # Copyright (C) 2003 John Gorman # http://www.webbysoft.com/babelkit # use strict; use warnings; use vars qw( $action $code_set $code_lang $code_lang2 $code_code $code_admin $self_url ); # # # # # # Main dispatch logic. # sub bka_admin_main { print $cgi->header; $self_url = $cgi->url(-absolute=>1); $action = $cgi->param('action') || ''; $code_set = $cgi->param('code_set') || ''; $code_lang = $cgi->param('code_lang') || ''; $code_lang2 = $cgi->param('code_lang2') || ''; $code_code = $cgi->param('code_code') || ''; if (!$code_lang or $code_lang eq $code_lang2) { $code_lang2 = ''; } $code_lang ||= $bkh->{native}; $code_admin = bka_admin_get($code_set); if ($code_admin->{slave}) { $perm_add = 0; $perm_del = 0; } bka_admin_header(); if ($action eq 'New') { bka_form_display(); } elsif ($action eq '' && $code_code ne '') { bka_form_display($code_code); } elsif ($action ne '') { bka_form_aud(); } elsif ($code_set ne '') { bka_set_display(); } else { bka_translations(); } print " "; } # # # # # # Print the page header # sub bka_admin_header { my $title = "BabelKit Universal Code Translation"; $title .= " : $code_set" if ($code_set); if ($action eq 'New') { $title .= " : New"; } elsif ($code_code ne '') { $title .= " : $code_code"; } elsif ($code_set) { $title .= " : $code_lang" if ($code_lang); $title .= "/$code_lang2" if ($code_lang2); } print " $title

$title

Main Translation Page - Help Docs - BabelKit Home

Select a code set and language(s)

"; print $bkh->select('code_set', $bkh->{native}, blank_prompt => 'All Codes' ); print $bkh->select('code_lang', $bkh->{native}); print $bkh->select('code_lang', $bkh->{native}, var_name => 'code_lang2', select_prompt => '(Other)', blank_prompt => '(None)' ); print "

"; } # # # # # # Display the code translation todo list # sub bka_translations { print "BabelKit Translation Sets\n"; # Get the code counts for all language sets. my $code_counts = bka_get_counts(); # Get the code and language sets and print the top header. my $set_rows = $bkh->lang_set('code_set', $bkh->{native}); my $lang_rows = $bkh->lang_set('code_lang', $bkh->{native}); print "
\n";
    printf("%-16s", "");
    for my $lang_row ( @$lang_rows ) {
        next if $lang_row->[3] eq 'd';
        my $lang_cd = $lang_row->[0];
        printf("%6s", $lang_cd);
    }

    # Print the count array.
    my $todo_count = 0;
    my $totals = {};
    for my $set_row ( @$set_rows ) {
        next if $set_row->[3] eq 'd';
        my $set_cd = $set_row->[0];

        my $this_admin = bka_admin_get($set_cd);
        next if $this_admin->{param};

        print "\n$set_cd";
        print ' ' x ( 16 - length($set_cd) );

        my $nat_count = $code_counts->{$set_cd}{$bkh->{native}} || 0;
        for my $lang_row ( @$lang_rows ) {
            next if $lang_row->[3] eq 'd';
            my $lang_cd = $lang_row->[0];
            my $code_count = $code_counts->{$set_cd}{$lang_cd} || 0;
            print ' ' x ( 6 - length($code_count + 0) );
            print "{native}" .
                "&code_lang2=$lang_cd") .
                "\">";
            if ($code_count == $nat_count) {
                printf("%d", $code_count);
            } else {
                printf("%d", $code_count);
                $todo_count += 1;
            }
            print "";

            $totals->{$lang_cd} += $code_count;
        }
    }

    # Print the language totals.
    printf("\n%-16s", "");
    for my $lang_row ( @$lang_rows ) {
        next if $lang_row->[3] eq 'd';
        my $lang_cd = $lang_row->[0];
        printf("%6d", $totals->{$lang_cd});
    }

    print "
\n"; printf("%d language sets need translation work!", $todo_count); } # # # # # # Display a code set # sub bka_set_display { my $edit_lang2 = $code_lang2; $edit_lang2 = '' unless $code_lang eq $bkh->{native}; my $set_desc = $bkh->ucwords('code_set', $bkh->{native}, $code_set); print "$set_desc Code Administration\n"; print "

\n"; print " "; if ($code_set eq 'code_set') { print " "; } else { print " "; } print " "; # Gather the codes in order and truncate the descriptions. my $base_set = $bkh->lang_set($code_set, $code_lang); for my $row ( @$base_set ) { my $desc = $row->[1]; if (length($desc) > 50) { $desc = substr($desc, 0, 50) . '...'; } $row->[1] = DBIx::BabelKit::htmlspecialchars($desc); } if ($code_lang2) { # Add the second language descriptions. my $lang_set = $bkh->lang_set($code_set, $code_lang2); my $lang_lookup = {}; for my $row ( @$lang_set ) { $lang_lookup->{$row->[0]} = $row->[1]; } undef $lang_set; for my $row ( @$base_set ) { my $cd = $row->[0]; my $desc = $lang_lookup->{$row->[0]}; if ($desc ne '') { if (length($desc) > 50) { $desc = substr($desc, 0, 50) . '...'; } $row->[4] = DBIx::BabelKit::htmlspecialchars($desc); } } undef $lang_lookup; } my $colspan = ($code_set eq 'code_set') ? 5 : 3; my $n = 0; for my $row ( @$base_set ) { my ( $code_code, $code_desc, $code_order, $code_flag, $code_desc2 ) = @$row; my $bgcolor = ($n % 2) ? "#6699CC" : "#6699FF"; $n++; print" "; if ($code_set eq 'code_set') { my $this_admin = bka_admin_get($code_code); my $P = $this_admin->{param} ? 'P' : ''; my $S = $this_admin->{slave} ? 'S' : ''; my $M = $this_admin->{multi} ? 'M' : ''; print " "; } else { my $D = $code_flag ? 'D' : ''; print " "; } print " "; if ($code_lang2) { print " "; } } print "
 P   S   M   D   O   Code   Description   Edit 
 $P   $S   $M  $D  $code_order   $code_code   $code_desc    {native}" . "&code_lang2=$edit_lang2" . "&code_code=$code_code") . "\" style=\"color:white;\"> edit 
   $code_desc2   
\n"; my $count = @$base_set; if ($count == 0) { print("

No records.\n\n"); } elsif ($count == 1) { printf("

%d record.\n\n", $count); } else { printf("

%d records.\n\n", $count); } if ($perm_add) { print "

Add new $set_desc code\n"; } } # # # # # # Display the multilanguage code entry/update form. # sub bka_form_display { my $code_code = shift; $code_code = '' unless defined $code_code; # Check for a valid code set or exit. my $set_desc = $bkh->ucwords('code_set', $bkh->{native}, $code_set); bka_error_exit("No Code set specified!") unless $set_desc; print "$set_desc Code Administration\n"; print "

\n"; print "

"; my ( $desc_nat, $code_order, $code_flag ) = $bkh->get($code_set, $bkh->{native}, $code_code); $code_order = '' unless defined $code_order; $code_flag ||= ''; if ($code_set eq 'code_set') { # Code Set Admin parameters my $this_admin = bka_admin_get($code_code); my $checked = ($this_admin->{param}) ? 'checked' : ''; print " "; $checked = ($this_admin->{slave}) ? 'checked' : ''; print " "; $checked = ($this_admin->{multi}) ? 'checked' : ''; print " "; } else { # Deprecated? my $checked = ($code_flag eq 'd') ? "checked" : ""; print " "; } # Order number. print " "; # Make a field for each translation. my $lang_rows; if ($code_admin->{param}) { $lang_rows = [ [ $bkh->{native}, $bkh->desc('code_lang', $bkh->{native}, $code_lang) ] ]; } elsif ($code_lang2) { $lang_rows = [ [ $code_lang , $bkh->desc('code_lang', $bkh->{native}, $code_lang) ], [ $code_lang2 , $bkh->desc('code_lang', $bkh->{native}, $code_lang2) ] ]; } else { $lang_rows = $bkh->lang_set('code_lang', $bkh->{native}); } for my $lang_row ( @$lang_rows ) { my ( $lang_code, $lang_desc, $lang_order, $lang_flag ) = @$lang_row; next if $lang_flag eq 'd'; my $code_desc = $bkh->data($code_set, $lang_code, $code_code); $code_desc = DBIx::BabelKit::htmlspecialchars($code_desc); $lang_desc = ucfirst($lang_desc); print "\n"; print "\n"; if ($lang_code eq $bkh->{native} && $code_admin->{slave}) { print "\n"; } elsif ($code_admin->{multi}) { my @n = split "\n", $code_desc; my $n = @n; $n = 3 if $n < 3; print "\n"; } else { print "\n"; } print "\n"; } # Action items. print "
"; if ($code_code eq '') { print "Add $set_desc code\n"; } else { # Code navigation aids. my $set = $bkh->lang_set($code_set, $bkh->{native}); my ( $n_of, $of_n, $next_cd, $prev_cd, $first_cd, $last_cd ) = bka_place($set, $code_code); print "Edit $set_desc code \"$code_code\" (#$n_of of $of_n)
\n"; print "Next ($next_cd)\n"; print "Prev ($prev_cd)\n"; print "First ($first_cd)\n"; print "Last ($last_cd)\n"; } # Code code. print "
Code "; if ($code_code eq '') { if ($code_set eq 'code_set') { print "\n"; } else { print "\n"; } } else { print "$code_code\n"; print "\n"; } print "
Parameter Set [Parameter sets are not translated]
Slave Set [Slave sets are for translation only]
Multiline Set [Paragraph mode]
Deprecated
Code Order
$lang_desc$code_desc\n"; print "\n
Action "; if ($code_code eq '') { if ($perm_add) { print "\n"; } } else { if ($perm_upd) { print "\n"; } if ($perm_del) { print "\n"; } if ($perm_add) { print "Add new $set_desc code\n"; } } print "
"; } # # # # # # Add / Update / Delete a code. # sub bka_form_aud { my $code_order = $cgi->param('code_order') || ''; my $code_flag = $cgi->param('code_flag') || ''; # Check for validity. if ( ! $bkh->get('code_set', $bkh->{native}, $code_set) ) { bka_error_exit("No Code set specified!"); } if ( $action eq 'Add' && !$perm_add ) { bka_error_exit("No permission to add '$code_set'!"); } if ( $action eq 'Update' && !$perm_upd ) { bka_error_exit("No permission to update '$code_set'!"); } if ( $action eq 'Delete' && !$perm_del ) { bka_error_exit("No permission to delete '$code_set'!"); } if ( $code_code eq '' ) { bka_error_exit("No code specified!"); } unless ( $code_code =~ /^[a-zA-Z_0-9-]+$/ ) { bka_error_exit("Code must consist of [a-zA-Z_0-9-]!"); } unless ( $code_order =~ /^-?[0-9]*$/ ) { bka_error_exit("Code order must be numeric!"); } # Get those language descriptions. my $lang_list = $bkh->lang_set('code_lang', $bkh->{native}); my $code_desc = {}; for my $lang_row ( @$lang_list ) { my $lang_cd = $lang_row->[0]; $code_desc->{$lang_cd} = $cgi->param("code_desc[$lang_cd]"); } # Variable setup. my $nat_exists = $bkh->get($code_set, $bkh->{native}, $code_code); my ( $n_of, $of_n, $next_cd, $prev_cd, $first_cd, $last_cd ); if ($action eq 'Update' || $action eq 'Delete') { my $set = $bkh->lang_set($code_set, $bkh->{native}); ( $n_of, $of_n, $next_cd, $prev_cd, $first_cd, $last_cd ) = bka_place($set, $code_code); } if ($action eq 'Delete') { if (!$nat_exists) { bka_error_exit("No such code '$code_code'!"); } $bkh->remove($code_set, $code_code); print "Record Deleted!

\n"; if ($next_cd eq $code_code) { bka_set_display(); } else { bka_form_display($next_cd); } } elsif ($action eq 'Add' || $action eq 'Update') { if ($action eq 'Add' && $nat_exists) { bka_error_exit("Code '$code_code' already exists!"); } if ($action eq 'Update' && !$nat_exists) { bka_error_exit("No such code '$code_code'!"); } if ($code_desc->{$bkh->{native}} eq '') { bka_error_exit("No native code description specified!"); } # Pump in those fields. for my $lang_row ( @$lang_list ) { my $lang_cd = $lang_row->[0]; my $lang_desc = $code_desc->{$lang_cd}; next unless defined $lang_desc; $lang_desc =~ s/^\s+//; $lang_desc =~ s/\s+$//; $bkh->put($code_set, $lang_cd, $code_code, $lang_desc, $code_order, $code_flag); } # Code Admin fields. if ($code_set eq 'code_set') { my $this_admin = {}; $this_admin->{param} = $cgi->param("this_admin[param]"); $this_admin->{slave} = $cgi->param("this_admin[slave]"); $this_admin->{multi} = $cgi->param("this_admithis_admin[multi]"); bka_admin_put($code_code, $this_admin); } # Whats next. if ($action eq 'Add') { print "Record Added!

\n"; bka_form_display(); } else { print "Record Updated!

\n"; bka_form_display($next_cd); } } else { bka_error_exit("Unknown form action '$action'"); } } # # # # # # Local Functions # # Get the code counts for all language sets. sub bka_get_counts { my $sth = $dbh->prepare(" select code_set, code_lang, count(*) code_count from $bkh->{table} group by code_set, code_lang "); $sth->execute; my $rows = $sth->fetchall_arrayref; my $code_counts = {}; for my $row ( @$rows ) { $code_counts->{$row->[0]}{$row->[1]} = $row->[2]; } return $code_counts; } # Find a code's place in the set. sub bka_place { my $set = shift; my $code_code = shift; my $count = @$set; my $first = $set->[0][0]; my $last = $set->[$count - 1][0]; my $prev; my $next; my $n; for ($n = 0; $n < $count; $n++) { last if $set->[$n][0] eq $code_code; } if ($n == 0) { $prev = $last; if ($count > 1) { $next = $set->[$n + 1][0]; } else { $next = $last; } } elsif ($n == $count - 1) { $prev = $set->[$n - 1][0]; $next = $first; } else { $prev = $set->[$n - 1][0]; $next = $set->[$n + 1][0]; } return ( $n + 1, $count, $next, $prev, $first, $last ); } # Get the code_admin options for the set. sub bka_admin_get { my $code_set = shift; my $code_admin = {}; my @params = split ' ', $bkh->param('code_admin', $code_set); for my $param ( @params ) { my ( $attr, $value ) = split '=', $param; $code_admin->{$attr} = $value; } return $code_admin; } # Put the code_admin options for the set. sub bka_admin_put { my $code_set = shift; my $code_admin = shift || {}; my $params = ''; for my $attr ( sort keys %$code_admin ) { my $value = $code_admin->{$attr}; next unless $attr and $value; $params .= ' ' if $params; $params .= "$attr=$value"; } $bkh->put('code_admin', $bkh->{native}, $code_set, $params); } # Error exit. sub bka_error_exit { my $msg = shift; print "

Error: $msg"; print "\n\n"; exit(); } 1;