X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-test.git;a=blobdiff_plain;f=pctb%2Fdictionary-manager;h=7284b374cc666852e7d4562372562f4ebe4c258d;hp=c2ea2b59f5b371fe99d72de6afa30b27123c468b;hb=e9534386e9b4399195d37e5437c18a54197f0b9f;hpb=f8488ba218ce448dc5c02c8d83e85b6c551332eb diff --git a/pctb/dictionary-manager b/pctb/dictionary-manager index c2ea2b5..7284b37 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 @@ -89,7 +99,7 @@ proc init_widgets {} { frame .privacy -bd 2 -relief groove pack .privacy -side top -padx 2 -pady 2 -fill x - upload_init_widgets + upload_init frame .d -bd 2 -relief groove -pady 2 -padx 2 @@ -159,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 ---------- @@ -218,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 @@ -242,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 "./#local-char$rows#.txt" + select_database char$rows draw_glyphsdone startup_cursor } @@ -326,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 } @@ -346,7 +372,7 @@ proc required/pixmap {} { set alloptions [exec ./dictionary-pixmap-options $unk_what] - read_database "./#local-pixmap#.txt" + select_database pixmap set mulcols [image width image/main] set mulrows [image height image/main] @@ -356,6 +382,7 @@ proc required/pixmap {} { pack forget .d.csr .d.got 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] @@ -381,7 +408,7 @@ proc required/pixmap {} { #========== UPLOADS TO DICTIONARY SERVER ========== -proc upload_init_widgets {} { +proc upload_init {} { global privacy_setting set privacy_setting [upload_status] @@ -414,6 +441,10 @@ proc upload_init_widgets {} { $w configure -state disabled } } + if {$privacy_setting} { + package require http + ::http::config -urlencoding utf-8 + } } proc upload_status {} { @@ -424,11 +455,85 @@ proc upload_status {} { 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 [string range $query 0 200]..." + + 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" + } +} + #========== CHARACTER SET ========== #---------- xpm input processor ---------- @@ -622,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 } } @@ -751,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} { @@ -779,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 } @@ -805,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 @@ -827,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 @@ -895,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 @@ -952,6 +1059,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 @@ -1008,14 +1116,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 @@ -1103,9 +1215,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} { }