X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-test.git;a=blobdiff_plain;f=pctb%2Fdictionary-update-receiver;fp=pctb%2Fdictionary-update-receiver;h=0000000000000000000000000000000000000000;hp=d088236b7429f2cb080b22624aa4949212ae7628;hb=c68fb80a6bbf7acbcac4b2cb2143f5fea745cd2b;hpb=b9cce976550d000f15e5a8f2b690740bdae1e468 diff --git a/pctb/dictionary-update-receiver b/pctb/dictionary-update-receiver deleted file mode 100755 index d088236..0000000 --- a/pctb/dictionary-update-receiver +++ /dev/null @@ -1,334 +0,0 @@ -#!/usr/bin/perl -w -# -# This script is invoked when the YPP SC PCTB client talks to the -# dictionary server. See README.privacy. - -# This is part of ypp-sc-tools, a set of third-party tools for assisting -# players of Yohoho Puzzle Pirates. -# -# Copyright (C) 2009 Ian Jackson -# -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -# -# Yohoho and Puzzle Pirates are probably trademarks of Three Rings and -# are used without permission. This program is not endorsed or -# sponsored by Three Rings. - - -# upload testing runes: -# -# YPPSC_PCTB_DICT_UPDATE=./ YPPSC_PCTB_DICT_SUBMIT=./ ./ypp-commodities --ocean midnight --pirate aristarchus --find-island --same --raw-tsv >raw.tsv -# ./dictionary-manager --debug --approve-updates '' . . - -use strict (qw(vars)); -use POSIX; - -$CGI::POST_MAX= 1024*1024; -$CGI::DISABLE_UPLOADS= 1; - -use CGI qw/:standard -private_tempfiles/; -use IO::Pipe; -use IO::Handle; - -my $aadepth=2; - -#---------- pixmaps ---------- - -sub parseentryin__pixmap ($) { - my ($entry_in) = @_; - $entry_in =~ - m/^(\S+ \- .*)\nP3\n([1-9]\d{1,3}) ([1-9]\d{1,3})\n255\n/s or die; - my ($def,$w,$h)= ($1, $2+0, $3+0); - my @d= grep { m/./ } split /\s+/, $'; - @d == $w*$h*3 or die "$d[0]|$d[1]|...|$d[$#d-1]|$d[$#d] ?"; - map { - m/\D/ and die "$& ?"; - $_ += 0; - $_ >= 0 or die "$_ ?"; - $_ <= 255 or die "$_ ?"; - } @d; - my $ppm= "P3\n$w $h\n255\n"; - my $di=0; - for (my $y=0; $y<$h; $y++) { - for (my $x=0; $x<$w; $x++, $di+=3) { -#print STDERR ">$x,$y,$di,",scalar(@d),"<\n"; - $ppm .= sprintf " %3d %3d %3d", @d[$di..$di+2]; - } - $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 10 -wpercent 5', - 'pgmtopbm -threshold', - 'pnminvert', - 'pbmtoascii'); - - my $entry= "$def\n$ppm"; - - return ('',$def,$ppm,$ppm,$def, $w,$icon,$whole,$entry); -} - -#---------- characters ---------- - -sub parseentryin__char ($$) { - my ($ei,$h) = @_; - $ei =~ m/^(Digit|Upper|Lower|Word)\n([^\n]+)\n/s or die; - my ($ctx,$str)= ($1,$2); -print STDERR ">ctx=$ctx|str=$str|$'<\n"; - my @d= grep { m/./ } split /\n/, $'; -print STDERR ">@d<\n"; - die if $h>100; - die if @d>400; - - my $w= @d; - - my $maxval= (1<<$aadepth)-1; - die 'cannot do [^0...$maxval]!' if $maxval>9; - - my $pgm= "P2\n$h $w\n$maxval\n"; - map { # x, left to right - m/[^0-$maxval]/ and die "$_ ?"; - my $l= $_; - $l =~ s/./ $&/g; - $pgm .= "$l\n"; - } @d; - - my $key= join ' ', $ctx, @d; - - $pgm= pipeval($pgm, - "pnmflip -xy", - "pnmnoraw"); - - my $icon= pipeval($pgm, - "pnmscale -xysize 156 ".($h*4), - 'pgmtopbm -threshold', - 'pnminvert', - 'pbmtoascii -2x4'); - - my $whole= pipeval($pgm, - "pnmscale 4", - 'pgmtopbm -fs', - 'pnminvert', - 'pbmtoascii'); - - my $entry= "$ctx\n$str\n$key\n"; - - return ($ctx,$str,$pgm,$key,$str, $w*4,$icon,$whole,$entry); -} - -#---------- 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; -} - -#========== main program ========== - -#---------- determine properties of the submission ---------- - -my $version= param('version'); -my $spec_aadepth= param('depth'); -if ($version ne '3' || $spec_aadepth ne $aadepth) { - print header('text/plain', - "403 YPP SC PCTB client is out of date". - " ($version, $spec_aadepth)"); - print "\nYour YPP SC client is out of date.\n"; - exit 0; -} - -my $dict= param('dict'); -my $entry_in= param('entry'); -defined $entry_in or die Dump()." ?"; - -my $ocean= param('ocean'); -my $pirate= param('pirate'); -if (defined $ocean && defined $pirate) { - $pirate= "$ocean - $pirate"; -} else { - $pirate= ''; -} - -my $caller= $ENV{'REMOTE_ADDR'}; -$caller= 'LOCAL' unless defined $caller; - -my $fwdf= $ENV{'HTTP_X_FORWARDED_FOR'}; -if (defined $fwdf) { - $fwdf =~ s/\s//g; - $fwdf =~ s/[^0-9.,]/?/g; - $caller= "$fwdf,$pirate"; -} - -my $kind; -my @xa; - -if ($dict =~ m/^pixmap$/) { - $kind= $&; -} elsif ($dict =~ m/^(char)([1-9]\d?)$/) { - ($kind,@xa)= ($1,$2); -} else { - die "$dict ?"; -} -$dict= $&; - -my ($ctx,$def,$image,$key,$val, $width,$icon,$whole,$entry)= - &{"parseentryin__$kind"}($entry_in, @xa); - -my $du=$ENV{'YPPSC_DICTUPDATES'}; -chdir $du or die "$du $!" - if defined $du; - -my $instance= $du; -$instance =~ s,ypp-sc-tools,,ig; -$instance =~ s,ypp,,ig; -$instance =~ s,pctb,,ig; -$instance =~ s,/\W+/,/,g; -$instance =~ s,/+$,,; -$instance =~ s,^.*/,,; - -#---------- compute the email to send ---------- - -my $whoami= `whoami`; $? and die $?; -chomp $whoami; - -my $email= < $fn_t" or die "$fn_t $!"; -(stat F) or die $!; -my $fn_i= sprintf "_update.$$-%016x.rdy", (stat _)[1]; - -print F "ypp-sc-tools dictionary update v3 depth=$aadepth\n"; - -foreach my $v ($pirate,$caller,$dict,$ctx,$def,$image,$key,$val) { - printf F "%d\n", length($v) or die $!; - print F $v,"\n" or die $!; -} - -close F or die $!; - -my @tm= localtime; -my $tm= strftime "%Y-%m-%d %H:%M:%S %Z", @tm; - -open L, ">> _dict.log" or die $!; -my $ll= sprintf "%s %-6s %-31s %-31s %s", $tm, $dict, $pirate, $caller, $fn_i; - -#---------- commit everything ---------- - -print L "$ll submit\n" or die $!; -L->flush or die $!; - -if (eval { - - open S, "|/usr/lib/sendmail -odb -oee -oi -t" or die $!; - print S $email or die $!; - $!=0; $?=0; close S or die $!; $? and die $?; - - rename $fn_t, $fn_i or die "$fn_t $fn_i $!"; - - 1; -}) { - print L "$ll stored\n" or die $!; -} else { - print L "$ll ERROR! $@\n" or die $!; - exit 1; -} -close L or die $!; - -print header('text/plain'), "OK $fn_i\n" or die $!;