+++ /dev/null
-#!/usr/bin/perl -w
-#
-# This script is invoked to process an email sent by the
-# commod-update-receiver Perl script.
-
-# 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 <ijackson@chiark.greenend.org.uk>
-#
-# 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 <http://www.gnu.org/licenses/>.
-#
-# 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.
-
-# Emails are:
-# multipart/mixed, containing
-# text/plain; name="metadata"; charset="utf-8"
-# Content-Disposition: inline; filename="metadata"
-# ocean\t<ocean> canonical mixed case
-# island\t<island> canonical mixed case
-# timestamp\t<digits> time_t (non-leap secs since start of 1970 UTC)
-# clientname\t<cname> may contain spaces
-# clientversion\t<cversion> may contain spaces
-# clientfixes\t<cfixes> space-delimited list
-# clientspec\t<cspec> <cname>\t<cversion>\t<cfixes>
-# servername\t<sname> may contain spaces
-# serverversion\t<sversion> may contain spaces
-# serverfixes\t<sfixes> space-delimited list
-# serverspec\t<sspec> <sname>\t<serverversion>\t<serverfixes>
-# application/octet-stream; name="deduped.tsv.gz"
-# Content-Disposition: attachment; filename="deduped.tsv.gz"
-# <base64>
-
-use strict (qw(vars));
-
-use POSIX;
-use MIME::Parser;
-
-use Commods;
-use CommodsDatabase;
-
-setlocale(LC_CTYPE, "en_GB.UTF-8");
-my $parser= new MIME::Parser;
-our $entity;
-
-$|=1;
-
-sub find_part ($$$) {
- my ($filename, $type, $accepter) = @_;
- foreach my $part ($entity->parts()) {
- my $h= $part->head();
- next unless $h->recommended_filename() eq $filename;
- next unless $h->mime_type() eq $type;
- next unless $part->effective_type() eq $type;
- next if defined $accepter and !&$accepter($h);
- return $part;
- }
- die "no appropriate part with name $filename and type $type";
-}
-
-sub bad_data_fail ($) { die $_[0]; }
-
-sub main () {
- $parser->extract_nested_messages(0);
- $parser->ignore_errors(0);
-
- $entity= $parser->parse(\*STDIN);
- my $eff_type= $entity->effective_type();
- die "effective type $eff_type\n" unless $eff_type eq 'multipart/mixed';
-
- my $mdpart= find_part('metadata', 'text/plain', sub {
- my $charset= $_[0]->mime_attr('content-type.charset');
- return 1 if grep { $_ eq $charset } qw(utf-8 us-ascii);
- });
-
- my $mdh= $mdpart->open('r') or die "failed to open metadata $!\n";
- my %md;
- while (defined($_= $mdh->getline())) {
- m/^([a-z]+)\t(.*)$/ or next;
- $md{$1}= $2;
- }
-
- foreach my $needed (qw(ocean island timestamp clientspec serverspec)) {
- defined $md{$needed} or die "missing metadata $needed\n";
- }
-
- my $mid= $entity->head()->get('message-id');
- defined $mid or die "missing Message-ID\n";
- chomp($mid);
- $mid !~ m/[^ -~]/ or die "Message-ID has strange character(s)\n";
-
- my $tsvpart= find_part('deduped.tsv.gz', 'application/octet-stream',
- undef);
- my $tsv= pipethrough_prep();
- $tsvpart->bodyhandle()->print($tsv);
- my $pt= pipethrough_run_along($tsv,undef, 'gunzip','gunzip');
-
- db_setocean($md{'ocean'});
- my $dbfn= db_filename();
- (stat $dbfn) or die "stat database $dbfn failed $!\n";
- db_connect();
-
- my ($islandid) = $dbh->selectrow_array(
- "SELECT islands.islandid
- FROM islands
- WHERE islandname == ?;
- ", {}, $md{'island'});
-
- die "unknown island\n" unless defined $islandid;
-
- db_doall("DELETE FROM uploads WHERE islandid == $islandid;
- DELETE FROM buy WHERE islandid == $islandid;
- DELETE FROM sell WHERE islandid == $islandid;
- ");
-
- $dbh->do("INSERT INTO uploads
- (islandid, message,
- timestamp, clientspec, serverspec)
- VALUES (?,?,?,?,?);
- ", {},
- $islandid, $mid,
- map { $md{$_} } (qw(timestamp clientspec serverspec)));
-
- my (%sth, %sub_cs, %cache_cs, %sth_insert);
-
- $sth_insert{'stall'}= $dbh->prepare(
- "INSERT OR IGNORE
- INTO stalls
- (islandid, stallname) VALUES ($islandid, ?)
- ");
- $sth_insert{'commods'}= $dbh->prepare(
- "INSERT OR IGNORE
- INTO commods
- (commodname) VALUES (?)
- ");
-
- foreach my $cs (qw(stall commod)) {
- my $sth_lookup= $dbh->prepare(
- "SELECT ${cs}id FROM ${cs}s WHERE ${cs}name == ?;
- ");
- $sub_cs{$cs}= sub {
- my ($name)= @_;
- my $r= $cache_cs{$cs}{$name};
- return $r if defined $r;
- $sth_lookup->execute($name) or die;
- ($r)= $sth_lookup->fetchrow_array();
- if (!defined $r) {
- $sth_insert{$cs}->execute($name);
- $sth_lookup->execute($name) or die;
- ($r)= $sth_lookup->fetchrow_array();
- die unless defined $r;
- }
- $cache_cs{$cs}{$name}= $r;
- return $r;
- };
- }
- my @v;
-
- my %sub_bs;
- foreach my $bs (qw(buy sell)) {
- my $sth= $dbh->prepare(
- "INSERT INTO $bs
- (commodid, stallid, islandid, price, qty)
- VALUES (?,?,?,?,?);
- ");
- $sub_bs{$bs}= sub {
- my ($priceix) = @_;
- my $price= $v[$priceix]; return if !length $price;
- my $qty= $v[$priceix+1];
- $qty++ if $qty =~ s/^\>//;
- $sth->execute($sub_cs{'commod'}($v[0]),
- $sub_cs{'stall'}($v[1]),
- $islandid,$price,$qty);
- };
- }
-
- while (<$pt>) {
- @v= check_tsv_line($_, \&bad_data_fail);
-# chomp;
-# @v= split /\t/, $_, -1;
-
- &{$sub_bs{'buy'}}(2);
- &{$sub_bs{'sell'}}(4);
-
-# print ".";
- }
-
- pipethrough_run_finish($pt, 'gunzip <$deduped_tsv.gz');
-
- print "\n";
- $dbh->commit();
-
- # select * from ((buy natural join commods) natural join stalls) natural join islands;
- # select * from ((sell natural join commods) natural join stalls) natural join islands;
-
-}
-
-my $ok= eval {
- main();
- 1;
-};
-my $err= $@;
-
-$parser->filer->purge();
-
-if (!$ok) {
- print STDERR "PROCESSING FAILED\n $@\n";
- exit 1;
-}
~yarrgweb / ypp-sc-tools.db-test.git / blobdiff