pctb/dictionary-update-receiver

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