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     return ('',$def,$ppm,$ppm,$def);
  55 }
  56
  57 #---------- characters ----------
  58
  59 sub parseentryin__char ($$) {
  60     my ($ei,$h) = @_;
  61     $ei =~ m/^(Digit|Upper|Lower)\n((?:[-&\'A-F0-9a-f ]|\x20)+)\n/s or die;
  62     my ($ctx,$str)= ($1,$2);
  63 #print STDERR ">$'<\n";
  64     my @d= grep { m/./ } split /\n/, $';
  65 #print STDERR ">@d<\n";
  66     die if $h>31;
  67     die if @d>400;
  68     my $maxval= (1<<$h)-1;
  69     map {
  70         m/^[0-9a-f]{1,8}$/ or die;
  71         $_= hex $_;
  72         die "$_ ?" if $_ > $maxval;
  73     } @d;
  74     my $w= @d;
  75     my $ppm= "P2\n$w $h\n1\n";
  76     for (my $y=0; $y<$h; $y++) {
  77         for (my $x=0; $x<$w; $x++) {
  78             $ppm .= sprintf " %d", !($d[$x] & (1<<$y));
  79         }
  80         $ppm .= "\n";
  81     }
  82     my $key= join ' ', $ctx, map { sprintf "%x", $_; } @d;
  83
  84     return ($ctx,$str,$ppm,$key,$str);
  85 }
  86
  87 #---------- main program ----------
  88
  89 my $dict= param('dict');
  90 my $entry_in= param('entry');
  91 defined $entry_in or die;
  92
  93 my $ocean= param('ocean');
  94 my $pirate= param('pirate');
  95 if (defined $ocean && defined $pirate) {
  96     $pirate= "$ocean - $pirate";
  97 } else {
  98     $pirate= $ENV{'REMOTE_ADDR'};
  99     my $fwdf= $ENV{'HTTP_X_FORWARDED_FOR'};
 100     if (defined $fwdf) {
 101         $fwdf =~ s/\s//g;
 102         $fwdf =~ s/[^0-9.,]/?/g;
 103         $pirate= "$fwdf,$pirate";
 104     }
 105 }
 106
 107 my $du=$ENV{'YPPSC_DICTUPDATES'};
 108 chdir $du or die "$du $!"
 109     if defined $du;
 110
 111 my $kind;
 112 my @xa;
 113
 114 if ($dict =~ m/^pixmap$/) {
 115     $kind= $&;
 116 } elsif ($dict =~ m/^(char)([1-9]\d?)$/) {
 117     ($kind,@xa)= ($1,$2);
 118 } else {
 119     die "$dict ?";
 120 }
 121 $dict= $&;
 122
 123 my ($ctx,$def,$image,$key,$val)= &{"parseentryin__$kind"}($entry_in, @xa);
 124
 125 my $fn_t= "_update.$$-xxxxxxxxxxxxxxxx.tmp";
 126 open F, "> $fn_t" or die "$fn_t $!";
 127 (stat F) or die $!;
 128 my $fn_i= sprintf "_update.$$-%016x.rdy", (stat _)[1];
 129
 130 print F "ypp-sc-tools dictionary update v1\n";
 131
 132 foreach my $v ($pirate,$dict,$ctx,$def,$image,$key,$val) {
 133     printf F "%d\n", length($v) or die $!;
 134     print F $v,"\n" or die $!;
 135 }
 136
 137 close F or die $!;
 138
 139 my @tm= localtime;
 140 my $tm= strftime "%Y-%m-%d %H:%M:%S %Z", @tm;
 141
 142 open L, ">> _dict.log" or die $!;
 143 my $ll= sprintf "%s %-6s %-31s %s %s\n", $tm, $dict, $pirate, $fn_i, "submit";
 144 print L $ll or die $!;
 145 close L or die $!;
 146
 147 rename $fn_t, $fn_i or die "$fn_t $fn_i $!";