#!/usr/bin/perl
use POSIX qw(getcwd);
use warnings 'all';
use strict;
no strict 'subs';
$| = 1;
use vars qw($COM);
BEGIN {
$COM = $0;
$COM =~ s/^.*\///;
}
our $VERSION;
$VERSION='0.95';
###############################################################################
# PREREQUISITES
###############################################################################
use Encode;
use Locale::VersionedMessages;
use Locale::VersionedMessages::lm;
use Tk;
use Tk::ROText;
use Locale::Country;
use Locale::Language;
use I18N::LangTags::Detect;
###############################################################################
# GLOBAL VARIABLES
###############################################################################
our $message_set = 'lm_gui';
our $default_locale = "en_US";
our $default_dir = (-d "lib" ? "lib" : ".");
our $default_height = 400;
our $default_width = 600;
our $font_family = 'Helvetica';
our $font_weight = 'normal'; # medium bold ...
our $font_slant = 'roman'; # italic
our $font_size = '10'; # 8 12 ...
###############################################################################
# HELP
###############################################################################
=pod
=head1 NAME
lm_gui - simple GUI tool for managine Locale::VersionedMessages lexicons
=head1 SYNOPSIS
This tool can be used to maintain the lexicon files used by the
Locale::VersionedMessages perl module.
=head1 DESCRIPTION
The Locale::VersionedMessages module allows translation tables (i.e. lexicons) for
a set of message to be stored in perl modules to be used in a localized
program.
This tool allows you to create a new set of messages, add lexicons
(i.e. a lookup table for a locale), as well as add or update any
of the messages in the lexicons.
All messages should be entered (and will be stored) as UTF-8 text. Other
encodings are not currently supported.
=head1 LOCALIZED MESSAGES
This tool is localized using the Locale::VersionedMessages tools. It should
be noted that some of the messages contain markup (such as <b>...</b>).
This markup is NOT part of Locale::Mesasages. The markup is handled
internally by this program to make the GUI more user friendly.
=head1 KNOWN BUGS
Because I use standard Tk widgets to create the GUI, some of the
widgets do not exactly look like they ideally would. For example
when browsing for a Message Set Description file in the main window,
a popup appears with a <File name> entry and a <Files of type> menu.
Since we're only interested in .pm files, I would like to remove
the <Files of type> box, but that widget won't allow me to do so.
=head1 BUGS AND QUESTIONS
Please refer to the Locale::VersionedMessages documentation for information on
submitting bug reports or questions to the author.
=head1 SEE ALSO
Locale::VersionedMessages
=head1 LICENSE
This script is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 AUTHOR
Sullivan Beck (sbeck@cpan.org)
=cut
###############################################################################
# MAIN PROGRAM
###############################################################################
# Main window and Frame handling based slightly on a message by zentara:
# http://www.perlmonks.org/?node_id=677105
# The main difference is that that posting kept creating new frames every
# time you switched which represents a memory leak. I create each frame once
# and reuse it.
our $lm = new Locale::VersionedMessages;
$lm->set($message_set);
my @loc = I18N::LangTags::Detect::detect();
my @l;
my %l;
foreach my $loc (@loc) {
if ($loc =~ /^(..)\-(..)$/) {
my($lc,$cc) = (lc($1),uc($2));
my $l = "${lc}_$cc";
if (! exists $l{$l}) {
push(@l,$l);
$l{$l} = 1;
}
if (! exists $l{$lc}) {
push(@l,$lc);
$l{$lc} = 1;
}
}
}
if (@l) {
$lm->search(@l);
}
# $main_window : Tk::Window
# %widgets : name => Widget (all named widgets)
# %data : name => Value (all data entered by user)
# set : message set
# dire : directory
# loc : locale to display
# msgid : message ID to display
# wid,hei,x,y : window dimensions
# add : 1 if we're adding a new message
# lvu : 0 or 1
# ood : 0 or 1
# %set : desc => Messages
# def => Locale
# oth => ( Locale => 1 )
# lex => ( Locale => Messages )
our ($main_window,%widgets,%data,%set);
our ($simp_re,$val_re,$end_re);
# Create and pack the main window.
$main_window = MainWindow->new();
$main_window->configure( -height => $default_height,
-width => $default_width,
);
frame_select('select_operation');
MainLoop;
###############################################################################
# MANAGE_SET WINDOW
# Create the frame.
#
# Frame ->
# 1) [Left Frame] [Right Frame]
#
# Left Frame ->
# L1) Message set: SET
# L2) listbox of message IDs
# sorted by message ID
# single select
# item background = yellow (if out-of-date in lexicon) or red (if missing)
# L3) <Add Message>
#
# Right Frame ->
# R_Loc) [Locale list] ________ <Add Locale>
#
# R_New) Instructions
# Message ID: _________ * (* = editable)
# Description: __________ *
# Substitution Values: __________ *
# Message Text: [textarea]
# <Submit>
#
# R_Def) Instructions
# Message ID: _________ *
# Description: __________ *
# Substitution Values: __________ *
# Message Text: [textarea] *
# Leave Version Unmodified: _
# <Submit>
#
# R_Edit) Instructions
# Message ID: _________
# Description: __________
# Substitution Values: __________
# Text in default lexicon: [ROText]
# Text in current lexicon: [textarea] *
# Mark out-of-date: _
# <Submit>
#
# R_Exit) <Exit>
#
# R_Err) Error message
#
# We won't pack any of the widgets in the right frame because they'll vary
# based on the operation. We'll handle packing in manage_set_pack().
#
sub manage_set_create {
my $frame = $main_window->Frame;
$widgets{'frame_manage_set'} = $frame;
my $submit = $lm->message($message_set,'button: submit');
chomp($submit);
$submit = decode('utf8',$submit);
my $cancel = $lm->message($message_set,'button: cancel');
chomp($cancel);
$cancel = decode('utf8',$cancel);
# 1 Frame
my $frame_left = $frame->Frame()->pack( -padx => 10,
-pady => 10,
-side => 'left',
-fill => 'y',
-expand => 1,
);
my $frame_right = $frame->Frame()->pack( -padx => 10,
-pady => 10,
-side => 'right',
-fill => 'y',
-expand => 1,
);
$widgets{'manage_set:frame_left'} = $frame_left;
$widgets{'manage_set:frame_right'} = $frame_right;
# L1 Message set: SET
my $list_text = $lm->message($message_set,'manage_set: msgid list',
'SET' => $data{'set'});
chomp($list_text);
$list_text = decode('utf8',$list_text);
$frame_left->Label( -text => $list_text )
->pack( -anchor => 'nw',
-fill => 'none',
);
# L1 [MsgID listbox]
my $msgid = listbox_msgid_create($frame_left);
$msgid->pack( -pady => 10,
-anchor => 'nw',
-fill => 'none',
);
$widgets{'manage_set:msgid'} = $msgid;
# L2 <Add Message>
my $add_message = $lm->message($message_set,'button: add message');
chomp($add_message);
$add_message = decode('utf8',$add_message);
$frame_left->Button( -text => $add_message,
-command =>
sub {
manage_set_add_message();
}
)
->pack( -fill => 'none',
-pady => 10,
-anchor => 'ne',
);
########################################
# R_Loc
my $frame_r_loc = $frame_right->Frame;
$widgets{'manage_set:frame_r_loc'} = $frame_r_loc;
# R_Loc [Locale list]
my @loc = ($set{'def'},sort keys %{ $set{'oth'} });
my $loc_sel = $frame_r_loc->Menubutton( -textvariable => \$data{'loc'},
-direction => 'flush',
-relief => 'raised',
);
my $loc_sel_m = $loc_sel->Menu ( -tearoff => 0,
);
$loc_sel->configure( -menu => $loc_sel_m );
foreach my $l (@loc) {
$loc_sel_m->command( -label => $l,
-command => sub { $data{'loc'} = $l;
frame_select('manage_set');
},
);
}
$loc_sel->pack( -side => 'left',
-anchor => 'w' );
$widgets{'manage_set:loc_sel'} = $loc_sel;
$widgets{'manage_set:loc_sel_m'} = $loc_sel_m;
# R_Loc <Add Locale>
my $add_locale = $lm->message($message_set,'button: add locale');
chomp($add_locale);
$add_locale = decode('utf8',$add_locale);
$frame_r_loc->Button( -text => $add_locale,
-command =>
sub {
manage_set_add_locale();
}
)->pack( -side => 'right',
-anchor => 'e' );
# R_Loc [entry]
my $loc_ent = $frame_r_loc->Entry( -width => 10,
-background => 'white' )
->pack( -side => 'right',
-anchor => 'e' );
$widgets{'manage_set:loc_ent'} = $loc_ent;
########################################
# R_New
my $frame_r_new = $frame_right->Frame;
$widgets{'manage_set:frame_r_new'} = $frame_r_new;
# R_New Instructions
my $new_mess = message_strip_newlines('manage_set: new mess instructions');
my $new_mess_i = text_widget('ROText',$frame_r_new,8,0);
$new_mess_i->pack( -expand => 'yes',
-fill => 'both',
-pady => 10,
);
insert_markup($new_mess_i,$new_mess);
# R_New <table>
my $frame_r_new_1 = $frame_r_new->Frame->pack();
# R_New Nessage ID: [entry]
my $new_msgid_text = $lm->message($message_set,'manage_set: msgid');
chomp($new_msgid_text);
$new_msgid_text = decode('utf8',$new_msgid_text);
my $new_msgid_label = $frame_r_new_1->Label( -text => "$new_msgid_text:" );
$new_msgid_label->grid( -row => 1, -column => 1, -sticky => 'w' );
my $new_msgid_ent = $frame_r_new_1->Entry( -width => 50,
-background => 'white' );
$new_msgid_ent->grid( -row => 1, -column => 2, -sticky => 'w' );
$widgets{'manage_set:new_msgid_ent'} = $new_msgid_ent;
# R_New Substitution Values: [entry]
my $new_subst_text = $lm->message($message_set,'manage_set: subst');
chomp($new_subst_text);
$new_subst_text = decode('utf8',$new_subst_text);
my $new_subst_label = $frame_r_new_1->Label( -text => "$new_subst_text:" );
$new_subst_label->grid( -row => 2, -column => 1, -sticky => 'w' );
my $new_subst_ent = $frame_r_new_1->Entry( -width => 50,
-background => 'white' );
$new_subst_ent->grid( -row => 2, -column => 2, -sticky => 'w' );
$widgets{'manage_set:new_subst_ent'} = $new_subst_ent;
# R_New Description: [entry]
my $new_desc_text = $lm->message($message_set,'manage_set: desc');
chomp($new_desc_text);
$new_desc_text = decode('utf8',$new_desc_text);
my $new_desc_label = $frame_r_new_1->Label( -text => "$new_desc_text:" );
$new_desc_label->grid( -row => 3, -column => 1, -sticky => 'w' );
my $new_desc_ent = text_widget('',$frame_r_new_1,3);
$new_desc_ent->grid( -row => 3, -column => 2, -sticky => 'w' );
$widgets{'manage_set:new_desc_ent'} = $new_desc_ent;
# R_New Message: [entry]
my $new_def_text = $lm->message($message_set,'manage_set: def');
chomp($new_def_text);
$new_def_text = decode('utf8',$new_def_text);
my $new_def_label = $frame_r_new_1->Label( -text => "$new_def_text:" );
$new_def_label->grid( -row => 4, -column => 1, -sticky => 'w' );
my $new_def_ent = text_widget('',$frame_r_new_1,15);
$new_def_ent->grid( -row => 4, -column => 2, -sticky => 'w' );
$widgets{'manage_set:new_def_ent'} = $new_def_ent;
# R_New <Submit> <Cancel>
my $frame_r_new_butt = $frame_r_new->Frame()->pack( -pady => 10 );
$frame_r_new_butt->Button( -text => $submit,
-command =>
sub {
manage_set_submit_new();
}
)->pack( -side => 'left', -pady => 10 );
$frame_r_new_butt->Button( -text => $cancel,
-command =>
sub {
manage_set_cancel_new();
}
)->pack( -side => 'right', -pady => 10 );
########################################
# R_Def
my $frame_r_def = $frame_right->Frame;
$widgets{'manage_set:frame_r_def'} = $frame_r_def;
# R_Def Instructions
my $def_mess = message_strip_newlines('manage_set: def mess instructions');
my $def_mess_i = text_widget('ROText',$frame_r_def,10,0);
$def_mess_i->pack( -expand => 'yes',
-fill => 'both',
-pady => 10,
);
insert_markup($def_mess_i,$def_mess);
# R_Def <table>
my $frame_r_def_1 = $frame_r_def->Frame->pack();
# R_Def Nessage ID: [entry]
my $def_msgid_text = $lm->message($message_set,'manage_set: msgid');
chomp($def_msgid_text);
$def_msgid_text = decode('utf8',$def_msgid_text);
my $def_msgid_label = $frame_r_def_1->Label( -text => "$def_msgid_text:" );
$def_msgid_label->grid( -row => 1, -column => 1, -sticky => 'w' );
my $def_msgid_ent = $frame_r_def_1->Entry( -width => 50,
-background => 'white' );
$def_msgid_ent->grid( -row => 1, -column => 2, -sticky => 'w' );
$widgets{'manage_set:def_msgid_ent'} = $def_msgid_ent;
# R_Def Substitution Values: [entry]
my $def_subst_text = $lm->message($message_set,'manage_set: subst');
chomp($def_subst_text);
$def_subst_text = decode('utf8',$def_subst_text);
my $def_subst_label = $frame_r_def_1->Label( -text => "$def_subst_text:" );
$def_subst_label->grid( -row => 2, -column => 1, -sticky => 'w' );
my $def_subst_ent = $frame_r_def_1->Entry( -width => 50,
-background => 'white' );
$def_subst_ent->grid( -row => 2, -column => 2, -sticky => 'w' );
$widgets{'manage_set:def_subst_ent'} = $def_subst_ent;
# R_Def Description: [entry]
my $def_desc_text = $lm->message($message_set,'manage_set: desc');
chomp($def_desc_text);
$def_desc_text = decode('utf8',$def_desc_text);
my $def_desc_label = $frame_r_def_1->Label( -text => "$def_desc_text:" );
$def_desc_label->grid( -row => 3, -column => 1, -sticky => 'w' );
my $def_desc_ent = text_widget('',$frame_r_def_1,3);
$def_desc_ent->grid( -row => 3, -column => 2, -sticky => 'w' );
$widgets{'manage_set:def_desc_ent'} = $def_desc_ent;
# R_Def Message: [entry]
my $def_def_text = $lm->message($message_set,'manage_set: def');
chomp($def_def_text);
$def_def_text = decode('utf8',$def_def_text);
my $def_def_label = $frame_r_def_1->Label( -text => "$def_def_text:" );
$def_def_label->grid( -row => 4, -column => 1, -sticky => 'w' );
my $def_def_ent = text_widget('',$frame_r_def_1,15);
$def_def_ent->grid( -row => 4, -column => 2, -sticky => 'w' );
$widgets{'manage_set:def_def_ent'} = $def_def_ent;
# R_Def Leave Version Unmodified: _
my $def_lvu_text = $lm->message($message_set,
'manage_set: leave version unmodified');
chomp($def_lvu_text);
$def_lvu_text = decode('utf8',$def_lvu_text);
my $def_lvu_label = $frame_r_def_1->Label( -text => "$def_lvu_text:" );
$def_lvu_label->grid( -row => 5, -column => 1, -sticky => 'w' );
my $def_lvu_chk = $frame_r_def_1->Checkbutton( -variable => \$data{'lvu'} );
$def_lvu_chk->grid( -row => 5, -column => 2, -sticky => 'w' );
# R_Def <Submit> <Cancel>
my $frame_r_def_butt = $frame_r_def->Frame()->pack( -pady => 10 );
$frame_r_def_butt->Button( -text => $submit,
-command =>
sub {
manage_set_submit_def();
}
)->pack( -side => 'left', -pady => 10 );
$frame_r_def_butt->Button( -text => $cancel,
-command =>
sub {
manage_set_cancel_def();
}
)->pack( -side => 'right', -pady => 10 );
########################################
# R_Edit
my $frame_r_edit = $frame_right->Frame;
$widgets{'manage_set:frame_r_edit'} = $frame_r_edit;
# R_Edit Instructions
my $edit_mess = message_strip_newlines('manage_set: edit mess instructions');
my $edit_mess_i = text_widget('ROText',$frame_r_edit,12,0);
$edit_mess_i->pack( -expand => 'yes',
-fill => 'both',
-pady => 10,
);
insert_markup($edit_mess_i,$edit_mess);
# R_Edit <table>
my $frame_r_edit_1 = $frame_r_edit->Frame->pack();
# R_Edit Nessage ID: Value
my $edit_msgid_text = $lm->message($message_set,'manage_set: msgid');
chomp($edit_msgid_text);
$edit_msgid_text = decode('utf8',$edit_msgid_text);
my $edit_msgid_label = $frame_r_edit_1->Label( -text => "$edit_msgid_text:" );
$edit_msgid_label->grid( -row => 1, -column => 1, -sticky => 'nw' );
my $edit_msgid_ent = text_widget('ROText',$frame_r_edit_1,-1,0);
$edit_msgid_ent->grid( -row => 1, -column => 2, -sticky => 'nw' );
$widgets{'manage_set:edit_msgid_ent'} = $edit_msgid_ent;
# R_Edit Substitution Values: Value
my $edit_subst_text = $lm->message($message_set,'manage_set: subst');
chomp($edit_subst_text);
$edit_subst_text = decode('utf8',$edit_subst_text);
my $edit_subst_label = $frame_r_edit_1->Label( -text => "$edit_subst_text:" );
$edit_subst_label->grid( -row => 2, -column => 1, -sticky => 'nw' );
my $edit_subst_ent = text_widget('ROText',$frame_r_edit_1,-1,0);
$edit_subst_ent->grid( -row => 2, -column => 2, -sticky => 'nw' );
$widgets{'manage_set:edit_subst_ent'} = $edit_subst_ent;
# R_Edit Description: Value
my $edit_desc_text = $lm->message($message_set,'manage_set: desc');
chomp($edit_desc_text);
$edit_desc_text = decode('utf8',$edit_desc_text);
my $edit_desc_label = $frame_r_edit_1->Label( -text => "$edit_desc_text:" );
$edit_desc_label->grid( -row => 3, -column => 1, -sticky => 'nw' );
my $edit_desc_ent = text_widget('ROText',$frame_r_edit_1,-3,0);
$edit_desc_ent->grid( -row => 3, -column => 2, -sticky => 'nw' );
$widgets{'manage_set:edit_desc_ent'} = $edit_desc_ent;
# R_Edit Def Message: [entry]
my $edit_def_text = $lm->message($message_set,'manage_set: def');
chomp($edit_def_text);
$edit_def_text = decode('utf8',$edit_def_text);
my $edit_def_label = $frame_r_edit_1->Label( -text => "$edit_def_text:" );
$edit_def_label->grid( -row => 4, -column => 1, -sticky => 'nw' );
my $edit_def_ent = text_widget('ROText',$frame_r_edit_1,15);
$edit_def_ent->grid( -row => 4, -column => 2, -sticky => 'nw' );
$widgets{'manage_set:edit_def_ent'} = $edit_def_ent;
# R_Edit Curr Message: [entry]
my $edit_curr_text = $lm->message($message_set,'manage_set: curr');
chomp($edit_curr_text);
$edit_curr_text = decode('utf8',$edit_curr_text);
my $edit_curr_label = $frame_r_edit_1->Label( -text => "$edit_curr_text:" );
$edit_curr_label->grid( -row => 5, -column => 1, -sticky => 'nw' );
my $edit_curr_ent = text_widget('',$frame_r_edit_1,15);
$edit_curr_ent->grid( -row => 5, -column => 2, -sticky => 'nw' );
$widgets{'manage_set:edit_curr_ent'} = $edit_curr_ent;
# R_edit Mark Out-of-Date: _
my $edit_ood_text = $lm->message($message_set,
'manage_set: mark ood');
chomp($edit_ood_text);
$edit_ood_text = decode('utf8',$edit_ood_text);
my $edit_ood_label = $frame_r_edit_1->Label( -text => "$edit_ood_text:" );
$edit_ood_label->grid( -row => 6, -column => 1, -sticky => 'nw' );
my $edit_ood_val;
my $edit_ood_chk = $frame_r_edit_1->Checkbutton( -variable =>
\$data{'ood'} );
$edit_ood_chk->grid( -row => 6, -column => 2, -sticky => 'nw' );
# R_Edit <Submit> <Cancel>
my $frame_r_edit_butt = $frame_r_edit->Frame()->pack( -pady => 10 );
$frame_r_edit_butt->Button( -text => $submit,
-command =>
sub {
manage_set_submit_edit();
}
)->pack( -side => 'left', -pady => 10 );
$frame_r_edit_butt->Button( -text => $cancel,
-command =>
sub {
manage_set_cancel_edit();
}
)->pack( -side => 'right', -pady => 10 );
########################################
# R_Exit <Exit>
my $frame_r_exit = $frame_right->Frame;
$widgets{'manage_set:frame_r_exit'} = $frame_r_exit;
my $exit = $lm->message($message_set,'button: exit');
chomp($exit);
$exit = decode('utf8',$exit);
$frame_r_exit->Button( -text => $exit,
-command =>
sub {
exit
})->pack( -side => 'right', -padx => 20 );
########################################
# R_Err Error message
my $frame_r_err = $frame_right->Frame;
$widgets{'manage_set:frame_r_err'} = $frame_r_err;
my $err_msg = text_widget('ROText',$frame_r_err,5,'err');
$err_msg->pack( -expand => 'yes',
-fill => 'both',
-pady => 10,
);
$widgets{'manage_set:err'} = $err_msg;
}
# Clear/reset any data.
#
sub manage_set_clear {
# Load the lexicon if necessary.
if (! exists $set{'lex'}{$data{'loc'}}) {
$set{'lex'}{$data{'loc'}} =
Locale::VersionedMessages::lm::_lexicon_read($data{'set'},$data{'dire'},
$data{'loc'});
}
# Clear the 'Add Locale' window.
if ($data{'add'}) {
$widgets{'manage_set:new_msgid_ent'}->delete(0,'end');
$widgets{'manage_set:new_desc_ent'}->delete('1.0','end');
$widgets{'manage_set:new_subst_ent'}->delete(0,'end');
$widgets{'manage_set:new_def_ent'}->delete('1.0','end');
return;
}
# Handle all the other types of windows.
my $msgid = $data{'msgid'};
return if (! $msgid);
my $def = $set{'def'};
my $loc = $data{'loc'};
if ($loc eq $def) {
# Default message
$widgets{'manage_set:def_msgid_ent'}->delete(0,'end');
$widgets{'manage_set:def_msgid_ent'}->insert('end',$msgid);
$widgets{'manage_set:def_desc_ent'}->delete('1.0','end');
$widgets{'manage_set:def_desc_ent'}->insert
('end',decode('utf-8',$set{'desc'}{$msgid}{'desc'}));
$widgets{'manage_set:def_subst_ent'}->delete(0,'end');
$widgets{'manage_set:def_subst_ent'}->insert
('end',join(' ',@{ $set{'desc'}{$msgid}{'vals'} }))
if ($set{'desc'}{$msgid}{'vals'});
$widgets{'manage_set:def_def_ent'}->delete('1.0','end');
$widgets{'manage_set:def_def_ent'}->insert
('end',decode('utf-8',$set{'lex'}{$def}{$msgid}{'text'}));
$data{'lvu'} = 0;
} else {
# Current locale
$widgets{'manage_set:edit_msgid_ent'}->delete('1.0','end');
$widgets{'manage_set:edit_msgid_ent'}->insert('end',$msgid);
$widgets{'manage_set:edit_desc_ent'}->delete('1.0','end');
$widgets{'manage_set:edit_desc_ent'}->insert
('end',decode('utf-8',$set{'desc'}{$msgid}{'desc'}));
$widgets{'manage_set:edit_subst_ent'}->delete('1.0','end');
$widgets{'manage_set:edit_subst_ent'}->insert
('end',join(' ',@{ $set{'desc'}{$msgid}{'vals'} }))
if ($set{'desc'}{$msgid}{'vals'});
$widgets{'manage_set:edit_def_ent'}->delete('1.0','end');
$widgets{'manage_set:edit_def_ent'}->insert
('end',$set{'lex'}{$def}{$msgid}{'text'});
$widgets{'manage_set:edit_curr_ent'}->delete('1.0','end');
$widgets{'manage_set:edit_curr_ent'}->insert
('end',decode('utf-8',$set{'lex'}{$loc}{$msgid}{'text'}))
if (exists $set{'lex'}{$loc}{$msgid} &&
$set{'lex'}{$loc}{$msgid}{'text'});
$data{'ood'} = 0;
}
# Clear the locale entry
$widgets{'manage_set:loc_ent'}->delete(0,'end');
}
# The <Add Locale> button was pressed.
#
sub manage_set_add_locale {
my $loc = $widgets{'manage_set:loc_ent'}->get;
chomp($loc);
# Make sure that the default locale was correctly specified.
my $err = check_locale($loc);
if ($err) {
frame_select('manage_set',$err);
return;
}
# Create the lexicon.
Locale::VersionedMessages::lm::_lexicon_create($data{'set'},$data{'dire'},$loc);
Locale::VersionedMessages::lm::_set_write($data{'set'},$data{'dire'},$set{'desc'},
$set{'def'},
sort(keys %{ $set{'oth'} },$loc));
$set{'oth'}{$loc} = 1;
$data{'loc'} = $loc;
my @loc = ( $set{'def'}, sort(keys %{ $set{'oth'} }) );
my $loc_sel_m = $widgets{'manage_set:loc_sel_m'};
$loc_sel_m->delete(0,'end');
foreach my $l (@loc) {
$loc_sel_m->command( -label => $l,
-command => sub { $data{'loc'} = $l;
frame_select('manage_set');
},
);
}
frame_select('manage_set');
}
# The <Cancel> button was pressed in a new message operation.
#
sub manage_set_cancel_new {
$data{'add'} = 0;
my @msgid = sort keys %{ $set{'desc'} };
$data{'msgid'} = $msgid[0];
frame_select('manage_set');
}
# The <Submit> button was pressed in a new message operation.
#
sub manage_set_submit_new {
# Make sure that the Message ID does not already exist and that
# the default text was entered.
my $msgid = $widgets{'manage_set:new_msgid_ent'}->get();
if (exists $set{'desc'}{$msgid}) {
my $err = $lm->message($message_set,'manage_set: new mess msgid err');
frame_select('manage_set',$err);
return;
}
my $desc = $widgets{'manage_set:new_desc_ent'}->get('1.0','end');
$desc = '' if (! $desc);
my $vals = $widgets{'manage_set:new_subst_ent'}->get();
my $text = $widgets{'manage_set:new_def_ent'}->get('1.0','end');
while (chomp($text)) {};
if (! $text) {
my $err = $lm->message($message_set,'manage_set: new mess def err');
frame_select('manage_set',$err);
return;
}
# Save the message.
my $loc = $set{'def'};
$set{'desc'}{$msgid}{'desc'} = $desc;
$set{'desc'}{$msgid}{'vals'} = [ split(/\s+/,$vals) ] if ($vals);
Locale::VersionedMessages::lm::_set_write($data{'set'},$data{'dire'},$set{'desc'},
$loc,sort(keys %{ $set{'oth'} }));
$set{'lex'}{$set{'def'}}{$msgid} = { 'vers' => 2,
'text' => $text };
Locale::VersionedMessages::lm::_lexicon_write($data{'set'},$data{'dire'},$loc,
$set{'lex'}{$loc});
$data{'add'} = 0;
$data{'msgid'} = $msgid;
frame_select('manage_set');
}
# The <Cancel> button was pressed in an edit default message operation.
#
sub manage_set_cancel_def {
frame_select('manage_set');
}
# The <Submit> button was pressed in a edit default message operation.
#
sub manage_set_submit_def {
my($lvu) = $data{'lvu'};
my $set = 0; # 1 if a change has been made to the set desc.
my @lex = (); # a list of changed lexicons
my $upd = 0; # 1 if we will increment the default version
# Has message ID changed? If so, we'll need to change it in the
# set description AND in ALL the lexicons where it is defined. This
# does not imply a new version of the message.
my $old = $data{'msgid'};
my $new = $widgets{'manage_set:def_msgid_ent'}->get();
if ($old ne $new) {
$set = 1;
$set{'desc'}{$new} = $set{'desc'}{$old};
delete $set{'desc'}{$old};
foreach my $lex ($set{'def'},sort keys %{ $set{'oth'} }) {
# Load the lexicon if necessary.
if (! exists $set{'lex'}{$lex}) {
$set{'lex'}{$lex} =
Locale::VersionedMessages::lm::_lexicon_read($data{'set'},$data{'dire'},$lex);
}
if (exists $set{'lex'}{$old}) {
$set{'lex'}{$new} = $set{'lex'}{$old};
delete $set{'lex'}{$old};
push(@lex,$lex);
}
}
# Replace the items in the listbox
$widgets{'manage_set:msgid'}->delete(0,'end');
$widgets{'manage_set:msgid'}->insert('end',sort keys %{ $set{'desc'} });
}
# If the description has changed, change the set, but no lexicons need
# to be updated, and the version doesn't need to change.
$old = $set{'desc'}{$data{'msgid'}}{'desc'};
$new = $widgets{'manage_set:def_desc_ent'}->get('1.0','end');
$new = encode('UTF-8',$new);
if ($old ne $new) {
$set = 1;
$set{'desc'}{$data{'msgid'}}{'desc'} = $new;
}
# If the substitution values have changed, change the set. We also MUST
# increment the version of the default message since all lexicons will have
# to be corrected.
$old = (exists $set{'desc'}{$data{'msgid'}}{'vals'} ?
join(' ',@{ $set{'desc'}{$data{'msgid'}}{'vals'} }) : '');
$new = $widgets{'manage_set:def_subst_ent'}->get();
if ($old ne $new) {
$set = 1;
$upd = 1;
if ($new) {
$set{'desc'}{$data{'msgid'}}{'vals'} = [ split(/\s+/,$new) ];
} else {
delete $set{'desc'}{$data{'msgid'}}{'vals'};
}
push(@lex,$data{'loc'}) if (! @lex);
}
# If the text of the default message has changed, change the default lexicon.
# Increment the version unless the <Leave Version Unchanged> checkbox was
# checked. Ignore trailing newlines (which get added for some reason).
$old = $set{'lex'}{$set{'def'}}{$data{'msgid'}}{'text'};
$new = $widgets{'manage_set:def_def_ent'}->get('1.0','end');
$new = encode('UTF-8',$new);
while (chomp($new)) {};
$new = "$new\n";
if ($old ne $new) {
$upd = 1 unless ($lvu);
$set{'lex'}{$set{'def'}}{$data{'msgid'}}{'text'} = $new;
push(@lex,$set{'def'}) if (! @lex);
}
# Save the set, if necessary.
if ($set) {
Locale::VersionedMessages::lm::_set_write($data{'set'},$data{'dire'},$set{'desc'},
$set{'def'},sort keys %{ $set{'oth'} });
}
if ($upd) {
$set{'lex'}{$set{'def'}}{$data{'msgid'}}{'vers'}++;
push(@lex,$set{'def'}) if (! @lex);
}
foreach my $lex (@lex) {
Locale::VersionedMessages::lm::_lexicon_write($data{'set'},$data{'dire'},$lex,
$set{'lex'}{$lex});
}
frame_select('manage_set');
}
# The <Cancel> button was pressed in a edit message operation.
#
sub manage_set_cancel_edit {
frame_select('manage_set');
}
# The <Submit> button was pressed in a edit message operation.
#
sub manage_set_submit_edit {
my($ood) = $data{'ood'};
# If the text of the message has changed, change the current lexicon.
# Set the version to the default version unless <Mark out-of-date>
# was checked, in which case set the version to be one less than the
# default version (regardless of what it was before).
#
# It is also allowed to mark the version as out-of-date without
# otherwise modifying it.
my $loc = $data{'loc'};
my $old = $set{'lex'}{$loc}{$data{'msgid'}}{'text'}
if (exists $set{'lex'}{$loc}{$data{'msgid'}});
$old = '' if (! $old);
my $new = $widgets{'manage_set:edit_curr_ent'}->get('1.0','end');
while (chomp($new)) {};
$new = "$new\n";
$new = encode('UTF-8',$new);
return if ($old eq $new && ! $ood);
# Update the text, if it has changed. Also, set the version.
if ($old ne $new) {
$set{'lex'}{$loc}{$data{'msgid'}}{'text'} = $new;
}
$set{'lex'}{$loc}{$data{'msgid'}}{'vers'} =
$set{'lex'}{$set{'def'}}{$data{'msgid'}}{'vers'};
$set{'lex'}{$loc}{$data{'msgid'}}{'vers'}-- if ($ood);
Locale::VersionedMessages::lm::_lexicon_write($data{'set'},$data{'dire'},$loc,
$set{'lex'}{$loc});
frame_select('manage_set');
}
# The <Add Message> button was pressed.
#
sub manage_set_add_message {
# Switch to default locale, with no message ID selected.
$data{'loc'} = $set{'def'};
$data{'msgid'} = '';
$data{'add'} = 1;
frame_select('manage_set');
}
sub manage_set_unpack {
# Since unpack is called before create, only unpack if the frame is
# already created.
return if (! exists $widgets{'manage_set:frame_right'});
my $f = $widgets{'manage_set:frame_right'};
my @w = $f->packSlaves;
foreach my $wid (@w) {
$wid->packForget;
}
}
sub manage_set_pack {
my($err) = @_;
while (1) {
# If we're adding a new message, then the only frame we need
# is the new message frame. All others get the locale frame.
if ($data{'add'}) {
$widgets{'manage_set:frame_r_new'}->pack( -fill => 'x', -expand => 1 );
$widgets{'manage_set:frame_r_exit'}->pack( -fill => 'x', -expand => 1 );
last;
}
# Add the locale list frame.
$widgets{'manage_set:frame_r_loc'}->pack( -fill => 'x', -expand => 1 );
# If no message is selected, we have created an empty
# locale.
if (! $data{'msgid'}) {
$widgets{'manage_set:frame_r_exit'}->pack( -fill => 'x', -expand => 1 );
last;
}
# Update the message ID list and locale list
listbox_msgid_update();
# Pack the appropriate frame.
if ($data{'loc'} eq $set{'def'}) {
$widgets{'manage_set:frame_r_def'}->pack( -fill => 'x', -expand => 1 );
} else {
$widgets{'manage_set:frame_r_edit'}->pack( -fill => 'x', -expand => 1 );
}
$widgets{'manage_set:frame_r_exit'}->pack( -fill => 'x', -expand => 1 );
last;
}
# Error message (if any)
if ($err) {
my $w = $widgets{'manage_set:err'};
$w->delete('1.0','end');
insert_markup($w,$err);
$widgets{'manage_set:frame_r_err'}->pack( -fill => 'x', -expand => 1 );
}
}
###############################################################################
# MSGID LISTBOX
# This creates a scrolled listbox widget containing all of the message
# IDs, one per line.
#
sub listbox_msgid_create {
my($frame) = @_;
# Read the set description
if (! exists $set{'desc'}) {
my($set_messages,$def_locale,@oth_locale) =
Locale::VersionedMessages::lm::_set_read($data{'set'},$data{'dire'});
$set{'desc'} = $set_messages;
$set{'def'} = $def_locale;
$set{'oth'} = { map {$_,1} @oth_locale };
$data{'loc'} = $def_locale;
}
# Create the widget
my $w = $frame->Scrolled( 'Listbox',
-setgrid => 1,
-background => 'light gray',
-selectmode => 'single',
-width => 30,
-height => 30,
-scrollbars => 'se',
-exportselection => 0
);
$w->bind('<<ListboxSelect>>' =>
sub {
my @sel = $w->curselection;
my @msgid = sort keys %{ $set{'desc'} };
$data{'msgid'} = $msgid[$sel[0]];
frame_select('manage_set');
}
);
my @msgid = sort keys %{ $set{'desc'} };
if (@msgid) {
$w->insert('end',@msgid);
$data{'msgid'} = $msgid[0];
}
return $w;
}
# Update the listbox widget. Set the background color for all items, and
# update the selection.
#
sub listbox_msgid_update {
my $w = $widgets{'manage_set:msgid'};
$w->delete(0,'end');
my @msgid = sort keys %{ $set{'desc'} };
return if (! @msgid);
$w->insert('end',@msgid);
my $i = 0;
my %msgid = map { $_,$i++ } @msgid;
# Update the background colors
my $def = $set{'def'};
my $loc = $data{'loc'};
if ($loc eq $def) {
# In default locale, everything is gray
for (my $i=0; $i<=$#msgid; $i++) {
$w->itemconfigure($i,
-background => '#bbbbbb',
-foreground => 'black',
-selectbackground => '#ececec',
-selectforeground => 'black',
);
}
} else {
# In other locale, up-to-date is gray, out-of-date is yellow,
# missing is red.
for (my $i=0; $i<=$#msgid; $i++) {
my $msgid = $msgid[$i];
my $miss = 0;
my $ood = 0;
if (! exists $set{'lex'}{$loc} ||
! exists $set{'lex'}{$loc}{$msgid}) {
$miss = 1;
} else {
my $def_v = $set{'lex'}{$def}{$msgid}{'vers'};
my $loc_v = $set{'lex'}{$loc}{$msgid}{'vers'};
$ood = 1 if ($def_v != $loc_v);
}
$w->itemconfigure($i,
-background => ($miss ? '#ffaaaa' :
($ood ? '#ffffaa' :
'light gray')),
-foreground => 'black',
-selectbackground => ($miss ? '#ff7777' :
($ood ? '#ffff77' :
'#ececec')),
-selectforeground => 'black',
);
}
}
# Update the selection
$w->selectionClear(0,'end');
if ($data{'msgid'}) {
$i = $msgid{$data{'msgid'}};
$w->selectionSet($i);
}
}
# Insert a new message ID into the msgid listbox.
#
sub listbox_msgid_insert {
my $w = $widgets{'manage_set:msgid'};
my $msgid = $data{'msgid'};
my @msgid = sort(keys %{ $set{'desc'} },$msgid);
my $i;
if (@msgid == 1) {
$w->insert('end',$msgid);
$i = 0;
} else {
for ($i=0; $i<=$#msgid; $i++) {
last if ($msgid[$i] eq $msgid);
}
$w->insert($i,$msgid);
}
}
###############################################################################
# CREATE_SET WINDOW
# Create the frame.
#
# Frame->
# 1) Create a new message set.
#
# 2) Default Locale: ______
#
# 3) <SUBMIT> <EXIT>
#
sub create_set_create {
my $frame = $main_window->Frame;
$widgets{'frame_create_set'} = $frame;
# 1 Instructions
my $mess = message_strip_newlines('create_set: instructions');
my $inst = text_widget('ROText',$frame,5,0);
$inst->pack( -expand => 'yes',
-fill => 'both',
-padx => 10,
-pady => 10,
);
insert_markup($inst,$mess);
# 2 Frame
my $frame_2 = $frame->Frame()->pack( -pady => 10 );
# 2a Locale:
my $loc_text = $lm->message($message_set,'create_set: locale');
chomp($loc_text);
$loc_text = decode('utf8',$loc_text);
my $loc_label = $frame_2->Label( -text => "$loc_text:" )
->pack( -side => 'left' );
# 2b [entry]
my $loc_ent = $frame_2->Entry( -width => 10,
-background => 'white' )
->pack( -side => 'left' );
$loc_ent->insert(0,$default_locale);
# 3 Frame
my $frame_3 = $frame->Frame()->pack( -pady => 10 );
# 3a <Submit>
my $submit = $lm->message($message_set,'button: submit');
chomp($submit);
$submit = decode('utf8',$submit);
$frame_3->Button( -text => $submit,
-command =>
sub {
create_set_submit();
})->pack( -side => 'left', -padx => 20 );
# 3b <Exit>
my $exit = $lm->message($message_set,'button: exit');
chomp($exit);
$exit = decode('utf8',$exit);
$frame_3->Button( -text => $exit,
-command =>
sub {
exit
})->pack( -side => 'right', -padx => 20 );
# Widgets to save
$widgets{'create_set:loc'} = $loc_ent;
}
# Clear data.
#
sub create_set_clear {
$widgets{'create_set:loc'}->delete(0,'end');
$widgets{'create_set:loc'}->insert(0,$default_locale);
}
# Pressed <Submit> in the create_set window.
#
sub create_set_submit {
my $loc = $widgets{'create_set:loc'}->get;
chomp($loc);
# Make sure that the default locale was correctly specified.
my $err = check_locale($loc);
if ($err) {
frame_select('create_set',$err);
return;
}
# Create the set.
Locale::VersionedMessages::lm::_set_create($data{'set'},$data{'dire'},$loc);
Locale::VersionedMessages::lm::_lexicon_create($data{'set'},$data{'dire'},$loc);
frame_select('manage_set');
}
sub create_set_unpack {
# Nothing to else to do beyond unpacking the main window.
}
sub create_set_pack {
my($err) = @_;
err_frame($main_window,'main_err',$err) if ($err);
}
# This checks a locale to see if it is valid. If not, it returns an
# error.
#
sub check_locale {
my($loc) = @_;
# Malformed locale error
my $err = $lm->message($message_set,'create_set: loc err');
return $err if (! $loc);
my %lc = map { lc($_) => 1 } all_language_codes();
my %cc = map { uc($_) => 1 } all_country_codes();
my ($lc,$cc);
if ($loc =~ /^[A-Za-z][A-Za-z]$/) {
return $err if (! exists $lc{$loc});
} elsif ($loc =~ /^([A-Za-z][A-Za-z])_([A-Za-z][A-Za-z])$/) {
my($lc,$cc) = ($1,$2);
return $err if (! exists $lc{$lc} ||
! exists $cc{$cc});
} else {
return $err;
}
return if (! $set{'def'}); # We're creating a new set
if ($set{'def'} eq $loc ||
exists $set{'oth'}{$loc}) {
return $lm->message($message_set,'manage_set: dupl loc err');
}
return;
}
###############################################################################
# SELECT_OPERATION WINDOW
# Clear data.
#
sub select_operation_clear {
$widgets{'select_operation:dire'}->delete(0,'end');
$widgets{'select_operation:set'}->delete(0,'end');
$widgets{'select_operation:desc'}->delete(0,'end');
}
# Create the frame.
#
# Frame->
# 1) This can be used to manage an existing message set, or
# create a new one.
#
# 2) Select Directory: _______ <BROWSE>
# 3) Message Set: _______
#
# 4) Or you can select an existing message set directly:
#
# 5) Message Set Description: ______ <BROWSE>
#
# 6) <SUBMIT> <EXIT>
#
sub select_operation_create {
my $frame = $main_window->Frame;
$widgets{'frame_select_operation'} = $frame;
# 1 Instructions
my $mess_1 = message_strip_newlines('select_operation: instructions_1');
my $inst_1 = text_widget('ROText',$frame,18,0);
$inst_1->pack( -expand => 'yes',
-fill => 'both',
-pady => 10,
-padx => 10,
);
insert_markup($inst_1,$mess_1);
# 2/3 Grid
my $frame_2 = $frame->Frame()->pack( -padx => 10,
-pady => 10,
);
# 2a Select directory:
my $dire_text = $lm->message($message_set,'select_operation: directory');
chomp($dire_text);
$dire_text = decode('utf8',$dire_text);
my $dire_label = $frame_2->Label( -text => "$dire_text:" );
$dire_label->grid( -row => 1,
-column => 1,
-sticky => 'w' );
# 2b [entry]
my $dire_ent = $frame_2->Entry( -width => 30,
-background => 'white' );
$dire_ent->grid( -row => 1,
-column => 2,
-sticky => 'w' );
# 2c <Browse>
my $browse = $lm->message($message_set,'button: browse');
chomp($browse);
$browse = decode('utf8',$browse);
my $dire_browse = $frame_2->Button( -text => $browse,
-command =>
sub {
select_operation_dire();
} );
$dire_browse->grid( -row => 1,
-column => 3,
-sticky => 'w' );
# 3a Message set:
my $set_text = $lm->message($message_set,'select_operation: set');
chomp($set_text);
$set_text = decode('utf8',$set_text);
my $set_label = $frame_2->Label( -text => "$set_text:" );
$set_label->grid( -row => 2,
-column => 1,
-sticky => 'w' );
# 3b [entry]
my $set_ent = $frame_2->Entry( -width => 30,
-background => 'white' );
$set_ent->grid( -row => 2,
-column => 2,
-sticky => 'w' );
# 4 Instructions
my $mess_2 = message_strip_newlines('select_operation: instructions_2');
my $inst_2 = text_widget('ROText',$frame,5,0);
$inst_2->pack( -expand => 'yes',
-fill => 'both',
-padx => 10,
-pady => 10,
);
insert_markup($inst_2,$mess_2);
# 5 Grid
my $frame_5 = $frame->Frame()->pack( -pady => 10,
-padx => 10,
);
# 5a Description:
my $desc_text = $lm->message($message_set,'select_operation: description');
chomp($desc_text);
$desc_text = decode('utf8',$desc_text);
my $desc_label = $frame_5->Label( -text => "$desc_text:" );
$desc_label->grid( -row => 1,
-column => 1,
-sticky => 'w' );
# 5b [entry]
my $desc_ent = $frame_5->Entry( -width => 30,
-background => 'white' );
$desc_ent->grid( -row => 1,
-column => 2,
-sticky => 'w' );
# 5c <Browse>
my $desc_browse = $frame_5->Button( -text => $browse,
-command =>
sub {
select_operation_desc();
} );
$desc_browse->grid( -row => 1,
-column => 3,
-sticky => 'w' );
# 6 Frame
my $frame_6 = $frame->Frame()->pack( -pady => 10,
-padx => 10,
);
# 6a <Submit>
my $submit = $lm->message($message_set,'button: submit');
chomp($submit);
$submit = decode('utf8',$submit);
$frame_6->Button( -text => $submit,
-command =>
sub {
select_operation_submit();
})->pack( -side => 'left', -padx => 20 );
# 6b <Exit>
my $exit = $lm->message($message_set,'button: exit');
chomp($exit);
$exit = decode('utf8',$exit);
$frame_6->Button( -text => $exit,
-command =>
sub {
exit
})->pack( -side => 'right', -padx => 20 );
# Widgets to save
$widgets{'select_operation:dire'} = $dire_ent;
$widgets{'select_operation:set'} = $set_ent;
$widgets{'select_operation:desc'} = $desc_ent;
}
# Pressed <Browse> next to Description.
#
sub select_operation_desc {
my $ent = $widgets{'select_operation:desc'};
my @types = (['Perl modules', '.pm']);
my $file = $main_window->getOpenFile( -filetypes => \@types );
if (defined $file and $file ne '') {
$ent->delete(0, 'end');
$ent->insert(0, $file);
$ent->xview('end');
}
}
# Pressed <Browse> next to Directory.
#
sub select_operation_dire {
my $ent = $widgets{'select_operation:dire'};
my $dir = $main_window->chooseDirectory;
if (defined $dir && $dir ne '') {
$ent->delete(0, 'end');
$ent->insert(0, $dir);
$ent->xview('end');
}
}
# Pressed <Submit> in the select_operation window.
#
sub select_operation_submit {
my $dire = $widgets{'select_operation:dire'}->get;
my $set = $widgets{'select_operation:set'}->get;
my $desc = $widgets{'select_operation:desc'}->get;
chomp($dire);
chomp($set);
chomp($desc);
# Make sure the data is valid.
if ( ($dire && ! $set) ||
(! $dire && $set) ||
($dire && $desc) ) {
my $err = $lm->message($message_set,'select_operation: err');
frame_select('select_operation',$err);
return;
}
if ($desc) {
# Description file entered
if ($desc =~ /^(.*)\/Locale\/VersionedMessages\/Sets\/([A-Za-z0-9_]+)\.pm$/) {
($dire,$set) = ($1,$2);
} else {
my $err = $lm->message($message_set,'select_operation: desc err');
frame_select('select_operation',$err);
return;
}
} elsif ($set) {
# Dire/set entered
if ($set !~ /^([A-Za-z0-9_]+)$/) {
my $err = $lm->message($message_set,'select_operation: set err');
frame_select('select_operation',$err);
return;
}
} else {
# Nothing entered
frame_select('select_operation');
return;
}
# Save the data
$data{'set'} = $set;
$data{'dire'} = $dire;
if (-f "$dire/Locale/VersionedMessages/Sets/$set.pm") {
frame_select('manage_set');
} else {
frame_select('create_set');
}
}
sub select_operation_unpack {
# Nothing to else to do beyond unpacking the main window.
}
sub select_operation_pack {
my($err) = @_;
err_frame($main_window,'main_err',$err) if ($err);
}
###############################################################################
# TEXT OPERATION
# This is based on DisText in:
# http://members.inode.at/w.laun/cookbook/cookbook.html
#
# Supported marks: Default Other
# <family FAMILY>...</family> FAMILY = Helvetica Courier, Times, ...
# <size SIZE>...</size> SIZE = 12 8, 10, 14, ...
# <weight WEIGHT>...</weight> WEIGHT = normal bold
# <slant SLANT>...</slant> SLANT = roman italic
# <underline>...</underline>
# <overstrike>...</overstrike>
# <background COLOR>...</background>
# <foreground COLOR>...</foreground>
# <border>...</border>
#
# Shortcuts:
# <b>...</b> <weight bold>
# <i>...</i> <slant italic>
# <u>...</u> <underline>
# <o>...</o> <overstrike>
# <bg COLOR>...</bg>
# <fg COLOR>...</fg>
#
# This inserts marked up text into a text widget.
#
sub insert_markup {
my($widget,$text,$resize) = @_;
$text = decode('utf-8',$text);
#
# Create a series of regexps that matches all tags. We only need to
# do this once.
#
if (! $simp_re) {
my @simp = qw(b i u o underline overstrike border);
my @val = qw(family size weight slant fg bg foreground background);
my $simp = join('|',@simp);
my $val = join('|',@val);
my $all = join('|',@simp,@val);
$simp_re = '<\s*(' . $simp . ')\s*>';
$simp_re = qr/$simp_re/is;
$val_re = '<\s*(' . $val . ')\s+([^>]+?)\s*>';
$val_re = qr/$val_re/is;
$end_re = '<\s*/\s*(' . $all . ')\s*>';
$end_re = qr/$end_re/is;
}
#
# Keep track of all tags that currently apply to the text. Create
# the basic font tag.
#
my $tag = 't000000';
my %taglist;
new_tag($widget,\$tag,\%taglist,0,'font');
#
# Look for TAGs in the text.
#
while ($text) {
my($t,$end,$type,$val);
if ($text =~ s/^(.*?)(?:$simp_re|$val_re|$end_re)//s) {
my($tt,$simp_type,$val_type,$val_val,$end_type) = ($1,$2,$3,$4,$5);
$t = $tt;
if ($simp_type) {
$type = $simp_type;
} elsif ($val_type) {
($type,$val) = ($val_type,$val_val);
} elsif ($end_type) {
($type,$end) = ($end_type,1);
}
} else {
$t = $text;
$text = '';
}
if ($t) {
my @taglist = taglist(\%taglist);
$widget->insert('end',$t,[@taglist]);
}
if ($type) {
new_tag($widget,\$tag,\%taglist,$end,lc($type),$val);
}
}
}
# This returns a list of all tags that apply to current text insertions.
#
sub taglist {
my($taglist) = @_;
my @taglist;
foreach my $type (keys %$taglist) {
push(@taglist,@{ $$taglist{$type} });
}
return @taglist;
}
# When inserting text with markup, any time you encounter a <TAG> you have to
# create a new markup tag that will be applied to future inserts. When you
# encounter a </TAG>, you have to remove one of the existing tags.
#
# Text will be inserted into the widget ($w). Although the insert
# isn't done here, we need the widget in order to create tags for it.
#
# Tags will be named $$tag (which is of the form 't000001') and stored
# in %$taglist.
#
# $end is 1 if </TAG> was encountered.
#
# $type is TAG. $val is the value for those tags of the form <TAG VAL>.
#
sub new_tag {
my($w,$tag,$taglist,$end,$type,$val) = @_;
#
# Some of the most commonly used tags have aliases. Handle them here.
#
if ($type eq 'b') {
$type = 'weight';
$val = 'bold';
} elsif ($type eq 'i') {
$type = 'slant';
$val = 'italic';
} elsif ($type eq 'u') {
$type = 'underline';
} elsif ($type eq 'o') {
$type = 'overstrike';
} elsif ($type eq 'fg') {
$type = 'forground';
} elsif ($type eq 'bg') {
$type = 'background';
}
#
# If we encountered an end tag: </TAG>
#
if ($end) {
if (exists $$taglist{$type}) {
pop @{ $$taglist{$type} };
}
return;
}
#
# Create a new tag
#
$$tag++;
if ($type eq 'font') {
# font : is special (only used for the initial font setup). It has
# no value. Use all default values.
my $font = $main_window->fontCreate(-family => $font_family,
-weight => $font_weight,
-slant => $font_slant,
-size => $font_size,
);
$w->tagConfigure($$tag,-font => $font);
} elsif ($type eq 'family') {
my $font = $main_window->fontCreate(-family => $val,
-weight => $font_weight,
-slant => $font_slant,
-size => $font_size,
);
$w->tagConfigure($$tag,-font => $font);
} elsif ($type eq 'weight') {
my $font = $main_window->fontCreate(-family => $font_family,
-weight => $val,
-slant => $font_slant,
-size => $font_size,
);
$w->tagConfigure($$tag,-font => $font);
} elsif ($type eq 'slant') {
my $font = $main_window->fontCreate(-family => $font_family,
-weight => $font_weight,
-slant => $val,
-size => $font_size,
);
$w->tagConfigure($$tag,-font => $font);
} elsif ($type eq 'size') {
my $font = $main_window->fontCreate(-family => $font_family,
-weight => $font_weight,
-slant => $font_slant,
-size => $val,
);
$w->tagConfigure($$tag,-font => $font);
} elsif ($type eq 'underline') {
$w->tagConfigure($$tag, -underline => 1);
} elsif ($type eq 'overstrike') {
$w->tagConfigure($$tag, -overstrike => 1);
} elsif ($type eq 'background') {
$w->tagConfigure($$tag, -background => $val);
} elsif ($type eq 'foreground') {
$w->tagConfigure($$tag, -foreground => $val);
} elsif ($type eq 'border') {
$w->tagConfigure($$tag, -borderwidth => 2,
-relief => 'raised');
}
#
# Store this tag in the current tag list.
#
if (! exists $$taglist{$type}) {
$$taglist{$type} = [$$tag];
} else {
push @{ $$taglist{$type} },$$tag;
}
}
# This looks up text in the lexicon and removes extraneous newlines. Between
# paragraphs, there will be a blank line, but each paragraph is a single line
# of text.
#
sub message_strip_newlines {
my($name) = @_;
my $text = $lm->message($message_set,$name);
my @text = split(/\n/,$text);
$text = '';
my $in_paragraph = 0;
while (@text) {
my $line = shift(@text);
if ($line && $in_paragraph) {
# Text = "We are in the middle"
# Line = "of a paragraph."
$text .= " $line";
$in_paragraph = 1;
} elsif ($line) {
# Text = "End of previous paragraph.\n\n"
# Line = "Start of new paragraph."
$text .= $line;
$in_paragraph = 1;
} elsif ($in_paragraph) {
# Text = "We are at the end of the paragraph."
# Line = ""
$text .= "\n\n";
$in_paragraph = 0;
} else {
# Text = "End of previous paragraph.\n\n"
# Line = ""
$in_paragraph = 0;
}
}
if ($in_paragraph) {
$text .= "\n";
}
return $text;
}
###############################################################################
# BASIC WIDGET CREATION
# Adds a ROText widget to a container widget ($parent) and returns the
# ROText widget.
#
# If $height < 0, no scrollbar
# If $height > 0, scrollbar
# If $height = 0, (currently not used)
#
sub text_widget {
my($rotext,$parent,$height,$err) = @_;
my $w;
my @opts = ( -setgrid => 1,
-spacing2 => 0,
-wrap => 'word',
-borderwidth => 0,
-relief => 'flat',
);
if ($height < 0) {
if ($rotext) {
$w = $parent->ROText ( @opts,
-height => -$height,
);
} else {
$w = $parent->Text ( @opts,
-height => -$height,
);
}
} elsif ($height > 0) {
$w = $parent->Scrolled( ($rotext ? 'ROText': 'Text'),
@opts,
-height => $height,
-scrollbars => 're',
);
} else {
# Unused... will be for widgets to automatically determine
# a static height (no scrollbar).
if ($rotext) {
$w = $parent->ROText ( @opts );
} else {
$w = $parent->Text ( @opts );
}
}
if ($err) {
$w->configure( -bg => '#FF9999');
} elsif (! $rotext) {
$w->configure( -bg => 'white');
}
return $w;
}
###############################################################################
# FRAME OPERATIONS
# This serves two purposes. It creates (and packs) the error frame if
# it does not already exist.
#
# It also updates the message displayed in the error frame. If $mess
# is passed in, it will be displayed. Otherwise any error message will
# be cleared and the frame will be unpacked.
#
sub err_frame {
my($parent,$label,$mess) = @_;
# Get the text widget that contains the actual error message
my ($err_wid,$err_frame);
if (exists $widgets{'err'}) {
$err_frame = $widgets{$label};
$err_wid = $widgets{"${label}_wid"};
} else {
$err_frame = $parent->Frame;
$err_wid = text_widget('ROText',$err_frame,5,'err');
$err_wid->pack( -expand => 'yes',
-fill => 'both',
-padx => 10,
-pady => 10,
);
$widgets{$label} = $err_frame;
$widgets{"${label}_wid"} = $err_wid;
}
# Display the new error message (overwriting any existing one).
$err_wid->delete('1.0','end');
my $tmp = $lm->message($message_set,'error');
insert_markup($err_wid,"$tmp\n$mess");
$err_frame->pack();
}
# This displays the given frame. It unpacks the current frame, display
# the error frame (as appropriate), clears the new frame, and displays it.
# The main window title is also updated.
#
sub frame_select {
my($frame,$err) = @_;
# Unpack the main window.
unpack_main($frame);
# Set the title on the main window
my $title = $lm->message($message_set,"$frame: window title", "COM" => $COM);
$title = $frame if (! $title);
chomp($title);
$main_window->configure( -title => $title, );
# If the new frame does not yet exist, we need to create it.
#
# If it does exist, then we just need to clear it.
if (! exists $widgets{"frame_$frame"}) {
frame_create($frame);
}
frame_clear($frame);
# Display the new frame.
pack_frame($frame,$err);
update_window();
}
# Clear any user entered text from a frame.
#
sub frame_clear {
my($name) = @_;
if ($name eq 'select_operation') {
select_operation_clear();
} elsif ($name eq 'create_set') {
create_set_clear();
} elsif ($name eq 'manage_set') {
manage_set_clear();
}
}
# This creates a new frame and stores the widgets in the global
# list.
#
sub frame_create {
my($name) = @_;
if ($name eq 'select_operation') {
select_operation_create();
} elsif ($name eq 'create_set') {
create_set_create();
} elsif ($name eq 'manage_set') {
manage_set_create();
}
}
# Unpacks the main window.
#
sub unpack_main {
my($frame) = @_;
# Save the current geometry
my $geometry = $main_window->geometry();
$geometry =~ /^(\d+)x(\d+)([+-]\d+)([+-]\d+)$/;
my($wid,$hei,$x,$y) = ($1,$2,$3,$4);
$data{'wid'} = $wid;
$data{'hei'} = $hei;
$data{'x'} = $x;
$data{'y'} = $y;
# Unpack the main window
$main_window->withdraw();
my @w = $main_window->packSlaves;
foreach my $frame (@w) {
$frame->packForget;
}
# Unpack any parts of the operation specific frame
if ($frame eq 'select_operation') {
select_operation_unpack();
} elsif ($frame eq 'create_set') {
create_set_unpack();
} elsif ($frame eq 'manage_set') {
manage_set_unpack();
}
}
# Adds a frame to the main window.
#
sub pack_frame {
my($frame,$err) = @_;
# Pack the main frame
my $f = $widgets{"frame_$frame"};
$f->pack();
# Pack any parts of the operation specific frame
if ($frame eq 'select_operation') {
select_operation_pack($err);
} elsif ($frame eq 'create_set') {
create_set_pack($err);
} elsif ($frame eq 'manage_set') {
manage_set_pack($err);
}
}
sub update_window {
my $geometry;
$geometry .= "$data{x}$data{y}";
$main_window->geometry($geometry);
$main_window->update;
$main_window->deiconify;
$main_window->raise;
}
# Local Variables:
# mode: cperl
# indent-tabs-mode: nil
# cperl-indent-level: 3
# cperl-continued-statement-offset: 2
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
# cperl-label-offset: 0
# End: