# 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 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 Affero General Public License for more details. # # 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 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. package CommodsWeb; use strict; use warnings; use DBI; use POSIX; use JSON; use Commods; use CommodsDatabase; BEGIN { use Exporter (); our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); $VERSION = 1.00; @ISA = qw(Exporter); @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(); } sub dotperllibdir () { my $dir; for my $dir (@INC) { if ($dir =~ m/\.perl-lib$/) { return $dir; } } 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 '.'; } 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/source-info.txt"; my $f= new IO::File $fn or die "$fn $!"; my @r; while (<$f>) { next unless m/^ocean\s+(\S.*\S)\s*$/; push @r, $1; } $f->error and die $!; close $fn; @ocean_list= @r; } return @ocean_list; } sub dbw_filename ($) { my ($ocean) = @_; die "unknown ocean $ocean ?" unless grep { $_ eq $ocean } ocean_list(); 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;