pctb/dictionary-update-receiver

   1 #!/usr/bin/perl -w
   2 #
   3 # This script is invoked when the YPP SC PCTB client phones home to
   4 # provide updated character set OCR data or updated screenshot pixmap
   5 # interpretation (island name) data.
   6 #
   7 # The client will also phone home anyway to fetch the latest parsedb
   8 # before
   9 #
  10 # This allows me (the operator of the SC server) to:
  11 #    - review the choices made by the user
  12 #    - if they are correct, incorporate them in the next client version
  13 #    - if they are wrong, incorporate fixes of them, or contradictions of them,
  14 #      in
  15
  16 # The information reported
  17 # The SC PCTB client does this so that
  18
  19 use strict (qw(vars));
  20 use POSIX;
  21
  22 $CGI::POST_MAX= 65536;
  23 $CGI::DISABLE_UPLOADS= 1;
  24
  25 use CGI qw/:standard -private_tempfiles/;
  26 use IO::Pipe;
  27 use IO::Handle;
  28
  29 #---------- pixmaps ----------
  30
  31 sub parseentryin__pixmap ($) {
  32     my ($entry_in) = @_;
  33     $entry_in =~
  34         m/^(\w+ \- \w[-+\'\"\#! 0-9a-z]*)\nP3\n([1-9]\d{1,3}) ([1-9]\d{1,3})\n255\n/s or die;
  35     my ($def,$w,$h)= ($1, $2+0, $3+0);
  36     my @d= grep { m/./ } split /\s+/, $';
  37     @d == $w*$h*3 or die "$d[0]|$d[1]|...|$d[$#d-1]|$d[$#d] ?";
  38     map {
  39         m/\D/ and die "$& ?";
  40         $_ += 0;
  41         $_ >= 0 or die "$_ ?";
  42         $_ <= 255 or die "$_ ?";
  43     } @d;
  44     my $ppm= "P3\n$w $h\n255\n";
  45     my $di=0;
  46     for (my $y=0; $y<$h; $y++) {
  47         for (my $x=0; $x<$w; $x++, $di+=3) {
  48 #print STDERR ">$x,$y,$di,",scalar(@d),"<\n";
  49             $ppm .= sprintf "  %3d %3d %3d", @d[$di..$di+2];
  50         }
  51         $ppm .= "\n";
  52     }
  53
  54     my $icon= pipeval($ppm,
  55                          'ppmtopgm',
  56                          'pnmscale -xysize 156 80',
  57                          'pnmnorm -bpercent 40 -wpercent 20',
  58                          'pgmtopbm -threshold',
  59                          'pnminvert',
  60                          'pbmtoascii -2x4');
  61
  62     my $whole= pipeval($ppm,
  63                        'ppmtopgm',
  64                        'pnmnorm -bpercent 40 -wpercent 20',
  65                        'pgmtopbm -threshold',
  66                        'pnminvert',
  67                        'pbmtoascii');
  68
  69     my $entry= "$def\n$ppm";
  70
  71     return ('',$def,$ppm,$ppm,$def, $w,$icon,$whole,$entry);
  72 }
  73
  74 #---------- characters ----------
  75
  76 sub parseentryin__char ($$) {
  77     my ($ei,$h) = @_;
  78     $ei =~ m/^(Digit|Upper|Lower)\n((?:[-&\'A-F0-9a-f ]|\x20)+)\n/s or die;
  79     my ($ctx,$str)= ($1,$2);
  80 #print STDERR ">$'<\n";
  81     my @d= grep { m/./ } split /\n/, $';
  82 #print STDERR ">@d<\n";
  83     die if $h>31;
  84     die if @d>400;
  85     my $maxval= (1<<$h)-1;
  86     map {
  87         m/^[0-9a-f]{1,8}$/ or die;
  88         $_= hex $_;
  89         die "$_ ?" if $_ > $maxval;
  90     } @d;
  91     my $w= @d;
  92     my $ppm= "P2\n$w $h\n1\n";
  93     my $whole='';
  94     for (my $y=0; $y<$h; $y++) {
  95         for (my $x=0; $x<$w; $x++) {
  96             my $pix= !($d[$x] & (1<<$y));
  97             $ppm .= sprintf " %d", $pix;
  98             $whole .= $pix ? '  ' : '<>';
  99         }
 100         $ppm .= "\n";
 101         $whole .= "\n";
 102     }
 103     map { $_= sprintf "%x", $_; } @d;
 104     my $key= join ' ', $ctx, @d;
 105
 106 #    my $whole= pipeval($ppm,
 107 #                     "pnmscale 2",
 108 #                     'pgmtopbm -threshold',
 109 #                     'pbmtoascii');
 110
 111     my $entry= "$ctx\n$str\n". join("\n", @d). "\n";
 112
 113     return ($ctx,$str,$ppm,$key,$str, $w*2,'',$whole,$entry);
 114 }
 115
 116 #---------- useful stuff ----------
 117
 118 sub pipeval ($@) {
 119     my ($val, @cmds) = @_;
 120     my (@pids);
 121
 122     my $lastpipe;
 123
 124     foreach my $cmd ('',@cmds) {
 125         my $pipe= new IO::Pipe or die $!;
 126         my $pid= fork();  defined $pid or die $!;
 127
 128         if (!$pid) {
 129             $pipe->writer();
 130             if (!$lastpipe) {
 131                  print $pipe $val or die $!;
 132                  exit 0;
 133              } else {
 134                  open STDIN, '<&', $lastpipe or die $!;
 135                  open STDOUT, '>&', $pipe or die $!;
 136                  close $lastpipe or die $!;
 137                  close $pipe or die $!;
 138                  exec $cmd; die $!;
 139              }
 140         }
 141         $pipe->reader();
 142         if ($lastpipe) { close $lastpipe or die $!; }
 143         $lastpipe= $pipe;
 144         push @pids, $pid;
 145     }
 146
 147     $!=0; { local ($/)=undef; $val= <$lastpipe>; }
 148     defined $val or die $!;
 149     $lastpipe->error and die $!;  close $lastpipe or die $!;
 150
 151     foreach my $cmd ('(paste)', @cmds) {
 152         my $pid= shift @pids;
 153         waitpid($pid,0) == $pid or die "$pid $? $!";
 154         $?==0 or $?==13 or die "$cmd $?";
 155     }
 156     return $val;
 157 }
 158
 159 #========== main program ==========
 160
 161 #---------- determine properties of the submission ----------
 162
 163 my $dict= param('dict');
 164 my $entry_in= param('entry');
 165 defined $entry_in or die;
 166
 167 my $ocean= param('ocean');
 168 my $pirate= param('pirate');
 169 if (defined $ocean && defined $pirate) {
 170     $pirate= "$ocean - $pirate";
 171 } else {
 172     $pirate= $ENV{'REMOTE_ADDR'};
 173     my $fwdf= $ENV{'HTTP_X_FORWARDED_FOR'};
 174     if (defined $fwdf) {
 175         $fwdf =~ s/\s//g;
 176         $fwdf =~ s/[^0-9.,]/?/g;
 177         $pirate= "$fwdf,$pirate";
 178     }
 179 }
 180
 181 my $kind;
 182 my @xa;
 183
 184 if ($dict =~ m/^pixmap$/) {
 185     $kind= $&;
 186 } elsif ($dict =~ m/^(char)([1-9]\d?)$/) {
 187     ($kind,@xa)= ($1,$2);
 188 } else {
 189     die "$dict ?";
 190 }
 191 $dict= $&;
 192
 193 my ($ctx,$def,$image,$key,$val, $width,$icon,$whole,$entry)=
 194     &{"parseentryin__$kind"}($entry_in, @xa);
 195
 196 #---------- compute the email to send ----------
 197
 198 my $whoami= `whoami`; $? and die $?;
 199 chomp $whoami;
 200
 201 my $email= <<END
 202 To: $whoami
 203 Subject: pctb $dict $ctx $def [ypp-sc-tools]
 204
 205 Pirate:     $pirate
 206 Dictionary: $dict
 207 Context:    $ctx
 208 Definition: $def
 209
 210 END
 211     ;
 212
 213 if (length $icon) {
 214     $email .= "$icon\n\n";
 215 }
 216
 217 $whole =~ s/(.*)\n/ sprintf "%-${width}s\n", $1 /mge;
 218 $whole =~ s/^/|/mg;
 219 $whole =~ s/\n/|\n/mg;
 220 $whole =~ s/^(.*)/ ",".('_' x $width).".\n".$1 /e;
 221 $whole =~ s/(.*)$/ $1."\n\`".('~' x $width)."'\n" /e;
 222
 223 my $lw= 79;
 224
 225 while ($whole =~ m/../) {
 226     my $lhs= $whole;
 227     $lhs =~ s/^(.{0,$lw}).*$/$1/mg;
 228     $whole =~ s/^.{1,$lw}//mg;
 229 #print STDERR "[[[[[$lhs########$whole]]]]]\n";
 230     $email .= $lhs;
 231 }
 232
 233 END
 234     ;
 235
 236 my $cutline= "-8<-\n";
 237 $email .= $cutline.$entry.$cutline;
 238
 239 #---------- prepare the database entry ----------
 240
 241 my $du=$ENV{'YPPSC_DICTUPDATES'};
 242 chdir $du or die "$du $!"
 243     if defined $du;
 244
 245
 246 my $fn_t= "_update.$$-xxxxxxxxxxxxxxxx.tmp";
 247 open F, "> $fn_t" or die "$fn_t $!";
 248 (stat F) or die $!;
 249 my $fn_i= sprintf "_update.$$-%016x.rdy", (stat _)[1];
 250
 251 print F "ypp-sc-tools dictionary update v1\n";
 252
 253 foreach my $v ($pirate,$dict,$ctx,$def,$image,$key,$val) {
 254     printf F "%d\n", length($v) or die $!;
 255     print F $v,"\n" or die $!;
 256 }
 257
 258 close F or die $!;
 259
 260 my @tm= localtime;
 261 my $tm= strftime "%Y-%m-%d %H:%M:%S %Z", @tm;
 262
 263 open L, ">> _dict.log" or die $!;
 264 my $ll= sprintf "%s %-6s %-31s %s", $tm, $dict, $pirate, $fn_i;
 265
 266 #---------- commit everything ----------
 267
 268 print L "$ll submit\n" or die $!;
 269 L->flush or die $!;
 270
 271 if (eval {
 272
 273     open S, "|sendmail -odb -oee -oi -t" or die $!;
 274     print S $email or die $!;
 275     $!=0; $?=0; close S or die $!; $? and die $?;
 276
 277     rename $fn_t, $fn_i or die "$fn_t $fn_i $!";
 278
 279     1;
 280 }) {
 281     print L "$ll stored\n" or die $!;
 282 } else {
 283     print L "$ll ERROR! $@\n" or die $!;
 284 }
 285 close L or die $!;
 286
 287 print header('text/plain'), "$fn_i\n" or die $!;