X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.web-live.git;a=blobdiff_plain;f=pctb%2Fdictionary-manager;h=a2a82a442de973eff2497b8885c6525145911228;hp=7aa707759efbcb80f5deaeaddeb0557e9789e937;hb=ebff4279347400f87f24bd9dbf7f655f425c132e;hpb=27ae0b4c6d571104f553d5bf863998fd478feb45

diff --git a/pctb/dictionary-manager b/pctb/dictionary-manager
index 7aa7077..a2a82a4 100755
--- a/pctb/dictionary-manager
+++ b/pctb/dictionary-manager
@@ -49,6 +49,28 @@ proc must_gets {f lvar} {
     if {[gets $f l] < 0} { error "huh?" }
 }
 
+proc must_gets_exactly {f expected} {
+    must_gets $f got
+    if {[string compare $expected $got]} { error "$expected $got ?" }
+}
+
+proc read_counted {f var} {
+    upvar 1 $var val
+    must_gets $f count
+    set val [read $f $count]
+    must_gets $f eol
+    if {[string length $eol]} { error "$eol ?" }
+    debug "READ_COUNTED $count $var"
+}
+
+proc puts_counted {f dvar} {
+    upvar 1 $dvar d
+    set count [string length $d]
+    puts $f $count
+    puts $f $d
+    debug "PUTS_COUNTED $count $dvar"
+}
+
 #---------- display core ----------
 
 set mul 6
@@ -542,7 +564,7 @@ proc recursor/text {} {
     focus .d.csr.csr.e
     bind_key Return {
 	set strq [.d.csr.csr.e get]
-	if {[regexp {^(?:[!-[]|[]-~]|\\\\|\\x[0-9a-f]{2})+} $strq]} {
+	if {[regexp -line {^(?:[!-[]|[]-~]|\\\\|\\x[0-9a-f]{2})+} $strq]} {
 	    RETURN_RESULT DEFINE "$cur_0 $cur_1 $strq"
 	}
     }
@@ -634,6 +656,7 @@ proc read_database_entry/char {f context} {
 }
 
 proc write_database_header/char {f} {
+    global rows
     puts $f "$rows\n"
 }
 proc format_database_entry/char {bm strq} {
@@ -695,6 +718,294 @@ proc RETURN_RESULT {how what} {
     done/$mainkind
 }
 
+#========== server for approving updates ==========
+
+proc remote-serv-log {dict pirate 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]
+    puts -nonewline $remoteserv_logf $s
+}
+
+proc remote-serv/list {} {
+    global dropdir
+    foreach file [glob -nocomplain -type f -directory $dropdir _update.*.rdy] {
+	puts yes
+	puts $file
+	set f [open $file]
+	set d [read $f]
+	close $f
+	puts_counted stdout d
+    }
+    puts end
+}
+
+proc remote-serv/take {yesno file dict} {
+    global dropdir dictdir rows reqkind database
+    set rows ""
+    debug "TAKE [list $yesno $file $dict]"
+    read_counted stdin pirate
+    read_counted stdin key
+    read_counted stdin val
+
+    must_gets_exactly stdin confirmed
+
+    if {![string compare pixmap $dict]} {
+	set reqkind pixmap
+	debug "DICT PIXMAP"
+    } elseif {[regexp {^(char)([1-9]\d*)$} $dict dummy reqkind rows]} {
+	debug "DICT CHAR rqk=$reqkind r=$rows."
+    } else {
+	error "$dict ?"
+    }
+    
+    if {$yesno} {
+	read_database $dictdir/master-$dict.txt
+	set database($key) $val
+	write_database
+	set desc approve
+    } else {
+	set desc reject
+    }
+    remote-serv-log $dict $pirate $file "$desc $reqkind $rows"
+    file delete -force $file
+
+    puts done
+}
+
+proc remote-serv/noop {} {
+    puts ok
+}
+
+set remoteserv_banner {ypp-sc-tools pctb remote-server v1}
+
+proc main/remoteserv {} {
+    global argv dropdir remoteserv_banner remoteserv_logf dictdir
+    manyset $argv dropdir dictdir
+    puts $remoteserv_banner
+    set remoteserv_logf [open $dropdir/_dict.log a]
+    fconfigure $remoteserv_logf -buffering line
+    while 1 {
+	flush stdout
+	if {[gets stdin l] < 0} break
+	eval remote-serv/$l
+    }
+}
+
+#========== updates approver ==========
+
+proc puts_server {s} {
+    global server
+    debug ">> $s"
+    puts $server $s
+}
+proc must_gets_server {lv} {
+    upvar 1 $lv l
+    global server
+    must_gets $server l
+    debug "<< $l"
+}
+
+proc must_gets_exactly_server {expected} {
+    must_gets_server got
+    if {[string compare $expected $got]} { error "$expected $got ?" }
+}
+
+proc regsub-data {exp subspec args} {
+    global data
+    if {![eval regsub $args -- [list $exp $data $subspec data]]} {
+	error "$exp >$data< ?"
+    }
+}
+
+proc chop_counted {var} {
+    upvar 1 $var val
+    global data
+    if {![regexp {^(0|[1-9]\d*)\n} $data dummy l]} { error "$data ?" }
+    regsub-data {^.*\n} {} -line
+    set val [string range $data 0 [expr {$l-1}]]
+    set data [string range $data $l end]
+    debug "CHOP_COUNTED $l $var"
+    regsub-data {^\n} {}
+}
+
+proc approve_decompose_data {specdata} {
+    global data
+    set data $specdata
+    
+    regsub-data {^ypp-sc-tools dictionary update v1\n} {}
+    uplevel 1 chop_counted pirate
+    uplevel 1 chop_counted dict
+    uplevel 1 chop_counted ctx
+    uplevel 1 chop_counted def
+    uplevel 1 chop_counted image
+    uplevel 1 chop_counted key
+    uplevel 1 chop_counted val
+
+    return [uplevel 1 {list $dict $def $image}]
+}
+
+proc approve_compare {fd1 fd2} {
+    manyset $fd1 file data; set sv1 [approve_decompose_data $data]
+    manyset $fd2 file data; set sv2 [approve_decompose_data $data]
+    return [string compare $sv1 $sv2]
+}
+
+proc approve_showentry {ix file specdata} {
+    global approve_ixes
+    
+    approve_decompose_data $specdata
+
+    set wb .app.e$ix
+
+    frame $wb-inf
+    label $wb-inf.who -text $pirate
+
+    entry $wb-inf.file -font fixed -relief flat
+    $wb-inf.file insert end [file tail $file]
+    $wb-inf.file configure -state readonly -width -1
+
+    pack $wb-inf.who $wb-inf.file -side top
+
+    frame $wb-def
+    label $wb-def.scope -text "$dict $ctx"
+    label $wb-def.def -text $def
+    pack $wb-def.scope $wb-def.def -side bottom
+
+    set ppm [exec pnmscale 2 << $image]
+    image create photo approve/$ix -data $ppm
+    label $wb-image -image approve/$ix -bd 2 -relief sunken
+
+    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 configure $wb-image -ipadx 3 -ipady 3 -sticky w
+
+    lappend approve_ixes $ix
+}
+
+proc approve_approve_reject_one {ix yesno} {
+    global approve_list server
+    manyset [lindex $approve_list $ix] file tdata
+    approve_decompose_data $tdata
+    puts_server "take $yesno $file $dict"
+    puts_counted $server pirate
+    puts_counted $server key
+    puts_counted $server val
+    puts_server confirmed
+    flush $server
+    must_gets_exactly_server done
+}
+
+proc approve_check_server {} {
+    global server
+    puts_server noop
+    flush $server
+    must_gets_exactly_server ok
+}
+
+proc approve_reject {ix} {
+    approve_check_server
+    approve_approve_reject_one $ix 0
+    approve_fetch_list
+}
+
+proc approve_these {} {
+    global approve_ixes
+    approve_check_server
+    foreach ix $approve_ixes { approve_approve_reject_one $ix 1 }
+    approve_fetch_list
+}
+
+proc approve_fetch_list {} {
+    global server approve_list
+    set approve_list {}
+    puts_server list
+    flush $server
+    while 1 {
+	must_gets_server more
+	switch -exact $more {
+	    yes { }
+	    end { break }
+	    default { error "$more ?" }
+	}
+	must_gets_server file
+	read_counted $server data
+	lappend approve_list [list $file $data]
+    }
+
+    if {![llength $approve_list]} { puts "Nothing (more) to approve."; exit 0 }
+
+    set approve_list [lsort -command approve_compare $approve_list]
+    approve_show_page 0
+}
+
+proc main/approve {} {
+    global argv server remoteserv_banner data approve_list approve_page
+    global userhost directory dictdir debug
+
+    if {[llength $argv] != 3} { error "wrong # args" }
+    manyset $argv 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] }
+    }
+    lappend cmd 2>@ stderr
+    set server [open |$cmd r+]
+    must_gets_exactly_server $remoteserv_banner
+
+    button .left -text {<<} -command {approve_show_page -1}
+    button .right -text {>>} -command {approve_show_page +1}
+
+    label .title -text {}
+    frame .app -bd 2 -relief groove
+    button .ok -text "Approve These" -command approve_these
+    pack .title .app -side top
+    pack .left -side left
+    pack .right -side right
+    pack .ok -side bottom
+
+    set approve_page 0
+    approve_fetch_list
+}
+
+proc approve_show_page {delta} {
+    global approve_page approve_ixes approve_list userhost directory dictdir
+
+    eval destroy [winfo children .app]
+    set approve_ixes {}
+
+    set per_page 10
+    incr approve_page $delta
+
+    set ll [llength $approve_list]
+    set npages [expr {($ll+$per_page-1)/$per_page}]
+    if {$approve_page >= $npages} { incr approve_page -1 }
+
+    set page_start [expr {$approve_page*$per_page}]
+    set page_end [expr {$page_start+$per_page-1}]
+    
+    for {set ix $page_start} {$ix < $ll && $ix <= $page_end} {incr ix} {
+	set fd [lindex $approve_list $ix]
+	eval approve_showentry $ix $fd
+    }
+
+    .title configure -text \
+ "$userhost\n$directory => $dictdir\nPage [expr {$approve_page+1}]/$npages"
+
+    .left configure -state disabled
+    .right configure -state disabled
+    if {$approve_page>0} { .left configure -state normal }
+    if {$approve_page<$npages-1} { .right configure -state normal }
+}
+
 #========== main program ==========
 
 proc main/default {} {
@@ -731,14 +1042,25 @@ proc done/automatic {} {
 proc debug {m} { }
 
 set mainkind default
+set ai 0
+set debug 0
 foreach arg $argv {
+    incr ai
     switch -exact -- $arg {
-	{--debug}        { proc debug {m} { puts stderr "SHOW-THING $m" } }
-	{--noop-arg}     { }
-	{--automatic-1}  { set mainkind automatic }
-	{--automatic*}   { error "incompatible versions - install problem" }
-	default          { error "huh $argv ?" }
+	{--debug}           { set debug 1 }
+	{--debug-server}    { proc debug {m} { puts stderr "DICT-MGR-SVR $m" }}
+	{--noop-arg}        { }
+	{--approve-updates} { set mainkind approve; break }
+	{--automatic-1}     { set mainkind automatic }
+	{--remote-server-1} { set mainkind remoteserv; break }
+	{--automatic*} - {--remote-server}
+	                    { error "incompatible versions - install problem" }
+	default             { error "huh $argv ?" }
     }
 }
+if {$debug} {
+    proc debug {m} { puts stderr "DICT-MGR $m" }
+}
+set argv [lrange $argv $ai end]
 
 main/$mainkind