X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-test.git;a=blobdiff_plain;f=yarrg%2FCommodsWeb.pm;h=5e120039838271ed9f5ce8377c397b49974b62a1;hp=f82e09cb2de18fad2d1ec7db7a195516b9e4c264;hb=b14effcf3ea7900eb4198f6e50112da751f29add;hpb=d97ce2e06c50ce30882d3482dfaefa14e52b309f diff --git a/yarrg/CommodsWeb.pm b/yarrg/CommodsWeb.pm index f82e09c..5e12003 100644 --- a/yarrg/CommodsWeb.pm +++ b/yarrg/CommodsWeb.pm @@ -1,26 +1,33 @@ -# This is part of ypp-sc-tools, a set of third-party tools for assisting -# players of Yohoho Puzzle Pirates. +# This is part of the YARRG website. YARRG is a tool and website +# for assisting players of Yohoho Puzzle Pirates. # # Copyright (C) 2009 Ian Jackson +# Copyright (C) 2009 Clare Boothby +# +# YARRG's client code etc. is covered by the ordinary GNU GPL (v3 or later). +# The YARRG website is covered by the GNU Affero GPL v3 or later, which +# basically means that every installation of the website will let you +# download the source. # # 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. +# it under the terms of the GNU Affero 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. +# GNU Affero General Public License for more details. # -# You should have received a copy of the GNU General Public License +# You should have received a copy of the GNU Affero 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. -# This package is used by the Mason scripts in yarrg/web/. + +# This Perl module is used by the Mason scripts in yarrg/web/. # We look for a symlink DATA to the actual data to use, so that # the data uploader and website displayer can use different code. @@ -31,49 +38,68 @@ use warnings; use DBI; use POSIX; +use JSON; use Commods; use CommodsDatabase; -our $self_url; -our $base_url; - BEGIN { use Exporter (); our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); $VERSION = 1.00; @ISA = qw(Exporter); - @EXPORT = qw(&dbw_connect &ocean_list $sourcebasedir); + @EXPORT = qw(&dbw_connect &dbw_filename &ocean_list &sourcebasedir + &to_json_shim &to_json_protecttags + &set_ctype_utf8 &webdatadir + &expected_error &dbw_lookup_string + &printable &tr_datarow &escerrq + &prettyprint_age &meta_prettyprint_age); %EXPORT_TAGS = ( ); @EXPORT_OK = qw(); } -our $datadir='.'; -our $sourcebasedir; - -for my $dir (@INC) { - if ($dir =~ m/\.perl-lib$/) { - $sourcebasedir= "$dir/.."; - if (stat "$dir/DATA") { - $datadir= "$dir/DATA"; - } elsif ($!==&ENOENT) { - $datadir= "$dir"; - } else { - die "stat $dir/DATA $!"; +sub dotperllibdir () { + my $dir; + + for my $dir (@INC) { + if ($dir =~ m/\.perl-lib$/) { + return $dir; } - last; } + die "no appropriate dotperllib dir in @INC"; +} + +sub sourcebasedir () { + return dotperllibdir().'/..'; +} + +sub some_datadir ($) { + my ($what) = @_; + my $edir= $ENV{"YARRG_${what}_DIR"}; + return $edir if defined $edir; + my $dir= dotperllibdir(); + my $dirwhat= "$dir/$what"; + if (stat $dirwhat) { + return $dirwhat; + } elsif ($!==&ENOENT) { + return "$dir"; + } else { + die "stat $dirwhat $!"; + } + return '.'; } -defined $sourcebasedir or - die "no source base dir in @INC"; + +sub webdatadir () { return some_datadir('WEBDATA'); } +sub datadir () { return some_datadir('DATA'); } my @ocean_list; sub ocean_list () { + my $datadir= datadir(); if (!@ocean_list) { - my $fn= "$datadir/master-info.txt"; - my $f= new IO::File $fn or die $!; + my $fn= "$datadir/source-info.txt"; + my $f= new IO::File $fn or die "$fn $!"; my @r; while (<$f>) { next unless m/^ocean\s+(\S.*\S)\s*$/; @@ -86,11 +112,128 @@ sub ocean_list () { return @ocean_list; } -sub dbw_connect ($) { +sub dbw_filename ($) { my ($ocean) = @_; die "unknown ocean $ocean ?" unless grep { $_ eq $ocean } ocean_list(); - return dbr_connect($datadir, $ocean); + return dbr_filename(datadir(), $ocean); +} + +sub dbw_connect ($) { + my ($ocean) = @_; + my $fn= dbw_filename($ocean); + return db_connect_core($fn); +} + +sub to_json_shim ($) { + my ($obj) = @_; + # In JSON.pm 2.x, jsonToObj prints a warning to stderr which + # our callers don't like at all. + if ($JSON::VERSION >= 2.0) { + return to_json($obj); + } else { + return objToJson($obj); + } +} + +sub to_json_protecttags ($) { + my ($v) = @_; + my $j= to_json_shim($v); + $j =~ s,/,\\/,g; + return $j; +} + +sub meta_prettyprint_age ($$$) { + my ($age,$floor,$plus) = @_; + return < ( $emsg, @dbresults ) + my ($each, + $sth, $stmt_nqs, $abbrev_initials, $maxambig, + $em_nomatch, $em_manyambig, $emf_ambiguous) = @_; + + $each =~ s/^\s*//; $each =~ s/\s*$//; $each =~ s/\s+/ /g; + my %m; + my $results; + my @pats= ("$each", "$each \%", "$each\%", "\%$each\%"); + if ($abbrev_initials) { + push @pats, join ' ', map { "$_%" } split //, $each; + } + foreach my $pat (@pats) { + $sth->execute(($pat) x $stmt_nqs); + $results= $sth->fetchall_arrayref(); + last if @$results==1; + $m{ $_->[0] }=1 for @$results; + $results= undef; + } + if (!$results) { + if (!%m) { + return $em_nomatch; + } elsif (keys(%m) > $maxambig) { + return $em_manyambig; + } else { + return $emf_ambiguous->($each, join(', ', sort keys %m)); + } + } + return (undef, @{ $results->[0] }); +} + +sub expected_error ($) { + my $r= { Emsg => $_[0] }; + bless $r, 'CommodsWeb::ExpectedError'; + die $r; +} + +sub printable ($) { # printable($m) where $m is the Mason request object + my ($m) = @_; + my $a= scalar $m->caller_args(-1); + foreach my $t (qw(pdf ps html pdf2 ps2)) { + return $t if $a->{"printable_$t"}; + } + return 0; +} + +sub tr_datarow ($$) { + my ($m, $lineno) = @_; + $lineno &= 1; + if (!printable($m)) { + $m->print(""); + } else { + $m->print(""); + } +} + +sub escerrq ($) { + return '"'.CGI::escapeHTML($_[0]).'"'; + # Prettier qotes as below are not in HTML 3.2: +# return '“'.CGI::escapeHTML($_[0]).'”'; +# return '‘'.CGI::escapeHTML($_[0]).'’'; +} + +package CommodsWeb::ExpectedError; + +sub emsg ($) { + my ($self) = @_; + return $self->{Emsg}; } 1;