chiark / gitweb /
dictionary approver works
authorIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sat, 20 Jun 2009 19:25:22 +0000 (20:25 +0100)
committerIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sat, 20 Jun 2009 19:25:22 +0000 (20:25 +0100)
.gitignore
pctb/Makefile
pctb/dictionary-manager
pctb/dictionary-update-receiver
pctb/testupdate-char
pctb/testupdate-char5 [new file with mode: 0644]

index f795243..1a3777d 100644 (file)
@@ -2,6 +2,7 @@
 t
 
 core
 t
 
 core
+vgcore.*
 
 pctb/*.o
 pctb/t.*
 
 pctb/*.o
 pctb/t.*
@@ -10,3 +11,4 @@ pctb/u.*
 pctb/ypp-commodities
 
 pctb/#*#.*
 pctb/ypp-commodities
 
 pctb/#*#.*
+pctb/_dict.log
index f798e52..046493b 100644 (file)
@@ -43,4 +43,5 @@ ypp-commodities: $(CONVERT_OBJS) -lnetpbm -lXtst -lX11
 $(CONVERT_OBJS): ocr.h convert.h structure.h common.h
 
 clean:
 $(CONVERT_OBJS): ocr.h convert.h structure.h common.h
 
 clean:
-       rm -f $(TARGETS) *.o core core.* *~ t t.* u u.* ./#pages#.ppm 
+       rm -f $(TARGETS) *.o core core.* *~ vgcore.*
+       rm -f t t.* u u.* v v.* ./#pages#.ppm 
index f15c99e..26c8807 100755 (executable)
@@ -49,11 +49,26 @@ proc must_gets {f lvar} {
     if {[gets $f l] < 0} { error "huh?" }
 }
 
     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} {
 proc read_counted {f var} {
-    upvar 1 $var var
+    upvar 1 $var val
     must_gets $f count
     must_gets $f count
-    set var [read $f $count]
-    if {[eof $f]} { error ? }
+    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 ----------
 }
 
 #---------- display core ----------
@@ -549,7 +564,7 @@ proc recursor/text {} {
     focus .d.csr.csr.e
     bind_key Return {
        set strq [.d.csr.csr.e get]
     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"
        }
     }
            RETURN_RESULT DEFINE "$cur_0 $cur_1 $strq"
        }
     }
@@ -641,6 +656,7 @@ proc read_database_entry/char {f context} {
 }
 
 proc write_database_header/char {f} {
 }
 
 proc write_database_header/char {f} {
+    global rows
     puts $f "$rows\n"
 }
 proc format_database_entry/char {bm strq} {
     puts $f "$rows\n"
 }
 proc format_database_entry/char {bm strq} {
@@ -704,9 +720,12 @@ proc RETURN_RESULT {how what} {
 
 #========== server for approving updates ==========
 
 
 #========== server for approving updates ==========
 
-proc remote-serv-log {pirate event} {
+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 t [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S %Z}]
-    set s [format "%s %15s %s" $t $pirate $event]
+    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 {} {
 }
 
 proc remote-serv/list {} {
@@ -717,39 +736,276 @@ proc remote-serv/list {} {
        set f [open $file]
        set d [read $f]
        close $f
        set f [open $file]
        set d [read $f]
        close $f
-       puts [string length $d]
-       puts -nonewline $d
+       puts_counted stdout d
     }
     puts end
 }
 
     }
     puts end
 }
 
-proc remote-serv/take {f args} {
-    global dropdir rows reqkind
+proc remote-serv/take {yesno file dict} {
+    global dropdir dictdir rows reqkind database
     set rows ""
     set rows ""
-    manyset $args yesno file pirate reqkind rows
-    read_counted stdin desc
+    debug "TAKE [list $yesno $file $dict]"
+    read_counted stdin pirate
     read_counted stdin key
     read_counted stdin val
     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} {
     if {$yesno} {
-       read_database
+       read_database $dictdir/master-$dict.txt
        set database($key) $val
        write_database
        set database($key) $val
        write_database
+       set desc approve
+    } else {
+       set desc reject
     }
     }
-    set ar [lindex {reject approve} $yesno]
-    remote-serv-log $pirate "$ar $reqkind $rows $desc"
-    file remove $file
+    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 {} {
 proc main/remoteserv {} {
-    global argv dropdir
-    manyset $argv dropdir
+    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 {
     while 1 {
-       puts {ypp-sc-tools pctb remote-server v1}
+       flush stdout
        if {[gets stdin l] < 0} break
        eval remote-serv/$l
     }
 }
 
        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
+
+    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 2
+    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 {} {
 #========== main program ==========
 
 proc main/default {} {
@@ -787,11 +1043,14 @@ proc debug {m} { }
 
 set mainkind default
 set ai 0
 
 set mainkind default
 set ai 0
+set debug 0
 foreach arg $argv {
     incr ai
     switch -exact -- $arg {
 foreach arg $argv {
     incr ai
     switch -exact -- $arg {
-       {--debug}           { proc debug {m} { puts stderr "SHOW-THING $m" } }
+       {--debug}           { set debug 1 }
+       {--debug-server}    { proc debug {m} { puts stderr "DICT-MGR-SVR $m" }}
        {--noop-arg}        { }
        {--noop-arg}        { }
+       {--approve-updates} { set mainkind approve; break }
        {--automatic-1}     { set mainkind automatic }
        {--remote-server-1} { set mainkind remoteserv; break }
        {--automatic*} - {--remote-server}
        {--automatic-1}     { set mainkind automatic }
        {--remote-server-1} { set mainkind remoteserv; break }
        {--automatic*} - {--remote-server}
@@ -799,6 +1058,9 @@ foreach arg $argv {
        default             { error "huh $argv ?" }
     }
 }
        default             { error "huh $argv ?" }
     }
 }
+if {$debug} {
+    proc debug {m} { puts stderr "DICT-MGR $m" }
+}
 set argv [lrange $argv $ai end]
 
 main/$mainkind
 set argv [lrange $argv $ai end]
 
 main/$mainkind
index 727b94b..3e04f6c 100755 (executable)
@@ -17,6 +17,7 @@
 # The SC PCTB client does this so that 
 
 use strict (qw(vars));
 # The SC PCTB client does this so that 
 
 use strict (qw(vars));
+use POSIX;
 
 $CGI::POST_MAX= 65536;
 $CGI::DISABLE_UPLOADS= 1;
 
 $CGI::POST_MAX= 65536;
 $CGI::DISABLE_UPLOADS= 1;
@@ -50,31 +51,15 @@ sub parseentryin__pixmap ($) {
        $ppm .= "\n";
     }
 
        $ppm .= "\n";
     }
 
-    my $icon= pipeval($ppm,
-                        'ppmtopgm',
-                        'pnmscale -xysize 156 80',
-                        'pnmnorm -bpercent 40 -wpercent 20',
-                        'pgmtopbm -threshold',
-                        'pnminvert',
-                        'pbmtoascii -2x4');
-
-    my $whole= pipeval($ppm,
-                      'ppmtopgm',
-                      'pnmnorm -bpercent 40 -wpercent 20',
-                      'pgmtopbm -threshold',
-                      'pnminvert',
-                      'pbmtoascii');
-    
-    my $entry= "$def\n$ppm";
-    return ('',$def,$entry,$icon,$w,$whole);
+    return ('',$def,$ppm,$ppm,$def);
 }
 
 #---------- characters ----------
 
 }
 
 #---------- characters ----------
 
-sub parseentryin__char ($) {
-    my ($ei) = @_;
-    $ei =~ m/^([1-9]\d{0,2})\n(Digit|Upper|Lower)\n((?:[-&\'A-F0-9a-f ]|\x20)+)\n/s or die;
-    my ($h,$ctx,$str)= ($1+0,$2,$3);
+sub parseentryin__char ($$) {
+    my ($ei,$h) = @_;
+    $ei =~ m/^(Digit|Upper|Lower)\n((?:[-&\'A-F0-9a-f ]|\x20)+)\n/s or die;
+    my ($ctx,$str)= ($1,$2);
 #print STDERR ">$'<\n";
     my @d= grep { m/./ } split /\n/, $';
 #print STDERR ">@d<\n";
 #print STDERR ">$'<\n";
     my @d= grep { m/./ } split /\n/, $';
 #print STDERR ">@d<\n";
@@ -90,132 +75,73 @@ sub parseentryin__char ($) {
     my $ppm= "P2\n$w $h\n1\n";
     for (my $y=0; $y<$h; $y++) {
        for (my $x=0; $x<$w; $x++) {
     my $ppm= "P2\n$w $h\n1\n";
     for (my $y=0; $y<$h; $y++) {
        for (my $x=0; $x<$w; $x++) {
-           $ppm .= sprintf " %d", !!($d[$x] & (1<<$y));
+           $ppm .= sprintf " %d", !($d[$x] & (1<<$y));
        }
        $ppm .= "\n";
     }
        }
        $ppm .= "\n";
     }
-    my $entry= sprintf "%d\n%s\n%s\n", $h,$ctx,$str;
-    map { $entry .= sprintf "%x\n", $_; } @d;
+    my $key= join ' ', $ctx, map { sprintf "%x", $_; } @d;
     
     
-#print STDERR "[[[[\n$ppm\n]]]]";
-
-    my $icon= pipeval($ppm,
-#                    "pnmscale -xysize 78 $h",
-                     'pgmtopbm -threshold',
-                     'pnminvert',
-                     'pbmtoascii');
-
-    return ("$ctx",$str,$entry, '',$w,$icon);
-}
-
-#---------- useful stuff ----------
-
-sub pipeval ($@) {
-    my ($val, @cmds) = @_;
-    my (@pids);
-
-    my $lastpipe;
-    
-    foreach my $cmd ('',@cmds) {
-       my $pipe= new IO::Pipe or die $!;
-       my $pid= fork();  defined $pid or die $!;
-
-       if (!$pid) {
-           $pipe->writer();
-           if (!$lastpipe) {
-                print $pipe $val or die $!;
-                exit 0;
-            } else {
-                open STDIN, '<&', $lastpipe or die $!;
-                open STDOUT, '>&', $pipe or die $!;
-                close $lastpipe or die $!;
-                close $pipe or die $!;
-                exec $cmd; die $!;
-            }
-       }
-       $pipe->reader();
-       if ($lastpipe) { close $lastpipe or die $!; }
-       $lastpipe= $pipe;
-       push @pids, $pid;
-    }
-
-    $!=0; { local ($/)=undef; $val= <$lastpipe>; }
-    defined $val or die $!;
-    $lastpipe->error and die $!;  close $lastpipe or die $!;
-
-    foreach my $cmd ('(paste)', @cmds) {
-       my $pid= shift @pids;
-       waitpid($pid,0) == $pid or die "$pid $? $!";
-       $?==0 or $?==13 or die "$cmd $?";
-    }
-    return $val;
+    return ($ctx,$str,$ppm,$key,$str);
 }
 
 #---------- main program ----------
 
 }
 
 #---------- main program ----------
 
-my $path= path_info();
+my $dict= param('dict');
 my $entry_in= param('entry');
 defined $entry_in or die;
 
 my $entry_in= param('entry');
 defined $entry_in or die;
 
+my $ocean= param('ocean');
+my $pirate= param('pirate');
+if (defined $ocean && defined $pirate) {
+    $pirate= "$ocean - $pirate";
+} else {
+    $pirate= $ENV{'REMOTE_ADDR'};
+    my $fwdf= $ENV{'HTTP_X_FORWARDED_FOR'};
+    if (defined $fwdf) {
+       $fwdf =~ s/\s//g;
+       $fwdf =~ s/[^0-9.,]/?/g;
+       $pirate= "$fwdf,$pirate";
+    }
+}
+
 my $du=$ENV{'YPPSC_DICTUPDATES'};
 chdir $du or die "$du $!"
     if defined $du;
 
 my $kind;
 my $du=$ENV{'YPPSC_DICTUPDATES'};
 chdir $du or die "$du $!"
     if defined $du;
 
 my $kind;
+my @xa;
 
 
-if ($path =~ /(pixmap|char)/) {
-    $kind=$1;
+if ($dict =~ m/^pixmap$/) {
+    $kind= $&;
+} elsif ($dict =~ m/^(char)([1-9]\d?)$/) {
+    ($kind,@xa)= ($1,$2);
 } else {
 } else {
-    die "$path ?";
+    die "$dict ?";
 }
 }
+$dict= $&;
 
 
-my ($ctx,$def,$entry,$icon,$width,$whole)= &{"parseentryin__$kind"}($entry_in);
+my ($ctx,$def,$image,$key,$val)= &{"parseentryin__$kind"}($entry_in, @xa);
 
 my $fn_t= "_update.$$-xxxxxxxxxxxxxxxx.tmp";
 open F, "> $fn_t" or die "$fn_t $!";
 (stat F) or die $!;
 my $fn_i= sprintf "_update.$$-%016x.rdy", (stat _)[1];
 
 
 my $fn_t= "_update.$$-xxxxxxxxxxxxxxxx.tmp";
 open F, "> $fn_t" or die "$fn_t $!";
 (stat F) or die $!;
 my $fn_i= sprintf "_update.$$-%016x.rdy", (stat _)[1];
 
-print F $whole or die $!;
-close F or die $!;
-rename $fn_t, $fn_i or die "$fn_t $fn_i $!";
-
-__END__
-
-$icon =~ s/^/ /mg;
-
-my $email= <<END
-To: $owner
-Subject: yppsc dictionary update
-
-Context:    $kind $ctx
-Definition: $def
+print F "ypp-sc-tools dictionary update v1\n";
 
 
-$icon
-
-END
-    ;
-
-$whole =~ s/(.*)\n/ sprintf "%-${width}s\n", $1 /mge;
-$whole =~ s/^/|/mg;
-$whole =~ s/\n/|\n/mg;
-$whole =~ s/^(.*)/ ",".('_' x $width).".\n".$1 /e;
-$whole =~ s/(.*)$/ $1."\n\`".('~' x $width)."'\n" /e;
-
-my $lw= 79;
-
-while ($whole =~ m/../) {
-    my $lhs= $whole;
-    $lhs =~ s/^(.{0,$lw}).*$/$1/mg;
-    $whole =~ s/^.{1,$lw}//mg;
-#print STDERR "[[[[[$lhs########$whole]]]]]\n";
-    $email .= $lhs;
+foreach my $v ($pirate,$dict,$ctx,$def,$image,$key,$val) {
+    printf F "%d\n", length($v) or die $!;
+    print F $v,"\n" or die $!;
 }
 
 }
 
-END
-    ;
+close F or die $!;
+
+my @tm= localtime;
+my $tm= strftime "%Y-%m-%d %H:%M:%S %Z", @tm;
 
 
-my $cutline= "-8<-\n";
-$email .= $cutline.$entry.$cutline;
+open L, ">> _dict.log" or die $!;
+my $ll= sprintf "%s %-6s %-31s %s %s\n", $tm, $dict, $pirate, $fn_i, "submit";
+print L $ll or die $!;
+close L or die $!;
 
 
-print $email or die $!;
+rename $fn_t, $fn_i or die "$fn_t $fn_i $!";
index 0f0c8f0..637e937 100644 (file)
@@ -1,4 +1,3 @@
-15
 Digit
 0
 3e0
 Digit
 0
 3e0
diff --git a/pctb/testupdate-char5 b/pctb/testupdate-char5
new file mode 100644 (file)
index 0000000..a25def5
--- /dev/null
@@ -0,0 +1,7 @@
+Digit
+5
+878
+848
+848
+488
+308