1 # This is part of ypp-sc-tools, a set of third-party tools for assisting
2 # players of Yohoho Puzzle Pirates.
4 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
6 # This program is free software: you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation, either version 3 of the License, or
9 # (at your option) any later version.
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with this program. If not, see <http://www.gnu.org/licenses/>.
19 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
20 # are used without permission. This program is not endorsed or
21 # sponsored by Three Rings.
23 package CommodsDatabase;
25 # Valid calling sequences:
26 # db_setocean('Midnight')
27 # [ db_filename() => 'OCEAN-Midnight.db' also OK at any later time ]
28 # [ db_writer() ] helpful but not essential
30 # [ db_onconflict(sub { .... }) ] essential if just dieing is not OK
31 # $dbh->do(...), $dbh->prepare(...), db_doall("stmt;stmt;"), etc.
43 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
46 @EXPORT = qw(&db_setocean &db_writer &db_connect $dbh
47 &db_filename &db_doall &db_onconflict
48 &dbr_filename &dbr_connect &db_connect_core);
54 sub dbr_filename ($$) {
55 my ($datadir,$oceanname) = @_;
56 return "$datadir/OCEAN-$oceanname.db";
58 sub dbr_connect ($$) {
59 my ($datadir,$ocean) = @_;
60 return connect_core(dbr_filename($datadir,$ocean));
63 sub db_connect_core ($) {
65 my $h= DBI->connect("dbi:SQLite:$fn",'','',
67 RaiseError=>1, ShowErrorStatement=>1,
69 or die "$fn $DBI::errstr ?";
71 # default timeout is 30s which is plenty
79 $dbfn= dbr_filename('.',$oceanname);
85 sub db_onconflict (&) {
86 my ($conflictproc) = @_;
87 $dbh->{HandleError}= sub {
88 my ($emsg,$dbh,$val1) = @_;
89 my $native_ecode= $dbh->err();
90 &$conflictproc($emsg) if grep { $_ == $native_ecode } qw(5 6);
91 # 5==SQLITE_BUSY, 6==SQLITE_LOCKED according to the SQLite3
92 # API documentation, .../capi3ref.html#extended-result-codes.
93 return 0; # RaiseError happens next.
100 my $lockfn= "Writer.lock";
101 $writerlockh= new IO::File "$lockfn", "w" or die "$lockfn $!";
103 my $flockall= pack 's!s!LLLLLL', F_WRLCK, SEEK_SET, 0,0,0,0,0,0;
104 # should work everywhere to lock the whole file, provided that
105 # l_type and l_whence are `short int' and come first in that order,
106 # and that start, len and pid are no more than 64 bits each.
108 my $r= fcntl($writerlockh, F_SETLKW, $flockall);
109 $r or die "$lockfn fcntl $!";
113 $dbh= connect_core($dbfn);
117 foreach my $cmd (split /\;/, $_[0]) {
118 $dbh->do("$cmd;") if $cmd =~ m/\S/;