X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.main.git;a=blobdiff_plain;f=pctb%2Fdictionary-manager;h=81a480ef476a0278f84f6a7bd6a1f85e66899efa;hp=0037a2a6f57474e6770dea0ad6ab54966874a6d9;hb=0ae7e17eb009e215cfd61b7193816caa0108f43c;hpb=e888c1dd3476ca49bccf82b93b4a3633587d400d diff --git a/pctb/dictionary-manager b/pctb/dictionary-manager index 0037a2a..81a480e 100755 --- a/pctb/dictionary-manager +++ b/pctb/dictionary-manager @@ -25,6 +25,10 @@ # sponsored by Three Rings. +# ./dictionary-manager --approve-updates ijackson@login.chiark.greenend.org.uk /home/ijackson/things/ypp-sc-tools.pctb-dict-test/pctb /home/ftp/users/ijackson/pctb/test +# ./dictionary-manager --approve-updates ijackson@login.chiark.greenend.org.uk /home/ijackson/things/ypp-sc-tools.pctb-dict/pctb /home/ftp/users/ijackson/pctb + + # invocation: # OUT OF DATE # run this without args @@ -71,6 +75,12 @@ proc puts_counted {f dvar} { debug "PUTS_COUNTED $count $dvar" } +proc bgerror {m} { + global errorCode errorInfo + puts stderr "ERROR: $m\n[list $errorCode]\n$errorInfo\n"; + exit 16 +} + #---------- display core ---------- set mul 6 @@ -85,8 +95,13 @@ proc init_widgets {} { global csrh gotsh ctxh if {[winfo exists .d]} return + + frame .privacy -bd 2 -relief groove + pack .privacy -side top -padx 2 -pady 2 -fill x + + upload_init - frame .d + frame .d -bd 2 -relief groove -pady 2 -padx 2 image create bitmap image/main label .d.mi -image image/main -borderwidth 0 @@ -112,14 +127,15 @@ static unsigned char csr_bits[] = { frame .d.mi.csr_1 -bg white -width 1 frame .d.pe frame .d.pe.grid + button .d.pe.ok -text OK pack .d.pe.grid .d.pe.ok -side left pack .d.mi .d.ctx -side top - pack .d + pack .d -fill x -padx 2 -pady 2 - frame .help - pack .help + frame .help -bd 2 -relief groove + pack .help -pady 2 -padx 2 } proc resize_widgets_core {} { @@ -143,7 +159,7 @@ proc helptext {t} { set x 0; foreach c $l { set w .help.at${x}x${y} label $w -text $c - grid $w -row $y -column $x -padx 5 + grid $w -row $y -column $x -padx 5 -sticky w incr x } incr y @@ -153,12 +169,14 @@ proc helptext {t} { proc bind_key {k proc} { global keybindings - bind . $proc + bind .d $proc set keybindings($k) [expr {!![string length $proc]}] + .d configure -takefocus 1 } proc unbind_all_keys {} { global keybindings foreach k [array names keybindings] { bind_key $k {} } + .d configure -takefocus 0 } #---------- database read and write common wrapper ---------- @@ -212,6 +230,19 @@ proc write_database {} { file rename -force $database_fn.new $database_fn } +proc select_database {dbname_spec} { + global dbname + set dbname $dbname_spec + read_database "./#local-$dbname#.txt" +} + +proc do_database_update {im def} { + global database + maybe_upload_entry $im $def + set database($im) $def + write_database +} + proc required/char {} { global mulrows glyphsdone unk_l unk_r unk_contexts rows @@ -236,8 +267,9 @@ proc required/char {} { pack forget .d.pe pack .d.csr -side top -before .d.mi pack .d.got .d.ctx -side top -after .d.mi + focus .d - read_database ./charset-$rows.txt + select_database char$rows draw_glyphsdone startup_cursor } @@ -294,11 +326,14 @@ proc pixmap_maybe_ok {} { set nsel 0 foreach_pixmap_col col { set cs [.d.pe.grid.l$col curselection] - incr nsel [llength $cs] + set lcs [llength $cs] + if {!$lcs} continue + incr nsel $lcs set pixmap_selcol $col set pixmap_selrow [lindex $cs 0] } if {$nsel==1} { + debug "MAYBE_OK YES col=$pixmap_selcol row=$pixmap_selrow." .d.pe.ok configure -state normal -command pixmap_ok } else { .d.pe.ok configure -state disabled -command {} @@ -317,8 +352,8 @@ proc pixmap_ok {} { rowname rowdesc set result "$colname - $rowname" debug "UPDATE PIXMAP AS >$result<" - set database($ppm) $result - write_database + + do_database_update $ppm $result done/$mainkind } @@ -337,7 +372,7 @@ proc required/pixmap {} { set alloptions [exec ./dictionary-pixmap-options $unk_what] - read_database ./pixmaps.txt + select_database pixmap set mulcols [image width image/main] set mulrows [image height image/main] @@ -346,7 +381,9 @@ proc required/pixmap {} { place forget .d.mi.csr_1 pack forget .d.csr .d.got - pack .d.pe -side top -before .d.mi -pady 10 + pack .d.pe -side top -before .d.mi -pady 2 + .d configure -takefocus 0 + #-pady 2 -fill x eval destroy [winfo children .d.pe.grid] set col 0; foreach {colname coldesc rows} $alloptions { @@ -365,7 +402,135 @@ proc required/pixmap {} { pixmap_maybe_ok helptext { - {{Indicate the correct parse of this image, and click OK.}} + {{Indicate the meaning of this image, and click OK.}} + } +} + +#========== UPLOADS TO DICTIONARY SERVER ========== + +proc upload_init {} { + global privacy_setting + + set privacy_setting [upload_status] + + label .privacy.warn -text " Privacy " + if {$privacy_setting} { + .privacy.warn configure -background yellow -foreground black + } + label .privacy.overall -text " Upload new dictionary entry:" + label .privacy.reference -text " See README.privacy." + + pack .privacy.warn .privacy.overall -side left + + foreach {setting string} { + 0 {No} + 1 {Yes, anonymously} + 2 {Yes, quoting my pirate name.} + } { + radiobutton .privacy.o$setting -text $string \ + -value $setting -variable privacy_setting + pack .privacy.o$setting -side left + if {$setting > $privacy_setting} { + .privacy.o$setting configure -state disabled + } + } + pack .privacy.reference -side left + + if {!$privacy_setting} { + foreach w [winfo children .privacy] { + $w configure -state disabled + } + } + if {$privacy_setting} { + package require http + ::http::config -urlencoding utf-8 + } +} + +proc upload_status {} { + # returns 0, 1, 2 for none, anon, with pirate name + global env + + if {![info exists env(YPPSC_PCTB_DICT_SUBMIT)]} { debug a; return 0 } + if {![string compare 0 $env(YPPSC_PCTB_DICT_SUBMIT)]} { debug b; return 0 } + + if {![info exists env(YPPSC_PIRATE)]} { return 1 } + if {![info exists env(YPPSC_OCEAN)]} { return 1 } + if {![string length $env(YPPSC_PIRATE)]} { return 1 } + if {![string length $env(YPPSC_OCEAN)]} { return 1 } + + return 2 +} + +proc maybe_upload_entry {im def} { + global reqkind privacy_setting env dbname quiet + + debug "DB-UPDATE PRIVACY $privacy_setting" + if {!$privacy_setting} return + + debug "DB-UPDATE UPLOADING" + + set pl {} + lappend pl dict $dbname + + if {$privacy_setting>=2} { + set pirate [string totitle $env(YPPSC_PIRATE)] + set ocean [string totitle $env(YPPSC_OCEAN)] + debug "DB-UPDATE NON-ANON $ocean $pirate" + lappend pl \ + pirate $pirate \ + ocean $ocean + } + lappend pl entry [format_database_entry/$reqkind $im $def] + + set url $env(YPPSC_PCTB_DICT_SUBMIT) + append url dictionary-update-receiver + + set query [eval ::http::formatQuery $pl] + regsub -all {%0d} $query {} query + debug "DB-UPDATE QUERY $query" + + if {[regexp {^\.?/} $url]} { + set cmd [list $url $query] + debug "SUBMIT CMD [string range $cmd 0 200]..." + set body [eval exec $cmd 2>@ stderr] + regsub {^Content-Type: text/plain.*\n\n} $body {} body + } else { + + if {[catch { + set req [::http::geturl $url -query $query] + } emsg]} { + puts stderr \ + "\nWARNING: Cannot do dictionary upload: $emsg\n" + return + } + upvar #0 $req s + debug "DB-UPDATE DONE $req $s(status) [array names s]" + set ncode [::http::ncode $req] + + if {!(![string compare ok $s(status)] && + ![string compare 200 $ncode])} { + set m "\nWARNING: Dictionary upload failed:" + foreach v {status http error posterror} { + if {[info exists s($v)]} { append m "\n $v: $s($v)" } + } + puts stderr $m + return + } + set body $s(body) + ::http::cleanup $req + } + + if {![string match {OK *} $body]} { + set m "\nWARNING: Dictionary upload went wrong:\n" + append m "\n " [join [split $body "\n"] "\n "] + puts stderr $m + return + } + + if {!$quiet} { + puts stderr \ + "Uploaded $dbname dictionary entry `$def': $body" } } @@ -528,9 +693,9 @@ proc recursor//01 {z1} { bind_key space { othercursor } bind_leftright_q cur_$z1 0 [expr {$cols-1}] if {[llength $glyphsdone]} { - bind_key Tab { set cur_mode already; recursor } + bind_key BackSpace { set cur_mode already; recursor } } else { - bind_key Tab {} + bind_key BackSpace {} } bind_key Return { if {$cur_0 != $cur_1} { @@ -543,7 +708,7 @@ proc recursor//01 {z1} { {{<- ->} {move cursor, adjusting area to define}} {Space {switch to moving other cursor}} {Return {confirm location, enter letter(s)}} - {Tab {switch to correcting earlier ocr}} + {Backspace {switch to correcting earlier ocr}} {Q {quit and abandon OCR run}} } } @@ -562,16 +727,17 @@ proc recursor/text {} { .d.csr.csr.l configure -text {define:} pack .d.csr.csr.e -side left focus .d.csr.csr.e - bind_key Return { + bind .d.csr.csr.e { set strq [.d.csr.csr.e get] if {[regexp -line {^(?:[!-[]|[]-~]|\\\\|\\x[0-9a-f]{2})+} $strq]} { RETURN_RESULT DEFINE "$cur_0 $cur_1 $strq" } } - bind_key Escape { + bind .d.csr.csr.e { bind_key Escape {} pack forget .d.csr.csr.e set cur_mode 1 + focus .d recursor } } @@ -585,9 +751,8 @@ proc recursor/already {} { set rmax [lindex $glyphsdone [expr {$cur_already*4}]] place .d.csr.csr -x [expr {$rmax*$mul-3}] bind_key Return {} - bind_key space {} bind_leftright_q cur_already 0 [expr {[llength $glyphsdone]/4-1}] - bind_key Tab { bind_key Delete {}; set cur_mode 1; recursor } + bind_key space { bind_key Delete {}; set cur_mode 1; recursor } bind_key Delete { RETURN_RESULT DELETE [lrange $glyphsdone \ [expr $cur_already*4] \ @@ -596,7 +761,7 @@ proc recursor/already {} { helptext { {{<- ->} {move cursor, selecting glyph to correct}} {Del {clear this glyph from the recognition database}} - {Tab {switch to selecting area to define as new glyph}} + {Space {switch to selecting area to define as new glyph}} {Q {quit and abandon OCR run}} } } @@ -692,9 +857,8 @@ proc update_database/DEFINE {c0 c1 strq} { incr c1 -1 foreach c $ncontexts { set bm [dbkey $c $c0 $c1] - set database($bm) $strq + do_database_update $bm $strq } - write_database } proc update_database/DELETE {l r ctxs} { @@ -720,11 +884,11 @@ proc RETURN_RESULT {how what} { #========== server for approving updates ========== -proc remote-serv-log {dict pirate file event} { +proc remote-serv-log {dict pirate caller file event} { global remoteserv_logf set t [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S %Z}] - set s [format "%s %-6s %-31s %s %s\n" \ - $t $dict $pirate [file tail $file] $event] + set s [format "%s %-6s %-31s %-31s %s %s\n" \ + $t $dict $pirate $caller [file tail $file] $event] puts -nonewline $remoteserv_logf $s } @@ -746,6 +910,7 @@ proc remote-serv/take {yesno file dict} { set rows "" debug "TAKE [list $yesno $file $dict]" read_counted stdin pirate + read_counted stdin caller read_counted stdin key read_counted stdin val @@ -768,7 +933,7 @@ proc remote-serv/take {yesno file dict} { } else { set desc reject } - remote-serv-log $dict $pirate $file "$desc $reqkind $rows" + remote-serv-log $dict $pirate $caller $file "$desc $reqkind $rows" file delete -force $file puts done @@ -836,6 +1001,7 @@ proc approve_decompose_data {specdata} { regsub-data {^ypp-sc-tools dictionary update v1\n} {} uplevel 1 chop_counted pirate + uplevel 1 chop_counted caller uplevel 1 chop_counted dict uplevel 1 chop_counted ctx uplevel 1 chop_counted def @@ -877,11 +1043,25 @@ proc approve_showentry {ix file specdata} { image create photo approve/$ix -data $ppm label $wb-image -image approve/$ix -bd 2 -relief sunken + set unic [exec perl -e { + use Unicode::CharName qw(uname); + $ARGV[0] =~ s/^ //; + foreach $_ (split //,$ARGV[0]) { + print uname(ord),"\n" or die $! + } + } " $def"] + label $wb-unicode -text $unic + + if {$ix} { + label $wb-div -bd 1 -relief sunken -image image/empty + grid configure $wb-div -columnspan 5 -sticky ew -padx 5 + } + frame $wb-act button $wb-act.rej -text Reject -command [list approve_reject $ix] pack $wb-act.rej - grid $wb-def $wb-image $wb-act $wb-inf -padx 3 + grid $wb-def $wb-image $wb-unicode $wb-act $wb-inf -padx 3 grid configure $wb-image -ipadx 3 -ipady 3 -sticky w lappend approve_ixes $ix @@ -893,6 +1073,7 @@ proc approve_approve_reject_one {ix yesno} { approve_decompose_data $tdata puts_server "take $yesno $file $dict" puts_counted $server pirate + puts_counted $server caller puts_counted $server key puts_counted $server val puts_server confirmed @@ -949,14 +1130,18 @@ proc main/approve {} { if {[llength $argv] != 3} { error "wrong # args" } manyset $argv userhost directory dictdir + debug "APPROVER FOR $userhost $directory $dictdir" + set cmd [list tclsh $directory/dictionary-manager] if {$debug} { lappend cmd --debug-server } lappend cmd --remote-server-1 $directory $dictdir switch -glob $userhost { {} { } {* *} { set cmd $userhost } - * { set cmd [append [list ssh $userhost] $cmd] } + * { set cmd [concat [list ssh $userhost] $cmd] } } + debug "APPROVER RUNS $cmd" + lappend cmd 2>@ stderr set server [open |$cmd r+] must_gets_exactly_server $remoteserv_banner @@ -972,6 +1157,8 @@ proc main/approve {} { pack .right -side right pack .ok -side bottom + image create bitmap image/empty + set approve_page 0 approve_fetch_list } @@ -1044,9 +1231,11 @@ proc debug {m} { } set mainkind default set ai 0 set debug 0 +set quiet 0 foreach arg $argv { incr ai switch -exact -- $arg { + {--quiet} { set quiet 1 } {--debug} { set debug 1 } {--debug-server} { proc debug {m} { puts stderr "DICT-MGR-SVR $m" }} {--noop-arg} { }