00001 # TKE - Advanced Programmer's Editor
00002 # Copyright (C) 2014-2019 Trevor Williams (phase1geo@gmail.com)
00003 #
00004 # This program is free software; you can redistribute it and/or modify
00005 # it under the terms of the GNU General Public License as published by
00006 # the Free Software Foundation; either version 2 of the License, or
00007 # (at your option) any later version.
00008 #
00009 # This program is distributed in the hope that it will be useful,
00010 # but WITHOUT ANY WARRANTY; without even the implied warranty of
00011 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
00012 # GNU General Public License for more details.
00013 #
00014 # You should have received a copy of the GNU General Public License along
00015 # with this program; if not, write to the Free Software Foundation, Inc.,
00016 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
00017
00018 ######################################################################
00019 # Name: lang.tcl
00020 # Author: Trevor Williams (trevorw@sgi.com)
00021 # Date: 10/11/2013
00022 # Brief: Creates new internationalization files and helps to maintain
00023 # them.
00024 ######################################################################
00025
00026 set tke_dir [file dirname [file dirname [file normalize $argv0]]]
00027
00028 lappend auto_path [file join $tke_dir lib]
00029
00030 package require -exact tablelist 6.3
00031 package require http
00032 package require tls
00033
00034 array set tablelistopts {
00035 selectbackground RoyalBlue1
00036 selectforeground white
00037 stretch all
00038 stripebackground #EDF3FE
00039 relief flat
00040 border 0
00041 showseparators yes
00042 takefocus 1
00043 setfocus 1
00044 activestyle none
00045 }
00046
00047 namespace eval lang {
00048
00049 variable hide_xlates 0
00050
00051 array set phrases {}
00052 array set xlates {}
00053 array set widgets {}
00054 array set notes {}
00055
00056 ######################################################################
00057 # Gets all of the msgcat::mc procedure calls for all of the library
00058 # files.
00059 proc gather_msgcat {} {
00060
00061 variable phrases
00062 variable notes
00063
00064 foreach src [glob -directory [file join $::tke_dir lib] *.tcl] {
00065
00066 if {![catch "open $src r" rc]} {
00067
00068 # Read the contents of the file and close the file
00069 set contents [read $rc]
00070 close $rc
00071
00072 # Look for a note that we will append to the filename in the generated files
00073 if {[regexp {msgcat::note\s+([^\n]+)} $contents -> note]} {
00074 set notes($src) $note
00075 }
00076
00077 # Store all of the found msgcat::mc calls in the phrases array
00078 set start 0
00079 while {[regexp -indices -start $start {msgcat::mc\s+\"([^\"]+)\"} $contents -> phrase_index]} {
00080 if {[string index $contents [lindex $phrase_index 1]] eq "\\"} {
00081 puts "ERROR: Found a translatable string that contains an embedded doublequote character"
00082 puts " File: $src, line: [llength [split [string range $contents 0 [lindex $phrase_index 1]] \n]]"
00083 exit 1
00084 }
00085 set phrase [string range $contents {*}$phrase_index]
00086 if {[info exists phrases($phrase)]} {
00087 if {[lindex $phrases($phrase) 0] ne $src} {
00088 set phrases($phrase) [list General [expr [lindex $phrases($phrase) 1] + 1]]
00089 } else {
00090 set phrases($phrase) [list $src [expr [lindex $phrases($phrase) 1] + 1]]
00091 }
00092 } else {
00093 set phrases($phrase) [list $src 1]
00094 }
00095 set start [lindex $phrase_index 1]
00096 }
00097
00098 }
00099
00100 }
00101
00102 }
00103
00104 ######################################################################
00105 # Reads the contents of the specified language file
00106 proc fetch_lang {lang} {
00107
00108 variable xlates
00109
00110 # Clear the xlates array
00111 array unset xlates
00112
00113 if {![catch "open [file join $::tke_dir data msgs $lang.msg] r" rc]} {
00114
00115 # Read the file contents and close the file
00116 set contents [read $rc]
00117 close $rc
00118
00119 # Parse the file
00120 foreach line [split $contents \n] {
00121 set line [string trim $line]
00122 if {[regexp {^#\s+(\S+)} $line -> fn]} {
00123 set fname $fn
00124 } elseif {[regexp {msgcat::mcmset} $line]} {
00125 set mcmset 1
00126 set xlate [list]
00127 } elseif {$mcmset} {
00128 if {[string index $line 0] eq "\}"} {
00129 foreach {me other} $xlate {
00130 set xlates($me) [list $fname $other]
00131 }
00132 set mcmset 0
00133 } elseif {$line ne ""} {
00134 lappend xlate [string range $line 1 end-1]
00135 }
00136 }
00137 }
00138
00139 }
00140
00141 # Update the xlates array
00142 update_xlates
00143
00144 }
00145
00146 ######################################################################
00147 # Compares the source msgcat strings with the strings in the xlates
00148 # array. At the end of the comparison, the xlates array will be
00149 # populated with the proper information.
00150 proc update_xlates {} {
00151
00152 variable phrases
00153 variable xlates
00154
00155 array set others [array get xlates]
00156 array unset xlates
00157
00158 foreach str [array names phrases] {
00159 if {[info exists others($str)]} {
00160 set xlates($str) [list [lindex $phrases($str) 0] [lindex $others($str) 1]]
00161 } else {
00162 set xlates($str) [list [lindex $phrases($str) 0] ""]
00163 }
00164 }
00165
00166 }
00167
00168 ######################################################################
00169 # Writes the English translation file.
00170 proc write_en {} {
00171
00172 variable phrases
00173
00174 if {![catch "open [file join $::tke_dir data msgs en.msg] w" rc]} {
00175
00176 puts $rc "msgcat::mcmset en \{\n"
00177 foreach phrase [array names phrases] {
00178 puts $rc " \"$phrase\""
00179 puts $rc " \"$phrase\"\n"
00180 }
00181 puts $rc "\}\n"
00182
00183 close $rc
00184
00185 }
00186
00187 }
00188
00189 ######################################################################
00190 # Write the translation information to the file based on the table
00191 # contents.
00192 proc write_lang {lang} {
00193
00194 variable widgets
00195 variable notes
00196
00197 if {![catch "open [file join $::tke_dir data msgs $lang.msg] w" rc]} {
00198
00199 # Organize the strings by file
00200 for {set i 0} {$i < [$widgets(tbl) size]} {incr i} {
00201 if {[set xlate [$widgets(tbl) cellcget $i,xlate -text]] ne ""} {
00202 lappend srcs([$widgets(tbl) cellcget $i,src -text]) [list [$widgets(tbl) cellcget $i,str -text] $xlate]
00203 }
00204 }
00205
00206 # Output to the file by source file
00207 foreach src [lsort [array names srcs]] {
00208
00209 # Figure out the note to attach
00210 set note [expr {[info exists notes($src)] ? " ($notes($src))" : ""}]
00211
00212 puts $rc "# [file tail $src]$note"
00213 puts $rc "msgcat::mcmset $lang \{\n"
00214
00215 foreach xlate $srcs($src) {
00216 puts $rc " \"[lindex $xlate 0]\""
00217 puts $rc " \"[lindex $xlate 1]\"\n"
00218 }
00219
00220 puts $rc "\}\n"
00221
00222 }
00223
00224 close $rc
00225
00226 }
00227
00228 }
00229
00230 ######################################################################
00231 # Creates the UI.
00232 proc create_ui {} {
00233
00234 variable widgets
00235
00236 wm geometry . 800x600
00237
00238 # Force the window to exit if the close button is clicked
00239 wm protocol . WM_DELETE_WINDOW {
00240 exit
00241 }
00242
00243 ttk::frame .tf
00244 set widgets(tbl) [tablelist::tablelist .tf.tl -columns {0 {} 0 String 0 Translation 0 Re-translation 0 {}} \
00245 -editselectedonly 1 -selectmode extended -exportselection 0 -stretch all \
00246 -editendcommand "lang::edit_end_command" \
00247 -yscrollcommand ".tf.vb set"]
00248 ttk::scrollbar .tf.vb -orient vertical -command ".tf.tl yview"
00249
00250 foreach {key value} [array get ::tablelistopts] {
00251 .tf.tl configure -$key $value
00252 }
00253
00254 .tf.tl columnconfigure 0 -name num -editable 0 -resizable 0 -stretchable 0 -showlinenumbers 1
00255 .tf.tl columnconfigure 1 -name str -editable 0 -stretchable 1 -maxwidth -400
00256 .tf.tl columnconfigure 2 -name xlate -editable 1 -stretchable 1 -maxwidth -400
00257 .tf.tl columnconfigure 3 -name rexlate -editable 0 -stretchable 1 -maxwidth -400
00258 .tf.tl columnconfigure 4 -name src -editable 0 -hide 1
00259
00260 grid rowconfigure .tf 0 -weight 1
00261 grid columnconfigure .tf 0 -weight 1
00262 grid .tf.tl -row 0 -column 0 -sticky news
00263 grid .tf.vb -row 0 -column 1 -sticky ns
00264
00265 ttk::frame .bf
00266 set widgets(xlate) [ttk::button .bf.xlate -text "Add Translations"]
00267 set widgets(rexlate) [ttk::button .bf.rexlate -text "Reverse translate"]
00268 set widgets(unxlate) [ttk::button .bf.unxlate -text "Use English"]
00269 set widgets(hide) [ttk::checkbutton .bf.hide -text "Hide translated" -variable lang::hide_xlates \
00270 -command "lang::show_hide_xlates"]
00271 set widgets(update) [ttk::button .bf.upd -text "Update" -width 6 -command "set ::update_lang 1; set ::update_done 1"]
00272 ttk::button .bf.cancel -text "Cancel" -width 6 -command "set ::update_done 1"
00273
00274 pack .bf.xlate -side left -padx 2 -pady 2
00275 pack .bf.rexlate -side left -padx 2 -pady 2
00276 pack .bf.unxlate -side left -padx 2 -pady 2
00277 pack .bf.hide -side left -padx 2 -pady 2
00278 pack .bf.cancel -side right -padx 2 -pady 2
00279 pack .bf.upd -side right -padx 2 -pady 2
00280
00281 pack .tf -fill both -expand yes
00282 pack .bf -fill x
00283
00284 }
00285
00286 ######################################################################
00287 # Handles the end of a manual edit of a cell.
00288 proc edit_end_command {tbl row col value} {
00289
00290 # Handle the show/hide status of the row
00291 if {$value ne ""} {
00292 after idle [list lang::show_hide_xlate $row]
00293 }
00294
00295 return $value
00296
00297 }
00298
00299 ######################################################################
00300 # Updates the user interface with the given language information.
00301 proc populate_ui {auto lang} {
00302
00303 variable widgets
00304 variable xlates
00305
00306 wm title . "Translations for $lang"
00307 wm geometry . 1000x800
00308
00309 # Clear the table
00310 $widgets(tbl) delete 0 end
00311
00312 # Populate the table
00313 set xlate_list [list]
00314 foreach xlate [lsort [array names xlates]] {
00315 lappend xlate_list [list "" $xlate [lindex $xlates($xlate) 1] [list] [lindex $xlates($xlate) 0]]
00316 }
00317 $widgets(tbl) insertlist end $xlate_list
00318
00319 # Ready the UI for translation
00320 set ::update_lang 0
00321 set ::update_done 0
00322
00323 # Setup the translations button
00324 $widgets(xlate) configure -command "lang::perform_translations $lang"
00325 $widgets(rexlate) configure -command "lang::perform_retranslations $lang"
00326 $widgets(unxlate) configure -command "lang::perform_untranslations $lang"
00327
00328 if {$auto} {
00329
00330 # Specify that we want to hide the translated rows
00331 set lang::hide_xlates 1
00332
00333 # Only show the lines that need to be translated
00334 lang::show_hide_xlates
00335
00336 # Perform the translation
00337 lang::perform_translations $lang
00338
00339 # Specify that the language was updated (if we were not cancellled)
00340 if {!$::update_done} {
00341 set ::update_lang 1
00342 }
00343
00344 } else {
00345
00346 # Wait for the user to Update or Cancel the window
00347 vwait ::update_done
00348
00349 # Make sure any edited cells are in the not edit mode
00350 $widgets(tbl) finishediting
00351
00352 }
00353
00354 # If we need to write the language file, do so now
00355 if {$::update_lang} {
00356 write_lang $lang
00357 }
00358
00359 return $::update_lang
00360
00361 }
00362
00363 ######################################################################
00364 # Toggles the show/hide translated status of the given row.
00365 proc show_hide_xlate {row} {
00366
00367 variable widgets
00368 variable hide_xlates
00369
00370 if {[$widgets(tbl) cellcget $row,xlate -text] ne ""} {
00371 $widgets(tbl) rowconfigure $row -hide $hide_xlates
00372 $widgets(tbl) selection clear $row
00373 }
00374
00375 }
00376
00377 ######################################################################
00378 # Toggles the show/hide translated items in the table.
00379 proc show_hide_xlates {} {
00380
00381 variable widgets
00382 variable hide_xlates
00383
00384 for {set i 0} {$i < [$widgets(tbl) size]} {incr i} {
00385 show_hide_xlate $i
00386 }
00387
00388 }
00389
00390 ######################################################################
00391 # Translates the item at the given row. Throws an exception if there
00392 # was an error with the translation.
00393 proc perform_translation {row lang} {
00394
00395 variable widgets
00396
00397 # Prepare the search string for URL usage
00398 set str2xlate [$widgets(tbl) cellcget $row,str -text]
00399 set str [http::formatQuery q $str2xlate]
00400 set str "https:
00401
00402 # Perform http request
00403 set token [http::geturl $str -strict 0]
00404
00405 # Get the data returned from the request
00406 if {[http::status $token] eq "ok"} {
00407 set data [http::data $token]
00408 if {[regexp {translatedText\":\"([^\"]+)\"} $data -> ttext]} {
00409 if {[string compare -length 17 "MYMEMORY WARNING:" $ttext] == 0} {
00410 http::cleanup $token
00411 return -code error "Row: $row, $ttext"
00412 }
00413 if {([string first "??" $ttext] != -1)} {
00414 set xlated $str2xlate
00415 } else {
00416 set xlated [subst [string map {{[} {\[} {]} {\]}} $ttext]]
00417 }
00418 $widgets(tbl) cellconfigure $row,xlate -text [string trim $xlated]
00419 $widgets(tbl) see $row
00420 show_hide_xlate $row
00421 }
00422 }
00423
00424 # Cleanup request
00425 http::cleanup $token
00426
00427 }
00428
00429 ######################################################################
00430 # Translate any items that are empty.
00431 proc perform_translations {lang} {
00432
00433 variable widgets
00434
00435 # Disable the "Add Translations" button from being clicked again
00436 $widgets(xlate) configure -state disabled
00437 $widgets(rexlate) configure -state disabled
00438 $widgets(unxlate) configure -state disabled
00439 $widgets(update) configure -state disabled
00440
00441 # Get any selected rows
00442 set selected [$widgets(tbl) curselection]
00443
00444 if {[catch {
00445 if {[llength $selected] > 0} {
00446 foreach row $selected {
00447 perform_translation $row $lang
00448 }
00449 } else {
00450 for {set i 0} {$i < [$widgets(tbl) size]} {incr i} {
00451 set str [$widgets(tbl) cellcget $i,str -text]
00452 set xlate [$widgets(tbl) cellcget $i,xlate -text]
00453 if {($xlate eq "") || ([string first "??" $xlate] != -1)} {
00454 perform_translation $i $lang
00455 }
00456 }
00457 }
00458 } rc]} {
00459 tk_messageBox -parent . -default ok -message "Translation error" -detail $rc -type ok
00460 }
00461
00462 # Enable the 'Add Translations' button
00463 $widgets(xlate) configure -state normal
00464 $widgets(rexlate) configure -state normal
00465 $widgets(unxlate) configure -state normal
00466 $widgets(update) configure -state normal
00467
00468 }
00469
00470 ######################################################################
00471 # Re-translates the item at the given row. Throws an exception if there
00472 # was an error with the translation.
00473 proc perform_retranslation {row lang} {
00474
00475 variable widgets
00476
00477 # Prepare the search string for URL usage
00478 set str2xlate [$widgets(tbl) cellcget $row,xlate -text]
00479 set str [http::formatQuery q $str2xlate]
00480 set str "https:
00481
00482 # Perform http request
00483 set token [http::geturl $str -strict 0]
00484
00485 # Get the data returned from the request
00486 if {[http::status $token] eq "ok"} {
00487 set data [http::data $token]
00488 if {[regexp {translatedText\":\"([^\"]+)\"} $data -> ttext]} {
00489 if {[string compare -length 17 "MYMEMORY WARNING:" $ttext] == 0} {
00490 http::cleanup $token
00491 return -code error "Row: $row, $ttext"
00492 }
00493 if {([string first "??" $ttext] != -1)} {
00494 set xlated $str2xlate
00495 } else {
00496 set xlated [subst [string map {{[} {\[} {]} {\]}} $ttext]]
00497 }
00498 $widgets(tbl) cellconfigure $row,rexlate -text [string trim $xlated]
00499 if {[string map {{ } {}} [string tolower $xlated]] ne [string map {{ } {}} [string tolower [$widgets(tbl) cellcget $row,str -text]]]} {
00500 $widgets(tbl) cellconfigure $row,rexlate -background red -foreground white
00501 }
00502 $widgets(tbl) see $row
00503 }
00504 }
00505
00506 # Cleanup request
00507 http::cleanup $token
00508
00509 }
00510
00511 ######################################################################
00512 # Re-translate any items that are empty.
00513 proc perform_retranslations {lang} {
00514
00515 variable widgets
00516
00517 # Disable the "Add Translations" button from being clicked again
00518 $widgets(xlate) configure -state disabled
00519 $widgets(rexlate) configure -state disabled
00520 $widgets(unxlate) configure -state disabled
00521 $widgets(update) configure -state disabled
00522
00523 # Get any selected rows
00524 set selected [$widgets(tbl) curselection]
00525
00526 if {[catch {
00527 if {[llength $selected] > 0} {
00528 foreach row $selected {
00529 perform_retranslation $row $lang
00530 }
00531 } else {
00532 for {set i 0} {$i < [$widgets(tbl) size]} {incr i} {
00533 set str [$widgets(tbl) cellcget $i,str -text]
00534 set rexlate [$widgets(tbl) cellcget $i,rexlate -text]
00535 if {($rexlate eq "") || ([string first "??" $rexlate] != -1)} {
00536 perform_retranslation $i $lang
00537 }
00538 }
00539 }
00540 } rc]} {
00541 tk_messageBox -parent . -default ok -message "Re-translation error" -detail $rc -type ok
00542 }
00543
00544 # Enable the 'Add Translations' button
00545 $widgets(xlate) configure -state normal
00546 $widgets(rexlate) configure -state normal
00547 $widgets(unxlate) configure -state normal
00548 $widgets(update) configure -state normal
00549
00550 }
00551
00552 ######################################################################
00553 # Sets the selected row translations back to match their English strings.
00554 proc perform_untranslations {lang} {
00555
00556 variable widgets
00557
00558 foreach row [$widgets(tbl) curselection] {
00559 $widgets(tbl) cellconfigure $row,xlate -text [$widgets(tbl) cellcget $row,str -text]
00560 $widgets(tbl) cellconfigure $row,rexlate -text "" -background "" -foreground ""
00561 }
00562
00563 }
00564
00565 ######################################################################
00566 # Updates all of the specified language files.
00567 proc update_langs {auto langs} {
00568
00569 variable xlates
00570
00571 # Read the current msgcat information from the source files
00572 gather_msgcat
00573
00574 # For each language, perform the update
00575 foreach lang $langs {
00576
00577 if {$lang eq "en"} {
00578
00579 write_en
00580
00581 } else {
00582
00583 # Read in the language, if it exists
00584 fetch_lang $lang
00585
00586 # Update the UI with the current language information
00587 if {[populate_ui $auto $lang] == 0} {
00588 break
00589 }
00590
00591 }
00592
00593 }
00594
00595 # When we are done, exit
00596 exit
00597
00598 }
00599
00600 }
00601
00602 ######################################################################
00603 # Displays usage information and exits.
00604 proc usage {} {
00605
00606 puts "Usage: wish8.5 lang.tcl (-h | <lang>+)"
00607 puts ""
00608 puts "Options:"
00609 puts " -h Displays this help information and exits"
00610 puts " -auto Automatically starts the translations, updates and quits"
00611 puts ""
00612
00613 exit
00614
00615 }
00616
00617 # Parse the command-line arguments
00618 set i 0
00619 set langs [list]
00620 set auto_update 0
00621 while {$i < $argc} {
00622 switch -exact -- [lindex $argv $i] {
00623 -h { usage }
00624 -auto { set auto_update 1 }
00625 default { lappend langs [lindex $argv $i] }
00626 }
00627 incr i
00628 }
00629
00630 if {[llength $langs] == 0} {
00631 usage
00632 }
00633
00634 # Use the clam theme
00635 ttk::style theme use clam
00636
00637 # Allow ourselves to make https calls
00638 http::register https 443 tls::socket
00639
00640 # Create the UI
00641 lang::create_ui
00642
00643 # Gather all of the msgcat::mc calls in the library source files
00644 lang::update_langs $auto_update $langs
00645