summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Multi/API.pm670
-rw-r--r--lib/Multi/Anime.pm108
-rw-r--r--lib/Multi/Core.pm4
-rw-r--r--lib/Multi/DLsite.pm18
-rw-r--r--lib/Multi/Denpa.pm39
-rw-r--r--lib/Multi/Feed.pm155
-rw-r--r--lib/Multi/IRC.pm187
-rw-r--r--lib/Multi/JASTUSA.pm87
-rw-r--r--lib/Multi/JList.pm48
-rw-r--r--lib/Multi/Maintenance.pm80
-rw-r--r--lib/Multi/RG.pm347
-rw-r--r--lib/Multi/Wikidata.pm2
-rw-r--r--lib/PWLookup.pm155
-rw-r--r--lib/SkinFile.pm74
-rw-r--r--lib/VNDB/BBCode.pm190
-rw-r--r--lib/VNDB/Config.pm62
-rw-r--r--lib/VNDB/DB/Chars.pm201
-rw-r--r--lib/VNDB/DB/Discussions.pm176
-rw-r--r--lib/VNDB/DB/Misc.pm119
-rw-r--r--lib/VNDB/DB/Producers.pm131
-rw-r--r--lib/VNDB/DB/Releases.pm269
-rw-r--r--lib/VNDB/DB/Staff.pm79
-rw-r--r--lib/VNDB/DB/Tags.pm256
-rw-r--r--lib/VNDB/DB/Traits.pm113
-rw-r--r--lib/VNDB/DB/ULists.pm77
-rw-r--r--lib/VNDB/DB/Users.pm49
-rw-r--r--lib/VNDB/DB/VN.pm369
-rw-r--r--lib/VNDB/ExtLinks.pm387
-rw-r--r--lib/VNDB/Func.pm382
-rw-r--r--lib/VNDB/Handler/Chars.pm531
-rw-r--r--lib/VNDB/Handler/Misc.pm252
-rw-r--r--lib/VNDB/Handler/Producers.pm500
-rw-r--r--lib/VNDB/Handler/Releases.pm565
-rw-r--r--lib/VNDB/Handler/Staff.pm116
-rw-r--r--lib/VNDB/Handler/Tags.pm517
-rw-r--r--lib/VNDB/Handler/Traits.pm457
-rw-r--r--lib/VNDB/Handler/ULists.pm51
-rw-r--r--lib/VNDB/Handler/VNBrowse.pm143
-rw-r--r--lib/VNDB/Handler/VNEdit.pm541
-rw-r--r--lib/VNDB/Handler/VNPage.pm1062
-rw-r--r--lib/VNDB/Schema.pm38
-rw-r--r--lib/VNDB/Skins.pm27
-rw-r--r--lib/VNDB/Types.pm246
-rw-r--r--lib/VNDB/Util/Auth.pm129
-rw-r--r--lib/VNDB/Util/BrowseHTML.pm190
-rw-r--r--lib/VNDB/Util/CommonHTML.pm327
-rw-r--r--lib/VNDB/Util/FormHTML.pm282
-rw-r--r--lib/VNDB/Util/LayoutHTML.pm43
-rw-r--r--lib/VNDB/Util/Misc.pm122
-rw-r--r--lib/VNDB/Util/ValidateTemplates.pm110
-rw-r--r--lib/VNDBUtil.pm145
-rw-r--r--lib/VNWeb/API.pm1085
-rw-r--r--lib/VNWeb/AdvSearch.pm963
-rw-r--r--lib/VNWeb/Auth.pm271
-rw-r--r--lib/VNWeb/Chars/Edit.pm163
-rw-r--r--lib/VNWeb/Chars/Elm.pm23
-rw-r--r--lib/VNWeb/Chars/List.pm146
-rw-r--r--lib/VNWeb/Chars/Page.pm231
-rw-r--r--lib/VNWeb/Chars/VNTab.pm68
-rw-r--r--lib/VNWeb/DB.pm152
-rw-r--r--lib/VNWeb/Discussions/Board.pm23
-rw-r--r--lib/VNWeb/Discussions/Edit.pm139
-rw-r--r--lib/VNWeb/Discussions/Elm.pm40
-rw-r--r--lib/VNWeb/Discussions/Index.pm10
-rw-r--r--lib/VNWeb/Discussions/Lib.pm61
-rw-r--r--lib/VNWeb/Discussions/PostEdit.pm89
-rw-r--r--lib/VNWeb/Discussions/Search.pm123
-rw-r--r--lib/VNWeb/Discussions/Thread.pm127
-rw-r--r--lib/VNWeb/Discussions/UPosts.pm44
-rw-r--r--lib/VNWeb/Docs/Edit.pm34
-rw-r--r--lib/VNWeb/Docs/Lib.pm22
-rw-r--r--lib/VNWeb/Docs/Page.pm15
-rw-r--r--lib/VNWeb/Elm.pm298
-rw-r--r--lib/VNWeb/Filters.pm246
-rw-r--r--lib/VNWeb/Graph.pm119
-rw-r--r--lib/VNWeb/HTML.pm820
-rw-r--r--lib/VNWeb/Images/Lib.pm166
-rw-r--r--lib/VNWeb/Images/List.pm209
-rw-r--r--lib/VNWeb/Images/Upload.pm86
-rw-r--r--lib/VNWeb/Images/Vote.pm138
-rw-r--r--lib/VNWeb/JS.pm73
-rw-r--r--lib/VNWeb/Misc/AdvSearch.pm31
-rw-r--r--lib/VNWeb/Misc/BBCode.pm10
-rw-r--r--lib/VNWeb/Misc/ElmAnime.pm25
-rw-r--r--lib/VNWeb/Misc/Feeds.pm80
-rw-r--r--lib/VNWeb/Misc/History.pm148
-rw-r--r--lib/VNWeb/Misc/HomePage.pm286
-rw-r--r--lib/VNWeb/Misc/Lockdown.pm54
-rw-r--r--lib/VNWeb/Misc/OpenSearch.pm22
-rw-r--r--lib/VNWeb/Misc/Redirects.pm46
-rw-r--r--lib/VNWeb/Misc/Reports.pm271
-rw-r--r--lib/VNWeb/Prelude.pm72
-rw-r--r--lib/VNWeb/Producers/Edit.pm114
-rw-r--r--lib/VNWeb/Producers/Elm.pm34
-rw-r--r--lib/VNWeb/Producers/Graph.pm72
-rw-r--r--lib/VNWeb/Producers/List.pm75
-rw-r--r--lib/VNWeb/Producers/Page.pm183
-rw-r--r--lib/VNWeb/Releases/DRM.pm120
-rw-r--r--lib/VNWeb/Releases/Edit.pm220
-rw-r--r--lib/VNWeb/Releases/Elm.pm61
-rw-r--r--lib/VNWeb/Releases/Engines.pm43
-rw-r--r--lib/VNWeb/Releases/Lib.pm185
-rw-r--r--lib/VNWeb/Releases/List.pm92
-rw-r--r--lib/VNWeb/Releases/Page.pm231
-rw-r--r--lib/VNWeb/Releases/VNTab.pm263
-rw-r--r--lib/VNWeb/Reviews/Edit.pm122
-rw-r--r--lib/VNWeb/Reviews/JS.pm24
-rw-r--r--lib/VNWeb/Reviews/Lib.pm30
-rw-r--r--lib/VNWeb/Reviews/List.pm87
-rw-r--r--lib/VNWeb/Reviews/Page.pm166
-rw-r--r--lib/VNWeb/Reviews/VNTab.pm93
-rw-r--r--lib/VNWeb/Staff/Edit.pm81
-rw-r--r--lib/VNWeb/Staff/Elm.pm34
-rw-r--r--lib/VNWeb/Staff/List.pm94
-rw-r--r--lib/VNWeb/Staff/Page.pm121
-rw-r--r--lib/VNWeb/TT/Elm.pm56
-rw-r--r--lib/VNWeb/TT/Index.pm88
-rw-r--r--lib/VNWeb/TT/Lib.pm102
-rw-r--r--lib/VNWeb/TT/List.pm102
-rw-r--r--lib/VNWeb/TT/TagEdit.pm154
-rw-r--r--lib/VNWeb/TT/TagLinks.pm (renamed from lib/VNWeb/Tags/Links.pm)51
-rw-r--r--lib/VNWeb/TT/TagPage.pm161
-rw-r--r--lib/VNWeb/TT/TraitEdit.pm134
-rw-r--r--lib/VNWeb/TT/TraitPage.pm149
-rw-r--r--lib/VNWeb/TableOpts.pm297
-rw-r--r--lib/VNWeb/Tags/Elm.pm24
-rw-r--r--lib/VNWeb/Tags/Lib.pm16
-rw-r--r--lib/VNWeb/TimeZone.pm512
-rw-r--r--lib/VNWeb/TitlePrefs.pm217
-rw-r--r--lib/VNWeb/ULists/Elm.pm297
-rw-r--r--lib/VNWeb/ULists/Export.pm127
-rw-r--r--lib/VNWeb/ULists/Lib.pm96
-rw-r--r--lib/VNWeb/ULists/List.pm348
-rw-r--r--lib/VNWeb/User/Admin.pm74
-rw-r--r--lib/VNWeb/User/Css.pm37
-rw-r--r--lib/VNWeb/User/Delete.pm214
-rw-r--r--lib/VNWeb/User/Edit.pm274
-rw-r--r--lib/VNWeb/User/List.pm47
-rw-r--r--lib/VNWeb/User/Lists.pm590
-rw-r--r--lib/VNWeb/User/Login.pm57
-rw-r--r--lib/VNWeb/User/Notifications.pm149
-rw-r--r--lib/VNWeb/User/Page.pm118
-rw-r--r--lib/VNWeb/User/PassReset.pm52
-rw-r--r--lib/VNWeb/User/PassSet.pm32
-rw-r--r--lib/VNWeb/User/Register.pm67
-rw-r--r--lib/VNWeb/VN/Edit.pm239
-rw-r--r--lib/VNWeb/VN/Elm.pm37
-rw-r--r--lib/VNWeb/VN/Graph.pm143
-rw-r--r--lib/VNWeb/VN/Length.pm213
-rw-r--r--lib/VNWeb/VN/List.pm450
-rw-r--r--lib/VNWeb/VN/Page.pm1036
-rw-r--r--lib/VNWeb/VN/Quotes.pm399
-rw-r--r--lib/VNWeb/VN/Tagmod.pm74
-rw-r--r--lib/VNWeb/VN/Votes.pm24
-rw-r--r--lib/VNWeb/Validation.pm319
155 files changed, 16526 insertions, 11852 deletions
diff --git a/lib/Multi/API.pm b/lib/Multi/API.pm
index d7c59378..8b9dfdbb 100644
--- a/lib/Multi/API.pm
+++ b/lib/Multi/API.pm
@@ -5,7 +5,7 @@
package Multi::API;
-use strict;
+use v5.26;
use warnings;
use Multi::Core;
use Socket 'SO_KEEPALIVE', 'SOL_SOCKET', 'IPPROTO_TCP';
@@ -15,11 +15,12 @@ use POE::Filter::VNDBAPI 'encode_filters';
use Encode 'encode_utf8', 'decode_utf8';
use Crypt::URandom 'urandom';
use Crypt::ScryptKDF 'scrypt_raw';;
-use VNDBUtil 'normalize_query', 'norm_ip';
+use VNDB::Func 'imgurl', 'imgsize', 'norm_ip', 'resolution', 'is_insecurepass';
use VNDB::Types;
use VNDB::Config;
use JSON::XS;
-use PWLookup;
+use List::Util 'min', 'max';
+use VNDB::ExtLinks 'sql_extlinks';
# Linux-specific, not exported by the Socket module.
sub TCP_KEEPIDLE () { 4 }
@@ -146,7 +147,8 @@ sub cres {
writelog $c, '[%2d/%4.0fms %5.0f] %s',
$c->{sqlq}, $c->{sqlt}*1000, length($msg),
@arg ? sprintf $log, @arg : $log;
- cmd_read($c);
+ if($c->{disconnect}) { $c->{h}->push_shutdown() }
+ else { cmd_read($c); }
}
@@ -229,6 +231,16 @@ sub cmd_handle {
return login($c, @arg) if $cmd eq 'login';
return cerr $c, needlogin => 'Not logged in.' if !$c->{client};
+ # logout
+ if($cmd eq 'logout') {
+ return cerr $c, parse => 'Too many arguments to logout command' if @arg > 0;
+ return cerr $c, needlogin => 'No session token associated with this connection' if !$c->{sessiontoken};
+ return pg_cmd 'SELECT user_logout($1, decode($2, \'hex\'))', [ $c->{uid}, $c->{sessiontoken} ], sub {
+ $c->{disconnect} = 1;
+ cres $c, ['ok'], 'Logged out, session invalidated';
+ }
+ }
+
# dbstats
if($cmd eq 'dbstats') {
return cerr $c, parse => 'Too many arguments to dbstats command' if @arg > 0;
@@ -260,42 +272,64 @@ sub login {
!exists $arg->{$_} && return cerr $c, missing => "Required field '$_' is missing", field => $_
for(qw|protocol client clientver|);
- for(qw|protocol client clientver username password|) {
+ for(qw|protocol client clientver username password sessiontoken|) {
exists $arg->{$_} && !defined $arg->{$_} && return cerr $c, badarg => "Field '$_' cannot be null", field => $_;
exists $arg->{$_} && ref $arg->{$_} && return cerr $c, badarg => "Field '$_' must be a scalar", field => $_;
}
return cerr $c, badarg => 'Unknown protocol version', field => 'protocol' if $arg->{protocol} ne '1';
- return cerr $c, badarg => 'The fields "username" and "password" must either both be present or both be missing.', field => 'username'
- if exists $arg->{username} && !exists $arg->{password} || exists $arg->{password} && !exists $arg->{username};
return cerr $c, badarg => 'Invalid client name', field => 'client' if $arg->{client} !~ /^[a-zA-Z0-9 _-]{3,50}$/;
return cerr $c, badarg => 'Invalid client version', field => 'clientver' if $arg->{clientver} !~ /^[a-zA-Z0-9_.\/-]{1,25}$/;
+ return cerr $c, badarg => '"createsession" can only be used when logging in with a password.' if !exists $arg->{password} && exists $arg->{createsession};
+ return cerr $c, badarg => 'Missing "username" field.', field => 'username' if !exists $arg->{username} && (exists $arg->{password} || exists $arg->{sessiontoken});
+
if(!exists $arg->{username}) {
$c->{client} = $arg->{client};
$c->{clientver} = $arg->{clientver};
cres $c, ['ok'], 'Login using client "%s" ver. %s', $c->{client}, $c->{clientver};
- return;
- } else {
- $arg->{username} = lc $arg->{username};
+
+ } elsif(exists $arg->{password}) {
return cerr $c, auth => "Password too weak, please log in on the site and change your password"
- if config->{password_db} && PWLookup::lookup(config->{password_db}, $arg->{password});
- }
+ if is_insecurepass($arg->{password});
+ login_auth($c, $arg);
+
+ } elsif(exists $arg->{sessiontoken}) {
+ return cerr $c, badarg => 'Invalid session token', field => 'sessiontoken' if $arg->{sessiontoken} !~ /^[a-fA-F0-9]{40}$/;
+ cpg $c,
+ 'SELECT u.id, u.username FROM users u JOIN users_shadow us ON us.id = u.id
+ WHERE lower(u.username) = lower($1) AND us.delete_at IS NULL AND user_validate_session(u.id, decode($2, \'hex\'), \'api\') IS DISTINCT FROM NULL',
+ [ $arg->{username}, $arg->{sessiontoken} ], sub {
+ if($_[0]->nRows == 1) {
+ $c->{uid} = $_[0]->value(0,0);
+ $c->{username} = $_[0]->value(0,1);
+ $c->{client} = $arg->{client};
+ $c->{clientver} = $arg->{clientver};
+ $c->{sessiontoken} = $arg->{sessiontoken};
+ cres $c, ['ok'], 'Successful login with session by %s (%s) using client "%s" ver. %s', $c->{username}, $c->{uid}, $c->{client}, $c->{clientver};
+ } else {
+ cerr $c, auth => "Wrong session token for user '$arg->{username}'";
+ }
+ };
- login_auth($c, $arg);
+ } else {
+ return cerr $c, badarg => 'Missing "password" or "sessiontoken" field.';
+ }
}
sub login_auth {
my($c, $arg) = @_;
- # check login throttle
+ # check login throttle (also used when logging in with a session... oh well)
cpg $c, 'SELECT extract(\'epoch\' from timeout) FROM login_throttle WHERE ip = $1', [ norm_ip($c->{ip}) ], sub {
my $tm = $_[0]->nRows ? $_[0]->value(0,0) : AE::time;
return cerr $c, auth => "Too many failed login attempts"
if $tm-AE::time() > config->{login_throttle}[1];
# Fetch user info
- cpg $c, 'SELECT id, encode(user_getscryptargs(id), \'hex\') FROM users WHERE username = $1', [ $arg->{username} ], sub {
+ cpg $c, '
+ SELECT u.id, u.username, encode(user_getscryptargs(u.id), \'hex\') FROM users u JOIN users_shadow us ON us.id = u.id
+ WHERE us.delete_at IS NULL AND lower(u.username) = lower($1)', [ $arg->{username} ], sub {
login_verify($c, $arg, $tm, $_[0]);
};
};
@@ -307,26 +341,32 @@ sub login_verify {
return cerr $c, auth => "No user with the name '$arg->{username}'" if $res->nRows == 0;
my $uid = $res->value(0,0);
- my $sargs = $res->value(0,1);
+ my $username = $res->value(0,1);
+ my $sargs = $res->value(0,2);
return cerr $c, auth => "Account disabled" if !$sargs || length($sargs) != 14*2;
- my $token = urandom(20);
+ my $token = unpack 'H*', urandom(20);
my($N, $r, $p, $salt) = unpack 'NCCa8', pack 'H*', $sargs;
my $passwd = pack 'NCCa8a*', $N, $r, $p, $salt, scrypt_raw(encode_utf8($arg->{password}), config->{scrypt_salt} . $salt, $N, $r, $p, 32);
- cpg $c, 'SELECT user_login($1, decode($2, \'hex\'), decode($3, \'hex\'))', [ $uid, unpack('H*', $passwd), unpack('H*', $token) ], sub {
+ cpg $c, 'SELECT user_login($1, \'api\', decode($2, \'hex\'), decode($3, \'hex\'))', [ $uid, unpack('H*', $passwd), $token ], sub {
if($_[0]->nRows == 1 && ($_[0]->value(0,0)||'') =~ /t/) {
$c->{uid} = $uid;
- $c->{username} = $arg->{username};
+ $c->{username} = $username;
$c->{client} = $arg->{client};
$c->{clientver} = $arg->{clientver};
- pg_cmd 'SELECT user_logout($1, decode($2, \'hex\'))', [ $uid, unpack('H*', $token) ];
- cres $c, ['ok'], 'Successful login by %s (%s) using client "%s" ver. %s', $arg->{username}, $c->{uid}, $c->{client}, $c->{clientver};
+ if($arg->{createsession}) {
+ $c->{sessiontoken} = $token;
+ cres $c, ['session', $token], 'Successful login with password+session by %s (%s) using client "%s" ver. %s', $username, $c->{uid}, $c->{client}, $c->{clientver};
+ } else {
+ pg_cmd 'SELECT user_logout($1, decode($2, \'hex\'))', [ $uid, $token ];
+ cres $c, ['ok'], 'Successful login with password by %s (%s) using client "%s" ver. %s', $username, $c->{uid}, $c->{client}, $c->{clientver};
+ }
} else {
my @a = ( $tm + config->{login_throttle}[0], norm_ip($c->{ip}) );
pg_cmd 'UPDATE login_throttle SET timeout = to_timestamp($1) WHERE ip = $2', \@a;
pg_cmd 'INSERT INTO login_throttle (ip, timeout) SELECT $2, to_timestamp($1) WHERE NOT EXISTS(SELECT 1 FROM login_throttle WHERE ip = $2)', \@a;
- cerr $c, auth => "Wrong password for user '$arg->{username}'";
+ cerr $c, auth => "Wrong password for user '$username'";
}
};
}
@@ -337,8 +377,7 @@ sub dbstats {
cpg $c, 'SELECT section, count FROM stats_cache', undef, sub {
my $res = shift;
- cres $c, [ dbstats => { map {
- $_->{section} =~ s/^threads_//;
+ cres $c, [ dbstats => { users => 0, threads => 0, posts => 0, map {
($_->{section}, 1*$_->{count})
} $res->rowsAsHashes } ], 'dbstats';
};
@@ -363,6 +402,8 @@ sub parsedate {
sub formatwd { $_[0] ? "Q$_[0]" : undef }
+sub idnum { defined $_[0] ? 1*($_[0] =~ s/^[a-z]+//r) : undef }
+
sub splitarray {
(my $s = shift) =~ s/^{(.*)}$/$1/;
@@ -370,6 +411,23 @@ sub splitarray {
}
+# Returns an image flagging structure or undef if $image is false.
+# Assumes $obj has c_votecount, c_sexual_avg and c_violence_avg.
+# Those fields are removed from $obj.
+sub image_flagging {
+ my($image, $obj) = @_;
+ my $flag = {
+ votecount => delete $obj->{c_votecount},
+ sexual_avg => delete $obj->{c_sexual_avg},
+ violence_avg => delete $obj->{c_violence_avg},
+ };
+ $flag->{votecount} *= 1 if defined $flag->{votecount};
+ $flag->{sexual_avg} /= 100 if defined $flag->{sexual_avg};
+ $flag->{violence_avg} /= 100 if defined $flag->{violence_avg};
+ $image ? $flag : undef;
+}
+
+
# sql => str: Main sql query, three printf args: select, where part, order by and limit clauses
# sqluser => str: Alternative to 'sql' if the user is logged in. One additional printf arg: user id.
# If sql is undef and sqluser isn't, the command is only available to logged in users.
@@ -391,63 +449,82 @@ sub splitarray {
# }
# filters => filters args for get_filters() (TODO: Document)
my %GET_VN = (
- sql => 'SELECT %s FROM vn v WHERE NOT v.hidden AND (%s) %s',
+ sql => 'SELECT %s FROM vnt v LEFT JOIN images i ON i.id = v.image WHERE NOT v.hidden AND (%s) %s',
select => 'v.id',
proc => sub {
- $_[0]{id} *= 1
+ $_[0]{id} = idnum $_[0]{id};
},
sortdef => 'id',
sorts => {
id => 'v.id %s',
- title => 'v.title %s',
- released => 'v.c_released %s',
- popularity => 'v.c_popularity %s NULLS LAST',
- rating => 'v.c_rating %s NULLS LAST',
- votecount => 'v.c_votecount %s',
+ title => 'v.sorttitle %s, v.id',
+ released => 'v.c_released %s, v.id',
+ popularity => '-v.c_pop_rank %s NULLS LAST, v.id',
+ rating => '-v.c_rat_rank %s NULLS LAST, v.id',
+ votecount => 'v.c_votecount %s, v.id',
},
flags => {
basic => {
- select => 'v.title, v.original, v.c_released, v.c_languages, v.c_olang, v.c_platforms',
+ select => 'v.title[2], v.title[4] AS original, v.c_released, v.c_languages, v.olang, v.c_platforms',
proc => sub {
$_[0]{original} ||= undef;
$_[0]{platforms} = splitarray delete $_[0]{c_platforms};
$_[0]{languages} = splitarray delete $_[0]{c_languages};
- $_[0]{orig_lang} = splitarray delete $_[0]{c_olang};
+ $_[0]{orig_lang} = [ delete $_[0]{olang} ];
$_[0]{released} = formatdate delete $_[0]{c_released};
},
},
details => {
- select => 'v.image, v.img_nsfw, v.alias AS aliases, v.length, v.desc AS description, v.l_wp, v.l_encubed, v.l_renai, l_wikidata',
+ select => 'v.image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, i.width AS image_width, i.height AS image_height, v.alias AS aliases,
+ v.length, v.c_length AS length_minutes, v.c_lengthnum AS length_votes, v.description, v.l_wp, v.l_encubed, v.l_renai, l_wikidata',
proc => sub {
$_[0]{aliases} ||= undef;
$_[0]{length} *= 1;
$_[0]{length} ||= undef;
+ $_[0]{length_votes}*= 1;
+ $_[0]{length_minutes}*=1 if defined $_[0]{length_minutes};
$_[0]{description} ||= undef;
- $_[0]{image_nsfw} = delete($_[0]{img_nsfw}) =~ /t/ ? TRUE : FALSE;
$_[0]{links} = {
wikipedia => delete($_[0]{l_wp}) ||undef,
encubed => delete($_[0]{l_encubed})||undef,
renai => delete($_[0]{l_renai}) ||undef,
wikidata => formatwd(delete $_[0]{l_wikidata}),
};
- $_[0]{image} = $_[0]{image} ? sprintf '%s/cv/%02d/%d.jpg', config->{url_static}, $_[0]{image}%100, $_[0]{image} : undef;
+ $_[0]{image} = $_[0]{image} ? imgurl $_[0]{image} : undef;
+ $_[0]{image_nsfw} = !$_[0]{image} ? FALSE : !$_[0]{c_votecount} || $_[0]{c_sexual_avg} > 40 || $_[0]{c_violence_avg} > 40 ? TRUE : FALSE;
+ $_[0]{image_flagging} = image_flagging $_[0]{image}, $_[0];
+ $_[0]{image_width} *= 1 if defined $_[0]{image_width};
+ $_[0]{image_height} *= 1 if defined $_[0]{image_height};
},
},
stats => {
- select => 'v.c_popularity, v.c_rating, v.c_votecount',
+ select => 'v.c_rating, v.c_votecount as votecount',
proc => sub {
- $_[0]{popularity} = 1 * sprintf '%.2f', 100*(delete $_[0]{c_popularity} or 0);
- $_[0]{rating} = 1 * sprintf '%.2f', 0.1*(delete $_[0]{c_rating} or 0);
- $_[0]{votecount} = 1 * delete $_[0]{c_votecount};
+ $_[0]{popularity} = 1 * sprintf '%.2f', min(100, ($_[0]{votecount} or 0)/150);
+ $_[0]{rating} = 1 * sprintf '%.2f', (delete $_[0]{c_rating} or 0)/100;
+ $_[0]{votecount} *= 1;
},
},
+ titles => {
+ fetch => [[ 'id', 'SELECT id, lang, title, latin, official FROM vn_titles WHERE id IN(%s)',
+ sub { my($r, $n) = @_;
+ for my $i (@$r) {
+ $i->{titles} = [ grep $i->{id} eq $_->{id}, @$n ];
+ }
+ for (@$n) {
+ delete $_->{id};
+ $_->{official} = $_->{official} =~ /t/ ? TRUE : FALSE,
+ }
+ }
+ ]],
+ },
anime => {
fetch => [[ 'id', 'SELECT va.id AS vid, a.id, a.year, a.ann_id, a.nfo_id, a.type, a.title_romaji, a.title_kanji
FROM anime a JOIN vn_anime va ON va.aid = a.id WHERE va.id IN(%s)',
sub { my($r, $n) = @_;
# link
for my $i (@$r) {
- $i->{anime} = [ grep $i->{id} == $_->{vid}, @$n ];
+ $i->{anime} = [ grep $i->{id} eq $_->{vid}, @$n ];
}
# cleanup
for (@$n) {
@@ -460,14 +537,14 @@ my %GET_VN = (
]],
},
relations => {
- fetch => [[ 'id', 'SELECT vr.id AS vid, v.id, vr.relation, v.title, v.original, vr.official FROM vn_relations vr
- JOIN vn v ON v.id = vr.vid WHERE vr.id IN(%s)',
+ fetch => [[ 'id', 'SELECT vr.id AS vid, v.id, vr.relation, v.title[2], v.title[4] AS original, vr.official FROM vn_relations vr
+ JOIN vnt v ON v.id = vr.vid WHERE vr.id IN(%s)',
sub { my($r, $n) = @_;
for my $i (@$r) {
- $i->{relations} = [ grep $i->{id} == $_->{vid}, @$n ];
+ $i->{relations} = [ grep $i->{id} eq $_->{vid}, @$n ];
}
for (@$n) {
- $_->{id} *= 1;
+ $_->{id} = idnum $_->{id};
$_->{original} ||= undef;
$_->{official} = $_->{official} =~ /t/ ? TRUE : FALSE,
delete $_->{vid};
@@ -483,42 +560,45 @@ my %GET_VN = (
sub { my($r, $n) = @_;
for my $i (@$r) {
$i->{tags} = [ map
- [ $_->{id}*1, 1*sprintf('%.2f', $_->{score}), 1*sprintf('%.0f', $_->{spoiler}) ],
- grep $i->{id} == $_->{vid}, @$n ];
+ [ idnum($_->{id}), 1*sprintf('%.2f', $_->{score}), 1*sprintf('%.0f', $_->{spoiler}) ],
+ grep $i->{id} eq $_->{vid}, @$n ];
}
},
]],
},
screens => {
- fetch => [[ 'id', 'SELECT vs.id AS vid, vs.scr AS image, vs.rid, vs.nsfw, s.width, s.height
- FROM vn_screenshots vs JOIN screenshots s ON s.id = vs.scr WHERE vs.id IN(%s)',
+ fetch => [[ 'id', 'SELECT vs.id AS vid, vs.scr, vs.rid, s.width, s.height, s.c_sexual_avg, s.c_violence_avg, s.c_votecount
+ FROM vn_screenshots vs JOIN images s ON s.id = vs.scr WHERE vs.id IN(%s)',
sub { my($r, $n) = @_;
for my $i (@$r) {
- $i->{screens} = [ grep $i->{id} == $_->{vid}, @$n ];
+ $i->{screens} = [ grep $i->{id} eq $_->{vid}, @$n ];
}
for (@$n) {
- $_->{image} = sprintf '%s/sf/%02d/%d.jpg', config->{url_static}, $_->{image}%100, $_->{image};
- $_->{rid} *= 1;
- $_->{nsfw} = $_->{nsfw} =~ /t/ ? TRUE : FALSE;
+ $_->{id} = $_->{scr};
+ $_->{thumbnail} = imgurl($_->{scr}, 't');
+ $_->{image} = imgurl delete $_->{scr};
+ $_->{rid} = idnum $_->{rid};
+ $_->{nsfw} = !$_->{c_votecount} || $_->{c_sexual_avg} > 40 || $_->{c_violence_avg} > 40 ? TRUE : FALSE;
$_->{width} *= 1;
$_->{height} *= 1;
+ ($_->{thumbnail_width}, $_->{thumbnail_height}) = imgsize $_->{width}, $_->{height}, config->{scr_size}->@*;
+ $_->{flagging} = image_flagging(1, $_);
delete $_->{vid};
}
},
]]
},
staff => {
- fetch => [[ 'id', 'SELECT vs.id, vs.aid, vs.role, vs.note, sa.id AS sid, sa.name, sa.original
- FROM vn_staff vs JOIN staff_alias sa ON sa.aid = vs.aid JOIN staff s ON s.id = sa.id
- WHERE vs.id IN(%s) AND NOT s.hidden',
+ fetch => [[ 'id', 'SELECT vs.id, vs.aid, vs.role, vs.note, s.id AS sid, s.title[2] AS name, s.title[4] AS original
+ FROM vn_staff vs JOIN staff_aliast s ON s.aid = vs.aid WHERE vs.id IN(%s) AND NOT s.hidden',
sub { my($r, $n) = @_;
for my $i (@$r) {
- $i->{staff} = [ grep $i->{id} == $_->{id}, @$n ];
+ $i->{staff} = [ grep $i->{id} eq $_->{id}, @$n ];
}
for (@$n) {
$_->{aid} *= 1;
- $_->{sid} *= 1;
- $_->{original} ||= undef;
+ $_->{sid} = idnum $_->{sid};
+ $_->{original} = undef if $_->{original} eq $_->{name};
$_->{note} ||= undef;
delete $_->{id};
}
@@ -528,21 +608,21 @@ my %GET_VN = (
},
filters => {
id => [
- [ 'int' => 'v.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ],
- [ inta => 'v.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, range => [1,1e6], join => ',' ],
+ [ 'int' => 'v.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'v' ],
+ [ inta => 'v.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, process => \'v', join => ',' ],
],
title => [
- [ str => 'v.title :op: :value:', {qw|= = != <>|} ],
- [ str => 'v.title ILIKE :value:', {'~',1}, process => \'like' ],
+ [ str => 'v.sorttitle :op: :value:', {qw|= = != <>|} ],
+ [ str => 'v.sorttitle ILIKE :value:', {'~',1}, process => \'like' ],
],
original => [
- [ undef, "v.original :op: ''", {qw|= = != <>|} ],
- [ str => 'v.original :op: :value:', {qw|= = != <>|} ],
- [ str => 'v.original ILIKE :value:', {'~',1}, process => \'like' ]
+ [ undef, "v.title[4] :op: ''", {qw|= = != <>|} ],
+ [ str => 'v.title[4] :op: :value:', {qw|= = != <>|} ],
+ [ str => 'v.title[4] ILIKE :value:', {'~',1}, process => \'like' ]
],
firstchar => [
- [ undef, '(:op: ((ASCII(v.title) < 97 OR ASCII(v.title) > 122) AND (ASCII(v.title) < 65 OR ASCII(v.title) > 90)))', {'=', '', '!=', 'NOT'} ],
- [ str => 'LOWER(SUBSTR(v.title, 1, 1)) :op: :value:' => {qw|= = != <>|}, process => sub { shift =~ /^([a-z])$/ ? $1 : \'Invalid character' } ],
+ [ undef, ':op: match_firstchar(v.sorttitle, \'0\')', {'=', '', '!=', 'NOT'} ],
+ [ str => ':op: match_firstchar(v.sorttitle, :value:)', {'=', '', '!=', 'NOT'}, process => sub { shift =~ /^([a-z])$/ ? $1 : \'Invalid character' } ],
],
released => [
[ undef, 'v.c_released :op: 0', {qw|= = != <>|} ],
@@ -559,59 +639,64 @@ my %GET_VN = (
[ stra => ':op: (v.c_languages && ARRAY[:value:]::language[])', {'=' => '', '!=' => 'NOT'}, join => ',', process => \'lang' ],
],
orig_lang => [
- [ str => ':op: (v.c_olang && ARRAY[:value:]::language[])', {'=' => '', '!=' => 'NOT'}, process => \'lang' ],
- [ stra => ':op: (v.c_olang && ARRAY[:value:]::language[])', {'=' => '', '!=' => 'NOT'}, join => ',', process => \'lang' ],
+ [ str => 'v.olang :op: :value:', {qw|= = != <>|}, process => \'lang' ],
+ [ stra => 'v.olang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ],
],
search => [
- [ str => '(:value:)', {'~',1}, split => \&normalize_query,
- join => ' AND ', serialize => 'v.c_search LIKE :value:', process => \'like' ],
+ [ str => 'EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = v.id AND sc.label LIKE ALL (search_query(:value:)))', {'~',1} ],
],
tags => [
- [ int => 'v.id :op:(SELECT vid FROM tags_vn_inherit WHERE tag = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6] ],
- [ inta => 'v.id :op:(SELECT vid FROM tags_vn_inherit WHERE tag IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ],
+ [ int => 'v.id :op:(SELECT vid FROM tags_vn_inherit WHERE tag = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'g' ],
+ [ inta => 'v.id :op:(SELECT vid FROM tags_vn_inherit WHERE tag IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'g' ],
],
},
);
my %GET_RELEASE = (
- sql => 'SELECT %s FROM releases r WHERE NOT hidden AND (%s) %s',
+ sql => 'SELECT %s FROM releasest r WHERE NOT hidden AND (%s) %s',
select => 'r.id',
sortdef => 'id',
sorts => {
id => 'r.id %s',
- title => 'r.title %s',
- released => 'r.released %s',
+ title => 'r.sorttitle %s, r.id',
+ released => 'r.released %s, r.id',
},
proc => sub {
- $_[0]{id} *= 1
+ $_[0]{id} = idnum $_[0]{id};
},
flags => {
basic => {
- select => 'r.title, r.original, r.released, r.type, r.patch, r.freeware, r.doujin',
+ select => 'r.title[2], r.title[4] AS original, r.released, r.patch, r.freeware, r.doujin, r.official',
proc => sub {
$_[0]{original} ||= undef;
$_[0]{released} = formatdate($_[0]{released});
$_[0]{patch} = $_[0]{patch} =~ /^t/ ? TRUE : FALSE;
$_[0]{freeware} = $_[0]{freeware} =~ /^t/ ? TRUE : FALSE;
$_[0]{doujin} = $_[0]{doujin} =~ /^t/ ? TRUE : FALSE;
+ $_[0]{official} = $_[0]{official} =~ /^t/ ? TRUE : FALSE;
},
- fetch => [[ 'id', 'SELECT id, lang FROM releases_lang WHERE id IN(%s)',
+ fetch => [[ 'id', 'SELECT id, lang FROM releases_titles WHERE id IN(%s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{languages} = [ map $i->{id} == $_->{id} ? $_->{lang} : (), @$r ];
+ $i->{languages} = [ map $i->{id} eq $_->{id} ? $_->{lang} : (), @$r ];
}
},
+ ], ['id', 'SELECT id, MAX(rtype) AS type FROM releases_vn WHERE id IN(%s) GROUP BY id',
+ sub { my($n, $r) = @_;
+ my %t = map +($_->{id},$_->{type}), @$r;
+ $_->{type} = $t{$_->{id}} for @$n;
+ },
]],
},
details => {
- select => 'r.website, r.notes, r.minage, r.gtin, r.catalog, r.resolution, r.voiced, r.ani_story, r.ani_ero',
+ select => 'r.website, r.notes, r.minage, r.gtin, r.catalog, r.reso_x, r.reso_y, r.voiced, r.ani_story, r.ani_ero',
proc => sub {
$_[0]{website} ||= undef;
$_[0]{notes} ||= undef;
- $_[0]{minage} = $_[0]{minage} < 0 ? undef : $_[0]{minage}*1;
+ $_[0]{minage} *= 1 if defined $_[0]{minage};
$_[0]{gtin} ||= undef;
$_[0]{catalog} ||= undef;
- $_[0]{resolution} = $_[0]{resolution} eq 'unknown' ? undef : $RESOLUTION{ $_[0]{resolution} }{txt};
+ $_[0]{resolution} = resolution $_[0];
$_[0]{voiced} = $_[0]{voiced} ? $_[0]{voiced}*1 : undef;
$_[0]{animation} = [
$_[0]{ani_story} ? $_[0]{ani_story}*1 : undef,
@@ -619,18 +704,20 @@ my %GET_RELEASE = (
];
delete($_[0]{ani_story});
delete($_[0]{ani_ero});
+ delete($_[0]{reso_x});
+ delete($_[0]{reso_y});
},
fetch => [
[ 'id', 'SELECT id, platform FROM releases_platforms WHERE id IN(%s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{platforms} = [ map $i->{id} == $_->{id} ? $_->{platform} : (), @$r ];
+ $i->{platforms} = [ map $i->{id} eq $_->{id} ? $_->{platform} : (), @$r ];
}
} ],
[ 'id', 'SELECT id, medium, qty FROM releases_media WHERE id IN(%s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{media} = [ grep $i->{id} == $_->{id}, @$r ];
+ $i->{media} = [ grep $i->{id} eq $_->{id}, @$r ];
}
for (@$r) {
delete $_->{id};
@@ -639,15 +726,30 @@ my %GET_RELEASE = (
} ],
]
},
+ lang => {
+ fetch => [[ 'id', 'SELECT rt.id, rt.lang, rt.title, rt.latin, rt.mtl, rt.lang = r.olang AS main
+ FROM releases_titles rt JOIN releases r ON r.id = rt.id WHERE rt.id IN(%s)',
+ sub { my($r, $n) = @_;
+ for my $i (@$r) {
+ $i->{lang} = [ grep $i->{id} eq $_->{id}, @$n ];
+ }
+ for (@$n) {
+ delete $_->{id};
+ $_->{mtl} = $_->{mtl} =~ /t/ ? TRUE : FALSE,
+ $_->{main} = $_->{main} =~ /t/ ? TRUE : FALSE,
+ }
+ }
+ ]],
+ },
vn => {
- fetch => [[ 'id', 'SELECT rv.id AS rid, v.id, v.title, v.original FROM releases_vn rv JOIN vn v ON v.id = rv.vid
+ fetch => [[ 'id', 'SELECT rv.id AS rid, rv.rtype, v.id, v.title[2], v.title[4] AS original FROM releases_vn rv JOIN vnt v ON v.id = rv.vid
WHERE NOT v.hidden AND rv.id IN(%s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{vn} = [ grep $i->{id} == $_->{rid}, @$r ];
+ $i->{vn} = [ grep $i->{id} eq $_->{rid}, @$r ];
}
for (@$r) {
- $_->{id}*=1;
+ $_->{id} = idnum $_->{id};
$_->{original} ||= undef;
delete $_->{rid};
}
@@ -655,43 +757,58 @@ my %GET_RELEASE = (
]],
},
producers => {
- fetch => [[ 'id', 'SELECT rp.id AS rid, rp.developer, rp.publisher, p.id, p.type, p.name, p.original FROM releases_producers rp
- JOIN producers p ON p.id = rp.pid WHERE NOT p.hidden AND rp.id IN(%s)',
+ fetch => [[ 'id', 'SELECT rp.id AS rid, rp.developer, rp.publisher, p.id, p.type, p.title[2] AS name, p.title[4] AS original FROM releases_producers rp
+ JOIN producerst p ON p.id = rp.pid WHERE NOT p.hidden AND rp.id IN(%s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{producers} = [ grep $i->{id} == $_->{rid}, @$r ];
+ $i->{producers} = [ grep $i->{id} eq $_->{rid}, @$r ];
}
for (@$r) {
- $_->{id}*=1;
- $_->{original} ||= undef;
+ $_->{id} = idnum $_->{id};
+ $_->{original} = undef if $_->{original} eq $_->{name};
$_->{developer} = $_->{developer} =~ /^t/ ? TRUE : FALSE;
$_->{publisher} = $_->{publisher} =~ /^t/ ? TRUE : FALSE;
delete $_->{rid};
}
}
]],
- }
+ },
+ links => {
+ select => sql_extlinks('r'),
+ proc => sub {
+ my($e) = @_;
+ $e->{links} = [];
+ for my $l (keys $VNDB::ExtLinks::LINKS{r}->%*) {
+ my $i = $VNDB::ExtLinks::LINKS{r}{$l};
+ my $v = $e->{$l};
+ push $e->{links}->@*,
+ map +{ label => $i->{label}, url => sprintf($i->{fmt}, $_) },
+ !$v || $v eq '{}' ? () : $v =~ /^{(.+)}$/ ? split /,/, $1 : ($v);
+ delete $e->{$l};
+ }
+ },
+ },
},
filters => {
id => [
- [ 'int' => 'r.id :op: :value:', {qw|= = != <> > > >= >= < < <= <=|}, range => [1,1e6] ],
- [ inta => 'r.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ],
+ [ 'int' => 'r.id :op: :value:', {qw|= = != <> > > >= >= < < <= <=|}, process => \'r' ],
+ [ inta => 'r.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'r' ],
],
vn => [
- [ 'int' => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.vid = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6] ],
- [ inta => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.vid IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ],
+ [ 'int' => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.vid = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'v' ],
+ [ inta => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.vid IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'v' ],
],
producer => [
- [ 'int' => 'r.id IN(SELECT rp.id FROM releases_producers rp WHERE rp.pid = :value:)', {'=',1}, range => [1,1e6] ],
+ [ 'int' => 'r.id IN(SELECT rp.id FROM releases_producers rp WHERE rp.pid = :value:)', {'=',1}, process => \'p' ],
],
title => [
- [ str => 'r.title :op: :value:', {qw|= = != <>|} ],
- [ str => 'r.title ILIKE :value:', {'~',1}, process => \'like' ],
+ [ str => 'r.sorttitle :op: :value:', {qw|= = != <>|} ],
+ [ str => 'r.sorttitle ILIKE :value:', {'~',1}, process => \'like' ],
],
original => [
- [ undef, "r.original :op: ''", {qw|= = != <>|} ],
- [ str => 'r.original :op: :value:', {qw|= = != <>|} ],
- [ str => 'r.original ILIKE :value:', {'~',1}, process => \'like' ]
+ [ undef, "r.title[4] :op: ''", {qw|= = != <>|} ],
+ [ str => 'r.title[4] :op: :value:', {qw|= = != <>|} ],
+ [ str => 'r.title[4] ILIKE :value:', {'~',1}, process => \'like' ]
],
released => [
[ undef, 'r.released :op: 0', {qw|= = != <>|} ],
@@ -701,7 +818,7 @@ my %GET_RELEASE = (
freeware => [ [ bool => 'r.freeware = :value:', {'=',1} ] ],
doujin => [ [ bool => 'r.doujin = :value:', {'=',1} ] ],
type => [
- [ str => 'r.type :op: :value:', {qw|= = != <>|},
+ [ str => 'r.id :op:(SELECT rv.id FROM releases_vn rv WHERE rv.rtype = :value:)', {'=' => 'IN', '!=' => 'NOT IN'},
process => sub { !$RELEASE_TYPE{$_[0]} ? \'No such release type' : $_[0] } ],
],
gtin => [
@@ -711,8 +828,8 @@ my %GET_RELEASE = (
[ str => 'r.catalog :op: :value:', {qw|= = != <>|} ],
],
languages => [
- [ str => 'r.id :op:(SELECT rl.id FROM releases_lang rl WHERE rl.lang = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'lang' ],
- [ stra => 'r.id :op:(SELECT rl.id FROM releases_lang rl WHERE rl.lang IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ],
+ [ str => 'r.id :op:(SELECT rl.id FROM releases_titles rl WHERE rl.lang = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'lang' ],
+ [ stra => 'r.id :op:(SELECT rl.id FROM releases_titles rl WHERE rl.lang IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ],
],
platforms => [
[ str => 'r.id :op:(SELECT rp.id FROM releases_platforms rp WHERE rp.platform = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'plat' ],
@@ -722,25 +839,25 @@ my %GET_RELEASE = (
);
my %GET_PRODUCER = (
- sql => 'SELECT %s FROM producers p WHERE NOT p.hidden AND (%s) %s',
+ sql => 'SELECT %s FROM producerst p WHERE NOT p.hidden AND (%s) %s',
select => 'p.id',
proc => sub {
- $_[0]{id} *= 1
+ $_[0]{id} = idnum $_[0]{id}
},
sortdef => 'id',
sorts => {
id => 'p.id %s',
- name => 'p.name %s',
+ name => 'p.name %s, p.id',
},
flags => {
basic => {
- select => 'p.type, p.name, p.original, p.lang AS language',
+ select => 'p.type, p.title[2] AS name, p.title[4] AS original, p.lang AS language',
proc => sub {
- $_[0]{original} ||= undef;
+ $_[0]{original} = undef if $_[0]{name} eq $_[0]{original};
},
},
details => {
- select => 'p.website, p.l_wp, p.l_wikidata, p.desc AS description, p.alias AS aliases',
+ select => 'p.website, p.l_wp, p.l_wikidata, p.description, p.alias AS aliases',
proc => sub {
$_[0]{description} ||= undef;
$_[0]{aliases} ||= undef;
@@ -752,15 +869,15 @@ my %GET_PRODUCER = (
},
},
relations => {
- fetch => [[ 'id', 'SELECT pl.id AS pid, p.id, pl.relation, p.name, p.original FROM producers_relations pl
- JOIN producers p ON p.id = pl.pid WHERE pl.id IN(%s)',
+ fetch => [[ 'id', 'SELECT pl.id AS pid, p.id, pl.relation, p.title[2] AS name, p.title[4] AS original FROM producers_relations pl
+ JOIN producerst p ON p.id = pl.pid WHERE pl.id IN(%s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{relations} = [ grep $i->{id} == $_->{pid}, @$r ];
+ $i->{relations} = [ grep $i->{id} eq $_->{pid}, @$r ];
}
for (@$r) {
- $_->{id}*=1;
- $_->{original} ||= undef;
+ $_->{id} = idnum $_->{id};
+ $_->{original} = undef if $_->{name} eq $_->{original};
delete $_->{pid};
}
},
@@ -769,17 +886,17 @@ my %GET_PRODUCER = (
},
filters => {
id => [
- [ 'int' => 'p.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ],
- [ inta => 'p.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ],
+ [ 'int' => 'p.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'p' ],
+ [ inta => 'p.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'p' ],
],
name => [
- [ str => 'p.name :op: :value:', {qw|= = != <>|} ],
- [ str => 'p.name ILIKE :value:', {'~',1}, process => \'like' ],
+ [ str => 'p.title[2] :op: :value:', {qw|= = != <>|} ],
+ [ str => 'p.title[2] ILIKE :value:', {'~',1}, process => \'like' ],
],
original => [
- [ undef, "p.original :op: ''", {qw|= = != <>|} ],
- [ str => 'p.original :op: :value:', {qw|= = != <>|} ],
- [ str => 'p.original ILIKE :value:', {'~',1}, process => \'like' ]
+ [ undef, "p.title[4] :op: ''", {qw|= = != <>|} ],
+ [ str => 'p.title[4] :op: :value:', {qw|= = != <>|} ],
+ [ str => 'p.title[4] ILIKE :value:', {'~',1}, process => \'like' ]
],
type => [
[ str => 'p.type :op: :value:', {qw|= = != <>|},
@@ -790,51 +907,56 @@ my %GET_PRODUCER = (
[ stra => 'p.lang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ],
],
search => [
- [ str => '(p.name ILIKE :value: OR p.original ILIKE :value: OR p.alias ILIKE :value:)', {'~',1}, process => \'like' ],
+ [ str => 'EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = p.id AND sc.label LIKE ALL (search_query(:value:)))', {'~',1} ],
],
},
);
my %GET_CHARACTER = (
- sql => 'SELECT %s FROM chars c WHERE NOT c.hidden AND (%s) %s',
+ sql => 'SELECT %s FROM charst c LEFT JOIN images i ON i.id = c.image WHERE NOT c.hidden AND (%s) %s',
select => 'c.id',
proc => sub {
- $_[0]{id} *= 1
+ $_[0]{id} = idnum $_[0]{id};
},
sortdef => 'id',
sorts => {
id => 'c.id %s',
- name => 'c.name %s',
+ name => 'c.name %s, c.id',
},
flags => {
basic => {
- select => 'c.name, c.original, c.gender, c.bloodt, c.b_day, c.b_month',
+ select => 'c.title[2] AS name, c.title[4] AS original, c.gender, c.spoil_gender, c.bloodt, c.b_day, c.b_month',
proc => sub {
- $_[0]{original} ||= undef;
+ $_[0]{original} = undef if $_[0]{original} eq $_[0]{name};
$_[0]{gender} = undef if $_[0]{gender} eq 'unknown';
$_[0]{bloodt} = undef if $_[0]{bloodt} eq 'unknown';
$_[0]{birthday} = [ delete($_[0]{b_day})*1||undef, delete($_[0]{b_month})*1||undef ];
},
},
details => {
- select => 'c.alias AS aliases, c.image, c."desc" AS description',
+ select => 'c.alias AS aliases, c.image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, i.width AS image_width, i.height AS image_height, c.description, c.age',
proc => sub {
$_[0]{aliases} ||= undef;
- $_[0]{image} = $_[0]{image} ? sprintf '%s/ch/%02d/%d.jpg', config->{url_static}, $_[0]{image}%100, $_[0]{image} : undef;
$_[0]{description} ||= undef;
+ $_[0]{image} = $_[0]{image} ? imgurl $_[0]{image} : undef;
+ $_[0]{image_flagging} = image_flagging $_[0]{image}, $_[0];
+ $_[0]{image_width} *=1 if defined $_[0]{image_width};
+ $_[0]{image_height} *=1 if defined $_[0]{image_height};
+ $_[0]{age}*=1 if defined $_[0]{age};
},
},
meas => {
- select => 'c.s_bust AS bust, c.s_waist AS waist, c.s_hip AS hip, c.height, c.weight',
+ select => 'c.s_bust AS bust, c.s_waist AS waist, c.s_hip AS hip, c.height, c.weight, c.cup_size',
proc => sub {
$_[0]{$_} = $_[0]{$_} ? $_[0]{$_}*1 : undef for(qw|bust waist hip height weight|);
+ $_[0]{cup_size} ||= undef;
},
},
traits => {
fetch => [[ 'id', 'SELECT id, tid, spoil FROM chars_traits WHERE id IN(%s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{traits} = [ map [ $_->{tid}*1, $_->{spoil}*1 ], grep $i->{id} == $_->{id}, @$r ];
+ $i->{traits} = [ map [ idnum($_->{tid}), $_->{spoil}*1 ], grep $i->{id} eq $_->{id}, @$r ];
}
},
]],
@@ -843,7 +965,7 @@ my %GET_CHARACTER = (
fetch => [[ 'id', 'SELECT id, vid, rid, spoil, role FROM chars_vns WHERE id IN(%s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{vns} = [ map [ $_->{vid}*1, ($_->{rid}||0)*1, $_->{spoil}*1, $_->{role} ], grep $i->{id} == $_->{id}, @$r ];
+ $i->{vns} = [ map [ idnum($_->{vid}), idnum($_->{rid}||0), $_->{spoil}*1, $_->{role} ], grep $i->{id} eq $_->{id}, @$r ];
}
},
]],
@@ -854,12 +976,12 @@ my %GET_CHARACTER = (
WHERE vs.cid IN(%s) AND NOT v.hidden AND NOT s.hidden',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{voiced} = [ grep $i->{id} == $_->{cid}, @$r ];
+ $i->{voiced} = [ grep $i->{id} eq $_->{cid}, @$r ];
}
for (@$r) {
- $_->{id}*=1;
+ $_->{id} = idnum $_->{id};
$_->{aid}*=1;
- $_->{vid}*=1;
+ $_->{vid} = idnum $_->{vid};
$_->{note} ||= undef;
delete $_->{cid};
}
@@ -867,15 +989,15 @@ my %GET_CHARACTER = (
]]
},
instances => {
- fetch => [[ 'id', 'SELECT c2.id AS cid, c.id, c.name, c.original, c2.main_spoil AS spoiler FROM chars c2 JOIN chars c ON c.id = c2.main OR c.main = c2.main WHERE c2.id IN(%s)
- UNION SELECT c.main AS cid, c.id, c.name, c.original, c.main_spoil AS spoiler FROM chars c WHERE c.main IN(%1$s)',
+ fetch => [[ 'id', 'SELECT c2.id AS cid, c.id, c.title[2] AS name, c.title[4] AS original, c2.main_spoil AS spoiler FROM chars c2 JOIN charst c ON c.id = c2.main OR c.main = c2.main WHERE c2.id IN(%s)
+ UNION SELECT c.main AS cid, c.id, c.title[2] AS name, c.title[4] AS original, c.main_spoil AS spoiler FROM charst c WHERE c.main IN(%1$s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{instances} = [ grep $i->{id} == $_->{cid} && $_->{id} != $i->{id}, @$r ];
+ $i->{instances} = [ grep $i->{id} eq $_->{cid} && $_->{id} ne $i->{id}, @$r ];
}
for (@$r) {
- $_->{id}*=1;
- $_->{original} ||= undef;
+ $_->{id} = idnum $_->{id};
+ $_->{original} = undef if $_->{original} eq $_->{name};
$_->{spoiler}*=1;
delete $_->{cid};
}
@@ -885,38 +1007,38 @@ my %GET_CHARACTER = (
},
filters => {
id => [
- [ 'int' => 'c.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ],
- [ inta => 'c.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6], join => ',' ],
+ [ 'int' => 'c.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'c' ],
+ [ inta => 'c.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'c', join => ',' ],
],
name => [
- [ str => 'c.name :op: :value:', {qw|= = != <>|} ],
- [ str => 'c.name ILIKE :value:', {'~',1}, process => \'like' ],
+ [ str => 'c.title[2] :op: :value:', {qw|= = != <>|} ],
+ [ str => 'c.title[2] ILIKE :value:', {'~',1}, process => \'like' ],
],
original => [
- [ undef, "c.original :op: ''", {qw|= = != <>|} ],
- [ str => 'c.original :op: :value:', {qw|= = != <>|} ],
- [ str => 'c.original ILIKE :value:', {'~',1}, process => \'like' ]
+ [ undef, "c.title[4] :op: ''", {qw|= = != <>|} ],
+ [ str => 'c.title[4] :op: :value:', {qw|= = != <>|} ],
+ [ str => 'c.title[4] ILIKE :value:', {'~',1}, process => \'like' ]
],
search => [
- [ str => '(c.name ILIKE :value: OR c.original ILIKE :value: OR c.alias ILIKE :value:)', {'~',1}, process => \'like' ],
+ [ str => 'EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = c.id AND sc.label LIKE ALL (search_query(:value:)))', {'~',1} ],
],
vn => [
- [ 'int' => 'c.id IN(SELECT cv.id FROM chars_vns cv WHERE cv.vid = :value:)', {'=',1}, range => [1,1e6] ],
- [ inta => 'c.id IN(SELECT cv.id FROM chars_vns cv WHERE cv.vid IN(:value:))', {'=',1}, range => [1,1e6], join => ',' ],
+ [ 'int' => 'c.id IN(SELECT cv.id FROM chars_vns cv WHERE cv.vid = :value:)', {'=',1}, process => \'v' ],
+ [ inta => 'c.id IN(SELECT cv.id FROM chars_vns cv WHERE cv.vid IN(:value:))', {'=',1}, process => \'v', join => ',' ],
],
traits => [
- [ int => 'c.id :op:(SELECT tc.cid FROM traits_chars tc WHERE tc.tid = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6] ],
- [ inta => 'c.id :op:(SELECT tc.cid FROM traits_chars tc WHERE tc.tid IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', range => [1,1e6] ],
+ [ int => 'c.id :op:(SELECT tc.cid FROM traits_chars tc WHERE tc.tid = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'i' ],
+ [ inta => 'c.id :op:(SELECT tc.cid FROM traits_chars tc WHERE tc.tid IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'i' ],
],
},
);
my %GET_STAFF = (
- sql => 'SELECT %s FROM staff s JOIN staff_alias sa ON sa.aid = s.aid WHERE NOT s.hidden AND (%s) %s',
+ sql => 'SELECT %s FROM staff_aliast s WHERE s.aid = s.main AND NOT s.hidden AND (%s) %s',
select => 's.id',
proc => sub {
- $_[0]{id} *= 1
+ $_[0]{id} = idnum $_[0]{id};
},
sortdef => 'id',
sorts => {
@@ -924,14 +1046,14 @@ my %GET_STAFF = (
},
flags => {
basic => {
- select => 'sa.name, sa.original, s.gender, s.lang AS language',
+ select => 's.title[2] AS name, s.title[4] AS original, s.gender, s.lang AS language',
proc => sub {
- $_[0]{original} ||= undef;
+ $_[0]{original} = undef if $_[0]{original} eq $_[0]{name};
$_[0]{gender} = undef if $_[0]{gender} eq 'unknown';
},
},
details => {
- select => 's."desc" AS description, s.l_wp, s.l_site, s.l_twitter, s.l_anidb, s.l_wikidata, s.l_pixiv',
+ select => 's.description, s.l_wp, s.l_site, s.l_twitter, s.l_anidb, s.l_wikidata, s.l_pixiv',
proc => sub {
$_[0]{description} ||= undef;
$_[0]{links} = {
@@ -949,10 +1071,10 @@ my %GET_STAFF = (
proc => sub {
$_[0]{main_alias} = delete($_[0]{aid})*1;
},
- fetch => [[ 'id', 'SELECT id, aid, name, original FROM staff_alias WHERE id IN(%s)',
+ fetch => [[ 'id', 'SELECT id, aid, title[2] AS name, title[4] AS original FROM staff_aliast WHERE id IN(%s)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{aliases} = [ map [ $_->{aid}*1, $_->{name}, $_->{original}||undef ], grep $i->{id} == $_->{id}, @$r ];
+ $i->{aliases} = [ map [ $_->{aid}*1, $_->{name}, $_->{original} eq $_->{name} ? undef : $_->{original} ], grep $i->{id} eq $_->{id}, @$r ];
}
},
]],
@@ -963,10 +1085,10 @@ my %GET_STAFF = (
WHERE sa.id IN(%s) AND NOT v.hidden',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{vns} = [ grep $i->{id} == $_->{sid}, @$r ];
+ $i->{vns} = [ grep $i->{id} eq $_->{sid}, @$r ];
}
for (@$r) {
- $_->{id}*=1;
+ $_->{id} = idnum $_->{id};
$_->{aid}*=1;
$_->{note} ||= undef;
delete $_->{sid};
@@ -980,12 +1102,12 @@ my %GET_STAFF = (
WHERE sa.id IN(%s) AND NOT v.hidden',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{voiced} = [ grep $i->{id} == $_->{sid}, @$r ];
+ $i->{voiced} = [ grep $i->{id} eq $_->{sid}, @$r ];
}
for (@$r) {
- $_->{id}*=1;
+ $_->{id} = idnum $_->{id};
$_->{aid}*=1;
- $_->{cid}*=1;
+ $_->{cid} = idnum $_->{cid};
$_->{note} ||= undef;
delete $_->{sid};
}
@@ -995,36 +1117,54 @@ my %GET_STAFF = (
},
filters => {
id => [
- [ 'int' => 's.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ],
- [ inta => 's.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6], join => ',' ],
+ [ 'int' => 's.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'s' ],
+ [ inta => 's.id :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'s' ],
],
aid => [
[ 'int' => 's.id IN(SELECT sa.id FROM staff_alias sa WHERE sa.aid = :value:)', {'=',1}, range => [1,1e6] ],
[ inta => 's.id IN(SELECT sa.id FROM staff_alias sa WHERE sa.aid IN(:value:))', {'=',1}, range => [1,1e6], join => ',' ],
],
search => [
- [ str => 's.id IN(SELECT sa.id FROM staff_alias sa WHERE sa.name ILIKE :value: OR sa.original ILIKE :value:)', {'~',1}, process => \'like' ],
+ [ str => 'EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = s.id AND sc.label LIKE ALL (search_query(:value:)))', {'~',1} ],
],
},
);
+my %GET_QUOTE = (
+ sql => "SELECT %s FROM quotes q JOIN vnt v ON v.id = q.vid WHERE q.rand IS NOT NULL AND NOT v.hidden AND (%s) %s",
+ select => "v.id, v.title[2], q.quote",
+ proc => sub {
+ $_[0]{id} = idnum $_[0]{id};
+ },
+ sortdef => 'random',
+ sorts => { id => 'q.vid %s', random => 'RANDOM() %s' },
+ flags => { basic => {} },
+ filters => {
+ id => [
+ [ 'int' => 'q.vid :op: :value:', {qw|= = != <> > > >= >= < < <= <=|}, process => \'v' ],
+ [ inta => 'q.vid :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'v' ],
+ ]
+ },
+);
+
+
# All user ID filters consider uid=0 to be the logged in user. Needs a special processing function to handle that.
-sub subst_user_id { my($id, $c) = @_; !$id && !$c->{uid} ? \'Not logged in.' : $id || $c->{uid} }
+sub subst_user_id { my($id, $c) = @_; $id && $id =~ /^[1-9][0-9]{0,6}$/ ? "u$id" : ($c->{uid} || \'Not logged in.') }
my %GET_USER = (
sql => "SELECT %s FROM users u WHERE (%s) %s",
select => "id, username",
proc => sub {
- $_[0]{id}*=1;
+ $_[0]{id} = idnum $_[0]{id};
},
sortdef => 'id',
sorts => { id => 'id %s' },
flags => { basic => {} },
filters => {
id => [
- [ 'int' => 'u.id :op: :value:', {qw|= =|}, range => [0,1e6], process => \&subst_user_id ],
- [ inta => 'u.id IN(:value:)', {'=',1}, range => [0,1e6], join => ',', process => \&subst_user_id ],
+ [ 'int' => 'u.id :op: :value:', {qw|= =|}, process => \&subst_user_id ],
+ [ inta => 'u.id IN(:value:)', {'=',1}, join => ',', process => \&subst_user_id ],
],
username => [
[ str => 'u.username :op: :value:', {qw|= = != <>|} ],
@@ -1036,25 +1176,23 @@ my %GET_USER = (
# the uid filter for votelist/vnlist/wishlist
-my $UID_FILTER = [ 'int' => 'uv.uid :op: :value:', {qw|= =|}, range => [0,1e6], process => \&subst_user_id ];
+my $UID_FILTER = [ 'int' => 'uv.uid :op: :value:', {qw|= =|}, process => \&subst_user_id ];
# Similarly, a filter for 'vid'
my $VN_FILTER = [
- [ 'int' => 'uv.vid :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ],
- [ inta => 'uv.vid :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, range => [1,1e6], join => ',' ],
+ [ 'int' => 'uv.vid :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \'v' ],
+ [ inta => 'uv.vid :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'v', join => ',' ],
];
-my $UV_PUBLIC = 'EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private)';
-
my %GET_VOTELIST = (
islist => 1,
- sql => "SELECT %s FROM ulist_vns uv WHERE uv.vote IS NOT NULL AND (%s) AND $UV_PUBLIC %s",
- sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE uv.vote IS NOT NULL AND (%2\$s) AND (uid = %4\$d OR $UV_PUBLIC) %3\$s",
- select => "uid, vid as vn, vote, extract('epoch' from vote_date) AS added",
+ sql => "SELECT %s FROM ulist_vns uv WHERE vote IS NOT NULL AND (%s ) AND NOT c_private %s",
+ sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE vote IS NOT NULL AND (%2\$s) AND (uid = %4\$s OR NOT c_private) %3\$s",
+ select => "uid AS uid, vid as vn, vote, extract('epoch' from vote_date) AS added",
proc => sub {
- $_[0]{uid}*=1;
- $_[0]{vn}*=1;
+ $_[0]{uid} = idnum $_[0]{uid};
+ $_[0]{vn} = idnum $_[0]{vn};
$_[0]{vote}*=1;
$_[0]{added} = int $_[0]{added};
},
@@ -1064,44 +1202,40 @@ my %GET_VOTELIST = (
filters => { uid => [ $UID_FILTER ], vn => $VN_FILTER }
);
-my $SQL_VNLIST = 'FROM ulist_vns uv LEFT JOIN ulist_vns_labels uvl ON uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl IN(1,2,3,4)'
- .' WHERE (EXISTS(SELECT 1 FROM ulist_vns_labels uvl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl IN(1,2,3,4))'
- .' OR NOT EXISTS(SELECT 1 FROM ulist_vns_labels uvl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid))';
+my $SQL_VNLIST = "FROM ulist_vns uv WHERE (labels IN('{}','{7}') OR labels && ARRAY[1,2,3,4]::smallint[])";
my %GET_VNLIST = (
islist => 1,
- sql => "SELECT %s $SQL_VNLIST AND (%s) AND $UV_PUBLIC GROUP BY uv.uid, uv.vid, uv.added, uv.notes %s",
- sqluser => "SELECT %1\$s $SQL_VNLIST AND (%2\$s) AND (uv.uid = %4\$d OR $UV_PUBLIC) GROUP BY uv.uid, uv.vid, uv.added, uv.notes %3\$s",
- select => "uv.uid, uv.vid as vn, MAX(uvl.lbl) AS status, extract('epoch' from uv.added) AS added, uv.notes",
+ sql => "SELECT %s $SQL_VNLIST AND (%s) AND NOT c_private %s",
+ sqluser => "SELECT %1\$s $SQL_VNLIST AND (%2\$s) AND (uid = %4\$s OR NOT c_private) %3\$s",
+ select => "uid AS uid, vid as vn, labels, extract('epoch' from added) AS added, notes",
proc => sub {
- $_[0]{uid}*=1;
- $_[0]{vn}*=1;
- $_[0]{status} = defined $_[0]{status} ? $_[0]{status}*1 : 0;
+ $_[0]{uid} = idnum $_[0]{uid};
+ $_[0]{vn} = idnum $_[0]{vn};
+ my @labels = delete($_[0]{labels}) =~ /^{(.+)}$/ ? split /,/, $1 : ();
+ $_[0]{status} = 1*(max(grep $_ <= 4, @labels) || 0);
$_[0]{added} = int $_[0]{added};
$_[0]{notes} ||= undef;
},
sortdef => 'vn',
- sorts => { vn => 'uv.vid %s' },
+ sorts => { vn => 'vid %s' },
flags => { basic => {} },
filters => { uid => [ $UID_FILTER ], vn => $VN_FILTER }
);
-my $SQL_WISHLIST = "FROM ulist_vns uv JOIN ulist_vns_labels uvl ON uvl.uid = uv.uid AND uvl.vid = uv.vid JOIN ulist_labels ul ON ul.uid = uv.uid AND ul.id = uvl.lbl"
- ." WHERE (uvl.lbl IN(5,6) OR ul.label IN('Wishlist-Low','Wishlist-Medium','Wishlist-High'))";
-
my %GET_WISHLIST = (
islist => 1,
- sql => "SELECT %s $SQL_WISHLIST AND (%s) AND NOT ul.private GROUP BY uv.uid, uv.vid, uv.added %s",
- sqluser => "SELECT %1\$s $SQL_WISHLIST AND (%2\$s) AND (uv.uid = %4\$d OR NOT ul.private) GROUP BY uv.uid, uv.vid, uv.added %3\$s",
- select => "uv.uid, uv.vid AS vn, MAX(ul.label) AS priority, extract('epoch' from uv.added) AS added",
+ sql => "SELECT %s FROM ulist_vns uv WHERE labels && ARRAY[5,6]::smallint[] AND (%s) AND NOT c_private %s",
+ sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE labels && ARRAY[5,6]::smallint[] AND (%2\$s) AND (uid = %4\$s OR NOT c_private) %3\$s",
+ select => "uid AS uid, vid AS vn, CASE WHEN labels && ARRAY[6]::smallint[] THEN 3 ELSE 1 END AS priority, extract('epoch' from added) AS added",
proc => sub {
- $_[0]{uid}*=1;
- $_[0]{vn}*=1;
- $_[0]{priority} = {'Wishlist-High' => 0, 'Wishlist-Medium' => 1, 'Wishlist-Low' => 2, 'Blacklist' => 3}->{$_[0]{priority}}//1;
+ $_[0]{uid} = idnum $_[0]{uid};
+ $_[0]{vn} = idnum $_[0]{vn};
+ $_[0]{priority} *= 1;
$_[0]{added} = int $_[0]{added};
},
sortdef => 'vn',
- sorts => { vn => 'uv.vid %s' },
+ sorts => { vn => 'vid %s' },
flags => { basic => {} },
filters => { uid => [ $UID_FILTER ], vn => $VN_FILTER }
);
@@ -1109,11 +1243,11 @@ my %GET_WISHLIST = (
my %GET_ULIST_LABELS = (
islist => 1,
sql => 'SELECT %s FROM ulist_labels uv WHERE (%s) AND NOT uv.private %s',
- sqluser => 'SELECT %1$s FROM ulist_labels uv WHERE (%2$s) AND (uv.uid = %4$d OR NOT uv.private) %3$s',
- select => 'uid, id, label, private',
+ sqluser => 'SELECT %1$s FROM ulist_labels uv WHERE (%2$s) AND (uv.uid = %4$s OR NOT uv.private) %3$s',
+ select => 'uid AS uid, id, label, private',
proc => sub {
- $_[0]{uid}*=1;
- $_[0]{id}*=1;
+ $_[0]{uid} = idnum $_[0]{uid};
+ $_[0]{id} = idnum $_[0]{id};
$_[0]{private} = $_[0]{private} =~ /^t/ ? TRUE : FALSE;
},
sortdef => 'id',
@@ -1122,15 +1256,14 @@ my %GET_ULIST_LABELS = (
filters => { uid => [ $UID_FILTER ] },
);
-my $ULIST_PUBLIC = 'EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private)';
my %GET_ULIST = (
islist => 1,
- sql => "SELECT %s FROM ulist_vns uv WHERE (%s) AND ($ULIST_PUBLIC) %s",
- sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE (%2\$s) AND (uv.uid = %4\$d OR $ULIST_PUBLIC) %3\$s",
- select => "uid, vid as vn, extract('epoch' from added) AS added, extract('epoch' from lastmod) AS lastmod, extract('epoch' from vote_date) AS voted, vote, started, finished, notes",
+ sql => "SELECT %s FROM ulist_vns uv WHERE (%s ) AND NOT c_private %s",
+ sqluser => "SELECT %1\$s FROM ulist_vns uv WHERE (%2\$s) AND (uid = %4\$s OR NOT uv.c_private) %3\$s",
+ select => "uid AS uid, vid as vn, extract('epoch' from added) AS added, extract('epoch' from lastmod) AS lastmod, extract('epoch' from vote_date) AS voted, vote, started, finished, notes",
proc => sub {
- $_[0]{uid}*=1;
- $_[0]{vn}*=1;
+ $_[0]{uid} = idnum $_[0]{uid};
+ $_[0]{vn} = idnum $_[0]{vn};
$_[0]{added} = int $_[0]{added};
$_[0]{lastmod} = int $_[0]{lastmod};
$_[0]{voted} = int $_[0]{voted} if $_[0]{voted};
@@ -1149,15 +1282,17 @@ my %GET_ULIST = (
flags => {
basic => {},
labels => {
- fetch => [[ ['uid','vn'], 'SELECT uvl.uid, uvl.vid, ul.id, ul.label
- FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl
- WHERE (uvl.uid,uvl.vid) IN(%s) AND (NOT ul.private OR uvl.uid = %s)',
+ fetch => [[ ['uid','vn'], 'SELECT uv.uid, uv.vid, ul.id, ul.label
+ FROM ulist_vns uv
+ JOIN unnest(uv.labels) l(id) ON true
+ JOIN ulist_labels ul ON ul.uid = uv.uid AND ul.id = l.id
+ WHERE (uv.uid,uv.vid) IN(%s) AND (NOT ul.private OR uv.uid = %s OR ul.id = 7)',
sub { my($n, $r) = @_;
for my $i (@$n) {
- $i->{labels} = [ grep $i->{uid} == $_->{uid} && $i->{vn} == $_->{vid}, @$r ];
+ $i->{labels} = [ grep $i->{uid} eq $_->{uid} && $i->{vn} eq $_->{vid}, @$r ];
}
for (@$r) {
- $_->{id}*=1;
+ $_->{id} = idnum $_->{id};
delete $_->{uid};
delete $_->{vid};
}
@@ -1169,8 +1304,7 @@ my %GET_ULIST = (
uid => [ $UID_FILTER ],
vn => $VN_FILTER,
label => [
- [ 'int' => 'EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl
- WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl = :value: AND NOT ul.private)', {'=',1}, range => [1,1e6] ],
+ [ 'int' => '(:value: = 7 OR EXISTS(SELECT 1 FROM ulist_labels ul WHERE ul.uid = uv.uid AND ul.id = :value: AND NOT ul.private)) AND labels && ARRAY[:value:]::smallint[]', {'=',1}, range => [1,32000] ],
],
},
);
@@ -1182,6 +1316,7 @@ my %GET = (
producer => \%GET_PRODUCER,
character => \%GET_CHARACTER,
staff => \%GET_STAFF,
+ quote => \%GET_QUOTE,
user => \%GET_USER,
votelist => \%GET_VOTELIST,
vnlist => \%GET_VNLIST,
@@ -1285,6 +1420,9 @@ sub get_filters {
return cerr $c, filter => 'Invalid language code', %e if !$LANGUAGE{$v};
} elsif(${$o{process}} eq 'plat') {
return cerr $c, filter => 'Invalid platform code', %e if !$PLATFORM{$v};
+ } elsif(length ${$o{process}} == 1) {
+ return cerr $c, filter => 'Invalid identifier', %e if $v !~ /^[1-9][0-9]{0,6}$/;
+ $v = ${$o{process}}.$v;
}
}
@@ -1344,7 +1482,7 @@ sub get_mainsql {
$sql = $type->{sqluser} if $c->{uid} && $type->{sqluser};
no if $] >= 5.022, warnings => 'redundant';
- cpg $c, sprintf($sql, $select, $where, $last, $c->{uid}), \@placeholders, sub {
+ cpg $c, sprintf($sql, $select, $where, $last, $c->{uid} ? "'$c->{uid}'" : 'NULL'), \@placeholders, sub {
my @res = $_[0]->rowsAsHashes;
$get->{more} = pop(@res)&&1 if @res > $get->{opt}{results};
$get->{list} = \@res;
@@ -1369,7 +1507,7 @@ sub get_fetch {
my @ids = map { my $d=$_; ref $field ? @{$d}{@$field} : ($d->{$field}) } @{$get->{list}};
my $ids = join ',', map { ref $field ? '('.join(',', map '$'.$ref++, @$field).')' : '$'.$ref++ } 1..@{$get->{list}};
no warnings 'redundant';
- cpg $c, sprintf($need{$n}[1], $ids, $c->{uid}||'NULL'), \@ids, sub {
+ cpg $c, sprintf($need{$n}[1], $ids, $c->{uid} ? "'$c->{uid}'" : 'NULL'), \@ids, sub {
$get->{fetched}{$n} = [ $need{$n}[2], [$_[0]->rowsAsHashes] ];
delete $need{$n};
get_final($c, $type, $get) if !keys %need;
@@ -1438,14 +1576,16 @@ sub setpg {
sub set_ulist_ret {
my($c, $obj) = @_;
- setpg $obj, 'SELECT update_users_ulist_stats($1)', [ $c->{uid} ]; # XXX: This can be deferred, to speed up batch updates over the same connection
+ cpg $obj->{c}, 'SELECT update_users_ulist_private($1, $2)', [ $c->{uid}, 'v'.$obj->{id} ], sub {
+ setpg $obj, 'SELECT update_users_ulist_stats($1)', [ $c->{uid} ];
+ };
}
sub set_votelist {
my($c, $obj) = @_;
- return cpg $c, 'UPDATE ulist_vns SET vote = NULL, vote_date = NULL WHERE uid = $1 AND vid = $2', [ $c->{uid}, $obj->{id} ], sub {
+ return cpg $c, 'UPDATE ulist_vns SET vote = NULL, vote_date = NULL WHERE uid = $1 AND vid = $2', [ $c->{uid}, 'v'.$obj->{id} ], sub {
set_ulist_ret $c, $obj
} if !$obj->{opt};
@@ -1454,7 +1594,7 @@ sub set_votelist {
return cerr $c, badarg => 'Invalid vote', field => 'vote' if ref($vv) || !defined($vv) || $vv !~ /^\d+$/ || $vv < 10 || $vv > 100;
cpg $c, 'INSERT INTO ulist_vns (uid, vid, vote, vote_date) VALUES ($1, $2, $3, NOW()) ON CONFLICT (uid, vid) DO UPDATE SET vote = $3, vote_date = NOW(), lastmod = NOW()',
- [ $c->{uid}, $obj->{id}, $vv ], sub { set_ulist_ret $c, $obj; }
+ [ $c->{uid}, 'v'.$obj->{id}, $vv ], sub { set_ulist_ret $c, $obj; }
}
@@ -1462,7 +1602,7 @@ sub set_vnlist {
my($c, $obj) = @_;
# Bug: Also removes from wishlist and votelist.
- return cpg $c, 'DELETE FROM ulist_vns WHERE uid = $1 AND vid = $2', [ $c->{uid}, $obj->{id} ], sub {
+ return cpg $c, 'DELETE FROM ulist_vns WHERE uid = $1 AND vid = $2', [ $c->{uid}, 'v'.$obj->{id} ], sub {
set_ulist_ret $c, $obj;
} if !$obj->{opt};
@@ -1474,33 +1614,24 @@ sub set_vnlist {
$vs ||= 0;
$vn ||= '';
- cpg $c, 'INSERT INTO ulist_vns (uid, vid, notes) VALUES ($1, $2, $3) ON CONFLICT (uid, vid) DO UPDATE SET lastmod = NOW()'.($en ? ', notes = $3' : ''),
- [ $c->{uid}, $obj->{id}, $vn ], sub {
- if($es) {
- cpg $c, 'DELETE FROM ulist_vns_labels WHERE uid = $1 AND vid = $2 AND lbl IN(1,2,3,4)', [ $c->{uid}, $obj->{id} ], sub {
- if($vs) {
- cpg $c, 'INSERT INTO ulist_vns_labels (uid, vid, lbl) VALUES($1, $2, $3)', [ $c->{uid}, $obj->{id}, $vs ], sub {
- set_ulist_ret $c, $obj;
- }
- } else {
- set_ulist_ret $c, $obj;
- }
- }
- } else {
- set_ulist_ret $c, $obj;
- }
- }
+ my $l = 'array_remove(array_remove(array_remove(array_remove(ulist_vns.labels, 1), 2), 3), 4)';
+ cpg $c, q{
+ INSERT INTO ulist_vns (uid, vid, notes, labels)
+ VALUES ($1, $2, $3, CASE WHEN $4 = 0 THEN '{}' ELSE ARRAY[$4]::smallint[] END)
+ ON CONFLICT (uid, vid) DO UPDATE SET lastmod = NOW()}
+ .($en ? ', notes = $3' : '')
+ .($es ? ', labels = CASE WHEN $4 = 0 THEN '.$l.' ELSE array_set('.$l.', $4) END' : ''),
+ [ $c->{uid}, 'v'.$obj->{id}, $vn, $vs ], sub { set_ulist_ret $c, $obj; };
}
sub set_wishlist {
my($c, $obj) = @_;
-
- my $sql_label = "(lbl IN(5,6) OR lbl IN(SELECT id FROM ulist_labels WHERE uid = \$1 AND label IN('Wishlist-Low','Wishlist-High','Wishlist-Medium')))";
+ my $l = 'array_remove(array_remove(ulist_vns.labels,5),6)';
# Bug: This will make it appear in the vnlist
- return cpg $c, "DELETE FROM ulist_vns_labels WHERE uid = \$1 AND vid = \$2 AND $sql_label",
- [ $c->{uid}, $obj->{id} ], sub {
+ return cpg $c, "UPDATE ulist_vns SET labels = $l, lastmod = NOW() WHERE uid = \$1 AND vid = \$2",
+ [ $c->{uid}, 'v'.$obj->{id} ], sub {
set_ulist_ret $c, $obj;
} if !$obj->{opt};
@@ -1508,33 +1639,25 @@ sub set_wishlist {
return cerr $c, missing => 'No priority given', field => 'priority' if !$ep;
return cerr $c, badarg => 'Invalid priority', field => 'priority' if ref($vp) || !defined($vp) || $vp !~ /^[0-3]$/;
- # Bug: High/Med/Low statuses are only set if a Wishlist-(High|Medium|Low) label exists; These should probably be created if they don't.
- cpg $c, 'INSERT INTO ulist_vns (uid, vid) VALUES ($1, $2) ON CONFLICT DO NOTHING', [ $c->{uid}, $obj->{id} ], sub {
- cpg $c, "DELETE FROM ulist_vns_labels WHERE uid = \$1 AND vid = \$2 AND $sql_label", [ $c->{uid}, $obj->{id} ], sub {
- cpg $c, 'INSERT INTO ulist_vns_labels (uid, vid, lbl) VALUES($1, $2, $3)', [ $c->{uid}, $obj->{id}, $vp == 3 ? 6 : 5 ], sub {
- if($vp != 3) {
- cpg $c, 'INSERT INTO ulist_vns_labels (uid, vid, lbl) SELECT $1, $2, id FROM ulist_labels WHERE uid = $1 AND label = $3',
- [ $c->{uid}, $obj->{id}, ['Wishlist-High', 'Wishlist-Medium', 'Wishlist-Low']->[$vp] ], sub {
- set_ulist_ret $c, $obj;
- }
- } else {
- set_ulist_ret $c, $obj;
- }
- }
- }
- }
+ my $label = $vp == 3 ? 6 : 5; # Other statuses are not supported anymore.
+ cpg $c,
+ 'INSERT INTO ulist_vns (uid, vid, labels) VALUES ($1, $2, ARRAY[$3]::smallint[])
+ ON CONFLICT (uid,vid) DO UPDATE SET lastmod = NOW(), labels = array_set('.$l.', $3)',
+ [ $c->{uid}, 'v'.$obj->{id}, $label ],
+ sub { set_ulist_ret $c, $obj };
}
+
sub set_ulist {
my($c, $obj) = @_;
- return cpg $c, 'DELETE FROM ulist_vns WHERE uid = $1 AND vid = $2', [ $c->{uid}, $obj->{id} ], sub {
+ return cpg $c, 'DELETE FROM ulist_vns WHERE uid = $1 AND vid = $2', [ $c->{uid}, 'v'.$obj->{id} ], sub {
set_ulist_ret $c, $obj;
} if !$obj->{opt};
my $opt = $obj->{opt};
my @set;
- my @bind = ($c->{uid}, $obj->{id});
+ my @bind = ($c->{uid}, 'v'.$obj->{id});
if(exists $opt->{vote}) {
return cerr $c, badarg => 'Invalid vote', field => 'vote' if defined($opt->{vote}) && (ref $opt->{vote} || $opt->{vote} !~ /^[0-9]+$/ || $opt->{vote} < 10 || $opt->{vote} > 100);
@@ -1564,20 +1687,15 @@ sub set_ulist {
return cerr $c, badarg => "Labels field expects an array", field => 'labels' if ref $opt->{labels} ne 'ARRAY';
return cerr $c, badarg => "Invalid label: '$_'", field => 'labels' for grep !defined($_) || ref($_) || !/^[0-9]+$/, $opt->{labels}->@*;
my %l = map +($_,1), grep $_ != 7, $opt->{labels}->@*;
- # XXX: This is ugly. Errors (especially: unknown labels) are ignored and
- # the entire set operation ought to run in a single transaction.
- pg_cmd 'SELECT lbl FROM ulist_vns_labels WHERE uid = $1 AND vid = $2', [ $c->{uid}, $obj->{id} ], sub {
- return if pg_expect $_[0];
- my %ids = map +($_->{lbl}, 1), $_[0]->rowsAsHashes;
- pg_cmd 'INSERT INTO ulist_vns_labels (uid, vid, lbl) VALUES ($1,$2,$3)', [ $c->{uid}, $obj->{id}, $_ ] for grep !$ids{$_}, keys %l;
- pg_cmd 'DELETE FROM ulist_vns_labels WHERE uid = $1 AND vid = $2 AND lbl = $3', [ $c->{uid}, $obj->{id}, $_ ] for grep !$l{$_}, keys %ids;
- };
+ # XXX: Labels aren't validated here, so we might actually be writing garbage into the DB. Rest of the code doesn't mind that too much, though.
+ push @bind, '{'.join(',',sort { $a <=> $b } keys %l).'}';
+ push @set, 'labels = $'.@bind;
}
- push @set, 'lastmod = NOW()' if @set || $opt->{labels};
+ push @set, 'lastmod = NOW()' if @set;
return cerr $c, missing => 'No fields to change' if !@set;
- cpg $c, 'INSERT INTO ulist_vns (uid, vid) VALUES ($1, $2) ON CONFLICT (uid, vid) DO NOTHING', [ $c->{uid}, $obj->{id} ], sub {
+ cpg $c, 'INSERT INTO ulist_vns (uid, vid) VALUES ($1, $2) ON CONFLICT (uid, vid) DO NOTHING', [ $c->{uid}, 'v'.$obj->{id} ], sub {
cpg $c, 'UPDATE ulist_vns SET '.join(',', @set).' WHERE uid = $1 AND vid = $2', \@bind, sub {
set_ulist_ret $c, $obj;
}
diff --git a/lib/Multi/Anime.pm b/lib/Multi/Anime.pm
index d286a657..b9db5003 100644
--- a/lib/Multi/Anime.pm
+++ b/lib/Multi/Anime.pm
@@ -10,8 +10,10 @@ use warnings;
use Multi::Core;
use AnyEvent::Socket;
use AnyEvent::Util;
+use AnyEvent::HTTP;
use Encode 'decode_utf8', 'encode_utf8';
use VNDB::Types;
+use VNDB::Config;
sub LOGIN_ACCEPTED () { 200 }
@@ -33,6 +35,7 @@ my @handled_codes = (
my %O = (
+ titlesurl => 'https://anidb.net/api/anime-titles.dat.gz',
apihost => 'api.anidb.net',
apiport => 9000,
# AniDB UDP API options
@@ -45,6 +48,7 @@ my %O = (
maxtimeoutdelay => 2*3600,
check_delay => 3600,
resolve_delay => 3*3600,
+ titles_delay => 48*3600,
cachetime => '3 months',
);
@@ -63,9 +67,11 @@ my %C = (
sub run {
shift;
+ $O{ua} = sprintf 'VNDB.org Anime Fetcher (Multi v%s; contact@vndb.org)', config->{version};
%O = (%O, @_);
die "No AniDB user/pass configured!" if !$O{user} || !$O{pass};
+ push_watcher schedule 0, $O{titles_delay}, \&titles_import;
push_watcher schedule 0, $O{resolve_delay}, \&resolve;
resolve();
}
@@ -76,8 +82,76 @@ sub unload {
}
+
+# BUGs, kind of:
+# - If the 'ja' title is not present in the titles dump, the title_kanji column will not be set to NULL.
+# - This doesn't attempt to delete rows from the anime table that aren't present in the titles dump.
+# Both can be 'solved' by periodically pruning unreferenced rows from the anime
+# table and setting all title_kanji columns to NULL.
+
+my %T;
+
+sub titles_import {
+ %T = (
+ titles => 0,
+ updates => 0,
+ start_dl => AE::now(),
+ );
+ http_get $O{titlesurl}, headers => {'User-Agent' => $O{ua} }, timeout => 60, sub {
+ my($body, $hdr) = @_;
+ return AE::log warn => "Error fetching titles dump: $hdr->{Status} $hdr->{Reason}" if $hdr->{Status} !~ /^2/;
+
+ $T{start_insert} = AE::now();
+ if(!open $T{fh}, '<:gzip:utf8', \$body) {
+ AE::log warn => "Error parsing titles dump: $!";
+ return;
+ }
+ titles_insert();
+ };
+}
+
+sub titles_next {
+ my $F = $T{fh};
+ while(local $_ = <$F>) {
+ chomp;
+ next if /^#/;
+ my($id,$type,$lang,$title) = split /\|/, $_, 4;
+ return (0, $id, $title) if $type eq '1';
+ return (1, $id, $title) if $type eq '4' && $lang eq 'ja';
+ }
+ ()
+}
+
+sub titles_insert {
+ my($orig, $id, $title) = titles_next();
+
+ if(!defined $orig) {
+ AE::log info => sprintf 'AniDB title import: %d titles, %d updates in %.1fs (fetch) + %.1fs (insert)',
+ $T{titles}, $T{updates}, $T{start_insert}-$T{start_dl}, AE::now()-$T{start_insert};
+ %T = ();
+ return;
+ }
+
+ my $col = $orig ? 'title_kanji' : 'title_romaji';
+ pg_cmd "INSERT INTO anime (id, $col) VALUES (\$1, \$2) ON CONFLICT (id) DO UPDATE SET $col = excluded.$col WHERE anime.$col IS DISTINCT FROM excluded.$col", [ $id, $title ], sub {
+ my($res) = @_;
+ return if pg_expect $res, 0;
+ $T{titles}++;
+ $T{updates} += $res->cmdRows;
+ titles_insert();
+ }
+}
+
+
+
+
+
sub resolve {
AnyEvent::Socket::resolve_sockaddr $O{apihost}, $O{apiport}, 'udp', 0, undef, sub {
+ if(!@_) {
+ AE::log warn => "Unable to resolve '$O{apihost}'";
+ return; # Re-use old socket address or try again after resolve_delay.
+ }
my($fam, $type, $proto, $saddr) = @{$_[0]};
my $sock;
socket $sock, $fam, $type, $proto or die "Can't create UDP socket: $!";
@@ -100,7 +174,10 @@ sub resolve {
sub check_anime {
return if $C{aid} || $C{tw};
- pg_cmd 'SELECT id FROM anime WHERE lastfetch IS NULL OR lastfetch < NOW() - $1::interval ORDER BY lastfetch DESC NULLS FIRST LIMIT 1', [ $O{cachetime} ], sub {
+ pg_cmd 'SELECT id FROM anime
+ WHERE EXISTS(SELECT 1 FROM vn_anime WHERE aid = anime.id)
+ AND (lastfetch IS NULL OR lastfetch < NOW() - $1::interval)
+ ORDER BY lastfetch DESC NULLS FIRST LIMIT 1', [ $O{cachetime} ], sub {
my $res = shift;
return if pg_expect $res, 1 or $C{aid} or $C{tw} or !$res->rows;
$C{aid} = $res->value(0,0);
@@ -125,7 +202,8 @@ sub nextcmd {
) : ( # logged in, get anime
command => 'ANIME',
aid => $C{aid},
- acode => 3973121, # aid, ANN id, NFO id, year, type, romaji, kanji
+ # aid, year, type, ann, nfo
+ amask => sprintf('%02x%02x%02x%02x%02x%02x%02x', 128+32+16, 0, 0, 0, 64+16, 0, 0),
);
# XXX: We don't have a writability watcher, but since we're only ever sending
@@ -226,27 +304,25 @@ sub handlemsg {
sub update_anime {
my $r = shift;
- # aid, ANN id, NFO id, year, type, romaji, kanji
- my @col = split(/\|/, $r, 7);
+ # aid, year, type, ann, nfo
+ my @col = split(/\|/, $r, 5);
for(@col) {
$_ =~ s/<br \/>/\n/g;
$_ =~ s/`/'/g;
}
- $col[1] = undef if !$col[1];
- $col[2] = undef if !$col[2] || $col[2] =~ /^0,/;
- $col[3] = $col[3] =~ /^([0-9]+)/ ? $1 : undef;
- ($col[4]) = grep lc($col[4]) eq lc($ANIME_TYPE{$_}{anidb}), keys %ANIME_TYPE;
- $col[5] = undef if !$col[5];
- $col[6] = undef if !$col[6];
+ if($col[0] ne $C{aid}) {
+ AE::log warn => sprintf 'Received from aid (%s) for a%d', $col[0], $C{aid};
+ return;
+ }
+ $col[1] = $col[1] =~ /^([0-9]+)/ ? $1 : undef;
+ ($col[2]) = grep lc($col[2]) eq lc($ANIME_TYPE{$_}{anidb}), keys %ANIME_TYPE;
+ $col[3] = undef if !$col[3];
+ $col[4] = undef if !$col[4] || $col[2] =~ /^0,/;
pg_cmd 'UPDATE anime
- SET id = $1, ann_id = $2, nfo_id = $3, year = $4, type = $5,
- title_romaji = $6, title_kanji = $7, lastfetch = NOW()
- WHERE id = $8',
- [ @col, $C{aid} ];
+ SET id = $1, year = $2, type = $3, ann_id = $4, nfo_id = $5, lastfetch = NOW()
+ WHERE id = $1', \@col;
AE::log info => "Fetched anime info for a$C{aid}";
- AE::log warn => "a$C{aid} doesn't have a title or year!"
- if !$col[3] || !$col[5];
}
diff --git a/lib/Multi/Core.pm b/lib/Multi/Core.pm
index f8b277bf..c20c03c9 100644
--- a/lib/Multi/Core.pm
+++ b/lib/Multi/Core.pm
@@ -118,7 +118,7 @@ sub unload {
sub run {
my $p = shift;
- $pidfile = config->{root}."/data/multi.pid";
+ $pidfile = config->{var_path}."/multi.pid";
die "PID file already exists\n" if -e $pidfile;
$stopcv = AE::cv;
@@ -148,7 +148,7 @@ sub run {
# Eg. daily at 12:00 GMT: schedule 24*3600, 12*3600, sub { .. }.
sub schedule {
my($o, $i, $s) = @_;
- AE::timer($i - ((AE::time() + $o) % $i), $i, $s);
+ AE::timer($i - ((AE::time() - $o) % $i), $i, $s);
}
diff --git a/lib/Multi/DLsite.pm b/lib/Multi/DLsite.pm
index 46a0263c..a09f0325 100644
--- a/lib/Multi/DLsite.pm
+++ b/lib/Multi/DLsite.pm
@@ -12,7 +12,7 @@ use VNDB::Config;
my %C = (
url => 'https://www.dlsite.com/%s/work/=/product_id/%s.html',
clean_timeout => 48*3600,
- check_timeout => 5*60,
+ check_timeout => 1*60,
);
@@ -22,10 +22,7 @@ sub run {
%C = (%C, @_);
push_watcher schedule 0, $C{clean_timeout}, sub {
- pg_cmd q{DELETE FROM shop_dlsite WHERE id NOT IN(
- SELECT l_dlsite FROM releases WHERE NOT hidden
- UNION ALL
- SELECT l_dlsiteen FROM releases WHERE NOT hidden)};
+ pg_cmd q{DELETE FROM shop_dlsite WHERE id NOT IN(SELECT l_dlsite FROM releases WHERE NOT hidden)};
};
push_watcher schedule 0, $C{check_timeout}, sub {
pg_cmd q{
@@ -34,15 +31,7 @@ sub run {
FROM releases
WHERE NOT hidden AND l_dlsite <> ''
AND NOT EXISTS(SELECT 1 FROM shop_dlsite WHERE id = l_dlsite)
- }, [], sub {
- pg_cmd q{
- INSERT INTO shop_dlsite (id)
- SELECT DISTINCT l_dlsiteen
- FROM releases
- WHERE NOT hidden AND l_dlsiteen <> ''
- AND NOT EXISTS(SELECT 1 FROM shop_dlsite WHERE id = l_dlsiteen)
- }, [], \&sync
- }
+ }, [], \&sync
}
}
@@ -61,7 +50,6 @@ sub data {
$body =~ m{<i class="work_jpy">([0-9,]+) JPY</i></span>} ? sprintf('JP¥ %d', $1 =~ s/,//gr) : '';
$shop = $body =~ /,"category":"([^"]+)"/ ? $1 : '';
- $shop = 'ecchi-eng' if $shop eq 'ecchieng'; # Both work, but DLsite seems to prefer a dash.
return AE::log warn => "$prefix Product found, but no price ($price) or shop ($shop)" if $found && (!$price || !$shop);
diff --git a/lib/Multi/Denpa.pm b/lib/Multi/Denpa.pm
index bdecd085..99c60231 100644
--- a/lib/Multi/Denpa.pm
+++ b/lib/Multi/Denpa.pm
@@ -4,18 +4,13 @@ use strict;
use warnings;
use Multi::Core;
use AnyEvent::HTTP;
-use JSON::XS 'decode_json';
-use MIME::Base64 'encode_base64';
use VNDB::Config;
-use TUWF::Misc 'uri_escape';
+use VNDB::ExtLinks ();
my %C = (
- api => '',
- user => '',
- pass => '',
clean_timeout => 48*3600,
- check_timeout => 15*60,
+ check_timeout => 10*60,
);
@@ -42,26 +37,25 @@ sub run {
sub data {
my($time, $id, $body, $hdr) = @_;
my $prefix = sprintf '[%.1fs] %s', $time, $id;
- return AE::log warn => "$prefix ERROR: $hdr->{Status} $hdr->{Reason}" if $hdr->{Status} !~ /^2/;
+ return AE::log warn => "$prefix ERROR: $hdr->{Status} $hdr->{Reason}" if $hdr->{Status} !~ /^(2|404)/;
- my $data = eval { decode_json $body };
- if(!$data) {
- AE::log warn => "$prefix Error decoding JSON: $@";
- return;
- }
+ my $listprice = $body =~ m{<meta property="product:price:amount" content="([^"]+)"} && $1;
+ my $currency = $body =~ m{<meta property="product:price:currency" content="([^"]+)"} && $1;
+ my $availability = $body =~ m{<meta property="product:availability" content="([^"]+)"} && $1;
+ my $sku = $body =~ m{<meta property="product:retailer_item_id" content="([^"]+)"} ? $1 : '';
- my($prod) = $data->{products}->@*;
+ # Meta properties aren't set if the product has multiple SKU's (e.g. multi-platform), fall back to some json-ld string.
+ ($listprice, $currency) = ($1,$2) if !$listprice && $body =~ /"priceSpecification":\{"price":"([^"]+)","priceCurrency":"([^"]+)"/;
- if(!$prod || !$prod->{published_at}) {
+ if($hdr->{Status} eq '404' || !$listprice || !$availability || $availability ne 'instock') {
pg_cmd q{UPDATE shop_denpa SET deadsince = COALESCE(deadsince, NOW()), lastfetch = NOW() WHERE id = $1}, [ $id ];
- AE::log info => "$prefix not found.";
+ AE::log info => "$prefix not found or not in stock.";
} else {
- my $price = 'US$ '.$prod->{variants}[0]{price};
- $price = 'free' if $price eq 'US$ 0.00';
+ my $price = $listprice eq '0.00' ? 'free' : ($currency eq 'USD' ? 'US$' : $currency).' '.$listprice;
pg_cmd 'UPDATE shop_denpa SET deadsince = NULL, lastfetch = NOW(), sku = $2, price = $3 WHERE id = $1',
- [ $prod->{handle}, $prod->{variants}[0]{sku}, $price ];
- AE::log debug => "$prefix for $price at $prod->{variants}[0]{sku}";
+ [ $id, $sku, $price ];
+ AE::log debug => "$prefix for $price at $sku";
}
}
@@ -73,9 +67,8 @@ sub sync {
my $id = $res->value(0,0);
my $ts = AE::now;
- my $code = encode_base64("$C{user}:$C{pass}", '');
- http_get $C{api}.'?handle='.uri_escape($id),
- headers => {'User-Agent' => $C{ua}, Authorization => "Basic $code"},
+ http_get sprintf($VNDB::ExtLinks::LINKS{r}{l_denpa}{fmt}, $id),
+ headers => {'User-Agent' => $C{ua}},
timeout => 60,
sub { data(AE::now-$ts, $id, @_) };
};
diff --git a/lib/Multi/Feed.pm b/lib/Multi/Feed.pm
deleted file mode 100644
index 626e837b..00000000
--- a/lib/Multi/Feed.pm
+++ /dev/null
@@ -1,155 +0,0 @@
-
-#
-# Multi::Feed - Generates and updates Atom feeds
-#
-
-package Multi::Feed;
-
-use strict;
-use warnings;
-use TUWF::XML;
-use Multi::Core;
-use POSIX 'strftime';
-use VNDB::BBCode;
-use VNDB::Config;
-
-my %stats; # key = feed, value = [ count, total, max ]
-
-
-sub run {
- my $p = shift;
- my %o = (
- regenerate_interval => 600, # 10 min.
- stats_interval => 86400, # daily
- @_
- );
- push_watcher schedule 0, $o{regenerate_interval}, \&generate;
- push_watcher schedule 0, $o{stats_interval}, \&stats;
-}
-
-
-sub generate {
- # announcements
- pg_cmd q{
- SELECT '/t'||t.id AS id, t.title, extract('epoch' from tp.date) AS published,
- extract('epoch' from tp.edited) AS updated, u.username, u.id AS uid, tp.msg AS summary
- FROM threads t
- JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1
- JOIN threads_boards tb ON tb.tid = t.id AND tb.type = 'an'
- JOIN users u ON u.id = tp.uid
- WHERE NOT t.hidden AND NOT t.private
- ORDER BY t.id DESC
- LIMIT $1},
- [10],
- sub { write_atom(announcements => '/t/an', 'VNDB Site Announcements', @_) };
-
- # changes
- pg_cmd q{
- SELECT '/'||c.type||COALESCE(v.id, r.id, p.id, ca.id, s.id, d.id)||'.'||c.rev AS id,
- COALESCE(v.title, r.title, p.name, ca.name, sa.name, d.title) AS title, extract('epoch' from c.added) AS updated,
- u.username, u.id AS uid, c.comments AS summary
- FROM changes c
- LEFT JOIN vn v ON c.type = 'v' AND c.itemid = v.id
- LEFT JOIN releases r ON c.type = 'r' AND c.itemid = r.id
- LEFT JOIN producers p ON c.type = 'p' AND c.itemid = p.id
- LEFT JOIN chars ca ON c.type = 'c' AND c.itemid = ca.id
- LEFT JOIN docs d ON c.type = 'd' AND c.itemid = d.id
- LEFT JOIN staff s ON c.type = 's' AND c.itemid = s.id
- LEFT JOIN staff_alias sa ON sa.id = s.id AND sa.aid = s.aid
- JOIN users u ON u.id = c.requester
- WHERE c.requester <> 1
- ORDER BY c.id DESC
- LIMIT $1},
- [25],
- sub { write_atom(changes => '/hist', 'VNDB Recent Changes', @_); };
-
- # posts
- pg_cmd q{
- SELECT '/t'||t.id||'.'||tp.num AS id, t.title||' (#'||tp.num||')' AS title, extract('epoch' from tp.date) AS published,
- extract('epoch' from tp.edited) AS updated, u.username, u.id AS uid, tp.msg AS summary
- FROM threads_posts tp
- JOIN threads t ON t.id = tp.tid
- JOIN users u ON u.id = tp.uid
- WHERE NOT tp.hidden AND NOT t.hidden AND NOT t.private
- ORDER BY tp.date DESC
- LIMIT $1},
- [25],
- sub { write_atom(posts => '/t', 'VNDB Recent Posts', @_); };
-}
-
-
-sub write_atom {
- my($feed, $path, $title, $res, $sqltime) = @_;
- return if pg_expect $res, 1;
-
- my $start = AE::time;
-
- my @r = $res->rowsAsHashes;
- my $updated = 0;
- for(@r) {
- $updated = $_->{published} if $_->{published} && $_->{published} > $updated;
- $updated = $_->{updated} if $_->{updated} && $_->{updated} > $updated;
- }
-
- my $data;
- my $x = TUWF::XML->new(write => sub { $data .= shift }, pretty => 2);
- $x->xml();
- $x->tag(feed => xmlns => 'http://www.w3.org/2005/Atom', 'xml:lang' => 'en', 'xml:base' => config->{url}.'/');
- $x->tag(title => $title);
- $x->tag(updated => datetime($updated));
- $x->tag(id => config->{url}.$path);
- $x->tag(link => rel => 'self', type => 'application/atom+xml', href => config->{url}."/feeds/$feed.atom", undef);
- $x->tag(link => rel => 'alternate', type => 'text/html', href => config->{url}.$path, undef);
-
- for(@r) {
- $x->tag('entry');
- $x->tag(id => config->{url}.$_->{id});
- $x->tag(title => $_->{title});
- $x->tag(updated => datetime($_->{updated} || $_->{published}));
- $x->tag(published => datetime($_->{published})) if $_->{published};
- if($_->{username}) {
- $x->tag('author');
- $x->tag(name => $_->{username});
- $x->tag(uri => config->{url}.'/u'.$_->{uid}) if $_->{uid};
- $x->end;
- }
- $x->tag(link => rel => 'alternate', type => 'text/html', href => config->{url}.$_->{id}, undef);
- $x->tag('summary', type => 'html', bb2html $_->{summary}) if $_->{summary};
- $x->end('entry');
- }
-
- $x->end('feed');
-
- open my $f, '>:utf8', config->{root}."/www/feeds/$feed.atom" || die $!;
- print $f $data;
- close $f;
-
- AE::log debug => sprintf 'Wrote %16s.atom (%d entries, sql:%4dms, perl:%4dms)',
- $feed, scalar(@r), $sqltime*1000, (AE::time-$start)*1000;
-
- my $time = ((AE::time-$start)+$sqltime)*1000;
- $stats{$feed} = [ 0, 0, 0 ] if !$stats{$feed};
- $stats{$feed}[0]++;
- $stats{$feed}[1] += $time;
- $stats{$feed}[2] = $time if $stats{$feed}[2] < $time;
-}
-
-
-sub stats {
- for (keys %stats) {
- my $v = $stats{$_};
- next if !$v->[0];
- AE::log info => sprintf 'Stats summary for %16s.atom: total:%5dms, avg:%4dms, max:%4dms, size: %.1fkB',
- $_, $v->[1], $v->[1]/$v->[0], $v->[2], (-s config->{root}."/www/feeds/$_.atom")/1024;
- }
- %stats = ();
-}
-
-
-sub datetime {
- strftime('%Y-%m-%dT%H:%M:%SZ', gmtime shift);
-}
-
-
-1;
-
diff --git a/lib/Multi/IRC.pm b/lib/Multi/IRC.pm
index 503a1543..df055b93 100644
--- a/lib/Multi/IRC.pm
+++ b/lib/Multi/IRC.pm
@@ -10,7 +10,6 @@ use warnings;
use Multi::Core;
use AnyEvent::IRC::Client;
use AnyEvent::IRC::Util 'prefix_nick';
-use VNDBUtil 'normalize_query';
use VNDB::Config;
use TUWF::Misc 'uri_escape';
use POSIX 'strftime';
@@ -19,9 +18,9 @@ use Encode 'decode_utf8', 'encode_utf8';
# long subquery used in several places
my $GETBOARDS = q{array_to_string(array(
- SELECT tb.type||COALESCE(':'||COALESCE(u.username, v.title, p.name), '')
+ SELECT tb.type||COALESCE(':'||COALESCE(u.username, v.title[1+1], p.name), '')
FROM threads_boards tb
- LEFT JOIN vn v ON tb.type = 'v' AND v.id = tb.iid
+ LEFT JOIN vnt v ON tb.type = 'v' AND v.id = tb.iid
LEFT JOIN producers p ON tb.type = 'p' AND p.id = tb.iid
LEFT JOIN users u ON tb.type = 'u' AND u.id = tb.iid
WHERE tb.tid = t.id
@@ -37,7 +36,6 @@ my $LIGHT_GREY = "\x0315";
my $irc;
my $connecttimer;
-my @quotew;
my %lastnotify;
@@ -62,7 +60,6 @@ sub run {
set_cbs();
set_logger();
- set_quotew($_) for (0..$#{$O{channels}});
set_notify();
ircconnect();
@@ -86,7 +83,6 @@ sub run {
sub unload {
- @quotew = ();
# TODO: Wait until we've nicely disconnected?
$irc->disconnect('Closing...');
undef $connecttimer;
@@ -107,24 +103,6 @@ sub reconnect {
}
-sub send_quote {
- my $chan = shift;
- pg_cmd 'SELECT quote FROM quotes ORDER BY random() LIMIT 1', undef, sub {
- return if pg_expect $_[0], 1 or !$_[0]->nRows;
- $irc->send_msg(PRIVMSG => $chan, encode_utf8 $_[0]->value(0,0));
- };
-}
-
-
-sub set_quotew {
- my $idx = shift;
- $quotew[$idx] = AE::timer +(18*3600)+rand()*(72*3600), 0, sub {
- send_quote($O{channels}[$idx]) if $irc->registered;
- set_quotew($idx);
- };
-}
-
-
sub set_cbs {
$irc->reg_cb(connect => sub {
return if !$_[1];
@@ -199,19 +177,17 @@ sub set_logger {
sub set_notify {
pg_cmd q{SELECT
(SELECT id FROM changes ORDER BY id DESC LIMIT 1) AS rev,
- (SELECT id FROM tags ORDER BY id DESC LIMIT 1) AS tag,
- (SELECT id FROM traits ORDER BY id DESC LIMIT 1) AS trait,
- (SELECT date FROM threads_posts ORDER BY date DESC LIMIT 1) AS post
+ (SELECT date FROM threads_posts ORDER BY date DESC LIMIT 1) AS post,
+ (SELECT id FROM reviews ORDER BY id DESC LIMIT 1) AS review
}, undef, sub {
return if pg_expect $_[0], 1;
%lastnotify = %{($_[0]->rowsAsHashes())[0]};
- push_watcher pg->listen($_, on_notify => \&notify) for qw{newrevision newpost newtag newtrait};
+ push_watcher pg->listen($_, on_notify => \&notify) for qw{newrevision newpost newreview};
};
}
# formats and posts database items listed in @res, where each item is a hashref with:
-# type database item in [dvprtug]
# id database id
# title main name or title of the DB entry
# rev (optional) revision, post number
@@ -234,19 +210,23 @@ sub formatid {
i => 'trait',
t => 'thread',
d => 'doc',
+ w => 'review',
);
for (@$res) {
- my $id = $_->{type}.$_->{id} . ($_->{rev} ? '.'.$_->{rev} : '');
+ my $id = $_->{id} . ($_->{rev} ? '.'.$_->{rev} : '');
+ my $type = $types{ substr $id, 0, 1 };
# (always) [x+.+]
my @msg = ("$BOLD$c"."[$NORMAL$BOLD$id$c]$NORMAL");
# (only if username key is present) Edit of / New item / reply to / whatever
push @msg, $c.(
- ($_->{rev}||1) == 1 ? "New $types{$_->{type}}" :
- $_->{type} eq 't' ? 'Reply to' : 'Edit of'
- ).$NORMAL if $_->{username};
+ $id =~ /^w/ && !$_->{rev} ? 'Review of' :
+ $id =~ /^w/ ? 'Comment to review of' :
+ ($_->{rev}||1) == 1 ? "New $type" :
+ $id =~ /^t/ ? 'Reply to' : 'Edit of'
+ ).$NORMAL if exists $_->{username};
# (always) main title
push @msg, $_->{title};
@@ -255,7 +235,7 @@ sub formatid {
push @msg, $c."Posted in$NORMAL $_->{boards}" if $_->{boards};
# (only if username key is present) By [username]
- push @msg, $c."By$NORMAL $_->{username}" if $_->{username};
+ push @msg, $c."By$NORMAL ".($_->{username}//'deleted') if exists $_->{username};
# (only if comments key is present) Summary:
$_->{comments} =~ s/\n/ /g if $_->{comments};
@@ -273,13 +253,13 @@ sub formatid {
sub handleid {
- my($chan, $t, $id, $rev) = @_;
+ my($chan, $id, $rev) = @_;
# Some common exceptions
- return if grep "$t$id$rev" eq $_, qw|v1 v2 v3 v4 u2 i3 i5 i7 c64|;
+ return if grep $id eq $_, qw|v1 v2 v3 v4 u2 i3 i5 i7 c64|;
return if throttle $O{throt_vndbid}, 'irc_vndbid';
- return if throttle $O{throt_sameid}, "irc_sameid_$t$id$rev";
+ return if throttle $O{throt_sameid}, "irc_sameid_$id.$rev";
my $c = sub {
return if pg_expect $_[0], 1;
@@ -287,29 +267,18 @@ sub handleid {
};
# plain vn/user/producer/thread/tag/trait/release
- pg_cmd 'SELECT $1::text AS type, $2::integer AS id, '.(
- $t eq 'v' ? 'v.title FROM vn v WHERE v.id = $2' :
- $t eq 'u' ? 'u.username AS title FROM users u WHERE u.id = $2' :
- $t eq 'p' ? 'p.name AS title FROM producers p WHERE p.id = $2' :
- $t eq 'c' ? 'c.name AS title FROM chars c WHERE c.id = $2' :
- $t eq 's' ? 'sa.name AS title FROM staff s JOIN staff_alias sa ON sa.aid = s.aid AND sa.id = s.id WHERE s.id = $2' :
- $t eq 't' ? 'title, '.$GETBOARDS.' FROM threads t WHERE NOT t.hidden AND NOT t.private AND t.id = $2' :
- $t eq 'g' ? 'name AS title FROM tags WHERE id = $2' :
- $t eq 'i' ? 'name AS title FROM traits WHERE id = $2' :
- $t eq 'd' ? 'title FROM docs WHERE id = $2' :
- 'r.title FROM releases r WHERE r.id = $2'),
- [ $t, $id ], $c if !$rev && $t =~ /[dvprtugics]/;
+ pg_cmd 'SELECT $1::vndbid AS id, '.(
+ $id =~ /^t/ ? 'title, '.$GETBOARDS.' FROM threads t WHERE NOT t.hidden AND NOT t.private AND t.id = $1' :
+ $id =~ /^w/ ? 'v.title[1+1], u.username FROM reviews w JOIN vnt v ON v.id = w.vid LEFT JOIN users u ON u.id = w.uid WHERE w.id = $1' :
+ 'title[1+1] FROM item_info(NULL,$1,NULL) x'),
+ [ $id ], $c if !$rev && $id =~ /^[dvprtugicsw]/;
# edit/insert of vn/release/producer or discussion board post
- pg_cmd 'SELECT $1::text AS type, $2::integer AS id, $3::integer AS rev, '.(
- $t eq 'v' ? 'vh.title, u.username, c.comments FROM changes c JOIN vn_hist vh ON c.id = vh.chid JOIN users u ON u.id = c.requester WHERE c.type = \'v\' AND c.itemid = $2 AND c.rev = $3' :
- $t eq 'r' ? 'rh.title, u.username, c.comments FROM changes c JOIN releases_hist rh ON c.id = rh.chid JOIN users u ON u.id = c.requester WHERE c.type = \'r\' AND c.itemid = $2 AND c.rev = $3' :
- $t eq 'p' ? 'ph.name AS title, u.username, c.comments FROM changes c JOIN producers_hist ph ON c.id = ph.chid JOIN users u ON u.id = c.requester WHERE c.type = \'p\' AND c.itemid = $2 AND c.rev = $3' :
- $t eq 'c' ? 'ch.name AS title, u.username, c.comments FROM changes c JOIN chars_hist ch ON c.id = ch.chid JOIN users u ON u.id = c.requester WHERE c.type = \'c\' AND c.itemid = $2 AND c.rev = $3' :
- $t eq 's' ? 'sah.name AS title, u.username, c.comments FROM changes c JOIN staff_hist sh ON c.id = sh.chid JOIN users u ON u.id = c.requester JOIN staff_alias_hist sah ON sah.chid = c.id AND sah.aid = sh.aid WHERE c.type = \'s\' AND c.itemid = $2 AND c.rev = $3' :
- $t eq 'd' ? 'dh.title, u.username, c.comments FROM changes c JOIN docs_hist dh ON c.id = dh.chid JOIN users u ON u.id = c.requester WHERE c.type = \'d\' AND c.itemid = $2 AND c.rev = $3' :
- 't.title, u.username, '.$GETBOARDS.' FROM threads t JOIN threads_posts tp ON tp.tid = t.id JOIN users u ON u.id = tp.uid WHERE NOT t.hidden AND NOT t.private AND t.id = $2 AND tp.num = $3'),
- [ $t, $id, $rev], $c if $rev && $t =~ /[dvprtcs]/;
+ pg_cmd 'SELECT $1::vndbid AS id, $2::integer AS rev, '.(
+ $id =~ /^t/ ? 't.title, u.username, '.$GETBOARDS.' FROM threads t JOIN threads_posts tp ON tp.tid = t.id LEFT JOIN users u ON u.id = tp.uid WHERE NOT t.hidden AND NOT t.private AND t.id = $1 AND tp.num = $2' :
+ $id =~ /^w/ ? 'v.title[1+1], u.username FROM reviews_posts wp JOIN reviews w ON w.id = wp.id JOIN vnt v ON v.id = w.vid LEFT JOIN users u ON u.id = wp.uid WHERE wp.id = $1 AND wp.num = $2' :
+ 'x.title[1+1], u.username, c.comments FROM changes c JOIN item_info(NULL,$1,$2) x ON true JOIN users u ON u.id = c.requester WHERE c.itemid = $1 AND c.rev = $2'),
+ [ $id, $rev], $c if $rev && $id =~ /^[dvprtcsgiw]/;
}
@@ -321,8 +290,8 @@ sub vndbid {
my @id; # [ type, id, ref ]
for (split /[, ]/, $msg) {
next if length > 15 or m{[a-z]{3,6}://}i; # weed out URLs and too long things
- push @id, /^(?:.*[^\w]|)([dvprtcs])([1-9][0-9]*)\.([1-9][0-9]*)(?:[^\w].*|)$/ ? [ $1, $2, $3 ] # x+.+
- : /^(?:.*[^\w]|)([dvprtugics])([1-9][0-9]*)(?:[^\w].*|)$/ ? [ $1, $2, '' ] : (); # x+
+ push @id, /^(?:.*[^\w]|)([wdvprtcsgi][1-9][0-9]*)\.([1-9][0-9]*)(?:[^\w].*|)$/ ? [ $1, $2 ] # x+.+
+ : /^(?:.*[^\w]|)([wdvprtcsgiu][1-9][0-9]*)(?:[^\w].*|)$/ ? [ $1, '' ] : (); # x+
}
handleid($chan, @$_) for @id;
}
@@ -332,43 +301,31 @@ sub vndbid {
sub notify {
my(undef, $sel) = @_;
- my $k = {qw|newrevision rev newpost post newtrait trait newtag tag|}->{$sel};
+ my $k = {qw|newrevision rev newpost post newreview review|}->{$sel};
return if !$k || !$lastnotify{$k};
my $q = {
rev => q{
- SELECT c.type, c.rev, c.comments, c.id AS lastid, c.itemid AS id,
- COALESCE(vh.title, rh.title, ph.name, ch.name, sah.name, dh.title) AS title, u.username
+ SELECT c.rev, c.comments, c.id AS lastid, c.itemid AS id, x.title[1+1], u.username
FROM changes c
- LEFT JOIN vn_hist vh ON c.type = 'v' AND c.id = vh.chid
- LEFT JOIN releases_hist rh ON c.type = 'r' AND c.id = rh.chid
- LEFT JOIN producers_hist ph ON c.type = 'p' AND c.id = ph.chid
- LEFT JOIN chars_hist ch ON c.type = 'c' AND c.id = ch.chid
- LEFT JOIN staff_hist sh ON c.type = 's' AND c.id = sh.chid
- LEFT JOIN staff_alias_hist sah ON c.type = 's' AND sah.aid = sh.aid AND sah.chid = c.id
- LEFT JOIN docs_hist dh ON c.type = 'd' AND c.id = dh.chid
+ JOIN item_info(NULL, c.itemid, c.rev) x ON true
JOIN users u ON u.id = c.requester
- WHERE c.id > $1 AND c.requester <> 1
+ WHERE c.id > $1 AND c.requester <> 'u1'
ORDER BY c.id},
post => q{
- SELECT 't' AS type, tp.tid AS id, tp.num AS rev, t.title, u.username, tp.date AS lastid, }.$GETBOARDS.q{
+ SELECT tp.tid AS id, tp.num AS rev, t.title, COALESCE(u.username, 'deleted') AS username, tp.date AS lastid, }.$GETBOARDS.q{
FROM threads_posts tp
JOIN threads t ON t.id = tp.tid
- JOIN users u ON u.id = tp.uid
+ LEFT JOIN users u ON u.id = tp.uid
WHERE tp.date > $1 AND tp.num = 1 AND NOT t.hidden AND NOT t.private
ORDER BY tp.date},
- trait => q{
- SELECT 'i' AS type, t.id, t.name AS title, u.username, t.id AS lastid
- FROM traits t
- JOIN users u ON u.id = t.addedby
- WHERE t.id > $1
- ORDER BY t.id},
- tag => q{
- SELECT 'g' AS type, t.id, t.name AS title, u.username, t.id AS lastid
- FROM tags t
- JOIN users u ON u.id = t.addedby
- WHERE t.id > $1
- ORDER BY t.id}
+ review => q{
+ SELECT w.id, v.title[1+1], u.username, w.id AS lastid
+ FROM reviews w
+ JOIN vnt v ON v.id = w.vid
+ LEFT JOIN users u ON u.id = w.uid
+ WHERE w.id > $1
+ ORDER BY w.id}
}->{$k};
pg_cmd $q, [ $lastnotify{$k} ], sub {
@@ -396,29 +353,30 @@ list => [ 0, 0, sub {
$irc->is_channel_name($_[1]) ? 'This is not a warez channel!' : 'I am not a warez bot!');
}],
-quote => [ 1, 0, sub { send_quote($_[1]) } ],
+quote => [ 1, 0, sub {
+ my(undef, $chan) = @_;
+ pg_cmd 'SELECT quote FROM quotes ORDER BY random() LIMIT 1', undef, sub {
+ return if pg_expect $_[0], 1 or !$_[0]->nRows;
+ $irc->send_msg(PRIVMSG => $chan, encode_utf8 $_[0]->value(0,0));
+ };
+} ],
vn => [ 0, 0, sub {
my($nick, $chan, $q) = @_;
return $irc->send_msg(PRIVMSG => $chan, 'You forgot the search query, dummy~~!') if !$q;
- my @q = normalize_query($q);
- return $irc->send_msg(PRIVMSG => $chan,
- "Couldn't do anything with that search query, you might want to add quotes or use longer words.") if !@q;
-
- my $w = join ' AND ', map "c_search LIKE \$$_", 1..@q;
- pg_cmd qq{
- SELECT 'v'::text AS type, id, title
- FROM vn
- WHERE NOT hidden AND $w
- ORDER BY title
+ pg_cmd q{
+ SELECT id, title[1+1]
+ FROM vnt v
+ WHERE NOT hidden AND EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = v.id AND sc.label LIKE ALL (search_query($1)))
+ ORDER BY sorttitle
LIMIT 6
- }, [ map "%$_%", @q ], sub {
+ }, [ $q ], sub {
my $res = shift;
return if pg_expect $res, 1;
return $irc->send_msg(PRIVMSG => $chan, 'No visual novels found.') if !$res->nRows;
return $irc->send_msg(PRIVMSG => $chan,
- sprintf 'Too many results found, see %s/v/all?q=%s', config->{url}, uri_escape($q)) if $res->nRows > 5;
+ sprintf 'Too many results found, see %s/v?q=%s', config->{url}, uri_escape($q)) if $res->nRows > 5;
formatid([$res->rowsAsHashes()], $chan, 0);
};
}],
@@ -427,12 +385,12 @@ p => [ 0, 0, sub {
my($nick, $chan, $q) = @_;
return $irc->send_msg(PRIVMSG => $chan, 'You forgot the search query, dummy~~!') if !$q;
pg_cmd q{
- SELECT 'p'::text AS type, id, name AS title
- FROM producers p
- WHERE hidden = FALSE AND (name ILIKE $1 OR original ILIKE $1 OR alias ILIKE $1)
- ORDER BY name
- LIMIT 6
- }, [ "%$q%" ], sub {
+ SELECT id, name AS title
+ FROM producers p
+ WHERE NOT hidden AND EXISTS(SELECT 1 FROM search_cache sc WHERE sc.id = p.id AND sc.label LIKE ALL (search_query($1)))
+ ORDER BY name
+ LIMIT 6
+ }, [ $q ], sub {
my $res = shift;
return if pg_expect $res, 1;
return $irc->send_msg(PRIVMSG => $chan, 'No producers novels found.') if !$res->nRows;
@@ -442,27 +400,6 @@ p => [ 0, 0, sub {
};
}],
-scr => [ 0, 0, sub {
- my($nick, $chan, $q) = @_;
- return $irc->send_msg(PRIVMSG => $chan,
- q|Sorry, I failed to comprehend which screenshot you'd like me to lookup for you,|
- .q| please understand that Yorhel was not willing to supply me with mind reading capabilities.|)
- if !$q || $q !~ /([0-9]+)\.jpg/;
- $q = $1;
- pg_cmd q{
- SELECT 'v'::text AS type, v.id, v.title
- FROM changes c
- JOIN vn_screenshots_hist vsh ON vsh.chid = c.id
- JOIN vn v ON v.id = c.itemid
- WHERE vsh.scr = $1 LIMIT 1
- }, [ $q ], sub {
- my $res = shift;
- return if pg_expect $res, 1;
- return $irc->send_msg(PRIVMSG => $chan, "Couldn't find a VN with that screenshot ID.") if !$res->nRows;
- formatid([$res->rowsAsHashes()], $chan, 0);
- };
-}],
-
die => [ 1, 1, sub {
kill 'TERM', 0;
}],
diff --git a/lib/Multi/JASTUSA.pm b/lib/Multi/JASTUSA.pm
new file mode 100644
index 00000000..bf4b88f8
--- /dev/null
+++ b/lib/Multi/JASTUSA.pm
@@ -0,0 +1,87 @@
+package Multi::JASTUSA;
+
+use v5.28;
+use Multi::Core;
+use AnyEvent::HTTP;
+use JSON::XS 'decode_json';
+use VNDB::Config;
+
+
+my %C = (
+ sync_timeout => 6*3600,
+ url => 'https://app.jastusa.com/api/v2/shop/es?channelCode=JASTUSA&currency=USD&limit=50&localeCode=en_US&sale=false&sort=newest&zone=US&page=%d',
+);
+
+
+sub run {
+ shift;
+ $C{ua} = sprintf 'VNDB.org Affiliate Crawler (Multi v%s; contact@vndb.org)', config->{version};
+ %C = (%C, @_);
+
+ push_watcher schedule 35*60, $C{sync_timeout}, \&sync;
+}
+
+
+sub slug {
+ # The slug is not included in the API, so presumably generated in JS.
+ # This is reverse engineering attempt based on titles in the store, most likely missing a whole lot of symbols.
+ lc($_[0]) =~ s/[-, \[\]]+/-/rg =~ s/^-//r =~ s/-$//r =~ s/&/and/rg =~ s/♥/love/rg =~ tr/–ω锓*³★・;\/?/-we""/rd
+}
+
+
+sub item {
+ my($prefix, $p) = @_;
+ return 'Invalid object' if !$p->{code} || !$p->{variants}[0] || !$p->{translations}{en_US}{name};
+ my $slug = slug $p->{translations}{en_US}{name};
+ my $var = $p->{variants}[0];
+ return 'Not in stock' if !$var->{inStock};
+ return 'No price info' if !defined $var->{price};
+ my $price = $var->{price} ? sprintf 'US$ %.2f', $var->{price}/100 : 'free';
+ AE::log info => "$prefix $p->{code} at $slug for $price";
+ pg_cmd 'UPDATE shop_jastusa SET lastfetch = NOW(), deadsince = NULL, price = $1, slug = $2 WHERE id = $3',
+ [ $price, $slug, $p->{code} ];
+ 0
+}
+
+
+sub data {
+ my($page, $time, $body, $hdr) = @_;
+ my $prefix = sprintf '[%.1fs] %d', $time, $page;
+ return AE::log warn => "$prefix ERROR: $hdr->{Status} $hdr->{Reason}" if $hdr->{Status} !~ /^2/;
+ my $nfo = decode_json $body;
+ return AE::log warn => "$prefix ERROR: $hdr->{Status} $hdr->{Reason}" if ref $nfo ne 'HASH' || !$nfo->{pages};
+
+ for my $p ($nfo->{products}->@*) {
+ my $r = item($prefix, $p);
+ AE::log warn => "$prefix $p->{code}: $r" if $r;
+ }
+
+ if($page < $nfo->{pages}) {
+ fetch($page+1);
+ } else {
+ pg_cmd "UPDATE shop_jastusa SET deadsince = NOW(), price = '' WHERE deadsince IS NULL AND (lastfetch IS NULL OR lastfetch < NOW()-'1 hour'::interval)";
+ }
+}
+
+
+sub fetch {
+ my($page) = @_;
+ my $ts = AE::now;
+ http_get sprintf($C{url}, $page),
+ headers => {'User-Agent' => $C{ua}},
+ timeout => 60,
+ sub { data($page, AE::now-$ts, @_) };
+}
+
+sub sync {
+ pg_cmd 'DELETE FROM shop_jastusa WHERE id NOT IN(SELECT l_jastusa FROM releases WHERE NOT hidden)';
+ pg_cmd q{
+ INSERT INTO shop_jastusa (id)
+ SELECT DISTINCT l_jastusa
+ FROM releases
+ WHERE NOT hidden AND l_jastusa <> ''
+ AND NOT EXISTS(SELECT 1 FROM shop_jastusa WHERE id = l_jastusa)
+ }, [], sub { fetch(1) }
+}
+
+1;
diff --git a/lib/Multi/JList.pm b/lib/Multi/JList.pm
index 515a34b5..60ce2c1e 100644
--- a/lib/Multi/JList.pm
+++ b/lib/Multi/JList.pm
@@ -5,11 +5,11 @@ use warnings;
use Multi::Core;
use AnyEvent::HTTP;
use VNDB::Config;
+use VNDB::ExtLinks;
my %C = (
- jbox => 'https://www.jbox.com/',
- jlist => 'https://www.jlist.com/',
+ url => 'https://jlist.com/shop/product/%s',
clean_timeout => 48*3600,
check_timeout => 10*60, # Minimum time between fetches.
);
@@ -35,45 +35,34 @@ sub run {
}
-sub trysite {
- my($jbox, $id) = @_;
- my $ts = AE::now;
- my $url = ($jbox eq 't' ? $C{jbox} : $C{jlist}).$id;
- http_get $url, headers => {'User-Agent' => $C{ua} }, timeout => 60,
- sub { data($jbox, AE::now-$ts, $id, @_) };
-}
-
-
sub data {
- my($jbox, $time, $id, $body, $hdr) = @_;
+ my($time, $id, $body, $hdr) = @_;
my $prefix = sprintf '[%.1fs] %s', $time, $id;
return AE::log warn => "$prefix ERROR: $hdr->{Status} $hdr->{Reason}" if $hdr->{Status} !~ /^2/ && $hdr->{Status} ne '404';
- return AE::log warn => "$prefix ERROR: Blocked by StackPath" if $body =~ /StackPath/;
- my $found = $hdr->{Status} ne '404' && $body =~ /fancybox mainProductImage/;
- my $outofstock = $body =~ /<div class="statusBox-detail">[\s\r\n]*Out of stock[\s\r\n]*<\/div>/im;
- my $price = $body =~ /<span class="price"(?: id="product-price-\d+")?>\s*\$(\d+\.\d+)(?:\/\$\d+\.\d+)?\s*<\/span>/ ? sprintf('US$ %.2f', $1) : '';
+ # Extract info from the JSON-LD embedded on the page. Assumes there's either
+ # a single "Product" or none. Also assumes specific JSON formatting, because
+ # I'm too lazy to properly extract out and parse the JSON.
+ my $found = $hdr->{Status} ne '404' && $body =~ /"\@type":"Product"/;
+ my $outofstock = $body !~ m{"availability":"https://schema.org/InStock"};
+ my $price = $body =~ /"price":"([0-9\.]+)"/ ? sprintf('US$ %.2f', $1) : '';
return AE::log warn => "$prefix Product found, but no price" if !$price && $found && !$outofstock;
# Out of stock? Update database.
if($outofstock) {
- pg_cmd q{UPDATE shop_jlist SET deadsince = NULL, jbox = $2, price = '', lastfetch = NOW() WHERE id = $1}, [ $id, $jbox ];
- AE::log debug => "$prefix is out of stock on jbox=$jbox";
+ pg_cmd q{UPDATE shop_jlist SET deadsince = NULL, price = '', lastfetch = NOW() WHERE id = $1}, [ $id ];
+ AE::log debug => "$prefix is out of stock";
# We have a price? Update database.
} elsif($price) {
- pg_cmd q{UPDATE shop_jlist SET deadsince = NULL, jbox = $2, price = $3, lastfetch = NOW() WHERE id = $1}, [ $id, $jbox, $price ];
- AE::log debug => "$prefix for $price on jbox=$jbox";
-
- # No price or stock info? Try J-List
- } elsif($jbox eq 't') {
- trysite 'f', $id;
+ pg_cmd q{UPDATE shop_jlist SET deadsince = NULL, price = $2, lastfetch = NOW() WHERE id = $1}, [ $id, $price ];
+ AE::log debug => "$prefix for $price";
- # Nothing at all? Update database.
+ # Not found? Update database.
} else {
- pg_cmd q{UPDATE shop_jlist SET deadsince = coalesce(deadsince, NOW()), lastfetch = NOW() WHERE id = $1}, [ $id ];
- AE::log info => "$prefix not found on either JBOX or J-List.";
+ pg_cmd q{UPDATE shop_jlist SET deadsince = NOW() WHERE deadsince IS NULL AND id = $1}, [ $id ];
+ AE::log info => "$prefix not found.";
}
}
@@ -82,6 +71,9 @@ sub sync {
pg_cmd 'SELECT id FROM shop_jlist ORDER BY lastfetch ASC NULLS FIRST LIMIT 1', [], sub {
my($res, $time) = @_;
return if pg_expect $res, 1 or !$res->nRows;
- trysite 't', $res->value(0,0);
+ my $id = $res->value(0,0);
+ my $ts = AE::now;
+ http_get sprintf($C{url}, $id), headers => {'User-Agent' => $C{ua} }, timeout => 60,
+ sub { data(AE::now-$ts, $id, @_) };
};
}
diff --git a/lib/Multi/Maintenance.pm b/lib/Multi/Maintenance.pm
index abed87a6..12158eb1 100644
--- a/lib/Multi/Maintenance.pm
+++ b/lib/Multi/Maintenance.pm
@@ -9,7 +9,6 @@ use strict;
use warnings;
use Multi::Core;
use PerlIO::gzip;
-use VNDBUtil 'normalize_titles';
use VNDB::Config;
@@ -17,9 +16,8 @@ my $monthly;
sub run {
- push_watcher schedule 12*3600, 24*3600, \&daily;
- push_watcher schedule 0, 3600, \&vnsearch_check;
- push_watcher pg->listen(vnsearch => on_notify => \&vnsearch_check);
+ push_watcher schedule 57*60, 3600, \&hourly; # Every hour at xx:57
+ push_watcher schedule 7*3600+1800, 24*3600, \&daily; # 7:30 UTC, 30 minutes before the daily DB dumps are created
set_monthly();
}
@@ -48,12 +46,26 @@ sub log_res {
}
+sub hourly {
+ pg_cmd 'SELECT update_vnvotestats()', undef, sub { log_res vnstats => @_ };
+}
+
+
#
# D A I L Y J O B S
#
my %dailies = (
+ # Delete tags assigned to Multi that also have (possibly inherited) votes from other users.
+ cleanmultitags => q|
+ WITH RECURSIVE
+ t_votes(tag,vid,uid) AS (SELECT tv.tag, tv.vid, tv.uid FROM tags_vn tv LEFT JOIN users u ON u.id = tv.uid WHERE tv.uid IS DISTINCT FROM 'u1' AND (u.id IS NULL OR u.perm_tag)),
+ t_inherit(tag,vid,uid) AS (SELECT * FROM t_votes UNION SELECT tp.parent, th.vid, th.uid FROM t_inherit th JOIN tags_parents tp ON tp.id = th.tag),
+ t_nonmulti(tag,vid) AS (SELECT DISTINCT tag, vid FROM t_inherit),
+ t_del(tag,vid) AS (SELECT tv.tag, tv.vid FROM tags_vn tv JOIN t_nonmulti tn ON (tn.tag,tn.vid) = (tv.tag,tv.vid) WHERE tv.uid = 'u1')
+ DELETE FROM tags_vn tv WHERE tv.uid = 'u1' AND EXISTS(SELECT 1 FROM t_del td WHERE (td.tag,td.vid) = (tv.tag,tv.vid))|,
+
# takes about 50ms to 500ms to complete, depending on how many releases have been released within the past 5 days
vncache_inc => q|
SELECT update_vncache(id)
@@ -65,27 +77,30 @@ my %dailies = (
AND r.released <= TO_CHAR(NOW(), 'YYYYMMDD')::integer
) AS r(id)|,
- # takes about 15 seconds max, still OK
+ # takes about 6 seconds, OK
tagcache => 'SELECT tag_vn_calc(NULL)',
- # takes about 25 seconds, OK
+ # takes about 11 seconds, OK
traitcache => 'SELECT traits_chars_calc(NULL)',
- # takes about 4 seconds, OK
- vnstats => 'SELECT update_vnvotestats()',
+ lengthcache => 'SELECT update_vn_length_cache(NULL)',
+
+ # takes about 10 seconds, OK
+ imagecache => 'SELECT update_images_cache(NULL)',
+
+ reviewcache => 'SELECT update_reviews_votes_cache(NULL)',
- # should be pretty fast
- cleangraphs => q|
- DELETE FROM relgraphs vg
- WHERE NOT EXISTS(SELECT 1 FROM vn WHERE rgraph = vg.id)
- AND NOT EXISTS(SELECT 1 FROM producers WHERE rgraph = vg.id)|,
+ quotescache => 'SELECT quotes_rand_calc()',
- cleansessions => q|DELETE FROM sessions WHERE expires < NOW()|,
+ deleteusers => q|SELECT user_delete()|,
+ cleansessions => q|DELETE FROM sessions WHERE expires < NOW() AND type <> 'api2'|,
cleannotifications => q|DELETE FROM notifications WHERE read < NOW()-'1 month'::interval|,
cleannotifications2=> q|DELETE FROM notifications WHERE id IN (
SELECT id FROM (SELECT id, row_number() OVER (PARTITION BY uid ORDER BY id DESC) > 500 from notifications) AS x(id,del) WHERE x.del)|,
rmunconfirmusers => q|DELETE FROM users WHERE registered < NOW()-'1 week'::interval AND NOT email_confirmed|,
cleanthrottle => q|DELETE FROM login_throttle WHERE timeout < NOW()|,
+ cleanresthrottle => q|DELETE FROM reset_throttle WHERE timeout < NOW()|,
+ cleanregthrottle => q|DELETE FROM registration_throttle WHERE timeout < NOW()|,
);
@@ -166,41 +181,4 @@ sub monthly {
}
-
-#
-# V N S E A R C H C A C H E
-#
-
-
-sub vnsearch_check {
- pg_cmd 'SELECT id FROM vn WHERE c_search IS NULL LIMIT 1', undef, sub {
- my $res = shift;
- return if pg_expect $res, 1 or !$res->rows;
-
- my $id = $res->value(0,0);
- pg_cmd q|SELECT title, original, alias FROM vn WHERE id = $1
- UNION SELECT r.title, r.original, NULL FROM releases r JOIN releases_vn rv ON rv.id = r.id WHERE rv.vid = $1 AND NOT r.hidden|,
- [ $id ], sub { vnsearch_update($id, @_) };
- };
-}
-
-
-sub vnsearch_update { # id, res, time
- my($id, $res, $time) = @_;
- return if pg_expect $res, 1;
-
- my $t = normalize_titles(grep length, map
- +($_->{title}, $_->{original}, split /[\n,]/, $_->{alias}||''),
- $res->rowsAsHashes
- );
-
- pg_cmd 'UPDATE vn SET c_search = $1 WHERE id = $2', [ $t, $id ], sub {
- my($res, $t2) = @_;
- return if pg_expect $res, 0;
- AE::log info => sprintf 'Updated search cache for v%d (%3dms SQL)', $id, ($time+$t2)*1000;
- vnsearch_check;
- };
-}
-
-
1;
diff --git a/lib/Multi/RG.pm b/lib/Multi/RG.pm
deleted file mode 100644
index 0a6039a3..00000000
--- a/lib/Multi/RG.pm
+++ /dev/null
@@ -1,347 +0,0 @@
-
-#
-# Multi::RG - Relation graph generator
-#
-
-package Multi::RG;
-
-use strict;
-use warnings;
-use Multi::Core;
-use AnyEvent::Util;
-use Encode 'encode_utf8';
-use XML::Parser;
-use TUWF::XML;
-use VNDB::Types;
-
-
-my %O = (
- font => 'Arial',
- fsize => [ 9, 7, 10 ], # nodes, edges, node_title
- dot => '/usr/bin/dot',
- check_delay => 3600,
-);
-
-
-my %C;
-
-
-sub run {
- shift;
- %O = (%O, @_);
- push_watcher schedule 0, $O{check_delay}, \&check_rg;
- push_watcher pg->listen(relgraph => on_notify => \&check_rg);
-}
-
-
-sub check_rg {
- # Only process one at a time, we don't know how many other entries the
- # current graph will affect.
- return if $C{id};
-
- AE::log debug => 'Checking for new graphs to create.';
- pg_cmd q|
- SELECT 'v', v.id FROM vn v JOIN vn_relations vr ON vr.id = v.id WHERE v.rgraph IS NULL AND v.hidden = FALSE
- UNION
- SELECT 'p', p.id FROM producers p JOIN producers_relations pr ON pr.id = p.id WHERE p.rgraph IS NULL AND p.hidden = FALSE
- LIMIT 1|, undef, sub {
- my($res, $time) = @_;
- return if pg_expect $res, 1 or !$res->rows;
- creategraph(scalar $res->value(0, 0), scalar $res->value(0, 1), 0, $time);
- }
-}
-
-
-sub creategraph {
- my($type, $id, $official, $sqlt) = @_;
-
- %C = (
- start => scalar AE::time(),
- type => $type,
- id => $id,
- sqlt => $sqlt,
- offi => $official,
- rels => {}, # relations (key=id1-id2, value=[relation,official])
- nodes => {}, # nodes (key=id, value= 0:found, 1:processed)
- );
-
- AE::log debug => "Generating graph for $C{type}$C{id}";
- getrelid($C{id});
-}
-
-
-sub getrelid {
- my $id = shift;
- AE::log debug => "Fetching relations for $C{type}$id";
- pg_cmd $C{type} eq 'p'
- ? 'SELECT pid, relation FROM producers_relations WHERE id = $1'
- : $C{offi} ? 'SELECT vid, relation, official FROM vn_relations WHERE id = $1 AND official'
- : 'SELECT vid, relation, official FROM vn_relations WHERE id = $1',
- [ $id ], sub { getrel($id, @_) };
-}
-
-
-sub getrel { # id, res, time
- my($id, $res, $time) = @_;
- return if pg_expect $res, 1, $id;
-
- $C{sqlt} += $time;
- $C{nodes}{$id} = 1;
-
- for($res->rows) {
- my($xid, $xrel, $xoff) = @$_;
- $xoff = 0 if $xoff && $xoff =~ /^f/;
-
- $C{rels}{$id.'-'.$xid} = [ ($C{type} eq 'v' ? \%VN_RELATION : \%PRODUCER_RELATION)->{$xrel}{reverse}, $xoff ] if $id < $xid;
- $C{rels}{$xid.'-'.$id} = [ $xrel, $xoff ] if $id > $xid;
-
- # New node? Get its relations too.
- if(!exists $C{nodes}{$xid}) {
- $C{nodes}{$xid} = 0;
- getrelid $xid;
- }
- }
-
- # Wait for other node relations to come in.
- return if grep !$_, values %{$C{nodes}};
-
- # For VNs: If the graph has more than 30 nodes and there are unofficial
- # links, start again, this time throwing away the unofficial links.
- # XXX: This is an ugly hack.
- # - This would remove unofficial links between VNs that are in the graph anyway.
- # - It can result in graphs with just a single VN node and no links.
- # - How well does this work together with the current caching mechanism? It's
- # possible that a distant VN doesn't get its relation graph updated because
- # it's being excluded here.
- if($C{type} eq 'v' && scalar keys %{$C{nodes}} > 30 && grep !$_->[1], values %{$C{rels}}) {
- AE::log info => "Graph for $C{type}$C{id} is too large, re-creating graph without unofficial links";
- return creategraph v => $C{id}, 1, $C{sqlt};
- }
-
- # do we have all relations now? get node info
- my @ids = keys %{$C{nodes}};
- my $ids = join(', ', map '$'.$_, 1..@ids);
- AE::log debug => "Fetching node information for $C{type}:".join ', ', @ids;
- pg_cmd $C{type} eq 'v'
- ? "SELECT id, title, c_released AS date, array_to_string(c_languages, '/') AS lang FROM vn WHERE id IN($ids) ORDER BY c_released"
- : "SELECT id, name, lang, type FROM producers WHERE id IN($ids) ORDER BY name",
- [ @ids ], \&builddot;
-}
-
-
-sub builddot {
- my($res, $time) = @_;
- return if pg_expect $res, 1, $C{id};
- $C{sqlt} += $time;
-
- my $gv =
- qq|graph rgraph {\n|.
- qq|\tnode [ fontname = "$O{font}", shape = "plaintext",|.
- qq| fontsize = $O{fsize}[0], fontcolor = "#333333", color = "#111111" ]\n|.
- qq|\tedge [ labeldistance = 2.5, labelangle = -20, labeljust = 1, minlen = 2, dir = "both",|.
- qq| fontname = $O{font}, fontsize = $O{fsize}[1], arrowsize = 0.7, color = "#111111", fontcolor = "#333333" ]\n|;
-
- # insert all nodes and relations
- my %nodes = map +($_->{id}, $_), $res->rowsAsHashes;
- $gv .= $C{type} eq 'v' ? gv_vnnode($nodes{$_}) : gv_prodnode($nodes{$_}) for keys %nodes;
- $gv .= $C{type} eq 'v' ? gv_vnrels($C{rels}, \%nodes) : gv_prodrels($C{rels}, \%nodes);
-
- $gv .= "}\n";
-
- rundot($gv);
-}
-
-
-sub gv_vnnode {
- my $n = shift;
-
- my $date = sprintf '%08d', $n->{date};
- $date =~ s{^([0-9]{4})([0-9]{2})([0-9]{2})$}{
- $1 == 0 ? 'unknown'
- : $1 == 9999 ? 'TBA'
- : $2 == 99 ? $1
- : $3 == 99 ? "$1-$2" : "$1-$2-$3"
- }e;
-
- my $title = $n->{title};
- $title = substr($title, 0, 27).'...' if length($title) > 30;
- $title =~ s/&/&amp;/g;
- $title =~ s/>/&gt;/g;
- $title =~ s/</&lt;/g;
-
- my $tooltip = $n->{title};
- $tooltip =~ s/\\/\\\\/g;
- $tooltip =~ s/"/\\"/g;
-
- return sprintf
- qq|\tv%d [ id = "node_v%1\$d", URL = "/v%1\$d", tooltip = "%s", label=<|.
- q|<TABLE CELLSPACING="0" CELLPADDING="1" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|.
- q|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="2"><FONT POINT-SIZE="%d"> %s </FONT></TD></TR>|.
- q|<TR><TD> %s </TD><TD> %s </TD></TR>|.
- qq|</TABLE>> ]\n|,
- $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($title), $date, $n->{lang}||'N/A';
-}
-
-
-sub gv_vnrels {
- my($rels, $vns) = @_;
- my $r = '';
-
- # @rels = ([ vid1, vid2, relation, official, date1, date2 ], ..), for easier processing
- my @rels = map {
- /^([0-9]+)-([0-9]+)$/;
- [ $1, $2, @{$rels->{$_}}, $vns->{$1}{date}, $vns->{$2}{date} ]
- } keys %$rels;
-
- # insert all edges, ordered by release date
- for (sort { ($a->[4]>$a->[5]?$a->[5]:$a->[4]) <=> ($b->[4]>$b->[5]?$b->[5]:$b->[4]) } @rels) {
- # [older game] -> [newer game]
- if($_->[5] > $_->[4]) {
- ($_->[0], $_->[1]) = ($_->[1], $_->[0]);
- $_->[2] = $VN_RELATION{$_->[2]}{reverse};
- }
- my $rel = $VN_RELATION{$_->[2]}{txt};
- my $rev = $VN_RELATION{ $VN_RELATION{$_->[2]}{reverse} }{txt};
- my $style = $_->[3] ? '' : ', style="dotted"';
- my $label = $rev ne $rel
- ? qq|headlabel = "$rel" taillabel = "${rev}" $style|
- : qq|label = "$rel" $style|;
- $r .= qq|\tv$$_[1] -- v$$_[0] [ $label ]\n|;
- }
- $r;
-}
-
-
-sub gv_prodnode {
- my $n = shift;
-
- my $name = $n->{name};
- $name = substr($name, 0, 27).'...' if length($name) > 30;
- $name =~ s/&/&amp;/g;
- $name =~ s/>/&gt;/g;
- $name =~ s/</&lt;/g;
-
- my $tooltip = $n->{name};
- $tooltip =~ s/\\/\\\\/g;
- $tooltip =~ s/"/\\"/g;
-
- return sprintf
- qq|\tp%d [ id = "node_p%1\$d", URL = "/p%1\$d", tooltip = "%s", label=<|.
- q|<TABLE CELLSPACING="0" CELLPADDING="1" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|.
- q|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="2"><FONT POINT-SIZE="%d"> %s </FONT></TD></TR>|.
- q|<TR><TD ALIGN="CENTER"> %s </TD><TD ALIGN="CENTER"> %s </TD></TR>|.
- qq|</TABLE>> ]\n|,
- $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($name),
- $LANGUAGE{$n->{lang}}, $PRODUCER_TYPE{$n->{type}};
-}
-
-
-sub gv_prodrels {
- my($rels, $prods) = @_;
- my $r = '';
-
- for (keys %$rels) {
- /^([0-9]+)-([0-9]+)$/;
- my $p1 = $prods->{$1};
- my $p2 = $prods->{$2};
-
- my $rel = $PRODUCER_RELATION{$rels->{$_}[0]}{txt};
- my $rev = $PRODUCER_RELATION{ $PRODUCER_RELATION{$rels->{$_}[0]}{reverse} }{txt};
- my $label = $rev ne $rel
- ? qq|headlabel = "$rev", taillabel = "$rel"|
- : qq|label = "$rel"|;
- $r .= qq|\tp$p1->{id} -- p$p2->{id} [ $label ]\n|;
- }
- $r;
-}
-
-
-sub rundot {
- my $gv = shift;
- AE::log trace => "Running graphviz, dot:\n$gv";
-
- my $svg;
- my $cv = run_cmd [ $O{dot}, '-Tsvg' ],
- '<', \$gv,
- '>', \$svg,
- '2>', sub { AE::log warn => "STDERR from graphviz: $_[0]" if $_[0]; };
-
- $cv->cb(sub {
- return AE::log warn => 'graphviz failed' if shift->recv;
- processgraph($svg);
- });
-}
-
-
-sub processgraph {
- my $data = shift;
-
- # Before saving the SVG output, we'll modify it a little:
- # - Remove comments
- # - Remove <title> elements (unused)
- # - Remove id attributes (unused)
- # - Remove first <polygon> element (emulates the background color)
- # - Replace stroke and fill attributes with classes (so that coloring is done in CSS)
- my $svg = '';
- my $w = TUWF::XML->new(write => sub { $svg .= shift });
- my $p = XML::Parser->new;
- $p->setHandlers(
- Start => sub {
- my($expat, $el, %attr) = @_;
- return if $el eq 'title' || $expat->in_element('title');
- return if $el eq 'polygon' && $expat->depth == 2;
-
- $attr{class} = 'border' if $attr{stroke} && $attr{stroke} eq '#111111';
- $attr{class} = 'nodebg' if $attr{fill} && $attr{fill} eq '#222222';
-
- delete @attr{qw|stroke fill|};
- delete $attr{id} if $attr{id} && $attr{id} !~ /^node_[vp]\d+$/;
- $w->tag($el, %attr, $el eq 'path' || $el eq 'polygon' ? undef : ());
- },
- End => sub {
- my($expat, $el) = @_;
- return if $el eq 'title' || $expat->in_element('title');
- return if $el eq 'polygon' && $expat->depth == 2;
- $w->end($el) if $el ne 'path' && $el ne 'polygon';
- },
- Char => sub {
- my($expat, $str) = @_;
- return if $expat->in_element('title');
- $w->txt($str) if $str !~ /^[\s\t\r\n]*$/s;
- }
- );
- $p->parsestring($data);
-
- # save the processed SVG in the database and fetch graph ID
- AE::log trace => "Processed SVG:\n$svg";
- pg_cmd 'INSERT INTO relgraphs (svg) VALUES ($1) RETURNING id', [ $svg ], \&save_rgraph;
-}
-
-
-sub save_rgraph {
- my($res, $time) = @_;
- return if pg_expect $res, 1;
- $C{sqlt} += $time;
-
- my $graphid = $res->value(0,0);
- my @ids = sort keys %{$C{nodes}};
- my $ids = join ',', map '$'.$_, 2..@ids+1;
- my $table = $C{type} eq 'v' ? 'vn' : 'producers';
-
- pg_cmd "UPDATE $table SET rgraph = \$1 WHERE id IN($ids)",
- [ $graphid, @ids ],
- sub {
- my($res, $time) = @_;
- return if pg_expect $res, 0;
- $C{sqlt} += $time;
-
- AE::log info => sprintf 'Generated relation graph #%d in %.2fs (%.2fs SQL), %s: %s',
- $graphid, AE::time-$C{start}, $C{sqlt}, $C{type}, join ',', @ids;
-
- %C = ();
- check_rg;
- };
-}
-
-
-1;
diff --git a/lib/Multi/Wikidata.pm b/lib/Multi/Wikidata.pm
index d54fbc8b..44f49a43 100644
--- a/lib/Multi/Wikidata.pm
+++ b/lib/Multi/Wikidata.pm
@@ -94,7 +94,7 @@ sub save {
my $v = $_->{mainsnak}{datavalue}{value};
if(ref $v) {
AE::log warn => "Q$id has a non-scalar value for '$p'";
- } elsif($_->{qualifiers}{P582}) {
+ } elsif($_->{qualifiers}{P582} || $_->{qualifiers}{P8554}) {
AE::log info => "Q$id excluding property '$p' because it has an 'end time'";
} elsif(defined $v) {
push @val, $v;
diff --git a/lib/PWLookup.pm b/lib/PWLookup.pm
deleted file mode 100644
index 6e2f03e4..00000000
--- a/lib/PWLookup.pm
+++ /dev/null
@@ -1,155 +0,0 @@
-#!/usr/bin/perl
-
-# This script is based on the btree.pl that I wrote as part of a little
-# experiment: https://dev.yorhel.nl/doc/pwlookup
-#
-# It is hardcoded to use gzip (because that's available in a standard Perl
-# distribution) compression level 9 (saves a few MiB with no noticable impact
-# on lookup performance) with 4k block sizes (because that is fast enough and
-# offers good compression).
-#
-# Creating the database:
-#
-# perl PWlookup.pm create <sorted-dictionary >dbfile
-#
-# Extracting all passwords from the database:
-#
-# perl PWLookup.pm extract dbfile >sorted-dictionary
-#
-# Performing lookups (from the CLI):
-#
-# perl PWLookup.pm lookup dbfile query
-#
-# Performing lookups (from Perl):
-#
-# use PWLookup;
-# my $pw_exists = PWLookup::lookup($dbfile, $query);
-
-package PWLookup;
-
-use strict;
-use warnings;
-use v5.10;
-use Compress::Zlib qw/compress uncompress/;
-use Encode qw/encode_utf8 decode_utf8/;
-
-my $blocksize = 4096;
-
-# Encode/decode a block reference, [ leaf, length, offset ]. Encoded in a single 64bit integer as (leaf | length << 1 | offset << 16)
-sub eref($) { pack 'Q', ($_[0][0]?1:0) | $_[0][1]<<1 | $_[0][2]<<16 }
-sub dref($) { my $v = unpack 'Q', $_[0]; [$v&1, ($v>>1)&((1<<15)-1), $v>>16] }
-
-# Write a block and return its reference.
-sub writeblock {
- state $off = 0;
- my $buf = compress($_[0], 9);
- my $len = length $buf;
- print $buf;
- my $oldoff = $off;
- $off += $len;
- [$_[1], $len, $oldoff]
-}
-
-# Read a block given a file handle and a reference.
-sub readblock {
- my($F, $ref) = @_;
- die $! if !sysseek $F, $ref->[2], 0;
- die $! if $ref->[1] != sysread $F, (my $buf), $ref->[1];
- uncompress($buf)
-}
-
-sub encode {
- my $leaf = "\0";
- my @nodes = ('');
- my $ref;
-
- my $flush = sub {
- my $minsize = $_[0];
- return if $minsize > length $leaf;
-
- my $str = $leaf =~ /^\x00([^\x00]*)/ && $1;
- $ref = writeblock $leaf, 1;
- $leaf = "\0";
- $nodes[0] .= "$str\x00".eref($ref);
-
- for(my $i=0; $i <= $#nodes && $minsize < length $nodes[$i]; $i++) {
- my $str = $nodes[$i] =~ s/^([^\x00]*)\x00// && $1;
- $ref = writeblock $nodes[$i], 0;
- $nodes[$i] = '';
- if($minsize || $nodes[$i+1]) {
- $nodes[$i+1] ||= '';
- $nodes[$i+1] .= "$str\x00".eref($ref);
- }
- }
- };
-
- my $last;
- while((my $p = <STDIN>)) {
- chomp($p);
- # No need to store passwords that are rejected by form validation
- if(!length($p) || length($p) > 500 || !eval { decode_utf8((local $_=$p), Encode::FB_CROAK); 1 } || $p =~ /\x00/) {
- warn sprintf "Rejecting: %s\n", ($p =~ s/([^\x21-\x7e])/sprintf '%%%02x', ord $1/ger);
- next;
- }
- # Extra check to make sure the input is unique and sorted according to Perl's string comparison
- if(defined($last) && $last ge $p) {
- warn "Rejecting due to uniqueness or incorrect sorting: $p\n";
- next;
- }
- $leaf .= "$p\0";
- $flush->($blocksize);
- }
- $flush->(0);
- print eref $ref;
-}
-
-
-sub lookup_rec {
- my($F, $q, $ref) = @_;
- my $buf = readblock $F, $ref;
- if($ref->[0]) {
- return $buf =~ /\x00\Q$q\E\x00/;
- } else {
- while($buf =~ /(.{8})([^\x00]+)\x00/sg) {
- return lookup_rec($F, $q, dref $1) if $q lt $2;
- }
- return lookup_rec($F, $q, dref substr $buf, -8)
- }
-}
-
-sub lookup {
- my($f, $q) = @_;
- open my $F, '<', $f or die $!;
- sysseek $F, -8, 2 or die $!;
- die $! if 8 != sysread $F, (my $buf), 8;
- lookup_rec($F, encode_utf8($q), dref $buf)
-}
-
-
-sub extract_rec {
- my($F, $ref) = @_;
- my $buf = readblock $F, $ref;
- if($ref->[0]) {
- print "$1\n" while $buf =~ /\x00([^\x00]+)/g;
- } else {
- extract_rec($F, dref $1) while $buf =~ /(.{8})[^\x00]+\x00/sg;
- extract_rec($F, dref substr $buf, -8)
- }
-}
-
-sub extract {
- my($f) = @_;
- open my $F, '<', $f or die $!;
- sysseek $F, -8, 2 or die $!;
- die $! if 8 != sysread $F, (my $buf), 8;
- extract_rec($F, dref $buf)
-}
-
-
-if(!caller) {
- encode() if $ARGV[0] eq 'create';
- extract($ARGV[1]) if $ARGV[0] eq 'extract';
- printf "%s\n", lookup($ARGV[1], decode_utf8 $ARGV[2]) ? 'Found' : 'Not found' if $ARGV[0] eq 'lookup';
-}
-
-1;
diff --git a/lib/SkinFile.pm b/lib/SkinFile.pm
deleted file mode 100644
index 78608f89..00000000
--- a/lib/SkinFile.pm
+++ /dev/null
@@ -1,74 +0,0 @@
-
-package SkinFile;
-
-use strict;
-use warnings;
-use Fcntl 'LOCK_SH', 'SEEK_SET';
-
-
-sub new {
- my($class, $root, $open) = @_;
- my $self = bless { root => $root }, $class;
- $self->open($open) if $open;
- return $self;
-}
-
-
-sub list {
- return map /\/([^\/]+)\/conf/?$1:(), glob "$_[0]{root}/*/conf";
-}
-
-
-sub open {
- my($self, $dir, $force) = @_;
- return if $self->{"s_$dir"} && !$force;
- my %o;
- open my $F, '<:utf8', "$self->{root}/$dir/conf" or die $!;
- flock $F, LOCK_SH or die $!;
- seek $F, 0, SEEK_SET or die $!;
- local $_;
- while(<$F>) {
- chomp;
- s/\r//g;
- s{[\t\s]*//.+$}{};
- next if !/^([a-z0-9]+)[\t\s]+(.+)$/;
- $o{$1} = $2;
- }
- close $F;
- $self->{"s_$dir"} = \%o;
- $self->{opened} = $dir;
-}
-
-
-sub get {
- my($self, $dir, $var) = @_;
- $self->open($dir) if defined $var;
- $var = $dir if !defined $var;
- $var ? $self->{"s_$self->{opened}"}{$var} : keys %{$self->{"s_$self->{opened}"}};
-}
-
-
-1;
-
-
-__END__
-
-=pod
-
-=head1 NAME
-
-SkinFile - Simple object oriented interface to parsing skin configuration files
-
-=head1 USAGE
-
- use SkinFile;
- my $s = SkinFile->new($dir);
- my @skins = $s->list;
-
- $s->open($skins[0]);
- my $name = $s->get('name');
-
- # same as above, but in one function
- my $name = $s->get($skins[0], 'name');
-
-
diff --git a/lib/VNDB/BBCode.pm b/lib/VNDB/BBCode.pm
index d11171c5..950dcb8b 100644
--- a/lib/VNDB/BBCode.pm
+++ b/lib/VNDB/BBCode.pm
@@ -5,9 +5,13 @@ use warnings;
use Exporter 'import';
use TUWF::XML 'xml_escape';
-our @EXPORT = qw/bb2html bb2text bb_subst_links/;
+our @EXPORT = qw/bb_format bb_subst_links/;
# Supported BBCode:
+# [b] .. [/b]
+# [i] .. [/i]
+# [u] .. [/u]
+# [s] .. [/s]
# [spoiler] .. [/spoiler]
# [quote] .. [/quote]
# [code] .. [/code]
@@ -17,7 +21,8 @@ our @EXPORT = qw/bb2html bb2text bb_subst_links/;
# dblink: v+, v+.+, d+#+, d+#+.+
#
# Permitted nesting of formatting codes:
-# spoiler -> url, raw, link, dblink
+# inline = b,i,u,s,spoiler
+# inline -> inline, url, raw, link, dblink
# quote -> anything
# code -> nothing
# url -> raw
@@ -29,10 +34,18 @@ our @EXPORT = qw/bb2html bb2text bb_subst_links/;
# Returns: ($token, @arg) on successful parse, () otherwise.
# Trivial open and close actions
+sub _b_start { if(lc$_[1] eq '[b]') { push @{$_[0]}, 'b'; ('b_start') } else { () } }
+sub _i_start { if(lc$_[1] eq '[i]') { push @{$_[0]}, 'i'; ('i_start') } else { () } }
+sub _u_start { if(lc$_[1] eq '[u]') { push @{$_[0]}, 'u'; ('u_start') } else { () } }
+sub _s_start { if(lc$_[1] eq '[s]') { push @{$_[0]}, 's'; ('s_start') } else { () } }
sub _spoiler_start { if(lc$_[1] eq '[spoiler]') { push @{$_[0]}, 'spoiler'; ('spoiler_start') } else { () } }
sub _quote_start { if(lc$_[1] eq '[quote]') { push @{$_[0]}, 'quote'; ('quote_start') } else { () } }
sub _code_start { if(lc$_[1] eq '[code]') { push @{$_[0]}, 'code'; ('code_start') } else { () } }
sub _raw_start { if(lc$_[1] eq '[raw]') { push @{$_[0]}, 'raw'; ('raw_start') } else { () } }
+sub _b_end { if(lc$_[1] eq '[/b]') { pop @{$_[0]}; ('b_end' ) } else { () } }
+sub _i_end { if(lc$_[1] eq '[/i]') { pop @{$_[0]}; ('i_end' ) } else { () } }
+sub _u_end { if(lc$_[1] eq '[/u]') { pop @{$_[0]}; ('u_end' ) } else { () } }
+sub _s_end { if(lc$_[1] eq '[/s]') { pop @{$_[0]}; ('s_end' ) } else { () } }
sub _spoiler_end { if(lc$_[1] eq '[/spoiler]') { pop @{$_[0]}; ('spoiler_end') } else { () } }
sub _quote_end { if(lc$_[1] eq '[/quote]' ) { pop @{$_[0]}; ('quote_end' ) } else { () } }
sub _code_end { if(lc$_[1] eq '[/code]' ) { pop @{$_[0]}; ('code_end' ) } else { () } }
@@ -65,10 +78,15 @@ sub _link {
# Permitted actions to take in each state. The actions are run in order, if
# none succeed then the token is passed through as text.
# The "current state" is the most recent tag in the stack, or '' if no tags are open.
+my @INLINE = (\&_link, \&_url_start, \&_raw_start, \&_b_start, \&_i_start, \&_u_start, \&_s_start, \&_spoiler_start);
my %STATE = (
- '' => [ \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start],
- spoiler => [\&_spoiler_end, \&_link, \&_url_start, \&_raw_start],
- quote => [\&_quote_end, \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start],
+ '' => [ @INLINE, \&_quote_start, \&_code_start],
+ b => [\&_b_end, @INLINE],
+ i => [\&_i_end, @INLINE],
+ u => [\&_u_end, @INLINE],
+ s => [\&_s_end, @INLINE],
+ spoiler => [\&_spoiler_end, @INLINE],
+ quote => [\&_quote_end, @INLINE, \&_quote_start, \&_code_start],
code => [\&_code_end ],
url => [\&_url_end, \&_raw_start],
raw => [\&_raw_end ],
@@ -88,6 +106,14 @@ my %STATE = (
#
# Tags:
# text -> literal text, $raw is the text to display
+# b_start -> start bold
+# b_end -> end
+# i_start -> start italic
+# i_end -> end
+# u_start -> start underline
+# u_end -> end
+# s_start -> start strike
+# s_end -> end
# spoiler_start -> start a spoiler
# spoiler_end -> end
# quote_start -> start a quote
@@ -111,11 +137,11 @@ sub parse {
my @stack;
while($raw =~ m{(?:
- \[ \/? (?i: spoiler|quote|code|url|raw ) [^\s\]]* \] | # tag
- d[1-9][0-9]* \# [1-9][0-9]* (?: \.[1-9][0-9]* )? | # d+#+[.+]
- [tdvprcs][1-9][0-9]*\.[1-9][0-9]* | # v+.+
- [tdvprcsugi][1-9][0-9]* | # v+
- (?:https?|ftp)://[^><"\n\s\]\[]+[\d\w=/-] # link
+ \[ \/? (?i: b|i|u|s|spoiler|quote|code|url|raw ) [^\s\]]* \] | # tag
+ d[1-9][0-9]* \# [1-9][0-9]* (?: \.[1-9][0-9]* )? | # d+#+[.+]
+ [tdvprcswgi][1-9][0-9]*\.[1-9][0-9]* | # v+.+
+ [tdvprcsugiw][1-9][0-9]* | # v+
+ (?:https?|ftp)://[^><"\n\s\]\[]+[\d\w=/-] # link
)}xg) {
my $token = $&;
my $pre = substr $raw, $last, $-[0]-$last;
@@ -147,110 +173,111 @@ FINAL:
}
-# charspoil:
-# 0/undef/missing: Output <b class="spoiler">..
-# 1: Output 'charspoil_*' classes
-# 2: Just output 'hidden by spoiler setting' message
-# 3: Just output the spoilers, unmarked
-sub bb2html {
- my($input, $maxlength, $charspoil) = @_;
+# Options:
+# maxlength => 0/$n - truncate after $n visible characters
+# inline => 0/1 - don't insert line breaks and don't format block elements
+#
+# One of:
+# text => 0/1 - format as plain text, no tags
+# onlyids => 0/1 - format as HTML, but only convert VNDBIDs, leave the rest alone (including [spoiler]s)
+# default: format all to HTML.
+#
+# One of:
+# delspoil => 0/1 - delete [spoiler] tags and its contents
+# replacespoil => 0/1 - replace [spoiler] tags with a "hidden by spoiler settings" message
+# keepsoil => 0/1 - keep the contents of spoiler tags without any special formatting
+# default: format as <span class="spoiler">..
+sub bb_format {
+ my($input, %opt) = @_;
+ $opt{delspoil} = 1 if $opt{text} && !$opt{keepspoil};
my $incode = 0;
+ my $inspoil = 0;
my $rmnewline = 0;
my $length = 0;
my $ret = '';
# escapes, returns string, and takes care of $length and $maxlength; also
# takes care to remove newlines and double spaces when necessary
- my $e = sub {
+ my sub e {
local $_ = shift;
s/^\n// if $rmnewline && $rmnewline--;
s/\n{5,}/\n\n/g if !$incode;
s/ +/ /g if !$incode;
$length += length $_;
- if($maxlength && $length > $maxlength) {
- $_ = substr($_, 0, $maxlength-$length);
+ if($opt{maxlength} && $length > $opt{maxlength}) {
+ $_ = substr($_, 0, $opt{maxlength}-$length);
s/\W+\w*$//; # cleanly cut off on word boundary
}
- s/&/&amp;/g;
- s/>/&gt;/g;
- s/</&lt;/g;
- s/\n/<br>/g if !$maxlength;
- s/\n/ /g if $maxlength;
+ if(!$opt{text}) {
+ s/&/&amp;/g;
+ s/>/&gt;/g;
+ s/</&lt;/g;
+ s/\n/<br>/g if !$opt{inline};
+ }
+ s/\n/ /g if $opt{inline};
$_;
};
parse $input, sub {
my($raw, $tag, @arg) = @_;
- #$ret .= "$tag {$raw}\n";
- #return 1;
+ return 1 if $inspoil && $tag ne 'spoiler_end' && ($opt{delspoil} || $opt{replacespoil});
if($tag eq 'text') {
- $ret .= $e->($raw);
-
- } elsif($tag eq 'spoiler_start') {
- $ret .= !$charspoil ? '<b class="spoiler">' :
- $charspoil == 1 ? '<b class="grayedout charspoil charspoil_-1">&lt;hidden by spoiler settings&gt;</b><span class="charspoil charspoil_2">' :
- $charspoil == 2 ? '<b class="grayedout charspoil charspoil_-1">&lt;hidden by spoiler settings&gt;</b><!--' : '';
- } elsif($tag eq 'spoiler_end') {
- $ret .= !$charspoil ? '</b>' :
- $charspoil == 1 ? '</span>' :
- $charspoil == 2 ? '-->' : '';
+ $ret .= e $raw;
+ } elsif($tag eq 'dblink') {
+ (my $link = $raw) =~ s/^d(\d+)\.(\d+)\.(\d+)$/d$1#$2.$3/;
+ $ret .= $opt{text} ? e $raw : sprintf '<a href="/%s">%s</a>', $link, e $raw;
+
+ } elsif($opt{idonly}) {
+ $ret .= e $raw;
+
+ } elsif($tag eq 'b_start') { $ret .= $opt{text} ? e '*' : '<strong>'
+ } elsif($tag eq 'b_end') { $ret .= $opt{text} ? e '*' : '</strong>'
+ } elsif($tag eq 'i_start') { $ret .= $opt{text} ? e '/' : '<em>'
+ } elsif($tag eq 'i_end') { $ret .= $opt{text} ? e '/' : '</em>'
+ } elsif($tag eq 'u_start') { $ret .= $opt{text} ? e '_' : '<span class="underline">'
+ } elsif($tag eq 'u_end') { $ret .= $opt{text} ? e '_' : '</span>'
+ } elsif($tag eq 's_start') { $ret .= $opt{text} ? e '-' : '<s>'
+ } elsif($tag eq 's_end') { $ret .= $opt{text} ? e '-' : '</s>'
} elsif($tag eq 'quote_start') {
- $ret .= '<div class="quote">' if !$maxlength;
+ $ret .= $opt{text} || $opt{inline} ? e '"' : '<div class="quote">';
$rmnewline = 1;
} elsif($tag eq 'quote_end') {
- $ret .= '</div>' if !$maxlength;
+ $ret .= $opt{text} || $opt{inline} ? e '"' : '</div>';
$rmnewline = 1;
} elsif($tag eq 'code_start') {
- $ret .= '<pre>' if !$maxlength;
+ $ret .= $opt{text} || $opt{inline} ? e '`' : '<pre>';
$rmnewline = 1;
$incode = 1;
} elsif($tag eq 'code_end') {
- $ret .= '</pre>' if !$maxlength;
+ $ret .= $opt{text} || $opt{inline} ? e '`' : '</pre>';
$rmnewline = 1;
$incode = 0;
+ } elsif($tag eq 'spoiler_start') {
+ $inspoil = 1;
+ $ret .= $opt{delspoil} || $opt{keepspoil} ? ''
+ : $opt{replacespoil} ? '<small>&lt;hidden by spoiler settings&gt;</small>'
+ : '<span class="spoiler">';
+ } elsif($tag eq 'spoiler_end') {
+ $inspoil = 0;
+ $ret .= $opt{delspoil} || $opt{keepspoil} || $opt{replacespoil} ? '' : '</span>';
+
} elsif($tag eq 'url_start') {
- $ret .= sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]);
+ $ret .= $opt{text} ? '' : sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]);
} elsif($tag eq 'url_end') {
- $ret .= '</a>';
+ $ret .= $opt{text} ? '' : '</a>';
} elsif($tag eq 'link') {
- $ret .= sprintf '<a href="%s" rel="nofollow">%s</a>', xml_escape($raw), $e->('link');
-
- } elsif($tag eq 'dblink') {
- (my $link = $raw) =~ s/^d(\d+)\.(\d+)\.(\d+)$/d$1#$2.$3/;
- $ret .= sprintf '<a href="/%s">%s</a>', $link, $e->($raw);
+ $ret .= $opt{text} ? e $raw : sprintf '<a href="%s" rel="nofollow">%s</a>', xml_escape($raw), e 'link';
}
- !$maxlength || $length < $maxlength;
- };
- $ret;
-}
-
-
-# Convert bbcode into plain text, stripping all tags and spoilers. [url] tags
-# only display the title.
-sub bb2text {
- my $input = shift;
-
- my $inspoil = 0;
- my $ret = '';
- parse $input, sub {
- my($raw, $tag, @arg) = @_;
- if($tag eq 'spoiler_start') {
- $inspoil = 1;
- } elsif($tag eq 'spoiler_end') {
- $inspoil = 0;
- } else {
- $ret .= $raw if !$inspoil && $tag !~ /_(start|end)$/;
- }
- 1;
+ !$opt{maxlength} || $length < $opt{maxlength};
};
$ret;
}
@@ -268,26 +295,15 @@ sub bb_subst_links {
my %lookup;
parse $msg, sub {
my($code, $tag) = @_;
- $lookup{$1}{$2} = 1 if $tag eq 'dblink' && $code =~ /^(.)(\d+)/;
+ $lookup{$1} = 1 if $tag eq 'dblink' && $code =~ /^([vcpgis]\d+)$/;
1;
};
return $msg unless %lookup;
- # Now resolve the links
- state $types = { # Query must return 'id' and 'name' columns, list of IDs will be appended to it.
- v => 'SELECT id, title AS name FROM vn WHERE id IN',
- c => 'SELECT id, name FROM chars WHERE id IN',
- p => 'SELECT id, name FROM producers WHERE id IN',
- g => 'SELECT id, name FROM tags WHERE id IN',
- i => 'SELECT id, name FROM traits WHERE id IN',
- s => 'SELECT s.id, sa.name FROM staff_alias sa JOIN staff s ON s.aid = sa.aid WHERE s.id IN',
- };
- my %links;
- for my $type (keys %$types) {
- next if !$lookup{$type};
- my $lst = $TUWF::OBJ->dbAlli($types->{$type}, [keys %{$lookup{$type}}]);
- $links{$type . $_->{id}} = $_->{name} for @$lst;
- }
+ my $first = 0;
+ my %links = map +($_->{id}, $_->{title}), $TUWF::OBJ->dbAlli(
+ 'SELECT id, title[1+1] FROM (VALUES', (map +($first++ ? ',(' : '(', \"$_", '::vndbid)'), sort keys %lookup), ') n(id), item_info(NULL, n.id, NULL)'
+ )->@*;
return $msg unless %links;
# Now substitute
diff --git a/lib/VNDB/Config.pm b/lib/VNDB/Config.pm
index 11f1822a..050a0124 100644
--- a/lib/VNDB/Config.pm
+++ b/lib/VNDB/Config.pm
@@ -3,13 +3,19 @@ package VNDB::Config;
use strict;
use warnings;
use Exporter 'import';
+use Cwd 'abs_path';
our @EXPORT = ('config');
my $ROOT = $INC{'VNDB/Config.pm'} =~ s{/lib/VNDB/Config\.pm$}{}r;
+my $GEN = abs_path($ENV{VNDB_GEN} // "$ROOT/gen");
+my $VAR = abs_path($ENV{VNDB_VAR} // "$ROOT/var");
# Default config options
my $config = {
- url => 'http://localhost:3000',
+ gen_path => $GEN,
+ var_path => $VAR,
+
+ url => 'http://localhost:3000',
tuwf => {
db_login => [ 'dbi:Pg:dbname=vndb', 'vndb_site', undef ],
@@ -17,55 +23,37 @@ my $config = {
},
skin_default => 'angel',
- placeholder_img => 'http://s.vndb.org/s/angel/bg.jpg', # Used in the og:image meta tag
+ placeholder_img => 'https://s.vndb.org/s/angel-bg.jpg', # Used in the og:image meta tag
scrypt_args => [ 65536, 8, 1 ], # N, r, p
scrypt_salt => 'another-random-string',
form_salt => 'a-private-string-here',
source_url => 'https://code.blicky.net/yorhel/vndb',
admin_email => 'contact@vndb.org',
login_throttle => [ 24*3600/10, 24*3600 ], # interval between attempts, max burst (10 a day)
+ reset_throttle => [ 24*3600/2, 24*3600 ], # interval between attempts, max burst (2 a day)
board_edit_time => 7*24*3600, # Time after which posts become immutable
- poll_options => 20, # max number of options in discussion board polls
-
- engines => [ grep $_, split /\s*\n\s*/, q{
- BGI/Ethornell
- CatSystem2
- codeX RScript
- EntisGLS
- Flash Player
- Ikura GDL
- KiriKiri
- LiveMaker
- Majiro
- NScripter
- QLIE
- RPG Maker
- RealLive
- Ren'Py
- Shiina Rio
- SiglusEngine
- TyranoScript
- Unity
- YU-RIS
- }],
-
- dlsite_url => 'https://www.dlsite.com/%s/work/=/product_id/%%s.html',
- denpa_url => 'https://denpasoft.com/products/%s',
- jlist_url => 'https://www.jlist.com/%s',
- jbox_url => 'https://www.jbox.com/%s',
- mg_r18_url => 'https://www.mangagamer.com/r18/detail.php?product_code=%d',
- mg_main_url => 'https://www.mangagamer.com/detail.php?product_code=%d',
+ graphviz_path => '/usr/bin/dot',
+ imgproc_path => "$GEN/imgproc",
+ trace_log => 0,
+ # Put the site in full read-only mode; Login is disabled and nothing is written to the DB. Handy for migrations.
+ read_only => 0,
+
+ location_db => undef, # Optional path to a libloc database for IP geolocation
+
+ scr_size => [ 136, 102 ], # w*h of screenshot thumbnails
+ ch_size => [ 256, 300 ], # max. w*h of char images
+ cv_size => [ 256, 400 ], # max. w*h of cover images
+
+ api_throttle => [ 60, 5 ], # execution time multiplier, allowed burst
Multi => {
Core => {},
- Feed => {},
Maintenance => {},
- RG => {},
},
};
-my $config_file = do $ROOT.'/data/conf.pl';
+my $config_file = -e "$VAR/conf.pl" ? do("$VAR/conf.pl") || die $! : {};
my $config_merged;
sub config {
@@ -76,10 +64,10 @@ sub config {
$c->{tuwf}{$_} = $config_file->{tuwf}{$_} for keys %{ $config_file->{tuwf} || {} };
$c->{url_static} ||= $c->{url};
- $c->{version} ||= `git -C "$ROOT" describe` =~ /^(.+)\-g[0-9a-f]+$/ && $1;
+ $c->{version} ||= `git -C "$ROOT" describe` =~ s/\-g[0-9a-f]+$//rg =~ s/\r?\n//rg;
$c->{root} = $ROOT;
$c->{Multi}{Core}{log_level} ||= 'debug';
- $c->{Multi}{Core}{log_dir} ||= $ROOT.'/data/log';
+ $c->{Multi}{Core}{log_dir} ||= $VAR.'/log';
$c
};
$config_merged
diff --git a/lib/VNDB/DB/Chars.pm b/lib/VNDB/DB/Chars.pm
deleted file mode 100644
index a93ad28c..00000000
--- a/lib/VNDB/DB/Chars.pm
+++ /dev/null
@@ -1,201 +0,0 @@
-
-package VNDB::DB::Chars;
-
-use strict;
-use warnings;
-use Exporter 'import';
-
-our @EXPORT = qw|dbCharFilters dbCharGet dbCharGetRev dbCharRevisionInsert dbCharImageId|;
-
-
-# Character filters shared by dbCharGet and dbVNGet
-sub dbCharFilters {
- my($self, %o) = @_;
- return (
- defined $o{gender} ? ( 'c.gender IN(!l)' => [ ref $o{gender} ? $o{gender} : [$o{gender}] ]) : (),
- defined $o{bloodt} ? ( 'c.bloodt IN(!l)' => [ ref $o{bloodt} ? $o{bloodt} : [$o{bloodt}] ]) : (),
- defined $o{bust_min} ? ( 'c.s_bust >= ?' => $o{bust_min} ) : (),
- defined $o{bust_max} ? ( 'c.s_bust <= ? AND c.s_bust > 0' => $o{bust_max} ) : (),
- defined $o{waist_min} ? ( 'c.s_waist >= ?' => $o{waist_min} ) : (),
- defined $o{waist_max} ? ( 'c.s_waist <= ? AND c.s_waist > 0' => $o{waist_max} ) : (),
- defined $o{hip_min} ? ( 'c.s_hip >= ?' => $o{hip_min} ) : (),
- defined $o{hip_max} ? ( 'c.s_hip <= ? AND c.s_hip > 0' => $o{hip_max} ) : (),
- defined $o{height_min} ? ( 'c.height >= ?' => $o{height_min} ) : (),
- defined $o{height_max} ? ( 'c.height <= ? AND c.height > 0' => $o{height_max} ) : (),
- defined $o{weight_min} ? ( 'c.weight >= ?' => $o{weight_min} ) : (),
- defined $o{weight_max} ? ( 'c.weight <= ?' => $o{weight_max} ) : (),
- defined $o{cup_min} ? ( 'c.cup_size >= ?' => $o{cup_min} ) : (),
- defined $o{cup_max} ? ( 'c.cup_size <= ?' => $o{cup_max} ) : (),
- $o{role} ? (
- 'EXISTS(SELECT 1 FROM chars_vns cvi WHERE cvi.id = c.id AND cvi.role IN(!l))',
- [ ref $o{role} ? $o{role} : [$o{role}] ] ) : (),
- $o{trait_inc} ? (
- 'c.id IN(SELECT cid FROM traits_chars WHERE tid IN(!l) AND spoil <= ? GROUP BY cid HAVING COUNT(tid) = ?)',
- [ ref $o{trait_inc} ? $o{trait_inc} : [$o{trait_inc}], $o{tagspoil}, ref $o{trait_inc} ? $#{$o{trait_inc}}+1 : 1 ]) : (),
- $o{trait_exc} ? (
- 'c.id NOT IN(SELECT cid FROM traits_chars WHERE tid IN(!l))' => [ ref $o{trait_exc} ? $o{trait_exc} : [$o{trait_exc}] ] ) : (),
- $o{va_inc} ? ( 'c.id IN(SELECT ivs.cid FROM vn_seiyuu ivs JOIN staff_alias isa ON isa.aid = ivs.aid WHERE isa.id IN(!l))' => [ ref $o{va_inc} ? $o{va_inc} : [$o{va_inc}] ] ) : (),
- $o{va_exc} ? ( 'c.id NOT IN(SELECT ivs.cid FROM vn_seiyuu ivs JOIN staff_alias isa ON isa.aid = ivs.aid WHERE isa.id IN(!l))' => [ ref $o{va_exc} ? $o{va_exc} : [$o{va_exc}] ] ) : (),
- )
-}
-
-
-# options: id instance tagspoil trait_inc trait_exc char what results page gender bloodt
-# bust_min bust_max waist_min waist_max hip_min hip_max height_min height_max weight_min weight_max role
-# what: extended traits vns changes
-sub dbCharGet {
- my $self = shift;
- my %o = (
- page => 1,
- results => 10,
- what => '',
- tagspoil => 0,
- @_
- );
-
- $o{search} =~ s/%//g if $o{search};
-
- my %where = (
- !$o{id} ? ( 'c.hidden = FALSE' => 1 ) : (),
- $o{id} ? ( 'c.id IN(!l)' => [ ref $o{id} ? $o{id} : [$o{id}] ] ) : (),
- $o{notid} ? ( 'c.id <> ?' => $o{notid} ) : (),
- $o{instance} ? ( 'c.main = ?' => $o{instance} ) : (),
- $o{vid} ? ( 'c.id IN(SELECT id FROM chars_vns WHERE vid = ?)' => $o{vid} ) : (),
- $o{search} ? (
- "(c.name ILIKE ? OR translate(c.original,' ','') ILIKE translate(?,' ','') OR c.alias ILIKE ?)", [ map '%'.$o{search}.'%', 1..3 ] ) : (),
- $o{char} ? (
- 'LOWER(SUBSTR(c.name, 1, 1)) = ?' => $o{char} ) : (),
- defined $o{char} && !$o{char} ? (
- '(ASCII(c.name) < 97 OR ASCII(c.name) > 122) AND (ASCII(c.name) < 65 OR ASCII(c.name) > 90)' => 1 ) : (),
- $self->dbCharFilters(%o),
- );
-
- my @select = (qw|c.id c.name c.original c.gender|);
- push @select, qw|c.hidden c.locked c.alias c.desc c.image c.b_month c.b_day c.s_bust c.s_waist c.s_hip c.height c.weight c.bloodt c.cup_size c.age c.main c.main_spoil| if $o{what} =~ /extended/;
-
- my($r, $np) = $self->dbPage(\%o, q|
- SELECT !s
- FROM chars c
- !W
- ORDER BY c.name|,
- join(', ', @select), \%where
- );
-
- return _enrich($self, $r, $np, 0, $o{what}, $o{vid});
-}
-
-
-sub dbCharGetRev {
- my $self = shift;
- my %o = (what => '', @_);
-
- $o{rev} ||= $self->dbRow('SELECT MAX(rev) AS rev FROM changes WHERE type = \'c\' AND itemid = ?', $o{id})->{rev};
-
- my $select = 'c.itemid AS id, ch.name, ch.original, ch.gender';
- $select .= ', extract(\'epoch\' from c.added) as added, c.comments, c.rev, c.ihid, c.ilock, '.VNWeb::DB::sql_user();
- $select .= ', c.id AS cid, NOT EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.rev = c.rev+1) AS lastrev';
- $select .= ', ch.alias, ch.desc, ch.image, ch.b_month, ch.b_day, ch.s_bust, ch.s_waist, ch.s_hip, ch.height, ch.weight, ch.bloodt, ch.cup_size, ch.age, ch.main, ch.main_spoil, co.hidden, co.locked' if $o{what} =~ /extended/;
-
- my $r = $self->dbAll(q|
- SELECT !s
- FROM changes c
- JOIN chars co ON co.id = c.itemid
- JOIN chars_hist ch ON ch.chid = c.id
- JOIN users u ON u.id = c.requester
- WHERE c.type = 'c' AND c.itemid = ? AND c.rev = ?|,
- $select, $o{id}, $o{rev}
- );
-
- return _enrich($self, $r, 0, 1, $o{what});
-}
-
-
-sub _enrich {
- my($self, $r, $np, $rev, $what, $vid) = @_;
-
- if(@$r && $what =~ /vns|traits/) {
- my($col, $hist, $colname) = $rev ? ('cid', '_hist', 'chid') : ('id', '', 'id');
- my %r = map {
- $_->{traits} = [];
- $_->{vns} = [];
- ($_->{$col}, $_)
- } @$r;
-
- if($what =~ /traits/) {
- push @{$r{ delete $_->{xid} }{traits}}, $_ for (@{$self->dbAll(qq|
- SELECT ct.$colname AS xid, ct.tid, ct.spoil, t.name, t.sexual, t."group", tg.name AS groupname
- FROM chars_traits$hist ct
- JOIN traits t ON t.id = ct.tid
- JOIN traits tg ON tg.id = t."group"
- WHERE ct.$colname IN(!l)
- ORDER BY tg."order", t.name|, [ keys %r ]
- )});
- }
-
- if($what =~ /vns(?:\((\d+)\))?/) {
- push @{$r{ delete $_->{xid} }{vns}}, $_ for (@{$self->dbAll("
- SELECT cv.$colname AS xid, cv.vid, cv.rid, cv.spoil, cv.role, v.title AS vntitle, r.title AS rtitle
- FROM chars_vns$hist cv
- JOIN vn v ON cv.vid = v.id
- LEFT JOIN releases r ON cv.rid = r.id
- !W
- ORDER BY v.c_released",
- { "cv.$colname IN(!l)" => [[keys %r]], $1 ? ('cv.vid = ?', $1) : () }
- )});
- }
- }
-
- # Depends on the VN revision rather than char revision
- if(@$r && $what =~ /seiyuu/) {
- my %r = map {
- $_->{seiyuu} = [];
- ($_->{id}, $_)
- } @$r;
-
- push @{$r{ delete $_->{cid} }{seiyuu}}, $_ for (@{$self->dbAll(q|
- SELECT vs.cid, s.id AS sid, sa.name, sa.original, vs.note, v.id AS vid, v.title AS vntitle
- FROM vn_seiyuu vs
- JOIN staff_alias sa ON sa.aid = vs.aid
- JOIN staff s ON s.id = sa.id
- JOIN vn v ON v.id = vs.id
- !W
- ORDER BY v.c_released, sa.name|, {
- 's.hidden = FALSE' => 1,
- 'vs.cid IN(!l)' => [[ keys %r ]],
- $vid ? ('v.id = ?' => $vid) : (),
- }
- )});
- }
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Updates the edit_* tables, used from dbItemEdit()
-# Arguments: { columns in chars_rev + traits + vns },
-sub dbCharRevisionInsert {
- my($self, $o) = @_;
-
- my %set = map exists($o->{$_}) ? (qq|"$_" = ?|, $o->{$_}) : (),
- qw|name original alias desc image b_month b_day s_bust s_waist s_hip height weight bloodt cup_size age gender main main_spoil|;
- $self->dbExec('UPDATE edit_chars !H', \%set) if keys %set;
-
- if($o->{traits}) {
- $self->dbExec('DELETE FROM edit_chars_traits');
- $self->dbExec('INSERT INTO edit_chars_traits (tid, spoil) VALUES (?,?)', $_->[0],$_->[1]) for (@{$o->{traits}});
- }
- if($o->{vns}) {
- $self->dbExec('DELETE FROM edit_chars_vns');
- $self->dbExec('INSERT INTO edit_chars_vns (vid, rid, spoil, role) VALUES(!l)', $_) for (@{$o->{vns}});
- }
-}
-
-
-# fetches an ID for a new image
-sub dbCharImageId {
- return shift->dbRow("SELECT nextval('charimg_seq') AS ni")->{ni};
-}
-
-
-1;
-
diff --git a/lib/VNDB/DB/Discussions.pm b/lib/VNDB/DB/Discussions.pm
deleted file mode 100644
index 442f8032..00000000
--- a/lib/VNDB/DB/Discussions.pm
+++ /dev/null
@@ -1,176 +0,0 @@
-
-package VNDB::DB::Discussions;
-
-use strict;
-use warnings;
-use Exporter 'import';
-
-our @EXPORT = qw|dbThreadGet dbPostGet|;
-
-
-# Options: id, type, iid, results, page, what, asuser, notusers, search, sort, reverse
-# What: boards, boardtitles, firstpost, lastpost, poll
-# Sort: id lastpost
-sub dbThreadGet {
- my($self, %o) = @_;
- $o{results} ||= 50;
- $o{page} ||= 1;
- $o{what} ||= '';
-
- my @where = (
- $o{id} ? (
- 't.id = ?' => $o{id}
- ) : (
- 'NOT t.hidden' => 0,
- q{(NOT t.private OR EXISTS(SELECT 1 FROM threads_boards WHERE tid = t.id AND type = 'u' AND iid = ?))} => $o{asuser}
- ),
- $o{type} && !$o{iid} ? (
- 'EXISTS(SELECT 1 FROM threads_boards WHERE tid = t.id AND type IN(!l))' => [ ref $o{type} ? $o{type} : [ $o{type} ] ] ) : (),
- $o{type} && $o{iid} ? (
- 'tb.type = ?' => $o{type}, 'tb.iid = ?' => $o{iid} ) : (),
- $o{notusers} ? (
- 'NOT EXISTS(SELECT 1 FROM threads_boards WHERE type = \'u\' AND tid = t.id)' => 1) : (),
- );
-
- if($o{search}) {
- for (split /[ -,._]/, $o{search}) {
- s/%//g;
- push @where, 't.title ilike ?', "%$_%" if length($_) > 0;
- }
- }
-
- my @select = (
- qw|t.id t.title t.count t.locked t.hidden t.private|, 't.poll_question IS NOT NULL AS haspoll',
- $o{what} =~ /lastpost/ ? (q|EXTRACT('epoch' from tpl.date) AS lastpost_date|, VNWeb::DB::sql_user('ul', 'lastpost_')) : (),
- $o{what} =~ /poll/ ? (qw|t.poll_question t.poll_max_options t.poll_preview t.poll_recast|) : (),
- );
-
- my @join = (
- $o{what} =~ /lastpost/ ? (
- 'JOIN threads_posts tpl ON tpl.tid = t.id AND tpl.num = t.count',
- 'JOIN users ul ON ul.id = tpl.uid'
- ) : (),
- $o{type} && $o{iid} ?
- 'JOIN threads_boards tb ON tb.tid = t.id' : (),
- );
-
- my $order = sprintf {
- id => 't.id %s',
- lastpost => 'tpl.date %s',
- }->{ $o{sort}||'id' }, $o{reverse} ? 'DESC' : 'ASC';
-
- my($r, $np) = $self->dbPage(\%o, q|
- SELECT !s
- FROM threads t
- !s
- !W
- ORDER BY !s|,
- join(', ', @select), join(' ', @join), \@where, $order
- );
-
- if($o{what} =~ /(boards|boardtitles|poll)/ && $#$r >= 0) {
- my %r = map {
- $r->[$_]{boards} = [];
- $r->[$_]{poll_options} = [];
- ($r->[$_]{id}, $_)
- } 0..$#$r;
-
- if($o{what} =~ /boards/) {
- push(@{$r->[$r{$_->{tid}}]{boards}}, [ $_->{type}, $_->{iid} ]) for (@{$self->dbAll(q|
- SELECT tid, type, iid
- FROM threads_boards
- WHERE tid IN(!l)|,
- [ keys %r ]
- )});
- }
-
- if($o{what} =~ /poll/) {
- push(@{$r->[$r{$_->{tid}}]{poll_options}}, [ $_->{id}, $_->{option} ]) for (@{$self->dbAll(q|
- SELECT tid, id, option
- FROM threads_poll_options
- WHERE tid IN(!l)|,
- [ keys %r ]
- )});
- }
-
- if($o{what} =~ /firstpost/) {
- do { my $idx = $r{ delete $_->{tid} }; $r->[$idx] = { $r->[$idx]->%*, %$_ } } for (@{$self->dbAll(q|
- SELECT tpf.tid, EXTRACT('epoch' from tpf.date) AS firstpost_date, !s
- FROM threads_posts tpf
- JOIN users uf ON tpf.uid = uf.id
- WHERE tpf.num = 1 AND tpf.tid IN(!l)|,
- VNWeb::DB::sql_user('uf', 'firstpost_'), [ keys %r ]
- )});
- }
-
- if($o{what} =~ /boardtitles/) {
- push(@{$r->[$r{$_->{tid}}]{boards}}, $_) for (@{$self->dbAll(q|
- SELECT tb.tid, tb.type, tb.iid, COALESCE(u.username, v.title, p.name) AS title, COALESCE(u.username, v.original, p.original) AS original
- FROM threads_boards tb
- LEFT JOIN vn v ON tb.type = 'v' AND v.id = tb.iid
- LEFT JOIN producers p ON tb.type = 'p' AND p.id = tb.iid
- LEFT JOIN users u ON tb.type = 'u' AND u.id = tb.iid
- WHERE tb.tid IN(!l)|,
- [ keys %r ]
- )});
- }
- }
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Options: tid, num, what, uid, mindate, hide, search, type, page, results, sort, reverse
-# what: user thread
-sub dbPostGet {
- my($self, %o) = @_;
- $o{results} ||= 50;
- $o{page} ||= 1;
- $o{what} ||= '';
-
- my %where = (
- $o{tid} ? (
- 'tp.tid = ?' => $o{tid} ) : (),
- $o{num} ? (
- 'tp.num = ?' => $o{num} ) : (),
- $o{uid} ? (
- 'tp.uid = ?' => $o{uid} ) : (),
- $o{mindate} ? (
- 'tp.date > to_timestamp(?)' => $o{mindate} ) : (),
- $o{hide} ? (
- 'tp.hidden = FALSE' => 1 ) : (),
- $o{hide} && $o{what} =~ /thread/ ? (
- 't.hidden = FALSE AND t.private = FALSE' => 1 ) : (),
- $o{type} ? (
- 'tp.tid IN(SELECT tid FROM threads_boards WHERE type IN(!l))' => [ ref $o{type} ? $o{type} : [ $o{type} ] ] ) : (),
- );
-
- my @select = (
- qw|tp.tid tp.num tp.hidden|, q|extract('epoch' from tp.date) as date|, q|extract('epoch' from tp.edited) as edited|,
- $o{search} ? () : 'tp.msg',
- $o{what} =~ /user/ ? (VNWeb::DB::sql_user()) : (),
- $o{what} =~ /thread/ ? ('t.title', 't.hidden AS thread_hidden') : (),
- );
- my @join = (
- $o{what} =~ /user/ ? 'JOIN users u ON u.id = tp.uid' : (),
- $o{what} =~ /thread/ ? 'JOIN threads t ON t.id = tp.tid' : (),
- );
-
- my $order = sprintf {
- num => 'tp.num %s',
- date => 'tp.date %s',
- }->{ $o{sort}||'num' }, $o{reverse} ? 'DESC' : 'ASC';
-
- my($r, $np) = $self->dbPage(\%o, q|
- SELECT !s
- FROM threads_posts tp
- !s
- !W
- ORDER BY !s|,
- join(', ', @select), join(' ', @join), \%where, $order
- );
-
- return wantarray ? ($r, $np) : $r;
-}
-
-1;
diff --git a/lib/VNDB/DB/Misc.pm b/lib/VNDB/DB/Misc.pm
deleted file mode 100644
index cd290d61..00000000
--- a/lib/VNDB/DB/Misc.pm
+++ /dev/null
@@ -1,119 +0,0 @@
-
-package VNDB::DB::Misc;
-
-use strict;
-use warnings;
-use Exporter 'import';
-
-our @EXPORT = qw|
- dbStats dbItemEdit dbRevisionGet dbWikidata
-|;
-
-
-# Returns: hashref, key = section, value = number of (visible) entries
-# Sections: vn, producers, releases, users, threads, posts
-sub dbStats {
- my $s = shift;
- return { map {
- $_->{section} eq 'threads_posts' ? 'posts' : $_->{section}, $_->{count}
- } @{$s->dbAll('SELECT * FROM stats_cache')}};
-}
-
-
-# Inserts a new revision into the database
-# Arguments: type [vrpcsd], itemid, rev, %options->{ editsum uid ihid ilock + db[item]RevisionInsert }
-# rev = changes.rev of the revision this edit is based on, undef to create a new DB item
-# Returns: { itemid, chid, rev }
-sub dbItemEdit {
- my($self, $type, $itemid, $rev, %o) = @_;
-
- $self->dbExec('SELECT edit_!s_init(?, ?)', $type, $itemid, $rev);
- $self->dbExec('UPDATE edit_revision !H', {
- 'requester = ?' => $o{uid}||$self->authInfo->{id},
- 'ip = ?' => $self->reqIP,
- 'comments = ?' => $o{editsum},
- exists($o{ihid}) ? ('ihid = ?' => $o{ihid} ?1:0) : (),
- exists($o{ilock}) ? ('ilock = ?' => $o{ilock}?1:0) : (),
- });
-
- $self->dbVNRevisionInsert( \%o) if $type eq 'v';
- $self->dbProducerRevisionInsert(\%o) if $type eq 'p';
- $self->dbReleaseRevisionInsert( \%o) if $type eq 'r';
- $self->dbCharRevisionInsert( \%o) if $type eq 'c';
-
- return $self->dbRow('SELECT * FROM edit_!s_commit()', $type);
-}
-
-
-# Options: type, itemid, uid, auto, hidden, edit, page, results, releases
-sub dbRevisionGet {
- my($self, %o) = @_;
- $o{results} ||= 10;
- $o{page} ||= 1;
- $o{auto} ||= 0; # 0:show, -1:only, 1:hide
- $o{hidden} ||= 0;
- $o{edit} ||= 0; # 0:both, -1:new, 1:edits
- $o{releases} = 0 if !$o{type} || $o{type} ne 'v' || !$o{itemid};
-
- my %where = (
- $o{releases} ? (
- # This selects all changes of releases that are currently linked to the VN, not release revisions that are linked to the VN.
- # The latter seems more useful, but is also a lot more expensive.
- q{((c.type = 'v' AND c.itemid = ?) OR (c.type = 'r' AND c.itemid = ANY(ARRAY(SELECT rv.id FROM releases_vn rv WHERE rv.vid = ?))))} => [$o{itemid}, $o{itemid}],
- ) : (
- $o{type} ? (
- 'c.type IN(!l)' => [ ref($o{type})?$o{type}:[$o{type}] ] ) : (),
- $o{itemid} ? (
- 'c.itemid = ?' => [ $o{itemid} ] ) : (),
- ),
- $o{uid} ? (
- 'c.requester = ?' => $o{uid} ) : (),
- $o{auto} ? (
- 'c.requester !s 1' => $o{auto} < 0 ? '=' : '<>' ) : (),
- $o{hidden} ? (
- '!s EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.ihid AND'.
- ' c2.rev = (SELECT MAX(c3.rev) FROM changes c3 WHERE c3.type = c.type AND c3.itemid = c.itemid))' => $o{hidden} == 1 ? 'NOT' : '') : (),
- $o{edit} ? (
- 'c.rev !s 1' => $o{edit} < 0 ? '=' : '>' ) : (),
- );
-
- my($r, $np) = $self->dbPage(\%o, q|
- SELECT c.id, c.type, c.itemid, c.comments, c.rev, extract('epoch' from c.added) as added, !s
- FROM changes c
- JOIN users u ON c.requester = u.id
- !W
- ORDER BY c.id DESC|, VNWeb::DB::sql_user(), \%where
- );
-
- # I couldn't find a way to fetch the titles the main query above without slowing it down considerably, so let's just do it this way.
- if(@$r) {
- my %r = map +($_->{id}, $_), @$r;
- my $w = join ' OR ', ('(type = ? AND id = ?)') x @$r;
- my @w = map +($_->{type}, $_->{id}), @$r;
-
- $r{ $_->{id} }{ititle} = $_->{title}, $r{ $_->{id} }{ioriginal} = $_->{original} for(@{$self->dbAll("
- SELECT id, title, original FROM (
- SELECT 'v'::dbentry_type, chid, title, original FROM vn_hist
- UNION ALL SELECT 'r'::dbentry_type, chid, title, original FROM releases_hist
- UNION ALL SELECT 'p'::dbentry_type, chid, name, original FROM producers_hist
- UNION ALL SELECT 'c'::dbentry_type, chid, name, original FROM chars_hist
- UNION ALL SELECT 'd'::dbentry_type, chid, title, '' AS original FROM docs_hist
- UNION ALL SELECT 's'::dbentry_type, sh.chid, name, original FROM staff_hist sh JOIN staff_alias_hist sah ON sah.chid = sh.chid AND sah.aid = sh.aid
- ) x(type, id, title, original)
- WHERE $w
- ", @w
- )});
- }
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Returns a row from wikidata
-sub dbWikidata {
- return $_[0]->dbRow('SELECT * FROM wikidata WHERE id = ?', $_[1]);
-}
-
-
-1;
-
diff --git a/lib/VNDB/DB/Producers.pm b/lib/VNDB/DB/Producers.pm
deleted file mode 100644
index 0caf0ece..00000000
--- a/lib/VNDB/DB/Producers.pm
+++ /dev/null
@@ -1,131 +0,0 @@
-
-package VNDB::DB::Producers;
-
-use strict;
-use warnings;
-use Exporter 'import';
-
-our @EXPORT = qw|dbProducerGet dbProducerGetRev dbProducerRevisionInsert|;
-
-
-# options: results, page, id, search, char, sort, inc_hidden
-# what: extended relations relgraph
-sub dbProducerGet {
- my $self = shift;
- my %o = (
- results => 10,
- page => 1,
- what => '',
- @_
- );
-
- $o{search} =~ s/%//g if $o{search};
-
- my %where = (
- !$o{id} && !$o{inc_hidden} ? (
- 'p.hidden = FALSE' => 1 ) : (),
- $o{id} ? (
- 'p.id IN(!l)' => [ ref $o{id} ? $o{id} : [$o{id}] ] ) : (),
- $o{search} ? (
- '(p.name ILIKE ? OR p.original ILIKE ? OR p.alias ILIKE ?)', [ map '%'.$o{search}.'%', 1..3 ] ) : (),
- $o{char} ? (
- 'LOWER(SUBSTR(p.name, 1, 1)) = ?' => $o{char} ) : (),
- defined $o{char} && !$o{char} ? (
- '(ASCII(p.name) < 97 OR ASCII(p.name) > 122) AND (ASCII(p.name) < 65 OR ASCII(p.name) > 90)' => 1 ) : (),
- );
-
- my $join = $o{what} =~ /relgraph/ ? 'JOIN relgraphs pg ON pg.id = p.rgraph' : '';
-
- my $select = 'p.id, p.type, p.name, p.original, p.lang, p.rgraph';
- $select .= ', p.desc, p.alias, p.website, p.l_wp, p.l_wikidata, p.hidden, p.locked' if $o{what} =~ /extended/;
- $select .= ', pg.svg' if $o{what} =~ /relgraph/;
-
- my($order, @order) = ('p.name');
- if($o{sort} && $o{sort} eq 'search') {
- $order = 'least(substr_score(p.name, ?), substr_score(p.original, ?)), p.name';
- @order = ($o{search}) x 2;
- }
-
- my($r, $np) = $self->dbPage(\%o, qq|
- SELECT !s
- FROM producers p
- !s
- !W
- ORDER BY $order|,
- $select, $join, \%where, @order
- );
-
- return _enrich($self, $r, $np, 0, $o{what});
-}
-
-
-# options: id, rev, what
-# what: extended relations
-sub dbProducerGetRev {
- my $self = shift;
- my %o = (what => '', @_);
-
- $o{rev} ||= $self->dbRow('SELECT MAX(rev) AS rev FROM changes WHERE type = \'p\' AND itemid = ?', $o{id})->{rev};
-
- my $select = 'c.itemid AS id, p.type, p.name, p.original, p.lang, po.rgraph';
- $select .= ', extract(\'epoch\' from c.added) as added, c.comments, c.rev, c.ihid, c.ilock, '.VNWeb::DB::sql_user();
- $select .= ', c.id AS cid, NOT EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.rev = c.rev+1) AS lastrev';
- $select .= ', p.desc, p.alias, p.website, p.l_wp, p.l_wikidata, po.hidden, po.locked' if $o{what} =~ /extended/;
-
- my $r = $self->dbAll(q|
- SELECT !s
- FROM changes c
- JOIN producers po ON po.id = c.itemid
- JOIN producers_hist p ON p.chid = c.id
- JOIN users u ON u.id = c.requester
- WHERE c.type = 'p' AND c.itemid = ? AND c.rev = ?|,
- $select, $o{id}, $o{rev}
- );
-
- return _enrich($self, $r, 0, 1, $o{what});
-}
-
-
-sub _enrich {
- my($self, $r, $np, $rev, $what) = @_;
-
- if(@$r && $what =~ /relations/) {
- my($col, $hist, $colname) = $rev ? ('cid', '_hist', 'chid') : ('id', '', 'id');
- my %r = map {
- $r->[$_]{relations} = [];
- ($r->[$_]{$col}, $_)
- } 0..$#$r;
-
- push @{$r->[$r{$_->{xid}}]{relations}}, $_ for(@{$self->dbAll(qq|
- SELECT rel.$colname AS xid, rel.pid AS id, rel.relation, p.name, p.original
- FROM producers_relations$hist rel
- JOIN producers p ON rel.pid = p.id
- WHERE rel.$colname IN(!l)|,
- [ keys %r ]
- )});
- }
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Updates the edit_* tables, used from dbItemEdit()
-# Arguments: { columns in producers_rev + relations },
-sub dbProducerRevisionInsert {
- my($self, $o) = @_;
-
- my %set = map exists($o->{$_}) ? (qq|"$_" = ?|, $o->{$_}) : (),
- qw|name original website l_wp l_wikidata type lang desc alias|;
- $self->dbExec('UPDATE edit_producers !H', \%set) if keys %set;
-
- if($o->{relations}) {
- $self->dbExec('DELETE FROM edit_producers_relations');
- my $q = join ',', map '(?,?)', @{$o->{relations}};
- my @q = map +($_->[1], $_->[0]), @{$o->{relations}};
- $self->dbExec("INSERT INTO edit_producers_relations (pid, relation) VALUES $q", @q) if @q;
- }
-}
-
-
-1;
-
diff --git a/lib/VNDB/DB/Releases.pm b/lib/VNDB/DB/Releases.pm
deleted file mode 100644
index 9813029d..00000000
--- a/lib/VNDB/DB/Releases.pm
+++ /dev/null
@@ -1,269 +0,0 @@
-
-package VNDB::DB::Releases;
-
-use strict;
-use warnings;
-use POSIX 'strftime';
-use Exporter 'import';
-use VNDB::Func 'gtintype';
-
-our @EXPORT = qw|dbReleaseFilters dbReleaseGet dbReleaseGetRev dbReleaseRevisionInsert dbReleaseEngines|;
-
-
-# Release filters shared by dbReleaseGet and dbVNGet
-sub dbReleaseFilters {
- my($self, %o) = @_;
- $o{plat} = [ $o{plat} ] if $o{plat} && !ref $o{plat};
- $o{med} = [ $o{med} ] if $o{med} && !ref $o{med};
- return (
- defined $o{patch} ? ( 'r.patch = ?' => $o{patch} == 1 ? 1 : 0) : (),
- defined $o{freeware} ? ( 'r.freeware = ?' => $o{freeware} == 1 ? 1 : 0) : (),
- defined $o{uncensored} ? ( 'r.uncensored = ?' => $o{uncensored} == 1 ? 1 : 0) : (),
- defined $o{type} ? ( 'r.type = ?' => $o{type} ) : (),
- defined $o{date_before} ? ( 'r.released <= ?' => $o{date_before} ) : (),
- defined $o{date_after} ? ( 'r.released >= ?' => $o{date_after} ) : (),
- defined $o{minage} ? ( 'r.minage IN(!l)' => [ ref $o{minage} ? $o{minage} : [$o{minage}] ] ) : (),
- defined $o{doujin} ? ( 'NOT r.patch AND r.doujin = ?' => $o{doujin} == 1 ? 1 : 0) : (),
- defined $o{resolution} ? ( 'NOT r.patch AND r.resolution IN(!l)' => [ ref $o{resolution} ? $o{resolution} : [$o{resolution}] ] ) : (),
- defined $o{voiced} ? ( 'NOT r.patch AND r.voiced IN(!l)' => [ ref $o{voiced} ? $o{voiced} : [$o{voiced}] ] ) : (),
- defined $o{ani_story} ? ( 'NOT r.patch AND r.ani_story IN(!l)' => [ ref $o{ani_story} ? $o{ani_story} : [$o{ani_story}] ] ) : (),
- defined $o{ani_ero} ? ( 'NOT r.patch AND r.ani_ero IN(!l)' => [ ref $o{ani_ero} ? $o{ani_ero} : [$o{ani_ero}] ] ) : (),
- defined $o{engine} ? ( 'r.engine = ?' => $o{engine} ) : (),
- defined $o{released} ? ( 'r.released !s ?' => [ $o{released} ? '<=' : '>', strftime('%Y%m%d', gmtime) ] ) : (),
- $o{lang} ? (
- 'r.id IN(SELECT irl.id FROM releases_lang irl WHERE irl.lang IN(!l))' => [ ref $o{lang} ? $o{lang} : [ $o{lang} ] ] ) : (),
- $o{olang} ? (
- 'r.id IN(SELECT irv.id FROM releases_vn irv JOIN vn v ON irv.vid = v.id WHERE v.c_olang && ARRAY[!l]::language[])' => [ ref $o{olang} ? $o{olang} : [ $o{olang} ] ] ) : (),
- $o{plat} ? ('('.join(' OR ',
- grep(/^unk$/, @{$o{plat}}) ? 'NOT EXISTS(SELECT 1 FROM releases_platforms irp WHERE irp.id = r.id)' : (),
- grep(!/^unk$/, @{$o{plat}}) ? 'r.id IN(SELECT irp.id FROM releases_platforms irp WHERE irp.platform IN(!l))' : (),
- ).')', [ [ grep !/^unk$/, @{$o{plat}} ] ]) : (),
- $o{med} ? ('('.join(' OR ',
- grep(/^unk$/, @{$o{med}}) ? 'NOT EXISTS(SELECT 1 FROM releases_media irm WHERE irm.id = r.id)' : (),
- grep(!/^unk$/, @{$o{med}}) ? 'r.id IN(SELECT irm.id FROM releases_media irm WHERE irm.medium IN(!l))' : ()
- ).')', [ [ grep(!/^unk$/, @{$o{med}}) ] ]) : (),
- $o{prod_inc} ? ('r.id IN(SELECT irp.id FROM releases_producers irp WHERE irp.pid IN(!l))' => [ ref $o{prod_inc} ? $o{prod_inc} : [$o{prod_inc}] ]) : (),
- $o{prod_exc} ? ('r.id NOT IN(SELECT irp.id FROM releases_producers irp WHERE irp.pid IN(!l))' => [ ref $o{prod_exc} ? $o{prod_exc} : [$o{prod_exc}] ]) : (),
- );
-}
-
-
-# Options: id vid pid released page results what med sort reverse date_before date_after
-# plat prod_inc prod_exc lang olang type minage search resolution freeware doujin voiced uncensored ani_story ani_ero hidden_only
-# What: extended vn producers platforms media
-# Sort: title released minage
-sub dbReleaseGet {
- my($self, %o) = @_;
- $o{results} ||= 50;
- $o{page} ||= 1;
- $o{what} ||= '';
-
- my @where = (
- !$o{id} && !$o{hidden_only} ? ( 'r.hidden = FALSE' => 0 ) : (),
- $o{hidden_only} ? ('r.hidden = TRUE' => 1) : (),
- $o{id} ? ( 'r.id = ?' => $o{id} ) : (),
- $o{pid} ? ( 'rp.pid = ?' => $o{pid} ) : (),
- $o{vid} ? ( 'r.id IN(SELECT id FROM releases_vn WHERE vid IN(!l))' => [ ref $o{vid} ? $o{vid} : [$o{vid}] ] ) : (),
- $self->dbReleaseFilters(%o),
- );
-
- if($o{search}) {
- for (split /[ -,._]/, $o{search}) {
- s/%//g;
- if(/^\d+$/ && gtintype($_)) {
- push @where, 'r.gtin = ?', $_;
- } elsif(length($_) > 0) {
- $_ = "%$_%";
- push @where, '(r.title ILIKE ? OR r.original ILIKE ? OR r.catalog = ?)',
- [ $_, $_, $_ ];
- }
- }
- }
-
- my @join = (
- $o{pid} ? 'JOIN releases_producers rp ON rp.id = r.id' : (),
- );
-
- my @select = (
- qw|r.id r.title r.original r.website r.released r.minage r.type r.patch|,
- $o{what} =~ /extended/ ? qw|
- r.notes r.catalog r.gtin r.resolution r.voiced r.freeware r.doujin r.uncensored r.ani_story r.ani_ero r.engine r.hidden r.locked
- | : (),
- $o{pid} ? ('rp.developer', 'rp.publisher') : (),
- $o{what} =~ /links/ ? qw|
- r.gtin r.l_steam r.l_gog r.l_gyutto r.l_digiket r.l_melon r.l_getchu r.l_getchudl r.l_dmm r.l_itch r.l_jastusa r.l_egs r.l_erotrail r.l_mg r.l_denpa r.l_jlist r.l_dlsite r.l_dlsiteen
- | : ()
- );
-
- my $order = sprintf {
- title => 'r.title %s, r.released %1$s',
- type => 'r.patch %s, r.type %1$s, r.released %1$s, r.title %1$s',
- publication => 'r.doujin %s, r.freeware %1$s, r.patch %1$s, r.released %1$s, r.title %1$s',
- resolution => 'r.resolution %s, r.patch %2$s, r.released %1$s, r.title %1$s',
- voiced => 'r.voiced %s, r.patch %2$s, r.released %1$s, r.title %1$s',
- ani_ero => 'r.ani_story %s, r.ani_ero %1$s, r.patch %2$s, r.released %1$s, r.title %1$s',
- released => 'r.released %s, r.id %1$s',
- minage => 'r.minage %s, r.released %1$s, r.title %1$s',
- notes => 'r.notes %s, r.released %1$s, r.title %1$s',
- }->{ $o{sort}||'released' }, $o{reverse} ? 'DESC' : 'ASC', !$o{reverse} ? 'DESC' : 'ASC';
-
- my($r, $np) = $self->dbPage(\%o, q|
- SELECT !s
- FROM releases r
- !s
- !W
- ORDER BY !s|,
- join(', ', @select), join(' ', @join), \@where, $order
- );
-
- return _enrich($self, $r, $np, 0, $o{what});
-}
-
-
-# options: id, rev, what
-# what: extended vn producers platforms media
-sub dbReleaseGetRev {
- my $self = shift;
- my %o = (what => '', @_);
-
- $o{rev} ||= $self->dbRow('SELECT MAX(rev) AS rev FROM changes WHERE type = \'r\' AND itemid = ?', $o{id})->{rev};
-
- my $select = 'c.itemid AS id, r.title, r.original, r.website, r.released, r.minage, r.type, r.patch';
- $select .= ', r.notes, r.catalog, r.gtin, r.resolution, r.voiced, r.freeware, r.doujin, r.uncensored, r.ani_story, r.ani_ero, r.engine, ro.hidden, ro.locked' if $o{what} =~ /extended/;
- $select .= ', extract(\'epoch\' from c.added) as added, c.comments, c.rev, c.ihid, c.ilock, '.VNWeb::DB::sql_user();
- $select .= ', c.id AS cid, NOT EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.rev = c.rev+1) AS lastrev';
- $select .= ', r.gtin, r.l_steam, r.l_gog, r.l_gyutto, r.l_digiket, r.l_melon, r.l_getchu, r.l_getchudl, r.l_dmm, r.l_itch, r.l_jastusa, r.l_egs, r.l_erotrail, r.l_mg, r.l_denpa, r.l_jlist, r.l_dlsite, r.l_dlsiteen' if $o{what} =~ /links/;
-
- my $r = $self->dbAll(q|
- SELECT !s
- FROM changes c
- JOIN releases ro ON ro.id = c.itemid
- JOIN releases_hist r ON r.chid = c.id
- JOIN users u ON u.id = c.requester
- WHERE c.type = 'r' AND c.itemid = ? AND c.rev = ?|,
- $select, $o{id}, $o{rev}
- );
-
- return _enrich($self, $r, 0, 1, $o{what});
-}
-
-
-sub _enrich {
- my($self, $r, $np, $rev, $what) = @_;
-
- if(@$r) {
- my($col, $hist, $colname) = $rev ? ('cid', '_hist', 'chid') : ('id', '', 'id');
- my %r = map {
- $r->[$_]{producers} = [];
- $r->[$_]{platforms} = [];
- $r->[$_]{media} = [];
- $r->[$_]{vn} = [];
- $r->[$_]{languages} = [];
- ($r->[$_]{$col}, $_)
- } 0..$#$r;
-
- push(@{$r->[$r{$_->{xid}}]{languages}}, $_->{lang}) for (@{$self->dbAll("
- SELECT $colname AS xid, lang
- FROM releases_lang$hist
- WHERE $colname IN(!l)",
- [ keys %r ]
- )});
-
- if($what =~ /vn/) {
- push(@{$r->[$r{$_->{xid}}]{vn}}, $_) for (@{$self->dbAll("
- SELECT rv.$colname AS xid, v.id AS vid, v.title, v.original
- FROM releases_vn$hist rv
- JOIN vn v ON v.id = rv.vid
- WHERE rv.$colname IN(!l)
- ORDER BY v.title",
- [ keys %r ]
- )});
- }
-
- if($what =~ /producers/) {
- push(@{$r->[$r{$_->{xid}}]{producers}}, $_) for (@{$self->dbAll("
- SELECT rp.$colname AS xid, rp.developer, rp.publisher, p.id, p.name, p.original, p.type
- FROM releases_producers$hist rp
- JOIN producers p ON rp.pid = p.id
- WHERE rp.$colname IN(!l)
- ORDER BY p.name",
- [ keys %r ]
- )});
- }
-
- if($what =~ /platforms/) {
- push(@{$r->[$r{$_->{xid}}]{platforms}}, $_->{platform}) for (@{$self->dbAll("
- SELECT $colname AS xid, platform
- FROM releases_platforms$hist
- WHERE $colname IN(!l)",
- [ keys %r ]
- )});
- }
-
- if($what =~ /media/) {
- push(@{$r->[$r{$_->{xid}}]{media}}, $_) for (@{$self->dbAll("
- SELECT $colname AS xid, medium, qty
- FROM releases_media$hist
- WHERE $colname IN(!l)",
- [ keys %r ]
- )});
- }
- }
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Updates the edit_* tables, used from dbItemEdit()
-# Arguments: { columns in releases_rev + languages + vn + producers + media + platforms }
-sub dbReleaseRevisionInsert {
- my($self, $o) = @_;
-
- my %set = map exists($o->{$_}) ? ("$_ = ?", $o->{$_}) : (),
- qw|title original gtin catalog website released notes minage type
- l_steam l_dlsite l_dlsiteen l_gog l_denpa l_jlist l_digiket l_melon l_mg l_getchu l_getchudl l_itch l_jastusa l_egs l_erotrail
- patch resolution voiced freeware doujin uncensored ani_story ani_ero engine|;
- $set{'l_dmm = ARRAY[!l]::text[]'} = [ $o->{l_dmm} ] if exists $o->{l_dmm};
- $set{'l_gyutto = ARRAY[!l]::integer[]'} = [ $o->{l_gyutto} ] if exists $o->{l_gyutto};
- $self->dbExec('UPDATE edit_releases !H', \%set) if keys %set;
-
- if($o->{languages}) {
- $self->dbExec('DELETE FROM edit_releases_lang');
- my $q = join ',', map '(?)', @{$o->{languages}};
- $self->dbExec("INSERT INTO edit_releases_lang (lang) VALUES $q", @{$o->{languages}}) if @{$o->{languages}};
- }
-
- if($o->{producers}) {
- $self->dbExec('DELETE FROM edit_releases_producers');
- my $q = join ',', map '(?,?,?)', @{$o->{producers}};
- my @q = map +($_->[0], $_->[1]?1:0, $_->[2]?1:0), @{$o->{producers}};
- $self->dbExec("INSERT INTO edit_releases_producers (pid, developer, publisher) VALUES $q", @q) if @q;
- }
-
- if($o->{platforms}) {
- $self->dbExec('DELETE FROM edit_releases_platforms');
- my $q = join ',', map '(?)', @{$o->{platforms}};
- $self->dbExec("INSERT INTO edit_releases_platforms (platform) VALUES $q", @{$o->{platforms}}) if @{$o->{platforms}};
- }
-
- if($o->{vn}) {
- $self->dbExec('DELETE FROM edit_releases_vn');
- my $q = join ',', map '(?)', @{$o->{vn}};
- $self->dbExec("INSERT INTO edit_releases_vn (vid) VALUES $q", @{$o->{vn}}) if @{$o->{vn}};
- }
-
- if($o->{media}) {
- $self->dbExec('DELETE FROM edit_releases_media');
- my $q = join ',', map '(?,?)', @{$o->{media}};
- my @q = map +($_->[0], $_->[1]), @{$o->{media}};
- $self->dbExec("INSERT INTO edit_releases_media (medium, qty) VALUES $q", @q) if @q;
- }
-}
-
-
-sub dbReleaseEngines {
- shift->dbAll(q{SELECT engine, count(*) as cnt FROM releases WHERE engine <> '' GROUP BY engine ORDER BY COUNT(*) desc, engine});
-}
-
-1;
-
diff --git a/lib/VNDB/DB/Staff.pm b/lib/VNDB/DB/Staff.pm
deleted file mode 100644
index 5a393dbb..00000000
--- a/lib/VNDB/DB/Staff.pm
+++ /dev/null
@@ -1,79 +0,0 @@
-
-package VNDB::DB::Staff;
-
-use strict;
-use warnings;
-use Exporter 'import';
-
-our @EXPORT = qw|dbStaffGet |;
-
-# options: results, page, id, aid, search, exact, truename, role, gender
-sub dbStaffGet {
- my $self = shift;
- my %o = (
- results => 10,
- page => 1,
- what => '',
- @_
- );
- my(@roles, $seiyuu);
- if(defined $o{role}) {
- if(ref $o{role}) {
- $seiyuu = grep /^seiyuu$/, @{$o{role}};
- @roles = grep !/^seiyuu$/, @{$o{role}};
- } else {
- $seiyuu = $o{role} eq 'seiyuu';
- @roles = $o{role} unless $seiyuu;
- }
- }
-
- $o{search} =~ s/%//g if $o{search};
-
- my %where = (
- !$o{id} ? ( 's.hidden = FALSE' => 1 ) : (),
- $o{id} ? ( ref $o{id} ? ('s.id IN(!l)' => [$o{id}]) : ('s.id = ?' => $o{id}) ) : (),
- $o{aid} ? ( ref $o{aid} ? ('sa.aid IN(!l)' => [$o{aid}]) : ('sa.aid = ?' => $o{aid}) ) : (),
- $o{id} || $o{truename} ? ( 's.aid = sa.aid' => 1 ) : (),
- defined $o{gender} ? ( 's.gender IN(!l)' => [ ref $o{gender} ? $o{gender} : [$o{gender}] ]) : (),
- defined $o{lang} ? ( 's.lang IN(!l)' => [ ref $o{lang} ? $o{lang} : [$o{lang}] ]) : (),
- defined $o{role} ? (
- '('.join(' OR ',
- @roles ? ( 'EXISTS(SELECT 1 FROM vn_staff vs JOIN vn v ON v.id = vs.id WHERE vs.aid = sa.aid AND vs.role IN(!l) AND NOT v.hidden)' ) : (),
- $seiyuu ? ( 'EXISTS(SELECT 1 FROM vn_seiyuu vsy JOIN vn v ON v.id = vsy.id WHERE vsy.aid = sa.aid AND NOT v.hidden)' ) : ()
- ).')' => ( @roles ? [ \@roles ] : 1 ),
- ) : (),
- $o{exact} ? ( '(lower(sa.name) = lower(?) OR lower(sa.original) = lower(?))' => [ ($o{exact}) x 2 ] ) : (),
- $o{search} ?
- $o{search} =~ /[\x{3000}-\x{9fff}\x{ff00}-\x{ff9f}]/ ?
- # match against 'original' column only if search string contains any
- # japanese character.
- # note: more precise regex would be /[\p{Hiragana}\p{Katakana}\p{Han}]/
- ( q|(sa.original LIKE ? OR translate(sa.original,' ','') LIKE ?)| => [ '%'.$o{search}.'%', ($o{search} =~ s/\s+//gr).'%' ] ) :
- ( '(sa.name ILIKE ? OR sa.original ILIKE ?)' => [ map '%'.$o{search}.'%', 1..2 ] ) : (),
- $o{char} ? ( 'LOWER(SUBSTR(sa.name, 1, 1)) = ?' => $o{char} ) : (),
- defined $o{char} && !$o{char} ?
- ( '(ASCII(sa.name) < 97 OR ASCII(sa.name) > 122) AND (ASCII(sa.name) < 65 OR ASCII(sa.name) > 90)' => 1 ) : (),
- );
-
- my $select = 's.id, sa.aid, sa.name, sa.original, s.gender, s.lang';
-
- my($order, @order) = ('sa.name');
- if($o{sort} && $o{sort} eq 'search') {
- $order = 'least(substr_score(sa.name, ?), substr_score(sa.original, ?)), sa.name';
- @order = ($o{search}) x 2;
- }
-
- my($r, $np) = $self->dbPage(\%o, qq|
- SELECT !s
- FROM staff s
- JOIN staff_alias sa ON sa.id = s.id
- !W
- ORDER BY $order|,
- $select, \%where, @order
- );
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-1;
diff --git a/lib/VNDB/DB/Tags.pm b/lib/VNDB/DB/Tags.pm
deleted file mode 100644
index ed3ea9fe..00000000
--- a/lib/VNDB/DB/Tags.pm
+++ /dev/null
@@ -1,256 +0,0 @@
-
-package VNDB::DB::Tags;
-
-use strict;
-use warnings;
-use Exporter 'import';
-
-our @EXPORT = qw|dbTagGet dbTTTree dbTagEdit dbTagAdd dbTagMerge dbTagLinks dbTagStats dbTagWipeVotes|;
-
-
-# %options->{ id noid name search state searchable applicable page results what sort reverse }
-# what: parents childs(n) aliases addedby
-# sort: id name added items search
-sub dbTagGet {
- my $self = shift;
- my %o = (
- page => 1,
- results => 10,
- what => '',
- @_
- );
-
- $o{search} =~ s/%//g if $o{search};
-
- my %where = (
- $o{id} ? (
- 't.id IN(!l)' => [ ref $o{id} ? $o{id} : [$o{id}] ] ) : (),
- $o{noid} ? (
- 't.id <> ?' => $o{noid} ) : (),
- $o{name} ? (
- 't.id = (SELECT id FROM tags LEFT JOIN tags_aliases ON id = tag WHERE lower(name) = ? OR lower(alias) = ? LIMIT 1)' => [ lc $o{name}, lc $o{name} ]) : (),
- defined $o{state} && $o{state} != -1 ? (
- 't.state = ?' => $o{state} ) : (),
- !defined $o{state} && !$o{id} && !$o{name} ? (
- 't.state <> 1' => 1 ) : (),
- $o{search} ? (
- 't.id IN (SELECT id FROM tags LEFT JOIN tags_aliases ON id = tag WHERE name ILIKE ? OR alias ILIKE ?)' => [ "%$o{search}%", "%$o{search}%" ] ) : (),
- defined $o{searchable} ? ('t.searchable = ?' => $o{searchable}?1:0 ) : (),
- defined $o{applicable} ? ('t.applicable = ?' => $o{applicable}?1:0 ) : (),
- );
- my @select = (
- qw|t.id t.searchable t.applicable t.name t.description t.state t.cat t.c_items t.defaultspoil|,
- q|extract('epoch' from t.added) as added|,
- $o{what} =~ /addedby/ ? (VNWeb::DB::sql_user()) : (),
- );
- my @join = $o{what} =~ /addedby/ ? 'JOIN users u ON u.id = t.addedby' : ();
-
- my $order = sprintf {
- id => 't.id %s',
- name => 't.name %s',
- added => 't.added %s',
- items => 't.c_items %s',
- search=> 'substr_score(t.name, ?) ASC, t.name %s', # Assigning a matching score for aliases is also possible, but more involved
- }->{ $o{sort}||'id' }, $o{reverse} ? 'DESC' : 'ASC';
- my @order = $o{sort} && $o{sort} eq 'search' ? ($o{search}) : ();
-
-
- my($r, $np) = $self->dbPage(\%o, qq|
- SELECT !s
- FROM tags t
- !s
- !W
- ORDER BY $order|,
- join(', ', @select), join(' ', @join), \%where, @order
- );
-
- if(@$r && $o{what} =~ /aliases/) {
- my %r = map {
- $_->{aliases} = [];
- ($_->{id}, $_->{aliases})
- } @$r;
-
- push @{$r{$_->{tag}}}, $_->{alias} for (@{$self->dbAll(q|
- SELECT tag, alias FROM tags_aliases WHERE tag IN(!l)|, [ keys %r ]
- )});
- }
-
- if($o{what} =~ /parents\((\d+)\)/) {
- $_->{parents} = $self->dbTTTree(tag => $_->{id}, $1, 1) for(@$r);
- }
-
- if($o{what} =~ /childs\((\d+)\)/) {
- $_->{childs} = $self->dbTTTree(tag => $_->{id}, $1) for(@$r);
- }
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Walks the tag/trait tree
-# type = tag | trait
-# id = tag to start with, or 0 to start with top-level tags
-# lvl = max. recursion level
-# back = false for parent->child, true for child->parent
-# Returns: [ { id, name, c_items, sub => [ { id, name, c_items, sub => [..] }, .. ] }, .. ]
-sub dbTTTree {
- my($self, $type, $id, $lvl, $back) = @_;
- $lvl ||= 15;
- my $xtra = $type eq 'trait' ? ', "order"' : '';
- my $xtra2 = $type eq 'trait' ? ', t."order"' : '';
- my $r = $self->dbAll(qq|
- WITH RECURSIVE thetree(lvl, id, parent, name, c_items) AS (
- SELECT ?::integer, id, 0, name, c_items$xtra
- FROM ${type}s
- !W
- UNION ALL
- SELECT tt.lvl-1, t.id, tt.id, t.name, t.c_items$xtra2
- FROM thetree tt
- JOIN ${type}s_parents tp ON !s
- JOIN ${type}s t ON !s
- WHERE tt.lvl > 0
- AND t.state = 2
- ) SELECT DISTINCT id, parent, name, c_items$xtra FROM thetree ORDER BY name|, $lvl,
- $id ? {'id = ?' => $id} : {"NOT EXISTS(SELECT 1 FROM ${type}s_parents WHERE $type = id)" => 1, 'state = 2' => 1},
- !$back ? ('tp.parent = tt.id', "t.id = tp.$type") : ("tp.$type = tt.id", 't.id = tp.parent')
- );
-
- my %pars; # parent-id -> [ child-object, .. ]
- push @{$pars{$_->{parent}}}, $_ for(@$r);
- $_->{'sub'} = $pars{$_->{id}} || [] for(@$r);
- my @r = grep !delete($_->{parent}), @$r;
- return $id ? $r[0]{'sub'} : \@r;
-}
-
-
-# args: tag id, %options->{ columns in the tags table + parents + aliases }
-sub dbTagEdit {
- my($self, $id, %o) = @_;
-
- $self->dbExec('UPDATE tags !H WHERE id = ?', {
- $o{upddate} ? ('added = NOW()' => 1) : (),
- map exists($o{$_}) ? ("$_ = ?" => $o{$_}) : (), qw|name searchable applicable description state cat defaultspoil|
- }, $id);
- if($o{aliases}) {
- $self->dbExec('DELETE FROM tags_aliases WHERE tag = ?', $id);
- $self->dbExec('INSERT INTO tags_aliases (tag, alias) VALUES (?, ?)', $id, $_) for (@{$o{aliases}});
- }
- if($o{parents}) {
- $self->dbExec('DELETE FROM tags_parents WHERE tag = ?', $id);
- $self->dbExec('INSERT INTO tags_parents (tag, parent) VALUES (?, ?)', $id, $_) for(@{$o{parents}});
- }
-}
-
-
-# same args as dbTagEdit, without the first tag id
-# returns the id of the new tag
-sub dbTagAdd {
- my($self, %o) = @_;
- my $id = $self->dbRow('INSERT INTO tags (name, searchable, applicable, description, state, cat, defaultspoil, addedby) VALUES (!l, ?) RETURNING id',
- [ map $o{$_}, qw|name searchable applicable description state cat defaultspoil| ], $o{addedby}||$self->authInfo->{id}
- )->{id};
- $self->dbExec('INSERT INTO tags_parents (tag, parent) VALUES (?, ?)', $id, $_) for(@{$o{parents}});
- $self->dbExec('INSERT INTO tags_aliases (tag, alias) VALUES (?, ?)', $id, $_) for (@{$o{aliases}});
- return $id;
-}
-
-
-sub dbTagMerge {
- my($self, $id, @merge) = @_;
- $self->dbExec(q|
- DELETE FROM tags_vn tv
- WHERE tag IN(!l)
- AND EXISTS(SELECT 1 FROM tags_vn ti WHERE ti.tag = ? AND ti.uid = tv.uid AND ti.vid = tv.vid)|, \@merge, $id);
- $self->dbExec('UPDATE tags_vn SET tag = ? WHERE tag IN(!l)', $id, \@merge);
- $self->dbExec('UPDATE tags_aliases SET tag = ? WHERE tag IN(!l)', $id, \@merge);
- $self->dbExec('INSERT INTO tags_aliases (tag, alias) VALUES (?, ?)', $id, $_->{name})
- for (@{$self->dbAll('SELECT name FROM tags WHERE id IN(!l)', \@merge)});
- $self->dbExec('DELETE FROM tags_parents WHERE tag IN(!l)', \@merge);
- $self->dbExec('DELETE FROM tags WHERE id IN(!l)', \@merge);
-}
-
-
-# Directly fetch rows from tags_vn
-# Options: vid uid tag page results what sort reverse
-# What: details
-sub dbTagLinks {
- my($self, %o) = @_;
- $o{results} ||= 999;
- $o{page} ||= 1;
- $o{what} ||= '';
-
- my %where = (
- $o{vid} ? ('tv.vid = ?' => $o{vid}) : (),
- $o{uid} ? ('tv.uid = ?' => $o{uid}) : (),
- $o{tag} ? ('tv.tag = ?' => $o{tag}) : (),
- );
-
- my @select = (
- qw|tv.tag tv.vid tv.uid tv.vote tv.spoiler tv.ignore|, "EXTRACT('epoch' from tv.date) AS date",
- $o{what} =~ /details/ ? (qw|v.title t.name|, VNWeb::DB::sql_user()) : (),
- );
-
- my @join = $o{what} =~ /details/ ? (
- 'JOIN vn v ON v.id = tv.vid',
- 'JOIN users u ON u.id = tv.uid',
- 'JOIN tags t ON t.id = tv.tag'
- ) : ();
-
- my $order = !$o{sort} ? '' : 'ORDER BY '.{
- username => 'u.username',
- date => 'tv.date',
- title => 'v.title',
- tag => 't.name',
- }->{$o{sort}}.($o{reverse} ? ' DESC' : ' ASC');
-
- my($r, $np) = $self->dbPage(\%o,
- 'SELECT !s FROM tags_vn tv !s !W !s',
- join(', ', @select), join(' ', @join), \%where, $order
- );
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Fetch all tags related to a VN
-# Argument: %options->{ vid minrating state results what page sort reverse }
-# sort: name, rating
-sub dbTagStats {
- my($self, %o) = @_;
- $o{results} ||= 10;
- $o{page} ||= 1;
-
- my $rating = 'avg(CASE WHEN tv.ignore THEN NULL ELSE tv.vote END)';
- my $order = sprintf {
- name => 't.name %s',
- rating => "$rating %s",
- }->{ $o{sort}||'name' }, $o{reverse} ? 'DESC' : 'ASC';
-
- my %where = (
- 'tv.vid = ?' => $o{vid},
- defined $o{state} ? ('t.state = ?', $o{state}) : (),
- );
-
- my($r, $np) = $self->dbPage(\%o, qq|
- SELECT t.id, t.name, t.cat, count(*) as cnt, $rating as rating,
- COALESCE(avg(CASE WHEN tv.ignore THEN NULL ELSE tv.spoiler END), t.defaultspoil) as spoiler,
- bool_or(tv.ignore) AS overruled
- FROM tags t
- JOIN tags_vn tv ON tv.tag = t.id
- !W
- GROUP BY t.id, t.name, t.cat
- !s
- ORDER BY !s|,
- \%where, defined $o{minrating} ? "HAVING $rating > $o{minrating}" : '', $order
- );
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Deletes all votes on a tag.
-sub dbTagWipeVotes {
- $_[0]->dbExec('DELETE FROM tags_vn WHERE tag = ?', $_[1])
-}
-
-1;
-
diff --git a/lib/VNDB/DB/Traits.pm b/lib/VNDB/DB/Traits.pm
deleted file mode 100644
index 019f512f..00000000
--- a/lib/VNDB/DB/Traits.pm
+++ /dev/null
@@ -1,113 +0,0 @@
-
-package VNDB::DB::Traits;
-
-# This module is for a large part a copy of VNDB::DB::Tags. I could have chosen
-# to modify that module to work for both traits and tags but that would have
-# complicated the code, so I chose to maintain two versions with similar
-# functionality instead.
-
-use strict;
-use warnings;
-use Exporter 'import';
-
-our @EXPORT = qw|dbTraitGet dbTraitEdit dbTraitAdd|;
-
-
-# Options: id noid search name state searchable applicable what results page sort reverse
-# what: parents childs(n) addedby
-# sort: id name name added items search
-sub dbTraitGet {
- my $self = shift;
- my %o = (
- page => 1,
- results => 10,
- what => '',
- @_,
- );
-
- $o{search} =~ s/%//g if $o{search};
-
- my %where = (
- $o{id} ? ( 't.id IN(!l)' => [ ref($o{id}) ? $o{id} : [$o{id}] ]) : (),
- $o{group} ? ( 't.group = ?' => $o{group} ) : (),
- $o{noid} ? ( 't.id <> ?' => $o{noid} ) : (),
- defined $o{state} && $o{state} != -1 ? (
- 't.state = ?' => $o{state} ) : (),
- !defined $o{state} && !$o{id} && !$o{name} ? (
- 't.state = 2' => 1 ) : (),
- $o{search} ? (
- '(t.name ILIKE ? OR t.alias ILIKE ?)' => [ "%$o{search}%", "%$o{search}%" ] ) : (),
- $o{name} ? ( # TODO: This is terribly ugly, use an aliases table.
- q{(LOWER(t.name) = LOWER(?) OR t.alias ~ ('(!sin)^'||?||'$'))} => [ $o{name}, '?', quotemeta $o{name} ] ) : (),
- defined $o{applicable} ? ('t.applicable = ?' => $o{applicable}?1:0 ) : (),
- defined $o{searchable} ? ('t.searchable = ?' => $o{searchable}?1:0 ) : (),
- );
-
- my @select = (
- qw|t.id t.searchable t.applicable t.name t.description t.state t.alias t."group" t."order" t.sexual t.c_items t.defaultspoil|,
- 'tg.name AS groupname', 'tg."order" AS grouporder', q|extract('epoch' from t.added) as added|,
- $o{what} =~ /addedby/ ? (VNWeb::DB::sql_user()) : (),
- );
- my @join = $o{what} =~ /addedby/ ? 'JOIN users u ON u.id = t.addedby' : ();
- push @join, 'LEFT JOIN traits tg ON tg.id = t."group"';
-
- my $order = sprintf {
- id => 't.id %s',
- name => 't.name %s',
- group => 'tg."order" %s, t.name %1$s',
- added => 't.added %s',
- items => 't.c_items %s',
- search=> 'substr_score(t.name, ?) ASC, t.name %s', # Can't score aliases at the moment
- }->{ $o{sort}||'id' }, $o{reverse} ? 'DESC' : 'ASC';
- my @order = $o{sort} && $o{sort} eq 'search' ? ($o{search}) : ();
-
- my($r, $np) = $self->dbPage(\%o, qq|
- SELECT !s
- FROM traits t
- !s
- !W
- ORDER BY $order|,
- join(', ', @select), join(' ', @join), \%where, @order,
- );
-
- if($o{what} =~ /parents\((\d+)\)/) {
- $_->{parents} = $self->dbTTTree(trait => $_->{id}, $1, 1) for(@$r);
- }
-
- if($o{what} =~ /childs\((\d+)\)/) {
- $_->{childs} = $self->dbTTTree(trait => $_->{id}, $1) for(@$r);
- }
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# args: trait id, %options->{ columns in the traits table + parents }
-sub dbTraitEdit {
- my($self, $id, %o) = @_;
-
- $self->dbExec('UPDATE traits !H WHERE id = ?', {
- $o{upddate} ? ('added = NOW()' => 1) : (),
- map exists($o{$_}) ? ("\"$_\" = ?" => $o{$_}) : (), qw|name searchable applicable description state alias group order sexual defaultspoil|
- }, $id);
- if($o{parents}) {
- $self->dbExec('DELETE FROM traits_parents WHERE trait = ?', $id);
- $self->dbExec('INSERT INTO traits_parents (trait, parent) VALUES (?, ?)', $id, $_) for(@{$o{parents}});
- }
-}
-
-
-# same args as dbTraitEdit, without the first trait id
-# returns the id of the new trait
-sub dbTraitAdd {
- my($self, %o) = @_;
- my $id = $self->dbRow('INSERT INTO traits (name, searchable, applicable, description, state, alias, "group", "order", sexual, defaultspoil, addedby) VALUES (!l, ?) RETURNING id',
- [ map $o{$_}, qw|name searchable applicable description state alias group order sexual defaultspoil| ], $o{addedby}||$self->authInfo->{id}
- )->{id};
- $self->dbExec('INSERT INTO traits_parents (trait, parent) VALUES (?, ?)', $id, $_) for(@{$o{parents}});
- return $id;
-}
-
-
-1;
-
diff --git a/lib/VNDB/DB/ULists.pm b/lib/VNDB/DB/ULists.pm
deleted file mode 100644
index 4c1d10ae..00000000
--- a/lib/VNDB/DB/ULists.pm
+++ /dev/null
@@ -1,77 +0,0 @@
-
-package VNDB::DB::ULists;
-
-use strict;
-use warnings;
-use Exporter 'import';
-
-
-our @EXPORT = qw|
- dbRListGet dbRListAdd dbRListDel
- dbVoteStats
-|;
-
-
-# Options: uid rid
-sub dbRListGet {
- my($self, %o) = @_;
-
- my %where = (
- 'uid = ?' => $o{uid},
- $o{rid} ? ('rid IN(!l)' => [ ref $o{rid} ? $o{rid} : [$o{rid}] ]) : (),
- );
-
- return $self->dbAll(q|
- SELECT uid, rid, status
- FROM rlists
- !W|,
- \%where
- );
-}
-
-
-# Arguments: uid rid status
-# rid can be an arrayref only when the rows are already present, in which case an update is done
-sub dbRListAdd {
- my($self, $uid, $rid, $stat) = @_;
- $self->dbExec(
- 'UPDATE rlists SET status = ? WHERE uid = ? AND rid IN(!l)',
- $stat, $uid, ref($rid) ? $rid : [ $rid ]
- )
- ||
- $self->dbExec(
- 'INSERT INTO rlists (uid, rid, status) VALUES(?, ?, ?)',
- $uid, $rid, $stat
- );
-}
-
-
-# Arguments: uid, rid
-sub dbRListDel {
- my($self, $uid, $rid) = @_;
- $self->dbExec(
- 'DELETE FROM rlists WHERE uid = ? AND rid IN(!l)',
- $uid, ref($rid) ? $rid : [ $rid ]
- );
-}
-
-
-# Arguments: 'vid', id
-# Returns an arrayref with 10 elements containing the [ count(vote), sum(vote) ]
-# for votes in the range of ($index+0.5) .. ($index+1.4)
-sub dbVoteStats {
- my($self, $col, $id, $ign) = @_;
- my $r = [ map [0,0], 0..9 ];
- $r->[$_->{idx}] = [ $_->{votes}, $_->{total} ] for (@{$self->dbAll(q|
- SELECT (vote::numeric/10)::int-1 AS idx, COUNT(vote) as votes, SUM(vote) AS total
- FROM ulist_vns uv
- WHERE uv.vote IS NOT NULL AND NOT EXISTS(SELECT 1 FROM users u WHERE u.id = uv.uid AND u.ign_votes)
- AND uv.vid = ?
- GROUP BY (vote::numeric/10)::int|,
- $id
- )});
- return $r;
-}
-
-1;
-
diff --git a/lib/VNDB/DB/Users.pm b/lib/VNDB/DB/Users.pm
deleted file mode 100644
index 2f7d8e5c..00000000
--- a/lib/VNDB/DB/Users.pm
+++ /dev/null
@@ -1,49 +0,0 @@
-
-package VNDB::DB::Users;
-
-use strict;
-use warnings;
-use Exporter 'import';
-
-our @EXPORT = qw|
- dbUserGet
-|;
-
-
-# %options->{ uid results page what }
-# sort: username registered votes changes tags
-sub dbUserGet {
- my $s = shift;
- my %o = (
- page => 1,
- results => 10,
- what => '',
- @_
- );
-
- my %where = (
- $o{uid} && !ref($o{uid}) ? (
- 'id = ?' => $o{uid} ) : (),
- $o{uid} && ref($o{uid}) ? (
- 'id IN(!l)' => [ $o{uid} ]) : (),
- );
-
- my @select = (
- qw|id username c_votes c_changes c_tags hide_list|,
- VNWeb::DB::sql_user(), # XXX: This duplicates id and username, but updating all the code isn't going to be easy
- q|extract('epoch' from registered) as registered|,
- );
-
- my($r, $np) = $s->dbPage(\%o, q|
- SELECT !s
- FROM users u
- !W
- ORDER BY id DESC|,
- join(', ', @select), \%where
- );
-
- return wantarray ? ($r, $np) : $r;
-}
-
-1;
-
diff --git a/lib/VNDB/DB/VN.pm b/lib/VNDB/DB/VN.pm
deleted file mode 100644
index d099b6ff..00000000
--- a/lib/VNDB/DB/VN.pm
+++ /dev/null
@@ -1,369 +0,0 @@
-
-package VNDB::DB::VN;
-
-use strict;
-use warnings;
-use TUWF 'sqlprint';
-use POSIX 'strftime';
-use Exporter 'import';
-use VNDB::Func 'normalize_query', 'gtintype';
-
-our @EXPORT = qw|dbVNGet dbVNGetRev dbVNRevisionInsert dbVNImageId dbScreenshotAdd dbScreenshotGet dbScreenshotRandom|;
-
-
-# Options: id, char, search, gtin, length, lang, olang, plat, tag_inc, tag_exc, tagspoil,
-# hasani, hasshot, ul_notblack, ul_onwish, results, page, what, sort,
-# reverse, inc_hidden, date_before, date_after, released, release, character
-# What: extended anime staff seiyuu relations screenshots relgraph rating ranking vnlist
-# Note: vnlist is ignored (no db search) unless a user is logged in
-# Sort: id rel pop rating title tagscore rand
-sub dbVNGet {
- my($self, %o) = @_;
- $o{results} ||= 10;
- $o{page} ||= 1;
- $o{what} ||= '';
- $o{sort} ||= 'title';
- $o{tagspoil} //= 2;
-
- # user input that is literally added to the query should be checked...
- die "Invalid input for tagspoil or tag_inc at dbVNGet()\n" if
- grep !defined($_) || $_!~/^\d+$/, $o{tagspoil},
- !$o{tag_inc} ? () : (ref($o{tag_inc}) ? @{$o{tag_inc}} : $o{tag_inc});
-
- my $uid = $self->authInfo->{id};
-
- $o{gtin} = delete $o{search} if $o{search} && $o{search} =~ /^\d+$/ && gtintype(local $_ = $o{search});
-
- my @where = (
- $o{id} ? (
- 'v.id IN(!l)' => [ ref $o{id} ? $o{id} : [$o{id}] ] ) : (),
- $o{char} ? (
- 'LOWER(SUBSTR(v.title, 1, 1)) = ?' => $o{char} ) : (),
- defined $o{char} && !$o{char} ? (
- '(ASCII(v.title) < 97 OR ASCII(v.title) > 122) AND (ASCII(v.title) < 65 OR ASCII(v.title) > 90)' => 1 ) : (),
- defined $o{length} ? (
- 'v.length IN(!l)' => [ ref $o{length} ? $o{length} : [$o{length}] ]) : (),
- $o{lang} ? (
- 'v.c_languages && ARRAY[!l]::language[]' => [ ref $o{lang} ? $o{lang} : [$o{lang}] ]) : (),
- $o{olang} ? (
- 'v.c_olang && ARRAY[!l]::language[]' => [ ref $o{olang} ? $o{olang} : [$o{olang}] ]) : (),
- $o{plat} ? (
- 'v.c_platforms && ARRAY[!l]::platform[]' => [ ref $o{plat} ? $o{plat} : [$o{plat}] ]) : (),
- defined $o{hasani} ? (
- '!sEXISTS(SELECT 1 FROM vn_anime va WHERE va.id = v.id)' => [ $o{hasani} ? '' : 'NOT ' ]) : (),
- defined $o{hasshot} ? (
- '!sEXISTS(SELECT 1 FROM vn_screenshots vs WHERE vs.id = v.id)' => [ $o{hasshot} ? '' : 'NOT ' ]) : (),
- $o{tag_inc} ? (
- 'v.id IN(SELECT vid FROM tags_vn_inherit WHERE tag IN(!l) AND spoiler <= ? GROUP BY vid HAVING COUNT(tag) = ?)',
- [ ref $o{tag_inc} ? $o{tag_inc} : [$o{tag_inc}], $o{tagspoil}, ref $o{tag_inc} ? $#{$o{tag_inc}}+1 : 1 ]) : (),
- $o{tag_exc} ? (
- 'v.id NOT IN(SELECT vid FROM tags_vn_inherit WHERE tag IN(!l))' => [ ref $o{tag_exc} ? $o{tag_exc} : [$o{tag_exc}] ] ) : (),
- $o{search} ? (
- map +('v.c_search like ?', "%$_%"), normalize_query($o{search})) : (),
- $o{gtin} ? (
- 'v.id IN(SELECT irv.vid FROM releases_vn irv JOIN releases ir ON ir.id = irv.id WHERE ir.gtin = ?)' => $o{gtin}) : (),
- $o{staff_inc} ? ( 'v.id IN(SELECT ivs.id FROM vn_staff ivs JOIN staff_alias isa ON isa.aid = ivs.aid WHERE isa.id IN(!l))' => [ ref $o{staff_inc} ? $o{staff_inc} : [$o{staff_inc}] ] ) : (),
- $o{staff_exc} ? ( 'v.id NOT IN(SELECT ivs.id FROM vn_staff ivs JOIN staff_alias isa ON isa.aid = ivs.aid WHERE isa.id IN(!l))' => [ ref $o{staff_exc} ? $o{staff_exc} : [$o{staff_exc}] ] ) : (),
- $uid && $o{ul_notblack} ? (
- 'v.id NOT IN(SELECT vid FROM ulist_vns_labels WHERE uid = ? AND lbl = 6)' => $uid ) : (),
- $uid && defined $o{ul_onwish} ? (
- 'v.id !s IN(SELECT vid FROM ulist_vns_labels WHERE uid = ? AND lbl = 5)' => [ $o{ul_onwish} ? '' : 'NOT', $uid ] ) : (),
- $uid && defined $o{ul_voted} ? (
- 'v.id !s IN(SELECT vid FROM ulist_vns_labels WHERE uid = ? AND lbl = 7)' => [ $o{ul_voted} ? '' : 'NOT', $uid ] ) : (),
- $uid && defined $o{ul_onlist} ? (
- 'v.id !s IN(SELECT vid FROM ulist_vns WHERE uid = ?)' => [ $o{ul_onlist} ? '' : 'NOT', $uid ] ) : (),
- !$o{id} && !$o{inc_hidden} ? (
- 'v.hidden = FALSE' => 0 ) : (),
- # optimize fetching random entries (only when there are no other filters present, otherwise this won't work well)
- $o{sort} eq 'rand' && $o{results} <= 10 && !grep(!/^(?:results|page|what|sort|tagspoil)$/, keys %o) ? (
- 'v.id IN(SELECT floor(random() * last_value)::integer FROM generate_series(1,20), (SELECT MAX(id) AS last_value FROM vn) s1 LIMIT 20)' ) : (),
- defined $o{date_before} ? ( 'v.c_released <= ?' => $o{date_before} ) : (),
- defined $o{date_after} ? ( 'v.c_released >= ?' => $o{date_after} ) : (),
- defined $o{released} ? ( 'v.c_released !s ?' => [ $o{released} ? '<=' : '>', strftime('%Y%m%d', gmtime) ] ) : (),
- );
-
- if($o{release}) {
- my($q, @p) = sqlprint
- 'v.id IN(SELECT rv.vid FROM releases r JOIN releases_vn rv ON rv.id = r.id !W)',
- [ 'NOT r.hidden' => 1, $self->dbReleaseFilters(%{$o{release}}), ];
- push @where, $q, \@p;
- }
- if($o{character}) {
- my($q, @p) = sqlprint
- 'v.id IN(SELECT cv.vid FROM chars c JOIN chars_vns cv ON cv.id = c.id !W)',
- [ 'NOT c.hidden' => 1, $self->dbCharFilters(%{$o{character}}) ];
- push @where, $q, \@p;
- }
-
- my @join = (
- $o{what} =~ /relgraph/ ? 'JOIN relgraphs vg ON vg.id = v.rgraph' : (),
- $uid && $o{what} =~ /vnlist/ ? ("LEFT JOIN (
- SELECT irv.vid, COUNT(*) AS userlist_all,
- SUM(CASE WHEN irl.status = 2 THEN 1 ELSE 0 END) AS userlist_obtained
- FROM rlists irl
- JOIN releases_vn irv ON irv.id = irl.rid
- WHERE irl.uid = $uid
- GROUP BY irv.vid
- ) AS vnlist ON vnlist.vid = v.id") : (),
- );
-
- my $tag_ids = $o{tag_inc} && join ',', ref $o{tag_inc} ? @{$o{tag_inc}} : $o{tag_inc};
- my @select = ( # see https://rt.cpan.org/Ticket/Display.html?id=54224 for the cast on c_languages and c_platforms
- qw|v.id v.locked v.hidden v.c_released v.c_languages::text[] v.c_olang::text[] v.c_platforms::text[] v.title v.original v.rgraph|,
- $o{what} =~ /extended/ ? (
- qw|v.alias v.image v.img_nsfw v.length v.desc v.l_wp v.l_encubed v.l_renai v.l_wikidata| ) : (),
- $o{what} =~ /relgraph/ ? 'vg.svg' : (),
- $o{what} =~ /rating/ ? (qw|v.c_popularity v.c_rating v.c_votecount|) : (),
- $o{what} =~ /ranking/ ? (
- '(SELECT COUNT(*)+1 FROM vn iv WHERE iv.hidden = false AND iv.c_popularity > COALESCE(v.c_popularity, 0.0)) AS p_ranking',
- '(SELECT COUNT(*)+1 FROM vn iv WHERE iv.hidden = false AND iv.c_rating > COALESCE(v.c_rating, 0.0)) AS r_ranking',
- ) : (),
- $uid && $o{what} =~ /vnlist/ ? (qw|vnlist.userlist_all vnlist.userlist_obtained|) : (),
- # TODO: optimize this, as it will be very slow when the selected tags match a lot of VNs (>1000)
- $tag_ids ?
- qq|(SELECT AVG(tvh.rating) FROM tags_vn_inherit tvh WHERE tvh.tag IN($tag_ids) AND tvh.vid = v.id AND spoiler <= $o{tagspoil} GROUP BY tvh.vid) AS tagscore| : (),
- );
-
- no if $] >= 5.022, warnings => 'redundant';
- my $order = sprintf {
- id => 'v.id %s',
- rel => 'v.c_released %s, v.title ASC',
- pop => 'v.c_popularity %s NULLS LAST',
- rating => 'v.c_rating %s NULLS LAST',
- title => 'v.title %s',
- tagscore => 'tagscore %s, v.title ASC',
- rand => 'RANDOM()',
- }->{$o{sort}}, $o{reverse} ? 'DESC' : 'ASC';
-
- my($r, $np) = $self->dbPage(\%o, q|
- SELECT !s
- FROM vn v
- !s
- !W
- ORDER BY !s|,
- join(', ', @select), join(' ', @join), \@where, $order,
- );
-
- return _enrich($self, $r, $np, 0, $o{what});
-}
-
-
-sub dbVNGetRev {
- my $self = shift;
- my %o = (what => '', @_);
-
- $o{rev} ||= $self->dbRow('SELECT MAX(rev) AS rev FROM changes WHERE type = \'v\' AND itemid = ?', $o{id})->{rev};
-
- # XXX: Too much duplication with code in dbVNGet() here. Can we combine some code here?
- my $uid = $self->authInfo->{id};
-
- my $select = 'c.itemid AS id, vo.c_released, vo.c_languages::text[], vo.c_olang::text[], vo.c_platforms::text[], v.title, v.original, vo.rgraph';
- $select .= ', extract(\'epoch\' from c.added) as added, c.comments, c.rev, c.ihid, c.ilock, '.VNWeb::DB::sql_user();
- $select .= ', c.id AS cid, NOT EXISTS(SELECT 1 FROM changes c2 WHERE c2.type = c.type AND c2.itemid = c.itemid AND c2.rev = c.rev+1) AS lastrev';
- $select .= ', v.alias, v.image, v.img_nsfw, v.length, v.desc, v.l_wp, v.l_encubed, v.l_renai, v.l_wikidata, vo.hidden, vo.locked' if $o{what} =~ /extended/;
- $select .= ', vo.c_popularity, vo.c_rating, vo.c_votecount' if $o{what} =~ /rating/;
- $select .= ', (SELECT COUNT(*)+1 FROM vn iv WHERE iv.hidden = false AND iv.c_popularity > COALESCE(vo.c_popularity, 0.0)) AS p_ranking'
- .', (SELECT COUNT(*)+1 FROM vn iv WHERE iv.hidden = false AND iv.c_rating > COALESCE(vo.c_rating, 0.0)) AS r_ranking' if $o{what} =~ /ranking/;
-
- my $r = $self->dbAll(q|
- SELECT !s
- FROM changes c
- JOIN vn vo ON vo.id = c.itemid
- JOIN vn_hist v ON v.chid = c.id
- JOIN users u ON u.id = c.requester
- WHERE c.type = 'v' AND c.itemid = ? AND c.rev = ?|,
- $select, $o{id}, $o{rev}
- );
-
- return _enrich($self, $r, 0, 1, $o{what});
-}
-
-
-sub _enrich {
- my($self, $r, $np, $rev, $what) = @_;
-
- if(@$r && $what =~ /anime|relations|screenshots|staff|seiyuu/) {
- my($col, $hist, $colname) = $rev ? ('cid', '_hist', 'chid') : ('id', '', 'id');
- my %r = map {
- $r->[$_]{anime} = [];
- $r->[$_]{credits} = [];
- $r->[$_]{seiyuu} = [];
- $r->[$_]{relations} = [];
- $r->[$_]{screenshots} = [];
- ($r->[$_]{$col}, $_)
- } 0..$#$r;
-
- if($what =~ /staff/) {
- push(@{$r->[$r{ delete $_->{xid} }]{credits}}, $_) for (@{$self->dbAll("
- SELECT vs.$colname AS xid, s.id, vs.aid, sa.name, sa.original, s.gender, s.lang, vs.role, vs.note
- FROM vn_staff$hist vs
- JOIN staff_alias sa ON vs.aid = sa.aid
- JOIN staff s ON s.id = sa.id
- WHERE vs.$colname IN(!l)
- ORDER BY vs.role ASC, sa.name ASC",
- [ keys %r ]
- )});
- }
-
- if($what =~ /seiyuu/) {
- # The seiyuu query needs the VN id to get the VN<->Char spoiler level.
- # Obtaining this ID is different when using the hist table.
- my($vid, $join) = $rev ? ('h.itemid', 'JOIN changes h ON h.id = vs.chid') : ('vs.id', '');
- push(@{$r->[$r{ delete $_->{xid} }]{seiyuu}}, $_) for (@{$self->dbAll("
- SELECT vs.$colname AS xid, s.id, vs.aid, sa.name, sa.original, s.gender, s.lang, c.id AS cid, c.name AS cname, vs.note,
- (SELECT MAX(spoil) FROM chars_vns cv WHERE cv.vid = $vid AND cv.id = c.id) AS spoil
- FROM vn_seiyuu$hist vs
- JOIN staff_alias sa ON vs.aid = sa.aid
- JOIN staff s ON s.id = sa.id
- JOIN chars c ON c.id = vs.cid
- $join
- WHERE vs.$colname IN(!l)
- ORDER BY c.name",
- [ keys %r ]
- )});
- }
-
- if($what =~ /anime/) {
- push(@{$r->[$r{ delete $_->{xid} }]{anime}}, $_) for (@{$self->dbAll("
- SELECT va.$colname AS xid, a.id, a.year, a.ann_id, a.nfo_id, a.type, a.title_romaji, a.title_kanji, extract('epoch' from a.lastfetch) AS lastfetch
- FROM vn_anime$hist va
- JOIN anime a ON va.aid = a.id
- WHERE va.$colname IN(!l)",
- [ keys %r ]
- )});
- }
-
- if($what =~ /relations/) {
- push(@{$r->[$r{ delete $_->{xid} }]{relations}}, $_) for(@{$self->dbAll("
- SELECT rel.$colname AS xid, rel.vid AS id, rel.relation, rel.official, v.title, v.original
- FROM vn_relations$hist rel
- JOIN vn v ON rel.vid = v.id
- WHERE rel.$colname IN(!l)",
- [ keys %r ]
- )});
- }
-
- if($what =~ /screenshots/) {
- push(@{$r->[$r{ delete $_->{xid} }]{screenshots}}, $_) for (@{$self->dbAll("
- SELECT vs.$colname AS xid, s.id, vs.nsfw, vs.rid, s.width, s.height
- FROM vn_screenshots$hist vs
- JOIN screenshots s ON vs.scr = s.id
- WHERE vs.$colname IN(!l)
- ORDER BY vs.scr",
- [ keys %r ]
- )});
- }
- }
-
- VNWeb::DB::enrich_flatten(vnlist_labels => id => vid => sub { VNWeb::DB::sql('
- SELECT uvl.vid, ul.label
- FROM ulist_vns_labels uvl
- JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl
- WHERE uvl.uid =', \$self->authInfo->{id}, 'AND uvl.vid IN', $_[0], '
- ORDER BY CASE WHEN ul.id < 10 THEN ul.id ELSE 10 END, ul.label'
- )}, $r) if $what =~ /vnlist/ && $self->authInfo->{id};
-
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Updates the edit_* tables, used from dbItemEdit()
-# Arguments: { columns in producers_rev + anime + relations + screenshots }
-# screenshots = [ [ scrid, nsfw, rid ], .. ]
-# relations = [ [ rel, vid ], .. ]
-# anime = [ aid, .. ]
-sub dbVNRevisionInsert {
- my($self, $o) = @_;
-
- $o->{img_nsfw} = $o->{img_nsfw}?1:0 if exists $o->{img_nsfw};
- my %set = map exists($o->{$_}) ? (qq|"$_" = ?| => $o->{$_}) : (),
- qw|title original desc alias image img_nsfw length l_wp l_encubed l_renai l_wikidata|;
- $self->dbExec('UPDATE edit_vn !H', \%set) if keys %set;
-
- if($o->{screenshots}) {
- $self->dbExec('DELETE FROM edit_vn_screenshots');
- my $q = join ',', map '(?, ?, ?)', @{$o->{screenshots}};
- my @val = map +($_->{id}, $_->{nsfw}?1:0, $_->{rid}), @{$o->{screenshots}};
- $self->dbExec("INSERT INTO edit_vn_screenshots (scr, nsfw, rid) VALUES $q", @val) if @val;
- }
-
- if($o->{relations}) {
- $self->dbExec('DELETE FROM edit_vn_relations');
- my $q = join ',', map '(?, ?, ?)', @{$o->{relations}};
- my @val = map +($_->[1], $_->[0], $_->[2]?1:0), @{$o->{relations}};
- $self->dbExec("INSERT INTO edit_vn_relations (vid, relation, official) VALUES $q", @val) if @val;
- }
-
- if($o->{anime}) {
- $self->dbExec('DELETE FROM edit_vn_anime');
- my $q = join ',', map '(?)', @{$o->{anime}};
- $self->dbExec("INSERT INTO edit_vn_anime (aid) VALUES $q", @{$o->{anime}}) if @{$o->{anime}};
- }
-
- if($o->{credits}) {
- $self->dbExec('DELETE FROM edit_vn_staff');
- my $q = join ',', ('(?, ?, ?)') x @{$o->{credits}};
- my @val = map +($_->{aid}, $_->{role}, $_->{note}), @{$o->{credits}};
- $self->dbExec("INSERT INTO edit_vn_staff (aid, role, note) VALUES $q", @val) if @val;
- }
-
- if($o->{seiyuu}) {
- $self->dbExec('DELETE FROM edit_vn_seiyuu');
- my $q = join ',', ('(?, ?, ?)') x @{$o->{seiyuu}};
- my @val = map +($_->{aid}, $_->{cid}, $_->{note}), @{$o->{seiyuu}};
- $self->dbExec("INSERT INTO edit_vn_seiyuu (aid, cid, note) VALUES $q", @val) if @val;
- }
-}
-
-
-# fetches an ID for a new image
-sub dbVNImageId {
- return shift->dbRow("SELECT nextval('covers_seq') AS ni")->{ni};
-}
-
-
-# insert a new screenshot and return it's ID
-sub dbScreenshotAdd {
- my($s, $width, $height) = @_;
- return $s->dbRow(q|INSERT INTO screenshots (width, height) VALUES (?, ?) RETURNING id|, $width, $height)->{id};
-}
-
-
-# arrayref of screenshot IDs as argument
-sub dbScreenshotGet {
- return shift->dbAll(q|SELECT * FROM screenshots WHERE id IN(!l)|, shift);
-}
-
-
-# Fetch random VN + screenshots
-# if any arguments are given, it will return one random screenshot for each VN
-sub dbScreenshotRandom {
- my($self, @vids) = @_;
- return $self->dbAll(q|
- SELECT s.id AS scr, s.width, s.height, v.id AS vid, v.title
- FROM screenshots s
- JOIN vn_screenshots vs ON vs.scr = s.id
- JOIN vn v ON v.id = vs.id
- WHERE NOT v.hidden AND NOT vs.nsfw
- AND s.id IN(
- SELECT floor(random() * last_value)::integer
- FROM generate_series(1,20), (SELECT MAX(id) AS last_value FROM screenshots) s1
- LIMIT 20
- )
- LIMIT 4|
- ) if !@vids;
- # this query is faster than it looks
- return $self->dbAll(join(' UNION ALL ', map
- q|SELECT s.id AS scr, s.width, s.height, v.id AS vid, v.title, RANDOM() AS position
- FROM (
- SELECT vs2.id, vs2.scr FROM vn_screenshots vs2
- WHERE vs2.id = ? AND NOT vs2.nsfw
- ORDER BY RANDOM() LIMIT 1
- ) vs
- JOIN vn v ON v.id = vs.id
- JOIN screenshots s ON s.id = vs.scr
- |, @vids).' ORDER BY position', @vids);
-}
-
-
-1;
diff --git a/lib/VNDB/ExtLinks.pm b/lib/VNDB/ExtLinks.pm
index 332351c1..7d22ec32 100644
--- a/lib/VNDB/ExtLinks.pm
+++ b/lib/VNDB/ExtLinks.pm
@@ -3,9 +3,15 @@ package VNDB::ExtLinks;
use v5.26;
use warnings;
use VNDB::Config;
+use VNDB::Schema;
use Exporter 'import';
-our @EXPORT = ('enrich_extlinks', 'revision_extlinks');
+our @EXPORT = qw/
+ sql_extlinks
+ enrich_extlinks
+ revision_extlinks
+ validate_extlinks
+/;
# column name in wikidata table => \%info
@@ -39,21 +45,35 @@ our %WIKIDATA = (
crunchyroll => { type => 'text[]', property => 'P4110', label => undef, fmt => undef },
igdb_game => { type => 'text[]', property => 'P5794', label => 'IGDB', fmt => 'https://www.igdb.com/games/%s' },
giantbomb => { type => 'text[]', property => 'P5247', label => undef, fmt => undef },
- pcgamingwiki => { type => 'text[]', property => 'P6337', label => undef, fmt => undef },
+ pcgamingwiki => { type => 'text[]', property => 'P6337', label => 'PCGamingWiki', fmt => 'https://www.pcgamingwiki.com/wiki/%s' },
steam => { type => 'integer[]', property => 'P1733', label => undef, fmt => undef },
gog => { type => 'text[]', property => 'P2725', label => 'GOG', fmt => 'https://www.gog.com/game/%s' },
pixiv_user => { type => 'integer[]', property => 'P5435', label => 'Pixiv', fmt => 'https://www.pixiv.net/member.php?id=%d' },
doujinshi_author => { type => 'integer[]', property => 'P7511', label => 'Doujinshi.org', fmt => 'https://www.doujinshi.org/browse/author/%d/' },
+ soundcloud => { type => 'text[]', property => 'P3040', label => 'Soundcloud', fmt => 'https://soundcloud.com/%s' },
+ humblestore => { type => 'text[]', property => 'P4477', label => undef, fmt => undef },
+ itchio => { type => 'text[]', property => 'P7294', label => undef, fmt => undef },
+ playstation_jp => { type => 'text[]', property => 'P5999', label => undef, fmt => undef },
+ playstation_na => { type => 'text[]', property => 'P5944', label => undef, fmt => undef },
+ playstation_eu => { type => 'text[]', property => 'P5971', label => undef, fmt => undef },
+ lutris => { type => 'text[]', property => 'P7597', label => 'Lutris', fmt => 'https://lutris.net/games/%s' },
+ wine => { type => 'integer[]', property => 'P600', label => 'Wine AppDB', fmt => 'https://appdb.winehq.org/appview.php?iAppId=%d' },
);
# dbentry_type => column name => \%info
+# Column names are also used for AdvSearch filters, so they should be stable.
# info keys:
# label Name of the link
# fmt How to generate a url (basic version, printf-style only)
# fmt2 How to generate a better url
# (printf-style string or subroutine, given a hashref of the DB entry and returning a new 'fmt' string)
# ("better" meaning proper store section, affiliate link)
+# regex Regex to detect a URL and extract the database value (the first non-empty placeholder).
+# Excludes a leading qr{^https?://} match and is anchored on both sites, see full_regex() below.
+# (A valid DB value must survive a 'fmt' -> 'regex' round trip)
+# (Only set for links that should be autodetected in the edit form)
+# patt Human-readable URL pattern that corresponds to 'fmt' and 'regex'; Automatically derived from 'fmt' if not set.
our %LINKS = (
v => {
l_renai => { label => 'Renai.us', fmt => 'https://renai.us/game/%s' },
@@ -64,33 +84,175 @@ our %LINKS = (
},
r => {
website => { label => 'Official website', fmt => '%s' },
- l_egs => { label => 'ErogameScape', fmt => 'https://erogamescape.dyndns.org/~ap2/ero/toukei_kaiseki/game.php?game=%d' },
- l_erotrail => { label => 'ErogeTrailers', fmt => 'http://erogetrailers.com/soft/%d' },
- l_steam => { label => 'Steam', fmt => 'https://store.steampowered.com/app/%d/' },
- l_dlsite => { label => 'DLsite (jpn)', fmt => 'https://www.dlsite.com/home/work/=/product_id/%s.html'
- , fmt2 => sub { sprintf config->{dlsite_url}, shift->{l_dlsite_shop}||'home' } },
- l_dlsiteen => { label => 'DLsite (eng)', fmt => 'https://www.dlsite.com/home/eng/=/product_id/%s.html'
- , fmt2 => sub { sprintf config->{dlsite_url}, shift->{l_dlsiteen_shop}||'eng' } },
- l_gog => { label => 'GOG', fmt => 'https://www.gog.com/game/%s' },
- l_itch => { label => 'Itch.io', fmt => 'https://%s' },
- l_denpa => { label => 'Denpasoft', fmt => 'https://denpasoft.com/products/%s', fmt2 => config->{denpa_url} },
- l_jlist => { label => 'J-List', fmt => 'https://www.jlist.com/%s', fmt2 => sub { config->{ shift->{l_jlist_jbox} ? 'jbox_url' : 'jlist_url' } } },
- l_jastusa => { label => 'JAST USA', fmt => 'https://jastusa.com/%s' },
- l_gyutto => { label => 'Gyutto', fmt => 'https://gyutto.com/i/item%d' },
- l_digiket => { label => 'Digiket', fmt => 'https://www.digiket.com/work/show/_data/ID=ITM%07d/' },
- l_melon => { label => 'Melonbooks', fmt => 'https://www.melonbooks.com/index.php?main_page=product_info&products_id=IT%010d' },
- l_mg => { label => 'MangaGamer', fmt => 'https://www.mangagamer.com/r18/detail.php?product_code=%d'
- , fmt2 => sub { config->{ !defined($_[0]{l_mg_r18}) || $_[0]{l_mg_r18} ? 'mg_r18_url' : 'mg_main_url' } } },
- l_getchu => { label => 'Getchu', fmt => 'http://www.getchu.com/soft.phtml?id=%d' },
- l_getchudl => { label => 'DL.Getchu', fmt => 'http://dl.getchu.com/i/item%d' },
- l_dmm => { label => 'DMM', fmt => 'https://%s' },
+ l_egs => { label => 'ErogameScape'
+ , fmt => 'https://erogamescape.dyndns.org/~ap2/ero/toukei_kaiseki/game.php?game=%d'
+ , regex => qr{erogamescape\.dyndns\.org/~ap2/ero/toukei_kaiseki/(?:before_)?game\.php\?(?:.*&)?game=([0-9]+)(?:&.*)?} },
+ l_steam => { label => 'Steam'
+ , fmt => 'https://store.steampowered.com/app/%d/'
+ , fmt2 => 'https://store.steampowered.com/app/%d/?utm_source=vndb'
+ , regex => qr{(?:www\.)?(?:store\.steampowered\.com/app/([0-9]+)(?:/.*)?|steamcommunity\.com/(?:app|games)/([0-9]+)(?:/.*)?|steamdb\.info/app/([0-9]+)(?:/.*)?)} },
+ l_dlsite => { label => 'DLsite'
+ , fmt => 'https://www.dlsite.com/home/work/=/product_id/%s.html'
+ , fmt2 => sub { config->{dlsite_url} && sprintf config->{dlsite_url}, shift->{l_dlsite_shop}||'home' }
+ , regex => qr{(?:www\.)?dlsite\.com/.*/(?:dlaf/=/link/work/aid/.*/id|work/=/product_id)/([VR]J[0-9]{6,8}).*}
+ , patt => 'https://www.dlsite.com/<store>/work/=/product_id/<VJ or RJ-code>' },
+ l_gog => { label => 'GOG'
+ , fmt => 'https://www.gog.com/game/%s'
+ , regex => qr{(?:www\.)?gog\.com/(?:[a-z]{2}/)?game/([a-z0-9_]+).*} },
+ l_itch => { label => 'Itch.io'
+ , fmt => 'https://%s'
+ , regex => qr{([a-z0-9_-]+\.itch\.io/[a-z0-9_-]+)}
+ , patt => 'https://<artist>.itch.io/<product>' },
+ l_patreonp => { label => 'Patreon post'
+ , fmt => 'https://www.patreon.com/posts/%d'
+ , regex => qr{(?:www\.)?patreon\.com/posts/(?:[^/?]+-)?([0-9]+).*} },
+ l_patreon => { label => 'Patreon'
+ , fmt => 'https://www.patreon.com/%s'
+ , regex => qr{(?:www\.)?patreon\.com/(?!user[\?/]|posts[\?/]|join[\?/])([^/?]+).*} },
+ l_substar => { label => 'SubscribeStar'
+ , fmt => 'https://subscribestar.%s'
+ , regex => qr{(?:www\.)?subscribestar\.((?:adult|com)/[^/?]+).*}
+ , patt => 'https://subscribestar.<adult or com>/<name>' },
+ l_denpa => { label => 'Denpasoft'
+ , fmt => 'https://denpasoft.com/product/%s/'
+ , fmt2 => config->{denpa_url}
+ , regex => qr{(?:www\.)?denpasoft\.com/products?/([^/&#?:]+).*} },
+ l_jlist => { label => 'J-List'
+ , fmt => 'https://www.jlist.com/shop/product/%s'
+ , fmt2 => config->{jlist_url},
+ , regex => qr{(?:www\.)?(?:jlist|jbox)\.com/shop/product/([^/#?]+).*} },
+ l_jastusa => { label => 'JAST USA'
+ , fmt => 'https://jastusa.com/games/%s/vndb'
+ , fmt2 => sub { config->{jastusa_url} && sprintf config->{jastusa_url}, shift->{l_jast_slug}||'vndb' },
+ , regex => qr{(?:www\.)?jastusa\.com/games/([a-z0-9_-]+)/[^/]+}
+ , patt => 'https://jastusa.com/games/<code>/<title>' },
+ l_fakku => { label => 'Fakku'
+ , fmt => 'https://www.fakku.net/games/%s'
+ , regex => qr{(?:www\.)?fakku\.(?:net|com)/games/([^/]+)(?:[/\?].*)?} },
+ l_googplay => { label => 'Google Play'
+ , fmt => 'https://play.google.com/store/apps/details?id=%s'
+ , regex => qr{play\.google\.com/store/apps/details\?id=([^/&\?]+)(?:&.*)?} },
+ l_appstore => { label => 'App Store'
+ , fmt => 'https://apps.apple.com/app/id%d'
+ , regex => qr{(?:itunes|apps)\.apple\.com/(?:[^/]+/)?app/(?:[^/]+/)?id([0-9]+)([/\?].*)?} },
+ l_animateg => { label => 'Animate Games'
+ , fmt => 'https://www.animategames.jp/home/detail/%d'
+ , regex => qr{(?:www\.)?animategames\.jp/home/detail/([0-9]+)} },
+ l_freem => { label => 'Freem!'
+ , fmt => 'https://www.freem.ne.jp/win/game/%d'
+ , regex => qr{(?:www\.)?freem\.ne\.jp/win/game/([0-9]+)} },
+ l_freegame => { label => 'Freegame Mugen'
+ , fmt => 'https://freegame-mugen.jp/%s.html'
+ , regex => qr{(?:www\.)?freegame-mugen\.jp/([^/]+/game_[0-9]+)\.html}
+ , patt => 'https://freegame-mugen.jp/<genre>/game_<id>.html' },
+ l_novelgam => { label => 'NovelGame'
+ , fmt => 'https://novelgame.jp/games/show/%d'
+ , regex => qr{(?:www\.)?novelgame\.jp/games/show/([0-9]+)} },
+ l_gyutto => { label => 'Gyutto'
+ , fmt => 'https://gyutto.com/i/item%d'
+ , regex => qr{(?:www\.)?gyutto\.(?:com|jp|me)/(?:.+\/)?i/item([0-9]+).*} },
+ l_digiket => { label => 'Digiket'
+ , fmt => 'https://www.digiket.com/work/show/_data/ID=ITM%07d/'
+ , regex => qr{(?:www\.)?digiket\.com/.*ITM([0-9]{7}).*} },
+ l_melon => { label => 'Melonbooks.com'
+ , fmt => 'https://www.melonbooks.com/index.php?main_page=product_info&products_id=IT%010d'
+ , regex => qr{(?:www\.)?melonbooks\.com/.*products_id=IT([0-9]{10}).*} },
+ l_melonjp => { label => 'Melonbooks.co.jp'
+ , fmt => 'https://www.melonbooks.co.jp/detail/detail.php?product_id=%d',
+ , regex => qr{(?:www\.)?melonbooks\.co\.jp/detail/detail\.php\?product_id=([0-9]+)(&:?.*)?} },
+ l_mg => { label => 'MangaGamer'
+ , fmt => 'https://www.mangagamer.com/r18/detail.php?product_code=%d'
+ , fmt2 => sub { config->{ !defined($_[0]{l_mg_r18}) || $_[0]{l_mg_r18} ? 'mg_r18_url' : 'mg_main_url' } }
+ , regex => qr{(?:www\.)?mangagamer\.com/.*product_code=([0-9]+).*} },
+ l_getchu => { label => 'Getchu'
+ , fmt => 'http://www.getchu.com/soft.phtml?id=%d'
+ , regex => qr{(?:www\.)?getchu\.com/soft\.phtml\?id=([0-9]+).*} },
+ l_getchudl => { label => 'DL.Getchu'
+ , fmt => 'http://dl.getchu.com/i/item%d'
+ , regex => qr{(?:dl|order)\.getchu\.com/(?:i/item|(?:r|index).php.*[?&]gcd=D?0*)([0-9]+).*} },
+ l_dmm => { label => 'DMM'
+ , fmt => 'https://%s'
+ , regex => qr{((?:www\.|dlsoft\.)?dmm\.(?:com|co\.jp)/[^\s?]+)(?:\?.*)?}
+ , patt => 'https://<any link to dmm.com or dmm.co.jp>' },
+ l_toranoana=> { label => 'Toranoana'
+ # ec.* is for 18+, ecs.toranoana.jp is for non-18+.
+ # ec.toranoana.shop will redirect to ecs.* as appropriate for the product ID, but ec.toranoana.jp won't.
+ , fmt => 'https://ec.toranoana.shop/tora/ec/item/%012d/'
+ , regex => qr{(?:www\.)?ecs?\.toranoana\.(?:shop|jp)/(?:aqua/ec|(?:tora|joshi)(?:/ec|_r/ec|_d/digi|_rd/digi)?)/item/([0-9]{12}).*}
+ , patt => 'https://ec.toranoana.<shop or jp>/<shop>/item/<number>/' },
+ l_booth => { label => 'BOOTH'
+ , fmt => 'https://booth.pm/en/items/%d'
+ , regex => qw{(?:[a-z0-9_-]+\.)?booth\.pm/(?:[a-z-]+\/)?items/([0-9]+).*}
+ , patt => 'https://booth.pm/<language>/items/<id> OR https://<publisher>.booth.pm/items/<id>' },
+ l_gamejolt => { label => 'Game Jolt'
+ , fmt => 'https://gamejolt.com/games/vn/%d', # /vn/ should be the game title, but it doesn't matter
+ , regex => qr{(?:www\.)?gamejolt\.com/games/(?:[^/]+)/([0-9]+)(?:/.*)?} },
+ l_nutaku => { label => 'Nutaku'
+ , fmt => 'https://www.nutaku.net/games/%s/'
+ , regex => qr{(?:www\.)?nutaku\.net/games/(?:mobile/|download/|app/)?([a-z0-9-]+)/?} }, # The section part does sometimes link to different pages, but it's the same game and the non-section link always works.
+ l_playstation_jp => { label => 'PlayStation Store (JP)'
+ , fmt => 'https://store.playstation.com/ja-jp/product/%s'
+ , regex => qr{store\.playstation\.com/(?:[-a-z]+\/)?product\/(JP\d{4}-[A-Z]{4}\d{5}_00-[\dA-Z_]{16})} },
+ l_playstation_na => { label => 'PlayStation Store (NA)'
+ , fmt => 'https://store.playstation.com/en-us/product/%s'
+ , regex => qr{store\.playstation\.com/(?:[-a-z]+\/)?product\/(UP\d{4}-[A-Z]{4}\d{5}_00-[\dA-Z_]{16})} },
+ l_playstation_eu => { label => 'PlayStation Store (EU)'
+ , fmt => 'https://store.playstation.com/en-gb/product/%s'
+ , regex => qr{store\.playstation\.com/(?:[-a-z]+\/)?product\/(EP\d{4}-[A-Z]{4}\d{5}_00-[\dA-Z_]{16})} },
+ l_playstation_hk => { label => 'PlayStation Store (HK)'
+ , fmt => 'https://store.playstation.com/en-hk/product/%s'
+ , regex => qr{store\.playstation\.com/(?:[-a-z]+\/)?product\/(HP\d{4}-[A-Z]{4}\d{5}_00-[\dA-Z_]{16})} },
+ l_nintendo => { label => 'Nintendo'
+ , fmt => 'https://www.nintendo.com/store/products/%s/'
+ , regex => qr{www\.nintendo\.com\/store\/products\/([-a-z0-9]+-(?:switch|wii-u|3ds))\/} },
+ l_nintendo_jp => { label => 'Nintendo (JP)'
+ , fmt => 'https://store-jp.nintendo.com/list/software/%d.html'
+ , regex => qr{store-jp\.nintendo\.com/list/software/([0-9]+).html} },
+ l_nintendo_hk => { label => 'Nintendo (HK)'
+ , fmt => 'https://store.nintendo.com.hk/%d'
+ , regex => qr{store\.nintendo\.com\.hk/([0-9]+)} },
+ # deprecated
+ l_dlsiteen => { label => 'DLsite (eng)', fmt => 'https://www.dlsite.com/eng/work/=/product_id/%s.html' },
+ l_erotrail => { label => 'ErogeTrailers', fmt => 'http://erogetrailers.com/soft/%d' },
},
s => {
l_site => { label => 'Official website', fmt => '%s' },
- l_wikidata => { label => 'Wikidata', fmt => 'https://www.wikidata.org/wiki/Q%d' },
- l_twitter => { label => 'Twitter', fmt => 'https://twitter.com/%s' },
- l_anidb => { label => 'AniDB', fmt => 'https://anidb.net/cr%s' },
- l_pixiv => { label => 'Pixiv', fmt => 'https://www.pixiv.net/member.php?id=%d' },
+ l_wikidata => { label => 'Wikidata'
+ , fmt => 'https://www.wikidata.org/wiki/Q%d'
+ , regex => qr{www\.wikidata\.org/wiki/Q([1-9][0-9]*)} },
+ l_twitter => { label => 'Xitter'
+ , fmt => 'https://twitter.com/%s'
+ , regex => qr{(?:(?:www\.)?twitter\.com|nitter\.[^/]+)/([^?\/ ]{1,16})(?:[?/].*)?} },
+ l_anidb => { label => 'AniDB'
+ , fmt => 'https://anidb.net/cr%s'
+ , regex => qr{anidb\.net/(?:cr|creator/)([1-9][0-9]*)} },
+ l_pixiv => { label => 'Pixiv'
+ , fmt => 'https://www.pixiv.net/member.php?id=%d'
+ , regex => qr{www\.pixiv\.net/(?:member\.php\?id=|en/users/|users/)([0-9]+)} },
+ l_vgmdb => { label => 'VGMdb'
+ , fmt => 'https://vgmdb.net/artist/%d'
+ , regex => qr{vgmdb\.net/artist/([0-9]+)} },
+ l_discogs => { label => 'Discogs'
+ , fmt => 'https://www.discogs.com/artist/%d'
+ , regex => qr{(?:www\.)?discogs\.com/artist/([0-9]+)(?:[?/-].*)?} },
+ l_mobygames=> { label => 'MobyGames'
+ , fmt => 'https://www.mobygames.com/person/%d'
+ , regex => qr{(?:www\.)?mobygames\.com/person/([0-9]+)(?:[?/].*)?} },
+ l_bgmtv => { label => 'Bangumi'
+ , fmt => 'https://bgm.tv/person/%d'
+ , regex => qr{(?:www\.)?(?:bgm|bangumi)\.tv/person/([0-9]+)(?:[?/].*)?} },
+ l_imdb => { label => 'IMDb'
+ , fmt => 'https://www.imdb.com/name/nm%07d'
+ , regex => qr{(?:www\.)?imdb\.com/name/nm([0-9]{7,8})(?:[?/].*)?} },
+ l_mbrainz => { label => 'MusicBrainz'
+ , fmt => 'https://musicbrainz.org/artist/%s'
+ , regex => qr{musicbrainz\.org/artist/([0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12})} },
+ l_scloud => { label => 'SoundCloud'
+ , fmt => 'https://soundcloud.com/%s'
+ , regex => qr{soundcloud\.com/([a-z0-9-]+)} },
+ l_vndb => { label => 'VNDB user'
+ , fmt => 'https://vndb.org/%s'
+ , regex => qr{vndb\.org/(u[1-9][0-9]*)} },
# deprecated
l_wp => { label => 'Wikipedia', fmt => 'https://en.wikipedia.org/wiki/%s' },
},
@@ -103,17 +265,27 @@ our %LINKS = (
);
+# Return a list of columns to fetch all external links for a database entry.
+sub sql_extlinks {
+ my($type, $prefix) = @_;
+ $prefix ||= '';
+ my $l = $LINKS{$type} || die "DB entry type $type has no links";
+ join ',', map $prefix.$_, sort keys %$l
+}
+
+
# Fetch a list of links to display at the given database entries, adds the
# following field to each object:
#
# extlinks => [
-# [ $title, $url, $price ],
+# { name, label, id, url, url2, price }, # depending on which fields are $enabled
# ..
# ]
#
-# (It also adds a few other fields in some cases, but you can ignore those)
+# Assumes the columns returned by sql_extlinks() are already available.
sub enrich_extlinks {
- my($type, @obj) = @_;
+ my($type, $enabled, @obj) = @_;
+ $enabled ||= { label => 1, url2 => 1, price => 1 };
@obj = map ref $_ eq 'ARRAY' ? @$_ : ($_), @obj;
my $l = $LINKS{$type} || die "DB entry type $type has no links";
@@ -122,27 +294,38 @@ sub enrich_extlinks {
my $w = @w_ids ? { map +($_->{id}, $_), $TUWF::OBJ->dbAlli('SELECT * FROM wikidata WHERE id IN', \@w_ids)->@* } : {};
# Fetch shop info for releases
+ my @cleanup;
if($type eq 'r') {
VNWeb::DB::enrich_merge(id => q{
SELECT r.id
, smg.price AS l_mg_price, smg.r18 AS l_mg_r18
, sdenpa.price AS l_denpa_price
- , sjlist.price AS l_jlist_price, sjlist.jbox AS l_jlist_jbox
+ , sjast.price AS l_jast_price, sjast.slug AS l_jast_slug
+ , sjlist.price AS l_jlist_price
, sdlsite.price AS l_dlsite_price, sdlsite.shop AS l_dlsite_shop
- , sdlsiteen.price AS l_dlsiteen_price, sdlsiteen.shop AS l_dlsiteen_shop
FROM releases r
LEFT JOIN shop_denpa sdenpa ON sdenpa.id = r.l_denpa AND sdenpa.lastfetch IS NOT NULL AND sdenpa.deadsince IS NULL
LEFT JOIN shop_dlsite sdlsite ON sdlsite.id = r.l_dlsite AND sdlsite.lastfetch IS NOT NULL AND sdlsite.deadsince IS NULL
- LEFT JOIN shop_dlsite sdlsiteen ON sdlsiteen.id = r.l_dlsiteen AND sdlsiteen.lastfetch IS NOT NULL AND sdlsiteen.deadsince IS NULL
+ LEFT JOIN shop_jastusa sjast ON sjast.id = r.l_jastusa AND sjast.lastfetch IS NOT NULL AND sjast.deadsince IS NULL
LEFT JOIN shop_jlist sjlist ON sjlist.id = r.l_jlist AND sjlist.lastfetch IS NOT NULL AND sjlist.deadsince IS NULL
LEFT JOIN shop_mg smg ON smg.id = r.l_mg AND smg.lastfetch IS NOT NULL AND smg.deadsince IS NULL
WHERE r.id IN},
- grep $_->{l_mg}||$_->{l_denpa}||$_->{l_jlist}||$_->{l_dlsite}||$_->{l_dlsiteen}, @obj
- );
- VNWeb::DB::enrich(l_playasia => gtin => gtin =>
- "SELECT gtin, price, url FROM shop_playasia WHERE price <> '' AND gtin IN",
- grep $_->{gtin}, @obj
- );
+ grep $_->{l_mg}||$_->{l_denpa}||$_->{l_jastusa}||$_->{l_jlist}||$_->{l_dlsite}, @obj
+ ) if $enabled->{price} || $enabled->{url2};
+
+ if(grep exists $_->{gtin}, @obj) {
+ VNWeb::DB::enrich(l_playasia => gtin => gtin =>
+ "SELECT gtin, price, url FROM shop_playasia WHERE price <> '' AND gtin IN",
+ grep $_->{gtin}, @obj
+ );
+ } else {
+ VNWeb::DB::enrich(l_playasia => id => id =>
+ "SELECT r.id, s.gtin, s.price, s.url FROM releases r JOIN shop_playasia s ON s.gtin = r.gtin WHERE s.price <> '' AND r.id IN",
+ @obj
+ );
+ }
+
+ @cleanup = qw{l_mg_price l_mg_r18 l_denpa_price l_jast_price l_jast_slug l_jlist_price l_dlsite_price l_dlsite_shop l_playasia};
}
for my $obj (@obj) {
@@ -150,12 +333,36 @@ sub enrich_extlinks {
my sub w {
return if !$obj->{l_wikidata};
my($v, $fmt, $label) = ($w->{$obj->{l_wikidata}}{$_[0]}, @{$WIKIDATA{$_[0]}}{'fmt', 'label'});
- push @links, map [ $label, ref $fmt ? $fmt->($_) : sprintf $fmt, $_ ], ref $v ? @$v : $v ? $v : ()
+ push @links, map +{
+ $enabled->{name} ? (name => $_[0]) : (),
+ $enabled->{label} ? (label => $label) : (),
+ $enabled->{id} ? (id => $_) : (),
+ $enabled->{url} ? (url => ref $fmt ? $fmt->($_) : sprintf $fmt, $_) : (),
+ $enabled->{url2} ? (url2 => ref $fmt ? $fmt->($_) : sprintf $fmt, $_) : (),
+ }, ref $v ? @$v : $v ? $v : ()
}
my sub l {
my($f, $price) = @_;
- my($v, $fmt, $fmt2, $label) = ($obj->{$f}, @{$l->{$f}}{'fmt', 'fmt2', 'label'});
- push @links, map [ $label, sprintf(ref $fmt2 ? $fmt2->($obj) : $fmt2 || $fmt, $_), $price ], ref $v ? @$v : $v ? $v : ()
+ my($v, $fmt, $fmt2, $label) = ($obj->{$f}, $l->{$f} ? @{$l->{$f}}{'fmt', 'fmt2', 'label'} : ());
+ push @links, map +{
+ $enabled->{name} ? (name => $_[0] =~ s/^l_//r) : (),
+ $enabled->{label} ? (label => $label) : (),
+ $enabled->{id} ? (id => $_) : (),
+ $enabled->{url} ? (url => sprintf($fmt, $_)) : (),
+ $enabled->{url2} ? (url2 => sprintf((ref $fmt2 ? $fmt2->($obj) : $fmt2) || $fmt, $_)) : (),
+ $enabled->{price} && length $price ? (price => $price) : (),
+ }, ref $v ? @$v : $v ? $v : ()
+ }
+ my sub c {
+ my($name, $label, $fmt, $id, $price) = @_;
+ push @links, {
+ $enabled->{name} ? (name => $name) : (),
+ $enabled->{label} ? (label => $label) : (),
+ $enabled->{id} ? (id => $id) : (),
+ $enabled->{url} ? (url => sprintf($fmt, $id)) : (),
+ $enabled->{url2} ? (url2 => sprintf($fmt, $id)) : (),
+ $enabled->{price} && length $price ? (price => $price) : (),
+ }
}
l 'l_site';
@@ -173,31 +380,54 @@ sub enrich_extlinks {
w 'indiedb_game';
w 'howlongtobeat';
w 'igdb_game';
+ w 'pcgamingwiki';
+ w 'lutris';
+ w 'wine';
l 'l_renai';
- push @links, [ 'VNStat', sprintf 'https://vnstat.net/novel/%d', $obj->{id} ] if $obj->{c_votecount}>=20;
+ c 'vnstat', 'VNStat', 'https://vnstat.net/novel/%d', $obj->{id} =~ s/^.//r if $obj->{c_votecount}>=20;
}
# Release links
if($type eq 'r') {
l 'l_egs';
- l 'l_erotrail';
l 'l_steam';
- push @links, [ 'SteamDB', sprintf 'https://steamdb.info/app/%d/info', $obj->{l_steam} ] if $obj->{l_steam};
+ c 'steamdb', 'SteamDB', 'https://steamdb.info/app/%d/info', $obj->{l_steam} if $obj->{l_steam};
l 'l_dlsite', $obj->{l_dlsite_price};
- l 'l_dlsiteen', $obj->{l_dlsiteen_price};
l 'l_gog';
l 'l_itch';
+ l 'l_patreonp';
+ l 'l_patreon';
+ l 'l_substar';
+ l 'l_gamejolt';
l 'l_denpa', $obj->{l_denpa_price};
l 'l_jlist', $obj->{l_jlist_price};
- l 'l_jastusa';
+ l 'l_jastusa', $obj->{l_jast_price};
+ l 'l_fakku';
+ l 'l_appstore';
+ l 'l_googplay';
+ l 'l_animateg';
+ l 'l_freem';
+ l 'l_freegame';
+ l 'l_novelgam';
l 'l_gyutto';
l 'l_digiket';
l 'l_melon';
+ l 'l_melonjp';
l 'l_mg', $obj->{l_mg_price};
+ l 'l_nutaku';
l 'l_getchu';
l 'l_getchudl';
l 'l_dmm';
- push @links, map [ 'PlayAsia', $_->{url}, $_->{price} ], @{$obj->{l_playasia}} if $obj->{l_playasia};
+ l 'l_toranoana';
+ l 'l_booth';
+ l 'l_playstation_jp';
+ l 'l_playstation_na';
+ l 'l_playstation_eu';
+ l 'l_playstation_hk';
+ l 'l_nintendo';
+ l 'l_nintendo_jp';
+ l 'l_nintendo_hk';
+ c 'playasia', 'PlayAsia', '%s', $_->{url}, $_->{price} for $obj->{l_playasia}->@*;
}
# Staff links
@@ -205,10 +435,15 @@ sub enrich_extlinks {
l 'l_twitter'; w 'twitter' if !$obj->{l_twitter};
l 'l_anidb'; w 'anidb_person' if !$obj->{l_anidb};
l 'l_pixiv'; w 'pixiv_user' if !$obj->{l_pixiv};
- w 'musicbrainz_artist';
- w 'vgmdb_artist';
- w 'discogs_artist';
- w 'doujinshi_author';
+ l 'l_mbrainz'; w 'musicbrainz_artist' if !$obj->{l_mbrainz};
+ l 'l_vgmdb'; w 'vgmdb_artist' if !$obj->{l_vgmdb};
+ l 'l_discogs'; w 'discogs_artist' if !$obj->{l_discogs};
+ l 'l_scloud'; w 'soundcloud' if !$obj->{l_scloud};
+ l 'l_mobygames';
+ l 'l_bgmtv';
+ l 'l_imdb';
+ l 'l_vndb';
+ #w 'doujinshi_author';
}
# Producer links
@@ -216,11 +451,13 @@ sub enrich_extlinks {
w 'twitter';
w 'mobygames_company';
w 'gamefaqs_company';
- w 'doujinshi_author';
- push @links, [ 'VNStat', sprintf 'https://vnstat.net/developer/%d', $obj->{id} ];
+ #w 'doujinshi_author';
+ w 'soundcloud';
+ c 'vnstat', 'VNStat', 'https://vnstat.net/developer/%d', $obj->{id} =~ s/^.//r;
}
- $obj->{extlinks} = \@links
+ $obj->{extlinks} = \@links;
+ delete @{$obj}{ @cleanup };
}
}
@@ -235,4 +472,46 @@ sub revision_extlinks {
}
+# Turn a 'regex' value in %LINKS into a full proper regex.
+sub full_regex { qr{^(?:https?://)?$_[0](?:\#.*)?$} }
+
+
+# Returns a list of keys for inclusion into a TUWF::Validate schema.
+# Only includes links for which a 'regex' has been set.
+sub validate_extlinks {
+ my($type) = @_;
+ my($schema) = grep +($_->{dbentry_type}||'') eq $type, values VNDB::Schema::schema->%*;
+
+ map {
+ my($f, $p) = ($_, $LINKS{$type}{$_});
+ my($s) = grep $_->{name} eq $f, $schema->{cols}->@*;
+
+ my %val;
+ $val{int} = 1 if $s->{type} =~ /^(big)?int/;
+ $val{maxlength} = 512 if !$val{int};
+ $val{func} = sub { $val{int} && !$_[0] ? 1 : sprintf($p->{fmt}, $_[0]) =~ full_regex $p->{regex} };
+ ($f, $s->{type} =~ /\[\]/
+ ? { type => 'array', values => \%val }
+ : { default => $s->{decl} !~ /not\s+null/i ? undef : $val{int} ? 0 : '', %val }
+ )
+ } sort grep $LINKS{$type}{$_}{regex}, keys $LINKS{$type}->%*
+}
+
+
+# Returns a list of sites for use in VNWeb::Elm and util/jsgen.pl:
+# { id => $id, name => $label, fmt => $label, regex => $regex, int => $bool, default => undef||0||''||[], pattern => [..] }
+sub extlinks_sites {
+ my($type) = @_;
+ my($schema) = grep +($_->{dbentry_type}||'') eq $type, values VNDB::Schema::schema->%*;
+ map {
+ my($f, $p) = ($_, $LINKS{$type}{$_});
+ my($s) = grep $_->{name} eq $f, $schema->{cols}->@*;
+ my $patt = $p->{patt} || ($p->{fmt} =~ s/%s/<code>/rg =~ s/%[0-9]*d/<number>/rg);
+ +{ id => $f, name => $p->{label}, fmt => $p->{fmt}, regex => full_regex($p->{regex})
+ , int => $s->{type} =~ /^(big)?int/ ? 1 : 0,
+ , default => $s->{type} =~ /\[\]/ ? [] : $s->{decl} !~ /not\s+null/i ? undef : $s->{type} =~ /^(big)?int/ ? 0 : ''
+ , pattern => [ split /(<[^>]+>)/, $patt ] }
+ } sort grep $LINKS{$type}{$_}{regex}, keys $LINKS{$type}->%*
+}
+
1;
diff --git a/lib/VNDB/Func.pm b/lib/VNDB/Func.pm
index 2a169552..8c448ad8 100644
--- a/lib/VNDB/Func.pm
+++ b/lib/VNDB/Func.pm
@@ -1,167 +1,160 @@
-
package VNDB::Func;
use strict;
use warnings;
-use TUWF ':html', 'kv_validate', 'xml_escape', 'uri_escape';
+use TUWF::Misc 'uri_escape';
use Exporter 'import';
-use POSIX 'strftime', 'ceil', 'floor';
-use JSON::XS;
-use VNDBUtil;
+use POSIX 'strftime', 'floor';
+use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6';
+use Digest::SHA 'sha1';
+use VNDB::Config;
use VNDB::Types;
use VNDB::BBCode;
-our @EXPORT = (@VNDBUtil::EXPORT, 'bb2html', 'bb2text', qw|
- clearfloat cssicon minage fil_parse fil_serialize parenttags
- childtags charspoil imgpath imgurl
- fmtvote fmtmedia fmtvnlen fmtage fmtdatestr fmtdate fmtrating fmtspoil
- lang_attr
- json_encode json_decode script_json
- form_compare
+our @EXPORT = ('bb_format', qw|
+ in
+ idcmp
+ shorten
+ resolution
+ gtintype
+ imgsize
+ norm_ip
+ minage
+ fmtvote fmtmedia fmtage fmtdate fmtrating fmtspoil fmtanimation
+ rdate
+ imgpath imgurl
+ tlang tattr
query_encode
md2html
+ is_insecurepass
|);
-# three ways to represent the same information
-our $fil_escape = '_ !"#$%&\'()*+,-./:;<=>?@[\]^`{}~';
-our @fil_escape = split //, $fil_escape;
-our %fil_escape = map +($fil_escape[$_], sprintf '%02d', $_), 0..$#fil_escape;
-
-
-# Clears a float, to make sure boxes always have the correct height
-sub clearfloat {
- div class => 'clearfloat', '';
+# Simple "is this element in the array?" function, using 'eq' to test equality.
+# Supports both an @array and \@array.
+# Usage:
+#
+# my $contains_hi = in 'hi', qw/ a b hi c /; # true
+#
+sub in {
+ my($q, @a) = @_;
+ $_ eq $q && return 1 for map ref $_ eq 'ARRAY' ? @$_ : ($_), @a;
+ 0
}
-# Draws a CSS icon, arguments: class, title
-sub cssicon {
- abbr class => "icons $_[0]", title => $_[1];
- lit '&#xa0;';
- end;
+# Compare two vndbids, using proper numeric order
+sub idcmp($$) {
+ my($a1, $a2) = $_[0] =~ /^([a-z]+)([0-9]+)$/;
+ my($b1, $b2) = $_[1] =~ /^([a-z]+)([0-9]+)$/;
+ $a1 cmp $b1 || $a2 <=> $b2
}
-sub minage {
- my($a, $ex) = @_;
- $a = $AGE_RATING{$a};
- $ex && $a->{ex} ? "$a->{txt} (e.g. $a->{ex})" : $a->{txt}
+sub shorten {
+ my($str, $len) = @_;
+ return length($str) > $len ? substr($str, 0, $len-3).'...' : $str;
}
-# arguments: $filter_string, @allowed_keys
-sub fil_parse {
- my $str = shift;
- my %keys = map +($_,1), @_;
- my %r;
- for (split /\./, $str) {
- next if !/^([a-z0-9_]+)-([a-zA-Z0-9_~\x81-\x{ffffff}]+)$/ || !$keys{$1};
- my($f, $v) = ($1, $2);
- my @v = split /~/, $v;
- s/_([0-9]{2})/$1 > $#fil_escape ? '' : $fil_escape[$1]/eg for(@v);
- $r{$f} = @v > 1 ? \@v : $v[0]
- }
- return \%r;
+sub resolution {
+ my($x,$y) = @_;
+ ($x,$y) = ($x->{reso_x}, $x->{reso_y}) if ref $x;
+ $x ? "${x}x${y}" : $y == 1 ? 'Non-standard' : undef
}
-sub fil_serialize {
- my $fil = shift;
- my $e = qr/([\Q$fil_escape\E])/;
- return join '.', map {
- my @v = ref $fil->{$_} ? @{$fil->{$_}} : ($fil->{$_});
- s/$e/_$fil_escape{$1}/g for(@v);
- $_.'-'.join '~', @v
- } grep defined($fil->{$_}), keys %$fil;
+# GTIN code as argument,
+# Returns 'JAN', 'EAN', 'UPC', 'ISBN' or undef,
+# Also 'normalizes' the first argument in place
+sub gtintype {
+ $_[0] =~ s/[^\d]+//g;
+ $_[0] =~ s/^0+//;
+ return undef if $_[0] !~ /^[0-9]{10,13}$/; # I've yet to see a UPC code shorter than 10 digits assigned to a game
+ $_[0] = ('0'x(12-length $_[0])) . $_[0] if length($_[0]) < 12; # pad with zeros to GTIN-12
+ my $c = shift;
+ return undef if $c !~ /^[0-9]{12,13}$/;
+ $c = "0$c" if length($c) == 12; # pad with another zero for GTIN-13
+
+ # calculate check digit according to
+ # http://www.gs1.org/productssolutions/barcodes/support/check_digit_calculator.html#how
+ my @n = reverse split //, $c;
+ my $n = shift @n;
+ $n += $n[$_] * ($_ % 2 != 0 ? 1 : 3) for (0..$#n);
+ return undef if $n % 10 != 0;
+
+ # Do some rough guesses based on:
+ # http://www.gs1.org/productssolutions/barcodes/support/prefix_list.html
+ # and http://en.wikipedia.org/wiki/List_of_GS1_country_codes
+ local $_ = $c;
+ return 'JAN' if /^4[59]/; # prefix code 450-459 & 490-499
+ return 'UPC' if /^(?:0[01]|0[6-9]|13|75[45])/; # prefix code 000-019 & 060-139 & 754-755
+ return 'ISBN' if /^97[89]/;
+ return undef if /^(?:0[2-5]|2|9[6-9])/; # some codes we don't want: 020–059 & 200-299 & non-ISBN 977-999
+ return 'EAN'; # let's just call everything else EAN :)
}
-# generates a parent tags/traits listing
-sub parenttags {
- my($t, $index, $type) = @_;
- p;
- my @p = _parenttags(@{$t->{parents}});
- for my $p (@p ? @p : []) {
- a href => "/$type", $index;
- for (reverse @$p) {
- txt ' > ';
- a href => "/$type$_->{id}", $_->{name};
- }
- txt " > $t->{name}";
- br;
- }
- end 'p';
-}
-
-# arg: tag/trait hashref
-# returns: [ [ tag1, tag2, tag3 ], [ tag1, tag2, tag5 ] ]
-sub _parenttags {
- my @r;
- for my $t (@_) {
- for (@{$t->{'sub'}}) {
- push @r, [ $t, @$_ ] for _parenttags($_);
- }
- push @r, [$t] if !@{$t->{'sub'}};
+# arguments: <image size>, <max dimensions>
+# returns the size of the thumbnail with the same aspect ratio as the full-size
+# image, but fits within the specified maximum dimensions
+sub imgsize {
+ my($ow, $oh, $sw, $sh) = @_;
+ return ($ow, $oh) if $ow <= $sw && $oh <= $sh;
+ if($ow/$oh > $sw/$sh) { # width is the limiting factor
+ $oh *= $sw/$ow;
+ $ow = $sw;
+ } else {
+ $ow *= $sh/$oh;
+ $oh = $sh;
}
- return @r;
+ return (int ($ow+0.5), int ($oh+0.5));
}
-# a child tags/traits box
-sub childtags {
- my($self, $title, $type, $t, $order) = @_;
-
- div class => 'mainbox';
- h1 $title;
- ul class => 'tagtree';
- for my $p (sort { !$order ? @{$b->{'sub'}} <=> @{$a->{'sub'}} : $a->{$order} <=> $b->{$order} } @{$t->{childs}}) {
- li;
- a href => "/$type$p->{id}", $p->{name};
- b class => 'grayedout', " ($p->{c_items})" if $p->{c_items};
- end, next if !@{$p->{'sub'}};
- ul;
- for (0..$#{$p->{'sub'}}) {
- last if $_ >= 5 && @{$p->{'sub'}} > 6;
- li;
- txt '> ';
- a href => "/$type$p->{sub}[$_]{id}", $p->{'sub'}[$_]{name};
- b class => 'grayedout', " ($p->{sub}[$_]{c_items})" if $p->{'sub'}[$_]{c_items};
- end;
- }
- if(@{$p->{'sub'}} > 6) {
- my $c = @{$p->{'sub'}}-5;
- li;
- txt '> ';
- a href => "/$type$p->{id}", style => 'font-style: italic',
- sprintf '%d more %s%s', $c, $type eq 'g' ? 'tag' : 'trait', $c==1 ? '' : 's';
- end;
- }
- end;
- end 'li';
+# Normalized IP address to use for duplicate detection/throttling. For IPv4
+# this is the /23 subnet (is this enough?), for IPv6 the /48 subnet, with the
+# least significant bits of the address zero'd.
+sub norm_ip {
+ my $ip = shift;
+
+ # There's a whole bunch of IP manipulation modules on CPAN, but many seem
+ # quite bloated and still don't offer the functionality to return an IP
+ # with its mask applied (admittedly not a common operation). The libc
+ # socket functions will do fine in parsing and formatting addresses, and
+ # the actual masking is quite trivial in binary form.
+ my $v4 = inet_pton AF_INET, $ip;
+ if($v4) {
+ $v4 =~ s/(..)(.)./$1 . chr(ord($2) & 254) . "\0"/se;
+ return inet_ntop AF_INET, $v4;
}
- end 'ul';
- clearfloat;
- br;
- end 'div';
+
+ $ip = inet_pton AF_INET6, $ip;
+ return '::' if !$ip;
+ $ip =~ s/^(.{6}).+$/$1 . "\0"x10/se;
+ return inet_ntop AF_INET6, $ip;
}
-# generates the class elements for character spoiler hiding
-sub charspoil {
- return "charspoil charspoil_$_[0]";
+sub minage {
+ my($a, $ex) = @_;
+ return 'Unknown' if !defined $a;
+ $a = $AGE_RATING{$a};
+ $ex && $a->{ex} ? "$a->{txt} (e.g. $a->{ex})" : $a->{txt}
}
-# generates a local path to an image in static/
-sub imgpath { # <type>, <id>
- return sprintf '%s/static/%s/%02d/%d.jpg', $TUWF::OBJ->{root}, $_[0], $_[1]%100, $_[1];
+sub _path {
+ my($t, $id) = $_[1] =~ /([a-z]+)([0-9]+)/;
+ sprintf '%s/%s%s/%02d/%d.%s', $_[0], $t, $_[2] ? ".$_[2]" : '', $id%100, $id, $_[3]||'jpg';
}
+# imgpath($image_id, $dir, $format)
+# $dir = empty || 't' || 'orig'
+# $format = empty || $file_ext
+sub imgpath { _path config->{var_path}.'/static', @_ }
-# generates a URL for an image in static/
-sub imgurl {
- return sprintf '%s/%s/%02d/%d.jpg', $TUWF::OBJ->{url_static}, $_[0], $_[1]%100, $_[1];
-}
+# imgurl($image_id, $dir, $format)
+sub imgurl { _path config->{url_static}, @_ }
# Formats a vote number.
@@ -178,13 +171,6 @@ sub fmtmedia {
$med->{ $med->{qty} && $qty > 1 ? 'plural' : 'txt' };
}
-# Formats a VN length (xtra = time indication)
-sub fmtvnlen {
- my($len, $xtra) = @_;
- $len = $VN_LENGTH{$len};
- $len->{txt}.($xtra && $len->{time} ? " ($len->{time})" : '');
-}
-
# Formats a UNIX timestamp as a '<number> <unit> ago' string
sub fmtage {
my $a = time-shift;
@@ -200,32 +186,12 @@ sub fmtage {
sprintf '%d %s ago', $t, $t == 1 ? $single : $plural;
}
-# argument: database release date format (yyyymmdd)
-# y = 0000 -> unknown
-# y = 9999 -> TBA
-# m = 99 -> month+day unknown
-# d = 99 -> day unknown
-# return value: (unknown|TBA|yyyy|yyyy-mm|yyyy-mm-dd)
-# if date > now: <b class="future">str</b>
-sub fmtdatestr {
- my $date = sprintf '%08d', shift||0;
- my $future = $date > strftime '%Y%m%d', gmtime;
- my($y, $m, $d) = ($1, $2, $3) if $date =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/;
-
- my $str = $y == 0 ? 'unknown' : $y == 9999 ? 'TBA' :
- $m == 99 ? sprintf('%04d', $y) :
- $d == 99 ? sprintf('%04d-%02d', $y, $m) :
- sprintf('%04d-%02d-%02d', $y, $m, $d);
-
- return $str if !$future;
- return qq|<b class="future">$str</b>|;
-}
# argument: unix timestamp and optional format (compact/full)
sub fmtdate {
my($t, $f) = @_;
- return strftime '%Y-%m-%d', gmtime $t if !$f || $f eq 'compact';
- return strftime '%Y-%m-%d at %R', gmtime $t;
+ return strftime '%Y-%m-%d', localtime $t if !$f || $f eq 'compact';
+ return strftime '%Y-%m-%d at %R', localtime $t;
}
# Turn a (natural number) vote into a rating indication
@@ -251,69 +217,56 @@ sub fmtspoil {
}
-# Generates a HTML 'lang' attribute given a list of possible languages.
-# This is used for the 'original language' field, which we can safely assume is not used for latin-alphabet languages.
-sub lang_attr {
- my @l = ref $_[0] ? $_[0]->@* : @_;
- # Choose Japanese, Chinese or Korean (in order of likelyness) if those are in the list.
- return (lang => 'ja') if grep $_ eq 'ja', @l;
- return (lang => 'zh') if grep $_ eq 'zh', @l;
- return (lang => 'ko') if grep $_ eq 'ko', @l;
- return (lang => $l[0]) if @l == 1;
- ()
+sub fmtanimation {
+ my($a, $cat) = @_;
+ return if !defined $a;
+ return $cat ? ucfirst "$cat not animated" : 'Not animated' if !$a;
+ return $cat ? "No $cat" : 'Not applicable' if $a == 1;
+ ($a & 256 ? 'Some scenes ' : $a & 512 ? 'All scenes ' : '').join('/',
+ $a & 4 ? 'Hand drawn' : (),
+ $a & 8 ? 'Vectorial' : (),
+ $a & 16 ? '3D' : (),
+ $a & 32 ? 'Live action' : ()
+ ).($cat ? " $cat" : '');
}
-
-# JSON::XS::encode_json converts input to utf8, whereas the below functions
-# operate on wide character strings. Canonicalization is enabled to allow for
-# proper comparison of serialized objects.
-my $JSON = JSON::XS->new;
-$JSON->canonical(1);
-
-sub json_encode ($) {
- $JSON->encode(@_);
+# Format a release date as a string.
+sub rdate {
+ my($y, $m, $d) = ($1, $2, $3) if sprintf('%08d', shift||0) =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/;
+ $y == 0 ? 'unknown' :
+ $y == 9999 ? 'TBA' :
+ $m == 99 ? sprintf('%04d', $y) :
+ $d == 99 ? sprintf('%04d-%02d', $y, $m) :
+ sprintf('%04d-%02d-%02d', $y, $m, $d);
}
-sub json_decode ($) {
- $JSON->decode(@_);
-}
-# Insert JSON-encoded data as script, arguments: id, object
-sub script_json {
- script id => $_[0], type => 'application/json';
- my $js = json_encode $_[1];
- $js =~ s/</\\u003C/g; # escape HTML tags like </script> and <!--
- lit $js;
- end;
+# Given a language code & title, returns a (lang => $x) html property.
+sub tlang {
+ my($lang, $title) = @_;
+ # TODO: The -Latn suffix is redundant for languages that use the Latin script by default, need to check with a list.
+ # English is the site's default, so no need to specify that.
+ $lang && $lang ne 'en'
+ ? (lang => $lang . ($title =~ /[\x{0400}-\x{04ff}\x{0600}-\x{06ff}\x{0e00}-\x{0e7f}\x{1100}-\x{11ff}\x{1400}-\x{167f}\x{3040}-\x{3099}\x{30a1}-\x{30fa}\x{3100}-\x{9fff}\x{ac00}-\x{d7af}\x{ff66}-\x{ffdc}\x{20000}-\x{323af}]/ ? '' : '-Latn'))
+ : ();
}
-
-# Compare the keys in %$old with the keys in %$new. Returns 1 if a difference was found, 0 otherwise.
-sub form_compare {
- my($old, $new) = @_;
- for my $k (keys %$old) {
- my($o, $n) = ($old->{$k}, $new->{$k});
- return 1 if defined $n ne defined $o || ref $o ne ref $n;
- if(!defined $o) {
- # must be equivalent
- } elsif(!ref $o) {
- return 1 if $o ne $n;
- } else { # 'json' template
- return 1 if @$o != @$n;
- return 1 if grep form_compare($o->[$_], $n->[$_]), 0..$#$o;
- }
- }
- return 0;
+# Given an SQL titles array, returns element attributes & content.
+sub tattr {
+ my $title = ref $_[0] eq 'HASH' ? $_[0]{title} : $_[0];
+ (tlang($title->[0],$title->[1]), title => $title->[3], $title->[1])
}
-# Encode query parameters. Takes a hash or hashref with key/values, supports array values.
+
+# Encode query parameters. Takes a hash or hashref with key/values, supports array values and objects that implement query_encode().
sub query_encode {
my $o = @_ == 1 ? $_[0] : {@_};
return join '&', map {
my($k, $v) = ($_, $o->{$_});
+ $v = $v->query_encode() if ref $v && ref $v ne 'ARRAY';
!defined $v ? () : ref $v ? map "$k=".uri_escape($_), sort @$v : "$k=".uri_escape($v)
} sort keys %$o;
}
@@ -348,5 +301,34 @@ sub md2html {
$html
}
-1;
+sub is_insecurepass {
+ utf8::encode(local $_ = shift);
+ my $hash = sha1 $_;
+ my $dir = config->{var_path}.'/hibp';
+ return 0 if !-d $dir;
+
+ my $prefix = uc unpack 'H4', $hash;
+ my $data = substr $hash, 2, 10;
+ my $F;
+ if(!open $F, '<', "$dir/$prefix") {
+ warn "Unable to lookup password prefix $prefix: $!";
+ return 0;
+ }
+
+ # Plain old binary search.
+ # Would be nicer to search through an mmap'ed view of the file, or at least
+ # use pread(), but alas, neither are easily available in Perl.
+ my($left, $right) = (0, -10 + -s $F);
+ while($left <= $right) {
+ my $off = floor(($left+$right)/20)*10;
+ sysseek $F, $off, 0 or die $!;
+ 10 == sysread $F, my $buf, 10 or die $!;
+ return 1 if $buf eq $data;
+ if($buf lt $data) { $left = $off + 10; }
+ else { $right = $off - 10; }
+ }
+ 0;
+}
+
+1;
diff --git a/lib/VNDB/Handler/Chars.pm b/lib/VNDB/Handler/Chars.pm
deleted file mode 100644
index a7a8d801..00000000
--- a/lib/VNDB/Handler/Chars.pm
+++ /dev/null
@@ -1,531 +0,0 @@
-
-package VNDB::Handler::Chars;
-
-use strict;
-use warnings;
-use TUWF ':html', 'uri_escape';
-use Exporter 'import';
-use VNDB::Func;
-use VNDB::Types;
-use List::Util 'min';
-
-our @EXPORT = ('charOps', 'charTable', 'charBrowseTable');
-
-TUWF::register(
- qr{c(?:([1-9]\d*)(?:\.([1-9]\d*))?/(edit|copy)|/new)}
- => \&edit,
- qr{c/([a-z0]|all)} => \&list,
-);
-
-
-sub charOps {
- my($self, $sexual, $blockId) = @_;
- $blockId ||= 'charops_block';
- my $spoil = $self->authPref('spoilers')||0;
-
- if($sexual) {
- my $id_sex = $blockId.'_sex';
- input type => 'checkbox', class => 'visuallyhidden sexual_check', id => $id_sex, ($self->authPref('traits_sexual') ? (checked => 'checked') : ());
- label for => $id_sex, class => 'lst sec', 'Show sexual traits';
- }
-
- my $id_2 = $blockId.'_2';
- input type => 'radio', class => 'visuallyhidden radio_spoil2', name => $blockId, id => $id_2, $spoil == 2 ? (checked => 'checked') : ();
- label for => $id_2, $sexual ? () : (class => 'lst'), 'Spoil me!';
-
- my $id_1 = $blockId.'_1';
- input type => 'radio', class => 'visuallyhidden radio_spoil1', name => $blockId, id => $id_1, $spoil == 1 ? (checked => 'checked') : ();
- label for => $id_1, 'Show minor spoilers';
-
- my $id_0 = $blockId.'_0';
- input type => 'radio', class => 'visuallyhidden radio_spoil0', name => $blockId, id => $id_0, $spoil == 0 ? (checked => 'checked') : ();
- label for => $id_0, 'Hide spoilers';
-}
-
-
-# Also used from Handler::VNPage
-sub charTable {
- my($self, $r, $link, $sep, $vn, $spoil) = @_;
- $spoil ||= 0;
-
- div class => 'chardetails '.charspoil($spoil).($sep ? ' charsep' : '');
-
- # image
- div class => 'charimg';
- if(!$r->{image}) {
- p 'No image uploaded yet';
- } else {
- img src => imgurl(ch => $r->{image}), alt => $r->{name};
- }
- end 'div';
-
- # info table
- table class => 'stripe';
- thead;
- Tr;
- td colspan => 2;
- if($link) {
- a href => "/c$r->{id}", style => 'margin-right: 10px; font-weight: bold', $r->{name};
- } else {
- b style => 'margin-right: 10px', $r->{name};
- }
- b class => 'grayedout', style => 'margin-right: 10px', $r->{original} if $r->{original};
- cssicon "gen $r->{gender}", $GENDER{$r->{gender}} if $r->{gender} ne 'unknown';
- span $BLOOD_TYPE{$r->{bloodt}} if $r->{bloodt} ne 'unknown';
- end;
- end;
- end;
-
- if($r->{alias}) {
- $r->{alias} =~ s/\n/, /g;
- Tr;
- td class => 'key', 'Aliases';
- td $r->{alias};
- end;
- }
- if(defined($r->{weight}) || $r->{height} || $r->{s_bust} || $r->{s_waist} || $r->{s_hip} || $r->{cup_size}) {
- Tr;
- td class => 'key', 'Measurements';
- td join ', ',
- $r->{height} ? "Height: $r->{height}cm" : (),
- defined($r->{weight}) ? "Weight: $r->{weight}kg" : (),
- $r->{s_bust} || $r->{s_waist} || $r->{s_hip} ?
- sprintf 'Bust-Waist-Hips: %s-%s-%scm', $r->{s_bust}||'??', $r->{s_waist}||'??', $r->{s_hip}||'??' : (),
- $r->{cup_size} ? "$CUP_SIZE{$r->{cup_size}} cup" : ();
- end;
- }
- if($r->{b_month} && $r->{b_day}) {
- Tr;
- td class => 'key', 'Birthday';
- td $r->{b_day}.' '.[qw{January February March April May June July August September October November December}]->[$r->{b_month}-1];
- end;
- }
- if(defined $r->{age}) {
- Tr;
- td class => 'key', 'Age';
- td $r->{age};
- end;
- }
-
- # traits
- my %groups;
- my @groups;
- for (@{$r->{traits}}) {
- my $g = $_->{group}||$_->{tid};
- push @groups, $g if !$groups{$g};
- push @{$groups{ $g }}, $_
- }
- for my $g (@groups) {
- Tr class => 'traitrow';
- td class => 'key'; a href => '/i'.($groups{$g}[0]{group}||$groups{$g}[0]{tid}), $groups{$g}[0]{groupname} || $groups{$g}[0]{name}; end;
- td;
- for (0..$#{$groups{$g}}) {
- my $t = $groups{$g}[$_];
- span class => charspoil($t->{spoil}).($t->{sexual} ? ' sexual' : '');
- txt ', ';
- a href => "/i$t->{tid}", $t->{name};
- end;
- }
- end;
- end;
- }
-
- # vns
- if(@{$r->{vns}} && (!$vn || $vn && (@{$r->{vns}} > 1 || $r->{vns}[0]{rid}))) {
- my %vns;
- push @{$vns{$_->{vid}}}, $_ for(sort { !defined($a->{rid})?1:!defined($b->{rid})?-1:$a->{rtitle} cmp $b->{rtitle} } @{$r->{vns}});
- Tr;
- td class => 'key', $vn ? 'Releases' : 'Visual novels';
- td;
- my $first = 0;
- for my $g (sort { $vns{$a}[0]{vntitle} cmp $vns{$b}[0]{vntitle} } keys %vns) {
- my @r = @{$vns{$g}};
- # special case: all releases, no exceptions
- if(!$vn && @r == 1 && !$r[0]{rid}) {
- span class => charspoil $r[0]{spoil};
- txt $CHAR_ROLE{$r[0]{role}}{txt}.' - ';
- a href => "/v$r[0]{vid}/chars", $r[0]{vntitle};
- br;
- end;
- next;
- }
- # otherwise, print VN title and list releases separately
- my $minspoil = 5;
- $minspoil = $minspoil > $_->{spoil} ? $_->{spoil} : $minspoil for (@r);
- span class => charspoil $minspoil;
- a href => "/v$r[0]{vid}/chars", $r[0]{vntitle} if !$vn;
- for(@r) {
- span class => charspoil $_->{spoil};
- br if !$vn || $_ != $r[0];
- b class => 'grayedout', '> ';
- txt $CHAR_ROLE{$_->{role}}{txt}.' - ';
- if($_->{rid}) {
- b class => 'grayedout', "r$_->{rid}:";
- a href => "/r$_->{rid}", $_->{rtitle};
- } else {
- txt 'All other releases';
- }
- end;
- }
- br;
- end;
- }
- end;
- end;
- }
-
- if(@{$r->{seiyuu}}) {
- Tr;
- td class => 'key', 'Voiced by';
- td;
- my $last_name = '';
- for my $s (sort { $a->{name} cmp $b->{name} } @{$r->{seiyuu}}) {
- next if $s->{name} eq $last_name;
- a href => "/s$s->{sid}", title => $s->{original}||$s->{name}, $s->{name};
- txt ' ('.$s->{note}.')' if $s->{note};
- br;
- $last_name = $s->{name};
- }
- end;
- end;
- }
-
- # description
- if($r->{desc}) {
- Tr class => 'nostripe';
- td class => 'chardesc', colspan => 2;
- h2 'Description';
- p;
- lit bb2html $r->{desc}, 0, 1;
- end;
- end;
- end;
- }
-
- end 'table';
- end;
- clearfloat;
-}
-
-
-
-sub edit {
- my($self, $id, $rev, $copy) = @_;
-
- $copy = $rev && $rev eq 'copy' || $copy && $copy eq 'copy';
- $rev = undef if defined $rev && $rev !~ /^\d+$/;
-
- my $r = $id && $self->dbCharGetRev(id => $id, what => 'extended vns traits', $rev ? (rev => $rev) : ())->[0];
- return $self->resNotFound if $id && !$r->{id};
- $rev = undef if !$r || $r->{lastrev};
-
- return $self->htmlDenied if !$self->authCan('edit')
- || $id && (($r->{locked} || $r->{hidden}) && !$self->authCan('dbmod'));
-
- my %b4 = !$id ? () : (
- (map +($_ => $r->{$_}), qw|name original alias desc image ihid ilock s_bust s_waist s_hip height weight bloodt cup_size age gender main_spoil|),
- main => $r->{main}||0,
- bday => $r->{b_month} ? sprintf('%02d-%02d', $r->{b_month}, $r->{b_day}) : '',
- traits => join(' ', map sprintf('%d-%d', $_->{tid}, $_->{spoil}), sort { $a->{tid} <=> $b->{tid} } @{$r->{traits}}),
- vns => join(' ', map sprintf('%d-%d-%d-%s', $_->{vid}, $_->{rid}||0, $_->{spoil}, $_->{role}),
- sort { $a->{vid} <=> $b->{vid} || ($a->{rid}||0) <=> ($b->{rid}||0) } @{$r->{vns}}),
- );
- my $frm;
-
- if($self->reqMethod eq 'POST') {
- return if !$self->authCheckCode;
- $frm = $self->formValidate(
- { post => 'name', maxlength => 200 },
- { post => 'original', required => 0, maxlength => 200, default => '' },
- { post => 'alias', required => 0, maxlength => 500, default => '' },
- { post => 'desc', required => 0, maxlength => 5000, default => '' },
- { post => 'gender', required => 0, default => 'unknown', enum => [ keys %GENDER ] },
- { post => 'image', required => 0, default => 0, template => 'id' },
- { post => 'bday', required => 0, default => '', regex => [ qr/^(?:[01]?[0-9])-(?:[0123]?[0-9])$/, 'Birthday must be in MM-DD format.' ] },
- { post => 's_bust', required => 0, default => 0, template => 'uint', max => 32767 },
- { post => 's_waist', required => 0, default => 0, template => 'uint', max => 32767 },
- { post => 's_hip', required => 0, default => 0, template => 'uint', max => 32767 },
- { post => 'height', required => 0, default => 0, template => 'uint', max => 32767 },
- { post => 'weight', required => 0, default => undef, template => 'uint', max => 32767 },
- { post => 'bloodt', required => 0, default => 'unknown', enum => [ keys %BLOOD_TYPE ] },
- { post => 'cup_size', required => 0, default => '', enum => [ keys %CUP_SIZE ] },
- { post => 'age', required => 0, default => undef, template => 'uint', max => 32767 },
- { post => 'main', required => 0, default => 0, template => 'id' },
- { post => 'main_spoil', required => 0, default => 0, enum => [ 0..2 ] },
- { post => 'traits', required => 0, default => '', regex => [ qr/^(?:[1-9]\d*-[0-2])(?: +[1-9]\d*-[0-2])*$/, 'Incorrect trait format.' ] },
- { post => 'vns', required => 0, default => '', regex => [ qr/^(?:[1-9]\d*-\d+-[0-2]-[a-z]+)(?: +[1-9]\d*-\d+-[0-2]-[a-z]+)*$/, 'Incorrect VN format.' ] },
- { post => 'editsum', template => 'editsum' },
- { post => 'ihid', required => 0 },
- { post => 'ilock', required => 0 },
- );
- $frm->{original} = '' if $frm->{original} eq $frm->{name};
-
- # handle image upload
- $frm->{image} = _uploadimage($self, $frm);
-
- # validate main character
- if(!$frm->{_err} && $frm->{main}) {
- my $m = $self->dbCharGet(id => $frm->{main}, what => 'extended')->[0];
- push @{$frm->{_err}}, 'Invalid main character. Make sure the ID is correct,'
- .' that the main character itself is not an instance of an other character,'
- .' and that this entry is not used as a main character elsewhere.'
- if !$m || $m->{main} || $r && !$copy && ($m->{id} == $r->{id} || $self->dbCharGet(instance => $r->{id})->[0]);
- }
-
- my(@traits, @vns);
- if(!$frm->{_err}) {
- # parse and normalize
- @vns = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } map [split /-/], split / /, $frm->{vns};
- $frm->{vns} = join(' ', map sprintf('%d-%d-%d-%s', @$_), @vns);
- $frm->{ihid} = $frm->{ihid} ?1:0;
- $frm->{ilock} = $frm->{ilock}?1:0;
- $frm->{desc} = $self->bbSubstLinks($frm->{desc});
- $frm->{main_spoil} = 0 if !$frm->{main};
-
- @traits = sort { $a->[0] <=> $b->[0] } map /^(\d+)-(\d+)$/&&[$1,$2], split / /, $frm->{traits};
- my %traits = @traits ? map +($_->{id}, 1), @{$self->dbTraitGet(results => 500, state => 2, applicable => 1, id => [ map $_->[0], @traits ])} : ();
- @traits = grep $traits{$_->[0]}, @traits;
- $frm->{traits} = join(' ', map sprintf('%d-%d', @$_), @traits);
-
- # check for changes
- my $same = $id && !grep +($frm->{$_}//'') ne ($b4{$_}//''), keys %b4;
- return $self->resRedirect("/c$id", 'post') if !$copy && $same;
- $frm->{_err} = ["No changes, please don't create an entry that is fully identical to another"] if $copy && $same;
- }
-
- if(!$frm->{_err}) {
- # modify for dbCharRevisionInsert
- ($frm->{b_month}, $frm->{b_day}) = delete($frm->{bday}) =~ /^(\d{2})-(\d{2})$/ ? ($1, $2) : (0, 0);
- $frm->{main} ||= undef;
- $frm->{traits} = \@traits;
- $_->[1]||=undef for (@vns);
- $frm->{vns} = \@vns;
-
- my $nrev = $self->dbItemEdit(c => !$copy && $id ? ($r->{id}, $r->{rev}) : (undef, undef), %$frm);
- return $self->resRedirect("/c$nrev->{itemid}.$nrev->{rev}", 'post');
- }
- }
-
- if(!$id) {
- my $vid = $self->formValidate({ get => 'vid', required => 1, template => 'id'});
- $frm->{vns} //= "$vid->{vid}-0-0-primary" if !$vid->{_err};
- }
- $frm->{$_} //= $b4{$_} for keys %b4;
- $frm->{editsum} //= sprintf 'Reverted to revision c%d.%d', $id, $rev if !$copy && $rev;
- $frm->{editsum} = sprintf 'New character based on c%d.%d', $id, $r->{rev} if $copy;
-
- my $title = !$r ? 'Add new character' : $copy ? "Copy $r->{name}" : "Edit $r->{name}";
- $self->htmlHeader(title => $title, noindex => 1);
- $self->htmlMainTabs('c', $r, $copy ? 'copy' : 'edit') if $r;
- $self->htmlEditMessage('c', $r, $title, $copy);
- $self->htmlForm({ frm => $frm, action => $r ? "/c$id/".($copy ? 'copy' : 'edit') : '/c/new', editsum => 1, upload => 1 },
- chare_geninfo => [ 'General info',
- [ input => name => 'Name (romaji)', short => 'name' ],
- [ input => name => 'Original name', short => 'original' ],
- [ static => content => 'The original name of the character, leave blank if it is already in the Latin alphabet.' ],
- [ text => name => 'Aliases', short => 'alias', rows => 3 ],
- [ static => content => '(Un)official aliases, separated by a newline.' ],
- [ text => name => 'Description<br /><b class="standout">English please!</b>', short => 'desc', rows => 6 ],
- [ select => name => 'Sex', short => 'gender', options => [
- map [ $_, $GENDER{$_} ], keys %GENDER ] ],
- [ input => name => 'Birthday', short => 'bday', width => 100,post => ' MM-DD (e.g. "01-26" for the 26th of January)' ],
- [ input => name => 'Age', short => 'age', width => 50, post => ' years', allow0 => 1 ],
- [ input => name => 'Bust', short => 's_bust', width => 50, post => ' cm' ],
- [ input => name => 'Waist', short => 's_waist',width => 50, post => ' cm' ],
- [ input => name => 'Hips', short => 's_hip', width => 50, post => ' cm' ],
- [ input => name => 'Height', short => 'height', width => 50, post => ' cm' ],
- [ input => name => 'Weight', short => 'weight', width => 50, post => ' kg', allow0 => 1 ],
- [ select => name => 'Blood type',short => 'bloodt', options => [
- map [ $_, $BLOOD_TYPE{$_} ], keys %BLOOD_TYPE ] ],
- [ select => name => 'Cup size', short => 'cup_size', options => [
- map [ $_, $CUP_SIZE{$_} ], keys %CUP_SIZE ] ],
- [ static => content => '<br />' ],
- [ input => name => 'Instance of',short => 'main', width => 50, post => ' ID of the main character - the character of which this is an instance of.' ],
- [ select => name => 'Spoiler', short => 'main_spoil', options => [
- map [$_, fmtspoil $_], 0..2 ] ],
- ],
-
- chare_img => [ 'Image', [ static => nolabel => 1, content => sub {
- div class => 'img';
- p 'No image uploaded yet' if !$frm->{image};
- img src => imgurl(ch => $frm->{image}) if $frm->{image};
- end;
-
- div;
- h2 'Image ID';
- input type => 'text', class => 'text', name => 'image', id => 'image', value => $frm->{image}||'';
- p 'Use a character image that is already on the server. Set to \'0\' to remove the current image.';
- br; br;
-
- h2 'Upload new image';
- input type => 'file', class => 'text', name => 'img', id => 'img';
- p 'Image must be in JPEG or PNG format and at most 1MiB. Images larger than 256x300 will automatically be resized. Image must be safe for work!';
- end;
- }]],
-
- chare_traits => [ 'Traits',
- [ hidden => short => 'traits' ],
- [ static => nolabel => 1, content => sub {
- h2 'Current traits';
- table; tbody id => 'traits_tbl';
- Tr id => 'traits_loading'; td colspan => '3', 'Loading...'; end;
- end; end;
- h2 'Add trait';
- table; Tr;
- td class => 'tc_name'; input id => 'trait_input', type => 'text', class => 'text'; end;
- td colspan => 2, '';
- end; end 'table';
- }],
- ],
-
- chare_vns => [ 'Visual novels',
- [ hidden => short => 'vns' ],
- [ static => nolabel => 1, content => sub {
- h2 'Selected visual novels';
- table; tbody id => 'vns_tbl';
- Tr id => 'vns_loading'; td colspan => '4', 'Loading...'; end;
- end; end;
- h2 'Add visual novel';
- table; Tr;
- td class => 'tc_vnadd'; input id => 'vns_input', type => 'text', class => 'text'; end;
- td colspan => 3, '';
- end; end;
- }],
- ]);
- $self->htmlFooter;
-}
-
-
-sub _uploadimage {
- my($self, $frm) = @_;
-
- if($frm->{_err} || !$self->reqPost('img')) {
- return 0 if !$frm->{image};
- push @{$frm->{_err}}, 'No image with that ID' if !-s imgpath(ch => $frm->{image});
- return $frm->{image};
- }
-
- # perform some elementary checks
- my $imgdata = $self->reqUploadRaw('img');
- $frm->{_err} = [ 'Image must be in JPEG or PNG format' ] if $imgdata !~ /^(\xff\xd8|\x89\x50)/; # JPG or PNG headers
- $frm->{_err} = [ 'Image is too large, only 1MB allowed' ] if length($imgdata) > 1024*1024;
- return undef if $frm->{_err};
-
- # resize/compress
- my $im = Image::Magick->new;
- $im->BlobToImage($imgdata);
- my($ow, $oh) = ($im->Get('width'), $im->Get('height'));
- my($nw, $nh) = imgsize($ow, $oh, @{$self->{ch_size}});
- $im->Set(background => '#ffffff');
- $im->Set(alpha => 'Remove');
- if($ow != $nw || $oh != $nh) {
- $im->GaussianBlur(geometry => '0.5x0.5');
- $im->Resize(width => $nw, height => $nh);
- $im->UnsharpMask(radius => 0, sigma => 0.75, amount => 0.75, threshold => 0.008);
- }
- $im->Set(magick => 'JPEG', quality => 90);
-
- # Get ID and save
- my $imgid = $self->dbCharImageId;
- my $fn = imgpath(ch => $imgid);
- $im->Write($fn);
- chmod 0666, $fn;
-
- return $imgid;
-}
-
-
-sub list {
- my($self, $fch) = @_;
-
- my $f = $self->formValidate(
- { get => 'p', required => 0, default => 1, template => 'page' },
- { get => 'q', required => 0, default => '' },
- { get => 'fil', required => 0, default => '' },
- );
- return $self->resNotFound if $f->{_err};
-
- my($list, $np) = $self->filFetchDB(char => $f->{fil}, {
- tagspoil => $self->authPref('spoilers')||0,
- }, {
- $fch ne 'all' ? ( char => $fch ) : (),
- $f->{q} ? ( search => $f->{q} ) : (),
- results => 50,
- page => $f->{p},
- what => 'vns',
- });
-
- $self->htmlHeader(title => 'Browse characters');
-
- my $quri = uri_escape($f->{q});
- form action => '/c/all', 'accept-charset' => 'UTF-8', method => 'get';
- div class => 'mainbox';
- h1 'Browse characters';
- $self->htmlSearchBox('c', $f->{q});
- p class => 'browseopts';
- for ('all', 'a'..'z', 0) {
- a href => "/c/$_?q=$quri;fil=$f->{fil}", $_ eq $fch ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#';
- }
- end;
-
- p class => 'filselect';
- a id => 'filselect', href => '#c';
- lit '<i>&#9656;</i> Filters<i></i>';
- end;
- end;
- input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil};
- end;
- end 'form';
-
- if(!@$list) {
- div class => 'mainbox';
- h1 'No results';
- p 'No characters found that matched your criteria.';
- end;
- }
-
- @$list && $self->charBrowseTable($list, $np, $f, "/c/$fch?q=$quri;fil=$f->{fil}");
-
- $self->htmlFooter;
-}
-
-
-# Also used on Handler::Traits
-sub charBrowseTable {
- my($self, $list, $np, $f, $uri) = @_;
-
- $self->htmlBrowse(
- class => 'charb',
- items => $list,
- options => $f,
- nextpage => $np,
- pageurl => $uri,
- sorturl => $uri,
- header => [ [ '' ], [ '' ] ],
- row => sub {
- my($s, $n, $l) = @_;
- Tr;
- td class => 'tc1';
- cssicon "gen $l->{gender}", $GENDER{$l->{gender}} if $l->{gender} ne 'unknown';
- end;
- td class => 'tc2';
- a href => "/c$l->{id}", title => $l->{original}||$l->{name}, shorten $l->{name}, 50;
- b class => 'grayedout';
- my $i = 1;
- my %vns;
- for (@{$l->{vns}}) {
- next if $_->{spoil} || $vns{$_->{vid}}++;
- last if $i++ > 4;
- txt ', ' if $i > 2;
- a href => "/v$_->{vid}/chars", title => $_->{vntitle}, shorten $_->{vntitle}, 30;
- }
- end;
- end;
- end;
- }
- )
-}
-
-
-1;
-
diff --git a/lib/VNDB/Handler/Misc.pm b/lib/VNDB/Handler/Misc.pm
deleted file mode 100644
index 25d10c39..00000000
--- a/lib/VNDB/Handler/Misc.pm
+++ /dev/null
@@ -1,252 +0,0 @@
-
-package VNDB::Handler::Misc;
-
-
-use strict;
-use warnings;
-use TUWF ':html', ':xml', 'uri_escape';
-use VNDB::Func;
-use VNDB::Types;
-
-
-TUWF::register(
- qr{}, \&homepage,
- qr{nospam}, \&nospam,
- qr{xml/prefs\.xml}, \&prefs,
- qr{opensearch\.xml}, \&opensearch,
-
- # redirects for old URLs
- qr{u([1-9]\d*)/tags}, sub { $_[0]->resRedirect("/g/links?u=$_[1]", 'perm') },
- qr{(.*[^/]+)/+}, sub { $_[0]->resRedirect("/$_[1]", 'perm') },
- qr{([pv])}, sub { $_[0]->resRedirect("/$_[1]/all", 'perm') },
- qr{v/search}, sub { $_[0]->resRedirect("/v/all?q=".uri_escape($_[0]->reqGet('q')||''), 'perm') },
- qr{notes}, sub { $_[0]->resRedirect('/d8', 'perm') },
- qr{faq}, sub { $_[0]->resRedirect('/d6', 'perm') },
- qr{v([1-9]\d*)/(?:stats|scr)},
- sub { $_[0]->resRedirect("/v$_[1]", 'perm') },
- qr{u/list(/[a-z0]|/all)?},
- sub { my $l = defined $_[1] ? $_[1] : '/all'; $_[0]->resRedirect("/u$l", 'perm') },
-);
-
-
-sub homepage {
- my $self = shift;
-
- my $title = 'The Visual Novel Database';
- my $desc = 'VNDB.org strives to be a comprehensive database for information about visual novels.';
-
- my $metadata = {
- 'og:type' => 'website',
- 'og:title' => $title,
- 'og:description' => $desc,
- };
-
- $self->htmlHeader(title => $title, feeds => 1, metadata => $metadata);
-
- div class => 'mainbox';
- h1 $title;
- p class => 'description';
- txt $desc;
- br;
- txt 'This website is built as a wiki, meaning that anyone can freely add'
- .' and contribute information to the database, allowing us to create the'
- .' largest, most accurate and most up-to-date visual novel database on the web.';
- end;
-
- # with filters applied it's signifcantly slower, so special-code the situations with and without filters
- my @vns;
- if($self->authPref('filter_vn')) {
- my $r = $self->filFetchDB(vn => undef, undef, {hasshot => 1, results => 4, sort => 'rand'});
- @vns = map $_->{id}, @$r;
- }
- my $scr = $self->dbScreenshotRandom(@vns);
- p class => 'screenshots';
- for (@$scr) {
- my($w, $h) = imgsize($_->{width}, $_->{height}, @{$self->{scr_size}});
- a href => "/v$_->{vid}", title => $_->{title};
- img src => imgurl(st => $_->{scr}), alt => $_->{title}, width => $w, height => $h;
- end;
- }
- end;
- end 'div';
-
- table class => 'mainbox threelayout';
- Tr;
-
- # Recent changes
- td;
- h1;
- a href => '/hist', 'Recent Changes'; txt ' ';
- a href => '/feeds/changes.atom'; cssicon 'feed', 'Atom Feed'; end;
- end;
- my $changes = $self->dbRevisionGet(results => 10, auto => 1);
- ul;
- for (@$changes) {
- li;
- txt "$_->{type}:";
- a href => "/$_->{type}$_->{itemid}.$_->{rev}", title => $_->{ioriginal}||$_->{ititle}, shorten $_->{ititle}, 33;
- lit " by ";
- VNWeb::HTML::user_($_);
- end;
- }
- end;
- end 'td';
-
- # Announcements
- td;
- my $an = $self->dbThreadGet(type => 'an', sort => 'id', reverse => 1, results => 2);
- h1;
- a href => '/t/an', 'Announcements'; txt ' ';
- a href => '/feeds/announcements.atom'; cssicon 'feed', 'Atom Feed'; end;
- end;
- for (@$an) {
- my $post = $self->dbPostGet(tid => $_->{id}, num => 1)->[0];
- h2;
- a href => "/t$_->{id}", $_->{title};
- end;
- p;
- lit bb2html $post->{msg}, 150;
- end;
- }
- end 'td';
-
- # Recent posts
- td;
- h1;
- a href => '/t/all', 'Recent Posts'; txt ' ';
- a href => '/feeds/posts.atom'; cssicon 'feed', 'Atom Feed'; end;
- end;
- my $posts = $self->dbThreadGet(what => 'lastpost boardtitles', results => 10, sort => 'lastpost', reverse => 1, notusers => 1);
- ul;
- for (@$posts) {
- my $boards = join ', ', map $BOARD_TYPE{$_->{type}}{txt}.($_->{iid}?' > '.$_->{title}:''), @{$_->{boards}};
- li;
- txt fmtage($_->{lastpost_date}).' ';
- a href => VNWeb::Discussions::Lib::post_url($_->{id}, $_->{count}, 'last'), title => "Posted in $boards", shorten $_->{title}, 25;
- lit ' by ';
- VNWeb::HTML::user_($_, 'lastpost_');
- end;
- }
- end;
- end 'td';
-
- end 'tr';
- Tr;
-
- # Random visual novels
- td;
- h1;
- a href => '/v/rand', 'Random visual novels';
- end;
- my $random = $self->filFetchDB(vn => undef, undef, {results => 10, sort => 'rand'});
- ul;
- for (@$random) {
- li;
- a href => "/v$_->{id}", title => $_->{original}||$_->{title}, shorten $_->{title}, 40;
- end;
- }
- end;
- end 'td';
-
- # Upcoming releases
- td;
- h1;
- a href => '/r?fil=released-0;o=a;s=released', 'Upcoming releases';
- end;
- my $upcoming = $self->filFetchDB(release => undef, undef, {results => 10, released => 0, what => 'platforms'});
- ul;
- for (@$upcoming) {
- li;
- lit fmtdatestr $_->{released};
- txt ' ';
- cssicon $_, $PLATFORM{$_} for (@{$_->{platforms}});
- cssicon "lang $_", $LANGUAGE{$_} for (@{$_->{languages}});
- txt ' ';
- a href => "/r$_->{id}", title => $_->{original}||$_->{title}, shorten $_->{title}, 30;
- end;
- }
- end;
- end 'td';
-
- # Just released
- td;
- h1;
- a href => '/r?fil=released-1;o=d;s=released', 'Just released';
- end;
- my $justrel = $self->filFetchDB(release => undef, undef, {results => 10, sort => 'released', reverse => 1, released => 1, what => 'platforms'});
- ul;
- for (@$justrel) {
- li;
- lit fmtdatestr $_->{released};
- txt ' ';
- cssicon $_, $PLATFORM{$_} for (@{$_->{platforms}});
- cssicon "lang $_", $LANGUAGE{$_} for (@{$_->{languages}});
- txt ' ';
- a href => "/r$_->{id}", title => $_->{original}||$_->{title}, shorten $_->{title}, 30;
- end;
- }
- end;
- end 'td';
-
- end 'tr';
- end 'table';
-
- $self->htmlFooter;
-}
-
-
-sub nospam {
- my $self = shift;
- $self->htmlHeader(title => 'Could not send form', noindex => 1);
-
- div class => 'mainbox';
- h1 'Could not send form';
- div class => 'warning';
- h2 'Error';
- p 'The form could not be sent, please make sure you have Javascript enabled in your browser.';
- end;
- end;
-
- $self->htmlFooter;
-}
-
-
-sub prefs {
- my $self = shift;
- return if !$self->authCheckCode;
- return $self->resNotFound if !$self->authInfo->{id};
- my $f = $self->formValidate(
- { get => 'key', enum => [qw|filter_vn filter_release|] },
- { get => 'value', required => 0, maxlength => 2000 },
- );
- return $self->resNotFound if $f->{_err};
- $self->authPref($f->{key}, $f->{value});
-
- # doesn't really matter what we return, as long as it's XML
- $self->resHeader('Content-type' => 'text/xml');
- xml;
- tag 'done', '';
-}
-
-
-sub opensearch {
- my $self = shift;
- my $h = $self->reqBaseURI();
- $self->resHeader('Content-Type' => 'application/opensearchdescription+xml');
- xml;
- tag 'OpenSearchDescription',
- xmlns => 'http://a9.com/-/spec/opensearch/1.1/', 'xmlns:moz' => 'http://www.mozilla.org/2006/browser/search/';
- tag 'ShortName', 'VNDB';
- tag 'LongName', 'VNDB.org visual novel search';
- tag 'Description', 'Search visual vovels on VNDB.org';
- tag 'Image', width => 16, height => 16, type => 'image/x-icon', "$h/favicon.ico";
- tag 'Url', type => 'text/html', method => 'get', template => "$h/v/all?q={searchTerms}", undef;
- tag 'Url', type => 'application/opensearchdescription+xml', rel => 'self', template => "$h/opensearch.xml", undef;
- tag 'Query', role => 'example', searchTerms => 'Tsukihime', undef;
- tag 'moz:SearchForm', "$h/v/all";
- end 'OpenSearchDescription';
-}
-
-
-1;
-
diff --git a/lib/VNDB/Handler/Producers.pm b/lib/VNDB/Handler/Producers.pm
deleted file mode 100644
index 7a1a287c..00000000
--- a/lib/VNDB/Handler/Producers.pm
+++ /dev/null
@@ -1,500 +0,0 @@
-
-package VNDB::Handler::Producers;
-
-use strict;
-use warnings;
-use TUWF ':html', ':xml', 'xml_escape', 'html_escape';
-use VNDB::Func;
-use VNDB::Types;
-use VNDB::ExtLinks;
-
-
-TUWF::register(
- qr{p([1-9]\d*)/rg} => \&rg,
- qr{p([1-9]\d*)(?:\.([1-9]\d*))?} => \&page,
- qr{p/add} => \&addform,
- qr{p(?:([1-9]\d*)(?:\.([1-9]\d*))?/edit|/new)}
- => \&edit,
- qr{p/([a-z0]|all)} => \&list,
- qr{xml/producers\.xml} => \&pxml,
-);
-
-
-sub rg {
- my($self, $pid) = @_;
-
- my $p = $self->dbProducerGet(id => $pid, what => 'relgraph')->[0];
- return $self->resNotFound if !$p->{id} || !$p->{rgraph};
-
- my $title = "Relation graph for $p->{name}";
- return if $self->htmlRGHeader($title, 'p', $p);
-
- $p->{svg} =~ s/id="node_p$pid"/id="graph_current"/;
-
- div class => 'mainbox';
- h1 $title;
- p class => 'center';
- lit $p->{svg};
- end;
- end;
- $self->htmlFooter;
-}
-
-
-sub page {
- my($self, $pid, $rev) = @_;
-
- my $method = $rev ? 'dbProducerGetRev' : 'dbProducerGet';
- my $p = $self->$method(
- id => $pid,
- what => 'extended relations',
- $rev ? ( rev => $rev ) : ()
- )->[0];
- return $self->resNotFound if !$p->{id};
- enrich_extlinks p => $p;
-
- my $metadata = {
- 'og:title' => $p->{name},
- 'og:description' => bb2text $p->{desc},
- };
-
- $self->htmlHeader(title => $p->{name}, noindex => $rev, metadata => $metadata);
- $self->htmlMainTabs(p => $p);
- return if $self->htmlHiddenMessage('p', $p);
-
- if($rev) {
- my $prev = $rev && $rev > 1 && $self->dbProducerGetRev(id => $pid, rev => $rev-1, what => 'extended relations')->[0];
- $self->htmlRevision('p', $prev, $p,
- [ type => 'Type', serialize => sub { $PRODUCER_TYPE{$_[0]} } ],
- [ name => 'Name (romaji)', diff => 1 ],
- [ original => 'Original name', diff => 1 ],
- [ alias => 'Aliases', diff => qr/[ ,\n\.]/ ],
- [ lang => 'Language', serialize => sub { "$_[0] ($LANGUAGE{$_[0]})" } ],
- [ website => 'Website', diff => 1 ],
- [ l_wp => 'Wikipedia link',htmlize => sub {
- $_[0] ? sprintf '<a href="http://en.wikipedia.org/wiki/%s">%1$s</a>', xml_escape $_[0] : '[empty]'
- }],
- [ l_wikidata=> 'Wikidata ID', htmlize => sub { $_[0] ? sprintf '<a href="https://www.wikidata.org/wiki/Q%d">Q%1$d</a>', $_[0] : '[empty]' } ],
- [ desc => 'Description', diff => qr/[ ,\n\.]/ ],
- [ relations => 'Relations', join => '<br />', split => sub {
- my @r = map sprintf('%s: <a href="/p%d" title="%s">%s</a>',
- $PRODUCER_RELATION{$_->{relation}}{txt}, $_->{id}, xml_escape($_->{original}||$_->{name}), xml_escape shorten $_->{name}, 40
- ), sort { $a->{id} <=> $b->{id} } @{$_[0]};
- return @r ? @r : ('[empty]');
- }],
- );
- }
-
- div class => 'mainbox';
- $self->htmlItemMessage('p', $p);
- h1 $p->{name};
- h2 class => 'alttitle', lang => $p->{lang}, $p->{original} if $p->{original};
- p class => 'center';
- txt "$LANGUAGE{$p->{lang}} $PRODUCER_TYPE{$p->{type}}";
- if($p->{alias}) {
- (my $alias = $p->{alias}) =~ s/\n/, /g;
- br;
- txt "a.k.a. $alias";
- }
-
- br if $p->{extlinks}->@*;
- for($p->{extlinks}->@*) {
- a href => $_->[1], $_->[0];
- txt ' - ' if $_ ne $p->{extlinks}[$#{$p->{extlinks}}];
- }
- end 'p';
-
- if(@{$p->{relations}}) {
- my %rel;
- push @{$rel{$_->{relation}}}, $_
- for (sort { $a->{name} cmp $b->{name} } @{$p->{relations}});
- p class => 'center';
- br;
- for my $r (keys %PRODUCER_RELATION) {
- next if !$rel{$r};
- txt $PRODUCER_RELATION{$r}{txt}.': ';
- for (@{$rel{$r}}) {
- a href => "/p$_->{id}", title => $_->{original}||$_->{name}, shorten $_->{name}, 40;
- txt ', ' if $_ ne $rel{$r}[$#{$rel{$r}}];
- }
- br;
- }
- end 'p';
- }
-
- if($p->{desc}) {
- p class => 'description';
- lit bb2html $p->{desc};
- end;
- }
- end 'div';
-
- _releases($self, $p);
-
- $self->htmlFooter;
-}
-
-sub _releases {
- my($self, $p) = @_;
-
- # prodpage_(dev|pub)
- my $r = $self->dbReleaseGet(pid => $p->{id}, results => 999, what => 'vn platforms links');
- enrich_extlinks r => $r;
-
- div class => 'mainbox';
- a href => '#', id => 'expandprodrel', 'collapse';
- h1 'Releases';
- if(!@$r) {
- p 'We have currently no visual novels by this producer.';
- end;
- return;
- }
-
- my %vn; # key = vid, value = [ $r1, $r2, $r3, .. ]
- my @vn; # $vn objects in order of first release
- for my $rel (@$r) {
- for my $v (@{$rel->{vn}}) {
- push @vn, $v if !$vn{$v->{vid}};
- push @{$vn{$v->{vid}}}, $rel;
- }
- }
-
- table id => 'prodrel';
- for my $v (@vn) {
- Tr class => 'vn';
- td colspan => 6;
- i; lit fmtdatestr $vn{$v->{vid}}[0]{released}; end;
- a href => "/v$v->{vid}", title => $v->{original}, $v->{title};
- span '('.join(', ',
- (grep($_->{developer}, @{$vn{$v->{vid}}}) ? 'developer' : ()),
- (grep($_->{publisher}, @{$vn{$v->{vid}}}) ? 'publisher' : ())
- ).')';
- end;
- end;
- for my $rel (@{$vn{$v->{vid}}}) {
- Tr class => 'rel';
- td class => 'tc1'; lit fmtdatestr $rel->{released}; end;
- td class => 'tc2', $rel->{minage} < 0 ? '' : minage $rel->{minage};
- td class => 'tc3';
- for (sort @{$rel->{platforms}}) {
- next if $_ eq 'oth';
- cssicon $_, $PLATFORM{$_};
- }
- cssicon "lang $_", $LANGUAGE{$_} for (@{$rel->{languages}});
- cssicon "rt$rel->{type}", $rel->{type};
- end;
- td class => 'tc4';
- a href => "/r$rel->{id}", title => $rel->{original}||$rel->{title}, $rel->{title};
- b class => 'grayedout', ' (patch)' if $rel->{patch};
- end;
- td class => 'tc5', join ', ',
- ($rel->{developer} ? 'developer' : ()), ($rel->{publisher} ? 'publisher' : ());
- td class => 'tc6';
- $self->releaseExtLinks($rel);
- end;
- end 'tr';
- }
- }
- end 'table';
- end 'div';
-}
-
-
-sub addform {
- my $self = shift;
- return $self->htmlDenied if !$self->authCan('edit');
-
- my $frm;
- my $l = [];
- if($self->reqMethod eq 'POST') {
- return if !$self->authCheckCode;
- $frm = $self->formValidate(
- { post => 'name', maxlength => 200 },
- { post => 'original', required => 0, maxlength => 200, default => '' },
- { post => 'alias', required => 0, maxlength => 500, default => '' },
- { post => 'continue_ign',required => 0 },
- );
-
- # look for duplicates
- if(!$frm->{_err} && !$frm->{continue_ign}) {
- $l = $self->dbProducerGet(search => $frm->{name}, what => 'extended', results => 50, inc_hidden => 1);
- push @$l, @{$self->dbProducerGet(search => $frm->{original}, what => 'extended', results => 50, inc_hidden => 1)} if $frm->{original};
- $_ && push @$l, @{$self->dbProducerGet(search => $_, what => 'extended', results => 50, inc_hidden => 1)} for(split /\n/, $frm->{alias});
- my %ids = map +($_->{id}, $_), @$l;
- $l = [ map $ids{$_}, sort { $ids{$a}{name} cmp $ids{$b}{name} } keys %ids ];
- }
-
- return edit($self, undef, undef, 1) if !@$l && !$frm->{_err};
- }
-
- $self->htmlHeader(title => 'Add a new producer', noindex => 1);
- if(@$l) {
- div class => 'mainbox';
- h1 'Possible duplicates found';
- div class => 'warning';
- p;
- txt 'The following is a list of producers that match the name(s) you gave.'
- .' Please check this list to avoid creating a duplicate producer entry.'
- .' Be especially wary of items that have been deleted! To see why an entry has been deleted, click on its title.';
- br; br;
- txt 'To add the producer anyway, hit the "Continue and ignore duplicates" button below.';
- end;
- end;
- ul;
- for(@$l) {
- li;
- a href => "/p$_->{id}", title => $_->{original}||$_->{name}, "p$_->{id}: ".shorten($_->{name}, 50);
- b class => 'standout', ' deleted' if $_->{hidden};
- end;
- }
- end;
- end 'div';
- }
-
- $self->htmlForm({ frm => $frm, action => '/p/add', continue => @$l ? 2 : 1 },
- vn_add => [ 'Add a new producer',
- [ input => name => 'Name (romaji)', short => 'name' ],
- [ input => name => 'Original name', short => 'original' ],
- [ static => content => 'The original name of the producer, leave blank if it is already in the Latin alphabet.' ],
- [ textarea => short => 'alias', name => 'Aliases', rows => 4 ],
- [ static => content => '(Un)official aliases, separated by a newline.' ],
- ]);
- $self->htmlFooter;
-}
-
-
-# pid as argument = edit producer
-# no arguments = add new producer
-sub edit {
- my($self, $pid, $rev, $nosubmit) = @_;
-
- my $p = $pid && $self->dbProducerGetRev(id => $pid, what => 'extended relations', rev => $rev)->[0];
- return $self->resNotFound if $pid && !$p->{id};
- $rev = undef if !$p || $p->{lastrev};
-
- return $self->htmlDenied if !$self->authCan('edit')
- || $pid && (($p->{locked} || $p->{hidden}) && !$self->authCan('dbmod'));
-
- my %b4 = !$pid ? () : (
- (map { $_ => $p->{$_} } qw|type name original lang website l_wikidata desc alias ihid ilock|),
- prodrelations => join('|||', map $_->{relation}.','.$_->{id}.','.$_->{name}, sort { $a->{id} <=> $b->{id} } @{$p->{relations}}),
- );
- my $frm;
-
- if($self->reqMethod eq 'POST') {
- return if !$nosubmit && !$self->authCheckCode;
- $frm = $self->formValidate(
- { post => 'type', required => !$nosubmit, enum => [ keys %PRODUCER_TYPE ] },
- { post => 'name', maxlength => 200 },
- { post => 'original', required => 0, maxlength => 200, default => '' },
- { post => 'alias', required => 0, maxlength => 500, default => '' },
- { post => 'lang', required => !$nosubmit, enum => [ keys %LANGUAGE ] },
- { post => 'website', required => 0, maxlength => 250, default => '', template => 'weburl' },
- { post => 'l_wikidata', required => 0, template => 'wikidata' },
- { post => 'desc', required => 0, maxlength => 5000, default => '' },
- { post => 'prodrelations', required => 0, maxlength => 5000, default => '' },
- { post => 'editsum', required => !$nosubmit, template => 'editsum' },
- { post => 'ihid', required => 0 },
- { post => 'ilock', required => 0 },
- );
- $frm->{original} = '' if $frm->{original} eq $frm->{name};
- if(!$nosubmit && !$frm->{_err}) {
- # parse
- my $relations = [ map { /^([a-z]+),([0-9]+),(.+)$/ && (!$pid || $2 != $pid) ? [ $1, $2, $3 ] : () } split /\|\|\|/, $frm->{prodrelations} ];
-
- # normalize
- $frm->{ihid} = $frm->{ihid}?1:0;
- $frm->{ilock} = $frm->{ilock}?1:0;
- $frm->{desc} = $self->bbSubstLinks($frm->{desc});
- $relations = [] if $frm->{ihid};
- $frm->{prodrelations} = join '|||', map $_->[0].','.$_->[1].','.$_->[2], sort { $a->[1] <=> $b->[1]} @{$relations};
-
- return $self->resRedirect("/p$pid", 'post')
- if $pid && !grep +(($frm->{$_}//'') ne ($b4{$_}//'')), keys %b4;
-
- $frm->{relations} = $relations;
- my $nrev = $self->dbItemEdit(p => $pid||undef, $pid ? $p->{rev} : undef, %$frm);
-
- # update reverse relations
- if(!$pid && $#$relations >= 0 || $pid && $frm->{prodrelations} ne $b4{prodrelations}) {
- my %old = $pid ? (map { $_->{id} => $_->{relation} } @{$p->{relations}}) : ();
- my %new = map { $_->[1] => $_->[0] } @$relations;
- _updreverse($self, \%old, \%new, $nrev->{itemid}, $nrev->{rev});
- }
-
- return $self->resRedirect("/p$nrev->{itemid}.$nrev->{rev}", 'post');
- }
- }
-
- !defined $frm->{$_} && ($frm->{$_} = $b4{$_}) for keys %b4;
- $frm->{lang} = 'ja' if !$pid && !defined $frm->{lang};
- $frm->{editsum} = sprintf 'Reverted to revision p%d.%d', $pid, $rev if $rev && !defined $frm->{editsum};
-
- my $title = $pid ? "Edit $p->{name}" : 'Add new producer';
- $self->htmlHeader(title => $title, noindex => 1);
- $self->htmlMainTabs('p', $p, 'edit') if $pid;
- $self->htmlEditMessage('p', $p, $title);
- $self->htmlForm({ frm => $frm, action => $pid ? "/p$pid/edit" : '/p/new', editsum => 1 },
- 'pedit_geninfo' => [ 'General info',
- [ select => name => 'Type', short => 'type',
- options => [ map [ $_, $PRODUCER_TYPE{$_} ], keys %PRODUCER_TYPE ] ],
- [ input => name => 'Name (romaji)', short => 'name' ],
- [ input => name => 'Original name', short => 'original' ],
- [ static => content => 'The original name of the producer, leave blank if it is already in the Latin alphabet.' ],
- [ textarea => short => 'alias', name => 'Aliases', rows => 4 ],
- [ static => content => '(Un)official aliases, separated by a newline.' ],
- [ select => name => 'Primary language', short => 'lang',
- options => [ map [ $_, "$LANGUAGE{$_} ($_)" ], sort { $LANGUAGE{$a} cmp $LANGUAGE{$b} } keys %LANGUAGE ] ],
- [ input => name => 'Website', short => 'website' ],
- [ input => short => 'l_wikidata',name => 'Wikidata ID',
- value => $frm->{l_wikidata} ? "Q$frm->{l_wikidata}" : '',
- post => qq{ (<a href="$self->{url_static}/f/wikidata.png">How to find this</a>)}
- ],
- [ text => name => 'Description<br /><b class="standout">English please!</b>', short => 'desc', rows => 6 ],
- ], 'pedit_rel' => [ 'Relations',
- [ hidden => short => 'prodrelations' ],
- [ static => nolabel => 1, content => sub {
- h2 'Selected producers';
- table;
- tbody id => 'relation_tbl';
- # to be filled using javascript
- end;
- end;
-
- h2 'Add producer';
- table;
- Tr id => 'relation_new';
- td class => 'tc_prod';
- input type => 'text', class => 'text';
- end;
- td class => 'tc_rel';
- Select;
- option value => $_, $PRODUCER_RELATION{$_}{txt}
- for (keys %PRODUCER_RELATION);
- end;
- end;
- td class => 'tc_add';
- a href => '#', 'add';
- end;
- end;
- end 'table';
- }],
- ]);
- $self->htmlFooter;
-}
-
-sub _updreverse {
- my($self, $old, $new, $pid, $rev) = @_;
- my %upd;
-
- # compare %old and %new
- for (keys %$old, keys %$new) {
- if(exists $$old{$_} and !exists $$new{$_}) {
- $upd{$_} = undef;
- } elsif((!exists $$old{$_} and exists $$new{$_}) || ($$old{$_} ne $$new{$_})) {
- $upd{$_} = $PRODUCER_RELATION{$$new{$_}}{reverse};
- }
- }
- return if !keys %upd;
-
- # edit all related producers
- for my $i (keys %upd) {
- my $r = $self->dbProducerGetRev(id => $i, what => 'relations')->[0];
- my @newrel = map $_->{id} != $pid ? [ $_->{relation}, $_->{id} ] : (), @{$r->{relations}};
- push @newrel, [ $upd{$i}, $pid ] if $upd{$i};
- $self->dbItemEdit(p => $i, $r->{rev},
- relations => \@newrel,
- editsum => "Reverse relation update caused by revision p$pid.$rev",
- uid => 1,
- );
- }
-}
-
-
-sub list {
- my($self, $char) = @_;
-
- my $f = $self->formValidate(
- { get => 'p', required => 0, default => 1, template => 'page' },
- { get => 'q', required => 0, default => '' },
- );
- return $self->resNotFound if $f->{_err};
-
- my($list, $np) = $self->dbProducerGet(
- $char ne 'all' ? ( char => $char ) : (),
- $f->{q} ? ( search => $f->{q} ) : (),
- results => 150,
- page => $f->{p}
- );
-
- $self->htmlHeader(title => 'Browse producers');
-
- div class => 'mainbox';
- h1 'Browse producers';
- form action => '/p/all', 'accept-charset' => 'UTF-8', method => 'get';
- $self->htmlSearchBox('p', $f->{q});
- end;
- p class => 'browseopts';
- for ('all', 'a'..'z', 0) {
- a href => "/p/$_", $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#';
- }
- end;
- end;
-
- my $pageurl = "/p/$char" . ($f->{q} ? "?q=$f->{q}" : '');
- $self->htmlBrowseNavigate($pageurl, $f->{p}, $np, 't');
- div class => 'mainbox producerbrowse';
- h1 $f->{q} ? 'Search results' : 'Producer list';
- if(!@$list) {
- p 'No results found';
- } else {
- # spread the results over 3 equivalent-sized lists
- my $perlist = @$list/3 < 1 ? 1 : @$list/3;
- for my $c (0..(@$list < 3 ? $#$list : 2)) {
- ul;
- for ($perlist*$c..($perlist*($c+1))-1) {
- li;
- cssicon 'lang '.$list->[$_]{lang}, $LANGUAGE{$list->[$_]{lang}};
- a href => "/p$list->[$_]{id}", title => $list->[$_]{original}, $list->[$_]{name};
- end;
- }
- end;
- }
- }
- clearfloat;
- end 'div';
- $self->htmlBrowseNavigate($pageurl, $f->{p}, $np, 'b');
- $self->htmlFooter;
-}
-
-
-# peforms a (simple) search and returns the results in XML format
-sub pxml {
- my $self = shift;
-
- my $f = $self->formValidate(
- { get => 'q', required => 0, maxlength => 500 },
- { get => 'id', required => 0, multi => 1, template => 'id' },
- { get => 'r', required => 0, template => 'uint', min => 1, max => 50, default => 10 },
- );
- return $self->resNotFound if $f->{_err} || (!$f->{q} && !$f->{id} && !$f->{id}[0]);
-
- my($list, $np) = $self->dbProducerGet(
- !$f->{q} ? () : $f->{q} =~ /^p([1-9]\d*)/ ? (id => $1) : (search => $f->{q}, sort => 'search'),
- $f->{id} && $f->{id}[0] ? (id => $f->{id}) : (),
- results => $f->{r},
- page => 1,
- );
-
- $self->resHeader('Content-type' => 'text/xml; charset=UTF-8');
- xml;
- tag 'producers', more => $np ? 'yes' : 'no', query => $f->{q}||'';
- for(@$list) {
- tag 'item', id => $_->{id}, $_->{name};
- }
- end;
-}
-
-
-1;
-
diff --git a/lib/VNDB/Handler/Releases.pm b/lib/VNDB/Handler/Releases.pm
deleted file mode 100644
index 589a685b..00000000
--- a/lib/VNDB/Handler/Releases.pm
+++ /dev/null
@@ -1,565 +0,0 @@
-
-package VNDB::Handler::Releases;
-
-use strict;
-use warnings;
-use TUWF ':html', ':xml', 'uri_escape';
-use VNDB::Func;
-use VNDB::Types;
-use Exporter 'import';
-
-our @EXPORT = ('releaseExtLinks');
-
-
-TUWF::register(
- qr{(v)([1-9]\d*)/add} => \&edit,
- qr{r} => \&browse,
- qr{r(?:([1-9]\d*)(?:\.([1-9]\d*))?/(edit|copy))}
- => \&edit,
- qr{r/engines} => \&engines,
- qr{xml/releases.xml} => \&relxml,
- qr{xml/engines.xml} => \&enginexml,
-);
-
-
-# rid = \d -> edit/copy release
-# rid = 'v' -> add release to VN with id $rev
-sub edit {
- my($self, $rid, $rev, $copy) = @_;
-
- my $vid = 0;
- $copy = $rev && $rev eq 'copy' || $copy && $copy eq 'copy';
- $rev = undef if defined $rev && $rev !~ /^\d+$/;
- if($rid eq 'v') {
- $vid = $rev;
- $rev = undef;
- $rid = 0;
- }
-
- my $r = $rid && $self->dbReleaseGetRev(id => $rid, what => 'vn extended links producers platforms media', $rev ? (rev => $rev) : ())->[0];
- return $self->resNotFound if $rid && !$r->{id};
- $rev = undef if !$r || $r->{lastrev};
-
- my $v = $vid && $self->dbVNGet(id => $vid)->[0];
- return $self->resNotFound if $vid && !$v->{id};
-
- return $self->htmlDenied if !$self->authCan('edit')
- || $rid && (($r->{locked} || $r->{hidden}) && !$self->authCan('dbmod'));
-
- my $vn = $rid ? $r->{vn} : [{ vid => $vid, title => $v->{title} }];
- my %b4 = !$rid ? () : (
- (map { $_ => $r->{$_} } (qw|type title original languages website released minage
- notes platforms patch resolution voiced freeware doujin uncensored ani_story ani_ero engine ihid ilock|,
- $copy ? () : (qw|
- gtin catalog l_steam l_dlsite l_dlsiteen l_gog l_denpa l_jlist l_digiket l_melon l_mg l_getchu l_getchudl l_itch l_jastusa l_egs l_erotrail
- |)
- )),
- $copy ? () : (
- l_gyutto => join(' ', sort @{$r->{l_gyutto}}),
- l_dmm => join(' ', sort @{$r->{l_dmm}}),
- ),
- media => join(',', sort map "$_->{medium} $_->{qty}", @{$r->{media}}),
- producers => join('|||', map
- sprintf('%d,%d,%s', $_->{id}, ($_->{developer}?1:0)+($_->{publisher}?2:0), $_->{name}),
- sort { $a->{id} <=> $b->{id} } @{$r->{producers}}
- ),
- );
- gtintype($b4{gtin}) if $b4{gtin}; # normalize gtin code
- $b4{vn} = join('|||', map "$_->{vid},$_->{title}", @$vn);
- my $frm;
-
- if($self->reqMethod eq 'POST') {
- return if !$self->authCheckCode;
- my $dmm_re = qr{(?:https?://)?(?:www|dlsoft)\.dmm\.(?:com|co\.jp)/[^\s]+};
- $frm = $self->formValidate(
- { post => 'type', enum => [ keys %RELEASE_TYPE ] },
- { post => 'patch', required => 0, default => 0 },
- { post => 'freeware', required => 0, default => 0 },
- { post => 'doujin', required => 0, default => 0 },
- { post => 'uncensored',required => 0, default => 0 },
- { post => 'title', maxlength => 250 },
- { post => 'original', required => 0, default => '', maxlength => 250 },
- { post => 'gtin', required => 0, default => '0', template => 'gtin' },
- { post => 'catalog', required => 0, default => '', maxlength => 50 },
- { post => 'languages', multi => 1, enum => [ keys %LANGUAGE ] },
- { post => 'website', required => 0, default => '', maxlength => 250, template => 'weburl' },
- { post => 'l_steam', required => 0, default => 0, template => 'uint' },
- { post => 'l_dlsite', required => 0, default => '', regex => [ qr/^[VR]J[0-9]{6}$/, 'Invalid DLsite ID' ] },
- { post => 'l_dlsiteen',required => 0, default => '', regex => [ qr/^[VR]E[0-9]{6}$/, 'Invalid DLsite ID' ] },
- { post => 'l_gog', required => 0, default => '', regex => [ qr/^[a-z0-9_]+$/, 'Invalid GOG.com ID' ] },
- { post => 'l_denpa', required => 0, default => '', regex => [ qr/^[a-z0-9-]+$/, 'Invalid Denpasoft ID' ] },
- { post => 'l_jlist', required => 0, default => '', regex => [ qr/^[a-z0-9-]+$/, 'Invalid J-List ID' ] },
- { post => 'l_gyutto', required => 0, default => '', regex => [ qr/^([0-9]+(\s+[0-9]+)*)?$/, 'Invalid Gyutto id' ] },
- { post => 'l_digiket', required => 0, default => 0, func => [ sub { $_[0] =~ s/^(?:ITM)?0+//; $_[0] =~ /^[0-9]+$/ }, 'Invalid Digiket ID' ] },
- { post => 'l_melon', required => 0, default => 0, func => [ sub { $_[0] =~ s/^(?:IT)?0+//; $_[0] =~ /^[0-9]+$/ }, 'Invalid Melonbooks.com ID' ] },
- { post => 'l_mg', required => 0, default => 0, template => 'uint' },
- { post => 'l_getchu', required => 0, default => 0, template => 'uint' },
- { post => 'l_getchudl',required => 0, default => 0, template => 'uint' },
- { post => 'l_dmm', required => 0, default => '', regex => [ qr/^($dmm_re(\s+$dmm_re)*)?$/, 'Invalid DMM URL' ] },
- { post => 'l_itch', required => 0, default => '', regex => [ qr{^(?:https?://)?([a-z0-9_-]+)\.itch\.io/([a-z0-9_-]+)$}, 'Invalid Itch.io URL' ] },
- { post => 'l_jastusa', required => 0, default => '', regex => [ qr/^[a-z0-9-]+$/, 'Invalid JAST USA ID' ] },
- { post => 'l_egs', required => 0, default => 0, template => 'uint' },
- { post => 'l_erotrail',required => 0, default => 0, template => 'uint' },
- { post => 'released', required => 0, default => 0, template => 'rdate' },
- { post => 'minage' , required => 0, default => -1, enum => [ keys %AGE_RATING ] },
- { post => 'notes', required => 0, default => '', maxlength => 10240 },
- { post => 'platforms', required => 0, default => '', multi => 1, enum => [ keys %PLATFORM ] },
- { post => 'media', required => 0, default => '' },
- { post => 'resolution',required => 0, default => 0, enum => [ keys %RESOLUTION ] },
- { post => 'voiced', required => 0, default => 0, enum => [ keys %VOICED ] },
- { post => 'ani_story', required => 0, default => 0, enum => [ keys %ANIMATED ] },
- { post => 'ani_ero', required => 0, default => 0, enum => [ keys %ANIMATED ] },
- { post => 'engine', required => 0, default => '', maxlength => 50 },
- { post => 'engine_oth',required => 0, default => '', maxlength => 50 },
- { post => 'producers', required => 0, default => '' },
- { post => 'vn', maxlength => 50000 },
- { post => 'editsum', template => 'editsum' },
- { post => 'ihid', required => 0 },
- { post => 'ilock', required => 0 },
- );
-
- $frm->{engine} = $frm->{engine_oth} if $frm->{engine} eq '_other_';
- delete $frm->{engine_oth};
-
- my $l_dmm = [ split /\s+/, $frm->{l_dmm} ];
- my $l_gyutto = [ split /\s+/, $frm->{l_gyutto} ];
-
- $frm->{original} = '' if $frm->{original} eq $frm->{title};
- $_ =~ s{^https?://}{} for @$l_dmm;
- $frm->{l_itch} =~ s{^https?://}{};
-
- push @{$frm->{_err}}, [ 'released', 'required', 1 ] if !$frm->{released};
-
- my($media, $producers, $new_vn);
- if(!$frm->{_err}) {
- # de-serialize
- $media = [ map [ split / / ], split /,/, $frm->{media} ];
- $producers = [ map { /^([0-9]+),([1-3])/ ? [ $1, $2&1?1:0, $2&2?1:0] : () } split /\|\|\|/, $frm->{producers} ];
- $new_vn = [ map { /^([0-9]+)/ ? $1 : () } split /\|\|\|/, $frm->{vn} ];
- $frm->{platforms} = [ grep $_, @{$frm->{platforms}} ];
- $frm->{$_} = $frm->{$_} ? 1 : 0 for (qw|patch freeware doujin uncensored ihid ilock|);
-
- # reset some fields when the patch flag is set
- if($frm->{patch}) {
- $frm->{doujin} = $frm->{voiced} = $frm->{ani_story} = $frm->{ani_ero} = 0;
- $frm->{resolution} = 'unknown';
- $frm->{engine} = '';
- }
- $frm->{uncensored} = 0 if $frm->{minage} != 18;
- $frm->{l_dmm} = join ' ', sort @$l_dmm;
- $frm->{l_gyutto} = join ' ', sort @$l_gyutto;
-
- my $same = $rid &&
- (join(',', sort @{$b4{platforms}}) eq join(',', sort @{$frm->{platforms}})) &&
- (join(',', map join(' ', @$_), sort { $a->[0] <=> $b->[0] } @$producers) eq join(',', map sprintf('%d %d %d',$_->{id}, $_->{developer}?1:0, $_->{publisher}?1:0), sort { $a->{id} <=> $b->{id} } @{$r->{producers}})) &&
- (join(',', sort @$new_vn) eq join(',', sort map $_->{vid}, @$vn)) &&
- (join(',', sort @{$b4{languages}}) eq join(',', sort @{$frm->{languages}})) &&
- !grep !/^(platforms|producers|vn|languages)$/ && $frm->{$_} ne $b4{$_}, keys %b4;
- return $self->resRedirect("/r$rid", 'post') if !$copy && $same;
- $frm->{_err} = [ "No changes, please don't create an entry that is fully identical to another" ] if $copy && $same;
- }
-
- if(!$frm->{_err}) {
- my $nrev = $self->dbItemEdit(r => !$copy && $rid ? ($r->{id}, $r->{rev}) : (undef, undef),
- (map { $_ => $frm->{$_} } qw| type title original gtin catalog languages website released minage
- l_steam l_dlsite l_dlsiteen l_gog l_denpa l_jlist l_digiket l_melon l_mg l_getchu l_getchudl l_itch l_jastusa l_egs l_erotrail
- notes platforms resolution editsum patch voiced freeware doujin uncensored ani_story ani_ero engine ihid ilock|),
- l_gyutto => $l_gyutto,
- l_dmm => $l_dmm,
- vn => $new_vn,
- producers => $producers,
- media => $media,
- );
-
- return $self->resRedirect("/r$nrev->{itemid}.$nrev->{rev}", 'post');
- }
- }
-
- !defined $frm->{$_} && ($frm->{$_} = $b4{$_}) for keys %b4;
- $frm->{languages} = ['ja'] if !$rid && !defined $frm->{languages};
- $frm->{editsum} = sprintf 'Reverted to revision r%d.%d', $rid, $rev if !$copy && $rev && !defined $frm->{editsum};
- $frm->{editsum} = sprintf 'New release based on r%d.%d', $rid, $r->{rev} if $copy && !defined $frm->{editsum};
- $frm->{title} = $v->{title} if !defined $frm->{title} && !$r;
- $frm->{original} = $v->{original} if !defined $frm->{original} && !$r;
-
- my $title = !$rid ? "Add release to $v->{title}" : $copy ? "Copy $r->{title}" : "Edit $r->{title}";
- $self->htmlHeader(title => $title, noindex => 1);
- $self->htmlMainTabs('r', $r, $copy ? 'copy' : 'edit') if $rid;
- $self->htmlMainTabs('v', $v, 'edit') if $vid;
- $self->htmlEditMessage('r', $r, $title, $copy);
- _listrel($self, $vid) if $vid && $self->reqMethod ne 'POST';
- _form($self, $r, $v, $frm, $copy);
- $self->htmlFooter;
-}
-
-
-sub _form {
- my($self, $r, $v, $frm, $copy) = @_;
-
- $self->htmlForm({ frm => $frm, action => $r ? "/r$r->{id}/".($copy ? 'copy' : 'edit') : "/v$v->{id}/add", editsum => 1 },
- rel_geninfo => [ 'General info',
- [ select => short => 'type', name => 'Type',
- options => [ map [ $_, $RELEASE_TYPE{$_} ], keys %RELEASE_TYPE ] ],
- [ check => short => 'patch', name => 'This release is a patch to another release.' ],
- [ check => short => 'freeware', name => 'Freeware (i.e. available at no cost)' ],
- [ check => short => 'doujin', name => 'Doujin (self-published, not by a company)' ],
- [ input => short => 'title', name => 'Title (romaji)', width => 450 ],
- [ input => short => 'original', name => 'Original title', width => 450 ],
- [ static => content => 'The original title of this release, leave blank if it already is in the Latin alphabet.' ],
- [ select => short => 'languages', name => 'Language(s)', multi => 1, size => 10,
- options => [ map [ $_, "$LANGUAGE{$_} ($_)" ], sort { $LANGUAGE{$a} cmp $LANGUAGE{$b} } keys %LANGUAGE ] ],
- [ input => short => 'gtin', name => 'JAN/UPC/EAN' ],
- [ input => short => 'catalog', name => 'Catalog number' ],
- [ input => short => 'website', name => 'Official website' ],
- [ date => short => 'released', name => 'Release date' ],
- [ static => content => 'Leave month or day blank if they are unknown' ],
- [ select => short => 'minage', name => 'Age rating',
- options => [ map [ $_, minage $_, 1 ], keys %AGE_RATING ] ],
- [ check => short => 'uncensored',name => 'No mosaic or other optical censoring (only check if this release has erotic content)' ],
-
- [ static => nolabel => 1, content => '<br><b>Links</b>' ],
- [ input => short => 'l_egs', name => 'ErogameScape', pre => 'erogamescape.dyndns.org/..?game=', width => 100 ],
- [ input => short => 'l_erotrail',name => 'ErogeTrailers', pre => 'erogetrailers.com/soft/', width => 100 ],
- [ input => short => 'l_steam', name => 'Steam AppID', pre => 'store.steampowered.com/app/', width => 100 ],
- [ input => short => 'l_jlist', name => 'J-List', pre => 'www.jlist.com/', post => ' (the last part of the URL, e.g. "np004")', width => 100 ],
- [ input => short => 'l_jastusa', name => 'JAST USA', pre => 'jastusa.com/' ],
- [ input => short => 'l_mg', name => 'MangaGamer', pre => 'mangagamer.com/..&product_code=', width => 100 ],
- [ input => short => 'l_denpa', name => 'Denpasoft', pre => 'denpasoft.com/products/' ],
- [ input => short => 'l_gog', name => 'GOG.com', pre => 'www.gog.com/game/' ],
- [ input => short => 'l_itch', name => 'Itch.io', post => ' (e.g. "author.itch.io/title")', width => 300 ],
- [ input => short => 'l_dlsiteen',name => 'DLsite (eng)', pre => 'www.dlsite.com/../product_id/', post => ' e.g. "RE083922"', width => 100 ],
- [ input => short => 'l_dlsite', name => 'DLsite (jpn)', pre => 'www.dlsite.com/../product_id/', post => ' e.g. "RJ083922"', width => 100 ],
- [ input => short => 'l_digiket', name => 'Digiket', pre => 'www.digiket.com/work/show/_data/ID=ITM', width => 100 ],
- [ input => short => 'l_gyutto', name => 'Gyutto', pre => 'gyutto.com/i/item', post => ' (item number, space separated)', width => 100 ],
- [ input => short => 'l_getchudl',name => 'DL.Getchu', pre => 'dl.getchu.com/i/item', post => ' (item number)', width => 100 ],
- [ input => short => 'l_getchu', name => 'Getchu', pre => 'www.getchu.com/soft.phtml?id=', width => 100 ],
- [ input => short => 'l_melon', name => 'Melonbooks.com', pre => 'www.melonbooks.com/..&products_id=IT', width => 100 ],
- [ input => short => 'l_dmm', name => 'DMM', post => ' (full URL, space separated)', width => 400 ],
-
- [ static => nolabel => 1, content => '<br>' ],
- [ textarea => short => 'notes', name => 'Notes<br /><b class="standout">English please!</b>' ],
- [ static => content =>
- 'Miscellaneous notes/comments, information that does not fit in the above fields.'
- .' E.g.: Types of censoring or for which releases this patch applies.' ],
- ],
-
- rel_format => [ 'Format',
- [ select => short => 'resolution', name => 'Resolution', options => [
- map [ $_, $RESOLUTION{$_}{txt}, $RESOLUTION{$_}{cat} ], keys %RESOLUTION ] ],
- [ static => label => 'Engine', content => sub {
- my $other = $frm->{engine} && !grep($_ eq $frm->{engine}, @{$self->{engines}});
- Select name => 'engine', id => 'engine', tabindex => 10;
- option value => $_, ($frm->{engine}||'') eq $_ ? (selected => 'selected') : (), $_ || 'Unknown'
- for ('', @{$self->{engines}});
- option value => '_other_', $other ? (selected => 'selected') : (), 'Other';
- end;
- input type => 'text', name => 'engine_oth', id => 'engine_oth', tabindex => 10, class => 'text '.($other ? '' : 'hidden'), value => $frm->{engine}||'';
- } ],
- [ static => content => 'Try to use a name from the <a href="/r/engines">engine list</a>.' ],
- [ select => short => 'voiced', name => 'Voiced', options => [
- map [ $_, $VOICED{$_}{txt} ], keys %VOICED ] ],
- [ select => short => 'ani_story', name => 'Story animation', options => [
- map [ $_, $ANIMATED{$_}{txt} ], keys %ANIMATED ] ],
- [ select => short => 'ani_ero', name => 'Ero animation', options => [
- map [ $_, $_ ? $ANIMATED{$_}{txt} : 'Unknown / no ero scenes' ], keys %ANIMATED ] ],
- [ static => content => 'Animation in erotic scenes, leave to unknown if there are no ero scenes.' ],
- [ hidden => short => 'media' ],
- [ static => nolabel => 1, content => sub {
- h2 'Platforms';
- div class => 'platforms';
- for my $p (sort keys %PLATFORM) {
- span;
- input type => 'checkbox', name => 'platforms', value => $p, id => $p,
- $frm->{platforms} && grep($_ eq $p, @{$frm->{platforms}}) ? (checked => 'checked') : ();
- label for => $p;
- cssicon $p, $PLATFORM{$p};
- txt ' '.$PLATFORM{$p};;
- end;
- end;
- }
- end;
-
- h2 'Media';
- div id => 'media_div', '';
- }],
- ],
-
- rel_prod => [ 'Producers',
- [ hidden => short => 'producers' ],
- [ static => nolabel => 1, content => sub {
- h2 'Selected producers';
- table; tbody id => 'producer_tbl'; end; end;
- h2 'Add producer';
- table; Tr;
- td class => 'tc_name'; input id => 'producer_input', type => 'text', class => 'text'; end;
- td class => 'tc_role'; Select id => 'producer_role';
- option value => 1, 'Developer';
- option value => 2, selected => 'selected', 'Publisher';
- option value => 3, 'Both';
- end; end;
- td class => 'tc_add'; a id => 'producer_add', href => '#', 'add'; end;
- end; end 'table';
- }],
- ],
-
- rel_vn => [ 'Visual novels',
- [ hidden => short => 'vn' ],
- [ static => nolabel => 1, content => sub {
- h2 'Selected visual novels';
- table class => 'stripe'; tbody id => 'vn_tbl'; end; end;
- h2 'Add visual novel';
- div;
- input id => 'vn_input', type => 'text', class => 'text';
- a href => '#', id => 'vn_add', 'add';
- end;
- }],
- ],
- );
-}
-
-sub _listrel {
- my($self, $vid) = @_;
- my $l = $self->dbReleaseGet(vid => $vid, hidden_only => 1, results => 50);
- return if !@$l;
- div class => 'mainbox';
- h1 'Deleted releases';
- div class => 'warning';
- p q{This visual novel has releases that have been deleted before. Please
- review this list to make sure you're not adding a release that has already
- been deleted before.};
- br;
- ul;
- for(@$l) {
- li;
- txt '['.join(',', @{$_->{languages}}).'] ';
- a href => "/r$_->{id}", title => $_->{original}||$_->{title}, "$_->{title} (r$_->{id})";
- end;
- }
- end;
- end;
- end;
-}
-
-sub browse {
- my $self = shift;
-
- my $f = $self->formValidate(
- { get => 'p', required => 0, default => 1, template => 'page' },
- { get => 'o', required => 0, default => 'a', enum => ['a', 'd'] },
- { get => 'q', required => 0, default => '', maxlength => 500 },
- { get => 's', required => 0, default => 'title', enum => [qw|released minage title|] },
- { get => 'fil',required => 0 },
- );
- return $self->resNotFound if $f->{_err};
- $f->{fil} //= $self->authPref('filter_release');
-
- my %compat = _fil_compat($self);
- my($list, $np) = !$f->{q} && !$f->{fil} && !keys %compat ? ([], 0) : $self->filFetchDB(release => $f->{fil}, \%compat, {
- sort => $f->{s}, reverse => $f->{o} eq 'd',
- page => $f->{p},
- results => 50,
- what => 'platforms',
- $f->{q} ? ( search => $f->{q} ) : (),
- });
-
- $self->htmlHeader(title => 'Browse releases');
-
- form method => 'get', action => '/r', 'accept-charset' => 'UTF-8';
- div class => 'mainbox';
- h1 'Browse releases';
- $self->htmlSearchBox('r', $f->{q});
- p class => 'filselect';
- a id => 'filselect', href => '#r';
- lit '<i>&#9656;</i> Filters<i></i>';
- end;
- end;
- input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil};
- end;
- end 'form';
-
- my $uri = sprintf '/r?q=%s;fil=%s', uri_escape($f->{q}), $f->{fil};
- $self->htmlBrowse(
- class => 'relbrowse',
- items => $list,
- options => $f,
- nextpage => $np,
- pageurl => "$uri;s=$f->{s};o=$f->{o}",
- sorturl => $uri,
- header => [
- [ 'Released', 'released' ],
- [ 'Rating', 'minage' ],
- [ '', '' ],
- [ 'Title', 'title' ],
- ],
- row => sub {
- my($s, $n, $l) = @_;
- Tr;
- td class => 'tc1';
- lit fmtdatestr $l->{released};
- end;
- td class => 'tc2', $l->{minage} < 0 ? '' : minage $l->{minage};
- td class => 'tc3';
- $_ ne 'oth' && cssicon $_, $PLATFORM{$_} for (@{$l->{platforms}});
- cssicon "lang $_", $LANGUAGE{$_} for (@{$l->{languages}});
- cssicon "rt$l->{type}", $l->{type};
- end;
- td class => 'tc4';
- a href => "/r$l->{id}", title => $l->{original}||$l->{title}, shorten $l->{title}, 90;
- b class => 'grayedout', ' (patch)' if $l->{patch};
- end;
- end 'tr';
- },
- ) if @$list;
- if(($f->{q} || $f->{fil}) && !@$list) {
- div class => 'mainbox';
- h1 'No results found';
- div class => 'notice';
- p;
- txt 'Sorry, couldn\'t find anything that comes through your filters. You might want to disable a few filters to get more results.';
- br; br;
- txt 'Also, keep in mind that we don\'t have all information about all releases.'
- .' So e.g. filtering on screen resolution will exclude all releases of which we don\'t know it\'s resolution,'
- .' even though it might in fact be in the resolution you\'re looking for.';
- end
- end;
- end;
- }
- $self->htmlFooter(pref_code => 1);
-}
-
-
-# provide compatibility with old URLs
-sub _fil_compat {
- my $self = shift;
- my %c;
- my $f = $self->formValidate(
- { get => 'ln', required => 0, multi => 1, default => '', enum => [ keys %LANGUAGE ] },
- { get => 'pl', required => 0, multi => 1, default => '', enum => [ keys %PLATFORM ] },
- { get => 'me', required => 0, multi => 1, default => '', enum => [ keys %MEDIUM ] },
- { get => 'tp', required => 0, default => '', enum => [ '', keys %RELEASE_TYPE ] },
- { get => 'pa', required => 0, default => 0, enum => [ 0..2 ] },
- { get => 'fw', required => 0, default => 0, enum => [ 0..2 ] },
- { get => 'do', required => 0, default => 0, enum => [ 0..2 ] },
- { get => 'ma_m', required => 0, default => 0, enum => [ 0, 1 ] },
- { get => 'ma_a', required => 0, default => 0, enum => [ keys %AGE_RATING ] },
- { get => 'mi', required => 0, default => 0, template => 'uint' },
- { get => 'ma', required => 0, default => 99999999, template => 'uint' },
- );
- return () if $f->{_err};
- $c{minage} = [ grep $_ >= 0 && ($f->{ma_m} ? $f->{ma_a} >= $_ : $f->{ma_a} <= $_), keys %AGE_RATING ] if $f->{ma_a} || $f->{ma_m};
- $c{date_after} = $f->{mi} if $f->{mi};
- $c{date_before} = $f->{ma} if $f->{ma} < 99990000;
- $c{plat} = $f->{pl} if $f->{pl}[0];
- $c{lang} = $f->{ln} if $f->{ln}[0];
- $c{med} = $f->{me} if $f->{me}[0];
- $c{type} = $f->{tp} if $f->{tp};
- $c{patch} = $f->{pa} == 2 ? 0 : 1 if $f->{pa};
- $c{freeware} = $f->{fw} == 2 ? 0 : 1 if $f->{fw};
- $c{doujin} = $f->{do} == 2 ? 0 : 1 if $f->{do};
- return %c;
-}
-
-
-sub engines {
- my $self = shift;
- my $lst = $self->dbReleaseEngines();
- $self->htmlHeader(title => 'Engine list', noindex => 1);
-
- div class => 'mainbox';
- h1 'Engine list';
- p;
- lit q{
- This is a list of all engines currently associated with releases. This
- list can be used as reference when filling out the engine field for a
- release and to find inconsistencies in the engine names. See the <a
- href="/d3#3">releases guidelines</a> for more information.
- };
- end;
- ul;
- for my $e (@$lst) {
- li;
- a href => '/r?fil='.fil_serialize({engine => $e->{engine}}), $e->{engine};
- b class => 'grayedout', " $e->{cnt}";
- end;
- }
- end;
-
- end;
-}
-
-
-sub relxml {
- my $self = shift;
-
- my $f = $self->formValidate(
- { get => 'v', required => 1, multi => 1, mincount => 1, template => 'id' }
- );
- return $self->resNotFound if $f->{_err};
-
- my $vns = $self->dbVNGet(id => $f->{v}, order => 'title', results => 100);
- my $rel = $self->dbReleaseGet(vid => $f->{v}, results => 100, what => 'vn');
-
- $self->resHeader('Content-type' => 'text/xml; charset=UTF-8');
- xml;
- tag 'vns';
- for my $v (@$vns) {
- tag 'vn', id => $v->{id}, title => $v->{title};
- tag 'release', id => $_->{id}, lang => join(',', @{$_->{languages}}), $_->{title}
- for (grep (grep $_->{vid} == $v->{id}, @{$_->{vn}}), @$rel);
- end;
- }
- end;
-}
-
-
-sub enginexml {
- my $self = shift;
-
- # The list of engines happens to be small enough for this to make sense, and
- # fetching all unique engines from the releases table also happens to be fast
- # enough right now, but this may need a separate cache or index in the future.
- my $lst = $self->dbReleaseEngines();
-
- my $f = $self->formValidate(
- { get => 'q', required => 1, maxlength => 500 },
- );
- return $self->resNotFound if $f->{_err};
-
- $self->resHeader('Content-type' => 'text/xml; charset=UTF-8');
- xml;
- tag 'engines';
- for(grep $lst->[$_]{engine} =~ /\Q$f->{q}\E/i, 0..$#$lst) {
- tag 'item', count => $lst->[$_]{cnt}, id => $_+1, $lst->[$_]{engine};
- }
- end;
-}
-
-
-# Generate the html for an 'external links' dropdown, assumes enrich_extlinks() has already been called on this object.
-sub releaseExtLinks {
- my($self, $r) = @_;
- my $has_dd = $r->{extlinks}->@* > ($r->{website} ? 1 : 0);
- if($r->{extlinks}->@*) {
- a href => $r->{website}||'#', class => 'rllinks';
- txt scalar $r->{extlinks}->@* if $has_dd;
- cssicon 'external', 'External link';
- end;
- if($has_dd) {
- ul class => 'hidden rllinks_dd';
- for ($r->{extlinks}->@*) {
- li;
- a href => $_->[1];
- span $_->[2] if $_->[2];
- txt $_->[0];
- end;
- end;
- };
- end;
- }
- } else {
- txt ' ';
- }
-}
-
-1;
-
diff --git a/lib/VNDB/Handler/Staff.pm b/lib/VNDB/Handler/Staff.pm
deleted file mode 100644
index adab2be8..00000000
--- a/lib/VNDB/Handler/Staff.pm
+++ /dev/null
@@ -1,116 +0,0 @@
-
-package VNDB::Handler::Staff;
-
-use strict;
-use warnings;
-use TUWF qw(:html :xml uri_escape);
-use VNDB::Func;
-use VNDB::Types;
-use List::Util qw(first);
-
-TUWF::register(
- qr{s/([a-z0]|all)} => \&list,
- qr{xml/staff\.xml} => \&staffxml,
-);
-
-
-sub list {
- my ($self, $char) = @_;
-
- my $f = $self->formValidate(
- { get => 'p', required => 0, default => 1, template => 'page' },
- { get => 'q', required => 0, default => '' },
- { get => 'fil', required => 0, default => '' },
- );
- return $self->resNotFound if $f->{_err};
-
- my ($list, $np) = $self->filFetchDB(staff => $f->{fil}, {}, {
- $char ne 'all' ? ( char => $char ) : (),
- $f->{q} ? ($f->{q} =~ /^=(.+)$/ ? (exact => $1) : (search => $f->{q})) : (),
- results => 150,
- page => $f->{p}
- });
-
- return $self->resRedirect('/s'.$list->[0]{id}, 'temp')
- if $f->{q} && @$list && (!first { $_->{id} != $list->[0]{id} } @$list) && $f->{p} == 1 && !$f->{fil};
- # redirect to the staff page if all results refer to the same entry
-
- my $quri = join(';', $f->{q} ? 'q='.uri_escape($f->{q}) : (), $f->{fil} ? "fil=$f->{fil}" : ());
- $quri = '?'.$quri if $quri;
- my $pageurl = "/s/$char$quri";
-
- $self->htmlHeader(title => 'Browse staff');
-
- form action => '/s/all', 'accept-charset' => 'UTF-8', method => 'get';
- div class => 'mainbox';
- h1 'Browse staff';
- $self->htmlSearchBox('s', $f->{q});
- p class => 'browseopts';
- for ('all', 'a'..'z', 0) {
- a href => "/s/$_$quri", $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#';
- }
- end;
-
- p class => 'filselect';
- a id => 'filselect', href => '#s';
- lit '<i>&#9656;</i> Filters<i></i>';
- end;
- end;
- input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil};
- end;
- end 'form';
-
- $self->htmlBrowseNavigate($pageurl, $f->{p}, $np, 't');
- div class => 'mainbox staffbrowse';
- h1 $f->{q} ? 'Search results' : 'Staff list';
- if(!@$list) {
- p 'No results found';
- } else {
- # spread the results over 3 equivalent-sized lists
- my $perlist = @$list/3 < 1 ? 1 : @$list/3;
- for my $c (0..(@$list < 3 ? $#$list : 2)) {
- ul;
- for ($perlist*$c..($perlist*($c+1))-1) {
- li;
- cssicon 'lang '.$list->[$_]{lang}, $LANGUAGE{$list->[$_]{lang}};
- a href => "/s$list->[$_]{id}",
- title => $list->[$_]{original}, $list->[$_]{name};
- end;
- }
- end;
- }
- }
- clearfloat;
- end 'div';
- $self->htmlBrowseNavigate($pageurl, $f->{p}, $np, 'b');
- $self->htmlFooter;
-}
-
-
-sub staffxml {
- my $self = shift;
-
- my $f = $self->formValidate(
- { get => 'q', required => 0, maxlength => 500 },
- { get => 'id', required => 0, multi => 1, template => 'id' },
- { get => 'staffid', required => 0, default => 0 }, # The returned id = staff id when set, otherwise it's the alias id
- { get => 'r', required => 0, template => 'uint', min => 1, max => 50, default => 10 },
- );
- return $self->resNotFound if $f->{_err} || (!$f->{q} && !$f->{id} && !$f->{id}[0]);
-
- my($list, $np) = $self->dbStaffGet(
- !$f->{q} ? () : $f->{q} =~ /^s([1-9]\d*)/ ? (id => $1) : $f->{q} =~ /^=(.+)/ ? (exact => $1) : (search => $f->{q}, sort => 'search'),
- $f->{id} && $f->{id}[0] ? (id => $f->{id}) : (),
- results => $f->{r}, page => 1,
- );
-
- $self->resHeader('Content-type' => 'text/xml; charset=UTF-8');
- xml;
- tag 'staff', more => $np ? 'yes' : 'no';
- for(@$list) {
- tag 'item', sid => $_->{id}, id => $f->{staffid} ? $_->{id} : $_->{aid}, orig => $_->{original}, $_->{name};
- }
- end;
-}
-
-1;
diff --git a/lib/VNDB/Handler/Tags.pm b/lib/VNDB/Handler/Tags.pm
deleted file mode 100644
index c44529cf..00000000
--- a/lib/VNDB/Handler/Tags.pm
+++ /dev/null
@@ -1,517 +0,0 @@
-
-package VNDB::Handler::Tags;
-
-
-use strict;
-use warnings;
-use TUWF ':html', ':xml', 'xml_escape';
-use VNDB::Func;
-use VNDB::Types;
-
-
-TUWF::register(
- qr{g([1-9]\d*)}, \&tagpage,
- qr{g([1-9]\d*)/(edit)}, \&tagedit,
- qr{g([1-9]\d*)/(add)}, \&tagedit,
- qr{g/new}, \&tagedit,
- qr{g/list}, \&taglist,
- qr{u([1-9]\d*)/tags}, \&usertags,
- qr{g}, \&tagindex,
- qr{g/debug}, \&fulltree,
- qr{xml/tags\.xml}, \&tagxml,
-);
-
-
-sub tagpage {
- my($self, $tag) = @_;
-
- my $t = $self->dbTagGet(id => $tag, what => 'parents(0) childs(2) aliases')->[0];
- return $self->resNotFound if !$t;
-
- my $f = $self->formValidate(
- { get => 's', required => 0, default => 'tagscore', enum => [ qw|title rel pop tagscore rating| ] },
- { get => 'o', required => 0, default => 'd', enum => [ 'a','d' ] },
- { get => 'p', required => 0, default => 1, template => 'page' },
- { get => 'm', required => 0, default => $self->authPref('spoilers') || 0, enum => [qw|0 1 2|] },
- { get => 'fil', required => 0 },
- );
- return $self->resNotFound if $f->{_err};
- $f->{fil} //= $self->authPref('filter_vn');
-
- my($list, $np) = !$t->{searchable} || $t->{state} != 2 ? ([],0) : $self->filFetchDB(vn => $f->{fil}, undef, {
- what => 'rating',
- results => 50,
- page => $f->{p},
- sort => $f->{s}, reverse => $f->{o} eq 'd',
- tagspoil => $f->{m},
- tag_inc => $tag,
- tag_exc => undef,
- });
-
- my $title = "Tag: $t->{name}";
- $self->htmlHeader(title => $title, noindex => $t->{state} != 2);
- $self->htmlMainTabs('g', $t);
-
- if($t->{state} != 2) {
- div class => 'mainbox';
- h1 $title;
- if($t->{state} == 1) {
- div class => 'warning';
- h2 'Tag deleted';
- p;
- txt 'This tag has been removed from the database, and cannot be used or re-added.';
- br;
- txt 'File a request on the ';
- a href => '/t/db', 'discussion board';
- txt ' if you disagree with this.';
- end;
- end;
- } else {
- div class => 'notice';
- h2 'Waiting for approval';
- p 'This tag is waiting for a moderator to approve it. You can still use it to tag VNs as you would with a normal tag.';
- end;
- }
- end 'div';
- }
-
- div class => 'mainbox';
- a class => 'addnew', href => "/g$tag/add", 'Create child tag' if $self->authCan('tag') && $t->{state} != 1;
- h1 $title;
-
- parenttags($t, 'Tags', 'g');
-
- if($t->{description}) {
- p class => 'description';
- lit bb2html $t->{description};
- end;
- }
- if(!$t->{applicable} || !$t->{searchable}) {
- p class => 'center';
- b 'Properties';
- br;
- txt 'Not searchable.' if !$t->{searchable};
- br;
- txt 'Can not be directly applied to visual novels.' if !$t->{applicable};
- end;
- }
- p class => 'center';
- b 'Category';
- br;
- txt $TAG_CATEGORY{$t->{cat}};
- end;
- if(@{$t->{aliases}}) {
- p class => 'center';
- b 'Aliases';
- br;
- lit xml_escape($_).'<br />' for (@{$t->{aliases}});
- end;
- }
- end 'div';
-
- childtags($self, 'Child tags', 'g', $t) if @{$t->{childs}};
-
- if($t->{searchable} && $t->{state} == 2) {
- form action => "/g$t->{id}", 'accept-charset' => 'UTF-8', method => 'get';
- div class => 'mainbox';
- a class => 'addnew', href => "/g/links?t=$tag", 'Recently tagged';
- h1 'Visual novels';
-
- p class => 'browseopts';
- a href => "/g$t->{id}?fil=$f->{fil};s=$f->{s};o=$f->{o};m=0", $f->{m} == 0 ? (class => 'optselected') : (), 'Hide spoilers';
- a href => "/g$t->{id}?fil=$f->{fil};s=$f->{s};o=$f->{o};m=1", $f->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers';
- a href => "/g$t->{id}?fil=$f->{fil};s=$f->{s};o=$f->{o};m=2", $f->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!';
- end;
-
- p class => 'filselect';
- a id => 'filselect', href => '#v';
- lit '<i>&#9656;</i> Filters<i></i>';
- end;
- end;
- input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil};
- input type => 'hidden', class => 'hidden', name => 'm', id => 'm', value => $f->{m};
-
- if(!@$list) {
- p; br; br; txt 'This tag has not been linked to any visual novels yet, or they were hidden because of your spoiler settings or default filters.'; end;
- }
- if(@{$t->{childs}}) {
- p; br; txt 'The list below also includes all visual novels linked to child tags.'; end;
- }
- end 'div';
- end 'form';
- $self->htmlBrowseVN($list, $f, $np, "/g$t->{id}?fil=$f->{fil};m=$f->{m}", 1) if @$list;
- }
-
- $self->htmlFooter(pref_code => 1);
-}
-
-
-sub tagedit {
- my($self, $tag, $act) = @_;
-
- my($frm, $par);
- if($act && $act eq 'add') {
- $par = $self->dbTagGet(id => $tag)->[0];
- return $self->resNotFound if !$par;
- $frm->{parents} = $par->{name};
- $frm->{cat} = $par->{cat};
- $tag = undef;
- }
-
- return $self->htmlDenied if !$self->authCan('tag') || $tag && !$self->authCan('tagmod');
-
- my $t = $tag && $self->dbTagGet(id => $tag, what => 'parents(1) aliases addedby')->[0];
- return $self->resNotFound if $tag && !$t;
-
- if($self->reqMethod eq 'POST') {
- return if !$self->authCheckCode;
- $frm = $self->formValidate(
- { post => 'name', required => 1, maxlength => 250, regex => [ qr/^[^,]+$/, 'A comma is not allowed in tag names' ] },
- { post => 'state', required => 0, default => 0, enum => [ 0..2 ] },
- { post => 'cat', required => 1, enum => [ keys %TAG_CATEGORY ] },
- { post => 'catrec', required => 0 },
- { post => 'searchable', required => 0, default => 0 },
- { post => 'applicable', required => 0, default => 0 },
- { post => 'alias', required => 0, maxlength => 1024, default => '', regex => [ qr/^[^,]+$/s, 'No comma allowed in aliases' ] },
- { post => 'description', required => 0, maxlength => 10240, default => '' },
- { post => 'defaultspoil',required => 0, default => 0, enum => [ 0..2 ] },
- { post => 'parents', required => !$self->authCan('tagmod'), default => '' },
- { post => 'merge', required => 0, default => '' },
- { post => 'wipevotes', required => 0, default => 0 },
- );
- my @aliases = split /[\t\s]*\n[\t\s]*/, $frm->{alias};
- my @parents = split /[\t\s]*,[\t\s]*/, $frm->{parents};
- my @merge = split /[\t\s]*,[\t\s]*/, $frm->{merge};
- if(!$frm->{_err}) {
- my @dups = @{$self->dbTagGet(name => $frm->{name}, noid => $tag)};
- push @dups, @{$self->dbTagGet(name => $_, noid => $tag)} for @aliases;
- push @{$frm->{_err}}, \sprintf 'Tag <a href="/g%d">%s</a> already exists!', $_->{id}, xml_escape $_->{name} for @dups;
- for(@parents, @merge) {
- my $c = $self->dbTagGet(name => $_, noid => $tag);
- push @{$frm->{_err}}, "Tag '$_' not found" if !@$c;
- $_ = $c->[0]{id};
- }
- }
-
- if(!$frm->{_err}) {
- if(!$self->authCan('tagmod')) {
- $frm->{state} = 0;
- $frm->{searchable} = $frm->{applicable} = 1;
- }
- my %opts = (
- name => $frm->{name},
- state => $frm->{state},
- cat => $frm->{cat},
- description => $frm->{description},
- searchable => $frm->{searchable}?1:0,
- applicable => $frm->{applicable}?1:0,
- defaultspoil => $frm->{defaultspoil},
- aliases => \@aliases,
- parents => \@parents,
- );
- if(!$tag) {
- $tag = $self->dbTagAdd(%opts);
- } else {
- $self->dbTagEdit($tag, %opts, upddate => $frm->{state} == 2 && $t->{state} != 2);
- _set_childs_cat($self, $tag, $frm->{cat}) if $frm->{catrec};
- }
- $self->dbTagWipeVotes($tag) if $self->authCan('tagmod') && $frm->{wipevotes};
- $self->dbTagMerge($tag, @merge) if $self->authCan('tagmod') && @merge;
- $self->resRedirect("/g$tag", 'post');
- return;
- }
- }
-
- if($tag) {
- $frm->{$_} ||= $t->{$_} for (qw|name searchable applicable description state cat defaultspoil|);
- $frm->{alias} ||= join "\n", @{$t->{aliases}};
- $frm->{parents} ||= join ', ', map $_->{name}, @{$t->{parents}};
- }
-
- my $title = $par ? "Add child tag to $par->{name}" : $tag ? "Edit tag: $t->{name}" : 'Add new tag';
- $self->htmlHeader(title => $title, noindex => 1);
- $self->htmlMainTabs('g', $par || $t, 'edit') if $t || $par;
-
- if(!$self->authCan('tagmod')) {
- div class => 'mainbox';
- h1 'Requesting new tag';
- div class => 'notice';
- h2 'Your tag must be approved';
- p;
- txt 'Because all tags have to be approved by moderators, it can take a while before it will show up in the tag list'
- .' or on visual novel pages. You can still vote on tag even if it has not been approved yet, though.';
- br; br;
- txt 'Also, make sure you\'ve read the ';
- a href => '/d10', 'guidelines';
- txt ' so you can predict whether your tag will be accepted or not.';
- end;
- end;
- end;
- }
-
- $self->htmlForm({ frm => $frm, action => $par ? "/g$par->{id}/add" : $tag ? "/g$tag/edit" : '/g/new' }, 'tagedit' => [ $title,
- [ input => short => 'name', name => 'Primary name' ],
- $self->authCan('tagmod') ? (
- $tag ?
- [ static => label => 'Added by', content => sub { VNWeb::HTML::user_($t); '' } ] : (),
- [ select => short => 'state', name => 'State', options => [
- [0, 'Awaiting moderation'], [1, 'Deleted/hidden'], [2, 'Approved'] ] ],
- [ checkbox => short => 'searchable', name => 'Searchable (people can use this tag to filter VNs)' ],
- [ checkbox => short => 'applicable', name => 'Applicable (people can apply this tag to VNs)' ],
- ) : (),
- [ select => short => 'cat', name => 'Category', options => [
- map [$_, $TAG_CATEGORY{$_}], keys %TAG_CATEGORY ] ],
- $self->authCan('tagmod') && $tag ? (
- [ checkbox => short => 'catrec', name => 'Also edit all child tags to have this category' ],
- [ static => content => 'WARNING: This will overwrite the category field for all child tags, this action can not be reverted!' ],
- ) : (),
- [ textarea => short => 'alias', name => "Aliases\n(separated by newlines)", cols => 30, rows => 4 ],
- [ textarea => short => 'description', name => 'Description' ],
- [ static => content => 'What should the tag be used for? Having a good description helps users choose which tags to link to a VN.' ],
- [ select => short => 'defaultspoil', name => 'Default spoiler level', options => [ map [$_, fmtspoil $_], 0..2 ] ],
- [ static => content => 'This is the spoiler level that will be used by default when everyone has voted "neutral".' ],
- [ input => short => 'parents', name => 'Parent tags' ],
- [ static => content => 'Comma separated list of tag names to be used as parent for this tag.' ],
- $self->authCan('tagmod') ? (
- [ part => title => 'DANGER: Merge tags' ],
- [ input => short => 'merge', name => 'Tags to merge' ],
- [ static => content =>
- 'Comma separated list of tag names to merge into this one.'
- .' All votes and aliases/names will be moved over to this tag, and the old tags will be deleted.'
- .' Just leave this field empty if you don\'t intend to do a merge.'
- .'<br />WARNING: this action cannot be undone!' ],
-
- [ part => title => 'DANGER: Delete tag votes' ],
- [ checkbox => short => 'wipevotes', name => 'Remove all votes on this tag. WARNING: cannot be undone!' ],
- ) : (),
- ]);
- $self->htmlFooter;
-}
-
-# recursively edit all child tags and set the category field
-# Note: this can be done more efficiently by doing everything in one UPDATE
-# query, but that takes more code and this feature isn't used very often
-# anyway.
-sub _set_childs_cat {
- my($self, $tag, $cat) = @_;
- my %done;
-
- my $e;
- $e = sub {
- my $l = shift;
- for (@$l) {
- $self->dbTagEdit($_->{id}, cat => $cat) if !$done{$_->{id}}++;
- $e->($_->{sub}) if $_->{sub};
- }
- };
-
- my $childs = $self->dbTTTree(tag => $tag, 25);
- $e->($childs);
-}
-
-
-sub taglist {
- my $self = shift;
-
- my $f = $self->formValidate(
- { get => 's', required => 0, default => 'name', enum => ['added', 'name'] },
- { get => 'o', required => 0, default => 'a', enum => ['a', 'd'] },
- { get => 'p', required => 0, default => 1, template => 'page' },
- { get => 't', required => 0, default => -1, enum => [ -1..2 ] },
- { get => 'q', required => 0, default => '' },
- );
- return $self->resNotFound if $f->{_err};
-
- my($t, $np) = $self->dbTagGet(
- sort => $f->{s}, reverse => $f->{o} eq 'd',
- page => $f->{p},
- results => 50,
- state => $f->{t},
- search => $f->{q}
- );
-
- $self->htmlHeader(title => 'Browse tags');
- div class => 'mainbox';
- h1 'Browse tags';
- form action => '/g/list', 'accept-charset' => 'UTF-8', method => 'get';
- input type => 'hidden', name => 't', value => $f->{t};
- $self->htmlSearchBox('g', $f->{q});
- end;
- p class => 'browseopts';
- a href => "/g/list?q=$f->{q};t=-1", $f->{t} == -1 ? (class => 'optselected') : (), 'All';
- a href => "/g/list?q=$f->{q};t=0", $f->{t} == 0 ? (class => 'optselected') : (), 'Awaiting moderation';
- a href => "/g/list?q=$f->{q};t=1", $f->{t} == 1 ? (class => 'optselected') : (), 'Deleted';
- a href => "/g/list?q=$f->{q};t=2", $f->{t} == 2 ? (class => 'optselected') : (), 'Accepted';
- end;
- if(!@$t) {
- p 'No results found';
- }
- end 'div';
- if(@$t) {
- $self->htmlBrowse(
- class => 'taglist',
- options => $f,
- nextpage => $np,
- items => $t,
- pageurl => "/g/list?t=$f->{t};q=$f->{q};s=$f->{s};o=$f->{o}",
- sorturl => "/g/list?t=$f->{t};q=$f->{q}",
- header => [
- [ 'Created', 'added' ],
- [ 'Tag', 'name' ],
- ],
- row => sub {
- my($s, $n, $l) = @_;
- Tr;
- td class => 'tc1', fmtage $l->{added};
- td class => 'tc3';
- a href => "/g$l->{id}", $l->{name};
- if($f->{t} == -1) {
- b class => 'grayedout', ' awaiting moderation' if $l->{state} == 0;
- b class => 'grayedout', ' deleted' if $l->{state} == 1;
- }
- end;
- end 'tr';
- }
- );
- }
- $self->htmlFooter;
-}
-
-
-sub tagindex {
- my $self = shift;
-
- $self->htmlHeader(title => 'Tag index');
- div class => 'mainbox';
- a class => 'addnew', href => "/g/new", 'Create new tag' if $self->authCan('tag');
- h1 'Search tags';
- form action => '/g/list', 'accept-charset' => 'UTF-8', method => 'get';
- $self->htmlSearchBox('g', '');
- end;
- end;
-
- my $t = $self->dbTTTree(tag => 0, 2);
- childtags($self, 'Tag tree', 'g', {childs => $t});
-
- table class => 'mainbox threelayout';
- Tr;
-
- # Recently added
- td;
- a class => 'right', href => '/g/list', 'Browse all tags';
- my $r = $self->dbTagGet(sort => 'added', reverse => 1, results => 10, state => 2);
- h1 'Recently added';
- ul;
- for (@$r) {
- li;
- txt fmtage $_->{added};
- txt ' ';
- a href => "/g$_->{id}", $_->{name};
- end;
- }
- end;
- end;
-
- # Popular
- td;
- a class => 'addnew', href => "/g/links", 'Recently tagged';
- $r = $self->dbTagGet(sort => 'items', reverse => 1, searchable => 1, applicable => 1, results => 10);
- h1 'Popular tags';
- ul;
- for (@$r) {
- li;
- a href => "/g$_->{id}", $_->{name};
- txt " ($_->{c_items})";
- end;
- }
- end;
- end;
-
- # Moderation queue
- td;
- h1 'Awaiting moderation';
- $r = $self->dbTagGet(state => 0, sort => 'added', reverse => 1, results => 10);
- ul;
- li 'Moderation queue empty! yay!' if !@$r;
- for (@$r) {
- li;
- txt fmtage $_->{added};
- txt ' ';
- a href => "/g$_->{id}", $_->{name};
- end;
- }
- li;
- br;
- a href => '/g/list?t=0;o=d;s=added', 'Moderation queue';
- txt ' - ';
- a href => '/g/list?t=1;o=d;s=added', 'Denied tags';
- end;
- end;
- end;
-
- end 'tr';
- end 'table';
- $self->htmlFooter;
-}
-
-
-# non-translatable debug page
-sub fulltree {
- my $self = shift;
- return $self->htmlDenied if !$self->authCan('tagmod');
-
- my $e;
- $e = sub {
- my $lst = shift;
- ul style => 'list-style-type: none; margin-left: 15px';
- for (@$lst) {
- li;
- txt '> ';
- a href => "/g$_->{id}", $_->{name};
- b class => 'grayedout', " ($_->{c_items})" if $_->{c_items};
- end;
- $e->($_->{sub}) if $_->{sub};
- }
- end;
- };
-
- my $tags = $self->dbTTTree(tag => 0, 25);
- $self->htmlHeader(title => '[DEBUG] Tag tree', noindex => 1);
- div class => 'mainbox';
- h1 '[DEBUG] Tag tree';
- $e->($tags);
- end;
- $self->htmlFooter;
-}
-
-
-sub tagxml {
- my $self = shift;
-
- my $f = $self->formValidate(
- { get => 'q', required => 0, maxlength => 500 },
- { get => 'id', required => 0, multi => 1, template => 'id' },
- { get => 'searchable', required => 0, default => 0 },
- { get => 'r', required => 0, template => 'uint', min => 1, max => 50, default => 15 },
- );
- return $self->resNotFound if $f->{_err} || (!$f->{q} && !$f->{id} && !$f->{id}[0]);
-
- my($list, $np) = $self->dbTagGet(
- !$f->{q} ? () : $f->{q} =~ /^g([1-9]\d*)/ ? (id => $1) : $f->{q} =~ /^=(.+)$/ ? (name => $1) : (search => $f->{q}, sort => 'search'),
- $f->{id} && $f->{id}[0] ? (id => $f->{id}) : (),
- results => $f->{r},
- page => 1,
- $f->{searchable} ? (state => 2, searchable => 1) : (),
- );
-
- $self->resHeader('Content-type' => 'text/xml; charset=UTF-8');
- xml;
- tag 'tags', more => $np ? 'yes' : 'no', $f->{q} ? (query => $f->{q}) : ();
- for(@$list) {
- tag 'item', id => $_->{id}, searchable => $_->{searchable} ? 'yes' : 'no', applicable => $_->{applicable} ? 'yes' : 'no', state => $_->{state}, $_->{name};
- }
- end;
-}
-
-
-1;
diff --git a/lib/VNDB/Handler/Traits.pm b/lib/VNDB/Handler/Traits.pm
deleted file mode 100644
index f9802cff..00000000
--- a/lib/VNDB/Handler/Traits.pm
+++ /dev/null
@@ -1,457 +0,0 @@
-
-package VNDB::Handler::Traits;
-
-use strict;
-use warnings;
-use TUWF ':html', ':xml', 'html_escape', 'xml_escape';
-use VNDB::Func;
-
-
-TUWF::register(
- qr{i([1-9]\d*)}, \&traitpage,
- qr{i([1-9]\d*)/(edit)}, \&traitedit,
- qr{i([1-9]\d*)/(add)}, \&traitedit,
- qr{i/new}, \&traitedit,
- qr{i/list}, \&traitlist,
- qr{i}, \&traitindex,
- qr{xml/traits\.xml}, \&traitxml,
-);
-
-
-sub traitpage {
- my($self, $trait) = @_;
-
- my $t = $self->dbTraitGet(id => $trait, what => 'parents(0) childs(2)')->[0];
- return $self->resNotFound if !$t;
-
- my $f = $self->formValidate(
- { get => 'p', required => 0, default => 1, template => 'page' },
- { get => 'm', required => 0, default => $self->authPref('spoilers')||0, enum => [qw|0 1 2|] },
- { get => 'fil', required => 0, default => '' },
- );
- return $self->resNotFound if $f->{_err};
-
- my $title = "Trait: $t->{name}";
- $self->htmlHeader(title => $title, noindex => $t->{state} != 2);
- $self->htmlMainTabs('i', $t);
-
- if($t->{state} != 2) {
- div class => 'mainbox';
- h1 $title;
- if($t->{state} == 1) {
- div class => 'warning';
- h2 'Trait deleted';
- p;
- txt 'This trait has been removed from the database, and cannot be used or re-added. File a request on the ';
- a href => '/t/db', 'discussion board';
- txt ' if you disagree with this.';
- end;
- end;
- } else {
- div class => 'notice';
- h2 'Waiting for approval';
- p 'This trait is waiting for a moderator to approve it.';
- end;
- }
- end 'div';
- }
-
- div class => 'mainbox';
- a class => 'addnew', href => "/i$trait/add", 'Create child trait' if $self->authCan('edit') && $t->{state} != 1;
- h1 $title;
-
- parenttags($t, 'Traits', 'i');
-
- if($t->{description}) {
- p class => 'description';
- lit bb2html $t->{description};
- end;
- }
- if(!$t->{applicable} || !$t->{searchable}) {
- p class => 'center';
- b 'Properties';
- br;
- txt 'Not searchable.' if !$t->{searchable};
- br;
- txt 'Can not be directly applied to characters.' if !$t->{applicable};
- end;
- }
- if($t->{sexual}) {
- p class => 'center';
- b 'Sexual content';
- end;
- }
- if($t->{alias}) {
- p class => 'center';
- b 'Aliases';
- br;
- lit html_escape($t->{alias});
- end;
- }
- end 'div';
-
- childtags($self, 'Child traits', 'i', $t) if @{$t->{childs}};
-
- if($t->{searchable} && $t->{state} == 2) {
- my($chars, $np) = $self->filFetchDB(char => $f->{fil}, {}, {
- trait_inc => $trait,
- tagspoil => $f->{m},
- results => 50,
- page => $f->{p},
- what => 'vns',
- });
-
- form action => "/i$t->{id}", 'accept-charset' => 'UTF-8', method => 'get';
- div class => 'mainbox';
- h1 'Characters';
-
- p class => 'browseopts';
- a href => "/i$trait?fil=$f->{fil};m=0", $f->{m} == 0 ? (class => 'optselected') : (), 'Hide spoilers';
- a href => "/i$trait?fil=$f->{fil};m=1", $f->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers';
- a href => "/i$trait?fil=$f->{fil};m=2", $f->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!';
- end;
-
- p class => 'filselect';
- a id => 'filselect', href => '#c';
- lit '<i>&#9656;</i> Filters<i></i>';
- end;
- end;
- input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil};
- input type => 'hidden', class => 'hidden', name => 'm', id => 'm', value => $f->{m};
-
- if(!@$chars) {
- p; br; br; txt 'This trait has not been linked to any characters yet, or they were hidden because of your spoiler settings.'; end;
- }
- if(@{$t->{childs}}) {
- p; br; txt 'The list below also includes all characters linked to child traits.'; end;
- }
- end 'div';
- end 'form';
- @$chars && $self->charBrowseTable($chars, $np, $f, "/i$trait?m=$f->{m};fil=$f->{fil}");
- }
-
- $self->htmlFooter;
-}
-
-
-sub traitedit {
- my($self, $trait, $act) = @_;
-
- my($frm, $par);
- if($act && $act eq 'add') {
- $par = $self->dbTraitGet(id => $trait)->[0];
- return $self->resNotFound if !$par;
- $frm->{parents} = $par->{id};
- $trait = undef;
- }
-
- return $self->htmlDenied if !$self->authCan('edit') || $trait && !$self->authCan('tagmod');
-
- my $t = $trait && $self->dbTraitGet(id => $trait, what => 'parents(1) addedby')->[0];
- return $self->resNotFound if $trait && !$t;
-
- if($self->reqMethod eq 'POST') {
- return if !$self->authCheckCode;
- $frm = $self->formValidate(
- { post => 'name', required => 1, maxlength => 250, regex => [ qr/^[^,]+$/, 'A comma is not allowed in trait names' ] },
- { post => 'state', required => 0, default => 0, enum => [ 0..2 ] },
- { post => 'searchable', required => 0, default => 0 },
- { post => 'applicable', required => 0, default => 0 },
- { post => 'sexual', required => 0, default => 0 },
- { post => 'alias', required => 0, maxlength => 1024, default => '', regex => [ qr/^[^,]+$/s, 'No comma allowed in aliases' ] },
- { post => 'description', required => 0, maxlength => 10240, default => '' },
- { post => 'parents', required => !$self->authCan('tagmod'), default => '', regex => [ qr/^(?:$|(?:[1-9]\d*)(?: +[1-9]\d*)*)$/, 'Parent traits must be a space-separated list of trait IDs' ] },
- { post => 'order', required => 0, default => 0, template => 'uint' },
- { post => 'defaultspoil',required => 0, default => 0, enum => [0..2] },
- );
- my @parents = split /[\t ]+/, $frm->{parents};
- my $group = undef;
- if(!$frm->{_err}) {
- for(@parents) {
- my $c = $self->dbTraitGet(id => $_);
- push @{$frm->{_err}}, "Trait '$_' not found" if !@$c;
- $group //= $c->[0]{group}||$c->[0]{id} if @$c;
- }
- }
- if(!$frm->{_err}) {
- my @dups = @{$self->dbTraitGet(name => $frm->{name}, noid => $trait, group => $group)};
- push @dups, @{$self->dbTraitGet(name => $_, noid => $trait, group => $group)} for split /[\t\s]*\n[\t\s]*/, $frm->{alias};
- push @{$frm->{_err}}, \sprintf 'Trait <a href="/i%d">%s</a> already exists within the same group.', $_->{id}, xml_escape $_->{name} for @dups;
- }
-
- if(!$frm->{_err}) {
- if(!$self->authCan('tagmod')) {
- $frm->{state} = 0;
- $frm->{applicable} = $frm->{searchable} = 1;
- }
- my %opts = (
- name => $frm->{name},
- state => $frm->{state},
- description => $frm->{description},
- searchable => $frm->{searchable}?1:0,
- applicable => $frm->{applicable}?1:0,
- sexual => $frm->{sexual}?1:0,
- alias => $frm->{alias},
- order => $frm->{order},
- defaultspoil => $frm->{defaultspoil},
- parents => \@parents,
- group => $group,
- );
- if(!$trait) {
- $trait = $self->dbTraitAdd(%opts);
- } else {
- $self->dbTraitEdit($trait, %opts, upddate => $frm->{state} == 2 && $t->{state} != 2) if $trait;
- _set_childs_group($self, $trait, $group||$trait) if ($group||0) != ($t->{group}||0);
- }
- $self->resRedirect("/i$trait", 'post');
- return;
- }
- }
-
- if($t) {
- $frm->{$_} ||= $t->{$_} for (qw|name searchable applicable sexual description state alias order defaultspoil|);
- $frm->{parents} ||= join ' ', map $_->{id}, @{$t->{parents}};
- }
-
- my $title = $par ? "Add child trait to $par->{name}" : $t ? "Edit trait: $t->{name}" : 'Add new trait';
- $self->htmlHeader(title => $title, noindex => 1);
- $self->htmlMainTabs('i', $par || $t, 'edit') if $t || $par;
-
- if(!$self->authCan('tagmod')) {
- div class => 'mainbox';
- h1 'Requesting new trait';
- div class => 'notice';
- h2 'Your trait must be approved';
- p;
- lit 'Because all traits have to be approved by moderators, it can take a while before your trait will show up in the listings or can be used on character entries.';
- end;
- end;
- end;
- }
-
- $self->htmlForm({ frm => $frm, action => $par ? "/i$par->{id}/add" : $t ? "/i$trait/edit" : '/i/new' }, 'traitedit' => [ $title,
- [ input => short => 'name', name => 'Primary name' ],
- $self->authCan('tagmod') ? (
- $t ?
- [ static => label => 'Added by', content => sub { VNWeb::HTML::user_($t); '' } ] : (),
- [ select => short => 'state', name => 'State', options => [
- [0,'Awaiting moderation'], [1,'Deleted/hidden'], [2,'Approved'] ] ],
- [ checkbox => short => 'searchable', name => 'Searchable (people can use this trait to filter characters)' ],
- [ checkbox => short => 'applicable', name => 'Applicable (people can apply this trait to characters)' ],
- ) : (),
- [ checkbox => short => 'sexual', name => 'Indicates sexual content' ],
- [ textarea => short => 'alias', name => "Aliases\n(Separated by newlines)", cols => 30, rows => 4 ],
- [ textarea => short => 'description', name => 'Description' ],
- [ select => short => 'defaultspoil', name => 'Default spoiler level', options => [ map [$_, fmtspoil $_], 0..2 ] ],
- [ static => content => 'This is the spoiler level that will be selected by default when adding this trait to a character.' ],
- [ input => short => 'parents', name => 'Parent traits' ],
- [ static => content => 'List of trait IDs to be used as parent for this trait, separated by a space.' ],
- $self->authCan('tagmod') ? (
- [ input => short => 'order', name => 'Group number', width => 50, post => ' (Only used if this trait is a group. Used for ordering, lowest first)' ],
- ) : (),
- ]);
-
- $self->htmlFooter;
-}
-
-# recursively edit all child traits and set the group field
-sub _set_childs_group {
- my($self, $trait, $group) = @_;
- my %done;
-
- my $e;
- $e = sub {
- my $l = shift;
- for (@$l) {
- $self->dbTraitEdit($_->{id}, group => $group) if !$done{$_->{id}}++;
- $e->($_->{sub}) if $_->{sub};
- }
- };
- $e->($self->dbTTTree(trait => $trait, 25));
-}
-
-
-sub traitlist {
- my $self = shift;
-
- my $f = $self->formValidate(
- { get => 's', required => 0, default => 'name', enum => ['added', 'name'] },
- { get => 'o', required => 0, default => 'a', enum => ['a', 'd'] },
- { get => 'p', required => 0, default => 1, template => 'page' },
- { get => 't', required => 0, default => -1, enum => [ -1..2 ] },
- { get => 'q', required => 0, default => '' },
- );
- return $self->resNotFound if $f->{_err};
-
- my($t, $np) = $self->dbTraitGet(
- sort => $f->{s}, reverse => $f->{o} eq 'd',
- page => $f->{p},
- results => 50,
- state => $f->{t},
- search => $f->{q}
- );
-
- $self->htmlHeader(title => 'Browse traits');
- div class => 'mainbox';
- h1 'Browse traits';
- form action => '/i/list', 'accept-charset' => 'UTF-8', method => 'get';
- input type => 'hidden', name => 't', value => $f->{t};
- $self->htmlSearchBox('i', $f->{q});
- end;
- p class => 'browseopts';
- a href => "/i/list?q=$f->{q};t=-1", $f->{t} == -1 ? (class => 'optselected') : (), 'All';
- a href => "/i/list?q=$f->{q};t=0", $f->{t} == 0 ? (class => 'optselected') : (), 'Awaiting moderation';
- a href => "/i/list?q=$f->{q};t=1", $f->{t} == 1 ? (class => 'optselected') : (), 'Deleted';
- a href => "/i/list?q=$f->{q};t=2", $f->{t} == 2 ? (class => 'optselected') : (), 'Accepted';
- end;
- if(!@$t) {
- p 'No results found';
- }
- end 'div';
- if(@$t) {
- $self->htmlBrowse(
- class => 'taglist',
- options => $f,
- nextpage => $np,
- items => $t,
- pageurl => "/i/list?t=$f->{t};q=$f->{q};s=$f->{s};o=$f->{o}",
- sorturl => "/i/list?t=$f->{t};q=$f->{q}",
- header => [
- [ 'Created', 'added' ],
- [ 'Trait', 'name' ],
- ],
- row => sub {
- my($s, $n, $l) = @_;
- Tr;
- td class => 'tc1', fmtage $l->{added};
- td class => 'tc3';
- if($l->{group}) {
- b class => 'grayedout', $l->{groupname}.' / ';
- }
- a href => "/i$l->{id}", $l->{name};
- if($f->{t} == -1) {
- b class => 'grayedout', ' awaiting moderation' if $l->{state} == 0;
- b class => 'grayedout', ' deleted' if $l->{state} == 1;
- }
- end;
- end 'tr';
- }
- );
- }
- $self->htmlFooter;
-}
-
-
-sub traitindex {
- my $self = shift;
-
- $self->htmlHeader(title => 'Trait index');
- div class => 'mainbox';
- a class => 'addnew', href => "/i/new", 'Create new trait' if $self->authCan('edit');
- h1 'Search traits';
- form action => '/i/list', 'accept-charset' => 'UTF-8', method => 'get';
- $self->htmlSearchBox('i', '');
- end;
- end;
-
- my $t = $self->dbTTTree(trait => 0, 2);
- childtags($self, 'Trait tree', 'i', {childs => $t}, 'order');
-
- table class => 'mainbox threelayout';
- Tr;
-
- # Recently added
- td;
- a class => 'right', href => '/i/list', 'Browse all traits';
- my $r = $self->dbTraitGet(sort => 'added', reverse => 1, results => 10);
- h1 'Recently added';
- ul;
- for (@$r) {
- li;
- txt fmtage $_->{added};
- txt ' ';
- b class => 'grayedout', $_->{groupname}.' / ' if $_->{group};
- a href => "/i$_->{id}", $_->{name};
- end;
- }
- end;
- end;
-
- # Popular
- td;
- h1 'Popular traits';
- ul;
- $r = $self->dbTraitGet(sort => 'items', reverse => 1, results => 10);
- for (@$r) {
- li;
- b class => 'grayedout', $_->{groupname}.' / ' if $_->{group};
- a href => "/i$_->{id}", $_->{name};
- txt " ($_->{c_items})";
- end;
- }
- end;
- end;
-
- # Moderation queue
- td;
- h1 'Awaiting moderation';
- $r = $self->dbTraitGet(state => 0, sort => 'added', reverse => 1, results => 10);
- ul;
- li 'Moderation queue empty! yay!' if !@$r;
- for (@$r) {
- li;
- txt fmtage $_->{added};
- txt ' ';
- b class => 'grayedout', $_->{groupname}.' / ' if $_->{group};
- a href => "/i$_->{id}", $_->{name};
- end;
- }
- li;
- br;
- a href => '/i/list?t=0;o=d;s=added', 'Moderation queue';
- txt ' - ';
- a href => '/i/list?t=1;o=d;s=added', 'Denied traits';
- end;
- end;
- end;
-
- end 'tr';
- end 'table';
- $self->htmlFooter;
-}
-
-
-sub traitxml {
- my $self = shift;
-
- my $f = $self->formValidate(
- { get => 'q', required => 0, maxlength => 500 },
- { get => 'id', required => 0, multi => 1, template => 'id' },
- { get => 'r', required => 0, default => 15, template => 'uint', min => 1, max => 200 },
- { get => 'searchable', required => 0, default => 0 },
- );
- return $self->resNotFound if $f->{_err} || (!$f->{q} && !$f->{id} && !$f->{id}[0]);
-
- my($list, $np) = $self->dbTraitGet(
- results => $f->{r},
- page => 1,
- sort => 'group',
- state => 2,
- $f->{searchable} ? (searchable => 1) : (),
- !$f->{q} ? () : $f->{q} =~ /^i([1-9]\d*)/ ? (id => $1) : (search => $f->{q}, sort => 'search'),
- $f->{id} && $f->{id}[0] ? (id => $f->{id}) : (),
- );
-
- $self->resHeader('Content-type' => 'text/xml; charset=UTF-8');
- xml;
- tag 'traits', more => $np ? 'yes' : 'no';
- for(@$list) {
- tag 'item', id => $_->{id}, searchable => $_->{searchable} ? 'yes' : 'no', applicable => $_->{applicable} ? 'yes' : 'no', group => $_->{group}||'',
- groupname => $_->{groupname}||'', state => $_->{state}, defaultspoil => $_->{defaultspoil}, $_->{name};
- }
- end;
-}
-
-
-1;
-
diff --git a/lib/VNDB/Handler/ULists.pm b/lib/VNDB/Handler/ULists.pm
deleted file mode 100644
index 03c079b1..00000000
--- a/lib/VNDB/Handler/ULists.pm
+++ /dev/null
@@ -1,51 +0,0 @@
-
-package VNDB::Handler::ULists;
-
-use strict;
-use warnings;
-use TUWF ':xml';
-use VNDB::Func;
-use VNDB::Types;
-
-
-TUWF::register(
- qr{r([1-9]\d*)/list}, \&rlist_e,
- qr{xml/rlist.xml}, \&rlist_e,
-);
-
-
-sub rlist_e {
- my($self, $id) = @_;
-
- my $rid = $id;
- if(!$rid) {
- my $f = $self->formValidate({ get => 'id', required => 1, template => 'id' });
- return $self->resNotFound if $f->{_err};
- $rid = $f->{id};
- }
-
- my $uid = $self->authInfo->{id};
- return $self->htmlDenied() if !$uid;
-
- return if !$self->authCheckCode;
- my $f = $self->formValidate(
- { get => 'e', required => 1, enum => [ -1, keys %RLIST_STATUS ] },
- { get => 'ref', required => 0, default => "/r$rid" }
- );
- return $self->resNotFound if $f->{_err};
-
- $self->dbRListDel($uid, $rid) if $f->{e} == -1;
- $self->dbRListAdd($uid, $rid, $f->{e}) if $f->{e} >= 0;
-
- if($id) {
- $self->resRedirect($f->{ref}, 'temp');
- } else {
- # doesn't really matter what we return, as long as it's XML
- $self->resHeader('Content-type' => 'text/xml');
- xml;
- tag 'done', '';
- }
-}
-
-1;
-
diff --git a/lib/VNDB/Handler/VNBrowse.pm b/lib/VNDB/Handler/VNBrowse.pm
deleted file mode 100644
index 64cc57d4..00000000
--- a/lib/VNDB/Handler/VNBrowse.pm
+++ /dev/null
@@ -1,143 +0,0 @@
-
-package VNDB::Handler::VNBrowse;
-
-use strict;
-use warnings;
-use TUWF ':html', 'uri_escape';
-use VNDB::Func;
-use VNDB::Types;
-
-
-TUWF::register(
- qr{v/([a-z0]|all)} => \&list,
-);
-
-
-sub list {
- my($self, $char) = @_;
-
- my $f = $self->formValidate(
- { get => 's', required => 0, default => 'tagscore', enum => [ qw|title rel pop tagscore rating| ] },
- { get => 'o', required => 0, enum => [ 'a','d' ] },
- { get => 'p', required => 0, default => 1, template => 'page' },
- { get => 'q', required => 0, default => '' },
- { get => 'sq', required => 0, default => '' },
- { get => 'fil',required => 0 },
- { get => 'rfil', required => 0, default => '' },
- { get => 'cfil', required => 0, default => '' },
- { get => 'vnlist', required => 0, default => 2, enum => [ '0', '1' ] }, # 2: use pref
- );
- return $self->resNotFound if $f->{_err};
- $f->{q} ||= $f->{sq};
- $f->{fil} //= $self->authPref('filter_vn');
- my %compat = _fil_compat($self);
- my $uid = $self->authInfo->{id};
-
- my $read_write_pref = sub {
- my($type, $pref_name) = @_;
-
- return 0 if !$uid; # no data to display anyway
- return $self->authPref($pref_name)?1:0 if $f->{$type} == 2;
-
- $self->authPref($pref_name => $f->{$type}?1:0) if ($self->authPref($pref_name)?1:0) != $f->{$type};
- return $f->{$type};
- };
-
- $f->{vnlist} = $read_write_pref->('vnlist', 'vn_list_own');
-
- return $self->resRedirect('/'.$1.$2.(!$3 ? '' : $1 eq 'd' ? '#'.$3 : '.'.$3), 'temp')
- if $f->{q} && $f->{q} =~ /^([gvrptudcis])([0-9]+)(?:\.([0-9]+))?$/;
-
- $f->{s} = 'title' if $f->{fil} !~ /tag_inc-/ && $f->{s} eq 'tagscore';
- $f->{o} = $f->{s} eq 'tagscore' ? 'd' : 'a' if !$f->{o};
-
- my $rfil = fil_parse $f->{rfil}, @{$VNDB::Util::Misc::filfields{release}};
- $self->filCompat(release => $rfil);
- $f->{rfil} = fil_serialize $rfil, @{$VNDB::Util::Misc::filfields{release}};
-
- my $cfil = fil_parse $f->{cfil}, @{$VNDB::Util::Misc::filfields{char}};
- $cfil->{tagspoil} //= $self->authPref('spoilers')||0 if keys %$cfil;
-
- my($list, $np) = $self->filFetchDB(vn => $f->{fil}, {
- %compat,
- tagspoil => $self->authPref('spoilers')||0,
- }, {
- what => ' rating'.($f->{vnlist} ? ' vnlist' : ''),
- $char ne 'all' ? ( char => $char ) : (),
- $f->{q} ? ( search => $f->{q} ) : (),
- keys %$rfil ? ( release => $rfil ) : (),
- keys %$cfil ? ( character => $cfil ) : (),
- results => 50,
- page => $f->{p},
- sort => $f->{s}, reverse => $f->{o} eq 'd',
- });
-
- $self->resRedirect('/v'.$list->[0]{id}, 'temp')
- if $f->{q} && @$list == 1 && $f->{p} == 1;
-
- $self->htmlHeader(title => 'Browse visual novels', search => $f->{q});
-
- my $quri = uri_escape($f->{q});
- form action => '/v/all', 'accept-charset' => 'UTF-8', method => 'get';
-
- # url generator
- my $url = sub {
- my($char, $toggle) = @_;
-
- return "/v/$char?q=$quri;fil=$f->{fil};rfil=$f->{rfil};cfil=$f->{cfil};s=$f->{s};o=$f->{o}" .
- ($toggle ? ";$toggle=".($f->{$toggle}?0:1) : '');
- };
-
- div class => 'mainbox';
- h1 'Browse visual novels';
- $self->htmlSearchBox('v', $f->{q});
- p class => 'browseopts';
- for ('all', 'a'..'z', 0) {
- a href => $url->($_), $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#';
- }
- end;
- if($uid) {
- p class => 'browseopts';
- a href => $url->($char, 'vnlist'), $f->{vnlist} ? (class => 'optselected') : (), 'User VN list';
- end 'p';
- }
-
- p class => 'filselect';
- a id => 'filselect', href => '#v';
- lit '<i>&#9656;</i> Visual Novel Filters<i></i>';
- end;
- a id => 'rfilselect', href => '#r';
- lit '<i>&#9656;</i> Release filters<i></i>';
- end;
- a id => 'cfilselect', href => '#c';
- lit '<i>&#9656;</i> Character filters<i></i>';
- end;
- end;
- input type => 'hidden', class => 'hidden', name => $_, id => $_, value => $f->{$_}
- for (qw{fil rfil cfil s o});
- end;
- end 'form';
-
- $self->htmlBrowseVN($list, $f, $np, "/v/$char?q=$quri;fil=$f->{fil};rfil=$f->{rfil};cfil=$f->{cfil}", $f->{fil} =~ /tag_inc-/);
- $self->htmlFooter(pref_code => 1);
-}
-
-
-sub _fil_compat {
- my $self = shift;
- my %c;
- my $f = $self->formValidate(
- { get => 'ln', required => 0, multi => 1, enum => [ keys %LANGUAGE ], default => '' },
- { get => 'pl', required => 0, multi => 1, enum => [ keys %PLATFORM ], default => '' },
- { get => 'sp', required => 0, default => ($self->reqCookie('tagspoil')||'') =~ /^([0-2])$/ ? $1 : 0, enum => [0..2] },
- );
- return () if $f->{_err};
- $c{lang} //= $f->{ln} if $f->{ln}[0];
- $c{plat} //= $f->{pl} if $f->{pl}[0];
- $c{tagspoil} //= $f->{sp};
- return %c;
-}
-
-
-1;
-
diff --git a/lib/VNDB/Handler/VNEdit.pm b/lib/VNDB/Handler/VNEdit.pm
deleted file mode 100644
index 932a07f9..00000000
--- a/lib/VNDB/Handler/VNEdit.pm
+++ /dev/null
@@ -1,541 +0,0 @@
-
-package VNDB::Handler::VNEdit;
-
-use strict;
-use warnings;
-use TUWF ':html', ':xml';
-use Image::Magick;
-use VNDB::Func;
-use VNDB::Types;
-
-
-TUWF::register(
- qr{v(?:([1-9]\d*)(?:\.([1-9]\d*))?/edit|/new)}
- => \&edit,
- qr{v/add} => \&addform,
- qr{xml/vn\.xml} => \&vnxml,
- qr{xml/screenshots\.xml} => \&scrxml,
-);
-
-
-sub addform {
- my $self = shift;
- return $self->htmlDenied if !$self->authCan('edit');
-
- my $frm;
- my $l = [];
- if($self->reqMethod eq 'POST') {
- return if !$self->authCheckCode;
- $frm = $self->formValidate(
- { post => 'title', maxlength => 250 },
- { post => 'original', required => 0, maxlength => 250, default => '' },
- { post => 'alias', required => 0, maxlength => 500, default => '' },
- { post => 'continue_ign',required => 0 },
- );
-
- # look for duplicates
- if(!$frm->{_err} && !$frm->{continue_ign}) {
- $l = $self->dbVNGet(search => $frm->{title}, what => 'changes', results => 50, inc_hidden => 1);
- push @$l, @{$self->dbVNGet(search => $frm->{original}, what => 'changes', results => 50, inc_hidden => 1)} if $frm->{original};
- $_ && push @$l, @{$self->dbVNGet(search => $_, what => 'changes', results => 50, inc_hidden => 1)} for(split /\n/, $frm->{alias});
- my %ids = map +($_->{id}, $_), @$l;
- $l = [ map $ids{$_}, sort { $ids{$a}{title} cmp $ids{$b}{title} } keys %ids ];
- }
-
- return edit($self, undef, undef, 1) if !@$l && !$frm->{_err};
- }
-
- $self->htmlHeader(title => 'Add a new visual novel', noindex => 1);
- if(@$l) {
- div class => 'mainbox';
- h1 'Possible duplicates found';
- div class => 'warning';
- p;
- txt 'The following is a list of visual novels that match the title(s) you gave.'
- .' Please check this list to avoid creating a duplicate visual novel entry.'
- .' Be especially wary of items that have been deleted! To see why an entry has been deleted, click on its title.';
- br; br;
- txt 'To add the visual novel anyway, hit the "Continue and ignore duplicates" button below.';
- end;
- end;
- ul;
- for(@$l) {
- li;
- a href => "/v$_->{id}", title => $_->{original}||$_->{title}, "v$_->{id}: ".shorten($_->{title}, 50);
- b class => 'standout', ' deleted' if $_->{hidden};
- end;
- }
- end;
- end 'div';
- }
-
- $self->htmlForm({ frm => $frm, action => '/v/add', continue => @$l ? 2 : 1 },
- vn_add => [ 'Add a new visual novel',
- [ input => short => 'title', name => 'Title (romaji)', width => 450 ],
- [ input => short => 'original', name => 'Original title', width => 450 ],
- [ static => content => 'The original title of this visual novel, leave blank if it already is in the Latin alphabet.' ],
- [ textarea => short => 'alias', name => 'Aliases', rows => 4 ],
- [ static => content => 'List of alternative titles or abbreviations. One line for each alias.' ],
- ]);
- $self->htmlFooter;
-}
-
-
-sub edit {
- my($self, $vid, $rev, $nosubmit) = @_;
-
- my $v = $vid && $self->dbVNGetRev(id => $vid, what => 'extended screenshots relations anime staff seiyuu changes', $rev ? (rev => $rev) : ())->[0];
- return $self->resNotFound if $vid && !$v->{id};
- $rev = undef if !$vid || $v->{lastrev};
-
- return $self->htmlDenied if !$self->authCan('edit')
- || $vid && (($v->{locked} || $v->{hidden}) && !$self->authCan('dbmod'));
-
- my $r = $v ? $self->dbReleaseGet(vid => $v->{id}) : [];
- my $chars = $v ? $self->dbCharGet(vid => $v->{id}, results => 500) : [];
-
- my %b4 = !$vid ? () : (
- (map { $_ => $v->{$_} } qw|title original desc alias length l_renai l_wikidata image img_nsfw ihid ilock|),
- credits => [
- map { my $c = $_; +{ map { $_ => $c->{$_} } qw|aid role note| } }
- sort { $a->{aid} <=> $b->{aid} || $a->{role} cmp $b->{role} } @{$v->{credits}}
- ],
- seiyuu => [
- map { my $c = $_; +{ map { $_ => $c->{$_} } qw|aid cid note| } }
- sort { $a->{aid} <=> $b->{aid} || $a->{cid} <=> $b->{cid} } @{$v->{seiyuu}}
- ],
- anime => join(' ', sort { $a <=> $b } map $_->{id}, @{$v->{anime}}),
- vnrelations => join('|||', map $_->{relation}.','.$_->{id}.','.($_->{official}?1:0).','.$_->{title}, sort { $a->{id} <=> $b->{id} } @{$v->{relations}}),
- screenshots => [
- map +{ id => $_->{id}, nsfw => $_->{nsfw}?1:0, rid => $_->{rid} },
- sort { $a->{id} <=> $b->{id} } @{$v->{screenshots}}
- ]
- );
-
- my $frm;
- if($self->reqMethod eq 'POST') {
- return if !$nosubmit && !$self->authCheckCode;
- $frm = $self->formValidate(
- { post => 'title', maxlength => 250 },
- { post => 'original', required => 0, maxlength => 250, default => '' },
- { post => 'alias', required => 0, maxlength => 500, default => '' },
- { post => 'desc', required => 0, default => '', maxlength => 10240 },
- { post => 'length', required => 0, default => 0, enum => [ keys %VN_LENGTH ] },
- { post => 'l_renai', required => 0, default => '', maxlength => 100 },
- { post => 'l_wikidata', required => 0, template => 'wikidata' },
- { post => 'anime', required => 0, default => '' },
- { post => 'image', required => 0, default => 0, template => 'id' },
- { post => 'img_nsfw', required => 0, default => 0 },
- { post => 'credits', required => 0, template => 'json', json_unique => ['aid','role'], json_sort => ['aid','role'], json_fields => [
- { field => 'aid', required => 1, template => 'id' },
- { field => 'role', required => 1, enum => [ keys %CREDIT_TYPE ] },
- { field => 'note', required => 0, maxlength => 250, default => '' },
- ]},
- { post => 'seiyuu', required => 0, template => 'json', json_unique => ['aid','cid'], json_sort => ['aid','cid'], json_fields => [
- { field => 'aid', required => 1, template => 'id' },
- { field => 'cid', required => 1, template => 'id' },
- { field => 'note', required => 0, maxlength => 250, default => '' },
- ]},
- { post => 'vnrelations', required => 0, default => '', maxlength => 5000 },
- { post => 'screenshots', required => 0, template => 'json', json_maxitems => 10, json_unique => 'id', json_sort => 'id', json_fields => [
- { field => 'id', required => 1, template => 'id' },
- { field => 'rid', required => 1, template => 'id' },
- { field => 'nsfw', required => 1, template => 'uint', enum => [0,1] },
- ]},
- { post => 'editsum', required => !$nosubmit, template => 'editsum' },
- { post => 'ihid', required => 0 },
- { post => 'ilock', required => 0 },
- );
- $frm->{original} = '' if $frm->{original} eq $frm->{title};
-
- # handle image upload
- $frm->{image} = _uploadimage($self, $frm) if !$nosubmit;
-
- if(!$nosubmit && !$frm->{_err}) {
- # normalize aliases
- $frm->{alias} = join "\n", map { s/^ +//g; s/ +$//g; $_?($_):() } split /\n/, $frm->{alias};
- # throw error on duplicate/existing aliases
- my %alias = map +(lc($_),1), $frm->{title}, $frm->{original}, map +($_->{title}, $_->{original}), @$r;
- my @e = map $alias{ lc($_) }++ ? "Duplicate alias '$_', or the alias is already used as a release title" : (), split /\n/, $frm->{alias};
- $frm->{_err} = \@e if @e;
- }
- if(!$nosubmit && !$frm->{_err}) {
- # parse and re-sort fields that have multiple representations of the same information
- my $anime = { map +($_=>1), grep /^[0-9]+$/, split /[ ,]+/, $frm->{anime} };
- my $relations = [ map { /^([a-z]+),([0-9]+),([01]),(.+)$/ && (!$vid || $2 != $vid) ? [ $1, $2, $3, $4 ] : () } split /\|\|\|/, $frm->{vnrelations} ];
-
- # Ensure submitted alias / character IDs exist within database
- my @alist = map $_->{aid}, @{$frm->{credits}}, @{$frm->{seiyuu}};
- my %staff = @alist ? map +($_->{aid}, 1), @{$self->dbStaffGet(aid => \@alist, results => 200)} : ();
- my %vn_chars = map +($_->{id} => 1), @$chars;
- $frm->{credits} = [ grep $staff{$_->{aid}}, @{$frm->{credits}} ];
- $frm->{seiyuu} = [ grep $staff{$_->{aid}} && $vn_chars{$_->{cid}}, @$chars ? @{$frm->{seiyuu}} : () ];
-
- $frm->{ihid} = $frm->{ihid}?1:0;
- $frm->{ilock} = $frm->{ilock}?1:0;
- $frm->{desc} = $self->bbSubstLinks($frm->{desc});
- $relations = [] if $frm->{ihid};
- $frm->{anime} = join ' ', sort { $a <=> $b } keys %$anime;
- $frm->{vnrelations} = join '|||', map $_->[0].','.$_->[1].','.($_->[2]?1:0).','.$_->[3], sort { $a->[1] <=> $b->[1]} @{$relations};
- $frm->{img_nsfw} = $frm->{img_nsfw} ? 1 : 0;
- $frm->{screenshots} = [ sort { $a->{id} <=> $b->{id} } @{$frm->{screenshots}} ];
-
- # nothing changed? just redirect
- return $self->resRedirect("/v$vid", 'post') if $vid && !form_compare(\%b4, $frm);
-
- # perform the edit/add
- my $nrev = $self->dbItemEdit(v => $vid ? ($v->{id}, $v->{rev}) : (undef, undef),
- (map { $_ => $frm->{$_} } qw|title original image alias desc length l_renai l_wikidata editsum img_nsfw ihid ilock credits seiyuu screenshots|),
- anime => [ keys %$anime ],
- relations => $relations,
- );
-
- # update reverse relations & relation graph
- if(!$vid && $#$relations >= 0 || $vid && $frm->{vnrelations} ne $b4{vnrelations}) {
- my %old = $vid ? (map +($_->{id} => [ $_->{relation}, $_->{official} ]), @{$v->{relations}}) : ();
- my %new = map +($_->[1] => [ $_->[0], $_->[2] ]), @$relations;
- _updreverse($self, \%old, \%new, $nrev->{itemid}, $nrev->{rev});
- }
-
- return $self->resRedirect("/v$nrev->{itemid}.$nrev->{rev}", 'post');
- }
- }
-
- !exists $frm->{$_} && ($frm->{$_} = $b4{$_}) for (keys %b4);
- $frm->{editsum} = sprintf 'Reverted to revision v%d.%d', $vid, $rev if $rev && !defined $frm->{editsum};
-
- my $title = $vid ? "Edit $v->{title}" : 'Add a new visual novel';
- $self->htmlHeader(title => $title, noindex => 1);
- $self->htmlMainTabs('v', $v, 'edit') if $vid;
- $self->htmlEditMessage('v', $v, $title);
- _form($self, $v, $frm, $r, $chars);
- $self->htmlFooter;
-}
-
-
-sub _uploadimage {
- my($self, $frm) = @_;
-
- if($frm->{_err} || !$self->reqPost('img')) {
- return 0 if !$frm->{image};
- push @{$frm->{_err}}, 'No image with that ID' if !-s imgpath(cv => $frm->{image});
- return $frm->{image};
- }
-
- # perform some elementary checks
- my $imgdata = $self->reqUploadRaw('img');
- $frm->{_err} = [ 'Image must be in JPEG or PNG format' ] if $imgdata !~ /^(\xff\xd8|\x89\x50)/; # JPG or PNG headers
- $frm->{_err} = [ 'Image is too large, only 5MB allowed' ] if length($imgdata) > 5*1024*1024;
- return undef if $frm->{_err};
-
- # resize/compress
- my $im = Image::Magick->new;
- $im->BlobToImage($imgdata);
- $im->Set(magick => 'JPEG');
- my($ow, $oh) = ($im->Get('width'), $im->Get('height'));
- my($nw, $nh) = imgsize($ow, $oh, @{$self->{cv_size}});
- $im->Set(background => '#ffffff');
- $im->Set(alpha => 'Remove');
- if($ow != $nw || $oh != $nh) {
- $im->GaussianBlur(geometry => '0.5x0.5');
- $im->Resize(width => $nw, height => $nh);
- $im->UnsharpMask(radius => 0, sigma => 0.75, amount => 0.75, threshold => 0.008);
- }
- $im->Set(quality => 90);
-
- # Get ID and save
- my $imgid = $self->dbVNImageId;
- my $fn = imgpath(cv => $imgid);
- $im->Write($fn);
- chmod 0666, $fn;
-
- return $imgid;
-}
-
-
-sub _form {
- my($self, $v, $frm, $r, $chars) = @_;
- $self->htmlForm({ frm => $frm, action => $v ? "/v$v->{id}/edit" : '/v/new', editsum => 1, upload => 1 },
- vn_geninfo => [ 'General info',
- [ input => short => 'title', name => 'Title (romaji)', width => 450 ],
- [ input => short => 'original', name => 'Original title', width => 450 ],
- [ static => content => 'The original title of this visual novel, leave blank if it already is in the Latin alphabet.' ],
- [ textarea => short => 'alias', name => 'Aliases', rows => 4 ],
- [ static => content =>
- 'List of alternative titles or abbreviations. One line for each alias.'
- .' Can include both official (japanese/english) titles and unofficial titles used around net.<br />'
- .' Titles that are listed in the releases should not be added here!' ],
- [ textarea => short => 'desc', name => 'Description<br /><b class="standout">English please!</b>', rows => 10 ],
- [ static => content =>
- 'Short description of the main story. Please do not include spoilers, and don\'t forget to list'
- .' the source in case you didn\'t write the description yourself. Formatting codes are allowed.' ],
- [ select => short => 'length', name => 'Length', options =>
- [ map [ $_ => fmtvnlen $_, 1 ], keys %VN_LENGTH ] ],
-
- [ input => short => 'l_wikidata',name => 'Wikidata ID',
- pre => 'https://www.wikidata.org/wiki/',
- value => $frm->{l_wikidata} ? "Q$frm->{l_wikidata}" : '',
- post => qq{ (<a href="$self->{url_static}/f/wikidata.png">How to find this</a>)}
- ],
- [ input => short => 'l_renai', name => 'Renai.us link', pre => 'http://renai.us/game/', post => '.shtml' ],
-
- [ input => short => 'anime', name => 'Anime' ],
- [ static => content =>
- 'Whitespace separated list of <a href="http://anidb.net/">AniDB</a> anime IDs.'
- .' E.g. "1015 3348" will add <a href="http://anidb.net/a1015">Shingetsutan Tsukihime</a>'
- .' and <a href="http://anidb.net/a3348">Fate/stay night</a> as related anime.<br />'
- .' Note: It can take a few minutes for the anime titles to appear on the VN page.' ],
- ],
-
- vn_img => [ 'Image', [ static => nolabel => 1, content => sub {
- div class => 'img';
- p 'No image uploaded yet' if !$frm->{image};
- img src => imgurl(cv => $frm->{image}) if $frm->{image};
- end;
-
- div;
- h2 'Image ID';
- input type => 'text', class => 'text', name => 'image', id => 'image', value => $frm->{image}||'';
- p 'Use a VN image that is already on the server. Set to \'0\' to remove the current image.';
- br; br;
-
- h2 'Upload new image';
- input type => 'file', class => 'text', name => 'img', id => 'img';
- p 'Preferably the cover of the CD/DVD/package. Image must be in JPEG or PNG format'
- .' and at most 5MB. Images larger than 256x400 will automatically be resized.';
- br; br; br;
-
- h2 'NSFW';
- input type => 'checkbox', class => 'checkbox', id => 'img_nsfw', name => 'img_nsfw',
- $frm->{img_nsfw} ? (checked => 'checked') : ();
- label class => 'checkbox', for => 'img_nsfw', 'Not Safe For Work';
- p 'Please check this option if the image contains nudity, gore, or is otherwise not safe in a work-friendly environment.';
- end 'div';
- }]],
-
- vn_staff => [ 'Staff',
- [ json => short => 'credits' ],
- [ static => nolabel => 1, content => sub {
- # propagate staff ids and names to javascript
- my @alist = map $_->{aid}, @{$frm->{credits}}, @{$frm->{seiyuu}};
- script_json staffdata => {
- map +($_->{aid}, {id => $_->{id}, aid => $_->{aid}, name => $_->{name}}),
- @alist ? @{$self->dbStaffGet(aid => \@alist, results => 200)} : ()
- };
- div class => 'warning';
- lit 'Please check the <a href="/d2#3">staff editing guidelines</a>. You can'
- .' <a href="/s/new">create a new staff entry</a> if it is not in the database yet,'
- .' but please <a href="/s/all">check for aliasses first</a>.';
- end;
- br;
- table; tbody id => 'credits_tbl';
- Tr id => 'credits_loading'; td colspan => '4', 'Loading...'; end;
- end; end;
- h2 'Add staff';
- table; Tr;
- td class => 'tc_staff';
- input id => 'credit_input', type => 'text', class => 'text', style => 'width: 300px'; end;
- td colspan => 3, '';
- end; end;
- }]],
-
- # Cast tab is only shown for VNs with some characters listed.
- # There's no way to add voice actors in new VN edits since character list
- # would be empty anyway.
- @{$chars} ? (vn_cast => [ 'Cast',
- [ json => short => 'seiyuu' ],
- [ static => nolabel => 1, content => sub {
- table; tbody id => 'cast_tbl';
- Tr id => 'cast_loading'; td colspan => '4', 'Loading...'; end;
- end; end;
- h2 'Add cast';
- table; Tr;
- td class => 'tc_char';
- Select id =>'cast_chars';
- option value => '', 'Select character';
- for my $i (0..$#$chars) {
- my($name, $id) = @{$chars->[$i]}{qw|name id|};
- # append character IDs to coinciding names
- # (assume dbCharGet sorted characters by name)
- $name .= ' - c'.$id if $name eq ($chars->[$i+1]{name}//'')
- .. $name ne ($chars->[$i+1]{name}//'');
- option value => $id, $name;
- }
- end;
- txt ' voiced by';
- end;
- td class => 'tc_staff';
- input id => 'cast_input', type => 'text', class => 'text', style => 'width: 300px';
- end;
- td colspan => 2, '';
- end; end;
- }]]) : (),
-
- vn_rel => [ 'Relations',
- [ hidden => short => 'vnrelations' ],
- [ static => nolabel => 1, content => sub {
- h2 'Selected relations';
- table;
- tbody id => 'relation_tbl';
- # to be filled using javascript
- end;
- end;
-
- h2 'Add relation';
- table;
- Tr id => 'relation_new';
- td class => 'tc_vn';
- input type => 'text', class => 'text';
- end;
- td class => 'tc_rel';
- txt 'is an ';
- input type => 'checkbox', id => 'official', checked => 'checked';
- label for => 'official', 'official';
- Select;
- option value => $_, $VN_RELATION{$_}{txt}
- for (keys %VN_RELATION);
- end;
- txt ' of';
- end;
- td class => 'tc_title', $v ? $v->{title} : '';
- td class => 'tc_add';
- a href => '#', 'add';
- end;
- end;
- end 'table';
- }],
- ],
-
- vn_scr => [ 'Screenshots', !@$r ? (
- [ static => nolabel => 1, content => 'No releases in the database yet. Screenshots can only be uploaded after a release has been added.' ],
- ) : (
- [ json => short => 'screenshots' ],
- [ static => nolabel => 1, content => sub {
- my @scr = map $_->{id}, @{$frm->{screenshots}};
- my %scr = map +($_->{id}, [ $_->{width}, $_->{height}]), @scr ? @{$self->dbScreenshotGet(\@scr)} : ();
- my @rels = map [ $_->{id}, sprintf '[%s] %s (r%d)', join(',', @{$_->{languages}}), $_->{title}, $_->{id} ], @$r;
- script_json screendata => {
- size => \%scr,
- rel => \@rels,
- staticurl => $self->{url_static},
- };
- div class => 'warning';
- lit 'Please keep the following in mind when uploading screenshots:<br />'
- .'- Screenshots have to be in the native resolution of the game,<br />'
- .'- Remove any window borders and make sure the image is unmarked,<br />'
- .'- Don\'t only upload event CGs.<br />'
- .'Please read the <a href="/d2#6">guidelines</a> for more information.<br />'
- .'Make sure to submit the form after the upload has finished!';
- end;
- br;
- table class => 'stripe';
- tbody id => 'scr_table', '';
- end;
- }],
- )]
-
- );
-}
-
-
-# Update reverse relations and regenerate relation graph
-# Arguments: %old. %new, vid, rev
-# %old,%new -> { vid => [ relation, official ], .. }
-# from the perspective of vid
-# rev is of the related edit
-sub _updreverse {
- my($self, $old, $new, $vid, $rev) = @_;
- my %upd;
-
- # compare %old and %new
- for (keys %$old, keys %$new) {
- if(exists $$old{$_} and !exists $$new{$_}) {
- $upd{$_} = undef;
- } elsif((!exists $$old{$_} and exists $$new{$_}) || ($$old{$_}[0] ne $$new{$_}[0] || !$$old{$_}[1] != !$$new{$_}[1])) {
- $upd{$_} = [ $VN_RELATION{ $$new{$_}[0] }{reverse}, $$new{$_}[1] ];
- }
- }
- return if !keys %upd;
-
- # edit all related VNs
- for my $i (keys %upd) {
- my $r = $self->dbVNGetRev(id => $i, what => 'relations')->[0];
- my @newrel = map $_->{id} != $vid ? [ $_->{relation}, $_->{id}, $_->{official} ] : (), @{$r->{relations}};
- push @newrel, [ $upd{$i}[0], $vid, $upd{$i}[1] ] if $upd{$i};
- $self->dbItemEdit(v => $r->{id}, $r->{rev},
- relations => \@newrel,
- editsum => "Reverse relation update caused by revision v$vid.$rev",
- uid => 1, # Multi
- );
- }
-}
-
-
-# peforms a (simple) search and returns the results in XML format
-sub vnxml {
- my $self = shift;
-
- my $q = $self->formValidate({ get => 'q', maxlength => 500 });
- return $self->resNotFound if $q->{_err};
- $q = $q->{q};
-
- my($list, $np) = $self->dbVNGet(
- $q =~ /^v([1-9]\d*)/ ? (id => $1) : (search => $q),
- results => 10,
- page => 1,
- );
-
- $self->resHeader('Content-type' => 'text/xml; charset=UTF-8');
- xml;
- tag 'vns', more => $np ? 'yes' : 'no', query => $q;
- for(@$list) {
- tag 'item', id => $_->{id}, $_->{title};
- }
- end;
-}
-
-
-# handles uploading screenshots and fetching information about them
-sub scrxml {
- my $self = shift;
- return $self->htmlDenied if !$self->authCan('edit') || $self->reqMethod ne 'POST';
-
- # upload new screenshot
- my $id = 0;
- my $imgdata = $self->reqUploadRaw('file');
- $id = -2 if !$imgdata;
- $id = -1 if !$id && $imgdata !~ /^(\xff\xd8|\x89\x50)/; # JPG or PNG headers
-
- # no error? process it
- my($ow, $oh);
- if(!$id) {
- my $im = Image::Magick->new;
- $im->BlobToImage($imgdata);
- $im->Set(background => '#000000');
- $im->Set(alpha => 'Remove');
- $im->Set(magick => 'JPEG');
- $im->Set(quality => 90);
- ($ow, $oh) = ($im->Get('width'), $im->Get('height'));
-
- $id = $self->dbScreenshotAdd($ow, $oh);
- my $fn = imgpath(sf => $id);
- $im->Write($fn);
- chmod 0666, $fn;
-
- # thumbnail
- my($nw, $nh) = imgsize($ow, $oh, @{$self->{scr_size}});
- $im->Thumbnail(width => $nw, height => $nh);
- $im->Set(quality => 90);
- $fn = imgpath(st => $id);
- $im->Write($fn);
- chmod 0666, $fn;
- }
-
- $self->resHeader('Content-type' => 'text/xml; charset=UTF-8');
- xml;
- tag 'image', id => $id, $id > 0 ? (width => $ow, height => $oh) : (), undef;
-}
-
-
-1;
-
diff --git a/lib/VNDB/Handler/VNPage.pm b/lib/VNDB/Handler/VNPage.pm
deleted file mode 100644
index 8b01fabc..00000000
--- a/lib/VNDB/Handler/VNPage.pm
+++ /dev/null
@@ -1,1062 +0,0 @@
-
-package VNDB::Handler::VNPage;
-
-use strict;
-use warnings;
-use TUWF ':html', 'xml_escape';
-use VNDB::Func;
-use VNDB::Types;
-use VNDB::ExtLinks;
-use List::Util 'min';
-use POSIX 'strftime';
-
-
-TUWF::register(
- qr{v/rand} => \&rand,
- qr{v([1-9]\d*)/rg} => \&rg,
- qr{v([1-9]\d*)/releases} => \&releases,
- qr{v([1-9]\d*)/(chars)} => \&page,
- qr{v([1-9]\d*)/staff} => sub { $_[0]->resRedirect("/v$_[1]#staff") },
- qr{v([1-9]\d*)(?:\.([1-9]\d*))?} => \&page,
-);
-
-
-sub rand {
- my $self = shift;
- $self->resRedirect('/v'.$self->filFetchDB(vn => undef, undef, {results => 1, sort => 'rand'})->[0]{id}, 'temp');
-}
-
-
-sub rg {
- my($self, $vid) = @_;
-
- my $v = $self->dbVNGet(id => $vid, what => 'relgraph')->[0];
- return $self->resNotFound if !$v->{id} || !$v->{rgraph};
-
- my $title = "Relation graph for $v->{title}";
- return if $self->htmlRGHeader($title, 'v', $v);
-
- $v->{svg} =~ s/id="node_v$vid"/id="graph_current"/;
-
- div class => 'mainbox';
- h1 $title;
- p 'Note: Unofficial relations are excluded if the graph would otherwise be too large.';
- p class => 'center';
- lit $v->{svg};
- end;
- end;
- $self->htmlFooter;
-}
-
-
-# Description of each column, field:
-# id: Identifier used in URLs
-# sort_field: Name of the field when sorting
-# what: Required dbReleaseGet 'what' flag
-# column_string: String to use as column header
-# column_width: Maximum width (in pixels) of the column in 'restricted width' mode
-# button_string: String to use for the hide/unhide button
-# na_for_patch: When the field is N/A for patch releases
-# default: Set when it's visible by default
-# has_data: Subroutine called with a release object, should return true if the release has data for the column
-# draw: Subroutine called with a release object, should draw its column contents
-my @rel_cols = (
- { # Title
- id => 'tit',
- sort_field => 'title',
- column_string => 'Title',
- draw => sub { a href => "/r$_[0]{id}", shorten $_[0]{title}, 60 },
- }, { # Type
- id => 'typ',
- sort_field => 'type',
- button_string => 'Type',
- default => 1,
- draw => sub { cssicon "rt$_[0]{type}", $_[0]{type}; txt '(patch)' if $_[0]{patch} },
- }, { # Languages
- id => 'lan',
- button_string => 'Language',
- default => 1,
- has_data => sub { !!@{$_[0]{languages}} },
- draw => sub {
- for(@{$_[0]{languages}}) {
- cssicon "lang $_", $LANGUAGE{$_};
- br if $_ ne $_[0]{languages}[$#{$_[0]{languages}}];
- }
- },
- }, { # Publication
- id => 'pub',
- sort_field => 'publication',
- column_string => 'Publication',
- column_width => 70,
- button_string => 'Publication',
- default => 1,
- what => 'extended',
- draw => sub { txt join ', ', $_[0]{freeware} ? 'Freeware' : 'Non-free', $_[0]{patch} ? () : ($_[0]{doujin} ? 'doujin' : 'commercial') },
- }, { # Platforms
- id => 'pla',
- button_string => 'Platforms',
- default => 1,
- what => 'platforms',
- has_data => sub { !!@{$_[0]{platforms}} },
- draw => sub {
- for(@{$_[0]{platforms}}) {
- cssicon $_, $PLATFORM{$_};
- br if $_ ne $_[0]{platforms}[$#{$_[0]{platforms}}];
- }
- txt 'Unknown' if !@{$_[0]{platforms}};
- },
- }, { # Media
- id => 'med',
- column_string => 'Media',
- button_string => 'Media',
- what => 'media',
- has_data => sub { !!@{$_[0]{media}} },
- draw => sub {
- for(@{$_[0]{media}}) {
- txt fmtmedia($_->{medium}, $_->{qty});
- br if $_ ne $_[0]{media}[$#{$_[0]{media}}];
- }
- txt 'Unknown' if !@{$_[0]{media}};
- },
- }, { # Resolution
- id => 'res',
- sort_field => 'resolution',
- column_string => 'Resolution',
- button_string => 'Resolution',
- na_for_patch => 1,
- default => 1,
- what => 'extended',
- has_data => sub { $_[0]{resolution} ne 'unknown' },
- draw => sub {
- txt $_[0]{resolution} eq 'unknown' ? 'Unknown' : $RESOLUTION{$_[0]{resolution}}{txt};
- },
- }, { # Voiced
- id => 'voi',
- sort_field => 'voiced',
- column_string => 'Voiced',
- column_width => 70,
- button_string => 'Voiced',
- na_for_patch => 1,
- default => 1,
- what => 'extended',
- has_data => sub { !!$_[0]{voiced} },
- draw => sub { txt $VOICED{$_[0]{voiced}}{txt} },
- }, { # Animation
- id => 'ani',
- sort_field => 'ani_ero',
- column_string => 'Animation',
- column_width => 110,
- button_string => 'Animation',
- na_for_patch => '1',
- what => 'extended',
- has_data => sub { !!($_[0]{ani_story} || $_[0]{ani_ero}) },
- draw => sub {
- txt join ', ',
- $_[0]{ani_story} ? "Story: $ANIMATED{$_[0]{ani_story}}{txt}" :(),
- $_[0]{ani_ero} ? "Ero scenes: $ANIMATED{$_[0]{ani_ero}}{txt}":();
- txt 'Unknown' if !$_[0]{ani_story} && !$_[0]{ani_ero};
- },
- }, { # Released
- id => 'rel',
- sort_field => 'released',
- column_string => 'Released',
- button_string => 'Released',
- default => 1,
- draw => sub { lit fmtdatestr $_[0]{released} },
- }, { # Age rating
- id => 'min',
- sort_field => 'minage',
- button_string => 'Age rating',
- default => 1,
- has_data => sub { $_[0]{minage} != -1 },
- draw => sub { txt minage $_[0]{minage} },
- }, { # Notes
- id => 'not',
- sort_field => 'notes',
- column_string => 'Notes',
- column_width => 400,
- button_string => 'Notes',
- default => 1,
- what => 'extended',
- has_data => sub { !!$_[0]{notes} },
- draw => sub { lit bb2html $_[0]{notes} },
- }
-);
-
-
-sub releases {
- my($self, $vid) = @_;
-
- my $v = $self->dbVNGet(id => $vid)->[0];
- return $self->resNotFound if !$v->{id};
-
- my $title = "Releases for $v->{title}";
- $self->htmlHeader(title => $title);
- $self->htmlMainTabs('v', $v, 'releases');
-
- my $f = $self->formValidate(
- map({ get => $_->{id}, required => 0, default => $_->{default}||0, enum => [0,1] }, grep $_->{button_string}, @rel_cols),
- { get => 'cw', required => 0, default => 0, enum => [0,1] },
- { get => 'o', required => 0, default => 0, enum => [0,1] },
- { get => 's', required => 0, default => 'released', enum => [ map $_->{sort_field}, grep $_->{sort_field}, @rel_cols ]},
- { get => 'os', required => 0, default => 'all', enum => [ 'all', keys %PLATFORM ] },
- { get => 'lang', required => 0, default => 'all', enum => [ 'all', keys %LANGUAGE ] },
- );
- return $self->resNotFound if $f->{_err};
-
- # Get the release info
- my %what = map +($_->{what}, 1), grep $_->{what} && $f->{$_->{id}}, @rel_cols;
- my $r = $self->dbReleaseGet(vid => $vid, what => join(' ', keys %what), sort => $f->{s}, reverse => $f->{o}, results => 200);
-
- # url generator
- my $url = sub {
- my %u = (%$f, @_);
- return "/v$vid/releases?".join(';', map "$_=$u{$_}", sort keys %u);
- };
-
- div class => 'mainbox releases_compare';
- h1 $title;
-
- if(!@$r) {
- td 'We don\'t have any information about releases of this visual novel yet...';
- } else {
- _releases_buttons($self, $f, $url, $r);
- }
- end 'div';
-
- _releases_table($self, $f, $url, $r) if @$r;
- $self->htmlFooter;
-}
-
-
-sub _releases_buttons {
- my($self, $f, $url, $r) = @_;
-
- # Column visibility
- p class => 'browseopts';
- a href => $url->($_->{id}, $f->{$_->{id}} ? 0 : 1), $f->{$_->{id}} ? (class => 'optselected') : (), $_->{button_string}
- for (grep $_->{button_string}, @rel_cols);
- end;
-
- # Misc options
- my $all_selected = !grep $_->{button_string} && !$f->{$_->{id}}, @rel_cols;
- my $all_unselected = !grep $_->{button_string} && $f->{$_->{id}}, @rel_cols;
- my $all_url = sub { $url->(map +($_->{id},$_[0]), grep $_->{button_string}, @rel_cols); };
- p class => 'browseopts';
- a href => $all_url->(1), $all_selected ? (class => 'optselected') : (), 'All on';
- a href => $all_url->(0), $all_unselected ? (class => 'optselected') : (), 'All off';
- a href => $url->('cw', $f->{cw} ? 0 : 1), $f->{cw} ? (class => 'optselected') : (), 'Restrict column width';
- end;
-
- # Platform/language filters
- my $plat_lang_draw = sub {
- my($row, $option, $txt, $csscat) = @_;
- my %opts = map +($_,1), map @{$_->{$row}}, @$r;
- return if !keys %opts;
- p class => 'browseopts';
- for('all', sort keys %opts) {
- a href => $url->($option, $_), $_ eq $f->{$option} ? (class => 'optselected') : ();
- $_ eq 'all' ? txt 'All' : cssicon "$csscat $_", $txt->{$_};
- end 'a';
- }
- end 'p';
- };
- $plat_lang_draw->('platforms', 'os', \%PLATFORM, '') if $f->{pla};
- $plat_lang_draw->('languages', 'lang',\%LANGUAGE, 'lang') if $f->{lan};
-}
-
-
-sub _releases_table {
- my($self, $f, $url, $r) = @_;
-
- # Apply language and platform filters
- my @r = grep +
- ($f->{os} eq 'all' || ($_->{platforms} && grep $_ eq $f->{os}, @{$_->{platforms}})) &&
- ($f->{lang} eq 'all' || ($_->{languages} && grep $_ eq $f->{lang}, @{$_->{languages}})), @$r;
-
- # Figure out which columns to display
- my @col;
- for my $c (@rel_cols) {
- next if $c->{button_string} && !$f->{$c->{id}}; # Hidden by settings
- push @col, $c if !@r || !$c->{has_data} || grep $c->{has_data}->($_), @r; # Must have relevant data
- }
-
- div class => 'mainbox releases_compare';
- table;
-
- thead;
- Tr;
- for my $c (@col) {
- td class => 'key';
- txt $c->{column_string} if $c->{column_string};
- for($c->{sort_field} ? (0,1) : ()) {
- my $active = $f->{s} eq $c->{sort_field} && !$f->{o} == !$_;
- a href => $url->(o => $_, s => $c->{sort_field}) if !$active;
- lit $_ ? "\x{25BE}" : "\x{25B4}";
- end 'a' if !$active;
- }
- end 'td';
- }
- end 'tr';
- end 'thead';
-
- for my $r (@r) {
- Tr;
- # Combine "N/A for patches" columns
- my $cspan = 1;
- for my $c (0..$#col) {
- if($r->{patch} && $col[$c]{na_for_patch} && $c < $#col && $col[$c+1]{na_for_patch}) {
- $cspan++;
- next;
- }
- td $cspan > 1 ? (colspan => $cspan) : (),
- $col[$c]{column_width} && $f->{cw} ? (style => "max-width: $col[$c]{column_width}px") : ();
- if($r->{patch} && $col[$c]{na_for_patch}) {
- txt 'NA for patches';
- } else {
- $col[$c]{draw}->($r);
- }
- end;
- $cspan = 1;
- }
- end;
- }
- end 'table';
- end 'div';
-}
-
-
-sub page {
- my($self, $vid, $rev) = @_;
-
- my $char = $rev && $rev eq 'chars';
- $rev = undef if $char;
-
- my $method = $rev ? 'dbVNGetRev' : 'dbVNGet';
- my $v = $self->$method(
- id => $vid,
- what => 'extended anime relations screenshots rating ranking staff'.($rev ? ' seiyuu' : ''),
- $rev ? (rev => $rev) : (),
- )->[0];
- return $self->resNotFound if !$v->{id};
-
- my $r = $self->dbReleaseGet(vid => $vid, what => 'extended links vns producers platforms media', results => 200);
-
- enrich_extlinks v => $v;
- enrich_extlinks r => $r;
-
- my $metadata = {
- 'og:title' => $v->{title},
- 'og:description' => bb2text $v->{desc},
- };
-
- if($v->{image} && !$v->{img_nsfw}) {
- $metadata->{'og:image'} = imgurl(cv => $v->{image});
- } elsif(my ($ss) = grep !$_->{nsfw}, @{$v->{screenshots}}) {
- $metadata->{'og:image'} = imgurl(st => $ss->{id});
- }
-
- $self->htmlHeader(title => $v->{title}, noindex => $rev, metadata => $metadata);
- $self->htmlMainTabs('v', $v);
- return if $self->htmlHiddenMessage('v', $v);
-
- _revision($self, $v, $rev);
-
- div class => 'mainbox';
- $self->htmlItemMessage('v', $v);
- h1 $v->{title};
- h2 class => 'alttitle', lang_attr($v->{c_olang}), $v->{original} if $v->{original};
-
- div class => 'vndetails';
-
- # image
- div class => 'vnimg';
- if(!$v->{image}) {
- p 'No image uploaded yet';
- } else {
- if($v->{img_nsfw}) {
- p class => 'nsfw_pic';
- input id => 'nsfw_chk', type => 'checkbox', class => 'visuallyhidden', $self->authPref('show_nsfw') ? (checked => 'checked') : ();
- label for => 'nsfw_chk';
- span id => 'nsfw_show';
- txt 'This image has been flagged as Not Safe For Work.';
- br; br;
- span class => 'fake_link', 'Show me anyway';
- br; br;
- txt '(This warning can be disabled in your account)';
- end;
- span id => 'nsfw_hid';
- img src => imgurl(cv => $v->{image}), alt => $v->{title};
- i 'Flagged as NSFW';
- end;
- end;
- end;
- } else {
- img src => imgurl(cv => $v->{image}), alt => $v->{title};
- }
- }
- end 'div'; # /vnimg
-
- # general info
- table class => 'stripe';
- Tr;
- td class => 'key', 'Title';
- td $v->{title};
- end;
- if($v->{original}) {
- Tr;
- td 'Original title';
- td lang_attr($v->{c_olang}), $v->{original};
- end;
- }
- if($v->{alias}) {
- $v->{alias} =~ s/\n/, /g;
- Tr;
- td 'Aliases';
- td $v->{alias};
- end;
- }
- if($v->{length}) {
- Tr;
- td 'Length';
- td fmtvnlen $v->{length}, 1;
- end;
- }
-
- _producers($self, $r);
- _relations($self, $v) if @{$v->{relations}};
-
- if($v->{extlinks}->@*) {
- Tr;
- td 'Links';
- td;
- for($v->{extlinks}->@*) {
- a href => $_->[1], $_->[0];
- txt ', ' if $_ ne $v->{extlinks}[$#{$v->{extlinks}}];
- }
- end;
- end;
- }
- _affiliate_links($self, $r);
-
- _anime($self, $v) if @{$v->{anime}};
-
- _useroptions($self, $v, $r) if $self->authInfo->{id};
-
- Tr class => 'nostripe';
- td class => 'vndesc', colspan => 2;
- h2 'Description';
- p;
- lit $v->{desc} ? bb2html $v->{desc} : '-';
- end;
- end;
- end;
-
- end 'table';
- end 'div';
- div class => 'clearfloat', style => 'height: 5px', ''; # otherwise the tabs below aren't positioned correctly
-
- # tags
- my $t = $self->dbTagStats(vid => $v->{id}, sort => 'rating', reverse => 1, minrating => 0, results => 999, state => 2);
- if(@$t) {
- div id => 'tagops';
- for (keys %TAG_CATEGORY) {
- input id => "cat_$_", type => 'checkbox', class => 'visuallyhidden',
- ($self->authInfo->{id} ? $self->authPref("tags_$_") : $_ ne 'ero') ? (checked => 'checked') : ();
- label for => "cat_$_", lc $TAG_CATEGORY{$_};
- }
- my $spoiler = $self->authPref('spoilers') || 0;
- input id => 'tag_spoil_none', type => 'radio', class => 'visuallyhidden', name => 'tag_spoiler', $spoiler == 0 ? (checked => 'checked') : ();
- label for => 'tag_spoil_none', class => 'sec', lc 'Hide spoilers';
- input id => 'tag_spoil_some', type => 'radio', class => 'visuallyhidden', name => 'tag_spoiler', $spoiler == 1 ? (checked => 'checked') : ();
- label for => 'tag_spoil_some', lc 'Show minor spoilers';
- input id => 'tag_spoil_all', type => 'radio', class => 'visuallyhidden', name => 'tag_spoiler', $spoiler == 2 ? (checked => 'checked') : ();
- label for => 'tag_spoil_all', lc 'Spoil me!';
-
- input id => 'tag_toggle_summary', type => 'radio', class => 'visuallyhidden', name => 'tag_all', $self->authPref('tags_all') ? () : (checked => 'checked');
- label for => 'tag_toggle_summary', class => 'sec', lc 'summary';
- input id => 'tag_toggle_all', type => 'radio', class => 'visuallyhidden', name => 'tag_all', $self->authPref('tags_all') ? (checked => 'checked') : ();
- label for => 'tag_toggle_all', class => 'lst', lc 'all';
- div id => 'vntags';
- my %counts = ();
- for (@$t) {
- my $cnt0 = $counts{$_->{cat} . '0'} || 0;
- my $cnt1 = $counts{$_->{cat} . '1'} || 0;
- my $cnt2 = $counts{$_->{cat} . '2'} || 0;
- my $spoil = $_->{spoiler} > 1.3 ? 2 : $_->{spoiler} > 0.4 ? 1 : 0;
- SWITCH: {
- $counts{$_->{cat} . '2'} = ++$cnt2;
- if ($spoil == 2) { last SWITCH; }
- $counts{$_->{cat} . '1'} = ++$cnt1;
- if ($spoil == 1) { last SWITCH; }
- $counts{$_->{cat} . '0'} = ++$cnt0;
- }
- my $cut = $cnt0 > 15 ? ' cut cut2 cut1 cut0' : ($cnt1 > 15 ? ' cut cut2 cut1' : ($cnt2 > 15 ? ' cut cut2' : ''));
- span class => sprintf 'tagspl%d cat_%s%s', $spoil, $_->{cat}, $cut;
- a href => "/g$_->{id}", style => sprintf('font-size: %dpx', $_->{rating}*3.5+6), $_->{name};
- b class => 'grayedout', sprintf ' %.1f', $_->{rating};
- end;
- txt ' ';
- }
- end;
- end;
- }
- end 'div'; # /mainbox
-
- my $chars = $self->dbCharGet(vid => $v->{id}, what => "seiyuu vns($v->{id})".($char ? ' extended traits' : ''), results => 500);
- if(@$chars || $self->authCan('edit')) {
- clearfloat; # fix tabs placement when tags are hidden
- div class => 'maintabs';
- ul;
- if(@$chars) {
- li class => (!$char ? ' tabselected' : ''); a href => "/v$v->{id}#main", name => 'main', 'main'; end;
- li class => ($char ? ' tabselected' : ''); a href => "/v$v->{id}/chars#chars", name => 'chars', 'characters'; end;
- }
- end;
- ul;
- if($self->authCan('edit')) {
- li; a href => "/v$v->{id}/add", 'add release'; end;
- li; a href => "/c/new?vid=$v->{id}", 'add character'; end;
- }
- end;
- end;
- }
-
- if($char) {
- _chars($self, $chars, $v);
- } else {
- _releases($self, $v, $r);
- _staff($self, $v);
- _charsum($self, $chars, $v);
- _stats($self, $v);
- _screenshots($self, $v, $r) if @{$v->{screenshots}};
- }
-
- $self->htmlFooter(v2rwjs => $self->authInfo->{id});
-}
-
-
-sub _revision {
- my($self, $v, $rev) = @_;
- return if !$rev;
-
- my $prev = $rev && $rev > 1 && $self->dbVNGetRev(
- id => $v->{id}, rev => $rev-1, what => 'extended anime relations screenshots staff seiyuu'
- )->[0];
-
- $self->htmlRevision('v', $prev, $v,
- [ title => 'Title (romaji)', diff => 1 ],
- [ original => 'Original title', diff => 1 ],
- [ alias => 'Alias', diff => qr/[ ,\n\.]/ ],
- [ desc => 'Description', diff => qr/[ ,\n\.]/ ],
- [ length => 'Length', serialize => sub { fmtvnlen $_[0] } ],
- [ l_wp => 'Wikipedia link', htmlize => sub {
- $_[0] ? sprintf '<a href="http://en.wikipedia.org/wiki/%s">%1$s</a>', xml_escape $_[0] : '[empty]'
- }],
- [ l_wikidata => 'Wikidata ID', htmlize => sub { $_[0] ? sprintf '<a href="https://www.wikidata.org/wiki/Q%d">Q%1$d</a>', $_[0] : '[empty]' } ],
- [ l_encubed => 'Encubed tag', htmlize => sub {
- $_[0] ? sprintf '<a href="http://novelnews.net/tag/%s/">%1$s</a>', xml_escape $_[0] : '[empty]'
- }],
- [ l_renai => 'Renai.us link', htmlize => sub {
- $_[0] ? sprintf '<a href="https://renai.us/game/%s">%1$s</a>', xml_escape $_[0] : '[empty]'
- }],
- [ credits => 'Credits', join => '<br />', split => sub {
- my @r = map sprintf('<a href="/s%d" title="%s">%s</a> [%s]%s', $_->{id},
- xml_escape($_->{original}||$_->{name}), xml_escape($_->{name}), xml_escape($CREDIT_TYPE{$_->{role}}),
- $_->{note} ? ' ['.xml_escape($_->{note}).']' : ''),
- sort { $a->{id} <=> $b->{id} || $a->{role} cmp $b->{role} } @{$_[0]};
- return @r ? @r : ('[empty]');
- }],
- [ seiyuu => 'Seiyuu', join => '<br />', split => sub {
- my @r = map sprintf('<a href="/s%d" title="%s">%s</a> as <a href="/c%d">%s</a>%s',
- $_->{id}, xml_escape($_->{original}||$_->{name}), xml_escape($_->{name}), $_->{cid}, xml_escape($_->{cname}),
- $_->{note} ? ' ['.xml_escape($_->{note}).']' : ''),
- sort { $a->{id} <=> $b->{id} || $a->{cid} <=> $b->{cid} || $a->{note} cmp $b->{note} } @{$_[0]};
- return @r ? @r : ('[empty]');
- }],
- [ relations => 'Relations', join => '<br />', split => sub {
- my @r = map sprintf('[%s] %s: <a href="/v%d" title="%s">%s</a>',
- $_->{official} ? 'official' : 'unofficial', $VN_RELATION{$_->{relation}}{txt},
- $_->{id}, xml_escape($_->{original}||$_->{title}), xml_escape shorten $_->{title}, 40
- ), sort { $a->{id} <=> $b->{id} } @{$_[0]};
- return @r ? @r : ('[empty]');
- }],
- [ anime => 'Anime', join => ', ', split => sub {
- my @r = map sprintf('<a href="http://anidb.net/a%d">a%1$d</a>', $_->{id}), sort { $a->{id} <=> $b->{id} } @{$_[0]};
- return @r ? @r : ('[empty]');
- }],
- [ screenshots => 'Screenshots', join => '<br />', split => sub {
- my @r = map sprintf('[%s] <a href="%s" data-iv="%dx%d">%d</a> (%s)',
- $_->{rid} ? qq|<a href="/r$_->{rid}">r$_->{rid}</a>| : 'no release',
- imgurl(sf => $_->{id}), $_->{width}, $_->{height}, $_->{id},
- $_->{nsfw} ? 'Not safe' : 'Safe'
- ), @{$_[0]};
- return @r ? @r : ('[empty]');
- }],
- [ image => 'Image', htmlize => sub {
- my $url = imgurl(cv => $_[0]);
- if($_[0]) {
- return $_[1]->{img_nsfw} && !$self->authPref('show_nsfw') ? "<a href=\"$url\">(NSFW)</a>" : "<img src=\"$url\" />";
- } else {
- return 'No image';
- }
- }],
- [ img_nsfw => 'Image NSFW', serialize => sub { $_[0] ? 'Not safe' : 'Safe' } ],
- );
-}
-
-
-sub _producers {
- my($self, $r) = @_;
-
- my %lang;
- my @lang = grep !$lang{$_}++, map @{$_->{languages}}, @$r;
-
- if(grep $_->{developer}, map @{$_->{producers}}, @$r) {
- my %dev = map $_->{developer} ? ($_->{id} => $_) : (), map @{$_->{producers}}, @$r;
- my @dev = sort { $a->{name} cmp $b->{name} } values %dev;
- Tr;
- td 'Developer';
- td;
- for (@dev) {
- a href => "/p$_->{id}", title => $_->{original}||$_->{name}, shorten $_->{name}, 30;
- txt ' & ' if $_ != $dev[$#dev];
- }
- end;
- end;
- }
-
- if(grep $_->{publisher}, map @{$_->{producers}}, @$r) {
- Tr;
- td 'Publishers';
- td;
- for my $l (@lang) {
- my %p = map $_->{publisher} ? ($_->{id} => $_) : (), map @{$_->{producers}}, grep grep($_ eq $l, @{$_->{languages}}), @$r;
- my @p = sort { $a->{name} cmp $b->{name} } values %p;
- next if !@p;
- cssicon "lang $l", $LANGUAGE{$l};
- for (@p) {
- a href => "/p$_->{id}", title => $_->{original}||$_->{name}, shorten $_->{name}, 30;
- txt ' & ' if $_ != $p[$#p];
- }
- br;
- }
- end;
- end 'tr';
- }
-}
-
-
-sub _relations {
- my($self, $v) = @_;
-
- my %rel;
- push @{$rel{$_->{relation}}}, $_
- for (sort { $a->{title} cmp $b->{title} } @{$v->{relations}});
-
-
- Tr;
- td 'Relations';
- td class => 'relations';
- dl;
- for(sort keys %rel) {
- dt $VN_RELATION{$_}{txt};
- dd;
- for (@{$rel{$_}}) {
- b class => 'grayedout', '[unofficial] ' if !$_->{official};
- a href => "/v$_->{id}", title => $_->{original}||$_->{title}, shorten $_->{title}, 40;
- br;
- }
- end;
- }
- end;
- end;
- end 'tr';
-}
-
-
-sub _anime {
- my($self, $v) = @_;
-
- Tr;
- td 'Related anime';
- td class => 'anime';
- for (sort { ($a->{year}||9999) <=> ($b->{year}||9999) } @{$v->{anime}}) {
- if(!$_->{lastfetch} || !$_->{year} || !$_->{title_romaji}) {
- b;
- lit sprintf '[no information available at this time: <a href="http://anidb.net/a%d">%1$d</a>]', $_->{id};
- end;
- } else {
- b;
- txt '[';
- a href => "http://anidb.net/a$_->{id}", title => 'AniDB', 'DB';
- # AnimeNFO links seem to be broken at the moment. TODO: Completely remove?
- #if($_->{nfo_id}) {
- # txt '-';
- # a href => "http://animenfo.com/animetitle,$_->{nfo_id},a.html", title => 'AnimeNFO', 'NFO';
- #}
- if($_->{ann_id}) {
- txt '-';
- a href => "http://www.animenewsnetwork.com/encyclopedia/anime.php?id=$_->{ann_id}", title => 'Anime News Network', 'ANN';
- }
- txt '] ';
- end;
- abbr title => $_->{title_kanji}||$_->{title_romaji}, shorten $_->{title_romaji}, 50;
- b ' ('.(defined $_->{type} ? $ANIME_TYPE{$_->{type}}{txt}.', ' : '').$_->{year}.')';
- br;
- }
- }
- end;
- end 'tr';
-}
-
-
-sub _useroptions {
- my($self, $v, $r) = @_;
-
- # Voting option is hidden if nothing has been released yet
- my $minreleased = min grep $_, map $_->{released}, @$r;
-
- my $labels = tuwf->dbAlli(
- 'SELECT l.id, l.label, l.private, uvl.vid IS NOT NULL as assigned
- FROM ulist_labels l
- LEFT JOIN ulist_vns_labels uvl ON uvl.uid = l.uid AND uvl.lbl = l.id AND uvl.vid =', \$v->{id}, '
- WHERE l.uid =', \$self->authInfo->{id}, '
- ORDER BY CASE WHEN l.id < 10 THEN l.id ELSE 10 END, l.label'
- );
- my $lst = tuwf->dbRowi('SELECT vid, vote FROM ulist_vns WHERE uid =', \$self->authInfo->{id}, 'AND vid =', \$v->{id});
-
- Tr class => 'nostripe';
- td colspan => 2;
- VNWeb::HTML::elm_('UList.VNPage', undef, {
- uid => 1*$self->authInfo->{id},
- vid => 1*$v->{id},
- onlist => $lst->{vid}?\1:\0,
- canvote => $minreleased && $minreleased < strftime('%Y%m%d', gmtime) ? \1 : \0,
- vote => fmtvote($lst->{vote}).'',
- labels => [ map +{ id => 1*$_->{id}, label => $_->{label}, private => $_->{private}?\1:\0 }, @$labels ],
- selected => [ map $_->{id}, grep $_->{assigned}, @$labels ],
- });
- end;
- end;
-}
-
-
-sub _affiliate_links {
- my($self, $r) = @_;
-
- # If the same shop link has been added to multiple releases, use the 'first' matching type in this list.
- my @type = ('bundle', '', 'partial', 'trial', 'patch');
-
- # url => [$title, $url, $price, $type]
- my %links;
- for my $rel (@$r) {
- my $type = $rel->{patch} ? 4 :
- $rel->{type} eq 'trial' ? 3 :
- $rel->{type} eq 'partial' ? 2 :
- @{$rel->{vn}} > 1 ? 0 : 1;
-
- for my $l (grep $_->[2], $rel->{extlinks}->@*) {
- $links{$l->[1]} = [ @$l, min $type, $links{$l->[1]}[3]||9 ];
- }
- }
- return if !keys %links;
-
- use utf8;
- Tr id => 'buynow';
- td 'Shops';
- td;
- for my $l (sort { $a->[0] cmp $b->[0] || $a->[2] cmp $b->[2] } values %links) {
- b class => 'standout', '» ';
- a href => $l->[1];
- txt $l->[2];
- b class => 'grayedout', " @ ";
- txt $l->[0];
- b class => 'grayedout', " ($type[$l->[3]])" if $l->[3] != 1;
- end;
- br;
- }
- end;
- end;
-}
-
-
-sub _releases {
- my($self, $v, $r) = @_;
-
- div class => 'mainbox releases';
- h1 'Releases';
- if(!@$r) {
- p 'We don\'t have any information about releases of this visual novel yet...';
- end;
- return;
- }
-
- if($self->authInfo->{id}) {
- my $l = $self->dbRListGet(uid => $self->authInfo->{id}, rid => [map $_->{id}, @$r]);
- for my $i (@$l) {
- [grep $i->{rid} == $_->{id}, @$r]->[0]{ulist} = $i;
- }
- div id => 'vnrlist_code', class => 'hidden', $self->authGetCode('/xml/rlist.xml');
- }
-
- my %lang;
- my @lang = grep !$lang{$_}++, map @{$_->{languages}}, @$r;
-
- table;
- for my $l (@lang) {
- Tr class => 'lang';
- td colspan => 7;
- cssicon "lang $l", $LANGUAGE{$l};
- txt $LANGUAGE{$l};
- end;
- end;
- for my $rel (grep grep($_ eq $l, @{$_->{languages}}), @$r) {
- Tr;
- td class => 'tc1'; lit fmtdatestr $rel->{released}; end;
- td class => 'tc2', $rel->{minage} < 0 ? '' : minage $rel->{minage};
- td class => 'tc3';
- for (sort @{$rel->{platforms}}) {
- next if $_ eq 'oth';
- cssicon $_, $PLATFORM{$_};
- }
- cssicon "rt$rel->{type}", $rel->{type};
- end;
- td class => 'tc4';
- a href => "/r$rel->{id}", title => $rel->{original}||$rel->{title}, $rel->{title};
- b class => 'grayedout', ' (patch)' if $rel->{patch};
- end;
-
- td class => 'tc_icons';
- _release_icons($self, $rel);
- end;
-
- td class => 'tc5';
- if($self->authInfo->{id}) {
- a href => "/r$rel->{id}", id => "rlsel_$rel->{id}", class => 'vnrlsel',
- $rel->{ulist} ? $RLIST_STATUS{ $rel->{ulist}{status} } : '--';
- } else {
- txt ' ';
- }
- end;
- td class => 'tc6';
- $self->releaseExtLinks($rel);
- end;
- end 'tr';
- }
- }
- end 'table';
- end 'div';
-}
-
-
-# Creates an small sized img inside an abbr tag. Used for per-release information icons.
-sub _release_icon {
- my($class, $title, $img) = @_;
- abbr class => "release_icons_container release_icon_$class", title => $title;
- img src=> "$TUWF::OBJ->{url_static}/f/$img.svg", class => "release_icons", alt => $title;
- end;
-}
-
-sub _release_icons {
- my($self, $rel) = @_;
-
- # Voice column
- my $voice = $rel->{voiced};
- _release_icon $VOICED{$voice}{icon}, $VOICED{$voice}{txt}, 'voiced' if $voice;
-
- # Animations columns
- my $story_anim = $rel->{ani_story};
- _release_icon $ANIMATED{$story_anim}{story_icon}, "Story: $ANIMATED{$story_anim}{txt}", 'story_animated' if $story_anim;
-
- my $ero_anim = $rel->{ani_ero};
- _release_icon $ANIMATED{$ero_anim}{ero_icon}, "Ero: $ANIMATED{$ero_anim}{txt}", 'ero_animated' if $ero_anim;
-
- # Cost column
- _release_icon 'freeware', 'Freeware', 'free' if $rel->{freeware};
- _release_icon 'nonfree', 'Non-free', 'nonfree' unless $rel->{freeware};
-
- # Publisher type column
- if(!$rel->{patch}) {
- _release_icon 'doujin', 'Doujin', 'doujin' if $rel->{doujin};
- _release_icon 'commercial', 'Commercial', 'commercial' unless $rel->{doujin};
- }
-
- # Resolution column
- my $resolution = $rel->{resolution};
- if($resolution ne 'unknown') {
- my $resolution_type = $resolution eq 'nonstandard' ? 'custom' : $RESOLUTION{$resolution}{cat} eq 'widescreen' ? '16-9' : '4-3';
- # Ugly workaround: PC-98 has non-square pixels, thus not widescreen
- $resolution_type = '4-3' if $resolution_type eq '16-9' && grep $_ eq 'p98', @{$rel->{platforms}};
- _release_icon "res$resolution_type", $RESOLUTION{$resolution}{txt}, "resolution_$resolution_type";
- }
-
- # Media column
- if(@{$rel->{media}}) {
- my $icon = $MEDIUM{ $rel->{media}[0]{medium} }{icon};
- my $media_detail = join ', ', map fmtmedia($_->{medium}, $_->{qty}), @{$rel->{media}};
- _release_icon $icon, $media_detail, $icon;
- }
-
- _release_icon 'uncensor', 'Uncensored', 'uncensor' if $rel->{uncensored};
-
- # Notes column
- _release_icon 'notes', bb2text($rel->{notes}), 'notes' if $rel->{notes};
-}
-
-
-sub _screenshots {
- my($self, $v, $r) = @_;
-
- input id => 'nsfwhide_chk', type => 'checkbox', class => 'visuallyhidden', $self->authPref('show_nsfw') ? (checked => 'checked') : ();
- div class => 'mainbox', id => 'screenshots';
-
- if(grep $_->{nsfw}, @{$v->{screenshots}}) {
- p class => 'nsfwtoggle';
- txt 'Showing ';
- i id => 'nsfwshown', scalar grep(!$_->{nsfw}, @{$v->{screenshots}});
- span class => 'nsfw', scalar @{$v->{screenshots}};
- txt sprintf ' out of %d screenshot%s. ', scalar @{$v->{screenshots}}, @{$v->{screenshots}} == 1 ? '' : 's';
- label for => 'nsfwhide_chk', class => 'fake_link', 'show/hide NSFW';
- end;
- }
-
- h1 'Screenshots';
-
- for my $rel (@$r) {
- my @scr = grep $_->{rid} && $rel->{id} == $_->{rid}, @{$v->{screenshots}};
- next if !@scr;
- p class => 'rel';
- cssicon "lang $_", $LANGUAGE{$_} for (@{$rel->{languages}});
- cssicon $_, $PLATFORM{$_} for (@{$rel->{platforms}});
- a href => "/r$rel->{id}", $rel->{title};
- end;
- div class => 'scr';
- for (@scr) {
- my($w, $h) = imgsize($_->{width}, $_->{height}, @{$self->{scr_size}});
- a href => imgurl(sf => $_->{id}),
- class => sprintf('scrlnk%s', $_->{nsfw} ? ' nsfw':''),
- 'data-iv' => "$_->{width}x$_->{height}:scr";
- img src => imgurl(st => $_->{id}),
- width => $w, height => $h, alt => "Screenshot #$_->{id}";
- end;
- }
- end;
- }
- end 'div';
-}
-
-
-sub _stats {
- my($self, $v) = @_;
-
- my $stats = $self->dbVoteStats(vid => $v->{id}, 1);
- div class => 'mainbox';
- h1 'User stats';
- if(!grep $_->[0] > 0, @$stats) {
- p 'Nobody has voted on this visual novel yet...';
- } else {
- $self->htmlVoteStats(v => $v, $stats);
- }
- end;
-}
-
-
-sub _charspoillvl {
- my($vid, $c) = @_;
- my $minspoil = 5;
- $minspoil = $_->{vid} == $vid && $_->{spoil} < $minspoil ? $_->{spoil} : $minspoil
- for(@{$c->{vns}});
- return $minspoil;
-}
-
-
-sub _chars {
- my($self, $l, $v) = @_;
- return if !@$l;
- my %done;
- my %rol;
- for my $r (keys %CHAR_ROLE) {
- $rol{$r} = [ grep grep($_->{role} eq $r, @{$_->{vns}}) && !$done{$_->{id}}++, @$l ];
- }
- div class => 'charops', id => 'charops';
- $self->charOps(1, 'chars');
- for my $r (keys %CHAR_ROLE) {
- next if !@{$rol{$r}};
- div class => 'mainbox';
- h1 $CHAR_ROLE{$r}{ @{$rol{$r}} > 1 ? 'plural' : 'txt' };
- $self->charTable($_, 1, $_ != $rol{$r}[0], 1, _charspoillvl $v->{id}, $_) for (@{$rol{$r}});
- end;
- }
- end;
-}
-
-
-sub _charsum {
- my($self, $l, $v) = @_;
- return if !@$l;
-
- my(@l, %done, $has_spoilers);
- for my $r (keys %CHAR_ROLE) {
- last if $r eq 'appears';
- for (grep grep($_->{role} eq $r, @{$_->{vns}}) && !$done{$_->{id}}++, @$l) {
- $_->{role} = $r;
- $has_spoilers = $has_spoilers || _charspoillvl $v->{id}, $_;
- push @l, $_;
- }
- }
-
- div class => 'mainbox charsum summarize charops', 'data-summarize-height' => 200, id => 'charops';
- $self->charOps(0, 'charsum') if $has_spoilers;
- h1 'Character summary';
- div class => 'charsum_list';
- for my $c (@l) {
- div class => 'charsum_bubble'.($has_spoilers ? ' '.charspoil(_charspoillvl $v->{id}, $c) : '');
- div class => 'name';
- i $CHAR_ROLE{$c->{role}}{txt};
- cssicon "gen $c->{gender}", $GENDER{$c->{gender}} if $c->{gender} ne 'unknown';
- a href => "/c$c->{id}", title => $c->{original}||$c->{name}, $c->{name};
- end;
- if(@{$c->{seiyuu}}) {
- div class => 'actor';
- txt 'Voiced by';
- @{$c->{seiyuu}} > 1 ? br : txt ' ';
- for my $s (sort { $a->{name} cmp $b->{name} } @{$c->{seiyuu}}) {
- a href => "/s$s->{sid}", title => $s->{original}||$s->{name}, $s->{name};
- b class => 'grayedout', $s->{note} if $s->{note};
- br;
- }
- end;
- }
- end;
- }
- end;
- end;
-}
-
-
-sub _staff {
- my ($self, $v) = @_;
- return if !@{$v->{credits}};
-
- div class => 'mainbox staff summarize', 'data-summarize-height' => 200, id => 'staff';
- h1 'Staff';
- for my $r (keys %CREDIT_TYPE) {
- my @s = grep $_->{role} eq $r, @{$v->{credits}};
- next if !@s;
- ul;
- li; b $CREDIT_TYPE{$r}; end;
- for(@s) {
- li;
- a href => "/s$_->{id}", title => $_->{original}||$_->{name}, $_->{name};
- b class => 'grayedout', $_->{note} if $_->{note};
- end;
- }
- end;
- }
- clearfloat;
- end;
-}
-
-1;
-
diff --git a/lib/VNDB/Schema.pm b/lib/VNDB/Schema.pm
index b6e476b6..ffc80e77 100644
--- a/lib/VNDB/Schema.pm
+++ b/lib/VNDB/Schema.pm
@@ -1,4 +1,4 @@
-# Utility functions to parse the files in util/sql/ and extract information and
+# Utility functions to parse the files in sql/ and extract information and
# perform a few simple sanity checks.
#
# This is not a full-blown SQL parser. The code makes all kinds of assumptions
@@ -23,54 +23,54 @@ my $ROOT = $INC{'VNDB/Schema.pm'} =~ s{/lib/VNDB/Schema\.pm}{}r;
# type => 'serial',
# decl => 'id SERIAL', # full declaration, exluding comments and PRIMARY KEY marker
# pub => 1,
+# comment => '',
# }, ...
# ],
# primary => ['id'],
+# comment => '',
# }
# }
sub schema {
my %schema;
my $table;
- open my $F, '<', "$ROOT/util/sql/schema.sql" or die "schema.sql: $!";
+ open my $F, '<', "$ROOT/sql/schema.sql" or die "schema.sql: $!";
while(<$F>) {
chomp;
next if /^\s*--/ || /^\s*$/;
- next if /^\s*CREATE\s+TYPE/;
- next if /^\s*CREATE\s+SEQUENCE/;
+ next if /^\s*CREATE\s+(?:TYPE|SEQUENCE|FUNCTION|DOMAIN|VIEW)/;
if(/^\s*CREATE\s+TABLE\s+([^ ]+)/) {
die "Unexpected 'CREATE TABLE $1'\n" if $table;
+ next if /PARTITION OF/;
$table = $1;
$schema{$table}{name} = $table;
- $schema{$table}{dbentry_type} = $1 if /--.*\s+dbentry_type=(.)/;
+ $schema{$table}{comment} = /--\s*(.*)\s*/ ? $1 : '';
+ $schema{$table}{dbentry_type} = $1 if $schema{$table}{comment} =~ s/\s*dbentry_type=(.)\s*//;
$schema{$table}{cols} = [];
- } elsif(/^\s*\);/) {
+ } elsif(/^\s*\)(?: PARTITION .+)?;/) {
$table = undef;
- } elsif(/^\s+CHECK/) {
+ } elsif(/^\s+(?:CHECK|CONSTRAINT)/) {
# ignore
} elsif($table && /^\s+PRIMARY\s+KEY\s*\(([^\)]+)\)/i) {
die "Double primary key for '$table'?\n" if $schema{$table}{primary};
$schema{$table}{primary} = [ map s/\s*"?([^\s"]+)"?\s*/$1/r, split /,/, $1 ];
- } elsif($table && s/^\s+"?([^"\( ]+)"?\s+//) {
+ } elsif($table && s/^\s+([^"\( ]+)\s+//) {
my $col = { name => $1 };
push @{$schema{$table}{cols}}, $col;
- $col->{pub} = /--.*\[pub\]/;
- s/,?\s*(?:--.*)?$//;
+ $col->{comment} = (s/,?\s*(?:--(.*))?$// && $1) || '';
+ $col->{pub} = $col->{comment} =~ s/\s*\[pub\]\s*//;
if(s/\s+PRIMARY\s+KEY//i) {
die "Double primary key for '$table'?\n" if $schema{$table}{primary};
$schema{$table}{primary} = [ $col->{name} ];
}
- $col->{decl} = "\"$col->{name}\" $_";
+ $col->{decl} = "$col->{name} $_";
$col->{type} = lc s/^([^ ]+)\s.+/$1/r;
-
- } else {
- die "Unrecognized line in schema.sql: $_\n";
}
}
@@ -86,10 +86,10 @@ sub schema {
# }
sub types {
my %types;
- open my $F, '<', "$ROOT/util/sql/schema.sql" or die "schema.sql: $!";
+ open my $F, '<', "$ROOT/sql/schema.sql" or die "schema.sql: $!";
while(<$F>) {
chomp;
- if(/^CREATE TYPE ([^ ]+)/) {
+ if(/^CREATE (?:TYPE|DOMAIN) ([^ ]+)/) {
$types{$1} = { decl => $_ };
}
}
@@ -110,7 +110,7 @@ sub types {
# ]
sub references {
my @ref;
- open my $F, '<', "$ROOT/util/sql/tableattrs.sql" or die "tableattrs.sql: $!";
+ open my $F, '<', "$ROOT/sql/tableattrs.sql" or die "tableattrs.sql: $!";
while(<$F>) {
chomp;
next if !/^\s*ALTER\s+TABLE\s+([^ ]+)\s+ADD\s+CONSTRAINT\s+([^ ]+)\s+FOREIGN\s+KEY\s+\(([^\)]+)\)\s*REFERENCES\s+([^ ]+)\s*\(([^\)]+)\)/;
@@ -118,9 +118,9 @@ sub references {
decl => $_,
from_table => $1,
name => $2,
- from_cols => [ map s/"//r, split /\s*,\s*/, $3 ],
+ from_cols => [ split /\s*,\s*/, $3 ],
to_table => $4,
- to_cols => [ map s/"//r, split /\s*,\s*/, $5 ]
+ to_cols => [ split /\s*,\s*/, $5 ]
};
}
\@ref
diff --git a/lib/VNDB/Skins.pm b/lib/VNDB/Skins.pm
new file mode 100644
index 00000000..d53eec5b
--- /dev/null
+++ b/lib/VNDB/Skins.pm
@@ -0,0 +1,27 @@
+package VNDB::Skins;
+
+use v5.26;
+use warnings;
+use Exporter 'import';
+our @EXPORT = ('skins');
+
+my $ROOT = $INC{'VNDB/Skins.pm'} =~ s{/lib/VNDB/Skins\.pm$}{}r;
+
+my $skins;
+
+sub skins {
+ $skins ||= do { +{ map {
+ my $skin = /\/([^\/]+)\.sass/ ? $1 : die;
+ my %o;
+ open my $F, '<:utf8', $_ or die $!;
+ if(<$F> !~ qr{^// *userid: *(u[0-9]+) *name: *(.+)}) {
+ warn "Invalid skin: $skin\n";
+ ()
+ } else {
+ +( $skin, { userid => $1, name => $2 })
+ }
+ } glob "$ROOT/css/skins/*.sass" } };
+ $skins;
+}
+
+1;
diff --git a/lib/VNDB/Types.pm b/lib/VNDB/Types.pm
index 3341343d..16f730c5 100644
--- a/lib/VNDB/Types.pm
+++ b/lib/VNDB/Types.pm
@@ -15,47 +15,61 @@ sub hash {
# SQL: ENUM language
+# 'latin' indicates whether the language is primarily written in a latin-ish script.
+# 'rank' is for quick selection of commonly used languages.
hash LANGUAGE =>
- ar => 'Arabic',
- bg => 'Bulgarian',
- ca => 'Catalan',
- cs => 'Czech',
- da => 'Danish',
- de => 'German',
- el => 'Greek',
- en => 'English',
- eo => 'Esperanto',
- es => 'Spanish',
- fi => 'Finnish',
- fr => 'French',
- gd => 'Scottish Gaelic',
- he => 'Hebrew',
- hr => 'Croatian',
- hu => 'Hungarian',
- id => 'Indonesian',
- it => 'Italian',
- ja => 'Japanese',
- ko => 'Korean',
- mk => 'Macedonian',
- ms => 'Malay',
- lt => 'Lithuanian',
- lv => 'Latvian',
- nl => 'Dutch',
- no => 'Norwegian',
- pl => 'Polish',
- 'pt-br' => 'Portuguese (Brazil)',
- 'pt-pt' => 'Portuguese (Portugal)',
- ro => 'Romanian',
- ru => 'Russian',
- sk => 'Slovak',
- sl => 'Slovene',
- sv => 'Swedish',
- ta => 'Tagalog',
- th => 'Thai',
- tr => 'Turkish',
- uk => 'Ukrainian',
- vi => 'Vietnamese',
- zh => 'Chinese';
+ ar => { latin => 0, rank => 0, txt => 'Arabic' },
+ eu => { latin => 1, rank => 0, txt => 'Basque' },
+ be => { latin => 0, rank => 0, txt => 'Belarusian' },
+ bg => { latin => 1, rank => 0, txt => 'Bulgarian' },
+ ca => { latin => 1, rank => 0, txt => 'Catalan' },
+ ck => { latin => 0, rank => 0, txt => 'Cherokee' }, # 'chr' in ISO 639-2 but not present in ISO 639-1, let's just use an unassigned code
+ zh => { latin => 0, rank => 2, txt => 'Chinese' },
+ 'zh-Hans'=> { latin => 0, rank => 2, txt => 'Chinese (simplified)' },
+ 'zh-Hant'=> { latin => 0, rank => 2, txt => 'Chinese (traditional)' },
+ hr => { latin => 1, rank => 0, txt => 'Croatian' },
+ cs => { latin => 1, rank => 0, txt => 'Czech' },
+ da => { latin => 1, rank => 0, txt => 'Danish' },
+ nl => { latin => 1, rank => 0, txt => 'Dutch' },
+ en => { latin => 1, rank => 3, txt => 'English' },
+ eo => { latin => 1, rank => 0, txt => 'Esperanto' },
+ fi => { latin => 1, rank => 0, txt => 'Finnish' },
+ fr => { latin => 1, rank => 1, txt => 'French' },
+ de => { latin => 1, rank => 1, txt => 'German' },
+ el => { latin => 0, rank => 0, txt => 'Greek' },
+ he => { latin => 0, rank => 0, txt => 'Hebrew' },
+ hi => { latin => 0, rank => 0, txt => 'Hindi' },
+ hu => { latin => 1, rank => 0, txt => 'Hungarian' },
+ ga => { latin => 1, rank => 0, txt => 'Irish' },
+ id => { latin => 1, rank => 0, txt => 'Indonesian' },
+ it => { latin => 1, rank => 0, txt => 'Italian' },
+ iu => { latin => 1, rank => 0, txt => 'Inuktitut' },
+ ja => { latin => 0, rank => 4, txt => 'Japanese' },
+ ko => { latin => 0, rank => 1, txt => 'Korean' },
+ la => { latin => 1, rank => 0, txt => 'Latin' },
+ lv => { latin => 1, rank => 0, txt => 'Latvian' },
+ lt => { latin => 1, rank => 0, txt => 'Lithuanian' },
+ mk => { latin => 1, rank => 0, txt => 'Macedonian' },
+ ms => { latin => 1, rank => 0, txt => 'Malay' },
+ no => { latin => 1, rank => 0, txt => 'Norwegian' },
+ fa => { latin => 0, rank => 0, txt => 'Persian' },
+ pl => { latin => 1, rank => 0, txt => 'Polish' },
+ 'pt-br' => { latin => 1, rank => 1, txt => 'Portuguese (Brazil)' },
+ 'pt-pt' => { latin => 1, rank => 1, txt => 'Portuguese (Portugal)' },
+ ro => { latin => 1, rank => 0, txt => 'Romanian' },
+ ru => { latin => 0, rank => 2, txt => 'Russian' },
+ gd => { latin => 1, rank => 0, txt => 'Scottish Gaelic' },
+ sr => { latin => 1, rank => 0, txt => 'Serbian' },
+ sk => { latin => 0, rank => 0, txt => 'Slovak' },
+ sl => { latin => 1, rank => 0, txt => 'Slovene' },
+ es => { latin => 1, rank => 1, txt => 'Spanish' },
+ sv => { latin => 1, rank => 0, txt => 'Swedish' },
+ ta => { latin => 1, rank => 0, txt => 'Tagalog' },
+ th => { latin => 0, rank => 0, txt => 'Thai' },
+ tr => { latin => 1, rank => 0, txt => 'Turkish' },
+ uk => { latin => 0, rank => 1, txt => 'Ukrainian' },
+ ur => { latin => 0, rank => 0, txt => 'Urdu' },
+ vi => { latin => 1, rank => 1, txt => 'Vietnamese' };
@@ -63,19 +77,29 @@ hash LANGUAGE =>
# The 'unk' platform is used to mean "Unknown" in various places (not in the DB).
hash PLATFORM =>
win => 'Windows',
- dos => 'DOS',
lin => 'Linux',
mac => 'Mac OS',
+ web => 'Website',
+ tdo => '3DO',
ios => 'Apple iProduct',
and => 'Android',
- dvd => 'DVD Player',
bdp => 'Blu-ray Player',
+ dos => 'DOS',
+ dvd => 'DVD Player',
+ drc => 'Dreamcast',
+ nes => 'Famicom',
+ sfc => 'Super Famicom',
+ fm7 => 'FM-7',
+ fm8 => 'FM-8',
fmt => 'FM Towns',
gba => 'Game Boy Advance',
gbc => 'Game Boy Color',
msx => 'MSX',
nds => 'Nintendo DS',
- nes => 'Famicom',
+ swi => 'Nintendo Switch',
+ wii => 'Nintendo Wii',
+ wiu => 'Nintendo Wii U',
+ n3d => 'Nintendo 3DS',
p88 => 'PC-88',
p98 => 'PC-98',
pce => 'PC Engine',
@@ -85,48 +109,65 @@ hash PLATFORM =>
ps2 => 'PlayStation 2',
ps3 => 'PlayStation 3',
ps4 => 'PlayStation 4',
+ ps5 => 'PlayStation 5',
psv => 'PlayStation Vita',
- drc => 'Dreamcast',
+ smd => 'Sega Mega Drive',
+ scd => 'Sega Mega-CD',
sat => 'Sega Saturn',
- sfc => 'Super Nintendo',
- swi => 'Nintendo Switch',
- wii => 'Nintendo Wii',
- wiu => 'Nintendo Wii U',
- n3d => 'Nintendo 3DS',
- x68 => 'X68000',
+ vnd => 'VNDS',
+ x1s => 'Sharp X1',
+ x68 => 'Sharp X68000',
xb1 => 'Xbox',
xb3 => 'Xbox 360',
xbo => 'Xbox One',
- web => 'Website',
+ xxs => 'Xbox X/S',
+ mob => 'Other (mobile)',
oth => 'Other';
# SQL: ENUM vn_relation
hash VN_RELATION =>
- seq => { reverse => 'preq', txt => 'Sequel' },
- preq => { reverse => 'seq', txt => 'Prequel' },
- set => { reverse => 'set', txt => 'Same setting' },
- alt => { reverse => 'alt', txt => 'Alternative version' },
- char => { reverse => 'char', txt => 'Shares characters' },
- side => { reverse => 'par', txt => 'Side story' },
- par => { reverse => 'side', txt => 'Parent story' },
- ser => { reverse => 'ser', txt => 'Same series' },
- fan => { reverse => 'orig', txt => 'Fandisc' },
- orig => { reverse => 'fan', txt => 'Original game' };
-
+ seq => { reverse => 'preq', pref => 1, txt => 'Sequel' },
+ preq => { reverse => 'seq', pref => 0, txt => 'Prequel' },
+ set => { reverse => 'set', pref => 0, txt => 'Same setting' },
+ alt => { reverse => 'alt', pref => 0, txt => 'Alternative version' },
+ char => { reverse => 'char', pref => 0, txt => 'Shares characters' },
+ side => { reverse => 'par', pref => 1, txt => 'Side story' },
+ par => { reverse => 'side', pref => 0, txt => 'Parent story' },
+ ser => { reverse => 'ser', pref => 0, txt => 'Same series' },
+ fan => { reverse => 'orig', pref => 1, txt => 'Fandisc' },
+ orig => { reverse => 'fan', pref => 0, txt => 'Original game' };
+
+
+hash DEVSTATUS =>
+ 0 => 'Finished',
+ 1 => 'In development',
+ 2 => 'Cancelled';
+
+
+hash DRM_PROPERTY => # No DRM: https://lucide.dev/icons/unlock (needs circle?)
+ disc => 'Disc check', # https://lucide.dev/icons/disc-3
+ cdkey => 'CD-key', # https://lucide.dev/icons/key-round (needs circle?)
+ activate => 'Online activation', # https://lucide.dev/icons/wifi (needs circle?)
+ alimit => 'Activation limit',
+ account => 'Account-based', # https://lucide.dev/icons/link (needs circle?)
+ online => 'Always online',
+ cloud => 'Cloud gaming',
+ physical => 'Physical'; # XXX: How does this relate to cdkey?
# SQL: ENUM producer_relation
+# "Pref" relations are considered the "preferred" relation to show (as opposed to their reverse)
hash PRODUCER_RELATION =>
- old => { reverse => 'new', txt => 'Formerly' },
- new => { reverse => 'old', txt => 'Succeeded by' },
- spa => { reverse => 'ori', txt => 'Spawned' },
- ori => { reverse => 'spa', txt => 'Originated from' },
- sub => { reverse => 'par', txt => 'Subsidiary' },
- par => { reverse => 'sub', txt => 'Parent producer' },
- imp => { reverse => 'ipa', txt => 'Imprint' },
- ipa => { reverse => 'imp', txt => 'Parent brand' };
+ old => { reverse => 'new', pref => 0, txt => 'Formerly' },
+ new => { reverse => 'old', pref => 1, txt => 'Succeeded by' },
+ spa => { reverse => 'ori', pref => 1, txt => 'Spawned' },
+ ori => { reverse => 'spa', pref => 0, txt => 'Originated from' },
+ sub => { reverse => 'par', pref => 1, txt => 'Subsidiary' },
+ par => { reverse => 'sub', pref => 0, txt => 'Parent producer' },
+ imp => { reverse => 'ipa', pref => 1, txt => 'Imprint' },
+ ipa => { reverse => 'imp', pref => 0, txt => 'Parent brand' };
@@ -141,22 +182,25 @@ hash PRODUCER_TYPE =>
# SQL: ENUM credit_type
hash CREDIT_TYPE =>
scenario => 'Scenario',
+ director => 'Director',
chardesign => 'Character design',
art => 'Artist',
music => 'Composer',
songs => 'Vocals',
- director => 'Director',
+ translator => 'Translator',
+ editor => 'Editor',
+ qa => 'Quality assurance',
staff => 'Staff';
hash VN_LENGTH =>
- 0 => { txt => 'Unknown', time => '' },
- 1 => { txt => 'Very short', time => '< 2 hours' },
- 2 => { txt => 'Short', time => '2 - 10 hours' },
- 3 => { txt => 'Medium', time => '10 - 30 hours' },
- 4 => { txt => 'Long', time => '30 - 50 hours' },
- 5 => { txt => 'Very long', time => '> 50 hours' };
+ 0 => { txt => 'Unknown', time => '', low => 0, high => 0 },
+ 1 => { txt => 'Very short', time => '< 2 hours', low => 1, high => 2*60 },
+ 2 => { txt => 'Short', time => '2 - 10 hours', low => 2*60, high => 10*60 },
+ 3 => { txt => 'Medium', time => '10 - 30 hours', low => 10*60, high => 30*60 },
+ 4 => { txt => 'Long', time => '30 - 50 hours', low => 30*60, high => 50*60 },
+ 5 => { txt => 'Very long', time => '> 50 hours', low => 50*60, high => 32767 };
@@ -181,28 +225,26 @@ hash TAG_CATEGORY =>
hash ANIMATED =>
- 0 => { txt => 'Unknown', story_icon => 'unknown', ero_icon => 'unknown' },
- 1 => { txt => 'No animations', story_icon => 'story_not_animated', ero_icon => 'ero_not_animated' },
- 2 => { txt => 'Simple animations', story_icon => 'story_simple_animated', ero_icon => 'ero_simple_animated' },
- 3 => { txt => 'Some fully animated scenes', story_icon => 'story_some_fully_animated', ero_icon => 'ero_some_fully_animated' },
- 4 => { txt => 'All scenes fully animated', story_icon => 'story_all_fully_animated', ero_icon => 'ero_all_fully_animated' };
+ 0 => { txt => 'Unknown' },
+ 1 => { txt => 'Not animated' },
+ 2 => { txt => 'Simple animations' },
+ 3 => { txt => 'Some fully animated scenes' },
+ 4 => { txt => 'All scenes fully animated' };
hash VOICED =>
- 0 => { txt => 'Unknown', icon => 'unknown' },
- 1 => { txt => 'Not voiced', icon => 'not_voiced' },
- 2 => { txt => 'Only ero scenes voiced', icon => 'ero_voiced' },
- 3 => { txt => 'Partially voiced', icon => 'partially_voiced' },
- 4 => { txt => 'Fully voiced', icon => 'fully_voiced' };
+ 0 => { txt => 'Unknown' },
+ 1 => { txt => 'Not voiced' },
+ 2 => { txt => 'Only ero scenes voiced' },
+ 3 => { txt => 'Partially voiced' },
+ 4 => { txt => 'Fully voiced' };
-# TODO: For some reason the minage column in SQL is nullable but still stores 'unknown' as -1.
-# This should be cleaned up at some point.
hash AGE_RATING =>
- -1 => { txt => 'Unknown', ex => '' },
0 => { txt => 'All ages', ex => 'CERO A' },
+ 3 => { txt => '3+', ex => '' },
6 => { txt => '6+', ex => '' },
7 => { txt => '7+', ex => '' },
8 => { txt => '8+', ex => '' },
@@ -227,6 +269,7 @@ hash MEDIUM =>
gdr => { qty => 1, txt => 'GD-ROM', plural => 'GD-ROMs', icon => 'disk' },
blr => { qty => 1, txt => 'Blu-ray disc', plural => 'Blu-ray discs', icon => 'disk' },
flp => { qty => 1, txt => 'Floppy', plural => 'Floppies', icon => 'cartridge' },
+ cas => { qty => 1, txt => 'Cassette tape', plural => 'Cassette tapes', icon => 'cartridge' },
mrt => { qty => 1, txt => 'Cartridge', plural => 'Cartridges', icon => 'cartridge' },
mem => { qty => 1, txt => 'Memory card', plural => 'Memory cards', icon => 'cartridge' },
umd => { qty => 1, txt => 'UMD', plural => 'UMDs', icon => 'disk' },
@@ -236,29 +279,6 @@ hash MEDIUM =>
-# SQL: ENUM resolution
-hash RESOLUTION =>
- unknown => { txt => 'Unknown / console / handheld', cat => '' }, # hardcoded in many places
- nonstandard => { txt => 'Non-standard', cat => '' }, # hardcoded in VNPage.pm
- '640x480' => { txt => '640x480', cat => '4:3' },
- '800x600' => { txt => '800x600', cat => '4:3' },
- '1024x768' => { txt => '1024x768', cat => '4:3' },
- '1280x960' => { txt => '1280x960', cat => '4:3' },
- '1600x1200' => { txt => '1600x1200', cat => '4:3' },
- '640x400' => { txt => '640x400', cat => 'widescreen' },
- '960x600' => { txt => '960x600', cat => 'widescreen' },
- '960x640' => { txt => '960x640', cat => 'widescreen' },
- '1024x576' => { txt => '1024x576', cat => 'widescreen' },
- '1024x600' => { txt => '1024x600', cat => 'widescreen' },
- '1024x640' => { txt => '1024x640', cat => 'widescreen' },
- '1280x720' => { txt => '1280x720', cat => 'widescreen' },
- '1280x800' => { txt => '1280x800', cat => 'widescreen' },
- '1366x768' => { txt => '1366x768', cat => 'widescreen' },
- '1600x900' => { txt => '1600x900', cat => 'widescreen' },
- '1920x1080' => { txt => '1920x1080', cat => 'widescreen' };
-
-
-
# SQL: ENUM release_type
hash RELEASE_TYPE =>
complete => 'Complete',
diff --git a/lib/VNDB/Util/Auth.pm b/lib/VNDB/Util/Auth.pm
deleted file mode 100644
index 4394149f..00000000
--- a/lib/VNDB/Util/Auth.pm
+++ /dev/null
@@ -1,129 +0,0 @@
-# Compatibility shim around VNWeb::Auth, new code should use that instead.
-package VNDB::Util::Auth;
-
-
-use strict;
-use warnings;
-use Exporter 'import';
-use TUWF ':html';
-use VNWeb::Auth;
-
-
-our @EXPORT = qw|
- authInit authLogin authLogout authInfo authCan authSetPass authAdminSetPass
- authResetPass authIsValidToken authGetCode authCheckCode authPref
-|;
-
-
-# login, arguments: user, password, url-to-redirect-to-on-success
-# returns 1 on success (redirected), 0 otherwise (no reply sent)
-sub authLogin {
- my(undef, $user, $pass, $to) = @_;
- my $success = auth->login($user, $pass);
- tuwf->resRedirect($to, 'post') if $success;
- $success
-}
-
-# clears authentication cookie and redirects to /
-sub authLogout {
- auth->logout;
- tuwf->resRedirect('/', 'temp');
-}
-
-
-# Replaces the user's password with a random token that can be used to reset the password.
-sub authResetPass {
- my(undef, $mail) = @_;
- auth->resetpass($mail)
-}
-
-
-sub authIsValidToken {
- my(undef, $uid, $token) = @_;
- auth->isvalidtoken($uid, $token)
-}
-
-
-# uid, new_pass, url_to_redir_to, 'token'|'pass', $token_or_pass
-# Changes the user's password, invalidates all existing sessions, creates a new
-# session and redirects.
-sub authSetPass {
- my(undef, $uid, $pass, $redir, $oldtype, $oldpass) = @_;
-
- my $success = auth->setpass($uid, $oldtype eq 'token' ? $oldpass : undef, $oldtype eq 'pass' ? $oldpass : undef, $pass);
- tuwf->resRedirect($redir, 'post') if $success;
- $success
-}
-
-
-sub authAdminSetPass {
- my(undef, $uid, $pass) = @_;
- auth->admin_setpass($uid, $pass);
-}
-
-
-sub authInfo {
- # Used to return a lot more, but only the id is still used now.
- # (code using other fields has been migrated)
- +{ id => auth->uid }
-}
-
-
-# returns whether the currently loggedin or anonymous user can perform
-# a certain action.
-sub authCan {
- my(undef, $act) = @_;
- auth->perm() & auth->listPerms->{$act}
-}
-
-
-# Generate a code to be used later on to validate that the form was indeed
-# submitted from our site and by the same user/visitor. Not limited to
-# logged-in users.
-# Arguments:
-# form-id (ignored nowadyas)
-# time (also ignored)
-sub authGetCode {
- auth->csrftoken;
-}
-
-
-# Validates the correctness of the returned code, creates an error page and
-# returns false if it's invalid, returns true otherwise. Codes are valid for at
-# least two and at most three hours.
-# Arguments:
-# [ form-id, [ code ] ]
-# If the code is not given, uses the 'formcode' form parameter instead. If
-# form-id is not given, the path of the current requests is used.
-sub authCheckCode {
- my $self = shift;
- my $id = shift;
- my $code = shift || $self->reqParam('formcode');
- return _incorrectcode($self) if !auth->csrfcheck($code);
- 1;
-}
-
-
-sub _incorrectcode {
- my $self = shift;
- $self->resInit;
- $self->htmlHeader(title => 'Validation code expired', noindex => 1);
-
- div class => 'mainbox';
- h1 'Validation code expired';
- div class => 'warning';
- p 'Please hit the back-button of your browser, refresh the page and try again.';
- end;
- end;
-
- $self->htmlFooter;
- return 0;
-}
-
-
-sub authPref {
- my(undef, $key, $val) = @_;
- @_ == 2 ? auth->pref($key)||'' : auth->prefSet($key, $val);
-}
-
-1;
diff --git a/lib/VNDB/Util/BrowseHTML.pm b/lib/VNDB/Util/BrowseHTML.pm
deleted file mode 100644
index 29d131c5..00000000
--- a/lib/VNDB/Util/BrowseHTML.pm
+++ /dev/null
@@ -1,190 +0,0 @@
-
-package VNDB::Util::BrowseHTML;
-
-use strict;
-use warnings;
-use TUWF ':html', 'xml_escape';
-use Exporter 'import';
-use VNDB::Func;
-use VNDB::Types;
-use POSIX 'ceil';
-
-
-our @EXPORT = qw| htmlBrowse htmlBrowseNavigate htmlBrowseVN |;
-
-
-# generates a browse box, arguments:
-# items => arrayref with the list items
-# options => hashref containing at least the keys s (sort key), o (order) and p (page)
-# nextpage => whether there's a next page or not
-# sorturl => base URL to append the sort options to (if there are any sortable columns)
-# pageurl => base URL to append the page option to
-# class => classname of the mainbox
-# header =>
-# can be either an arrayref or subroutine reference,
-# in the case of a subroutine, it will be called when the header should be written,
-# in the case of an arrayref, the array should contain the header items. Each item
-# can again be either an arrayref or subroutine ref. The arrayref would consist of
-# two elements: the name of the header, and the name of the sorting column if it can
-# be sorted
-# row => subroutine ref, which is called for each item in $list, arguments will be
-# $self, $item_number (starting from 0), $item_value
-# footer => subroutine ref, called after all rows have been processed
-sub htmlBrowse {
- my($self, %opt) = @_;
-
- $opt{sorturl} .= $opt{sorturl} =~ /\?/ ? ';' : '?' if $opt{sorturl};
-
- # top navigation
- $self->htmlBrowseNavigate($opt{pageurl}, $opt{options}{p}, $opt{nextpage}, 't') if $opt{pageurl};
-
- div class => 'mainbox browse'.($opt{class} ? ' '.$opt{class} : '');
- table class => 'stripe';
-
- # header
- thead;
- Tr;
- if(ref $opt{header} eq 'CODE') {
- $opt{header}->($self);
- } else {
- for(0..$#{$opt{header}}) {
- if(ref $opt{header}[$_] eq 'CODE') {
- $opt{header}[$_]->($self, $_+1);
- } else {
- td class => $opt{header}[$_][3]||'tc'.($_+1), $opt{header}[$_][2] ? (colspan => $opt{header}[$_][2]) : ();
- lit $opt{header}[$_][0];
- if($opt{header}[$_][1]) {
- lit ' ';
- $opt{options}{s} eq $opt{header}[$_][1] && $opt{options}{o} eq 'a' ? lit "\x{25B4}" : a href => "$opt{sorturl}o=a;s=$opt{header}[$_][1]", "\x{25B4}";
- $opt{options}{s} eq $opt{header}[$_][1] && $opt{options}{o} eq 'd' ? lit "\x{25BE}" : a href => "$opt{sorturl}o=d;s=$opt{header}[$_][1]", "\x{25BE}";
- }
- end;
- }
- }
- }
- end;
- end 'thead';
-
- # footer
- if($opt{footer}) {
- tfoot;
- $opt{footer}->($self);
- end;
- }
-
- # rows
- $opt{row}->($self, $_+1, $opt{items}[$_])
- for 0..$#{$opt{items}};
-
- end 'table';
- end 'div';
-
- # bottom navigation
- $self->htmlBrowseNavigate($opt{pageurl}, $opt{options}{p}, $opt{nextpage}, 'b') if $opt{pageurl};
-}
-
-
-# creates next/previous buttons (tabs), if needed
-# Arguments: page url, current page (1..n), nextpage (0/1 or [$total, $perpage]), alignment (t/b), noappend (0/1)
-sub htmlBrowseNavigate {
- my($self, $url, $p, $np, $al, $na) = @_;
- my($cnt, $pp) = ref($np) ? @$np : ($p+$np, 1);
- return if $p == 1 && $cnt <= $pp;
-
- $url .= $url =~ /\?/ ? ';p=' : '?p=' unless $na;
-
- my $tab = sub {
- my($page, $label) = @_;
- li;
- a href => $url.$page; lit $label; end;
- end;
- };
- my $ell = sub {
- use utf8;
- li class => 'ellipsis';
- b '⋯';
- end;
- };
- my $nc = 5; # max. number of buttons on each side
-
- div class => 'maintabs browsetabs '.($al eq 't' ? '' : 'bottom');
- ul;
- $p > 2 and ref $np and $tab->(1, '&laquo; first');
- $p > $nc+1 and ref $np and $ell->();
- $p > $_ and ref $np and $tab->($p-$_, $p-$_) for (reverse 2..($nc>$p-2?$p-2:$nc-1));
- $p > 1 and $tab->($p-1, '&lsaquo; previous');
- end;
-
- ul;
- my $l = ceil($cnt/$pp)-$p+1;
- $l > 1 and $tab->($p+1, 'next &rsaquo;');
- $l > $_ and $tab->($p+$_, $p+$_) for (2..($nc>$l-2?$l-2:$nc-1));
- $l > $nc+1 and $ell->();
- $l > 2 and $tab->($l+$p-1, 'last &raquo;');
- end;
- end 'div';
-}
-
-
-sub htmlBrowseVN {
- my($self, $list, $f, $np, $url, $tagscore) = @_;
- $self->htmlBrowse(
- class => 'vnbrowse',
- items => $list,
- options => $f,
- nextpage => $np,
- pageurl => "$url;o=$f->{o};s=$f->{s}",
- sorturl => $url,
- header => [
- $tagscore ? [ 'Score', 'tagscore', undef, 'tc_s' ] : (),
- [ 'Title', 'title', undef, $tagscore ? 'tc_t' : 'tc1' ],
- $f->{vnlist} ? [ '', 0, undef, 'tc7' ] : (),
- $f->{wish} ? [ '', 0, undef, 'tc8' ] : (),
- [ '', 0, undef, 'tc2' ],
- [ '', 0, undef, 'tc3' ],
- [ 'Released', 'rel', undef, 'tc4' ],
- [ 'Popularity', 'pop', undef, 'tc5' ],
- [ 'Rating', 'rating', undef, 'tc6' ],
- ],
- row => sub {
- my($s, $n, $l) = @_;
- Tr;
- if($tagscore) {
- td class => 'tc_s';
- VNWeb::Tags::Lib::tagscore_($l->{tagscore});
- end;
- }
- td class => $tagscore ? 'tc_t' : 'tc1';
- a href => '/v'.$l->{id}, title => $l->{original}||$l->{title}, shorten $l->{title}, 100;
- end;
- if($f->{vnlist}) {
- td class => 'tc7';
- lit sprintf '<b class="%s">%d/%d</b>', $l->{userlist_obtained} == $l->{userlist_all} ? 'done' : 'todo', $l->{userlist_obtained}, $l->{userlist_all} if $l->{userlist_all};
- abbr title => join(', ', $l->{vnlist_labels}->@*), scalar $l->{vnlist_labels}->@* if $l->{vnlist_labels} && $l->{vnlist_labels}->@*;
- abbr title => 'No labels', ' ' if $l->{vnlist_labels} && !$l->{vnlist_labels}->@*;
- end 'td';
- }
- td class => 'tc2';
- $_ ne 'oth' && cssicon $_, $PLATFORM{$_}
- for (sort @{$l->{c_platforms}});
- end;
- td class => 'tc3';
- cssicon "lang $_", $LANGUAGE{$_}
- for (reverse sort @{$l->{c_languages}});
- end;
- td class => 'tc4';
- lit fmtdatestr $l->{c_released};
- end;
- td class => 'tc5', sprintf '%.2f', ($l->{c_popularity}||0)*100;
- td class => 'tc6';
- txt sprintf '%.2f', ($l->{c_rating}||0)/10;
- b class => 'grayedout', sprintf ' (%d)', $l->{c_votecount};
- end;
- end 'tr';
- },
- );
-}
-
-
-1;
-
diff --git a/lib/VNDB/Util/CommonHTML.pm b/lib/VNDB/Util/CommonHTML.pm
deleted file mode 100644
index 7a3d554c..00000000
--- a/lib/VNDB/Util/CommonHTML.pm
+++ /dev/null
@@ -1,327 +0,0 @@
-
-package VNDB::Util::CommonHTML;
-
-use strict;
-use warnings;
-use TUWF ':html', 'xml_escape', 'html_escape';
-use Exporter 'import';
-use Algorithm::Diff::XS 'compact_diff';
-use Encode 'encode_utf8', 'decode_utf8';
-use VNDB::Func;
-use POSIX 'ceil';
-
-our @EXPORT = qw|
- htmlMainTabs htmlDenied htmlHiddenMessage htmlRevision
- htmlEditMessage htmlItemMessage htmlVoteStats htmlSearchBox htmlRGHeader
-|;
-
-
-# generates the "main tabs". These are the commonly used tabs for
-# 'objects', i.e. VN/producer/release entries and users
-# Arguments: u/v/r/p/g/i/c/d, object, currently selected item (empty=main)
-sub htmlMainTabs {
- my($self, $type, $obj, $sel) = @_;
- $obj->{entry_hidden} = $obj->{hidden};
- $obj->{entry_locked} = $obj->{locked};
- VNWeb::HTML::_maintabs_({ type => $type, dbobj => $obj, tab => $sel||''});
-}
-
-
-# generates a full error page, including header and footer
-sub htmlDenied { shift->resDenied }
-
-
-# Generates message saying that the current item has been deleted,
-# Arguments: [pvrc], obj
-# Returns 1 if the use doesn't have access to the page, 0 otherwise
-sub htmlHiddenMessage {
- my($self, $type, $obj) = @_;
- return 0 if !$obj->{hidden};
- my $board = $type =~ /[csd]/ ? 'db' : $type eq 'r' ? 'v'.$obj->{vn}[0]{vid} : $type.$obj->{id};
- # fetch edit summary (not present in $obj, requires the db*GetRev() methods)
- my $editsum = $type eq 'v' ? $self->dbVNGetRev(id => $obj->{id})->[0]{comments}
- : $type eq 'r' ? $self->dbReleaseGetRev(id => $obj->{id})->[0]{comments}
- : $type eq 'c' ? $self->dbCharGetRev(id => $obj->{id})->[0]{comments}
- : $self->dbProducerGetRev(id => $obj->{id})->[0]{comments};
- div class => 'mainbox';
- h1 $obj->{title}||$obj->{name};
- div class => 'warning';
- h2 'Item deleted';
- p;
- lit 'This item has been deleted from the database. File a request on the <a href="/t/'.$board.'">discussion board</a> to undelete this page.';
- br; br;
- lit bb2html $editsum;
- end;
- end;
- end 'div';
- return $self->htmlFooter() || 1 if !$self->authCan('dbmod');
- return 0;
-}
-
-
-# Shows a revision, including diff if there is a previous revision.
-# Arguments: v|p|r|c|d, old revision, new revision, @fields
-# Where @fields is a list of fields as arrayrefs with:
-# [ shortname, displayname, %options ],
-# Where %options:
-# diff => 1/0/regex, whether to show a diff on this field, and what to split it with (1 = character-level diff)
-# short_diff=> 1/0, when set, cut off long context in diffs
-# serialize => coderef, should convert the field into a readable string, no HTML allowed
-# htmlize => same as serialize, but HTML is allowed and this can't be diff'ed
-# split => coderef, should return an array of HTML strings that can be diff'ed. (implies diff => 1)
-# join => used in combination with split, specifies the string used for joining the HTML strings
-sub htmlRevision {
- my($self, $type, $old, $new, @fields) = @_;
- div class => 'mainbox revision';
- h1 "Revision $new->{rev}";
-
- # previous/next revision links
- a class => 'prev', href => sprintf('/%s%d.%d', $type, $new->{id}, $new->{rev}-1), '<- earlier revision' if $new->{rev} > 1;
- a class => 'next', href => sprintf('/%s%d.%d', $type, $new->{id}, $new->{rev}+1), 'later revision ->' if !$new->{lastrev};
- p class => 'center';
- a href => "/$type$new->{id}", "$type$new->{id}";
- end;
-
- # no previous revision, just show info about the revision itself
- if(!$old) {
- div class => 'rev';
- revheader($self, $type, $new);
- br;
- b 'Edit summary';
- br; br;
- lit bb2html($new->{comments})||'-';
- end;
- }
-
- # otherwise, compare the two revisions
- else {
- table class => 'stripe';
- thead;
- Tr;
- td; lit '&#xa0;'; end;
- td; revheader($self, $type, $old); end;
- td; revheader($self, $type, $new); end;
- end;
- Tr;
- td; lit '&#xa0;'; end;
- td colspan => 2;
- b "Edit summary of revision $new->{rev}:";
- br; br;
- lit bb2html($new->{comments})||'-';
- end;
- end;
- end;
- revdiff($type, $old, $new, @$_) for (
- [ ihid => 'Deleted', serialize => sub { $_[0] ? 'Yes' : 'No' } ],
- [ ilock => 'Locked', serialize => sub { $_[0] ? 'Yes' : 'No' } ],
- @fields
- );
- end 'table';
- }
- end 'div';
-}
-
-sub revheader { # type, obj
- my($self, $type, $obj) = @_;
- b "Revision $obj->{rev}";
- txt ' (';
- a href => "/$type$obj->{id}.$obj->{rev}/edit", 'revert to';
- if($obj->{user_id} && $self->authCan('board')) {
- lit ' / ';
- a href => "/t/u$obj->{user_id}/new?title=Regarding%20$type$obj->{id}.$obj->{rev}", 'msg user';
- }
- txt ')';
- br;
- txt 'By ';
- VNWeb::HTML::user_($obj);
- txt ' on ';
- txt fmtdate $obj->{added}, 'full';
-}
-
-sub revdiff {
- my($type, $old, $new, $short, $display, %o) = @_;
-
- $o{serialize} ||= $o{htmlize};
- $o{diff} = 1 if $o{split};
- $o{join} ||= '';
-
- my $ser1 = $o{serialize} ? $o{serialize}->($old->{$short}, $old) : $old->{$short};
- my $ser2 = $o{serialize} ? $o{serialize}->($new->{$short}, $new) : $new->{$short};
- return if $ser1 eq $ser2;
-
- if($o{diff} && $ser1 && $ser2) {
- my $sep = ref $o{diff} ? qr/($o{diff})/ : qr//;
- my @ser1 = map encode_utf8($_), $o{split} ? $o{split}->($ser1) : map html_escape($_), split $sep, $ser1;
- my @ser2 = map encode_utf8($_), $o{split} ? $o{split}->($ser2) : map html_escape($_), split $sep, $ser2;
- return if $o{split} && $#ser1 == $#ser2 && !grep $ser1[$_] ne $ser2[$_], 0..$#ser1;
-
- $ser1 = $ser2 = '';
- my @d = compact_diff(\@ser1, \@ser2);
- my $lastchunk = int (($#d-2)/2);
- for my $i (0..$lastchunk) {
- # $i % 2 == 0 -> equal, otherwise it's different
- my $a = join($o{join}, @ser1[ $d[$i*2] .. $d[$i*2+2]-1 ]);
- my $b = join($o{join}, @ser2[ $d[$i*2+1] .. $d[$i*2+3]-1 ]);
- # Reduce context if we have too much
- if($o{short_diff} && $i % 2 == 0 && length($a) > 300) {
- my $sep = '<b class="standout">&lt;...&gt;</b>';
- my $ctx = 100;
- $a = $i == 0 ? $sep.'<br>'.substr $a, -$ctx :
- $i == $lastchunk ? substr($a, 0, $ctx).'<br>'.$sep :
- substr($a, 0, $ctx)."<br><br>$sep<br><br>".substr($a, -$ctx);
- $b = $a;
- }
- $ser1 .= ($ser1?$o{join}:'').($i % 2 ? qq|<b class="diff_del">$a</b>| : $a) if $a ne '';
- $ser2 .= ($ser2?$o{join}:'').($i % 2 ? qq|<b class="diff_add">$b</b>| : $b) if $b ne '';
- }
- $ser1 = decode_utf8($ser1);
- $ser2 = decode_utf8($ser2);
- } elsif(!$o{htmlize}) {
- $ser1 = html_escape $ser1;
- $ser2 = html_escape $ser2;
- }
-
- $ser1 = '[empty]' if !$ser1 && $ser1 ne '0';
- $ser2 = '[empty]' if !$ser2 && $ser2 ne '0';
-
- Tr;
- td $display;
- td class => 'tcval'; lit $ser1; end;
- td class => 'tcval'; lit $ser2; end;
- end;
-}
-
-
-# Generates a generic message to show as the header of the edit forms
-# Arguments: v/r/p, obj, title, copy
-sub htmlEditMessage {
- shift; VNWeb::HTML::editmsg_(@_);
-}
-
-
-# Generates a small message when the user can't edit the item,
-# or the item is locked.
-# Arguments: v/r/p/c, obj
-sub htmlItemMessage {
- my($self, $type, $obj) = @_;
- # $type isn't being used at all... oh well.
-
- if($obj->{locked}) {
- p class => 'locked', 'Locked for editing';
- } elsif($self->authInfo->{id} && !$self->authCan('edit')) {
- p class => 'locked', 'You are not allowed to edit this page';
- }
-}
-
-
-# generates two tables, one with a vote graph, other with recent votes
-# Only supports $type eq 'v' now.
-sub htmlVoteStats {
- my($self, $type, $obj, $stats) = @_;
-
- my($max, $count, $total) = (0, 0, 0);
- for (0..$#$stats) {
- $max = $stats->[$_][0] if $stats->[$_][0] > $max;
- $count += $stats->[$_][0];
- $total += $stats->[$_][1];
- }
- div class => 'votestats';
- table class => 'votegraph';
- thead; Tr;
- td colspan => 2, 'Vote stats';
- end; end;
- tfoot; Tr;
- td colspan => 2, sprintf '%d vote%s total, average %.2f%s', $count, $count == 1 ? '' : 's', $total/$count/10,
- $type eq 'v' ? ' ('.fmtrating(ceil($total/$count/10-1)||1).')' : '';
- end; end;
- for (reverse 0..$#$stats) {
- Tr;
- td class => 'number', $_+1;
- td class => 'graph';
- div style => 'width: '.($stats->[$_][0]/$max*250).'px', ' ';
- txt $stats->[$_][0];
- end;
- end;
- }
- end 'table';
-
- my $recent = $self->dbAlli('
- SELECT uv.vote,', VNWeb::DB::sql_totime('uv.vote_date '), 'as date, ', VNWeb::DB::sql_user(), '
- , NOT EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private) AS hide_list
- FROM ulist_vns uv
- JOIN users u ON u.id = uv.uid
- WHERE uv.vid =', \$obj->{id}, 'AND uv.vote IS NOT NULL
- AND NOT EXISTS(SELECT 1 FROM users u WHERE u.id = uv.uid AND u.ign_votes)
- ORDER BY uv.vote_date DESC
- LIMIT', \8
- );
-
- if(@$recent) {
- table class => 'recentvotes stripe';
- thead; Tr;
- td colspan => 3;
- txt 'Recent votes';
- b;
- txt '(';
- a href => "/$type$obj->{id}/votes", 'show all';
- txt ')';
- end;
- end;
- end; end;
- for (@$recent) {
- Tr;
- td;
- if($_->{hide_list}) {
- b class => 'grayedout', 'hidden';
- } else {
- VNWeb::HTML::user_($_);
- }
- end;
- td fmtvote $_->{vote};
- td fmtdate $_->{date};
- end;
- }
- end 'table';
- }
-
- clearfloat;
- if($type eq 'v' && $obj->{c_votecount}) {
- div;
- h3 'Ranking';
- p sprintf 'Popularity: ranked #%d with a score of %.2f', $obj->{p_ranking}, ($obj->{c_popularity}||0)*100;
- p sprintf 'Bayesian rating: ranked #%d with a rating of %.2f', $obj->{r_ranking}, $obj->{c_rating}/10;
- end;
- }
- end 'div';
-}
-
-
-sub htmlSearchBox {
- shift; VNWeb::HTML::searchbox_(@_);
-}
-
-
-sub htmlRGHeader {
- my($self, $title, $type, $obj) = @_;
-
- # This used to be a good test for inline SVG support, but I'm not sure it is nowadays.
- if(($self->reqHeader('Accept')||'') !~ /application\/xhtml\+xml/) {
- $self->htmlHeader(title => $title);
- $self->htmlMainTabs($type, $obj, 'rg');
- div class => 'mainbox';
- h1 $title;
- div class => 'warning';
- h2 'Not supported';
- p 'Your browser sucks, it doesn\'t have the functionality to render our nice relation graphs.';
- end;
- end;
- $self->htmlFooter;
- return 1;
- }
- $self->htmlHeader(title => $title);
- $self->htmlMainTabs($type, $obj, 'rg');
- return 0;
-}
-
-
-1;
diff --git a/lib/VNDB/Util/FormHTML.pm b/lib/VNDB/Util/FormHTML.pm
deleted file mode 100644
index 85b7fab9..00000000
--- a/lib/VNDB/Util/FormHTML.pm
+++ /dev/null
@@ -1,282 +0,0 @@
-
-package VNDB::Util::FormHTML;
-
-use strict;
-use warnings;
-use TUWF ':html';
-use Exporter 'import';
-use POSIX 'strftime';
-use VNDB::Func;
-
-our @EXPORT = qw| htmlFormError htmlFormPart htmlForm |;
-
-
-# Displays friendly error message when form validation failed
-# Argument is the return value of formValidate, and an optional
-# argument indicating whether we should create a special mainbox
-# for the errors.
-sub htmlFormError {
- my($self, $frm, $mainbox) = @_;
- return if !$frm->{_err};
- if($mainbox) {
- div class => 'mainbox';
- h1 'Error';
- }
- div class => 'warning';
- h2 'Form could not be sent:';
- ul;
- for my $e (@{$frm->{_err}}) {
- if(!ref $e) {
- li $e;
- next;
- }
- if(ref $e eq 'SCALAR') {
- li; lit $$e; end;
- next;
- }
- my($field, $type, $rule) = @$e;
- ($type, $rule) = ('template', 'editsum') if $type eq 'required' && $field eq 'editsum';
-
- li "$field is a required field" if $type eq 'required';;
- li "$field: minimum number of values is $rule" if $type eq 'mincount';
- li "$field: maximum number of values is $rule" if $type eq 'maxcount';
- li "$field: should have at least $rule characters" if $type eq 'minlength';
- li "$field: only $rule characters allowed" if $type eq 'maxlength';
- li "$field must be one of the following: ".join(', ', @$rule) if $type eq 'enum';
- li $rule->[1] if $type eq 'func' || $type eq 'regex';
- if($type eq 'template') {
- li "$field: Invalid number" if $rule eq 'int' || $rule eq 'num' || $rule eq 'uint' || $rule eq 'page' || $rule eq 'id';
- li "$field: Invalid URL" if $rule eq 'weburl';
- li "$field: only ASCII characters allowed" if $rule eq 'ascii';
- li "Invalid email address" if $rule eq 'email';
- li "$field may only contain lowercase alphanumeric characters and a hyphen" if $rule eq 'uname';
- li 'Invalid JAN/UPC/EAN' if $rule eq 'gtin';
- li "$field: Malformed data or invalid input" if $rule eq 'json';
- li 'Invalid release date' if $rule eq 'rdate';
- li 'Invalid Wikidata ID' if $rule eq 'wikidata';
- if($rule eq 'editsum') {
- li; lit 'Please read <a href="/d5#4">the guidelines</a> on how to use the edit summary.'; end;
- }
- }
- }
- end;
- end 'div';
- end if $mainbox;
-}
-
-
-# Generates a form part.
-# A form part is a arrayref, with the first element being the type of the part,
-# and all other elements forming a hash with options specific to that type.
-# Type Options
-# hidden short, (value)
-# json short, (value) # Same as hidden, but value is passed through json_encode()
-# input short, name, (value, allow0, width, pre, post)
-# passwd short, name
-# static content, (label, nolabel)
-# check name, short, (value)
-# select name, short, options, (width, multi, size)
-# radio name, short, options
-# text name, short, (rows, cols)
-# date name, short
-# part title
-sub htmlFormPart {
- my($self, $frm, $fp) = @_;
- my($type, %o) = @$fp;
- local $_ = $type;
-
- if(/hidden/ || /json/) {
- Tr class => 'hidden';
- td colspan => 2;
- my $val = $o{value}||$frm->{$o{short}};
- input type => 'hidden', id => $o{short}, name => $o{short}, value => /json/ ? json_encode($val||[]) : $val||'';
- end;
- end;
- return
- }
-
- if(/part/) {
- Tr class => 'newpart';
- td colspan => 2, $o{title};
- end;
- return;
- }
-
- if(/check/) {
- Tr class => 'newfield';
- td class => 'label';
- lit '&#xa0;';
- end;
- td class => 'field';
- input type => 'checkbox', name => $o{short}, id => $o{short}, tabindex => 10,
- value => $o{value}||1, ($frm->{$o{short}}||0) eq ($o{value}||1) ? ( checked => 'checked' ) : ();
- label for => $o{short};
- lit $o{name};
- end;
- end;
- end;
- return;
- }
-
- Tr $o{name}||$o{label} ? (class => 'newfield') : ();
- if(!$o{nolabel}) {
- td class => 'label';
- if($o{short} && $o{name}) {
- label for => $o{short};
- lit $o{name};
- end;
- } elsif($o{label}) {
- txt $o{label};
- } else {
- lit '&#xa0;';
- }
- end;
- }
- td class => 'field', $o{nolabel} ? (colspan => 2) : ();
- if(/input/) {
- lit $o{pre} if $o{pre};
- input type => 'text', class => 'text', name => $o{short}, id => $o{short}, tabindex => 10,
- value => $o{value} // ($o{allow0} ? $frm->{$o{short}}//'' : $frm->{$o{short}}||''), $o{width} ? (style => "width: $o{width}px") : ();
- lit $o{post} if $o{post};
- }
- if(/passwd/) {
- input type => 'password', class => 'text', name => $o{short}, id => $o{short}, tabindex => 10,
- value => $frm->{$o{short}}||'';
- }
- if(/static/) {
- lit ref $o{content} eq 'CODE' ? $o{content}->($self, \%o) : $o{content};
- }
- if(/select/) {
- my $l='';
- Select name => $o{short}, id => $o{short}, tabindex => 10,
- $o{width} ? (style => "width: $o{width}px") : (), $o{multi} ? (multiple => 'multiple', size => $o{size}||5) : ();
- for my $p (@{$o{options}}) {
- if($p->[2] && $l ne $p->[2]) {
- end if $l;
- $l = $p->[2];
- optgroup label => $l;
- }
- my $sel = defined $frm->{$o{short}} && ($frm->{$o{short}} eq $p->[0] || ref($frm->{$o{short}}) eq 'ARRAY' && grep $_ eq $p->[0], @{$frm->{$o{short}}});
- option value => $p->[0], $sel ? (selected => 'selected') : (), $p->[1];
- }
- end if $l;
- end;
- }
- if(/radio/) {
- for my $p (@{$o{options}}) {
- input type => 'radio', id => "$o{short}_$p->[0]", name => $o{short}, value => $p->[0], tabindex => 10,
- defined $frm->{$o{short}} && $frm->{$o{short}} eq $p->[0] ? (checked => 'checked') : ();
- label for => "$o{short}_$p->[0]", $p->[1];
- }
- }
- if(/date/) {
- input type => 'hidden', id => $o{short}, name => $o{short}, value => $frm->{$o{short}}||'', class => 'dateinput';
- }
- if(/text/) {
- textarea name => $o{short}, id => $o{short}, rows => $o{rows}||5, cols => $o{cols}||60, tabindex => 10, $frm->{$o{short}}||'';
- }
- end;
- end 'tr';
-}
-
-
-# Generates a form, first argument is a hashref with global options, keys:
-# frm => the $frm as returned by formValidate,
-# action => The location the form should POST to (also used as form id)
-# method => post/get
-# upload => 1/0, adds an enctype.
-# nosubmit => 1/0, hides the submit button
-# editsum => 1/0, adds an edit summary field before the submit button
-# continue => 2/1/0, replace submit button with continue buttons
-# preview => 1/0, add preview button
-# noformcode=> 1/0, remove the formcode field
-# The other arguments are a list of subforms in the form
-# of (subform-name => [form parts]). Each subform is shown as a
-# (JavaScript-powered) tab, and has it's own 'mainbox'. This function
-# automatically calls htmlFormError and adds a 'formcode' field.
-sub htmlForm {
- my($self, $options, @subs) = @_;
- form action => '/nospam?'.$options->{action}, method => $options->{method}||'post', 'accept-charset' => 'utf-8',
- $options->{upload} ? (enctype => 'multipart/form-data') : ();
-
- if(!$options->{noformcode}) {
- div class => 'hidden';
- input type => 'hidden', name => 'formcode', value => $self->authGetCode($options->{action});
- end;
- }
-
- $self->htmlFormError($options->{frm}, 1);
-
- # tabs
- if(@subs > 2) {
- div class => 'maintabs left';
- ul id => 'jt_select';
- for (0..$#subs/2) {
- li class => 'left';
- a href => "#$subs[$_*2]", id => "jt_sel_$subs[$_*2]", $subs[$_*2+1][0];
- end;
- }
- li class => 'left';
- a href => '#all', id => 'jt_sel_all', 'All items';
- end;
- end 'ul';
- end 'div';
- }
-
- # form subs
- while(my($short, $parts) = (shift(@subs), shift(@subs))) {
- last if !$short || !$parts;
- my $name = shift @$parts;
- div class => 'mainbox', id => 'jt_box_'.$short;
- h1 $name;
- fieldset;
- legend $name;
- table class => 'formtable';
- $self->htmlFormPart($options->{frm}, $_) for @$parts;
- end;
- end;
- end 'div';
- }
-
- # db mod / edit summary / submit button
- if(!$options->{nosubmit}) {
- div class => 'mainbox';
- fieldset class => 'submit';
- if($options->{editsum}) {
- # hidden / locked checkbox
- if($self->authCan('dbmod')) {
- input type => 'checkbox', name => 'ihid', id => 'ihid', value => 1,
- tabindex => 10, $options->{frm}{ihid} ? (checked => 'checked') : ();
- label for => 'ihid', 'Deleted';
- input type => 'checkbox', name => 'ilock', id => 'ilock', value => 1,
- tabindex => 10, $options->{frm}{ilock} ? (checked => 'checked') : ();
- label for => 'ilock', 'Locked';
- br; txt 'Note: edit summary of the last edit should indicate the reason for the deletion.'; br;
- }
-
- # edit summary
- h2;
- txt 'Edit summary';
- b class => 'standout', ' (English please!)';
- end;
- textarea name => 'editsum', id => 'editsum', rows => 4, cols => 50, tabindex => 10, $options->{frm}{editsum}||'';
- br;
- }
- if(!$options->{continue}) {
- input type => 'submit', value => 'Submit', class => 'submit', tabindex => 10;
- } else {
- input type => 'submit', value => 'Continue', class => 'submit', tabindex => 10;
- input type => 'submit', name => 'continue_ign', value => 'Continue and ignore duplicates',
- class => 'submit', style => 'width: auto', tabindex => 10 if $options->{continue} == 2;
- }
- input type => 'submit', value => 'Preview', id => 'preview', name => 'preview', class => 'submit', tabindex => 10 if $options->{preview};
- end;
- end 'div';
- }
-
- end 'form';
-}
-
-
-1;
-
diff --git a/lib/VNDB/Util/LayoutHTML.pm b/lib/VNDB/Util/LayoutHTML.pm
deleted file mode 100644
index 6bafbeda..00000000
--- a/lib/VNDB/Util/LayoutHTML.pm
+++ /dev/null
@@ -1,43 +0,0 @@
-
-package VNDB::Util::LayoutHTML;
-
-use strict;
-use warnings;
-use TUWF ':html';
-use VNWeb::HTML;
-use Exporter 'import';
-
-our @EXPORT = qw|htmlHeader htmlFooter|;
-
-sub htmlHeader { # %options->{ title, noindex, search, feeds, metadata }
- my($self, %o) = @_;
- %VNWeb::HTML::pagevars = ();
-
- $o{og} = $o{metadata} ? +{ map +(s/og://r, $o{metadata}{$_}), keys $o{metadata}->%* } : undef;
- $o{index} = !$o{noindex};
-
- html lang => 'en';
- head sub { VNWeb::HTML::_head_(\%o) };
- body;
- div id => 'bgright', ' ';
- div id => 'header', sub { h1 sub { a href => '/', 'the visual novel database' } };
- div id => 'menulist', sub { VNWeb::HTML::_menu_(\%o) };
- div id => 'maincontent';
-}
-
-
-sub htmlFooter { # %options => { pref_code => 1 }
- my($self, %o) = @_;
- div id => 'footer', sub { VNWeb::HTML::_footer_ };
- end 'div'; # maincontent
-
- # Abuse an empty noscript tag for the formcode to update a preference setting, if the page requires one.
- noscript id => 'pref_code', title => $self->authGetCode('/xml/prefs.xml'), ''
- if $o{pref_code} && $self->authInfo->{id};
- script type => 'text/javascript', src => $self->{url_static}.'/f/vndb.js?'.$self->{version}, '';
- VNWeb::HTML::v2rwjs_() if $o{v2rwjs};
- end 'body';
- end 'html';
-}
-
-1;
diff --git a/lib/VNDB/Util/Misc.pm b/lib/VNDB/Util/Misc.pm
deleted file mode 100644
index b314bf08..00000000
--- a/lib/VNDB/Util/Misc.pm
+++ /dev/null
@@ -1,122 +0,0 @@
-
-package VNDB::Util::Misc;
-
-use strict;
-use warnings;
-use Exporter 'import';
-use TUWF ':html';
-use VNDB::Func;
-use VNDB::Types;
-use VNDB::BBCode;
-
-our @EXPORT = qw|filFetchDB filCompat bbSubstLinks|;
-
-
-our %filfields = (
- vn => [qw|date_before date_after released length hasani hasshot tag_inc tag_exc taginc tagexc tagspoil lang olang plat staff_inc staff_exc ul_notblack ul_onwish ul_voted ul_onlist|],
- release => [qw|type patch freeware doujin uncensored date_before date_after released minage lang olang resolution plat prod_inc prod_exc med voiced ani_story ani_ero engine|],
- char => [qw|gender bloodt bust_min bust_max waist_min waist_max hip_min hip_max height_min height_max va_inc va_exc weight_min weight_max cup_min cup_max trait_inc trait_exc tagspoil role|],
- staff => [qw|gender role truename lang|],
-);
-
-
-# Arguments:
-# type ('vn', 'release' or 'char'),
-# filter overwrite (string or undef),
-# when defined, these filters will be used instead of the preferences,
-# must point to a variable, will be modified in-place with the actually used filters
-# options to pass to db*Get() before the filters (hashref or undef)
-# these options can be overwritten by the filters or the next option
-# options to pass to db*Get() after the filters (hashref or undef)
-# these options overwrite all other options (pre-options and filters)
-
-sub filFetchDB {
- my($self, $type, $overwrite, $pre, $post) = @_;
- $pre = {} if !$pre;
- $post = {} if !$post;
- my $dbfunc = $self->can($type eq 'vn' ? 'dbVNGet' : $type eq 'release' ? 'dbReleaseGet' : $type eq 'char' ? 'dbCharGet' : 'dbStaffGet');
- my $prefname = 'filter_'.$type;
- my $pref = $self->authPref($prefname);
-
- my $filters = fil_parse $overwrite // $pref, @{$filfields{$type}};
-
- # compatibility
- my $compat = $self->filCompat($type, $filters);
- $self->authPref($prefname => fil_serialize $filters) if $compat && !defined $overwrite;
-
- # write the definite filter string in $overwrite
- $_[2] = fil_serialize({map +(
- exists($post->{$_}) ? ($_ => $post->{$_}) :
- exists($filters->{$_}) ? ($_ => $filters->{$_}) :
- exists($pre->{$_}) ? ($_ => $pre->{$_}) : (),
- ), @{$filfields{$type}}}) if defined $overwrite;
-
- return $dbfunc->($self, %$pre, %$filters, %$post) if defined $overwrite or !keys %$filters;;
-
- # since incorrect filters can throw a database error, we have to special-case
- # filters that originate from a preference setting, so that in case these are
- # the cause of an error, they are removed. Not doing this will result in VNDB
- # throwing 500's even for non-browse pages. We have to do some low-level
- # PostgreSQL stuff with savepoints to ensure that an error won't affect our
- # existing transaction.
- my $dbh = $self->dbh;
- $dbh->pg_savepoint('filter');
- my($r, $np);
- my $OK = eval {
- ($r, $np) = $dbfunc->($self, %$pre, %$filters, %$post);
- 1;
- };
- $dbh->pg_rollback_to('filter') if !$OK;
- $dbh->pg_release('filter');
-
- # error occured, let's try again without filters. if that succeeds we know
- # it's the fault of the filter preference, and we should remove it.
- if(!$OK) {
- ($r, $np) = $dbfunc->($self, %$pre, %$post);
- # if we're here, it means the previous function didn't die() (duh!)
- $self->authPref($prefname => '');
- warn sprintf "Reset filter preference for userid %d. Old: %s\n", $self->authInfo->{id}||0, $pref;
- }
- return wantarray ? ($r, $np) : $r;
-}
-
-
-# Compatibility with old filters. Modifies the filter in-place and returns the number of changes made.
-sub filCompat {
- my($self, $type, $fil) = @_;
- my $mod = 0;
-
- # older tag specification (by name rather than ID)
- if($type eq 'vn' && ($fil->{taginc} || $fil->{tagexc})) {
- my $tagfind = sub {
- return map {
- my $i = $self->dbTagGet(name => $_)->[0];
- $i && $i->{searchable} ? $i->{id} : ();
- } grep $_, ref $_[0] ? @{$_[0]} : ($_[0]||'')
- };
- $fil->{tag_inc} //= [ $tagfind->(delete $fil->{taginc}) ] if $fil->{taginc};
- $fil->{tag_exc} //= [ $tagfind->(delete $fil->{tagexc}) ] if $fil->{tagexc};
- $mod++;
- }
-
- if($type eq 'release' && $fil->{resolution}) {
- $fil->{resolution} = [ map {
- if(/^[0-9]+$/) {
- $mod++;
- (keys %RESOLUTION)[$_] || 'unknown'
- } else { $_ }
- } ref $fil->{resolution} ? @{$fil->{resolution}} : $fil->{resolution} ];
- }
-
- $mod;
-}
-
-
-
-sub bbSubstLinks {
- shift; bb_subst_links @_;
-}
-
-
-1;
-
diff --git a/lib/VNDB/Util/ValidateTemplates.pm b/lib/VNDB/Util/ValidateTemplates.pm
deleted file mode 100644
index 7966b319..00000000
--- a/lib/VNDB/Util/ValidateTemplates.pm
+++ /dev/null
@@ -1,110 +0,0 @@
-# This module implements various templates for formValidate()
-
-package VNDB::Util::ValidateTemplates;
-
-use strict;
-use warnings;
-use TUWF 'kv_validate';
-use VNDB::Func 'json_decode';
-use VNDBUtil 'gtintype';
-use Time::Local 'timegm';
-
-
-TUWF::set(
- validate_templates => {
- id => { template => 'uint', max => 1<<40 },
- page => { template => 'uint', max => 1000 },
- uname => { regex => qr/^[a-z0-9-]*$/, func => sub { $_[0] !~ /^-*[a-z][0-9]+-*$/ }, minlength => 2, maxlength => 15 },
- gtin => { func => \&gtintype },
- editsum => { maxlength => 5000, minlength => 2 },
- json => { func => \&json_validate, inherit => ['json_fields','json_maxitems','json_unique','json_sort'], default => [] },
- rdate => { template => 'uint', min => 0, max => 99999999, func => \&rdate_validate, default => 0 },
- wikidata => { func => \&wikidata_id, default => undef },
- }
-);
-
-
-sub wikidata_id {
- $_[0] =~ s/^Q//;
- $_[0] =~ /^([0-9]{1,9})$/
-}
-
-
-# Figure out if a field is treated as a number in kv_validate().
-sub json_validate_is_num {
- my $opts = shift;
- return 0 if !$opts->{template};
- return 1 if $opts->{template} eq 'num' || $opts->{template} eq 'int' || $opts->{template} eq 'uint';
- my $t = TUWF::set('validate_templates')->{$opts->{template}};
- return $t && json_validate_is_num($t);
-}
-
-
-sub json_validate_sort {
- my($sort, $fields, $data) = @_;
-
- # Figure out which fields need to use number comparison
- my %nums;
- for my $k (@$sort) {
- my $f = (grep $_->{field} eq $k, @$fields)[0];
- $nums{$k}++ if json_validate_is_num($f);
- }
-
- # Sort
- return [sort {
- for(@$sort) {
- my $r = $nums{$_} ? $a->{$_} <=> $b->{$_} : $a->{$_} cmp $b->{$_};
- return $r if $r;
- }
- 0
- } @$data];
-}
-
-# Special validation function for simple JSON structures as form fields. It can
-# only validate arrays of key-value objects. The key-value objects are then
-# validated using kv_validate.
-# TODO: json_unique implies json_sort on the same fields? These options tend to be the same.
-sub json_validate {
- my($val, $opts) = @_;
- my $fields = $opts->{json_fields};
- my $maxitems = $opts->{json_maxitems};
- my $unique = $opts->{json_unique};
- my $sort = $opts->{json_sort};
- $unique = [$unique] if $unique && !ref $unique;
- $sort = [$sort] if $sort && !ref $sort;
-
- my $data = eval { json_decode $val };
- $_[0] = $@ ? [] : $data;
- return 0 if $@ || ref $data ne 'ARRAY';
- return 0 if defined($maxitems) && @$data > $maxitems;
-
- my %known_fields = map +($_->{field},1), @$fields;
- my %unique;
-
- for my $i (0..$#$data) {
- return 0 if ref $data->[$i] ne 'HASH';
- # Require that all keys are known and have a scalar value.
- return 0 if grep !$known_fields{$_} || ref($data->[$i]{$_}), keys %{$data->[$i]};
- $data->[$i] = kv_validate({ field => sub { $data->[$i]{shift()} } }, $TUWF::OBJ->{_TUWF}{validate_templates}, $fields);
- return 0 if $data->[$i]{_err};
- return 0 if $unique && $unique{ join '|||', map $data->[$i]{$_}, @$unique }++;
- }
-
- $_[0] = json_validate_sort($sort, $fields, $data) if $sort;
- return 1;
-}
-
-
-sub rdate_validate {
- return 0 if $_[0] ne 0 && $_[0] !~ /^(\d{4})(\d{2})(\d{2})$/;
- my($y, $m, $d) = defined $1 ? ($1, $2, $3) : (0,0,0);
-
- # Normalization ought to be done in JS, but do it here again because we can't trust browsers
- ($m, $d) = (0, 0) if $y == 0;
- $m = 99 if $y == 9999;
- $d = 99 if $m == 99;
- $_[0] = $y*10000 + $m*100 + $d;
-
- return 0 if $y && $d != 99 && !eval { timegm(0, 0, 0, $d, $m-1, $y) };
- return 1;
-}
diff --git a/lib/VNDBUtil.pm b/lib/VNDBUtil.pm
deleted file mode 100644
index 5d7850bc..00000000
--- a/lib/VNDBUtil.pm
+++ /dev/null
@@ -1,145 +0,0 @@
-# Misc. utility functions, do not rely on YAWF or POE and can be used from any script
-
-package VNDBUtil;
-
-use strict;
-use warnings;
-use Exporter 'import';
-use Encode 'encode_utf8';
-use Unicode::Normalize 'NFKD', 'compose';
-use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6';
-
-our @EXPORT = qw|shorten gtintype normalize_titles normalize_query imgsize norm_ip|;
-
-
-sub shorten {
- my($str, $len) = @_;
- return length($str) > $len ? substr($str, 0, $len-3).'...' : $str;
-}
-
-
-# GTIN code as argument,
-# Returns 'JAN', 'EAN', 'UPC' or undef,
-# Also 'normalizes' the first argument in place
-sub gtintype {
- $_[0] =~ s/[^\d]+//g;
- return undef if $_[0] !~ /^[0-9]{10,13}$/; # I've yet to see a UPC code shorter than 10 digits assigned to a game
- $_[0] = ('0'x(12-length $_[0])) . $_[0] if length($_[0]) < 12; # pad with zeros to GTIN-12
- my $c = shift;
- return undef if $c !~ /^[0-9]{12,13}$/;
- $c = "0$c" if length($c) == 12; # pad with another zero for GTIN-13
-
- # calculate check digit according to
- # http://www.gs1.org/productssolutions/barcodes/support/check_digit_calculator.html#how
- my @n = reverse split //, $c;
- my $n = shift @n;
- $n += $n[$_] * ($_ % 2 != 0 ? 1 : 3) for (0..$#n);
- return undef if $n % 10 != 0;
-
- # Do some rough guesses based on:
- # http://www.gs1.org/productssolutions/barcodes/support/prefix_list.html
- # and http://en.wikipedia.org/wiki/List_of_GS1_country_codes
- local $_ = $c;
- return 'JAN' if /^4[59]/; # prefix code 450-459 & 490-499
- return 'UPC' if /^(?:0[01]|0[6-9]|13|75[45])/; # prefix code 000-019 & 060-139 & 754-755
- return undef if /^(?:0[2-5]|2|97[789]|9[6-9])/; # some codes we don't want: 020–059 & 200-299 & 977-999
- return 'EAN'; # let's just call everything else EAN :)
-}
-
-
-# a rather aggressive normalization
-sub normalize {
- local $_ = lc shift;
- use utf8;
- # Remove combining markings, except for kana.
- # This effectively removes all accents from the characters (e.g. é -> e)
- $_ = compose(NFKD($_) =~ s/(?<=[^ア-ンあ-ん])\pM//rg);
- # remove some characters that have no significance when searching
- tr/\r\n\t,_\-.~~〜∼ー῀:[]()%+!?#$"'`♥★☆♪†「」『』【】・‟“”‛’‘‚„«‹»›//d;
- tr/@/a/;
- tr/ı/i/; # Turkish lowercase i
- s/&/and/;
- # Consider wo and o the same thing (when used as separate word)
- s/(?:^| )o(?:$| )/wo/g;
- # Remove spaces. We're doing substring search, so let it cross word boundary to find more stuff
- tr/ //d;
- # remove commonly used release titles ("x Edition" and "x Version")
- # this saves some space and speeds up the search
- s/(?:
- first|firstpress|firstpresslimited|limited|regular|standard
- |package|boxed|download|complete|popular
- |lowprice|best|cheap|budget
- |special|trial|allages|fullvoice
- |cd|cdr|cdrom|dvdrom|dvd|dvdpack|dvdpg|windows
- |初回限定|初回|限定|通常|廉価|パッケージ|ダウンロード
- )(?:edition|version|版|生産)//xg;
- # other common things
- s/fandisk/fandisc/g;
- s/sempai/senpai/g;
- no utf8;
- return $_;
-}
-
-
-# normalizes each title and returns a concatenated string of unique titles
-sub normalize_titles {
- my %t = map +(normalize($_), 1), @_;
- return join ' ', grep $_, keys %t;
-}
-
-
-sub normalize_query {
- my $q = shift;
- # Consider wo and o the same thing (when used as separate word). Has to be
- # done here (in addition to normalize()) to make it work in combination with
- # double quote search.
- $q =~ s/(^| )o($| )/$1wo$2/ig;
- # remove spaces within quotes, so that it's considered as one search word
- $q =~ s/"([^"]+)"/(my $s=$1)=~y{ }{}d;$s/ge;
- # split into search words, normalize, and remove too short words
- return map length($_)>=(/^[\x01-\x7F]+$/?2:1) ? quotemeta($_) : (), map normalize($_), split / /, $q;
-}
-
-
-# arguments: <image size>, <max dimensions>
-# returns the size of the thumbnail with the same aspect ratio as the full-size
-# image, but fits within the specified maximum dimensions
-sub imgsize {
- my($ow, $oh, $sw, $sh) = @_;
- return ($ow, $oh) if $ow <= $sw && $oh <= $sh;
- if($ow/$oh > $sw/$sh) { # width is the limiting factor
- $oh *= $sw/$ow;
- $ow = $sw;
- } else {
- $ow *= $sh/$oh;
- $oh = $sh;
- }
- return (int $ow, int $oh);
-}
-
-
-# Normalized IP address to use for duplicate detection/throttling. For IPv4
-# this is the /23 subnet (is this enough?), for IPv6 the /48 subnet, with the
-# least significant bits of the address zero'd.
-sub norm_ip {
- my $ip = shift;
-
- # There's a whole bunch of IP manipulation modules on CPAN, but many seem
- # quite bloated and still don't offer the functionality to return an IP
- # with its mask applied (admittedly not a common operation). The libc
- # socket functions will do fine in parsing and formatting addresses, and
- # the actual masking is quite trivial in binary form.
- my $v4 = inet_pton AF_INET, $ip;
- if($v4) {
- $v4 =~ s/(..)(.)./$1 . chr(ord($2) & 254) . "\0"/se;
- return inet_ntop AF_INET, $v4;
- }
-
- $ip = inet_pton AF_INET6, $ip;
- return '::' if !$ip;
- $ip =~ s/^(.{6}).+$/$1 . "\0"x10/se;
- return inet_ntop AF_INET6, $ip;
-}
-
-1;
-
diff --git a/lib/VNWeb/API.pm b/lib/VNWeb/API.pm
new file mode 100644
index 00000000..8dad8277
--- /dev/null
+++ b/lib/VNWeb/API.pm
@@ -0,0 +1,1085 @@
+package VNWeb::API;
+
+use v5.26;
+use warnings;
+use TUWF;
+use Time::HiRes 'time', 'alarm';
+use List::Util 'min';
+use VNDB::Config;
+use VNDB::Func;
+use VNDB::ExtLinks;
+use VNDB::Types;
+use VNWeb::Auth;
+use VNWeb::DB;
+use VNWeb::Validation;
+use VNWeb::AdvSearch;
+use VNWeb::ULists::Lib 'ulist_filtlabels';
+
+return 1 if $main::NOAPI;
+
+
+TUWF::get qr{/api/(nyan|kana)}, sub {
+ state %data;
+ my $ver = tuwf->capture(1);
+ $data{$ver} ||= do {
+ open my $F, '<', config->{gen_path}.'/api-'.$ver.'.html' or die $!;
+ local $/=undef;
+ my $url = config->{api_endpoint}||tuwf->reqURI;
+ <$F> =~ s/%endpoint%/$url/rg;
+ };
+ tuwf->resHeader('Content-Type' => "text/html; charset=UTF-8");
+ tuwf->resBinary($data{$ver}, 'auto');
+};
+
+
+sub cors {
+ return if !tuwf->reqHeader('Origin');
+ if(tuwf->reqHeader('Cookie') || tuwf->reqHeader('Authorization')) {
+ tuwf->resHeader('Access-Control-Allow-Origin', tuwf->reqHeader('Origin'));
+ tuwf->resHeader('Access-Control-Allow-Credentials', 'true');
+ } else {
+ tuwf->resHeader('Access-Control-Allow-Origin', '*');
+ }
+}
+
+
+TUWF::options qr{/api/kana.*}, sub {
+ tuwf->resStatus(204);
+ tuwf->resHeader('Access-Control-Allow-Origin', tuwf->reqHeader('origin'));
+ tuwf->resHeader('Access-Control-Allow-Credentials', 'true');
+ tuwf->resHeader('Access-Control-Allow-Methods', 'POST, GET, OPTIONS');
+ tuwf->resHeader('Access-Control-Allow-Headers', 'Content-Type, Authorization');
+ tuwf->resHeader('Access-Control-Max-Age', 86400);
+};
+
+
+
+# Production API is currently running as a single process, so we can safely and
+# efficiently keep the throttle state as a local variable.
+# This throttle state only handles execution time limiting; request limiting
+# is done in nginx.
+my %throttle; # IP -> SQL time
+
+sub add_throttle {
+ my $now = time;
+ my $time = $now - (tuwf->req->{throttle_start}||$now);
+ my $norm = norm_ip tuwf->reqIP();
+ $throttle{$norm} = $now if !$throttle{$norm} || $throttle{$norm} < $now;
+ $throttle{$norm} += $time * config->{api_throttle}[0];
+}
+
+sub check_throttle {
+ tuwf->req->{throttle_start} = time;
+ err(429, 'Throttled on query execution time.')
+ if ($throttle{ norm_ip tuwf->reqIP }||0) >= time + (config->{api_throttle}[0] * config->{api_throttle}[1]);
+}
+
+sub logreq {
+ tuwf->log(sprintf '%4dms %s [%s] "%s" "%s"',
+ tuwf->req->{throttle_start} ? (time - tuwf->req->{throttle_start})*1000 : 0,
+ $_[0],
+ tuwf->reqIP(),
+ tuwf->reqHeader('origin')||'-',
+ tuwf->reqHeader('user-agent')||'');
+}
+
+sub err {
+ my($status, $msg) = @_;
+ add_throttle;
+ tuwf->resStatus($status);
+ tuwf->resHeader('Content-type', 'text');
+ tuwf->resHeader('WWW-Authenticate', 'Token') if $status == 401;
+ cors;
+ print { tuwf->resFd } $msg, "\n";
+ logreq "$status $msg";
+ tuwf->done;
+}
+
+sub count_request {
+ my($rows, $call) = @_;
+ close tuwf->resFd;
+ add_throttle;
+ logreq sprintf "%3dr%6db %s", $rows, length(tuwf->{_TUWF}{Res}{content}), $call;
+}
+
+
+sub api_get {
+ my($path, $schema, $sub) = @_;
+ my $s = tuwf->compile({ type => 'hash', keys => $schema });
+ TUWF::get qr{/api/kana\Q$path}, sub {
+ check_throttle;
+ my $res = $sub->();
+ tuwf->resJSON($s->analyze->coerce_for_json($res, unknown => 'pass'));
+ cors;
+ count_request(1, '-');
+ };
+}
+
+
+sub api_del {
+ my($path, $sub) = @_;
+ TUWF::del qr{/api/kana$path}, sub {
+ check_throttle;
+ my $del = $sub->();
+ tuwf->resStatus(204);
+ cors;
+ count_request($del?1:0, 'DELETE');
+ };
+}
+
+
+sub api_patch {
+ my($path, $req_schema, $sub) = @_;
+ $req_schema->{$_}{missing} = 'ignore' for keys $req_schema->%*;
+ my $s = tuwf->compile({ type => 'hash', unknown => 'reject', keys => $req_schema });
+ TUWF::patch qr{/api/kana$path}, sub {
+ check_throttle;
+ my $req = tuwf->validate(json => $s);
+ if(!$req) {
+ eval { $req->data }; warn $@;
+ my $err = $req->err;
+ if(!$err->{errors}) {
+ err 400, 'Missing request body.' if !$err->{keys};
+ err 400, "Unknown member '$err->{keys}[0]'." if $err->{keys};
+ }
+ $err = $err->{errors}[0]//{};
+ err 400, "Invalid '$err->{key}' member." if $err->{key};
+ err 400, 'Invalid request body.';
+ };
+ $req = $req->data;
+
+ # TUWF::Validate always creates a field, even if it was missing in the
+ # original body, but we want to differentiate between non-existent
+ # fields and empty ones, so we'll check with the raw body and delete
+ # the missing ones.
+ my $raw_input = tuwf->reqJSON();
+ delete $req->{$_} for grep !exists $raw_input->{$_}, keys $req->%*;
+
+ $sub->($req);
+ tuwf->resStatus(204);
+ cors;
+ count_request(1, 'PATCH');
+ };
+}
+
+
+# %opt:
+# filters => AdvSearch query type
+# sql => sub { sql 'SELECT id', $_[0], 'FROM x', $_[1], 'WHERE', $_[2] },
+# Main query to fetch items,
+# $_[0] is the list of fields to fetch (including a preceding comma)
+# $_[1] is a list of JOIN clauses
+# $_[2] the filters for in the WHERE clause
+# $_[3] points to the request parameters
+# 'ORDER BY' and 'LIMIT' clauses are appended to the returned query.
+# Query must always return a column named 'id'.
+# joins => {
+# $name => $sql,
+# # List of optional JOIN clauses that can be referenced by fields.
+# # These should always be 1-to-1 joins, i.e. no filtering or expansion may take place.
+# },
+# search => [ $type, $id, $subid ],
+# Whether sorting on "searchrank" is available, arguments are same as SearchQuery::sql_join().
+# fields => {
+# $name => { %field_definition },
+# },
+# sort => [
+# $name => $sql,
+# SQL may include '?o' and '!o' placeholders, see TableOpts.pm.
+# First sort option listed is the default.
+# ],
+#
+# %field_definition for simple fields:
+# select => 'SQL string',
+# col => 'name', # Name of the column returned by 'SQL string',
+# # if it does not match the $name of the field.
+# join => 'name', # This field requires a JOIN clause, refers to the 'joins' list above.
+# proc => sub {}, # Subroutine to do some formatting/processing of the value.
+# # $_[0] is the value as returned from the DB, should be modified in-place.
+#
+# %field_definition for nested 1-to-1 objects:
+# fields => {}, # Same as the parents' "fields" definitions.
+# # Can only be used to nest simple fields at a single level.
+# nullif => 'SQL string',
+# # The entire object itself is set to null if this SQL value is true.
+# # The SQL string must return a column named "${fieldname}_nullif}".
+#
+# %field_definition for nested 1-to-many objects:
+# enrich => sub { sql 'SELECT id', $_[0], 'FROM x', $_[1], 'WHERE id IN', $_[2] },
+# # Subroutine that returns an SQL statement
+# # $_[0] is the list of fields to fetch
+# # $_[1] is a list of JOIN clauses
+# # $_[2] is a list of identifiers to fetch
+# # $_[3] points to the request parameters
+# key => 'id', # $key argument to enrich()
+# col => 'id', # $merge_col argument to enrich()
+# select => 'SQL', # SQL to return $key, if it's not already part of the object.
+# # (The $key will then not be included in the output)
+# atmostone=> 1, # If this is a 1-to-[01] relation, removes the array in JSON output
+# # and sets the object to null if there's no result.
+# joins => {}, # Nested join definitions
+# fields => {}, # Nested field definitions
+# inherit => '/path'# Inherit joins+fields from another API.
+# proc => sub {} # Subroutine to do processing on the final value.
+# num => 1, # Estimate of the number of objects that will be returned.
+my %OBJS;
+sub api_query {
+ my($path, %opt) = @_;
+
+ $OBJS{$path} = \%opt;
+
+ my %sort = ($opt{sort}->@*, $opt{search} ? (searchrank => 'sc.score !o, sc.id, sc.subid') : ());
+ my $req_schema = tuwf->compile({ type => 'hash', unknown => 'reject', keys => {
+ filters => { advsearch => $opt{filters} },
+ fields => { default => {}, func => sub { parse_fields($opt{fields}, $_[0]) } },
+ sort => { default => $opt{sort}[0], enum => [ keys %sort ] },
+ reverse => { default => 0, jsonbool => 1 },
+ results => { default => 10, uint => 1, range => [0,100] },
+ page => { default => 1, uint => 1, range => [1,1e6] },
+ count => { default => 0, jsonbool => 1 },
+ user => { default => undef, vndbid => 'u' },
+ time => { default => 0, jsonbool => 1 },
+ compact_filters => { default => 0, jsonbool => 1 },
+ normalized_filters => { default => 0, jsonbool => 1 },
+ }});
+
+ TUWF::post qr{/api/kana\Q$path}, sub {
+ check_throttle;
+ tuwf->req->{advsearch_uid} = eval { tuwf->reqJSON->{user} };
+ my $req = tuwf->validate(json => $req_schema);
+ if(!$req) {
+ eval { $req->data }; warn $@;
+ my $err = $req->err;
+ if(!$err->{errors}) {
+ err 400, 'Missing request body.' if !$err->{keys};
+ err 400, "Unknown member '$err->{keys}[0]'." if $err->{keys};
+ }
+ $err = $err->{errors}[0]//{};
+ err 400, "Invalid '$err->{field}' filter: $err->{msg}." if $err->{key} eq 'filters' && $err->{msg} && $err->{field};
+ err 400, "Invalid '$err->{key}' member: $err->{msg}" if $err->{key} && $err->{msg};
+ err 400, "Invalid '$err->{key}' member." if $err->{key};
+ err 400, 'Invalid query.';
+ };
+ $req = $req->data;
+ $req->{user} //= auth->uid;
+
+ my $numfields = count_fields($opt{fields}, $req->{fields}, $req->{results});
+ err 400, sprintf 'Too much data selected (estimated %.0f fields)', $numfields if $numfields > 100_000;
+
+ my($filt, $searchquery) = $req->{sort} eq 'searchrank' ? $req->{filters}->extract_searchquery : ($req->{filters});
+ err 400, '"searchrank" sort is only available when the top-level filter is "search", or an "and" with at most one "search".'
+ if $req->{sort} eq 'searchrank' && !$searchquery;
+
+ my $sort = $sort{$req->{sort}};
+ my $order = $req->{reverse} ? 'DESC' : 'ASC';
+ my $opposite_order = $req->{reverse} ? 'ASC' : 'DESC';
+ $sort = $sort =~ /[?!]o/ ? ($sort =~ s/\?o/$order/rg =~ s/!o/$opposite_order/rg) : "$sort $order";
+
+ my($select, $joins) = prepare_fields($opt{fields}, $opt{joins}, $req->{fields});
+ $joins = sql $joins, $searchquery->sql_join($opt{search}->@*) if $searchquery;
+
+ my($results,$more,$count);
+ eval {
+ local $SIG{ALRM} = sub { die "Timeout\n"; };
+ alarm 3;
+ ($results, $more) = $req->{results} == 0 ? ([], 0) :
+ tuwf->dbPagei($req, $opt{sql}->($select, $joins, $filt->sql_where(), $req), 'ORDER BY', $sort);
+ $count = $req->{count} && (
+ !$more && $req->{results} && @$results <= $req->{results} ? ($req->{results}*($req->{page}-1))+@$results :
+ tuwf->dbVali('SELECT count(*) FROM (', $opt{sql}->('', '', $req->{filters}->sql_where), ') x')
+ );
+ proc_results($opt{fields}, $req->{fields}, $req, $results);
+ alarm 0;
+ 1;
+ } || do {
+ alarm 0;
+ err 500, 'Processing timeout' if $@ =~ /^Timeout/ || $@ =~ /canceling statement due to statement timeout/;
+ die $@;
+ };
+
+ tuwf->resJSON({
+ results => $results,
+ more => $more?\1:\0,
+ $req->{count} ? (count => $count) : (),
+ $req->{compact_filters} ? (compact_filters => $req->{filters}->query_encode) : (),
+ $req->{normalized_filters} ? (normalized_filters => $req->{filters}->json) : (),
+ $req->{time} ? (time => int(1000*(time() - tuwf->req->{throttle_start}))) : (),
+ });
+ cors;
+ count_request(scalar @$results, sprintf '[%s] {%s %s r%dp%d%s%s} %s', fmt_fields($req->{fields}),
+ $req->{sort}, lc($order), $req->{results}, $req->{page}, $req->{count}?'c':'', $req->{user}?" $req->{user}":'',
+ $req->{filters}->query_encode()||'-');
+ };
+}
+
+
+sub parse_fields {
+ my @tokens = split /\s*([,.{}])\s*/, $_[1];
+ $_[1] = {};
+ return (sub {
+ my($lvl, $f, $out) = @_;
+ my $nf = $f;
+ my $of = $out;
+ my $ln;
+ while(defined (my $t = shift @tokens)) {
+ next if !length $t;
+ if($t eq '}') {
+ return { msg => $ln ? "The '$ln' object requires specifying sub-field(s)." : "Expected (sub)field, got '}'" } if $nf;
+ return $lvl > 0 ? 1 : { msg => "Unmatched '}'" } ;
+ } elsif($t eq '{') {
+ return { msg => "Unexpected '{' after non-object field".($ln ? " '$ln'":'') } if !$nf;
+ my $r = __SUB__->($lvl+1, $nf, $of);
+ return $r if ref $r;
+ ($nf, $of, $ln) = ();
+ } elsif($t eq ',') {
+ return { msg => $ln ? "The '$ln' object requires specifying sub-field(s)." : 'Expected (sub)field, got comma' } if $nf;
+ ($nf, $of, $ln) = ($f, $out);
+ } else {
+ return { msg => $ln ? "Sub-field specified for non-object '$ln'" : 'Unexpected (sub)field after non-object field' } if !$nf;
+ if($t eq '.') {
+ $t = shift(@tokens) // return { msg => "Expected name after '.'" };
+ }
+ my $d = $nf->{$t} // return { msg => "Field '$t' not found", name => $t };
+ $ln = $t;
+ $nf = $d->{fields};
+ $of->{$t} ||= {};
+ $of = $of->{$t};
+ }
+ }
+ return { msg => "The '$ln' object requires specifying sub-field(s)." } if $nf;
+ return $lvl > 0 ? { msg => "Unmatched '{'" } : 1;
+ })->(0, $_[0], $_[1]);
+}
+
+sub fmt_fields {
+ (sub {
+ join ',', map $_ . (
+ keys $_[0]{$_}->%* == 0 ? '' :
+ keys $_[0]{$_}->%* == 1 ? '.'.__SUB__->($_[0]{$_}) : '{'.__SUB__->($_[0]{$_}).'}'
+ ), sort keys $_[0]->%*;
+ })->($_[0]);
+}
+
+
+# Calculate an estimate of how many fields will be returned in the response,
+# based on which fields are enabled.
+sub count_fields {
+ my($fields, $enabled, $num) = @_;
+ my $n = ($fields->{id} && !$enabled->{id} ? 1 : 0) + keys %$enabled;
+ $n += count_fields($fields->{$_}{fields}, $enabled->{$_}, $fields->{$_}{num})
+ for (grep $fields->{$_}{fields}, keys %$enabled);
+ $n * ($num // 1);
+}
+
+
+sub prepare_fields {
+ my($fields, $joins, $enabled) = @_;
+ my(@select, %join);
+ (sub {
+ for my $f (keys $_[1]->%*) {
+ my $d = $_[0]{$f};
+ $join{$d->{join}} = 1 if $d->{join};
+ push @select, $d->{select} if $d->{select};
+ push @select, $d->{nullif} if $d->{nullif};
+ push @select, sql_extlinks $d->{extlinks}, $d->{extlinks}.'.' if $d->{extlinks};
+ __SUB__->($d->{fields}, $_[1]{$f}) if $d->{fields} && !$d->{enrich};
+ }
+ })->($fields, $enabled);
+ return (
+ join('', map ",$_", @select),
+ join(' ', map $joins->{$_}, keys %join),
+ );
+}
+
+
+sub proc_field {
+ my($n, $d, $obj, $out) = @_;
+ $out->{$n} = delete $obj->{$d->{col}} if $d->{col};
+ $d->{proc}->($out->{$n}) if $d->{proc};
+}
+
+
+sub proc_results {
+ my($fields, $enabled, $req, $results) = @_;
+ for my $f (keys %$enabled) {
+ my $d = $fields->{$f};
+
+ # extlinks
+ if($d->{extlinks}) {
+ enrich_extlinks $d->{extlinks}, $enabled->{$f}, $results;
+ delete @{$_}{ keys $VNDB::ExtLinks::LINKS{$d->{extlinks}}->%* } for @$results;
+
+ # nested 1-to-many objects
+ } elsif($d->{enrich}) {
+ my($select, $join) = prepare_fields($d->{fields}, $d->{joins}, $enabled->{$f});
+ # DB::enrich() logic has been duplicated here to allow for
+ # efficient handling of nested proc_results() and `atmostone`.
+ my %ids = map defined($_->{$d->{key}}) ? ($_->{$d->{key}},[]) : (), @$results;
+ my $rows = keys %ids ? tuwf->dbAlli($d->{enrich}->($select, $join, [keys %ids], $req)) : [];
+ proc_results($d->{fields}, $enabled->{$f}, $req, $rows);
+ push $ids{ delete $_->{$d->{col}} }->@*, $_ for @$rows;
+ if($d->{atmostone}) {
+ if($d->{select}) { $_->{$f} = $ids{ delete $_->{$d->{key}} // '' }[0] for @$results }
+ else { $_->{$f} = $ids{ $_->{$d->{key}} // '' }[0] for @$results }
+ } else {
+ if($d->{select}) { $_->{$f} = $ids{ delete $_->{$d->{key}} // '' }||[] for @$results }
+ else { $_->{$f} = $ids{ $_->{$d->{key}} // '' }||[] for @$results }
+ }
+ $d->{proc}->($_->{$f}) for $d->{proc} ? @$results : ();
+
+ # nested 1-to-1 objects
+ } elsif($d->{fields}) {
+ for my $o (@$results) {
+ if($d->{nullif} && delete $o->{"${f}_nullif"}) {
+ $o->{$f} = undef;
+ delete $o->{ $d->{fields}{$_}{col}||$_ } for keys $enabled->{$f}->%*;
+ } else {
+ $o->{$f} = {};
+ proc_field($_, $d->{fields}{$_}, $o, $o->{$f}) for keys $enabled->{$f}->%*;
+ }
+ }
+
+ # simple fields
+ } else {
+ proc_field($f, $d, $_, $_) for @$results;
+ }
+ }
+}
+
+
+api_get '/schema', {}, sub {
+ my sub el {
+ my $l = $VNDB::ExtLinks::LINKS{$_[0]};
+ [ map +{ name => $_ =~ s/^l_//r, label => $l->{$_}{label}, url_format => $l->{$_}{fmt} },
+ grep $l->{$_}{regex}, keys %$l ]
+ }
+ state $s = {
+ enums => {
+ language => [ map +{ id => $_, label => $LANGUAGE{$_}{txt} }, keys %LANGUAGE ],
+ platform => [ map +{ id => $_, label => $PLATFORM{$_} }, keys %PLATFORM ],
+ medium => [ map +{ id => $_, label => $MEDIUM{$_}{txt}, plural => $MEDIUM{$_}{plural}||undef }, keys %MEDIUM ],
+ staff_role => [ map +{ id => $_, label => $CREDIT_TYPE{$_} }, keys %CREDIT_TYPE ],
+ },
+ api_fields => { map +($_, (sub {
+ +{ map {
+ my $f = $_[0]{$_};
+ my $s = $f->{fields} ? __SUB__->($f->{fields}, $f->{inherit} ? $OBJS{$f->{inherit}}{fields} : {}) : {};
+ $s->{_inherit} = $f->{inherit} if $f->{inherit};
+ ($_, keys %$s ? $s : undef)
+ } grep !$_[1]{$_}, keys $_[0]->%* }
+ })->($OBJS{$_}{fields}, {})), keys %OBJS },
+ extlinks => {
+ '/release' => el('r'),
+ '/staff' => el('s'),
+ },
+ }
+};
+
+
+my @STATS = qw{traits producers tags chars staff vn releases};
+api_get '/stats', { map +($_, { uint => 1 }), @STATS }, sub {
+ +{ map +($_->{section}, $_->{count}),
+ tuwf->dbAlli('SELECT * FROM stats_cache WHERE section IN', \@STATS)->@* };
+};
+
+
+api_get '/authinfo', {}, sub {
+ err 401, 'Unauthorized' if !auth;
+ +{
+ id => auth->uid,
+ username => auth->user->{user_name},
+ permissions => [
+ auth->api2Listread ? 'listread' : (),
+ auth->api2Listwrite ? 'listwrite' : (),
+ ]
+ }
+};
+
+
+api_get '/user', {}, sub {
+ my $data = tuwf->validate(get =>
+ q => { type => 'array', scalar => 1, maxlength => 100, values => {} },
+ fields => { fields => ['lengthvotes', 'lengthvotes_sum'] },
+ );
+ err 400, 'Invalid argument' if !$data;
+ my ($q, $f) = @{ $data->data }{qw{ q fields }};
+ my $regex = '^u[1-9][0-9]{0,6}$';
+ +{ map +(delete $_->{q}, $_->{id} ? $_ : undef), tuwf->dbAlli('
+ WITH u AS (
+ SELECT x.q, u.id, u.username
+ FROM unnest(', sql_array(@$q), ') x(q)
+ LEFT JOIN users u ON u.id = CASE WHEN x.q ~', \$regex, 'THEN x.q::vndbid ELSE NULL END
+ OR LOWER(u.username) = LOWER(x.q)
+ ) SELECT u.*',
+ $f->{lengthvotes} ? ', coalesce(l.count,0) AS lengthvotes' : (),
+ $f->{lengthvotes_sum} ? ', coalesce(l.sum,0) AS lengthvotes_sum' : (),
+ 'FROM u',
+ $f->{lengthvotes} || $f->{lengthvotes_sum} ? ('LEFT JOIN (
+ SELECT uid, count(*) AS count, sum(length) AS sum
+ FROM vn_length_votes
+ WHERE uid IN(SELECT id FROM u)
+ GROUP BY uid
+ ) l ON l.uid = u.id'
+ ) : (),
+ )->@* }
+};
+
+
+api_get '/ulist_labels', { labels => { aoh => {
+ id => { uint => 1 },
+ private => { anybool => 1 },
+ label => {},
+}}}, sub {
+ my $data = tuwf->validate(get =>
+ user => { vndbid => 'u', default => auth->uid||\'required' },
+ fields => { default => undef, enum => ['count'] },
+ );
+ err 400, 'Invalid argument' if !$data;
+ $data = $data->data;
+ +{ labels => ulist_filtlabels $data->{user}, $data->{fields} };
+};
+
+
+api_patch qr{/ulist/$RE{vid}}, {
+ vote => { uint => 1, range => [10,100] },
+ notes => { default => '', maxlength => 2000 },
+ started => { caldate => 1 },
+ finished => { caldate => 1 },
+ labels => { default => [], type => 'array', values => { uint => 1, range => [1,1600] } },
+ labels_set => { default => [], type => 'array', values => { uint => 1, range => [1,1600] } },
+ labels_unset => { default => [], type => 'array', values => { uint => 1, range => [1,1600] } },
+}, sub {
+ my($upd) = @_;
+ my $vid = tuwf->capture('id');
+ err 401, 'Unauthorized' if !auth->api2Listwrite;
+ err 404, 'Visual novel not found' if !tuwf->dbExeci('SELECT 1 FROM vn WHERE NOT hidden AND id =', \$vid);
+
+ my $newlabels = sql "'{}'::smallint[]";
+ if($upd->{labels} || $upd->{labels_set} || $upd->{labels_unset}) {
+ my @all = $upd->{labels} ? $upd->{labels}->@* : ();
+ my @set = $upd->{labels_set} ? $upd->{labels_set}->@* : ();
+ my @unset = $upd->{labels_unset} ? $upd->{labels_unset}->@* : ();
+ my %labels = map +($_, 1), @all, @set;
+ delete $labels{$_} for @unset;
+ err 400, 'Label id 7 cannot be used here' if $labels{7} || grep $_ == 7, @unset;
+
+ $upd->{labels} = $upd->{labels} ? sql(sql_array(sort { $a <=> $b } keys %labels),'::smallint[]') : do {
+ my $l = 'ulist_vns.labels';
+ $l = sql 'array_set(', $l, ',', \(0+$_), ')' for @set;
+ $l = sql 'array_remove(', $l, ',', \(0+$_), ')' for @unset;
+ $l
+ };
+
+ delete $upd->{labels_set};
+ delete $upd->{labels_unset};
+ $newlabels = sql(sql_array(sort { $a <=> $b } keys %labels),'::smallint[]');
+ }
+ $upd->{lastmod} = sql 'NOW()';
+ $upd->{vote_date} = sql $upd->{vote} ? 'CASE WHEN ulist_vns.vote IS NULL THEN NOW() ELSE ulist_vns.vote_date END' : 'NULL'
+ if exists $upd->{vote};
+
+ my $done = tuwf->dbExeci(
+ 'INSERT INTO ulist_vns', { %$upd,
+ labels => $newlabels,
+ vote_date => sql($upd->{vote} ? 'NOW()' : 'NULL'),
+ uid => auth->uid,
+ vid => $vid
+ },
+ 'ON CONFLICT (uid, vid) DO', keys %$upd ? ('UPDATE SET', $upd) : 'NOTHING'
+ );
+ if($done > 0) {
+ tuwf->dbExeci(SELECT => sql_func update_users_ulist_private => \auth->uid, \$vid);
+ tuwf->dbExeci(SELECT => sql_func update_users_ulist_stats => \auth->uid);
+ }
+};
+
+
+api_patch qr{/rlist/$RE{rid}}, {
+ status => { uint => 1, default => 0, enum => \%RLIST_STATUS },
+}, sub {
+ my($upd) = @_;
+ my $rid = tuwf->capture('id');
+ err 401, 'Unauthorized' if !auth->api2Listwrite;
+ err 404, 'Release not found' if !tuwf->dbExeci('SELECT 1 FROM releases WHERE NOT hidden AND id =', \$rid);
+ tuwf->dbExeci(
+ 'INSERT INTO rlists', { %$upd, uid => auth->uid, rid => $rid },
+ 'ON CONFLICT (uid, rid) DO', keys %$upd ? ('UPDATE SET', $upd) : 'NOTHING'
+ );
+};
+
+
+api_del qr{/ulist/$RE{vid}}, sub {
+ err 401, 'Unauthorized' if !auth->api2Listwrite;
+ tuwf->dbExeci('DELETE FROM ulist_vns WHERE uid =', \auth->uid, 'AND vid =', \tuwf->capture('id'));
+ tuwf->dbExeci(SELECT => sql_func update_users_ulist_stats => \auth->uid);
+};
+
+
+api_del qr{/rlist/$RE{rid}}, sub {
+ err 401, 'Unauthorized' if !auth->api2Listwrite;
+ tuwf->dbExeci('DELETE FROM rlists WHERE uid =', \auth->uid, 'AND rid =', \tuwf->capture('id'));
+};
+
+
+
+my @BOOL = (proc => sub { $_[0] = $_[0] ? \1 : \0 if defined $_[0] });
+my @INT = (proc => sub { $_[0] *= 1 if defined $_[0] }); # Generally unnecessary, DBD::Pg does this already
+my @RDATE = (proc => sub { $_[0] = $_[0] ? rdate $_[0] : undef });
+my @NSTR = (proc => sub { $_[0] = undef if !length $_[0] }); # Empty string -> null
+my @MSTR = (proc => sub { $_[0] = [ grep length($_), split /\n/, $_[0] ] }); # Multiline string -> array
+my @NINT = (proc => sub { $_[0] = $_[0] ? $_[0]*1 : undef }); # 0 -> null
+
+sub IMG {
+ my($main_col, $join_id, $join_prefix) = @_;
+ return (
+ id => { select => "$main_col AS image_id", col => 'image_id' },
+ url => { select => "$main_col AS image_url", col => 'image_url', proc => sub { $_[0] = imgurl $_[0] } },
+ dims => { join => $join_id, col => 'image_dims', select => "ARRAY[${join_prefix}width, ${join_prefix}height] AS image_dims" },
+ sexual => { join => $join_id, select => "${join_prefix}c_sexual_avg::real/100 AS image_sexual", col => 'image_sexual' },
+ violence => { join => $join_id, select => "${join_prefix}c_violence_avg::real/100 AS image_violence", col => 'image_violence' },
+ votecount => { join => $join_id, select => "${join_prefix}c_votecount AS image_votecount", col => 'image_votecount' },
+ );
+}
+
+# Extracts the alttitle from a 'vnt.titles'-like array column, returns null if equivalent to the main title.
+sub ALTTITLE { my($t,$col) = @_; +(select => "CASE WHEN $t"."[1+1] = $t"."[1+1+1+1] THEN NULL ELSE $t"."[1+1+1+1] END AS ".($col // 'alttitle')) }
+
+
+api_query '/vn',
+ filters => 'v',
+ sql => sub { sql 'SELECT v.id', $_[0], 'FROM vnt v', $_[1], 'WHERE NOT v.hidden AND (', $_[2], ')' },
+ joins => {
+ image => 'LEFT JOIN images i ON i.id = v.image',
+ },
+ search => [ 'v', 'v.id' ],
+ fields => {
+ id => {},
+ title => { select => 'v.title[1+1]' },
+ alttitle => { ALTTITLE 'v.title' },
+ titles => {
+ enrich => sub { sql 'SELECT vt.id', $_[0], 'FROM vn_titles vt', $_[1], 'WHERE vt.id IN', $_[2] },
+ key => 'id', col => 'id', num => 3,
+ joins => {
+ main => 'JOIN vn v ON v.id = vt.id',
+ },
+ fields => {
+ lang => { select => 'vt.lang' },
+ title => { select => 'vt.title' },
+ latin => { select => 'vt.latin' },
+ official => { select => 'vt.official', @BOOL },
+ main => { join => 'main', select => 'vt.lang = v.olang AS main', @BOOL },
+ },
+ },
+ aliases => { select => 'v.alias AS aliases', @MSTR },
+ olang => { select => 'v.olang' },
+ devstatus => { select => 'v.devstatus' },
+ released => { select => 'v.c_released AS released', @RDATE },
+ languages => { select => 'v.c_languages::text[] AS languages' },
+ platforms => { select => 'v.c_platforms::text[] AS platforms' },
+ image => {
+ fields => { IMG 'v.image', 'image', 'i.' },
+ nullif => 'v.image IS NULL AS image_nullif',
+ },
+ length => { select => 'v.length', proc => sub { $_[0] = undef if !$_[0] } },
+ length_minutes => { select => 'v.c_length AS length_minutes' },
+ length_votes => { select => 'v.c_lengthnum AS length_votes' },
+ description => { select => 'v.description', @NSTR },
+ rating => { select => 'v.c_rating AS rating', proc => sub { $_[0] /= 10 if defined $_[0] } },
+ popularity => { select => 'v.c_votecount AS popularity', proc => sub { $_[0] = min(100, $_[0]/150) if defined $_[0] } },
+ votecount => { select => 'v.c_votecount AS votecount' },
+ screenshots => {
+ enrich => sub { sql 'SELECT vs.id AS vid', $_[0], 'FROM vn_screenshots vs', $_[1], 'WHERE vs.id IN', $_[2] },
+ key => 'id', col => 'vid', num => 10,
+ joins => {
+ image => 'JOIN images i ON i.id = vs.scr',
+ },
+ fields => {
+ IMG('vs.scr', 'image', 'i.'),
+ thumbnail => { select => "vs.scr AS thumbnail", col => 'thumbnail', proc => sub { $_[0] = imgurl $_[0], 't' } },
+ thumbnail_dims => { join => 'image', col => 'thumbnail_dims'
+ , select => "ARRAY[i.width, i.height] AS thumbnail_dims"
+ , proc => sub { @{$_[0]} = imgsize @{$_[0]}, config->{scr_size}->@* } },
+ release => {
+ select => 'vs.rid AS screen_rid',
+ enrich => sub { sql 'SELECT r.id AS screen_rid, r.id', $_[0], 'FROM releasest r', $_[1], 'WHERE NOT r.hidden AND r.id IN', $_[2] },
+ key => 'screen_rid', col => 'screen_rid', atmostone => 1,
+ inherit => '/release',
+ }
+ },
+ },
+ relations => {
+ enrich => sub { sql 'SELECT vr.id AS vid, v.id', $_[0], 'FROM vn_relations vr JOIN vnt v ON v.id = vr.vid', $_[1], 'WHERE vr.id IN', $_[2] },
+ key => 'id', col => 'vid', num => 3,
+ inherit => '/vn',
+ fields => {
+ relation => { select => 'vr.relation' },
+ relation_official => { select => 'vr.official AS relation_official', @BOOL },
+ },
+ },
+ tags => {
+ enrich => sub { sql 'SELECT tv.vid, t.id', $_[0], 'FROM tags_vn_direct tv JOIN tags t ON t.id = tv.tag', $_[1], 'WHERE NOT t.hidden AND tv.vid IN', $_[2] },
+ key => 'id', col => 'vid', num => 50,
+ inherit => '/tag',
+ fields => {
+ rating => { select => 'tv.rating' },
+ spoiler => { select => 'tv.spoiler' },
+ lie => { select => 'tv.lie', @BOOL },
+ },
+ },
+ developers => {
+ enrich => sub { sql 'SELECT v.id AS vid, p.id', $_[0], 'FROM vn v, unnest(v.c_developers) vp(id), producerst p', $_[1], 'WHERE p.id = vp.id AND v.id IN', $_[2] },
+ key => 'id', col => 'vid', num => 2,
+ inherit => '/producer',
+ },
+ editions => {
+ enrich => sub { sql 'SELECT id', $_[0], 'FROM vn_editions WHERE id IN', $_[2] },
+ key => 'id', col => 'id', num => 3,
+ fields => {
+ eid => { select => 'eid' },
+ lang => { select => 'lang' },
+ name => { select => 'name' },
+ official => { select => 'official', @BOOL },
+ },
+ },
+ staff => {
+ enrich => sub { sql 'SELECT vs.id AS vid, s.id', $_[0], 'FROM vn_staff vs JOIN staff_aliast s ON s.aid = vs.aid', $_[1], 'WHERE NOT s.hidden AND vs.id IN', $_[2] },
+ key => 'id', col => 'vid', num => 20,
+ inherit => '/staff',
+ fields => {
+ eid => { select => 'vs.eid' },
+ role => { select => 'vs.role' },
+ note => { select => 'vs.note', @NSTR },
+ },
+ }
+ },
+ sort => [
+ id => 'v.id',
+ title => 'v.sorttitle ?o, v.id',
+ released => 'v.c_released ?o, v.id',
+ popularity => 'v.c_pop_rank !o NULLS LAST, v.id',
+ rating => 'v.c_rat_rank !o NULLS LAST, v.id',
+ votecount => 'v.c_votecount ?o, v.id',
+ ];
+
+
+api_query '/release',
+ filters => 'r',
+ sql => sub { sql 'SELECT r.id', $_[0], 'FROM releasest r', $_[1], 'WHERE NOT r.hidden AND (', $_[2], ')' },
+ search => [ 'r', 'r.id' ],
+ fields => {
+ id => {},
+ title => { select => 'r.title[1+1]' },
+ alttitle => { ALTTITLE 'r.title' },
+ languages => {
+ enrich => sub { sql 'SELECT rt.id', $_[0], 'FROM releases_titles rt', $_[1], 'WHERE rt.id IN', $_[2] },
+ key => 'id', col => 'id', num => 3,
+ joins => {
+ main => 'JOIN releases r ON r.id = rt.id',
+ },
+ fields => {
+ lang => { select => 'rt.lang' },
+ title => { select => 'rt.title' },
+ latin => { select => 'rt.latin' },
+ mtl => { select => 'rt.mtl', @BOOL },
+ main => { join => 'main', select => 'rt.lang = r.olang AS main', @BOOL },
+ },
+ },
+ platforms => {
+ enrich => sub { sql 'SELECT id, platform FROM releases_platforms WHERE id IN', $_[2] },
+ key => 'id', col => 'id', proc => sub { $_[0] = [ map $_->{platform}, $_[0]->@* ] },
+ },
+ media => {
+ enrich => sub { sql 'SELECT id', $_[0], 'FROM releases_media WHERE id IN', $_[2] },
+ key => 'id', col => 'id', num => 3,
+ fields => {
+ medium => { select => 'medium' },
+ qty => { select => 'qty' },
+ },
+ },
+ vns => {
+ enrich => sub { sql 'SELECT rv.id AS rid, v.id', $_[0], 'FROM releases_vn rv JOIN vnt v ON v.id = rv.vid', $_[1], 'WHERE rv.id IN', $_[2] },
+ key => 'id', col => 'rid', num => 3,
+ inherit => '/vn',
+ fields => {
+ rtype => { select => 'rv.rtype' },
+ },
+ },
+ producers => {
+ enrich => sub { sql 'SELECT rp.id AS rid, p.id', $_[0], 'FROM releases_producers rp JOIN producerst p ON p.id = rp.pid', $_[1], 'WHERE rp.id IN', $_[2] },
+ key => 'id', col => 'rid', num => 3,
+ inherit => '/producer',
+ fields => {
+ developer => { select => 'rp.developer', @BOOL },
+ publisher => { select => 'rp.publisher', @BOOL },
+ },
+ },
+ released => { select => 'r.released', @RDATE },
+ minage => { select => 'r.minage' },
+ patch => { select => 'r.patch', @BOOL },
+ freeware => { select => 'r.freeware', @BOOL },
+ uncensored => { select => 'r.uncensored', @BOOL },
+ official => { select => 'r.official', @BOOL },
+ has_ero => { select => 'r.has_ero', @BOOL },
+ resolution => { select => 'ARRAY[r.reso_x,r.reso_y] AS resolution'
+ , proc => sub { $_[0] = $_[0][1] == 0 ? undef : 'non-standard' if $_[0][0] == 0 } },
+ engine => { select => 'r.engine', @NSTR },
+ voiced => { select => 'r.voiced', @NINT },
+ notes => { select => 'r.notes', @NSTR },
+ gtin => { select => 'r.gtin', proc => sub { $_[0] = undef if !gtintype $_[0] } },
+ catalog => { select => 'r.catalog', @NSTR },
+ extlinks => { extlinks => 'r' },
+ },
+ sort => [
+ id => 'r.id',
+ title => 'r.sorttitle ?o, r.id',
+ released => 'r.released ?o, r.id',
+ ];
+
+
+api_query '/producer',
+ filters => 'p',
+ sql => sub { sql 'SELECT p.id', $_[0], 'FROM producerst p', $_[1], 'WHERE NOT p.hidden AND (', $_[2], ')' },
+ search => [ 'p', 'p.id' ],
+ fields => {
+ id => {},
+ name => { select => 'p.title[1+1] AS name' },
+ original => { ALTTITLE 'p.title', 'original' },
+ aliases => { select => 'p.alias AS aliases', @MSTR },
+ lang => { select => 'p.lang' },
+ type => { select => 'p.type' },
+ description => { select => 'p.description', @NSTR },
+ },
+ sort => [
+ id => 'p.id',
+ name => 'p.sorttitle ?o, p.id',
+ ];
+
+
+api_query '/character',
+ filters => 'c',
+ sql => sub { sql 'SELECT c.id', $_[0], 'FROM charst c', $_[1], 'WHERE NOT c.hidden AND (', $_[2], ')' },
+ search => [ 'c', 'c.id' ],
+ joins => {
+ image => 'LEFT JOIN images i ON i.id = c.image',
+ },
+ fields => {
+ id => {},
+ name => { select => 'c.title[1+1] AS name' },
+ original => { ALTTITLE 'c.title', 'original' },
+ aliases => { select => 'c.alias AS aliases', @MSTR },
+ description => { select => 'c.description', @NSTR },
+ image => {
+ fields => { IMG 'c.image', 'image', 'i.' },
+ nullif => 'c.image IS NULL AS image_nullif',
+ },
+ blood_type => { select => 'c.bloodt AS blood_type', proc => sub { $_[0] = undef if $_[0] eq 'unknown' } },
+ height => { select => 'c.height', @NINT },
+ weight => { select => 'c.weight' },
+ bust => { select => 'c.s_bust AS bust', @NINT },
+ waist => { select => 'c.s_waist AS waist', @NINT },
+ hips => { select => 'c.s_hip AS hips', @NINT },
+ cup => { select => 'c.cup_size AS cup', @NSTR },
+ age => { select => 'c.age' },
+ birthday => { select => 'CASE WHEN c.b_month = 0 THEN NULL ELSE ARRAY[c.b_month, NULLIF(c.b_day, 0)]::int[] END AS birthday' },
+ sex => { select => "NULLIF(ARRAY[NULLIF(c.gender, 'unknown'), NULLIF(COALESCE(c.spoil_gender, c.gender), 'unknown')]::text[], '{NULL,NULL}') AS sex" },
+ vns => {
+ enrich => sub { sql 'SELECT cv.id AS cid, v.id', $_[0], 'FROM chars_vns cv JOIN vnt v ON v.id = cv.vid', $_[1], 'WHERE NOT v.hidden AND cv.id IN', $_[2] },
+ key => 'id', col => 'cid', num => 3,
+ inherit => '/vn',
+ fields => {
+ spoiler => { select => 'cv.spoil AS spoiler' },
+ role => { select => 'cv.role' },
+ release => {
+ select => 'cv.rid',
+ enrich => sub { sql 'SELECT r.id AS rid, r.id', $_[0], 'FROM releasest r', $_[1], 'WHERE NOT r.hidden AND r.id IN', $_[2] },
+ key => 'rid', col => 'rid', atmostone => 1,
+ inherit => '/release',
+ }
+ },
+ },
+ traits => {
+ enrich => sub { sql 'SELECT ct.id AS cid, t.id', $_[0], 'FROM chars_traits ct JOIN traits t ON t.id = ct.tid', $_[1], 'WHERE NOT t.hidden AND ct.id IN', $_[2] },
+ key => 'id', col => 'cid', num => 30,
+ inherit => '/trait',
+ fields => {
+ spoiler => { select => 'ct.spoil AS spoiler' },
+ lie => { select => 'ct.lie', @BOOL },
+ },
+ },
+ },
+ sort => [
+ id => 'c.id',
+ name => 'c.name ?o, c.id',
+ ];
+
+
+api_query '/staff',
+ filters => 's',
+ sql => sub { sql 'SELECT s.id', $_[0], 'FROM staff_aliast s', $_[1], 'WHERE NOT s.hidden AND (', $_[2], ')' },
+ search => [ 's', 's.id', 's.aid' ],
+ fields => {
+ id => {},
+ aid => { select => 's.aid' },
+ ismain => { select => 's.main = s.aid AS ismain', @BOOL },
+ name => { select => 's.title[1+1] AS name' },
+ original => { ALTTITLE 's.title', 'original' },
+ lang => { select => 's.lang' },
+ gender => { select => "NULLIF(s.gender, 'unknown') AS gender" },
+ description => { select => 's.description', @NSTR },
+ extlinks => { extlinks => 's' },
+ aliases => {
+ enrich => sub { sql 'SELECT sa.id', $_[0], 'FROM staff_alias sa', $_[1], 'WHERE sa.id IN', $_[2] },
+ key => 'id', col => 'id', num => 3,
+ joins => {
+ main => 'JOIN staff s ON s.id = sa.id',
+ },
+ fields => {
+ aid => { select => 'sa.aid' },
+ name => { select => 'sa.name' },
+ latin => { select => 'sa.latin' },
+ ismain => { join => 'main', select => 'sa.aid = s.main AS ismain', @BOOL },
+ },
+ },
+ },
+ sort => [
+ id => 's.id',
+ name => 's.sorttitle ?o, s.id',
+ ];
+
+
+api_query '/tag',
+ filters => 'g',
+ sql => sub { sql 'SELECT t.id', $_[0], 'FROM tags t', $_[1], 'WHERE NOT t.hidden AND (', $_[2], ')' },
+ search => [ 'g', 't.id' ],
+ fields => {
+ id => {},
+ name => { select => 't.name' },
+ aliases => { select => 't.alias AS aliases', @MSTR },
+ description => { select => 't.description' },
+ category => { select => 't.cat AS category' },
+ searchable => { select => 't.searchable', @BOOL },
+ applicable => { select => 't.applicable', @BOOL },
+ vn_count => { select => 't.c_items AS vn_count' },
+ },
+ sort => [
+ id => 't.id',
+ name => 't.name',
+ vn_count => 't.c_items ?o, t.id',
+ ];
+
+
+api_query '/trait',
+ filters => 'i',
+ sql => sub { sql 'SELECT t.id', $_[0], 'FROM traits t', $_[1], 'WHERE NOT t.hidden AND (', $_[2], ')' },
+ search => [ 'i', 't.id' ],
+ joins => {
+ group => 'LEFT JOIN traits g ON g.id = t.gid',
+ },
+ fields => {
+ id => {},
+ name => { select => 't.name' },
+ aliases => { select => 't.alias AS aliases', @MSTR },
+ description => { select => 't.description' },
+ searchable => { select => 't.searchable', @BOOL },
+ applicable => { select => 't.applicable', @BOOL },
+ group_id => { join => 'group', select => 't.gid AS group_id' },
+ group_name => { join => 'group', select => 'g.name AS group_name' },
+ char_count => { select => 't.c_items AS char_count' },
+ },
+ sort => [
+ id => 't.id',
+ name => 't.name ?o, t.id',
+ char_count => 't.c_items ?o, t.id',
+ ];
+
+
+api_query '/ulist',
+ filters => 'v',
+ sql => sub {
+ err 400, 'Missing "user" parameter and not authenticated.' if !$_[3]{user};
+ sql 'SELECT v.id', $_[0], '
+ FROM ulist_vns uv
+ JOIN vnt v ON v.id = uv.vid', $_[1], '
+ WHERE', sql_and
+ 'NOT v.hidden',
+ sql('uv.uid =', \$_[3]{user}),
+ auth->api2Listread($_[3]{user}) ? () : 'NOT uv.c_private',
+ $_[2];
+ },
+ search => [ 'v', 'v.id' ],
+ fields => {
+ id => {},
+ added => { select => "extract('epoch' from uv.added)::bigint AS added" },
+ lastmod => { select => "extract('epoch' from uv.lastmod)::bigint AS lastmod" },
+ voted => { select => "extract('epoch' from uv.vote_date)::bigint AS voted" },
+ vote => { select => 'uv.vote' },
+ started => { select => 'uv.started' },
+ finished => { select => 'uv.finished' },
+ notes => { select => 'uv.notes', @NSTR },
+ labels => {
+ enrich => sub { sql 'SELECT uv.vid', $_[0], '
+ FROM ulist_vns uv, unnest(uv.labels) l(id), ulist_labels ul
+ WHERE', sql_and
+ sql('uv.uid =', \$_[3]{user}),
+ sql('ul.uid =', \$_[3]{user}),
+ 'ul.id = l.id',
+ auth->api2Listread($_[3]{user}) ? () : 'NOT ul.private',
+ sql('uv.vid IN', $_[2]) },
+ key => 'id', col => 'vid', num => 3,
+ fields => {
+ id => { select => 'l.id' },
+ label => { select => 'ul.label' },
+ },
+ },
+ vn => {
+ enrich => sub { sql 'SELECT v.id', $_[0], 'FROM vnt v', $_[1], 'WHERE v.id IN', $_[2] },
+ key => 'id', col => 'id', atmostone => 1, inherit => '/vn',
+ },
+ releases => {
+ enrich => sub { sql 'SELECT irv.vid, r.id', $_[0], '
+ FROM rlists rl
+ JOIN releasest r ON rl.rid = r.id', $_[1], '
+ JOIN (SELECT DISTINCT id, vid FROM releases_vn rv WHERE rv.vid IN', $_[2], ') AS irv(id,vid) ON rl.rid = irv.id
+ WHERE NOT r.hidden
+ AND rl.uid =', \$_[3]{user} },
+ key => 'id', col => 'vid', num => 3, inherit => '/release',
+ fields => {
+ list_status => { select => 'rl.status AS list_status' },
+ },
+ },
+ },
+ sort => [
+ id => 'v.id',
+ title => 'v.sorttitle ?o, v.id',
+ released => 'v.c_released ?o, v.id',
+ popularity => 'v.c_pop_rank !o NULLS LAST, v.id',
+ rating => 'v.c_rat_rank !o NULLS LAST, v.id',
+ votecount => 'v.c_votecount ?o, v.id',
+ voted => 'uv.vote_date ?o, v.id',
+ vote => 'uv.vote ?o, v.id',
+ added => 'uv.added',
+ lastmod => 'uv.lastmod',
+ started => 'uv.started ?o, v.id',
+ finished => 'uv.finished ?o, v.id',
+ ];
+
+
+
+
+
+# Now that all APIs have been defined, go over the definitions and:
+# - Resolve 'inherit' fields
+# - Expand 'extlinks' fields
+(sub {
+ for my $f (values $_[0]->%*) {
+ if($f->{inherit}) {
+ my $o = $OBJS{$f->{inherit}};
+ $f->{fields}{$_} = $o->{fields}{$_} for keys %{ $o->{fields}||{} };
+ $f->{joins}{$_} = $o->{joins}{$_} for keys %{ $o->{joins}||{} };
+ }
+ $f->{fields} ||= { map +($_,{}), qw{name label id url} } if $f->{extlinks};
+ __SUB__->($f->{fields}) if $f->{fields} && !$f->{_expand_done}++;
+ }
+})->($_->{fields}) for values %OBJS;
+
+1;
diff --git a/lib/VNWeb/AdvSearch.pm b/lib/VNWeb/AdvSearch.pm
new file mode 100644
index 00000000..6f226b7f
--- /dev/null
+++ b/lib/VNWeb/AdvSearch.pm
@@ -0,0 +1,963 @@
+package VNWeb::AdvSearch;
+
+# This module comes with query definitions and helper functions to handle
+# advanced search queries. Usage is as follows:
+#
+# my $q = tuwf->validate(get => f => { advsearch => 'v' })->data;
+#
+# $q->sql_where; # Returns an SQL condition for use in a where clause.
+# $q->elm_; # Instantiate an Elm widget
+
+
+use v5.26;
+use warnings;
+use B;
+use POSIX 'strftime';
+use List::Util 'max';
+use TUWF ':html5_';
+use VNWeb::Auth;
+use VNWeb::DB;
+use VNWeb::Validation;
+use VNWeb::HTML ();
+use VNDB::Types;
+use VNDB::ExtLinks ();
+use Exporter 'import';
+our @EXPORT = qw/advsearch_default/;
+
+
+
+# Search queries should be seen as some kind of low-level assembly for
+# generating complex queries, they're designed to be simple to implement,
+# powerful, extendable and stable. They're also a pain to work with, but that
+# comes with the trade-off.
+#
+# A search query can be expressed in three different representations.
+#
+# Normalized JSON form:
+#
+# $Query = $Combinator || $Predicate
+# $Combinator = [ 'and'||'or', $Query, .. ]
+# $Predicate = [ $Field, $Op, $Value ]
+# $Op = '=', '!=', '>=', '>', '<=', '<'
+# $Field = $string
+# $Value = $Query || $field_specific_json_value
+#
+# This representation is used internally and can be exposed as an API.
+# Eventually.
+#
+# Example:
+#
+# [ 'and'
+# , [ 'or' # No support for array values, so IN() queries need explicit ORs.
+# , [ 'lang', '=', 'en' ]
+# , [ 'lang', '=', 'de' ]
+# , [ 'lang', '=', 'fr' ]
+# ]
+# , [ 'olang', '!=', 'ja' ]
+# , [ 'release', '=', [ 'and' # VN has a release that matches the given query
+# , [ 'released', '>=', '2020-01-01' ]
+# , [ 'developer', '=', 'p30' ]
+# ]
+# ]
+# ]
+#
+# Compact JSON form:
+#
+# $Query = $Combinator || $Predicate
+# $Combinator = [ 0||1, $Query, .. ]
+# $Predicate = [ $Field, $Op, $Value ]
+# $Op = '=', '!=', '>=', '>', '<=', '<'
+# $Field = $integer
+# $Tuple = [ $integer, $integer ]
+# $Value = $integer || $string || $Query || $Tuple
+#
+# Compact JSON form uses integers to represent field names and 'and'/'or'.
+# The field numbers are specific to the query type (e.g. visual novel and
+# release queries). The accepted forms of $Value are much more limited and
+# conversion of values between compact and normalized form is
+# field-dependent.
+#
+# This representation is used as an intermediate format between the
+# normalized JSON form and the compact encoded form. Conversion between
+# normalized JSON and compact JSON form requires knowledge about all fields
+# and their accepted values, while conversion between compact JSON form and
+# compact encoded form can be done mechanically. This is the reason why Elm
+# works with the compact JSON form.
+#
+# Same example:
+#
+# [ 0
+# , [ 1
+# , [ 2, '=', 'de' ]
+# , [ 2, '=', 'en' ]
+# , [ 2, '=', 'fr' ]
+# ]
+# , [ 3, '!=', 'ja' ]
+# , [ 50, '=', [ 0
+# , [ 7, '>=', 20200101 ]
+# , [ 6, '=', 30 ]
+# ]
+# ]
+# ]
+#
+# Compact encoded form:
+#
+# Alternative and more compact representation of the compact JSON form.
+# Intended for use in a URL query string, used characters: [0-9a-zA-Z_-]
+# (plus any unicode characters that may be present in string fields).
+# Not intended to be easy to parse or work with, optimized for short length.
+#
+# Same example: 03132gde2gen2gfr3hjaN180272_0c2vQ60u
+
+
+# INTEGER ENCODING
+#
+# Positive integers are encoded in such a way that the first character
+# indicates the length of the encoded integer, this allows integers to be
+# concatenated without any need for a delimiter. Low numbers are encoded
+# fully in a single character. The two-character encoding uses 10 values from
+# the first character in order to make efficient use of space. The last 5
+# values of the first character are used to indicate the length of integers
+# needing more than 2 characters to encode.
+#
+# Alphabet: 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-
+# (that's base64-url, but with different indices)
+#
+# Full encoding format is as follows:
+# (# representing a character from the alphabet)
+#
+# FIRST FORMAT MIN VALUE MAX VALUE
+# 0..M # 0 48 -> Direct lookup in the alphabet
+# N..W ## 49 688 -> 49 + ($first_character-'N')*64 + $second_character
+# X X## 689 4_784 -> 689 + $first_character*64 + $second_character
+# Y Y### 4_785 266_928 etc.
+# Z Z#### 266_929 17_044_144
+# _ -##### 17_044_145 1_090_785_968
+# - _###### 1_090_785_969 69_810_262_704
+#
+# STRING ENCODING
+#
+# Strings are encoded as-is, with the following characters escaped:
+#
+# [SPACE]!"#$%&'()*+,-./:;<=>?@[\]^_`{|}~
+#
+# Escaping is done by taking the index of the character into the above list,
+# encoding that index to an integer according to the integer encoding rules
+# as described above and prefixing it with '_'. Example:
+#
+# "a b-c" -> "a_0b_dc"
+#
+# The end of a string can either be indicated with a '-' character, or the
+# length of the string can be encoded in a preceding field.
+#
+# QUERY ENCODING
+#
+# Int(n) refers to the integer encoding described above.
+# Escape(s) refers to the string encoding described above.
+#
+# $Query = $Predicate | $Combinator
+#
+# $CombiType = 'and' => 0, 'or' => 1
+# $Combinator = Int($CombiType) Int($num_queries) $Query..
+#
+# $Predicate = Int($field_number) $TypedOp $Value
+#
+# Both a Predicate and a Combinator start with an encoded integer. For
+# Combinator this is 0 or 1, for Predicate this is the field number (>=2).
+# A Query must either be self-delimiting or encode its own length, so that
+# these can be directly concatenated.
+#
+# $Op = '=' => 0, '!=' => 1, '>=' => 2, '>' => 3, '<=' => 4, '<' => 5
+# $Type = integer => 0, query => 1, string2 => 2, string3 => 3, stringn => 4, Tuple => 5
+# $TypedOp = Int( $Type*8 + $Op )
+# $Tuple = Int($first) Int($second)
+# $Value = Int($integer)
+# | Escape($string2) | Escape($string3) | Escape($stringn) '-'
+# | $Query
+# | $Tuple
+#
+# The encoded field number of a Predicate is followed by a single encoded
+# integer that covers both the operator and the type of the value. This
+# encoding leaves room for 2 additional operators. There are 3 different
+# string types: string2 and string3 are fixed-length strings of 2 and 3
+# characters, respectively, and $stringn is an arbitrary-length string that
+# ends with the '-' character.
+
+
+my @alpha = (0..9, 'a'..'z', 'A'..'Z', '_', '-');
+my %alpha = map +($alpha[$_],$_), 0..$#alpha;
+
+# Assumption: @escape has less than 49 characters.
+my @escape = split //, " !\"#\$%&'()*+,-./:;<=>?@[\\]^_`{|}~";
+my %escape = map +($escape[$_],$alpha[$_]), 0..$#escape;
+my $escape_re = qr{([${\quotemeta join '', @escape}])};
+
+my @ops = qw/= != >= > <= </;
+my %ops = map +($ops[$_],$_), 0..$#ops;
+
+sub _unescape_str { $_[0] =~ s{_(.)}{ $escape[$alpha{$1} // return] // return }reg }
+sub _escape_str { $_[0] =~ s/$escape_re/_$escape{$1}/rg }
+
+# Read a '-'-delimited string.
+sub _dec_str {
+ my($s, $i) = @_;
+ my $start = $$i;
+ $$i >= length $s and return while substr($s, $$i++, 1) ne '-';
+ _unescape_str substr $s, $start, $$i-$start-1;
+}
+
+sub _substr { $_[1]+$_[2] <= length $_[0] ? substr $_[0], $_[1], $_[2] : undef }
+
+sub _dec_int {
+ my($s, $i) = @_;
+ my $c1 = ($alpha{_substr($s, $$i++, 1) // return} // return);
+ return $c1 if $c1 < 49;
+ my $n = ($alpha{_substr($s, $$i++, 1) // return} // return);
+ return 49 + ($c1-49)*64 + $n if $c1 < 59;
+ $n = $n*64 + ($alpha{_substr($s, $$i++, 1) // return} // return) for (1..$c1-59+1);
+ $n + (689, 4785, 266929, 17044145, 1090785969)[$c1-59]
+}
+
+sub _dec_query {
+ my($s, $i) = @_;
+ my $c1 = _dec_int($s, $i) // return;
+ my $c2 = _dec_int($s, $i) // return;
+ return [ $c1, map +(_dec_query($s, $i) // return), 1..$c2 ] if $c1 <= 1;
+ my($op, $type) = ($c2 % 8, int ($c2 / 8));
+ [ $c1, $ops[$op],
+ $type == 0 ? (_dec_int($s, $i) // return) :
+ $type == 1 ? (_dec_query($s, $i) // return) :
+ $type == 2 ? do { my $v = _unescape_str(_substr($s, $$i, 2) // return) // return; $$i += 2; $v } :
+ $type == 3 ? do { my $v = _unescape_str(_substr($s, $$i, 3) // return) // return; $$i += 3; $v } :
+ $type == 4 ? (_dec_str($s, $i) // return) :
+ $type == 5 ? [ _dec_int($s, $i) // return, _dec_int($s, $i) // return ] : undef ]
+}
+
+sub _enc_int {
+ my($n) = @_;
+ return if $n < 0;
+ return $alpha[$n] if $n < 49;
+ return $alpha[49 + int(($n-49)/64)] . $alpha[($n-49)%64] if $n < 689;
+ sub r { ($_[0] > 1 ? r($_[0]-1,int $_[1]/64) : '').$alpha[$_[1]%64] }
+ return 'X'.r 2, $n - 689 if $n < 4785;
+ return 'Y'.r 3, $n - 4785 if $n < 266929;
+ return 'Z'.r 4, $n - 266929 if $n < 17044145;
+ return '_'.r 5, $n - 17044145 if $n < 1090785969;
+ return '-'.r 6, $n - 1090785969 if $n < 69810262705;
+}
+
+sub _is_tuple { ref $_[0] eq 'ARRAY' && $_[0]->@* == 2 && (local $_ = $_[0][1]) =~ /^[0-9]+$/ }
+
+# Assumes that the query is already in compact JSON form.
+sub _enc_query {
+ my($q) = @_;
+ return ($alpha[$q->[0]])._enc_int($#$q).join '', map _enc_query($_), @$q[1..$#$q] if $q->[0] <= 1;
+ my sub r { _enc_int($q->[0])._enc_int($ops{$q->[1]} + 8*$_[0]) }
+ return r(5)._enc_int($q->[2][0])._enc_int($q->[2][1]) if _is_tuple $q->[2];
+ return r(1)._enc_query($q->[2]) if ref $q->[2];
+ if(!(B::svref_2object(\$q->[2])->FLAGS & B::SVp_POK)) {
+ my $s = _enc_int $q->[2];
+ return r(0).$s if defined $s;
+ }
+ my $esc = _escape_str $q->[2];
+ return r(2).$esc if length $esc == 2;
+ return r(3).$esc if length $esc == 3;
+ r(4).$esc.'-';
+}
+
+
+
+
+# Define a $Field, args:
+# $type -> 'v', 'c', etc.
+# $name -> $Field name, must be stable and unique for the $type.
+# $num -> Numeric identifier for compact encoding, must be >= 2 and same requirements as $name.
+# Fields that don't occur often should use numbers above 50, for better encoding of common fields.
+# $value -> TUWF::Validate schema for value validation, or $query_type to accept a nested query.
+# %options:
+# $op -> Operator definitions and sql() generation functions.
+# sql -> sql() generation function that is called for all operators.
+# sql_list -> Alternative to the '=' and '!=' $op definitions to optimize lists of (in)equality queries.
+# sql() generation function that is called with the following arguments:
+# - negate, 1/0 - whether the entire query should be negated
+# - all, 1/0 - whether all values must match, 1=all, 0=any
+# - arrayref of values to compare for equality
+# sql_list_grp -> When using sql_list, a subroutine that returns a grouping identifier for the given value.
+# Only values with the same group identifier will be given to a single sql_list call.
+# May return to disable sql_list support for specific values.
+# compact -> Function to convert a value from normalized JSON form into compact JSON form.
+#
+# An implementation for the '!=' operator will be supplied automatically if it's not explicitely defined.
+# NOTE: That implementation does NOT work for NULL values.
+our(%FIELDS, %NUMFIELDS);
+sub f {
+ my($t, $num, $n, $v, @opts) = @_;
+ my %f = (
+ num => $num,
+ value => ref $v eq 'HASH' ? tuwf->compile($v) : $v,
+ @opts,
+ );
+ $f{'='} = sub { $f{sql_list}->(0,0,[$_]) } if !$f{'='} && $f{sql_list};
+ $f{'!='} = sub { $f{sql_list}->(1,0,[$_]) } if !$f{'!='} && $f{sql_list};
+ $f{'!='} = sub { sql 'NOT (', $f{'='}->(@_), ')' } if $f{'='} && !$f{'!='};
+ $f{vndbid} = ref $v eq 'HASH' && $v->{vndbid} && !ref $v->{vndbid} && $v->{vndbid};
+ $f{int} = ref $f{value} && ($v->{fuzzyrdate} || $f{value}->analyze->{type} eq 'int' || $f{value}->analyze->{type} eq 'bool');
+ $FIELDS{$t}{$n} = \%f;
+ die "Duplicate number $num for $t\n" if $NUMFIELDS{$t}{$num};
+ $NUMFIELDS{$t}{$num} = $n;
+}
+
+my @TYPE; # stack of query types, $TYPE[0] is the top-level query, $TYPE[$#TYPE] the query currently being processed.
+
+
+f v => 80 => 'id', { vndbid => 'v' }, sql => sub { sql 'v.id', $_[0], \$_ };
+f v => 81 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('v', 'v.id') };
+f v => 2 => 'lang', { enum => \%LANGUAGE }, '=' => sub { sql 'v.c_languages && ARRAY', \$_, '::language[]' };
+f v => 3 => 'olang', { enum => \%LANGUAGE }, '=' => sub { sql 'v.olang =', \$_ };
+f v => 4 => 'platform', { enum => \%PLATFORM }, '=' => sub { sql 'v.c_platforms && ARRAY', \$_, '::platform[]' };
+f v => 5 => 'length', { uint => 1, enum => \%VN_LENGTH },
+ '=' => sub { sql 'COALESCE(v.c_length BETWEEN', \$VN_LENGTH{$_}{low}, 'AND', \$VN_LENGTH{$_}{high}, ', v.length =', \$_, ')' };
+f v => 7 => 'released', { fuzzyrdate => 1 }, sql => sub { sql 'v.c_released', $_[0], \($_ == 1 ? strftime('%Y%m%d', gmtime) : $_) };
+f v => 9 => 'popularity',{ uint => 1, range => [ 0, 100] }, sql => sub { sql 'v.c_votecount', $_[0], \($_*150) }; # XXX: Deprecated
+f v => 10 => 'rating', { uint => 1, range => [10, 100] }, sql => sub { sql 'v.c_rating', $_[0], \($_*10) };
+f v => 11 => 'votecount', { uint => 1, range => [ 0,1<<30] }, sql => sub { sql 'v.c_votecount', $_[0], \$_ };
+f v => 61 => 'has_description', { uint => 1, range => [1,1] }, '=' => sub { 'v.description <> \'\'' };
+f v => 62 => 'has_anime', { uint => 1, range => [1,1] }, '=' => sub { 'EXISTS(SELECT 1 FROM vn_anime va WHERE va.id = v.id)' };
+f v => 63 => 'has_screenshot', { uint => 1, range => [1,1] }, '=' => sub { 'EXISTS(SELECT 1 FROM vn_screenshots vs WHERE vs.id = v.id)' };
+f v => 64 => 'has_review', { uint => 1, range => [1,1] }, '=' => sub { 'EXISTS(SELECT 1 FROM reviews r WHERE r.vid = v.id AND NOT r.c_flagged)' };
+f v => 65 => 'on_list', { uint => 1, range => [1,1] },
+ '=' => sub { auth ? sql 'v.id IN(SELECT vid FROM ulist_vns WHERE uid =', \auth->uid, auth->api2Listread ? () : 'AND NOT c_private', ')' : '1=0' };
+f v => 66 => 'devstatus', { uint => 1, enum => \%DEVSTATUS }, '=' => sub { 'v.devstatus =', \$_ };
+
+f v => 8 => 'tag', { type => 'any', func => \&_validate_tag }, compact => \&_compact_tag, sql_list => _sql_where_tag('tags_vn_inherit');
+f v => 14 => 'dtag', { type => 'any', func => \&_validate_tag }, compact => \&_compact_tag, sql_list => _sql_where_tag('tags_vn_direct');
+
+f v => 12 => 'label', { type => 'any', func => \&_validate_label },
+ compact => sub { [ ($_->[0] =~ s/^u//r)*1, $_->[1]*1 ] },
+ sql_list => \&_sql_where_label, sql_list_grp => sub { $_->[1] == 0 ? undef : $_->[0] };
+
+f v => 13 => 'anime_id', { id => 1 },
+ sql_list => sub {
+ my($neg, $all, $val) = @_;
+ sql 'v.id', $neg ? 'NOT' : '', 'IN(SELECT id FROM vn_anime WHERE aid IN', $val, $all && @$val > 1 ? ('GROUP BY id HAVING COUNT(aid) =', \scalar @$val) : (), ')';
+ };
+
+f v => 50 => 'release', 'r', '=' => sub { sql 'v.id IN(SELECT rv.vid FROM releases r JOIN releases_vn rv ON rv.id = r.id WHERE NOT r.hidden AND', $_, ')' };
+f v => 51 => 'character','c', '=' => sub { sql 'v.id IN(SELECT cv.vid FROM chars c JOIN chars_vns cv ON cv.id = c.id WHERE NOT c.hidden AND', $_, ')' }; # TODO: Spoiler setting?
+f v => 52 => 'staff', 's', '=' => sub {
+ # The "Staff" filter includes both vn_staff and vn_seiyuu. Union those tables together and filter on that.
+ sql 'v.id IN(SELECT vs.id
+ FROM (SELECT id, aid, role FROM vn_staff UNION ALL SELECT id, aid, NULL FROM vn_seiyuu) vs
+ JOIN staff_aliast s ON s.aid = vs.aid
+ WHERE NOT s.hidden AND', $_, ')' };
+f v => 55 => 'developer', 'p', '=' => sub { sql 'EXISTS(SELECT 1 FROM producers p, unnest(v.c_developers) vcd(x) WHERE p.id = vcd.x AND NOT p.hidden AND', $_, ')' };
+
+# Deprecated.
+f v => 6 => 'developer-id', { vndbid => 'p' }, '=' => sub { sql 'v.c_developers && ARRAY', \$_, '::vndbid[]' };
+
+
+
+f r => 80 => 'id', { vndbid => 'r' }, sql => sub { sql 'r.id', $_[0], \$_ };
+f r => 81 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('r', 'r.id') };
+f r => 2 => 'lang', { enum => \%LANGUAGE },
+ sql_list => sub {
+ my($neg, $all, $val) = @_;
+ sql 'r.id', $neg ? 'NOT' : '', 'IN(SELECT id FROM releases_titles WHERE NOT mtl AND lang IN', $val, $all && @$val > 1 ? ('GROUP BY id HAVING COUNT(lang) =', \scalar @$val) : (), ')';
+ };
+
+f r => 4 => 'platform', { default => undef, enum => \%PLATFORM },
+ sql_list_grp => sub { defined $_ },
+ sql_list => sub {
+ my($neg, $all, $val) = @_;
+ return sql $neg ? '' : 'NOT', 'EXISTS(SELECT 1 FROM releases_platforms WHERE id = r.id)' if !defined $val->[0];
+ sql 'r.id', $neg ? 'NOT' : '', 'IN(SELECT id FROM releases_platforms WHERE platform IN', $val, $all && @$val > 1 ? ('GROUP BY id HAVING COUNT(platform) =', \scalar @$val) : (), ')';
+ };
+
+f r => 7 => 'released', { fuzzyrdate => 1 }, sql => sub { sql 'r.released', $_[0], \($_ == 1 ? strftime('%Y%m%d', gmtime) : $_) };
+f r => 8 => 'resolution', { type => 'array', length => 2, values => { uint => 1, max => 32767 } },
+ sql => sub { sql 'NOT r.patch AND r.reso_x', $_[0], \$_->[0], 'AND r.reso_y', $_[0], \$_->[1], $_->[0] ? 'AND r.reso_x > 0' : () };
+f r => 9 => 'resolution-aspect', { type => 'array', length => 2, values => { uint => 1, max => 32767 } },
+ sql => sub { sql 'NOT r.patch AND r.reso_x', $_[0], \$_->[0], 'AND r.reso_y', $_[0], \$_->[1], 'AND r.reso_x*1000/GREATEST(1, r.reso_y) =', \(int ($_->[0]*1000/max(1,$_->[1]))), $_->[0] ? 'AND r.reso_x > 0' : () };
+f r => 10 => 'minage', { default => undef, uint => 1, enum => \%AGE_RATING },
+ sql => sub { defined $_ ? sql 'r.minage', $_[0], \$_ : $_[0] eq '=' ? 'r.minage IS NULL' : 'r.minage IS NOT NULL' };
+f r => 11 => 'medium', { default => undef, enum => \%MEDIUM },
+ '=' => sub { !defined $_ ? 'NOT EXISTS(SELECT 1 FROM releases_media rm WHERE rm.id = r.id)' : sql 'EXISTS(SELECT 1 FROM releases_media rm WHERE rm.id = r.id AND rm.medium =', \$_, ')' };
+f r => 12 => 'voiced', { default => 0, uint => 1, enum => \%VOICED }, '=' => sub { sql 'NOT r.patch AND r.voiced =', \$_ };
+f r => 13 => 'animation-ero', { uint => 1, enum => \%ANIMATED }, '=' => sub { sql 'NOT r.patch AND r.ani_ero =', \$_ };
+f r => 14 => 'animation-story', { uint => 1, enum => \%ANIMATED }, '=' => sub { sql 'NOT r.patch AND r.ani_story =', \$_ };
+f r => 15 => 'engine', { default => '' }, '=' => sub { sql 'r.engine =', \$_ };
+f r => 16 => 'rtype', { enum => \%RELEASE_TYPE }, '=' => sub { $#TYPE && $TYPE[$#TYPE-1] eq 'v' ? sql 'rv.rtype =', \$_ : sql 'r.id IN(SELECT id FROM releases_vn WHERE rtype =', \$_, ')' };
+f r => 18 => 'rlist', { uint => 1, enum => \%RLIST_STATUS }, sql_list => sub {
+ my($neg, $all, $val) = @_;
+ return '1=0' if !auth;
+ sql 'r.id', $neg ? 'NOT' : '', 'IN(SELECT rid FROM rlists WHERE uid =', \auth->uid, 'AND status IN', $val, $all && @$val > 1 ? ('GROUP BY rid HAVING COUNT(status) =', \scalar @$val) : (), ')';
+ };
+f r => 19 => 'extlink', _extlink_filter('r');
+f r => 20 => 'drm', { default => '' }, '=' => sub { sql 'EXISTS(SELECT 1 FROM drm JOIN releases_drm rd ON rd.drm = drm.id WHERE drm.name =', \$_, 'AND rd.id = r.id)' };
+f r => 61 => 'patch', { uint => 1, range => [1,1] }, '=' => sub { 'r.patch' };
+f r => 62 => 'freeware', { uint => 1, range => [1,1] }, '=' => sub { 'r.freeware' };
+f r => 64 => 'uncensored',{uint => 1, range => [1,1] }, '=' => sub { 'r.uncensored' };
+f r => 65 => 'official', { uint => 1, range => [1,1] }, '=' => sub { 'r.official' };
+f r => 66 => 'has_ero', { uint => 1, range => [1,1] }, '=' => sub { 'r.has_ero' };
+f r => 53 => 'vn', 'v', '=' => sub { sql 'r.id IN(SELECT rv.id FROM releases_vn rv JOIN vn v ON v.id = rv.vid WHERE NOT v.hidden AND', $_, ')' };
+f r => 55 => 'producer', 'p', '=' => sub { sql 'r.id IN(SELECT rp.id FROM releases_producers rp JOIN producers p ON p.id = rp.pid WHERE NOT p.hidden AND', $_, ')' };
+
+# Deprecated.
+f r => 6 => 'developer-id',{ vndbid => 'p' }, '=' => sub { sql 'r.id IN(SELECT id FROM releases_producers WHERE developer AND pid =', \$_, ')' }; # Does not have a new equivalent
+f r => 17 => 'producer-id', { vndbid => 'p' }, '=' => sub { sql 'r.id IN(SELECT id FROM releases_producers WHERE pid =', \$_, ')' };
+f r => 63 => 'doujin', { uint => 1, range => [1,1] }, '=' => sub { 'r.doujin' }; # Not recognized by Elm anymore.
+
+
+
+f c => 80 => 'id', { vndbid => 'c' }, sql => sub { sql 'c.id', $_[0], \$_ };
+f c => 81 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('c', 'c.id') };
+f c => 2 => 'role', { enum => \%CHAR_ROLE }, '=' => sub { $#TYPE && $TYPE[$#TYPE-1] eq 'v' ? sql 'cv.role =', \$_ : sql 'c.id IN(SELECT id FROM chars_vns WHERE role =', \$_, ')' };
+f c => 3 => 'blood_type', { enum => \%BLOOD_TYPE }, '=' => sub { sql 'c.bloodt =', \$_ };
+f c => 4 => 'sex', { enum => \%GENDER }, '=' => sub { sql 'c.gender =', \$_ };
+f c => 5 => 'sex_spoil', { enum => \%GENDER }, '=' => sub { sql '(c.gender =', \$_, 'AND c.spoil_gender IS NULL) OR c.spoil_gender IS NOT DISTINCT FROM', \$_ };
+f c => 6 => 'height', { default => undef, uint => 1, max => 32767 },
+ sql => sub { !defined $_ ? sql 'c.height', $_[0], 0 : sql 'c.height <> 0 AND c.height', $_[0], \$_ };
+f c => 7 => 'weight', { default => undef, uint => 1, max => 32767 },
+ sql => sub { !defined $_ ? sql('c.weight IS', $_[0] eq '=' ? '' : 'NOT', 'NULL') : sql 'c.weight', $_[0], \$_ };
+f c => 8 => 'bust', { default => undef, uint => 1, max => 32767 },
+ sql => sub { !defined $_ ? sql 'c.s_bust', $_[0], 0 : sql 'c.s_bust <> 0 AND c.s_bust', $_[0], \$_ };
+f c => 9 => 'waist', { default => undef, uint => 1, max => 32767 },
+ sql => sub { !defined $_ ? sql 'c.s_waist', $_[0], 0 : sql 'c.s_waist <> 0 AND c.s_waist', $_[0], \$_ };
+f c => 10 => 'hips', { default => undef, uint => 1, max => 32767 },
+ sql => sub { !defined $_ ? sql 'c.s_hip', $_[0], 0 : sql 'c.s_hip <> 0 AND c.s_hip', $_[0], \$_ };
+f c => 11 => 'cup', { default => undef, enum => \%CUP_SIZE },
+ sql => sub { !defined $_ ? sql 'c.cup_size', $_[0], "''" : sql 'c.cup_size <> \'\' AND c.cup_size', $_[0], \$_ };
+f c => 12 => 'age', { default => undef, uint => 1, max => 32767 },
+ sql => sub { !defined $_ ? sql('c.age IS', $_[0] eq '=' ? '' : 'NOT', 'NULL') : sql 'c.age', $_[0], \$_ };
+f c => 13 => 'trait', { type => 'any', func => \&_validate_trait }, compact => \&_compact_trait, sql_list => _sql_where_trait('traits_chars', 'cid');
+f c => 15 => 'dtrait', { type => 'any', func => \&_validate_trait }, compact => \&_compact_trait, sql_list => _sql_where_trait('chars_traits', 'id');
+f c => 14 => 'birthday', { default => [0,0], type => 'array', length => 2, values => { uint => 1, max => 31 } },
+ '=' => sub { sql 'c.b_month =', \$_->[0], $_->[1] ? ('AND c.b_day =', \$_->[1]) : () };
+
+# XXX: When this field is nested inside a VN query, it may match seiyuu linked to other VNs.
+# This can be trivially fixed by adding an (AND vs.id = v.id) clause, but that results in extremely slow queries that I've no clue how to optimize.
+f c => 52 => 'seiyuu', 's', '=' => sub { sql 'c.id IN(SELECT vs.cid FROM vn_seiyuu vs JOIN staff_aliast s ON s.aid = vs.aid WHERE NOT s.hidden AND', $_, ')' };
+f c => 53 => 'vn', 'v', '=' => sub { sql 'c.id IN(SELECT cv.id FROM chars_vns cv JOIN vn v ON v.id = cv.vid WHERE NOT v.hidden AND', $_, ')' };
+
+
+
+# Staff filters need 'staff_aliast s', aliases are treated as separate rows.
+f s => 2 => 'lang', { enum => \%LANGUAGE }, '=' => sub { sql 's.lang =', \$_ };
+f s => 3 => 'id', { vndbid => 's' }, sql => sub { sql 's.id', $_[0], \$_ };
+f s => 4 => 'gender', { enum => \%GENDER }, '=' => sub { sql 's.gender =', \$_ };
+f s => 5 => 'role', { enum => [ 'seiyuu', keys %CREDIT_TYPE ] },
+ sql_list_grp => sub { $_ eq 'seiyuu' ? undef : '' },
+ sql_list => sub {
+ my($neg, $all, $val) = @_;
+ my @grp = $all && @$val > 1 ? ('GROUP BY vs.aid HAVING COUNT(vs.role) =', \scalar @$val) : ();
+ if($#TYPE && $TYPE[$#TYPE-1] eq 'v') {
+ # Shortcut referencing the vn_staff table we're already querying
+ return $val->[0] eq 'seiyuu' ? 'vs.role IS NULL' : sql 'vs.role IN', $val if !@grp && !$neg;
+ return sql $neg ? 'NOT' : '', 'EXISTS(SELECT 1 FROM vn_seiyuu vs WHERE vs.id = v.id AND vs.aid = s.aid)' if $val->[0] eq 'seiyuu';
+ sql 's.aid', $neg ? 'NOT' : '', 'IN(SELECT vs.aid FROM vn_staff vs WHERE vs.id = v.id AND vs.role IN', $val, @grp, ')';
+ } else {
+ return sql $neg ? 'NOT' : '', 'EXISTS(SELECT 1 FROM vn_seiyuu vs JOIN vn v ON v.id = vs.id WHERE NOT v.hidden AND vs.aid = s.aid)' if $val->[0] eq 'seiyuu';
+ sql 's.aid', $neg ? 'NOT' : '', 'IN(SELECT vs.aid FROM vn_staff vs JOIN vn v ON v.id = vs.id WHERE NOT v.hidden AND vs.role IN', $val, @grp, ')';
+ }
+ };
+f s => 6 => 'extlink', _extlink_filter('s');
+f s => 61 => 'ismain', { uint => 1, range => [1,1] }, '=' => sub { 's.aid = s.main' };
+f s => 80 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('s', 's.id', 's.aid') };
+f s => 81 => 'aid', { id => 1 }, '=' => sub { sql 's.aid =', \$_ };
+
+f p => 2 => 'lang', { enum => \%LANGUAGE }, '=' => sub { sql 'p.lang =', \$_ };
+f p => 3 => 'id', { vndbid => 'p' }, sql => sub { sql 'p.id', $_[0], \$_ };
+f p => 4 => 'type', { enum => \%PRODUCER_TYPE }, '=' => sub { sql 'p.type =', \$_ };
+f p => 80 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('p', 'p.id') };
+
+
+f g => 2 => 'id', { vndbid => 'g' }, sql => sub { sql 't.id', $_[0], \$_ };
+f g => 3 => 'category', { enum => \%TAG_CATEGORY }, '=' => sub { sql 't.cat =', \$_ };
+f g => 80 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('g', 't.id') };
+
+
+f i => 2 => 'id', { vndbid => 'i' }, sql => sub { sql 't.id', $_[0], \$_ };
+f i => 80 => 'search', { searchquery => 1 }, '=' => sub { $_->sql_where('i', 't.id') };
+
+
+
+# 'extlink' filter accepts the following values:
+# - $name - Whether the entry has a link of site $name
+# - [ $name, $val ] - Whether the entry has a link of site $name with the given $val
+# - "$name,$val" - Compact version of above (not really *compact* by any means, but this filter isn't common anyway)
+# - "http://..." - Auto-detect version of [$name,$val]
+# TODO: This only handles links defined in %LINKS, but it would be nice to also support links from Wikidata & PlayAsia.
+sub _extlink_filter {
+ my($type) = @_;
+ my $schema = (grep +($_->{dbentry_type}||'') eq $type, values VNDB::Schema::schema->%*)[0];
+ my %links = map {
+ my $n = $_;
+ my $l = $VNDB::ExtLinks::LINKS{$type}{$n};
+ my $s = (grep $_->{name} eq $n, $schema->{cols}->@*)[0];
+ (s/^l_//r, +{ %$l,
+ _col => $n,
+ _schema => $s,
+ _regex => $l->{regex} && VNDB::ExtLinks::full_regex($l->{regex}),
+ _hasval => $s->{type} =~ /\[\]/ ? "<> '{}'" : $s->{decl} !~ /not\s+null/i ? 'is not null' : $s->{type} =~ /^(big)?int/i ? '<> 0' : "<> ''"
+ })
+ } keys $VNDB::ExtLinks::LINKS{$type}->%*;
+
+ my sub _val {
+ return 1 if !ref $_[0] && $links{$_[0]}; # just $name
+ if(!ref $_[0] && $_[0] =~ /^https?:/) { # URL
+ for (keys %links) {
+ if($links{$_}{_regex} && $_[0] =~ $links{$_}{_regex}) {
+ $_[0] = [ $_, $1 ];
+ last;
+ }
+ }
+ return { msg => 'Unrecognized URL format' } if !ref $_[0];
+ }
+ $_[0] = [ split /,/, $_[0], 2 ] if !ref $_[0]; # compact $name,$val form
+
+ # normalized $name,$val form
+ return 0 if ref $_[0] ne 'ARRAY' || $_[0]->@* != 2 || ref $_[0][0] || ref $_[0][1] || !defined $_[0][1];
+ my $l = $links{$_[0][0]};
+ return { msg => "Unknown field '$_[0][0]'" } if !$l;
+ return { msg => "Invalid value '$_[0][1]'" } if $l->{_schema}{type} =~ /^int/i && ($_[0][1] !~ /^-?[0-9]+$/ || $_[0][1] >= (1<<31) || $_[0][1] <= -(1<<31));
+ return { msg => "Invalid value '$_[0][1]'" } if $l->{_schema}{type} =~ /^bigint/i && ($_[0][1] !~ /^-?[0-9]+$/ || $_[0][1] >= (1<<63) || $_[0][1] <= -(1<<63));
+ $_[0][1] *= 1 if $l->{_schema}{type} =~ /^(big)?int/i;
+ 1
+ }
+
+ my sub _sql {
+ return "$type.$links{$_}{_col} $links{$_}{_hasval}" if !ref; # just name
+ my($l, $v) = ($links{$_->[0]}, $_->[1]);
+ sql "$type.$l->{_col}", $l->{_schema}{type} =~ /\[\]/ ? ('&& ARRAY[', \$v, ']::', $l->{_schema}{type}) : ('=', \$v);
+ }
+ my sub _comp { ref $_ ? $_->[0].','.(my $x=$_->[1]) : $_ }
+ ({ type => 'any', func => \&_val }, '=' => \&_sql, compact => \&_comp)
+}
+
+
+# Accepts either:
+# - $tag
+# - [$tag, $exclude_lies*16*3 + int($minlevel*5)*3 + $maxspoil] (compact form)
+# - [$tag, $maxspoil, $minlevel]
+# - [$tag, $maxspoil, $minlevel, $exclude_lies]
+# Normalizes to the latter two.
+sub _validate_tag {
+ $_[0] = [$_[0],0,0] if ref $_[0] ne 'ARRAY'; # just a tag id
+ my $v = tuwf->compile({ vndbid => 'g' })->validate($_[0][0]);
+ return 0 if $v->err;
+ $_[0][0] = $v->data;
+ if($_[0]->@* == 2) { # compact form
+ return 0 if !defined $_[0][1] || ref $_[0][1] || $_[0][1] !~ /^[0-9]+$/;
+ ($_[0][1],$_[0][2],$_[0][3]) = ($_[0][1]%3, int($_[0][1]%(3*16)/3)/5, int($_[0][1]/3/16) == 1 ? 1 : 0);
+ }
+ # normalized form
+ return 0 if $_[0]->@* < 3 || $_[0]->@* > 4;
+ return 0 if !defined $_[0][1] || ref $_[0][1] || $_[0][1] !~ /^[0-2]$/;
+ return 0 if !defined $_[0][2] || ref $_[0][2] || $_[0][2] !~ /^(?:[0-2](?:\.[0-9]+)?|3(?:\.0+)?)$/;
+ $_[0][1] *= 1;
+ $_[0][2] *= 1;
+ if ($_[0]->@* == 4) {
+ return 0 if !defined $_[0][3] || ref $_[0][3] || $_[0][3] !~ /^[0-1]$/;
+ $_[0][3] *= 1;
+ pop $_[0]->@* if !$_[0][3];
+ }
+ 1
+}
+
+sub _compact_tag { my $id = ($_->[0] =~ s/^g//r)*1; $_->[1] == 0 && $_->[2] == 0 && !$_->[3] ? $id : [ $id, ($_->[3]?16*3:0) + int($_->[2]*5)*3 + $_->[1] ] }
+sub _compact_trait { my $id = ($_->[0] =~ s/^i//r)*1; $_->[1] == 0 && !$_->[2] ? $id : [ $id, ($_->[2]?3:0) + $_->[1] ] }
+
+# Accepts either:
+# - $trait
+# - [$trait, $exclude_lies*3 + $maxspoil] (compact form)
+# - [$trait, $maxspoil]
+# - [$trait, $maxspoil, $exclude_lies]
+# Normalizes to the latter two.
+sub _validate_trait {
+ $_[0] = [$_[0],0] if ref $_[0] ne 'ARRAY'; # just a trait id
+ my $v = tuwf->compile({ vndbid => 'i' })->validate($_[0][0]);
+ return 0 if $v->err;
+ $_[0][0] = $v->data;
+ return 0 if !defined $_[0][1] || ref $_[0][1] || $_[0][1] !~ /^[0-9]+$/;
+ ($_[0][1], $_[0][2]) = ($_[0][1]%3, int($_[0][1]/3) == 1 ? 1 : 0) if $_[0]->@* == 2;
+ return 0 if $_[0]->@* != 3;
+ return 0 if $_[0][1] > 2;
+ return 0 if !defined $_[0][2] || ref $_[0][2] || $_[0][2] !~ /^[01]$/;
+ $_[0][1] *= 1;
+ $_[0][2] *= 1;
+ pop $_[0]->@* if $_[0]->@* == 3 && !$_[0][2];
+ 1
+}
+
+
+# Accepts either $label or [$uid, $label]. Normalizes to the latter. $label=0 is used for 'Unlabeled'.
+sub _validate_label {
+ $_[0] = [tuwf->req->{advsearch_uid}||auth->uid(), $_[0]] if ref $_[0] ne 'ARRAY';
+ my $v = tuwf->compile({ vndbid => 'u' })->validate($_[0][0]);
+ return 0 if $v->err;
+ $_[0][0] = $v->data;
+ $_[0]->@* == 2 && defined $_[0][1] && !ref $_[0][1] && $_[0][1] =~ /^(?:0|[1-9][0-9]{0,5})$/
+}
+
+
+sub _validate {
+ my($t, $q) = @_;
+ return { msg => 'Invalid query' } if ref $q ne 'ARRAY' || @$q < 2 || !defined $q->[0] || ref $q->[0];
+
+ $q->[0] = $q->[0] == 0 ? 'and' : $q->[0] == 1 ? 'or'
+ : $NUMFIELDS{$t}{$q->[0]} // return { msg => 'Unknown field', field => $q->[0] }
+ if $q->[0] =~ /^[0-9]+$/;
+
+ # combinator
+ if($q->[0] eq 'and' || $q->[0] eq 'or') {
+ for(@$q[1..$#$q]) {
+ my $r = _validate($t, $_);
+ return $r if !$r || ref $r;
+ }
+ return 1;
+ }
+
+ # predicate
+ return { msg => 'Invalid predicate' } if @$q != 3 || !defined $q->[1] || ref $q->[1];
+ my $f = $FIELDS{$t}{$q->[0]};
+ return { msg => 'Unknown field', field => $q->[0] } if !$f;
+ return { msg => 'Invalid operator', field => $q->[0], op => $q->[1] } if !defined $ops{$q->[1]} || (!$f->{$q->[1]} && !$f->{sql});
+ return _validate($f->{value}, $q->[2]) if !ref $f->{value};
+ my $r = $f->{value}->validate($q->[2]);
+ return { msg => 'Invalid value', field => $q->[0], value => $q->[2], error => $r->err } if $r->err;
+ $q->[2] = $r->data;
+ 1
+}
+
+
+sub _validate_adv {
+ my $t = shift;
+ return { msg => 'Invalid JSON', error => $@ =~ s{[\s\r\n]* at /[^ ]+ line.*$}{}smr } if !ref $_[0] && $_[0] =~ /^\[/ && !eval { $_[0] = JSON::XS->new->decode($_[0]); 1 };
+ if(!ref $_[0]) {
+ my($v,$i) = ($_[0],0);
+ return { msg => 'Invalid compact encoded form', character_index => $i } if !($_[0] = _dec_query($v, \$i));
+ return { msg => 'Trailing garbage' } if $i != length $v;
+ }
+ if(ref $_[0] eq 'ARRAY' && $_[0]->@* == 0) {
+ $_[0] = bless {type=>$t}, __PACKAGE__;
+ return 1;
+ }
+ my $v = _validate($t, @_);
+ $_[0] = bless { type => $t, query => $_[0] }, __PACKAGE__ if $v;
+ $v
+}
+
+
+
+# 'advsearch' validation, accepts either a compact encoded string, JSON string or an already decoded array.
+TUWF::set('custom_validations')->{advsearch} = sub { my($t) = @_; +{ type => 'any', default => bless({type=>$t}, __PACKAGE__), func => sub { _validate_adv $t, @_ } } };
+
+# 'advsearch_err' validation; Same as the 'advsearch' validation except it never throws an error.
+# If the validation failed, this will log a warning and return an empty query that will cause elm_() to display a warning message.
+TUWF::set('custom_validations')->{advsearch_err} = sub {
+ my ($t) = @_;
+ +{ type => 'any', default => bless({type=>$t}, __PACKAGE__), func => sub {
+ my $r = _validate_adv $t, @_;
+ $_[0] = bless {type=>$t,error=>1}, __PACKAGE__ if !$r || ref $r eq 'HASH';
+ 1
+ } }
+};
+
+
+# "Canonicalize"/simplify a query (in Normalized JSON form):
+# - Merges nested and/or's where possible
+# - Removes duplicate filters where possible
+# - Sorts fields and values, for deterministic processing
+#
+# This function is unaware of the behavior of individual filters, so it can't
+# currently simplify a query like "(a < 10) and (a < 9)" into "a < 9".
+#
+# The returned query is suitable for generating SQL and comparison of different
+# queries, but should not be given to the Elm UI as it changes the way fields
+# are merged.
+sub _canon {
+ my($t, $q) = @_;
+ return [ $q->[0], $q->[1], _canon($_->{value}, $q->[2]) ] if (local $_ = $FIELDS{$t}{$q->[0]}) && !ref $_->{value};
+ return $q if $q->[0] ne 'or' && $q->[0] ne 'and';
+ my @l = map _canon($t, $_), @$q[1..$#$q];
+ @l = map $_->[0] eq $q->[0] ? @$_[1..$#$_] : $_, @l; # Merge nested and/or's
+ return $l[0] if @l == 1; # and/or with a single field -> flatten
+
+ sub _stringify { ref $_[0] ? join ':', map _stringify($_//''), $_[0]->@* : $_[0] }
+ my %l = map +(_stringify($_),$_), @l;
+ [ $q->[0], map $l{$_}, sort keys %l ]
+}
+
+
+# returns an sql_list function for tags
+sub _sql_where_tag {
+ my($table) = @_;
+ sub {
+ my($neg, $all, $val) = @_;
+ my %f; # spoiler -> rating -> lie -> list
+ my @l;
+ push $f{$_->[1]*1}{$_->[2]*1}{$_->[3]?1:''}->@*, $_->[0] for @$val;
+ for my $s (keys %f) {
+ for my $r (keys $f{$s}->%*) {
+ for my $l (keys $f{$s}{$r}->%*) {
+ push @l, sql_and
+ $s < 2 ? sql('spoiler <=', \$s) : (),
+ $r > 0 ? sql('rating >=', \$r) : (),
+ $l ? ('NOT lie') : (),
+ sql('tag IN', $f{$s}{$r}{$l});
+ }
+ }
+ }
+ sql 'v.id', $neg ? 'NOT' : (), 'IN(SELECT vid FROM', $table, 'WHERE', sql_or(@l), $all && @$val > 1 ? ('GROUP BY vid HAVING COUNT(tag) =', \scalar @$val) : (), ')'
+ }
+}
+
+sub _sql_where_trait {
+ my($table, $cid) = @_;
+ sub {
+ my($neg, $all, $val) = @_;
+ my %f; # spoiler -> list
+ my @l;
+ push $f{$_->[1]*1}{$_->[2]?1:''}->@*, $_->[0] for @$val;
+ for my $s (keys %f) {
+ for my $l (keys $f{$s}->%*) {
+ push @l, sql_and
+ $s < 2 ? sql('spoil <=', \$s) : (),
+ $l ? ('NOT lie') : (),
+ sql('tid IN', $f{$s}{$l});
+ }
+ }
+ sql 'c.id', $neg ? 'NOT' : (), 'IN(SELECT', $cid, 'FROM', $table, 'WHERE', sql_or(@l), $all && @$val > 1 ? ('GROUP BY', $cid, 'HAVING COUNT(tid) =', \scalar @$val) : (), ')'
+ }
+}
+
+
+# Assumption: All labels in a group are for the same uid and label==0 has its own group.
+sub _sql_where_label {
+ my($neg, $all, $val) = @_;
+ my $uid = $val->[0][0];
+ require VNWeb::ULists::Lib;
+ my $own = VNWeb::ULists::Lib::ulists_own($uid);
+ my @lbl = map $_->[1], @$val;
+
+ # Unlabeled
+ if($lbl[0] == 0) {
+ return '1=0' if !$own;
+ return sql $neg ? 'NOT' : (), 'EXISTS(SELECT 1 FROM ulist_vns WHERE vid = v.id AND uid =', \$uid, "AND labels IN('{}','{7}'))";
+ }
+
+ if(!$own) {
+ # Label 7 can always be queried, do a lookup for the rest.
+ tuwf->req->{lblvis}{$uid} ||= { 7, 1, map +($_->{id},1), tuwf->dbAlli('SELECT id FROM ulist_labels WHERE NOT private AND uid =', \$uid)->@* };
+ my $vis = tuwf->req->{lblvis}{$uid};
+ return $neg ? '1=1' : '1=0' if $all && grep !$vis->{$_}, @lbl; # AND query but one label is private -> no match
+ @lbl = grep $vis->{$_}, @lbl;
+ return $neg ? '1=1' : '1=0' if !@lbl; # All requested labels are private -> no match
+ }
+
+ sql 'v.id', $neg ? 'NOT' : (), 'IN(
+ SELECT vid
+ FROM ulist_vns
+ WHERE uid =', \$uid,
+ 'AND labels', $all ? '@>' : '&&', sql_array(@lbl), '::smallint[]',
+ $own ? () : 'AND NOT c_private',
+ ')'
+}
+
+
+sub _sql_where {
+ my($t, $q) = @_;
+
+ if($q->[0] eq 'and' || $q->[0] eq 'or') {
+ my %f; # For sql_list; field -> op -> group -> list of values
+ my @l; # Remaining non-batched queries
+ for my $cq (@$q[1..$#$q]) {
+ my $cf = $FIELDS{$t}{$cq->[0]};
+ my $grp = !$cf || !$cf->{sql_list} || ($cq->[1] ne '=' && $cq->[1] ne '!=') ? undef
+ : !$cf->{sql_list_grp} ? ''
+ : do { local $_ = $cq->[2]; $cf->{sql_list_grp}->($_) };
+ if(defined $grp) {
+ push $f{$cq->[0]}{$cq->[1]}{$grp}->@*, $cq->[2];
+ } else {
+ push @l, _sql_where($t, $cq);
+ }
+ }
+
+ for my $field (keys %f) {
+ for my $op (keys $f{$field}->%*) {
+ push @l, $FIELDS{$t}{$field}{sql_list}->(
+ $q->[0] eq 'and' ? ($op eq '=' ? (0, 1) : (1, 0)) : $op eq '=' ? (0, 0) : (1, 1),
+ $_
+ ) for values $f{$field}{$op}->%*;
+ }
+ }
+
+ return sql '(', ($q->[0] eq 'and' ? sql_and @l : sql_or @l), ')';
+ }
+
+ my $f = $FIELDS{$t}{$q->[0]};
+ my $func = $f->{$q->[1]} || $f->{sql};
+ local $_ = ref $f->{value} ? $q->[2] : do {
+ push @TYPE, $f->{value};
+ my $v = _sql_where($f->{value}, $q->[2]);
+ pop @TYPE;
+ $v;
+ };
+ sql '(', $func->($q->[1]), ')';
+}
+
+
+sub sql_where {
+ my($self) = @_;
+ @TYPE = ($self->{type});
+ $self->{query} ? _sql_where $self->{type}, _canon $self->{type}, $self->{query} : '1=1';
+}
+
+
+sub json { shift->{query} }
+
+
+sub _compact_json {
+ my($t, $q) = @_;
+ return [ $q->[0] eq 'and' ? 0 : 1, map _compact_json($t, $_), @$q[1..$#$q] ] if $q->[0] eq 'and' || $q->[0] eq 'or';
+
+ my $f = $FIELDS{$t}{$q->[0]};
+ [ int $f->{num}, $q->[1],
+ $f->{compact} ? do { local $_ = $q->[2]; $f->{compact}->($_) }
+ : !defined $q->[2] ? ''
+ : _is_tuple( $q->[2]) ? [ int($q->[2][0] =~ s/^[a-z]//rg), int($q->[2][1]) ]
+ : $f->{vndbid} ? int ($q->[2] =~ s/^$f->{vndbid}//rg)
+ : $f->{int} ? int $q->[2]
+ : ref $f->{value} ? "$q->[2]" : _compact_json($f->{value}, $q->[2])
+ ]
+}
+
+
+sub compact_json {
+ my($self) = @_;
+ $self->{compact} //= $self->{query} && _compact_json($self->{type}, $self->{query});
+ $self->{compact};
+}
+
+
+sub _extract_ids {
+ my($t,$q,$ids) = @_;
+ if($q->[0] eq 'and' || $q->[0] eq 'or') {
+ _extract_ids($t, $_, $ids) for @$q[1..$#$q];
+ } else {
+ my $f = $FIELDS{$t}{$q->[0]};
+ $ids->{$q->[2]} = 1 if $f->{vndbid};
+ $ids->{"anime$q->[2]"} = 1 if $q->[0] eq 'anime_id';
+ $ids->{$q->[2][0]} = 1 if ref $f->{value} && ref $q->[2] eq 'ARRAY'; # Ugly heuristic, may have false positives
+ _extract_ids($f->{value}, $q->[2], $ids) if !ref $f->{value};
+ }
+}
+
+
+# Returns a JSON object suitable for the AdvSearchQuery API response.
+sub elm_search_query {
+ my($self) = @_;
+
+ my(%o,%ids);
+ _extract_ids($self->{type}, $self->{query}, \%ids) if $self->{query};
+
+ $o{producers} = [ map +{id => $_}, grep /^p/, keys %ids ];
+ enrich_merge id => sql('SELECT id, title[1+1] AS name, title[1+1+1+1] AS altname FROM', VNWeb::TitlePrefs::producerst(), 'p WHERE id IN'), $o{producers};
+
+ $o{staff} = [ map +{id => $_}, grep /^s/, keys %ids ];
+ enrich_merge id => sql('SELECT id, lang, aid, title[1+1], title[1+1+1+1] AS alttitle FROM', VNWeb::TitlePrefs::staff_aliast(), 's WHERE aid = main AND id IN'), $o{staff};
+
+ $o{tags} = [ map +{id => $_}, grep /^g/, keys %ids ];
+ enrich_merge id => 'SELECT id, name, searchable, applicable, hidden, locked FROM tags WHERE id IN', $o{tags};
+
+ $o{traits} = [ map +{id => $_}, grep /^i/, keys %ids ];
+ enrich_merge id => 'SELECT t.id, t.name, t.searchable, t.applicable, t.defaultspoil, t.hidden, t.locked, g.id AS group_id, g.name AS group_name
+ FROM traits t LEFT JOIN traits g ON g.id = t.gid WHERE t.id IN', $o{traits};
+
+ $o{anime} = [ map +{id => $_=~s/^anime//rg}, grep /^anime/, keys %ids ];
+ enrich_merge id => 'SELECT id, title_romaji AS title, title_kanji AS original FROM anime WHERE id IN', $o{anime};
+
+ $o{qtype} = $self->{type};
+ $o{query} = $self->compact_json;
+ \%o
+}
+
+
+sub elm_ {
+ my($self, $count, $time) = @_;
+
+ # TODO: labels can be lazily loaded to reduce page weight
+ state $schema ||= tuwf->compile({ type => 'hash', keys => {
+ uid => { vndbid => 'u', default => undef },
+ labels => { aoh => { id => { uint => 1 }, label => {} } },
+ defaultSpoil => { uint => 1 },
+ saved => { aoh => { name => {}, query => {} } },
+ error => { anybool => 1 },
+ query => $VNWeb::Elm::apis{AdvSearchQuery}[0],
+ }});
+ VNWeb::HTML::elm_ 'AdvSearch.Main', $schema, {
+ uid => auth->uid,
+ labels => auth ? tuwf->dbAlli('SELECT id, label FROM ulist_labels WHERE uid =', \auth->uid, 'ORDER BY CASE WHEN id < 10 THEN id ELSE 10 END, label') : [],
+ defaultSpoil => auth->pref('spoilers')||0,
+ saved => auth ? tuwf->dbAlli('SELECT name, query FROM saved_queries WHERE uid =', \auth->uid, ' AND qtype =', \$self->{type}, 'ORDER BY name') : [],
+ error => $self->{error}?1:0,
+ query => $self->elm_search_query(),
+ };
+
+ if (@_ > 1) {
+ p_ class => 'center', sub {
+ input_ type => 'submit', value => 'Search';
+ txt_ sprintf ' %d result%s in %.3fs', $count, $count == 1 ? '' : 's', $time if defined $count;
+ };
+ div_ class => 'warning', sub {
+ h2_ 'ERROR: Query timed out.';
+ p_ q{
+ This usually happens when your combination of filters is too complex for the server to handle.
+ This may also happen when the server is overloaded with other work, but that's much less common.
+ You can adjust your filters or try again later.
+ };
+ } if !defined $count;
+ }
+}
+
+
+sub query_encode {
+ my($self) = @_;
+ return '' if !$self->{query};
+ $self->{query_encode} //= _enc_query $self->compact_json;
+ $self->{query_encode};
+}
+
+
+sub extract_searchquery {
+ my($self) = @_;
+ my $q = $self->{query};
+ return ($self) if !$q;
+ return (bless({type => $self->{type}}, __PACKAGE__), $q->[2]) if @$q == 3 && $q->[1] eq '=' && ref $q->[2] eq 'VNWeb::Validate::SearchQuery';
+ if($q->[0] eq 'and') {
+ my(@newq, $s);
+ for (@{$q}[1..$#$q]) {
+ if(@$_ == 3 && $_->[1] eq '=' && ref $_->[2] eq 'VNWeb::Validate::SearchQuery') {
+ return ($self) if $s;
+ $s = $_->[2];
+ } else {
+ push @newq, $_;
+ }
+ }
+ return (bless({type => $self->{type}, query => ['and',@newq]}, __PACKAGE__), $s) if $s;
+ }
+ return ($self);
+}
+
+
+# Returns the saved default query for the current user, or an empty query if none has been set.
+sub advsearch_default {
+ my($t) = @_;
+ if(auth) {
+ my $def = tuwf->dbVali('SELECT query FROM saved_queries WHERE qtype =', \$t, 'AND name = \'\' AND uid =', \auth->uid);
+ return tuwf->compile({ advsearch => $t })->validate($def)->data if $def;
+ }
+ bless {type=>$t}, __PACKAGE__;
+}
+
+1;
diff --git a/lib/VNWeb/Auth.pm b/lib/VNWeb/Auth.pm
index 35587c8d..442d46f4 100644
--- a/lib/VNWeb/Auth.pm
+++ b/lib/VNWeb/Auth.pm
@@ -7,7 +7,7 @@
# ..user is logged in
# }
#
-# my $success = auth->login($user, $pass);
+# my $success = auth->login($uid, $pass);
# auth->logout;
#
# my $uid = auth->uid;
@@ -23,39 +23,47 @@ use warnings;
use TUWF;
use Exporter 'import';
+use Carp 'croak';
use Digest::SHA qw|sha1 sha1_hex|;
use Crypt::URandom 'urandom';
use Crypt::ScryptKDF 'scrypt_raw';
-use Encode 'encode_utf8';
+use MIME::Base64 'encode_base64url';
+use POSIX 'strftime';
-use VNDBUtil 'norm_ip';
+use VNDB::Func 'norm_ip';
use VNDB::Config;
use VNWeb::DB;
our @EXPORT = ('auth');
-my $auth;
-sub auth { $auth }
-
-
-TUWF::hook before => sub {
- my $cookie = tuwf->reqCookie('auth')||'';
- my($uid, $token_e) = $cookie =~ /^([a-fA-F0-9]{40})\.?(\d+)$/ ? ($2, sha1_hex pack 'H*', $1) : (0, '');
-
- $auth = __PACKAGE__->new();
- $auth->_load_session($uid, $token_e);
- 1;
-};
-
-
-TUWF::hook after => sub { $auth = __PACKAGE__->new() };
+sub auth {
+ tuwf->req->{auth} ||= do {
+ my $auth = __PACKAGE__->new();
+ if(config->{read_only}) {
+ # Account functionality disabled in read-only mode.
+
+ # API requests have two authentication methods:
+ # - If the origin equals the site, use the same Cookie auth as the rest of the site (handy for userscripts)
+ # - Otherwise, a custom token-based auth, but this hasn't been implemented yet
+ } elsif(VNWeb::Validation::is_api() && (tuwf->reqHeader('Origin')//'_') ne config->{url}) {
+ # XXX: User prefs and permissions are not loaded in this case - they're not used.
+ $auth->_load_api2(tuwf->reqHeader('authorization'));
+
+ } else {
+ my $cookie = tuwf->reqCookie('auth')||'';
+ my($uid, $token_e) = $cookie =~ /^([a-fA-F0-9]{40})\.?u?(\d+)$/ ? ('u'.$2, sha1_hex pack 'H*', $1) : (0, '');
+ $auth->_load_session($uid, $token_e);
+ }
+ $auth
+ };
+}
# log user IDs (necessary for determining performance issues, user preferences
# have a lot of influence in this)
TUWF::set log_format => sub {
my(undef, $uri, $msg) = @_;
- sprintf "[%s] %s %s: %s\n", scalar localtime(), $uri, auth ? 'u'.auth->uid : '-', $msg;
+ sprintf "[%s UTC] %s %s: %s\n", strftime('%Y-%m-%d %H:%M:%S', gmtime), $uri, tuwf->req && tuwf->req->{auth} ? auth->uid : '-', $msg;
};
@@ -63,39 +71,37 @@ TUWF::set log_format => sub {
use overload bool => sub { defined shift->{user}{user_id} };
sub uid { shift->{user}{user_id} }
-sub perm { shift->{user}{perm}||0 }
sub user { shift->{user} }
sub token { shift->{token} }
+sub isMod { auth->permUsermod || auth->permDbmod || auth->permBoardmod || auth->permTagmod }
-# The 'perm' field is a bit field, with the following bits.
-# The 'usermod' flag is hardcoded in sql/func.sql for the user_* functions.
-# Flag 8 was used for 'staffedit', but is now free for re-use.
-# Flag 256 was used for 'affiliates', now also free.
-my %perms = qw{
- board 1
- boardmod 2
- edit 4
- tag 16
- dbmod 32
- tagmod 64
- usermod 128
-};
-
-sub defaultPerms { $perms{board} + $perms{edit} + $perms{tag} }
-sub allPerms { my $i = 0; $i |= $_ for values %perms; $i }
-sub listPerms { \%perms }
+my @perms = qw/board boardmod edit imgvote tag dbmod tagmod usermod review lengthvote/;
+sub listPerms { @perms }
# Create a read-only accessor to check if the current user is authorized to
# perform a particular action.
-for my $perm (keys %perms) {
+for my $perm (@perms) {
no strict 'refs';
- *{ "perm".ucfirst($perm) } = sub { (shift->perm() & $perms{$perm}) > 0 }
+ *{ 'perm'.ucfirst($perm) } = sub { shift->{user}{"perm_$perm"} }
}
+
+# Pref(erences) are like permissions, we load these columns eagerly so they can
+# be accessed through auth->pref().
+my @pref_columns = qw/
+ timezone skin customcss_csum titles
+ notify_dbedit notify_post notify_comment
+ tags_all tags_cont tags_ero tags_tech
+ spoilers traits_sexual max_sexual max_violence
+ tableopts_c tableopts_v tableopts_vt
+ nodistract_can nodistract_noads nodistract_nofancy
+/;
+
+
sub _randomascii {
return join '', map chr($_%92+33), unpack 'C*', urandom shift;
}
@@ -108,7 +114,8 @@ sub _preparepass {
my($self, $pass, $salt, $N, $r, $p) = @_;
($N, $r, $p) = @{$self->{scrypt_args}} if !$N;
$salt ||= urandom(8);
- unpack 'H*', pack 'NCCa8a*', $N, $r, $p, $salt, scrypt_raw(encode_utf8($pass), $self->{scrypt_salt} . $salt, $N, $r, $p, 32);
+ utf8::encode(my $utf8pass = $pass);
+ unpack 'H*', pack 'NCCa8a*', $N, $r, $p, $salt, scrypt_raw($utf8pass, $self->{scrypt_salt} . $salt, $N, $r, $p, 32);
}
@@ -125,23 +132,23 @@ sub _encpass {
# Arguments: self, uid, encpass
-# Returns: 0 on error, 1 on success
+# Returns: 0 on error, 1 on success, token on !pretend && deleted account
sub _create_session {
my($self, $uid, $encpass, $pretend) = @_;
my $token = urandom 20;
my $token_db = sha1_hex $token;
return 0 if !tuwf->dbVali('SELECT ',
- sql_func(user_login => \$uid, sql_fromhex($encpass), sql_fromhex $token_db)
+ sql_func(user_login => \$uid, \'web', sql_fromhex($encpass), sql_fromhex $token_db)
);
if($pretend) {
tuwf->dbExeci('SELECT', sql_func user_logout => \$uid, sql_fromhex $token_db);
+ return 1;
} else {
tuwf->resCookie(auth => unpack('H*', $token).'.'.$uid, httponly => 1, expires => time + 31536000);
- $self->_load_session($uid, $token_db);
+ return $self->_load_session($uid, $token_db) ? 1 : $token_db;
}
- return 1;
}
@@ -149,9 +156,13 @@ sub _load_session {
my($self, $uid, $token_db) = @_;
my $user = $uid ? tuwf->dbRowi(
- 'SELECT perm, ', sql_user(), ' FROM users u
- WHERE id = ', \$uid,
- 'AND', sql_func(user_isvalidsession => 'id', sql_fromhex($token_db), \'web')
+ 'SELECT ', sql_user(), ',', sql_comma(@pref_columns, map "perm_$_", @perms), '
+ FROM users u
+ JOIN users_shadow us ON us.id = u.id
+ JOIN users_prefs up ON up.id = u.id
+ WHERE u.id = ', \$uid, '
+ AND us.delete_at IS NULL
+ AND', sql_func(user_validate_session => 'u.id', sql_fromhex($token_db), \'web'), 'IS DISTINCT FROM NULL'
) : {};
# Drop the cookie if it's not valid
@@ -159,7 +170,7 @@ sub _load_session {
$self->{user} = $user;
$self->{token} = $token_db;
- delete $self->{pref};
+ $user->{user_id};
}
@@ -168,19 +179,17 @@ sub new {
scrypt_salt => config->{scrypt_salt}||die(),
scrypt_args => config->{scrypt_args}||[ 65536, 8, 1 ],
csrf_key => config->{form_salt}||die(),
+ user => {},
}, shift;
}
# Returns 1 on success, 0 on failure
-# When $pretend is true, it only tests if the user/pass combination is correct,
+# When $pretend is true, it only tests if the uid/pass combination is correct,
# but doesn't actually create a session.
sub login {
- my($self, $user, $pass, $pretend) = @_;
- return 0 if $self->uid || !$user || !$pass;
-
- my $uid = tuwf->dbVali('SELECT id FROM users WHERE username =', \$user);
- return 0 if !$uid;
+ my($self, $uid, $pass, $pretend) = @_;
+ return 0 if $self->uid || !$uid || !$pass;
my $encpass = $self->_encpass($uid, $pass);
return 0 if !$encpass;
$self->_create_session($uid, $encpass, $pretend);
@@ -195,24 +204,28 @@ sub logout {
}
+sub wasteTime {
+ my $self = shift;
+ $self->_preparepass(urandom(20));
+}
+
+
# Create a random token that can be used to reset the password.
-# Returns ($uid, $token) if the email address is found in the DB, () otherwise.
+# Returns ($uid, $email, $token) if the email address is found in the DB, () otherwise.
sub resetpass {
my(undef, $mail) = @_;
my $token = unpack 'H*', urandom(20);
- my $id = tuwf->dbVali(
- select => sql_func(user_resetpass => \$mail, sql_fromhex sha1_hex lc $token)
+ my $u = tuwf->dbRowi(
+ 'SELECT uid, mail FROM', sql_func(user_resetpass => \$mail, sql_fromhex sha1_hex lc $token), 'x(uid, mail)'
);
- return $id ? ($id, $token) : ();
+ return $u->{uid} ? ($u->{uid}, $u->{mail}, $token) : ();
}
# Checks if the password reset token is valid
sub isvalidtoken {
my(undef, $uid, $token) = @_;
- tuwf->dbVali(
- select => sql_func(user_isvalidsession => \$uid, sql_fromhex(sha1_hex lc $token), \'pass')
- );
+ tuwf->dbVali('SELECT', sql_func(user_validate_session => \$uid, sql_fromhex(sha1_hex lc $token), \'pass'), 'IS DISTINCT FROM NULL');
}
@@ -253,49 +266,139 @@ sub setmail_confirm {
# less secure). The key is only valid for the current hour, tokens for previous
# hours can be generated by passing a negative $hour_offset.
sub csrftoken {
- my($self, $hour_offset) = @_;
- sha1_hex sprintf '%s%s%d',
+ my($self, $hour_offset, $purpose) = @_;
+ # 6 bytes (8 characters in base64) gives 48 bits of security; That's
+ # not the 160 bits of a full sha1 hash, but still more than good enough
+ # to make random guesses impractical.
+ encode_base64url substr sha1(sprintf 'p=%s;k=%s;s=%s;t=%d;',
+ $purpose||'', # Purpose
$self->{csrf_key} || 'csrf-token', # Server secret
$self->{token} || norm_ip(tuwf->reqIP), # User secret
- (time/3600)+($hour_offset||0); # Time limitation
+ (time/3600)+($hour_offset||0) # Time limitation
+ ), 0, 6
}
# Returns 1 if the given CSRF token is still valid (meaning: created for this
# user within the past 12 hours), 0 otherwise.
sub csrfcheck {
- my($self, $token) = @_;
- $self->csrftoken($_) eq $token && return 1 for reverse -11..0;
+ my($self, $token, $purpose) = @_;
+ $self->csrftoken($_, $purpose) eq $token && return 1 for reverse -11..0;
return 0;
}
-# TODO: Measure global usage of the pref() and prefSet() calls to see if this cache is actually necessary.
-
-my @pref_columns = qw/
- email_confirmed skin customcss filter_vn filter_release show_nsfw notify_dbedit notify_announce
- vn_list_own vn_list_wish tags_all tags_cont tags_ero tags_tech spoilers traits_sexual
- nodistract_can nodistract_noads nodistract_nofancy
-/;
-
-# Returns a user preference column for the current user. Lazily loads all
-# preferences to speed of subsequent calls.
sub pref {
my($self, $key) = @_;
return undef if !$self->uid;
+ croak "Pref key not loaded: $key" if !exists $self->{user}{$key};
+ $self->{user}{$key};
+}
+
+
+# Mark any notifications for a particular item for the current user as read.
+# Arguments: $vndbid, $num||[@nums]||<missing>
+sub notiRead {
+ my($self, $id, $num) = @_;
+ tuwf->dbExeci('
+ UPDATE notifications SET read = NOW() WHERE read IS NULL AND uid =', \$self->uid, 'AND iid =', \$id,
+ @_ == 2 ? () : !defined $num ? 'AND num IS NULL' : !ref $num ? sql 'AND num =', \$num : sql 'AND num IN', $num
+ ) if $self->uid;
+}
+
+
+# Add an entry to the audit log.
+sub audit {
+ my($self, $affected_uid, $action, $detail) = @_;
+ tuwf->dbExeci('INSERT INTO audit_log', {
+ by_uid => $self->uid(),
+ by_name => $self->{user}{user_name},
+ by_ip => VNWeb::Validation::ipinfo(),
+ affected_uid => $affected_uid||undef,
+ affected_name => $affected_uid ? sql('(SELECT username FROM users WHERE id =', \$affected_uid, ')') : undef,
+ action => $action,
+ detail => $detail,
+ });
+}
+
+
+
+my $api2_alpha = "ybndrfg8ejkmcpqxot1uwisza345h769"; # z-base-32
+
+# Converts from hex to encoded form
+sub _api2_encode {
+ state %l = map +(substr(unpack('B*', chr $_), 3, 8), substr($api2_alpha, $_, 1)), 0..(length($api2_alpha)-1);
+ (unpack('B*', pack('H*', $_[0])) =~ s/(.....)/$l{$1}/erg)
+ =~ s/(....)(.....)(.....)(....)(.....)(.....)(....)/$1-$2-$3-$4-$5-$6-$7/r;
+}
+# Converts from encoded form to hex
+sub _api2_decode {
+ state %l = ('-', '', map +(substr($api2_alpha, $_, 1), substr unpack('B*', chr $_), 3, 8), 0..(length($api2_alpha)-1));
+ unpack 'H*', pack 'B*', $_[0] =~ s{(.)}{$l{$1} // return}erg
+}
+
+# Takes a UID, returns hex value
+sub _api2_gen_token {
+ # Scramble for cosmetic reasons. This bytewise scramble still leaves an obvious pattern, but w/e.
+ unpack 'H*', (pack('N', $_[0] =~ s/^u//r).urandom(16))
+ =~ s/^(.)(.)(.)(.)(..)(....)(....)(....)(..)$/$5$1$6$2$7$3$8$4$9/sr;
+}
+
+# Extract UID from hex-encoded token
+sub _api2_get_uid {
+ 'u'.unpack 'N', pack('H*', $_[0]) =~ s/^..(.)....(.)....(.)....(.)..$/$1$2$3$4/sr;
+}
- $self->{pref} ||= tuwf->dbRowi('SELECT', sql_comma(map "\"$_\"", @pref_columns), 'FROM users WHERE id =', \$self->uid);
- $self->{pref}{$key};
+
+sub _load_api2 {
+ my($self, $header) = @_;
+ return if !$header;
+ return VNWeb::API::err(401, 'Invalid Authorization header format.') if $header !~ /^(?i:Token) +([-$api2_alpha]+)$/;
+ my $token_enc = $1;
+ return VNWeb::API::err(401, 'Invalid token format.') if length($token_enc =~ s/-//rg) != 32 || !length(my $token = _api2_decode $token_enc);
+ my $uid = _api2_get_uid $token;
+ my $user = tuwf->dbRowi(
+ 'SELECT ', sql_user(), ', x.listread, x.listwrite
+ FROM users u, users_shadow us, ', sql_func(user_validate_session => \$uid, sql_fromhex($token), \'api2'), 'x
+ WHERE u.id = ', \$uid, 'AND x.uid = u.id AND us.id = u.id AND us.delete_at IS NULL'
+ );
+ return VNWeb::API::err(401, 'Invalid token.') if !$user->{user_id};
+ $self->{token} = $token;
+ $self->{user} = $user;
+ $self->{api2} = 1;
+}
+
+sub api2_tokens {
+ my($self, $uid) = @_;
+ return [] if !$self;
+ my $r = tuwf->dbAlli("
+ SELECT coalesce(notes, '') AS notes, listread, listwrite, added::date,", sql_tohex('token'), "AS token
+ , (CASE WHEN expires = added THEN '' ELSE expires::date::text END) AS lastused
+ FROM", sql_func(user_api2_tokens => \$uid, \$self->uid, sql_fromhex($self->{token})), '
+ ORDER BY added');
+ $_->{token} = _api2_encode($_->{token}) for @$r;
+ $r;
}
+sub api2_set_token {
+ my($self, $uid, %o) = @_;
+ return if !auth;
+ my $token = $o{token} ? _api2_decode($o{token}) : _api2_gen_token($uid);
+ tuwf->dbExeci(select => sql_func user_api2_set_token => \$uid, \$self->uid, sql_fromhex($self->{token}),
+ sql_fromhex($token), \$o{notes}, \($o{listread}//0), \($o{listwrite}//0));
+ _api2_encode($token);
+}
-sub prefSet {
- my($self, $key, $value, $uid) = @_;
- die "Unknown pref key: $_" if !grep $key eq $_, @pref_columns;
- $uid //= $self->uid;
- $self->{pref}{$key} = $value;
- tuwf->dbExeci(qq{UPDATE users SET "$key" =}, \$value, 'WHERE id =', \$self->uid);
+sub api2_del_token {
+ my($self, $uid, $token) = @_;
+ return if !$self;
+ tuwf->dbExeci(select => sql_func user_api2_del_token => \$uid, \$self->uid, sql_fromhex($self->{token}), sql_fromhex(_api2_decode($token)));
}
+# API-specific permission checks
+# (Always return true for cookie-based auth)
+sub api2Listread { $_[0]{user}{user_id} && (!$_[1] || $_[0]{user}{user_id} eq $_[1]) && (!$_[0]{api2} || $_[0]{user}{listread}) }
+sub api2Listwrite { $_[0]{user}{user_id} && (!$_[1] || $_[0]{user}{user_id} eq $_[1]) && (!$_[0]{api2} || $_[0]{user}{listwrite}) }
+
1;
diff --git a/lib/VNWeb/Chars/Edit.pm b/lib/VNWeb/Chars/Edit.pm
new file mode 100644
index 00000000..5927ccaf
--- /dev/null
+++ b/lib/VNWeb/Chars/Edit.pm
@@ -0,0 +1,163 @@
+package VNWeb::Chars::Edit;
+
+use VNWeb::Prelude;
+use VNWeb::Images::Lib 'enrich_image';
+use VNWeb::Releases::Lib;
+
+
+my $FORM = {
+ id => { default => undef, vndbid => 'c' },
+ name => { sl => 1, maxlength => 200 },
+ latin => { default => undef, sl => 1, maxlength => 200 },
+ alias => { default => '', maxlength => 500 },
+ description=> { default => '', maxlength => 5000 },
+ gender => { default => 'unknown', enum => \%GENDER },
+ spoil_gender=>{ default => undef, enum => \%GENDER },
+ b_month => { default => 0, uint => 1, range => [ 0, 12 ] },
+ b_day => { default => 0, uint => 1, range => [ 0, 31 ] },
+ age => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ s_bust => { default => 0, uint => 1, range => [ 0, 32767 ] },
+ s_waist => { default => 0, uint => 1, range => [ 0, 32767 ] },
+ s_hip => { default => 0, uint => 1, range => [ 0, 32767 ] },
+ height => { default => 0, uint => 1, range => [ 0, 32767 ] },
+ weight => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ bloodt => { default => 'unknown', enum => \%BLOOD_TYPE },
+ cup_size => { default => '', enum => \%CUP_SIZE },
+ main => { default => undef, vndbid => 'c' },
+ main_spoil => { uint => 1, range => [0,2] },
+ main_ref => { _when => 'out', anybool => 1 },
+ main_name => { _when => 'out', default => '' },
+ image => { default => undef, vndbid => 'ch' },
+ image_info => { _when => 'out', default => undef, type => 'hash', keys => $VNWeb::Elm::apis{ImageResult}[0]{aoh} },
+ traits => { sort_keys => 'id', aoh => {
+ tid => { vndbid => 'i' },
+ spoil => { uint => 1, range => [0,2] },
+ lie => { anybool => 1 },
+ name => { _when => 'out' },
+ group => { _when => 'out', default => undef },
+ hidden => { _when => 'out', anybool => 1 },
+ locked => { _when => 'out', anybool => 1 },
+ applicable => { _when => 'out', anybool => 1 },
+ new => { _when => 'out', anybool => 1 },
+ } },
+ vns => { sort_keys => ['vid', 'rid'], aoh => {
+ vid => { vndbid => 'v' },
+ rid => { vndbid => 'r', default => undef },
+ spoil => { uint => 1, range => [0,2] },
+ role => { enum => \%CHAR_ROLE },
+ title => { _when => 'out' },
+ } },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+
+ authmod => { _when => 'out', anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+ releases => { _when => 'out', aoh => {
+ id => { vndbid => 'r' },
+ rels => $VNWeb::Elm::apis{Releases}[0]
+ } },
+};
+
+my $FORM_OUT = form_compile out => $FORM;
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_CMP = form_compile cmp => $FORM;
+
+
+TUWF::get qr{/$RE{crev}/(?<action>edit|copy)} => sub {
+ my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound;
+ my $copy = tuwf->capture('action') eq 'copy';
+ return tuwf->resDenied if !can_edit c => $copy ? {} : $e;
+
+ $e->{main_name} = $e->{main} ? tuwf->dbVali('SELECT title[1+1] FROM', charst, 'c WHERE id =', \$e->{main}) : '';
+ $e->{main_ref} = tuwf->dbVali('SELECT 1 FROM chars WHERE main =', \$e->{id})||0;
+
+ enrich_merge tid => sql(
+ 'SELECT t.id AS tid, t.name, t.hidden, t.locked, t.applicable, g.name AS group, g.gorder AS order, false AS new
+ FROM traits t
+ LEFT JOIN traits g ON g.id = t.gid
+ WHERE', $copy ? 'NOT t.hidden AND t.applicable AND' : (), 't.id IN'), $e->{traits};
+ $e->{traits} = [ sort { ($a->{order}//99) <=> ($b->{order}//99) || $a->{name} cmp $b->{name} } grep !$copy || $_->{applicable}, $e->{traits}->@* ];
+
+ enrich_merge vid => sql('SELECT id AS vid, title[1+1] AS title, sorttitle FROM', vnt, 'v WHERE id IN'), $e->{vns};
+ $e->{vns} = [ sort { $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{vid}, $b->{vid}) || idcmp($a->{rid}||'r0', $b->{rid}||'r0') } $e->{vns}->@* ];
+
+ my %vns;
+ $e->{releases} = [ map !$vns{$_->{vid}}++ ? { id => $_->{vid}, rels => releases_by_vn $_->{vid} } : (), $e->{vns}->@* ];
+
+ if($e->{image}) {
+ $e->{image_info} = { id => $e->{image} };
+ enrich_image 0, [$e->{image_info}];
+ } else {
+ $e->{image_info} = undef;
+ }
+
+ $e->{authmod} = auth->permDbmod;
+ $e->{editsum} = $copy ? "Copied from $e->{id}.$e->{chrev}" : $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}";
+
+ my $title = ($copy ? 'Copy ' : 'Edit ').dbobj($e->{id})->{title}[1];
+ framework_ title => $title, dbobj => $e, tab => tuwf->capture('action'),
+ sub {
+ editmsg_ c => $e, $title, $copy;
+ elm_ CharEdit => $FORM_OUT, $copy ? {%$e, id=>undef} : $e;
+ };
+};
+
+
+TUWF::get qr{/$RE{vid}/addchar}, sub {
+ return tuwf->resDenied if !can_edit c => undef;
+ my $v = tuwf->dbRowi('SELECT id, title[1+1] AS title FROM', vnt, 'v WHERE NOT hidden AND id =', \tuwf->capture('id'));
+ return tuwf->resNotFound if !$v->{id};
+
+ my $e = elm_empty($FORM_OUT);
+ $e->{vns} = [{ vid => $v->{id}, title => $v->{title}, rid => undef, spoil => 0, role => 'primary' }];
+ $e->{releases} = [{ id => $v->{id}, rels => releases_by_vn $v->{id} }];
+
+ framework_ title => 'Add character',
+ sub {
+ editmsg_ c => undef, 'Add character';
+ elm_ CharEdit => $FORM_OUT, $e;
+ };
+};
+
+
+elm_api CharEdit => $FORM_OUT, $FORM_IN, sub {
+ my $data = shift;
+ my $new = !$data->{id};
+ my $e = $new ? {} : db_entry $data->{id} or return tuwf->resNotFound;
+ return elm_Unauth if !can_edit c => $e;
+
+ if(!auth->permDbmod) {
+ $data->{hidden} = $e->{hidden}||0;
+ $data->{locked} = $e->{locked}||0;
+ }
+ $data->{description} = bb_subst_links $data->{description};
+ $data->{b_day} = 0 if !$data->{b_month};
+
+ $data->{main} = undef if $data->{hidden};
+ die "Attempt to set main to self" if $data->{main} && $e->{id} && $data->{main} eq $e->{id};
+ die "Attempt to set main while this character is already referenced." if $data->{main} && tuwf->dbVali('SELECT 1 AS ref FROM chars WHERE main =', \$e->{id});
+ # It's possible that the referenced character has been deleted since it was added as main, so don't die() on this one, just unset main.
+ $data->{main} = undef if $data->{main} && !tuwf->dbVali('SELECT 1 FROM chars WHERE NOT hidden AND main IS NULL AND id =', \$data->{main});
+ $data->{main_spoil} = 0 if !$data->{main};
+
+ validate_dbid 'SELECT id FROM images WHERE id IN', $data->{image} if $data->{image};
+
+ # Allow non-applicable or non-approved traits only when they were already applied to this character.
+ validate_dbid
+ sql('SELECT id FROM traits t WHERE ((NOT hidden AND applicable) OR EXISTS(SELECT 1 FROM chars_traits ct WHERE ct.tid = t.id AND ct.id =', \$e->{id}, ')) AND id IN'),
+ map $_->{tid}, $data->{traits}->@*;
+
+ validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, $data->{vns}->@*;
+ # XXX: This will also die when the release has been moved to a different VN
+ # and the char hasn't been updated yet. Would be nice to give a better
+ # error message in that case.
+ for($data->{vns}->@*) {
+ die "Bad release for $_->{vid}: $_->{rid}\n" if defined $_->{rid} && !tuwf->dbVali('SELECT 1 FROM releases_vn WHERE id =', \$_->{rid}, 'AND vid =', \$_->{vid});
+ }
+
+ return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e;
+ my $ch = db_edit c => $e->{id}, $data;
+ elm_Redirect "/$ch->{nitemid}.$ch->{nrev}";
+};
+
+1;
diff --git a/lib/VNWeb/Chars/Elm.pm b/lib/VNWeb/Chars/Elm.pm
new file mode 100644
index 00000000..ad8d723c
--- /dev/null
+++ b/lib/VNWeb/Chars/Elm.pm
@@ -0,0 +1,23 @@
+package VNWeb::Chars::Elm;
+
+use VNWeb::Prelude;
+
+elm_api Chars => undef, { search => { searchquery => 1 } }, sub {
+ my $q = shift->{search};
+
+ my $l = $q ? tuwf->dbPagei({ results => 15, page => 1 },
+ 'SELECT c.id, c.title[1+1] AS title, c.title[1+1+1+1] AS alttitle, c.main, cm.title[1+1] AS main_title, cm.title[1+1+1+1] AS main_alttitle
+ FROM', charst, 'c', $q->sql_join('c', 'c.id'), '
+ LEFT JOIN', charst, 'cm ON cm.id = c.main
+ WHERE NOT c.hidden
+ ORDER BY sc.score DESC, c.sorttitle
+ ') : [];
+ for (@$l) {
+ $_->{main} = { id => $_->{main}, title => $_->{main_title}, alttitle => $_->{main_alttitle} } if $_->{main};
+ delete $_->{main_title};
+ delete $_->{main_alttitle};
+ }
+ elm_CharResult $l;
+};
+
+1;
diff --git a/lib/VNWeb/Chars/List.pm b/lib/VNWeb/Chars/List.pm
new file mode 100644
index 00000000..87172f4a
--- /dev/null
+++ b/lib/VNWeb/Chars/List.pm
@@ -0,0 +1,146 @@
+package VNWeb::Chars::List;
+
+use VNWeb::Prelude;
+use VNWeb::AdvSearch;
+use VNWeb::Filters;
+use VNWeb::Images::Lib;
+
+our $TABLEOPTS = tableopts
+ _pref => 'tableopts_c',
+ _views => [qw|rows cards grid|];
+
+
+# Also used by VNWeb::TT::TraitPage
+sub listing_ {
+ my($opt, $list, $count) = @_;
+
+ my sub url { '?'.query_encode %$opt, @_ }
+ paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 't', $opt->{s};
+
+ article_ class => 'browse charb', sub {
+ table_ class => 'stripe', sub {
+ tr_ sub {
+ td_ class => 'tc1', sub {
+ abbr_ class => "icon-gen-$_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown';
+ };
+ td_ class => 'tc2', sub {
+ a_ href => "/$_->{id}", tattr $_;
+ small_ sub {
+ join_ ', ', sub { a_ href => "/$_->{id}", tattr $_ }, $_->{vn}->@*;
+ };
+ };
+ } for @$list;
+ }
+ } if $opt->{s}->rows;
+
+ article_ class => 'charbcard', sub {
+ my($w,$h) = (90,120);
+ div_ sub {
+ div_ sub {
+ if($_->{image}) {
+ my($iw,$ih) = imgsize $_->{image}{width}*100, $_->{image}{height}*100, $w, $h;
+ image_ $_->{image}, alt => $_->{title}[1], width => $iw, height => $ih, url => "/$_->{id}", overlay => undef;
+ } else {
+ txt_ 'no image';
+ }
+ };
+ div_ sub {
+ abbr_ class => "icon-gen-$_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown';
+ a_ href => "/$_->{id}", tattr $_;
+ br_;
+ small_ sub {
+ join_ ', ', sub { a_ href => "/$_->{id}", tattr $_ }, $_->{vn}->@*;
+ };
+ };
+ } for @$list;
+ } if $opt->{s}->cards;
+
+
+ article_ class => 'charbgrid', sub {
+ a_ href => "/$_->{id}", title => $_->{title}[3],
+ !$_->{image} || image_hidden($_->{image}) ? () : (style => 'background-image: url("'.imgurl($_->{image}{id}).'")'),
+ sub {
+ span_ $_->{title}[1];
+ } for @$list;
+ } if $opt->{s}->grid;
+
+ paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 'b';
+}
+
+
+# Also used by VNWeb::TT::TraitPage
+sub enrich_listing {
+ enrich vn => id => cid => sub { sql '
+ SELECT DISTINCT cv.id AS cid, v.id, v.title, v.sorttitle
+ FROM chars_vns cv
+ JOIN', vnt, 'v ON v.id = cv.vid
+ WHERE NOT v.hidden AND cv.spoil = 0 AND cv.id IN', $_, '
+ ORDER BY v.sorttitle'
+ }, @_;
+}
+
+
+TUWF::get qr{/c(?:/(?<char>all|[a-z0]))?}, sub {
+ my $opt = tuwf->validate(get =>
+ q => { searchquery => 1 },
+ p => { upage => 1 },
+ f => { advsearch_err => 'c' },
+ ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } },
+ fil=>{ onerror => '' },
+ s => { tableopts => $TABLEOPTS },
+ )->data;
+ $opt->{ch} = $opt->{ch}[0];
+
+ # compat with old URLs
+ my $oldch = tuwf->capture('char');
+ $opt->{ch} //= $oldch if defined $oldch && $oldch ne 'all';
+
+ # URL compatibility with old filters
+ if(!$opt->{f}->{query} && $opt->{fil}) {
+ my $q = eval {
+ my $f = filter_char_adv filter_parse c => $opt->{fil};
+ tuwf->compile({ advsearch => 'c' })->validate(@$f > 1 ? $f : undef)->data;
+ };
+ return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q;
+ }
+
+ $opt->{f} = advsearch_default 'c' if !$opt->{f}{query} && !defined tuwf->reqGet('f');
+
+ my $where = sql_and
+ 'NOT c.hidden', $opt->{f}->sql_where(),
+ defined($opt->{ch}) ? sql 'match_firstchar(c.sorttitle, ', \$opt->{ch}, ')' : ();
+
+ my $time = time;
+ my($count, $list);
+ db_maytimeout {
+ $count = tuwf->dbVali('SELECT count(*) FROM', charst, 'c WHERE', sql_and $where, $opt->{q}->sql_where('c', 'c.id'));
+ $list = $count ? tuwf->dbPagei({results => $opt->{s}->results(), page => $opt->{p}}, '
+ SELECT c.id, c.title, c.gender, c.image
+ FROM', charst, 'c', $opt->{q}->sql_join('c', 'c.id'), '
+ WHERE', $where, '
+ ORDER BY', $opt->{q} ? 'sc.score DESC, ' : (), 'c.sorttitle, c.id'
+ ) : [];
+ } || (($count, $list) = (undef, []));
+
+ enrich_listing $list;
+ enrich_image_obj image => $list if !$opt->{s}->rows;
+ $time = time - $time;
+
+ framework_ title => 'Browse characters', sub {
+ form_ action => '/c', method => 'get', sub {
+ article_ sub {
+ h1_ 'Browse characters';
+ searchbox_ c => $opt->{q}//'';
+ p_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'ch', value => ($_//''), ($_//'') eq ($opt->{ch}//'') ? (class => 'optselected') : (), !defined $_ ? 'ALL' : $_ ? uc $_ : '#'
+ for (undef, 'a'..'z', 0);
+ };
+ input_ type => 'hidden', name => 'ch', value => $opt->{ch}//'';
+ $opt->{f}->elm_($count, $time);
+ };
+ listing_ $opt, $list, $count if $count;
+ }
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Chars/Page.pm b/lib/VNWeb/Chars/Page.pm
index b8d5ad4a..e6ffc7e7 100644
--- a/lib/VNWeb/Chars/Page.pm
+++ b/lib/VNWeb/Chars/Page.pm
@@ -1,124 +1,170 @@
package VNWeb::Chars::Page;
use VNWeb::Prelude;
+use VNWeb::Images::Lib qw/image_ enrich_image_obj/;
sub enrich_seiyuu {
my($vid, @chars) = @_;
enrich seiyuu => id => cid => sub { sql '
- SELECT DISTINCT vs.cid, sa.id, sa.name, sa.original, vs.note
+ SELECT DISTINCT vs.cid, sa.id, sa.title, sa.sorttitle, vs.note
FROM vn_seiyuu vs
- JOIN staff_alias sa ON sa.aid = vs.aid
- WHERE vs.cid IN', $_, $vid ? ('AND vs.id =', \$vid) : (), '
- ORDER BY sa.name'
+ ', $vid ? () : ('JOIN vn v ON v.id = vs.id'), '
+ JOIN', staff_aliast, 'sa ON sa.aid = vs.aid
+ WHERE ', $vid ? ('vs.id =', \$vid) : ('NOT v.hidden'), 'AND vs.cid IN', $_, '
+ ORDER BY sa.sorttitle'
}, @chars;
}
+sub sql_trait_overrides {
+ sql '(
+ WITH RECURSIVE trait_overrides (tid, spoil, color, childs, lvl) AS (
+ SELECT tid, spoil, color, childs, 0 FROM users_prefs_traits WHERE id =', \auth->uid, '
+ UNION ALL
+ SELECT tp.id, x.spoil, x.color, true, lvl+1
+ FROM trait_overrides x
+ JOIN traits_parents tp ON tp.parent = x.tid
+ WHERE x.childs
+ ) SELECT DISTINCT ON(tid) tid, spoil, color FROM trait_overrides ORDER BY tid, lvl
+ )';
+}
sub enrich_item {
my($c) = @_;
- enrich_merge vid => 'SELECT id AS vid, title, original FROM vn WHERE id IN', $c->{vns};
- enrich_merge rid => 'SELECT id AS rid, title AS rtitle, original AS roriginal FROM releases WHERE id IN', grep $_->{rid}, $c->{vns}->@*;
- enrich_merge tid =>
- 'SELECT t.id AS tid, t.name, t.sexual, coalesce(g.id, t.id) AS group, coalesce(g.name, t.name) AS groupname, coalesce(g.order,0) AS order
- FROM traits t LEFT JOIN traits g ON t.group = g.id WHERE t.id IN', $c->{traits};
-
- $c->{vns} = [ sort { $a->{title} cmp $b->{title} || $a->{vid} <=> $b->{vid} || ($a->{rid}||999999) <=> ($b->{rid}||999999) } $c->{vns}->@* ];
+ enrich_image_obj image => $c;
+ enrich_merge vid => sql('SELECT id AS vid, title, sorttitle, c_released AS vn_released FROM', vnt, 'v WHERE id IN'), $c->{vns};
+ enrich_merge rid => sql('SELECT id AS rid, title AS rtitle, released AS rel_released FROM', releasest, 'r WHERE id IN'), grep $_->{rid}, $c->{vns}->@*;
+
+ # Even with trait overrides, we'll want to see the raw data in revision diffs,
+ # so fetch the raw spoil as a separate column and do filtering/processing later.
+ enrich_merge tid => sub { sql '
+ SELECT t.id AS tid, t.name, t.hidden, t.locked, t.applicable, t.sexual, x.spoil AS override, x.color
+ , coalesce(g.id, t.id) AS group, coalesce(g.name, t.name) AS groupname, coalesce(g.gorder,0) AS order
+ FROM traits t
+ LEFT JOIN traits g ON t.gid = g.id
+ LEFT JOIN', sql_trait_overrides(), 'x ON x.tid = t.id
+ WHERE t.id IN', $_
+ }, $c->{traits};
+
+ $c->{vns} = [ sort { $a->{vn_released} <=> $b->{vn_released} || ($a->{rel_released}||0) <=> ($b->{rel_released}||0)
+ || $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{vid}, $b->{vid}) || idcmp($a->{rid}||'r999999', $b->{rid}||'r999999') } $c->{vns}->@* ];
$c->{traits} = [ sort { $a->{order} <=> $b->{order} || $a->{groupname} cmp $b->{groupname} || $a->{name} cmp $b->{name} } $c->{traits}->@* ];
+
+ $c->{quotes} = tuwf->dbAlli('
+ SELECT q.vid, q.id, q.score, q.quote,', sql_totime('q.added'), 'AS added, q.addedby
+ FROM quotes q
+ WHERE NOT q.hidden AND vid IN', [map $_->{vid}, $c->{vns}->@*], 'AND q.cid =', \$c->{id}, '
+ ORDER BY q.score DESC, q.quote
+ ');
+ enrich_merge id => sql('SELECT id, vote FROM quotes_votes WHERE uid =', \auth->uid, 'AND id IN'), $c->{quotes} if auth;
}
# Fetch multiple character entries with a format suitable for chartable_()
+# Also used by Chars::VNTab.
sub fetch_chars {
my($vid, $where) = @_;
my $l = tuwf->dbAlli('
- SELECT id, name, original, alias, "desc", gender, b_month, b_day, s_bust, s_waist, s_hip, height, weight, bloodt, cup_size, age, image
- FROM chars WHERE NOT hidden AND (', $where, ')'
- );
+ SELECT id, title, alias, description, gender, spoil_gender, b_month, b_day, s_bust, s_waist, s_hip, height, weight, bloodt, cup_size, age, image
+ FROM', charst, 'c WHERE NOT hidden AND (', $where, ')
+ ORDER BY sorttitle
+ ');
enrich vns => id => id => sub { sql '
- SELECT cv.id, cv.vid, cv.rid, cv.spoil, cv.role, v.title, v.original, r.title AS rtitle, r.original AS roriginal
+ SELECT cv.id, cv.vid, cv.rid, cv.spoil, cv.role, v.title, r.title AS rtitle
FROM chars_vns cv
- JOIN vn v ON v.id = cv.vid
- LEFT JOIN releases r ON r.id = cv.rid
+ JOIN', vnt, 'v ON v.id = cv.vid
+ LEFT JOIN', releasest, 'r ON r.id = cv.rid
WHERE cv.id IN', $_, $vid ? ('AND cv.vid =', \$vid) : (), '
- ORDER BY v.title, cv.vid, cv.rid NULLS LAST'
+ ORDER BY v.c_released, r.released, v.sorttitle, cv.vid, cv.rid NULLS LAST'
}, $l;
enrich traits => id => id => sub { sql '
- SELECT ct.id, ct.tid, ct.spoil, t.name, t.sexual, coalesce(g.id, t.id) AS group, coalesce(g.name, t.name) AS groupname, coalesce(g.order,0) AS order
+ SELECT ct.id, ct.tid, ct.spoil, x.spoil AS override, x.color, ct.lie, t.name, t.hidden, t.locked, t.sexual
+ , coalesce(g.id, t.id) AS group, coalesce(g.name, t.name) AS groupname, coalesce(g.gorder,0) AS order
FROM chars_traits ct
JOIN traits t ON t.id = ct.tid
- LEFT JOIN traits g ON t.group = g.id
- WHERE ct.id IN', $_, '
- ORDER BY g.order NULLS FIRST, coalesce(g.name, t.name), t.name'
+ LEFT JOIN traits g ON t.gid = g.id
+ LEFT JOIN', sql_trait_overrides(), 'x ON x.tid = ct.tid
+ WHERE x.spoil IS DISTINCT FROM 1+1+1 AND ct.id IN', $_, '
+ ORDER BY g.gorder NULLS FIRST, coalesce(g.name, t.name), t.name'
}, $l;
enrich_seiyuu $vid, $l;
+ enrich_image_obj image => $l;
$l
}
sub _rev_ {
my($c) = @_;
- revision_ c => $c, \&enrich_item,
+ revision_ $c, \&enrich_item,
[ name => 'Name' ],
- [ original => 'Original name' ],
+ [ latin => 'Name (latin)' ],
[ alias => 'Aliases' ],
- [ desc => 'Description' ],
+ [ description=> 'Description' ],
[ gender => 'Sex', fmt => \%GENDER ],
+ [ spoil_gender=> 'Sex (spoiler)',fmt => \%GENDER ],
[ b_month => 'Birthday/month',empty => 0 ],
[ b_day => 'Birthday/day', empty => 0 ],
[ s_bust => 'Bust', empty => 0 ],
[ s_waist => 'Waist', empty => 0 ],
- [ s_hip => 'Hip', empty => 0 ],
+ [ s_hip => 'Hips', empty => 0 ],
[ height => 'Height', empty => 0 ],
[ weight => 'Weight', ],
[ bloodt => 'Blood type', fmt => \%BLOOD_TYPE ],
[ cup_size => 'Cup size', fmt => \%CUP_SIZE ],
- [ age => 'Age', empty => 0 ],
- [ main => 'Main character',empty => 0, fmt => sub {
- my $c = tuwf->dbRowi('SELECT id, name, original FROM chars WHERE id =', \$_);
- a_ href => "/c$c->{id}", title => $c->{name}, "c$c->{id}"
+ [ age => 'Age', ],
+ [ main => 'Instance of', empty => 0, fmt => sub {
+ my $c = tuwf->dbRowi('SELECT id, title FROM', charst, 'c WHERE id =', \$_);
+ a_ href => "/$c->{id}", title => $c->{title}[1], $c->{id}
} ],
[ main_spoil => 'Spoiler', fmt => sub { txt_ fmtspoil $_ } ],
- [ image => 'Image', empty => 0, fmt => sub { img_ src => tuwf->imgurl(ch => $_) } ],
+ [ image => 'Image', fmt => sub { image_ $_ } ],
[ vns => 'Visual novels', fmt => sub {
- a_ href => "/v$_->{vid}", title => $_->{original}||$_->{title}, "v$_->{vid}";
+ a_ href => "/$_->{vid}", tlang(@{$_->{title}}[0,1]), title => $_->{title}[1], $_->{vid};
if($_->{rid}) {
- txt_ ' ['; a_ href => "/r$_->{rid}", "r$_->{rid}"; txt_ ']';
+ txt_ ' ['; a_ href => "/$_->{rid}", $_->{rid}; txt_ ']';
}
txt_ " $CHAR_ROLE{$_->{role}}{txt} (".fmtspoil($_->{spoil}).')';
} ],
[ traits => 'Traits', fmt => sub {
- b_ class => 'grayedout', "$_->{groupname} / " if $_->{group} != $_->{tid};
- a_ href => "/i$_->{tid}", $_->{name};
- txt_ ' ('.fmtspoil($_->{spoil}).')';
+ small_ "$_->{groupname} / " if $_->{group} ne $_->{tid};
+ a_ href => "/$_->{tid}", $_->{name};
+ txt_ ' ('.fmtspoil($_->{spoil}).($_->{lie} ? ', lie':'').')';
+ b_ ' (awaiting moderation)' if $_->{hidden} && !$_->{locked};
+ b_ ' (trait deleted)' if $_->{hidden} && $_->{locked};
+ b_ ' (not applicable)' if !$_->{applicable};
} ],
}
-# TODO: Also to be used by the character listing on VN pages; But it's not
-# currently compatible with VNDB::Handler::VNPage because that uses a different
-# spoiler hiding mechanism.
+# Also used by Chars::VNTab
sub chartable_ {
my($c, $link, $sep, $vn) = @_;
my $view = viewget;
+ my @visvns = grep $_->{spoil} <= $view->{spoilers}, $c->{vns}->@*;
+
div_ mkclass(chardetails => 1, charsep => $sep), sub {
- div_ class => 'charimg', sub {
- p_ 'No image uploaded yet' if !$c->{image};
- img_ src => tuwf->imgurl(ch => $c->{image}), alt => $c->{name} if $c->{image};
- };
+ div_ class => 'charimg', sub { image_ $c->{image}, alt => $c->{title}[1] };
table_ class => 'stripe', sub {
thead_ sub { tr_ sub { td_ colspan => 2, sub {
$link
- ? a_ href => "/c$c->{id}", style => 'margin-right: 10px; font-weight: bold', $c->{name}
- : b_ style => 'margin-right: 10px', $c->{name};
- b_ class => 'grayedout', style => 'margin-right: 10px', $c->{original} if $c->{original};
- abbr_ class => "icons gen $c->{gender}", title => $GENDER{$c->{gender}}, '' if $c->{gender} ne 'unknown';
+ ? a_ href => "/$c->{id}", style => 'margin-right: 10px; font-weight: bold', tlang($c->{title}[0], $c->{title}[1]), $c->{title}[1]
+ : span_ style => 'margin-right: 10px', tlang($c->{title}[0], $c->{title}[1]), $c->{title}[1];
+ small_ style => 'margin-right: 10px', tlang($c->{title}[2], $c->{title}[3]), $c->{title}[3] if $c->{title}[3] ne $c->{title}[1];
+ abbr_ class => "icon-gen-$c->{gender}", title => $GENDER{$c->{gender}}, '' if $c->{gender} ne 'unknown';
+ if($view->{spoilers} == 2 && defined $c->{spoil_gender}) {
+ txt_ '(';
+ abbr_ class => "icon-gen-$c->{spoil_gender}", title => $GENDER{$c->{spoil_gender}}, '' if $c->{spoil_gender} ne 'unknown';
+ txt_ 'unknown' if $c->{spoil_gender} eq 'unknown';
+ spoil_ 2;
+ txt_ ')';
+ }
span_ $BLOOD_TYPE{$c->{bloodt}} if $c->{bloodt} ne 'unknown';
+ debug_ $c;
}}};
tr_ sub {
@@ -147,22 +193,28 @@ sub chartable_ {
} if defined $c->{age};
my @groups;
- for(grep $_->{spoil} <= $view->{spoilers} && (!$_->{sexual} || $view->{traits_sexual}), $c->{traits}->@*) {
- push @groups, $_ if !@groups || $groups[$#groups]{group} != $_->{group};
+ for(grep !$_->{hidden} && ($_->{override}//$_->{spoil}) <= $view->{spoilers} && (!$_->{sexual} || $view->{traits_sexual}), $c->{traits}->@*) {
+ push @groups, $_ if !@groups || $groups[$#groups]{group} ne $_->{group};
push $groups[$#groups]{traits}->@*, $_;
}
- tr_ sub {
- td_ class => 'key', sub { a_ href => "/i$_->{group}", $_->{groupname} };
- td_ sub { join_ ', ', sub { a_ href => "/i$_->{tid}", $_->{name} }, $_->{traits}->@* };
+ tr_ class => "trait_group_$_->{group}", sub {
+ td_ class => 'key', sub { a_ href => "/$_->{group}", $_->{groupname} };
+ td_ sub { join_ ', ', sub {
+ a_ href => "/$_->{tid}", mkclass(
+ $_->{color} ? ($_->{color}, $_->{color} =~ /standout|grayedout/ ? 1 : 0) : (),
+ lie => $_->{lie} && (($_->{override}//1) <= 0 || $view->{spoilers} >= 2),
+ ), ($_->{color}//'') =~ /^#/ ? (style => "color: $_->{color}") : (),
+ $_->{name};
+ spoil_ $_->{spoil};
+ }, $_->{traits}->@* };
} for @groups;
- my @visvns = grep $_->{spoil} <= $view->{spoilers}, $c->{vns}->@*;
tr_ sub {
td_ class => 'key', $vn ? 'Releases' : 'Visual novels';
td_ sub {
my @vns;
for(@visvns) {
- push @vns, $_ if !@vns || $vns[$#vns]{vid} != $_->{vid};
+ push @vns, $_ if !@vns || $vns[$#vns]{vid} ne $_->{vid};
push $vns[$#vns]{rels}->@*, $_;
}
join_ \&br_, sub {
@@ -170,20 +222,22 @@ sub chartable_ {
# Just a VN link, no releases
if(!$vn && $v->{rels}->@* == 1 && !$v->{rels}[0]{rid}) {
txt_ $CHAR_ROLE{$v->{role}}{txt}.' - ';
- a_ href => "/v$v->{vid}", title => $v->{original}||$v->{title}, $v->{title};
+ a_ href => "/$v->{vid}", tattr $v;
+ spoil_ $v->{spoil};
# With releases
} else {
- a_ href => "/v$v->{vid}", title => $v->{original}||$v->{title}, $v->{title} if !$vn;
+ a_ href => "/$v->{vid}", tattr $v if !$vn;
br_ if !$vn;
join_ \&br_, sub {
- b_ class => 'grayedout', '> ';
- txt_ $CHAR_ROLE{$v->{role}}{txt}.' - ';
+ small_ '> ';
+ txt_ $CHAR_ROLE{$_->{role}}{txt}.' - ';
if($_->{rid}) {
- b_ class => 'grayedout', "r$_->{rid}:";
- a_ href => "/r$_->{rid}", title => $_->{roriginal}||$_->{rtitle}, $_->{rtitle};
+ small_ "$_->{rid}:";
+ a_ href => "/$_->{rid}", tattr $_->{rtitle};
} else {
txt_ 'All other releases';
}
+ spoil_ $_->{spoil};
}, $v->{rels}->@*;
}
}, @vns;
@@ -194,7 +248,7 @@ sub chartable_ {
td_ class => 'key', 'Voiced by';
td_ sub {
join_ \&br_, sub {
- a_ href => "/s$_->{id}", title => $_->{original}||$_->{name}, $_->{name};
+ a_ href => "/$_->{id}", tattr $_;
txt_ " ($_->{note})" if $_->{note};
}, $c->{seiyuu}->@*;
};
@@ -203,17 +257,30 @@ sub chartable_ {
tr_ class => 'nostripe', sub {
td_ colspan => 2, class => 'chardesc', sub {
h2_ 'Description';
- p_ sub { lit_ bb2html $c->{desc}, 0, $view->{spoilers} == 2 ? 3 : 2 };
+ p_ sub { lit_ bb_format $c->{description}, replacespoil => $view->{spoilers} != 2, keepspoil => $view->{spoilers} == 2 };
};
- } if $c->{desc};
+ } if $c->{description};
+
};
};
clearfloat_;
+
+ my %visvns = map +($_->{vid}, 1), @visvns;
+ my @quotes = grep $visvns{$_->{vid}}, $c->{quotes}->@*;
+ div_ class => 'charquotes', sub {
+ h2_ 'Quotes';
+ table_ sub {
+ tr_ sub {
+ td_ sub { VNWeb::VN::Quotes::votething_($_) };
+ td_ $_->{quote};
+ } for @quotes;
+ };
+ } if @quotes;
}
TUWF::get qr{/$RE{crev}} => sub {
- my $c = db_entry c => tuwf->capture('id'), tuwf->capture('rev');
+ my $c = db_entry tuwf->captures('id','rev');
return tuwf->resNotFound if !$c;
enrich_item $c;
@@ -231,35 +298,39 @@ TUWF::get qr{/$RE{crev}} => sub {
my $max_spoil = max(
$inst_maxspoil||0,
- (map $_->{spoil}, $c->{traits}->@*),
- $c->{desc} =~ /\[spoiler\]/i ? 2 : 0, # crude
+ (map $_->{override}//($_->{lie}?2:$_->{spoil}), grep !$_->{hidden} && !(($_->{override}//0) == 3), $c->{traits}->@*),
+ (map $_->{spoil}, $c->{vns}->@*),
+ defined $c->{spoil_gender} ? 2 : 0,
+ $c->{description} =~ /\[spoiler\]/i ? 2 : 0, # crude
);
# Only display the sexual traits toggle when there are sexual traits within the current spoiler level.
- my $has_sex = grep $_->{spoil} <= $view->{spoilers} && $_->{sexual}, map $_->{traits}->@*, $c, @$inst;
+ my $has_sex = grep !$_->{hidden} && $_->{sexual} && ($_->{override}//$_->{spoil}) <= $view->{spoilers}, map $_->{traits}->@*, $c, @$inst;
- framework_ title => $c->{name}, index => !tuwf->capture('rev'), type => 'c', dbobj => $c, hiddenmsg => 1,
+ $c->{title} = titleprefs_swap tuwf->dbVali('SELECT c_lang FROM chars WHERE id =', \$c->{id}), @{$c}{qw/ name latin /};
+ framework_ title => $c->{title}[1], index => !tuwf->capture('rev'), dbobj => $c, hiddenmsg => 1,
og => {
- description => bb2text $c->{desc}
+ description => bb_format($c->{description}, text => 1),
+ image => $c->{image} && $c->{image}{votecount} && !$c->{image}{sexual} && !$c->{image}{violence} ? imgurl($c->{image}{id}) : undef,
},
sub {
_rev_ $c if tuwf->capture('rev');
- div_ class => 'mainbox', sub {
- itemmsg_ c => $c;
- p_ class => 'mainopts', sub {
+ article_ sub {
+ itemmsg_ $c;
+ h1_ tlang(@{$c->{title}}[0,1]), $c->{title}[1];
+ h2_ class => 'alttitle', tlang(@{$c->{title}}[2,3]), $c->{title}[3] if $c->{title}[3] && $c->{title}[3] ne $c->{title}[1];
+ p_ class => 'chardetailopts', sub {
if($max_spoil) {
- a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0), 'Hide spoilers';
- a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1), 'Show minor spoilers';
- a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2), 'Spoil me!' if $max_spoil == 2;
+ a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0, traits_sexual => $view->{traits_sexual}), 'Hide spoilers';
+ a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1, traits_sexual => $view->{traits_sexual}), 'Show minor spoilers';
+ a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2, traits_sexual => $view->{traits_sexual}), 'Spoil me!' if $max_spoil == 2;
}
- b_ class => 'grayedout', ' | ' if $has_sex && $max_spoil;
- a_ mkclass(checked => $view->{traits_sexual}), href => '?view='.viewset(traits_sexual=>!$view->{traits_sexual}), 'Show sexual traits' if $has_sex;
+ small_ ' | ' if $has_sex && $max_spoil;
+ a_ mkclass(checked => $view->{traits_sexual}), href => '?view='.viewset(spoilers => $view->{spoilers}, traits_sexual=>!$view->{traits_sexual}), 'Show sexual traits' if $has_sex;
};
- h1_ sub { txt_ $c->{name}; debug_ $c };
- h2_ class => 'alttitle', $c->{original} if length $c->{original};
chartable_ $c;
};
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ 'Other instances';
chartable_ $_, 1, $_ != $inst->[0] for @$inst;
} if @$inst;
diff --git a/lib/VNWeb/Chars/VNTab.pm b/lib/VNWeb/Chars/VNTab.pm
new file mode 100644
index 00000000..bea983a6
--- /dev/null
+++ b/lib/VNWeb/Chars/VNTab.pm
@@ -0,0 +1,68 @@
+package VNWeb::Chars::VNTab;
+
+use VNWeb::Prelude;
+
+sub chars_ {
+ my($v) = @_;
+ my $view = viewget;
+ my $chars = VNWeb::Chars::Page::fetch_chars($v->{id}, sql('id IN(SELECT id FROM chars_vns WHERE vid =', \$v->{id}, ')'));
+ return if !@$chars;
+
+ my $max_spoil = max(
+ map max(
+ (map $_->{override}//($_->{lie}?2:$_->{spoil}), grep !$_->{hidden} && !(($_->{override}//0) == 3), $_->{traits}->@*),
+ (map $_->{spoil}, $_->{vns}->@*),
+ defined $_->{spoil_gender} ? 2 : 0,
+ $_->{description} =~ /\[spoiler\]/i ? 2 : 0,
+ ), @$chars
+ );
+ $chars = [ grep +grep($_->{spoil} <= $view->{spoilers}, $_->{vns}->@*), @$chars ];
+ my $has_sex = grep !$_->{hidden} && $_->{sexual} && ($_->{override}//$_->{spoil}) <= $view->{spoilers}, map $_->{traits}->@*, @$chars;
+
+ my sub opts_ {
+ p_ class => 'mainopts', sub {
+ debug_ $chars;
+ if($max_spoil) {
+ a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0,traits_sexual=>$view->{traits_sexual}).'#chars', 'Hide spoilers';
+ a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1,traits_sexual=>$view->{traits_sexual}).'#chars', 'Show minor spoilers';
+ a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2,traits_sexual=>$view->{traits_sexual}).'#chars', 'Spoil me!' if $max_spoil == 2;
+ }
+ small_ ' | ' if $has_sex && $max_spoil;
+ a_ mkclass(checked => $view->{traits_sexual}), href => '?view='.viewset(spoilers=>$view->{spoilers},traits_sexual=>!$view->{traits_sexual}).'#chars', 'Show sexual traits' if $has_sex;
+ };
+ }
+
+ my %done;
+ my $first = 0;
+ for my $r (keys %CHAR_ROLE) {
+ my @c = grep grep($_->{role} eq $r, $_->{vns}->@*) && !$done{$_->{id}}++, @$chars;
+ next if !@c;
+ article_ sub {
+ opts_ if !$first++;
+ h1_ $CHAR_ROLE{$r}{ @c > 1 ? 'plural' : 'txt' };
+ VNWeb::Chars::Page::chartable_($_, 1, $_ != $c[0], 1) for @c;
+ }
+ }
+
+ article_ sub {
+ opts_;
+ h1_ '(Characters hidden by spoiler settings)';
+ } if !$first;
+}
+
+
+TUWF::get qr{/$RE{vid}/chars}, sub {
+ my $v = db_entry tuwf->capture('id');
+ return tuwf->resNotFound if !$v;
+
+ VNWeb::VN::Page::enrich_vn($v);
+
+ framework_ title => $v->{title}[1], index => 1, dbobj => $v, hiddenmsg => 1,
+ sub {
+ VNWeb::VN::Page::infobox_($v);
+ VNWeb::VN::Page::tabs_($v, 'chars');
+ chars_ $v;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/DB.pm b/lib/VNWeb/DB.pm
index 30018c96..7eae6db8 100644
--- a/lib/VNWeb/DB.pm
+++ b/lib/VNWeb/DB.pm
@@ -10,9 +10,10 @@ use VNDB::Schema;
our @EXPORT = qw/
sql
- sql_identifier sql_join sql_comma sql_and sql_or sql_array sql_func sql_fromhex sql_tohex sql_fromtime sql_totime sql_user
- enrich enrich_merge enrich_flatten
- db_entry db_edit
+ global_settings
+ sql_join sql_comma sql_and sql_or sql_array sql_func sql_fromhex sql_tohex sql_fromtime sql_totime sql_like sql_user
+ enrich enrich_merge enrich_flatten enrich_obj
+ db_maytimeout db_entry db_edit
/;
@@ -25,7 +26,9 @@ our @EXPORT = qw/
# (and who'd put effort into escaping strings when placeholders are easier?).
sub interp_warn {
my @r = sql_interp @_;
- carp "Possible SQL injection in '$r[0]'" if tuwf->debug && $r[0] =~ /[2-9](?<!r18)/; # 0 and 1 aren't interesting, "SELECT 1" is a common pattern and so is "x > 0"
+ # 0 and 1 aren't interesting, "SELECT 1" is a common pattern and so is "x > 0".
+ # '{7}' is commonly used in ulist filtering and r18/api2 are a valid database identifiers.
+ carp "Possible SQL injection in '$r[0]'" if tuwf->debug && ($r[0] =~ s/(?:r18|\{7\}|api2)//rg) =~ /[2-9]/;
return @r;
}
@@ -45,13 +48,6 @@ $Carp::Internal{ (__PACKAGE__) }++;
# sql_* are macros for SQL::Interp use
-# A table, column or function name
-sub sql_identifier($) {
- carp "Invalid identifier '$_[0]'" if $_[0] !~ /^[a-z_][a-z0-9_]*$/; # This regex is specific to VNDB
- $_[0] =~ /^(?:desc|group|order)$/ ? qq{"$_[0]"} : $_[0]
-}
-
-
# join(), but for sql objects.
sub sql_join {
my $sep = shift;
@@ -72,7 +68,7 @@ sub sql_array { 'ARRAY[', sql_join(',', map \$_, @_), ']' }
# Call an SQL function
sub sql_func {
my($funcname, @args) = @_;
- sql sql_identifier($funcname), '(', sql_comma(@args), ')';
+ sql $funcname, '(', sql_comma(@args), ')';
}
# Convert a Perl hex value into Postgres bytea
@@ -95,11 +91,16 @@ sub sql_totime($) {
sql "extract('epoch' from ", $_[0], ')';
}
+# Escape a string to be used as a literal match in a LIKE pattern.
+sub sql_like($) {
+ $_[0] =~ s/([%_\\])/\\$1/rg
+}
+
# Returns a list of column names to fetch for displaying a username with HTML::user_().
# Arguments: Name of the 'users' table (default: 'u'), prefix for the fetched fields (default: 'user_').
# (This function returns a plain string so that old non-SQL-Interp functions can also use it)
sub sql_user {
- my $tbl = sql_identifier(shift||'u');
+ my $tbl = shift||'u';
my $prefix = shift||'user_';
join ', ',
"$tbl.id as ${prefix}id",
@@ -107,7 +108,17 @@ sub sql_user {
"$tbl.support_can as ${prefix}support_can",
"$tbl.support_enabled as ${prefix}support_enabled",
"$tbl.uniname_can as ${prefix}uniname_can",
- "$tbl.uniname as ${prefix}uniname";
+ "$tbl.uniname as ${prefix}uniname",
+ tuwf->req->{auth} && VNWeb::Auth::auth()->isMod ? (
+ "$tbl.perm_board as ${prefix}perm_board",
+ "$tbl.perm_edit as ${prefix}perm_edit"
+ ) : (),
+}
+
+
+# Returns a (potentially cached) version of the global_settings table.
+sub global_settings {
+ tuwf->req->{global_settings} //= tuwf->dbRowi('SELECT * FROM global_settings');
}
@@ -119,18 +130,21 @@ sub sql_user {
#
# enrich $name, $key, $merge_col, $sql, @objects;
#
-# Add a $name field each item in @objects,
+# Add a $name field to each item in @objects,
# Its value is a (possibly empty) array of hashes with data from $sql,
#
# enrich_flatten $name, $key, $merge_col, $sql, @objects;
#
-# Add a $name field each item in @objects,
+# Add a $name field to each item in @objects,
# Its value is a (possibly empty) array of values from a single column from $sql,
#
# enrich_merge $key, $sql, @objects;
#
# Merge all columns returned by $sql into @objects;
#
+# enrich_obj $key, $merge_col, $sql, @objects;
+#
+# Replace all non-undef $key fields in @objects with an object returned by $sql.
#
# Arguments:
#
@@ -157,7 +171,7 @@ sub _enrich {
@array = map +(ref $_ eq 'ARRAY' ? @$_ : $_), @array;
# Create a list of unique identifiers to fetch, do nothing if there's nothing to fetch
- my %ids = map +($_->{$key},1), @array;
+ my %ids = map defined($_->{$key}) ? ($_->{$key},1) : (), @array;
return if !keys %ids;
# Fetch the data
@@ -201,6 +215,35 @@ sub enrich_flatten {
}
+sub enrich_obj {
+ my($key, $merge_col, $sql, @array) = @_;
+ _enrich sub {
+ my($data, $array) = @_;
+ my %ids = map +($_->{$merge_col}, $_), @$data;
+ $_->{$key} = defined $_->{$key} ? $ids{ $_->{$key} } : undef for @$array;
+ }, $key, $sql, @array;
+}
+
+
+
+# Run the given subroutine inside a savepoint and capture an SQL timeout.
+# Returns false and logs a warning on timeout.
+sub db_maytimeout(&) {
+ my($f) = @_;
+ tuwf->dbh->pg_savepoint('maytimeout');
+ my $r = eval { $f->(); 1 };
+
+ if(!$r && $@ =~ /canceling statement due to statement timeout/) {
+ tuwf->dbh->pg_rollback_to('maytimeout');
+ warn "Query timed out\n";
+ return 0;
+ }
+ carp $@ if !$r;
+ tuwf->dbh->pg_release('maytimeout');
+ 1;
+}
+
+
# Database entry API: Intended to provide a low-level read/write interface for
# versioned database entires. The same data structure is used for reading and
@@ -239,45 +282,35 @@ my $entry_types = do {
# id, chid, chrev, maxrev, hidden, locked, entry_hidden, entry_locked
#
# (Ordering of arrays is unspecified)
-#
-# TODO:
-# - Use non _hist tables if $maxrev == $rev (should be faster)
-# - Combine the enrich_merge() calls into a single query.
-# - Fixed ordering of arrays (use primary keys)
sub db_entry {
- my($type, $id, $rev) = @_;
- my $t = $entry_types->{$type}||die;
-
- my $maxrev = tuwf->dbVali('SELECT MAX(rev) FROM changes WHERE type =', \$type, ' AND itemid =', \$id);
- return undef if !$maxrev;
- $rev ||= $maxrev;
- my $entry = tuwf->dbRowi(q{
- SELECT itemid AS id, id AS chid, rev AS chrev, ihid AS hidden, ilock AS locked
- FROM changes
- WHERE}, { type => $type, itemid => $id, rev => $rev }
+ my($id, $rev) = @_;
+ my $t = $entry_types->{ substr $id, 0, 1 }||die;
+
+ my $entry = tuwf->dbRowi('
+ WITH maxrev (iid, maxrev) AS (SELECT itemid, MAX(rev) FROM changes WHERE itemid =', \$id, 'GROUP BY itemid)
+ , lastrev (entry_hidden, entry_locked) AS (SELECT ihid, ilock FROM maxrev, changes WHERE itemid = iid AND rev = maxrev)
+ SELECT itemid AS id, id AS chid, rev AS chrev, ihid AS hidden, ilock AS locked, maxrev, entry_hidden, entry_locked
+ FROM changes, maxrev, lastrev
+ WHERE itemid = iid AND rev = ', $rev ? \$rev : 'maxrev'
);
return undef if !$entry->{id};
- $entry->{maxrev} = $maxrev;
- if($maxrev == $rev) {
- $entry->{entry_hidden} = $entry->{hidden};
- $entry->{entry_locked} = $entry->{locked};
- } else {
- my $base = $t->{base}{name} =~ s/_hist$//r;
- enrich_merge id => sql('SELECT id, hidden AS entry_hidden, locked AS entry_locked FROM', sql_identifier($base), 'WHERE id IN'), $entry;
+ # Fetch data from the main entry tables if rev == maxrev, from the _hist
+ # tables otherwise. This should improve caching a bit.
+ my sub data_table {
+ $entry->{chrev} == $entry->{maxrev} ? sql $_[0] =~ s/_hist$//r, 'WHERE id =', \$id
+ : sql $_[0], 'WHERE chid =', \$entry->{chid}
}
- enrich_merge chid => sql(
- SELECT => sql_comma(map sql_identifier($_->{name}), $t->{base}{cols}->@*),
- FROM => sql_identifier($t->{base}{name}),
- 'WHERE chid IN'
- ), $entry;
+ %$entry = (%$entry, tuwf->dbRowi(
+ SELECT => sql_comma(map $_->{name}, grep $_->{name} ne 'chid', $t->{base}{cols}->@*),
+ FROM => data_table $t->{base}{name}
+ )->%*);
while(my($name, $tbl) = each $t->{tables}->%*) {
$entry->{$name} = tuwf->dbAlli(
- SELECT => sql_comma(map sql_identifier($_->{name}), grep $_->{name} ne 'chid', $tbl->{cols}->@*),
- FROM => sql_identifier($tbl->{name}),
- WHERE => { chid => $entry->{chid} }
+ SELECT => sql_comma(map $_->{name}, grep $_->{name} ne 'chid', $tbl->{cols}->@*),
+ FROM => data_table($tbl->{name}),
);
}
$entry
@@ -298,38 +331,43 @@ sub db_edit {
$id ||= undef;
my $t = $entry_types->{$type}||die;
- tuwf->dbExeci("SELECT edit_${type}_init(", \$id, ', (SELECT MAX(rev) FROM changes WHERE type = ', \$type, ' AND itemid = ', \$id, '))');
+ tuwf->dbExeci("SELECT edit_${type}_init(", \$id, ', (SELECT MAX(rev) FROM changes WHERE itemid = ', \$id, '))');
tuwf->dbExeci('UPDATE edit_revision SET', {
requester => $uid // scalar VNWeb::Auth::auth()->uid(),
- ip => scalar tuwf->reqIP(),
comments => $data->{editsum},
ihid => $data->{hidden},
ilock => $data->{locked},
});
+ # Array columns need special care; SQL::Interp and DBD::Pg don't like them
+ # as single bind params and Postgres can't infer their type.
+ my sub val {
+ my($v, $col) = @_;
+ ref $v ? (sql_array(@$v), '::'.$col->{type}) : \$v
+ }
+
{
my $base = $t->{base}{name} =~ s/_hist$//r;
tuwf->dbExeci("UPDATE edit_${base} SET ", sql_comma(
- map sql(sql_identifier($_->{name}), ' = ', \$data->{$_->{name}}),
- grep exists $data->{$_->{name}}, $t->{base}{cols}->@*
+ map sql($_->{name}, ' = ', val $data->{$_->{name}}, $_),
+ grep $_->{name} ne 'chid' && exists $data->{$_->{name}}, $t->{base}{cols}->@*
));
}
while(my($name, $tbl) = each $t->{tables}->%*) {
my $base = $tbl->{name} =~ s/_hist$//r;
- my @colnames = grep $_ ne 'chid', map $_->{name}, $tbl->{cols}->@*;
- my @cols = sql_comma(map sql_identifier($_), @colnames);
+ my @cols = grep $_->{name} ne 'chid', $tbl->{cols}->@*;
+ my @colnames = sql_comma(map $_->{name}, @cols);
my @rows = map {
my $d = $_;
- sql '(', sql_comma(map \$d->{$_}, @colnames), ')'
+ sql '(', sql_comma(map val($d->{$_->{name}}, $_), @cols), ')'
} $data->{$name}->@*;
tuwf->dbExeci("DELETE FROM edit_${base}");
- tuwf->dbExeci("INSERT INTO edit_${base} (", @cols, ') VALUES ', sql_comma @rows) if @rows;
+ tuwf->dbExeci("INSERT INTO edit_${base} (", @colnames, ') VALUES ', sql_comma @rows) if @rows;
}
- my $r = tuwf->dbRow("SELECT * FROM edit_${type}_commit()");
- ($r->{itemid}, $r->{chid}, $r->{rev})
+ tuwf->dbRow("SELECT * FROM edit_${type}_commit()");
}
1;
diff --git a/lib/VNWeb/Discussions/Board.pm b/lib/VNWeb/Discussions/Board.pm
index edce6789..9fa9e304 100644
--- a/lib/VNWeb/Discussions/Board.pm
+++ b/lib/VNWeb/Discussions/Board.pm
@@ -5,23 +5,22 @@ use VNWeb::Discussions::Lib;
TUWF::get qr{/t/(all|$BOARD_RE)}, sub {
- my($type, $id) = tuwf->capture(1) =~ /^([^0-9]+)([0-9]*)$/;
+ my $id = tuwf->capture(1);
+ my($type) = $id =~ /^([^0-9]+)/;
+ $id = undef if $id !~ /[0-9]$/;
my $page = tuwf->validate(get => p => { upage => 1 })->data;
- my $obj = !$id ? undef :
- $type eq 'v' ? tuwf->dbRowi('SELECT id, title, original, hidden AS entry_hidden, locked AS entry_locked FROM vn WHERE id =', \$id) :
- $type eq 'p' ? tuwf->dbRowi('SELECT id, name, original, hidden AS entry_hidden, locked AS entry_locked FROM producers WHERE id =', \$id) :
- $type eq 'u' ? tuwf->dbRowi('SELECT id,', sql_user(), 'FROM users u WHERE id =', \$id) : undef;
+ my $obj = $id ? dbobj $id : undef;
return tuwf->resNotFound if $id && !$obj->{id};
+ return tuwf->resNotFound if $id && $id =~ /^u/ && $obj->{entry_hidden} && !auth->isMod;
- my $ititle = $obj && ($obj->{title} || $obj->{name} || user_displayname $obj);
- my $title = $obj ? "Related discussions for $ititle" : $type eq 'all' ? 'All boards' : $BOARD_TYPE{$type}{txt};
- my $createurl = '/t/'.($id ? $type.$id : $type eq 'db' ? 'db' : 'ge').'/new';
+ my $title = $obj ? "Related discussions for $obj->{title}[1]" : $type eq 'all' ? 'All boards' : $BOARD_TYPE{$type}{txt};
+ my $createurl = '/t/'.($id || ($type eq 'db' ? 'db' : 'ge')).'/new';
- framework_ title => $title, type => $type, dbobj => $obj, tab => 'disc',
+ framework_ title => $title, dbobj => $obj, tab => 'disc',
sub {
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ $title;
boardtypes_ $type;
boardsearch_ $type if !$id;
@@ -32,12 +31,12 @@ TUWF::get qr{/t/(all|$BOARD_RE)}, sub {
threadlist_
where => $type ne 'all' && sql('t.id IN(SELECT tid FROM threads_boards WHERE type =', \$type, $id ? ('AND iid =', \$id) : (), ')'),
- boards => $type ne 'all' && sql('NOT (tb.type =', \$type, 'AND tb.iid =', \($id||0), ')'),
+ boards => $type ne 'all' && sql('NOT (tb.type =', \$type, 'AND tb.iid IS NOT DISTINCT FROM', \$id, ')'),
results => 50,
sort => $type eq 'an' ? 't.id DESC' : undef,
page => $page,
paginate => sub { "?p=$_" }
- or div_ class => 'mainbox', sub {
+ or article_ sub {
h1_ 'An empty board';
p_ class => 'center', sub {
txt_ "Nobody's started a discussion on this board yet. Why not ";
diff --git a/lib/VNWeb/Discussions/Edit.pm b/lib/VNWeb/Discussions/Edit.pm
index 550be76c..06fb2397 100644
--- a/lib/VNWeb/Discussions/Edit.pm
+++ b/lib/VNWeb/Discussions/Edit.pm
@@ -5,30 +5,26 @@ use VNWeb::Discussions::Lib;
my $FORM = {
- tid => { required => 0, id => 1 }, # Thread ID, only when editing a post
- num => { required => 0, id => 1 }, # Post number, only when editing
-
- # Only when num = 1 || tid = undef
- title => { required => 0, maxlength => 50 },
- boards => { required => 0, sort_keys => [ 'boardtype', 'iid' ], aoh => {
- btype => { enum => \%BOARD_TYPE },
- iid => { required => 0, default => 0, id => 1 }, #
- title => { required => 0 },
- } },
- poll => { required => 0, type => 'hash', keys => {
- question => { maxlength => 100 },
+ tid => { default => undef, vndbid => 't' }, # Thread ID, only when editing a post
+
+ title => { default => undef, sl => 1, maxlength => 50 },
+ boards => { default => undef, sort_keys => [ 'boardtype', 'iid' ], aoh => $VNWeb::Elm::apis{BoardResult}[0]{aoh} },
+ poll => { default => undef, type => 'hash', keys => {
+ question => { sl => 1, maxlength => 100 },
max_options => { uint => 1, min => 1, max => 20 }, #
- options => { type => 'array', values => { maxlength => 100 }, minlength => 2, maxlength => 20 },
+ options => { type => 'array', values => { sl => 1, maxlength => 100 }, minlength => 2, maxlength => 20 },
} },
- can_mod => { anybool => 1, _when => 'out' },
- can_private => { anybool => 1, _when => 'out' },
- locked => { anybool => 1 }, # When can_mod && (num = 1 || tid = undef)
- hidden => { anybool => 1 }, # When can_mod
- private => { anybool => 1 }, # When can_private && (num = 1 || tid = undef)
- nolastmod => { anybool => 1, _when => 'in' }, # When can_mod
+ can_mod => { anybool => 1, _when => 'out' },
+ can_private => { anybool => 1, _when => 'out' },
+ locked => { anybool => 1 }, # When can_mod
+ hidden => { anybool => 1 }, # When can_mod
+ boards_locked => { anybool => 1 }, # When can_mod
+ private => { anybool => 1 }, # When can_private
+ nolastmod => { anybool => 1, _when => 'in' }, # When can_mod
+ delete => { anybool => 1 }, # When can_mod
- msg => { maxlength => 32768 },
+ msg => { maxlength => 32768 },
};
my $FORM_OUT = form_compile out => $FORM;
@@ -38,54 +34,60 @@ my $FORM_IN = form_compile in => $FORM;
elm_api DiscussionsEdit => $FORM_OUT, $FORM_IN, sub {
my($data) = @_;
my $tid = $data->{tid};
- my $num = $data->{num} || 1;
my $t = !$tid ? {} : tuwf->dbRowi('
- SELECT t.id, tp.num, t.poll_question, t.poll_max_options, tp.hidden, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date
+ SELECT t.id, t.poll_question, t.poll_max_options, t.boards_locked, t.hidden, tp.num, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date
FROM threads t
- JOIN threads_posts tp ON tp.tid = t.id AND tp.num =', \$num,
- 'WHERE t.id =', \$tid,
+ JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1
+ WHERE t.id =', \$tid,
'AND', sql_visible_threads());
return tuwf->resNotFound if $tid && !$t->{id};
return elm_Unauth if !can_edit t => $t;
- my $pollchanged = !$data->{tid} && $data->{poll};
- if($num == 1) {
- die "Invalid title" if !length $data->{title};
- die "Invalid boards" if !$data->{boards} || grep +(!$BOARD_TYPE{$_->{btype}}{dbitem})^(!$_->{iid}), $data->{boards}->@*;
-
- validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{btype} eq 'v' ? $_->{iid} : (), $data->{boards}->@*;
- validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{btype} eq 'p' ? $_->{iid} : (), $data->{boards}->@*;
- # Do not validate user boards here, it's possible to have threads assigned to deleted users.
-
- die "Invalid max_options" if $data->{poll} && $data->{poll}{max_options} > $data->{poll}{options}->@*;
- $pollchanged = 1 if $tid && $data->{poll} && (
- $data->{poll}{question} ne ($t->{poll_question}||'')
- || $data->{poll}{max_options} != $t->{poll_max_options}
- || join("\n", $data->{poll}{options}->@*) ne
- join("\n", map $_->{option}, tuwf->dbAlli('SELECT option FROM threads_poll_options WHERE tid =', \$tid, 'ORDER BY id')->@*)
- )
+ tuwf->dbExeci(q{DELETE FROM notifications WHERE iid =}, \$tid) if $tid && auth->permBoardmod && ($data->{delete} || $data->{hidden});
+
+ if($tid && $data->{delete} && auth->permBoardmod) {
+ auth->audit($t->{user_id}, 'post delete', "deleted $tid.1");
+ tuwf->dbExeci('DELETE FROM threads WHERE id =', \$tid);
+ return elm_Redirect '/t';
}
+ auth->audit($t->{user_id}, 'post edit', "edited $tid.1") if $tid && $t->{user_id} ne auth->uid;
+
+
+ die "Invalid title" if !length $data->{title};
+ die "Invalid boards" if !$data->{boards} || grep +(!$BOARD_TYPE{$_->{btype}}{dbitem})^(!$_->{iid}), $data->{boards}->@*;
+
+ validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{btype} eq 'v' ? $_->{iid} : (), $data->{boards}->@*;
+ validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{btype} eq 'p' ? $_->{iid} : (), $data->{boards}->@*;
+ # Do not validate user boards here, it's possible to have threads assigned to deleted users.
+
+ die "Invalid max_options" if $data->{poll} && $data->{poll}{max_options} > $data->{poll}{options}->@*;
+ my $pollchanged = (!$tid && $data->{poll}) || ($tid && $data->{poll} && (
+ $data->{poll}{question} ne ($t->{poll_question}||'')
+ || $data->{poll}{max_options} != $t->{poll_max_options}
+ || join("\n", $data->{poll}{options}->@*) ne
+ join("\n", map $_->{option}, tuwf->dbAlli('SELECT option FROM threads_poll_options WHERE tid =', \$tid, 'ORDER BY id')->@*)
+ ));
my $thread = {
title => $data->{title},
poll_question => $data->{poll} ? $data->{poll}{question} : undef,
poll_max_options => $data->{poll} ? $data->{poll}{max_options} : 1,
- $tid ? () : (count => 1),
auth->permBoardmod ? (
hidden => $data->{hidden},
locked => $data->{locked},
+ boards_locked => $data->{boards_locked},
) : (),
- auth->permBoardmod || auth->permDbmod || auth->permUsermod ? (
+ auth->isMod ? (
private => $data->{private}
) : (),
};
- tuwf->dbExeci('UPDATE threads SET', $thread, 'WHERE id =', \$tid) if $tid && $num == 1;
+ tuwf->dbExeci('UPDATE threads SET', $thread, 'WHERE id =', \$tid) if $tid;
$tid = tuwf->dbVali('INSERT INTO threads', $thread, 'RETURNING id') if !$tid;
- if($num == 1) {
+ if(auth->permBoardmod || !$t->{boards_locked}) {
tuwf->dbExeci('DELETE FROM threads_boards WHERE tid =', \$tid);
- tuwf->dbExeci('INSERT INTO threads_boards', { tid => $tid, type => $_->{btype}, iid => $_->{iid}//0 }) for $data->{boards}->@*;
+ tuwf->dbExeci('INSERT INTO threads_boards', { tid => $tid, type => $_->{btype}, iid => $_->{iid} }) for $data->{boards}->@*;
}
if($pollchanged) {
@@ -95,30 +97,33 @@ elm_api DiscussionsEdit => $FORM_OUT, $FORM_IN, sub {
my $post = {
tid => $tid,
- num => $num,
+ num => 1,
msg => bb_subst_links($data->{msg}),
$data->{tid} ? () : (uid => auth->uid),
- auth->permBoardmod && $num != 1 ? (hidden => $data->{hidden}) : (),
- auth->permBoardmod && $data->{nolastmod} ? () : (edited => sql 'NOW()')
+ !$data->{tid} || (auth->permBoardmod && $data->{nolastmod}) ? () : (edited => sql 'NOW()')
};
tuwf->dbExeci('INSERT INTO threads_posts', $post) if !$data->{tid};
- tuwf->dbExeci('UPDATE threads_posts SET', $post, 'WHERE', { tid => $tid, num => $num }) if $data->{tid};
+ tuwf->dbExeci('UPDATE threads_posts SET', $post, 'WHERE', { tid => $tid, num => 1 }) if $data->{tid};
- elm_Redirect post_url $tid, $num, $num;
+ elm_Redirect "/$tid.1";
};
-TUWF::get qr{(?:/t/(?<board>$BOARD_RE)/new|/$RE{postid}/edit)}, sub {
- my($board_type, $board_id) = (tuwf->capture('board')||'') =~ /^([^0-9]+)([0-9]*)$/;
- my($tid, $num) = (tuwf->capture('id'), tuwf->capture('num'));
+TUWF::get qr{(?:/t/(?<board>$BOARD_RE)/new|/$RE{tid}\.1/edit)}, sub {
+ my $board_id = tuwf->capture('board')||'';
+ my($board_type) = $board_id =~ /^([^0-9]+)/;
+ $board_id = $board_id =~ /[0-9]$/ ? dbobj $board_id : undef;
+ my $tid = tuwf->capture('id');
+
+ return tuwf->resNotFound if $board_id && !$board_id->{id};
$board_type = 'ge' if $board_type && $board_type eq 'an' && !auth->permBoardmod;
my $t = !$tid ? {} : tuwf->dbRowi('
- SELECT t.id, tp.tid, tp.num, t.title, t.locked, t.private, t.poll_question, t.poll_max_options, tp.hidden, tp.msg, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date
+ SELECT t.id, tp.tid, t.title, t.locked, t.boards_locked, t.private, t.hidden, t.poll_question, t.poll_max_options, tp.msg, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date
FROM threads t
- JOIN threads_posts tp ON tp.tid = t.id AND tp.num =', \$num,
- 'WHERE t.id =', \$tid,
+ JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1
+ WHERE t.id =', \$tid,
'AND', sql_visible_threads());
return tuwf->resNotFound if $tid && !$t->{id};
return tuwf->resDenied if !can_edit t => $t;
@@ -133,27 +138,27 @@ TUWF::get qr{(?:/t/(?<board>$BOARD_RE)/new|/$RE{postid}/edit)}, sub {
} else {
$t->{boards} = [ {
btype => $board_type,
- iid => $board_id||0,
- title => !$board_id ? undef :
- tuwf->dbVali('SELECT title FROM', sql_boards(), 'x WHERE btype =', \$board_type, 'AND iid =', \$board_id)
+ iid => $board_id ? $board_id->{id} : undef,
+ title => $board_id ? $board_id->{title} : undef,
} ];
- return tuwf->resNotFound if $board_id && !length $t->{boards}[0]{title};
- push $t->{boards}->@*, { btype => 'u', iid => auth->uid, title => auth->user->{user_name} }
- if $board_type eq 'u' && $board_id != auth->uid;
+ push $t->{boards}->@*, { btype => 'u', iid => auth->uid, title => [undef,auth->user->{user_name}] }
+ if $board_type eq 'u' && $board_id->{id} ne auth->uid;
}
+ $_->{title} = $_->{title} && $_->{title}[1] for $t->{boards}->@*;
$t->{can_mod} = auth->permBoardmod;
- $t->{can_private} = auth->permBoardmod || auth->permDbmod || auth->permUsermod;
+ $t->{can_private} = auth->isMod;
+ $t->{hidden} //= 0;
$t->{msg} //= '';
$t->{title} //= tuwf->reqGet('title');
$t->{tid} //= undef;
- $t->{num} //= undef;
- $t->{private} //= 0;
- $t->{hidden} //= 0;
+ $t->{private} //= auth->isMod && tuwf->reqGet('priv') ? 1 : 0;
$t->{locked} //= 0;
+ $t->{boards_locked} //= 0;
+ $t->{delete} = 0;
- framework_ title => $tid ? 'Edit post' : 'Create new thread', sub {
+ framework_ title => $tid ? 'Edit thread' : 'Create new thread', sub {
elm_ 'Discussions.Edit' => $FORM_OUT, $t;
};
};
diff --git a/lib/VNWeb/Discussions/Elm.pm b/lib/VNWeb/Discussions/Elm.pm
index 77944926..500cc3b9 100644
--- a/lib/VNWeb/Discussions/Elm.pm
+++ b/lib/VNWeb/Discussions/Elm.pm
@@ -1,44 +1,32 @@
package VNWeb::Discussions::Elm;
use VNWeb::Prelude;
-use VNWeb::Discussions::Lib;
# Autocompletion search results for boards
elm_api Boards => undef, {
- search => {},
+ search => { searchquery => 1 },
}, sub {
return elm_Unauth if !auth->permBoard;
my $q = shift->{search};
- my $qs = $q =~ s/[%_]//gr;
+ my $qs = sql_like "$q";
- my sub subq {
- my($prio, $where) = @_;
- sql 'SELECT', $prio, ' AS prio, btype, iid, CASE WHEN iid = 0 THEN NULL ELSE title END AS title
- FROM (',
- sql_join('UNION ALL',
- sql('SELECT btype, iid, title, original FROM', sql_boards(), 'a'),
- map sql('SELECT', \$_, '::board_type, 0,', \$BOARD_TYPE{$_}{txt}, q{, ''}),
- grep !$BOARD_TYPE{$_}{dbitem} && ($BOARD_TYPE{$_}{post_perm} eq 'board' || auth->permBoardmod),
- keys %BOARD_TYPE
- ),
- ') x WHERE', $where
- }
+ my $uscore = sql 'similarity(username, ', \$qs, ')';
+ $uscore = sql 'CASE WHEN id =', \$qs, 'THEN 1+1 ELSE', $uscore, 'END' if $qs =~ /^u$RE{num}$/;
- # This query is SLOW :(
elm_BoardResult tuwf->dbPagei({ results => 10, page => 1 },
'SELECT btype, iid, title
FROM (',
sql_join('UNION ALL',
- # ID match
- $q =~ /^($BOARD_RE)$/ && $q =~ /^([a-z]+)([0-9]*)$/
- ? subq(0, sql_and sql('btype =', \"$1"), $2 ? sql('iid =', \"$2") : ()) : (),
- subq(
- sql('1+LEAST(substr_score(lower(title),', \$qs, '), substr_score(lower(original),', \$qs, '))'),
- sql('title ILIKE', \"%$qs%", ' OR original ILIKE', \"%$qs%")
- )
- ), ') x
- GROUP BY btype, iid, title
- ORDER BY MIN(prio), btype, iid'
+ (map sql('SELECT 10, ', \"$_", '::board_type, NULL::vndbid, NULL'),
+ grep $qs eq $_ || $BOARD_TYPE{$_}{txt} =~ /\Q$qs/i,
+ grep !$BOARD_TYPE{$_}{dbitem} && ($BOARD_TYPE{$_}{post_perm} eq 'board' || auth->permBoardmod),
+ keys %BOARD_TYPE),
+ sql('SELECT score, \'v\', v.id, title[1+1] FROM', vnt, 'v', $q->sql_join('v', 'v.id'), 'WHERE NOT v.hidden'),
+ sql('SELECT score, \'p\', p.id, title[1+1] FROM', producerst, 'p', $q->sql_join('p', 'p.id'), 'WHERE NOT p.hidden'),
+ sql('SELECT', $uscore, ', \'u\', id, username FROM users WHERE lower(username) LIKE', \lc "%$qs%",
+ $qs =~ /^u$RE{num}$/ ? ('OR id =', \$qs) : ())
+ ), ') x(score, btype, iid, title)
+ ORDER BY score DESC, btype, title'
)
};
diff --git a/lib/VNWeb/Discussions/Index.pm b/lib/VNWeb/Discussions/Index.pm
index 90ac31b1..1e797d31 100644
--- a/lib/VNWeb/Discussions/Index.pm
+++ b/lib/VNWeb/Discussions/Index.pm
@@ -7,7 +7,7 @@ use VNWeb::Discussions::Lib;
TUWF::get qr{/t}, sub {
framework_ title => 'Discussion board index', sub {
form_ method => 'get', action => '/t/search', sub {
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ 'Discussion board index';
boardtypes_ 'index';
boardsearch_;
@@ -18,12 +18,14 @@ TUWF::get qr{/t}, sub {
};
for my $b (keys %BOARD_TYPE) {
- h1_ class => 'boxtitle', sub {
- a_ href => "/t/$b", $BOARD_TYPE{$b}{txt};
+ nav_ sub {
+ h1_ sub {
+ a_ href => "/t/$b", $BOARD_TYPE{$b}{txt};
+ };
};
threadlist_
where => sql('t.id IN(SELECT tid FROM threads_boards WHERE type =', \$b, ')'),
- boards => sql('NOT (tb.type =', \$b, 'AND tb.iid = 0)'),
+ boards => sql('NOT (tb.type =', \$b, 'AND tb.iid IS NULL)'),
results => $BOARD_TYPE{$b}{index_rows},
page => 1;
}
diff --git a/lib/VNWeb/Discussions/Lib.pm b/lib/VNWeb/Discussions/Lib.pm
index 9f77397e..d4e8146a 100644
--- a/lib/VNWeb/Discussions/Lib.pm
+++ b/lib/VNWeb/Discussions/Lib.pm
@@ -3,47 +3,30 @@ package VNWeb::Discussions::Lib;
use VNWeb::Prelude;
use Exporter 'import';
-our @EXPORT = qw/$BOARD_RE post_url sql_visible_threads sql_boards enrich_boards threadlist_ boardsearch_ boardtypes_/;
+our @EXPORT = qw/$BOARD_RE sql_visible_threads enrich_boards threadlist_ boardsearch_ boardtypes_/;
our $BOARD_RE = join '|', map $_.($BOARD_TYPE{$_}{dbitem}?'(?:[1-9][0-9]{0,5})?':''), keys %BOARD_TYPE;
-# Returns the URL to the thread page holding the given post (with optional location.hash)
-sub post_url {
- my($id, $num, $hash) = @_;
- "/t$id".($num > 25 ? '/'.ceil($num/25) : '').($hash ? "#$hash" : '');
-}
-
-
# Returns a WHERE condition to filter threads that the current user is allowed to see.
sub sql_visible_threads {
- return '1=1' if auth && auth->uid == 2; # Yorhel sees everything
+ return '1=1' if auth && auth->uid eq 'u2'; # Yorhel sees everything
sql_and
auth->permBoardmod ? () : ('NOT t.hidden'),
sql('NOT t.private OR EXISTS(SELECT 1 FROM threads_boards WHERE tid = t.id AND type = \'u\' AND iid =', \auth->uid, ')');
}
-# Returns a SELECT subquery with all board IDs
-sub sql_boards {
- sql q{( SELECT 'v'::board_type AS btype, id AS iid, title, original FROM vn
- UNION ALL SELECT 'p'::board_type AS btype, id AS iid, name, original FROM producers
- UNION ALL SELECT 'u'::board_type AS btype, id AS iid, username, NULL FROM users
- )}
-}
-
-
# Adds a 'boards' array to threads.
sub enrich_boards {
my($filt, @lst) = @_;
- enrich boards => id => tid => sub { sql q{
- SELECT tb.tid, tb.type AS btype, tb.iid, b.title, b.original
- FROM threads_boards tb
- LEFT JOIN }, sql_boards(), q{b ON b.btype = tb.type AND b.iid = tb.iid
- WHERE }, sql_and(sql('tb.tid IN', $_[0]), $filt||()), q{
+ enrich boards => id => tid => sub { sql '
+ SELECT tb.tid, tb.type AS btype, tb.iid, x.title
+ FROM threads_boards tb, ', item_info('tb.iid', 'NULL'), 'x
+ WHERE ', sql_and(sql('tb.tid IN', $_[0]), $filt||()), '
ORDER BY tb.type, tb.iid
- }}, @lst;
+ '}, @lst;
}
@@ -65,14 +48,14 @@ sub threadlist_ {
return 0 if $opt{paginate} && !$count;
my $lst = tuwf->dbPagei(\%opt, q{
- SELECT t.id, t.title, t.count, t.locked, t.private, t.hidden, t.poll_question IS NOT NULL AS haspoll
+ SELECT t.id, t.title, t.c_count, t.c_lastnum, t.locked, t.private, t.hidden, t.poll_question IS NOT NULL AS haspoll
, }, sql_user('tfu', 'firstpost_'), ',', sql_totime('tf.date'), q{ as firstpost_date
, }, sql_user('tlu', 'lastpost_'), ',', sql_totime('tl.date'), q{ as lastpost_date
FROM threads t
JOIN threads_posts tf ON tf.tid = t.id AND tf.num = 1
- JOIN threads_posts tl ON tl.tid = t.id AND tl.num = t.count
- JOIN users tfu ON tfu.id = tf.uid
- JOIN users tlu ON tlu.id = tl.uid
+ JOIN threads_posts tl ON tl.tid = t.id AND tl.num = t.c_lastnum
+ LEFT JOIN users tfu ON tfu.id = tf.uid
+ LEFT JOIN users tlu ON tlu.id = tl.uid
WHERE }, $where, q{
ORDER BY}, $opt{sort}||'tl.date DESC'
);
@@ -81,7 +64,7 @@ sub threadlist_ {
enrich_boards $opt{boards}, $lst;
paginate_ $opt{paginate}, $opt{page}, [ $count, $opt{results} ], 't' if $opt{paginate};
- div_ class => 'mainbox browse discussions', sub {
+ article_ class => 'browse discussions', sub {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
td_ class => 'tc1', sub { txt_ 'Topic'; debug_ $lst };
@@ -92,27 +75,29 @@ sub threadlist_ {
tr_ sub {
my $l = $_;
td_ class => 'tc1', sub {
- a_ mkclass(locked => $l->{locked}), href => "/t$l->{id}", sub {
+ my $system = $l->{private} && $l->{firstpost_id} && $l->{firstpost_id} eq 'u1';
+ a_ mkclass(locked => !$system && $l->{locked}), href => "/$l->{id}", sub {
span_ class => 'pollflag', '[poll]' if $l->{haspoll};
- span_ class => 'pollflag', '[private]' if $l->{private};
+ span_ class => 'pollflag', $system ? '[system]' : '[private]' if $l->{private};
span_ class => 'pollflag', '[hidden]' if $l->{hidden};
txt_ shorten $l->{title}, 50;
};
- b_ class => 'boards', sub {
+ span_ class => 'boards', sub {
join_ ', ', sub {
- a_ href => "/t/$_->{btype}".($_->{iid}||''),
- title => $_->{original}||$BOARD_TYPE{$_->{btype}}{txt},
- shorten $_->{title}||$BOARD_TYPE{$_->{btype}}{txt}, 30;
+ a_ href => '/t/'.($_->{iid}||$_->{btype}),
+ $_->{title} ? tlang(@{$_->{title}}[0,1]) : (),
+ title => $_->{title} ? $_->{title}[3] : $BOARD_TYPE{$_->{btype}}{txt},
+ shorten $_->{title} ? $_->{title}[1] : $BOARD_TYPE{$_->{btype}}{txt}, 30;
}, $l->{boards}->@[0 .. min 4, $#{$l->{boards}}];
txt_ ', ...' if $l->{boards}->@* > 4;
- };
+ } if !$system;
};
- td_ class => 'tc2', $l->{count}-1;
+ td_ class => 'tc2', $l->{c_count}-1;
td_ class => 'tc3', sub { user_ $l, 'firstpost_' };
td_ class => 'tc4', sub {
user_ $l, 'lastpost_';
txt_ ' @ ';
- a_ href => post_url($l->{id}, $l->{count}, 'last'), fmtdate $l->{lastpost_date}, 'full';
+ a_ href => "/$l->{id}.$l->{c_lastnum}#last", fmtdate $l->{lastpost_date}, 'full';
};
} for @$lst;
}
diff --git a/lib/VNWeb/Discussions/PostEdit.pm b/lib/VNWeb/Discussions/PostEdit.pm
new file mode 100644
index 00000000..d0e4e1d2
--- /dev/null
+++ b/lib/VNWeb/Discussions/PostEdit.pm
@@ -0,0 +1,89 @@
+package VNWeb::Discussions::PostEdit;
+# Also used for editing review comments, which follow the exact same format.
+
+use VNWeb::Prelude;
+use VNWeb::Discussions::Lib;
+
+
+my $FORM = {
+ id => { vndbid => ['t','w'] },
+ num => { id => 1 },
+
+ can_mod => { anybool => 1, _when => 'out' },
+ hidden => { default => sub { $_[0] } }, # When can_mod
+ nolastmod => { anybool => 1, _when => 'in' }, # When can_mod
+ delete => { anybool => 1 }, # When can_mod
+
+ msg => { maxlength => 32768 },
+};
+
+my $FORM_OUT = form_compile out => $FORM;
+my $FORM_IN = form_compile in => $FORM;
+
+
+sub _info {
+ my($id,$num) = @_;
+ tuwf->dbRowi('
+ SELECT t.id, tp.num, tp.hidden, tp.msg, tp.uid AS user_id,', sql_totime('tp.date'), 'AS date
+ FROM threads t
+ JOIN threads_posts tp ON tp.tid = t.id AND tp.num =', \$num, '
+ WHERE t.id =', \$id, 'AND', sql_visible_threads(),'
+ UNION ALL
+ SELECT id, num, hidden, msg, uid AS user_id,', sql_totime('date'), 'AS date
+ FROM reviews_posts WHERE id =', \$id, 'AND num =', \$num
+ );
+}
+
+
+elm_api DiscussionsPostEdit => $FORM_OUT, $FORM_IN, sub {
+ my($data) = @_;
+ my $id = $data->{id};
+ my $num = $data->{num};
+
+ my $t = _info $id, $num;
+ return tuwf->resNotFound if !$t->{id};
+ return elm_Unauth if !can_edit t => $t;
+
+ tuwf->dbExeci(q{DELETE FROM notifications WHERE iid =}, \$id, 'AND num =', \$num) if auth->permBoardmod && ($data->{delete} || defined $data->{hidden});
+
+ if($data->{delete} && auth->permBoardmod) {
+ auth->audit($t->{user_id}, 'post delete', "deleted $id.$num");
+ tuwf->dbExeci('DELETE FROM threads_posts WHERE tid =', \$id, 'AND num =', \$num);
+ tuwf->dbExeci('DELETE FROM reviews_posts WHERE id =', \$id, 'AND num =', \$num);
+ return elm_Redirect "/$id";
+ }
+ auth->audit($t->{user_id}, 'post edit', "edited $id.$num") if $t->{user_id} ne auth->uid;
+
+ my $post = {
+ tid => $id,
+ num => $num,
+ msg => bb_subst_links($data->{msg}),
+ auth->permBoardmod ? (hidden => $data->{hidden}) : (),
+ (auth->permBoardmod && $data->{nolastmod}) ? () : (edited => sql 'NOW()')
+ };
+ tuwf->dbExeci('UPDATE threads_posts SET', $post, 'WHERE', { tid => $id, num => $num });
+ $post->{id} = delete $post->{tid};
+ tuwf->dbExeci('UPDATE reviews_posts SET', $post, 'WHERE', { id => $id, num => $num });
+
+ elm_Redirect "/$id.$num";
+};
+
+
+TUWF::get qr{/(?:$RE{tid}|$RE{wid})\.$RE{num}/edit}, sub {
+ my($id, $num) = (tuwf->capture('id'), tuwf->capture('num'));
+ tuwf->pass if $id =~ /^t/ && $num == 1; # t#.1 goes to Discussions::Edit.
+
+ my $t = _info $id, $num;
+ return tuwf->resNotFound if $id && !$t->{id};
+ return tuwf->resDenied if !can_edit t => $t;
+
+ $t->{can_mod} = auth->permBoardmod;
+ $t->{delete} = 0;
+
+ framework_ title => 'Edit post', sub {
+ elm_ 'Discussions.PostEdit' => $FORM_OUT, $t;
+ };
+};
+
+
+1;
diff --git a/lib/VNWeb/Discussions/Search.pm b/lib/VNWeb/Discussions/Search.pm
index 06366caf..79db2823 100644
--- a/lib/VNWeb/Discussions/Search.pm
+++ b/lib/VNWeb/Discussions/Search.pm
@@ -3,30 +3,34 @@ package VNWeb::Discussions::Search;
use VNWeb::Prelude;
use VNWeb::Discussions::Lib;
+my @BOARDS = (keys %BOARD_TYPE, 'w');
sub filters_ {
state $schema = tuwf->compile({ type => 'hash', keys => {
- bq => { required => 0, default => '' },
- b => { type => 'array', scalar => 1, onerror => [keys %BOARD_TYPE], values => { enum => \%BOARD_TYPE } },
+ bq => { default => '' },
+ uq => { default => '' },
+ b => { type => 'array', scalar => 1, onerror => \@BOARDS, values => { enum => \@BOARDS } },
t => { anybool => 1 },
p => { page => 1 },
}});
my $filt = tuwf->validate(get => $schema)->data;
my %boards = map +($_,1), $filt->{b}->@*;
+ my $u = $filt->{uq} && tuwf->dbVali('SELECT id FROM users WHERE', $filt->{uq} =~ /^u$RE{num}$/ ? 'id = ' : 'lower(username) =', \lc $filt->{uq});
+
form_ method => 'get', action => tuwf->reqPath(), sub {
boardtypes_;
- table_ style => 'margin: 0 auto', sub { tr_ sub {
- td_ style => 'padding: 10px', sub {
- p_ class => 'linkradio', sub {
- join_ \&br_, sub {
- input_ type => 'checkbox', name => 'b', id => "b_$_", value => $_, $boards{$_} ? (checked => 'checked') : ();
- label_ for => "b_$_", $BOARD_TYPE{$_}{txt};
- }, keys %BOARD_TYPE;
+ table_ class => 'boardsearchoptions', sub { tr_ sub {
+ td_ sub {
+ select_ multiple => 1, size => scalar @BOARDS, name => 'b', sub {
+ option_ $boards{$_} ? (selected => 1) : (), value => $_, $_ eq 'w' ? 'Reviews' : $BOARD_TYPE{$_}{txt} for @BOARDS;
}
};
- td_ style => 'padding: 10px', sub {
+ td_ sub {
input_ type => 'text', class => 'text', name => 'bq', style => 'width: 400px', placeholder => 'Search', value => $filt->{bq};
+ br_;
+ input_ type => 'text', class => 'text', name => 'uq', style => 'width: 150px', placeholder => 'Username or id', value => $filt->{uq};
+ b_ 'User not found.' if $filt->{uq} && !$u;
p_ class => 'linkradio', sub {
input_ type => 'checkbox', name => 't', id => 't', value => 1, $filt->{t} ? (checked => 'checked') : ();
@@ -39,12 +43,12 @@ sub filters_ {
};
}
};
- $filt
+ ($filt, $u)
}
sub noresults_ {
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ 'No results';
p_ 'No threads or messages found matching your criteria.';
};
@@ -52,16 +56,18 @@ sub noresults_ {
sub posts_ {
- my($filt) = @_;
+ my($filt, $u) = @_;
- # Turn query into something suitable for to_tsquery()
- # TODO: Use Postgres 11 websearch_to_tsquery() instead.
- (my $ts = $filt->{bq}) =~ y{+|&:*()="';!?$%^\\[]{}<>~` }{ }s;
- $ts =~ s/ +/ /;
- $ts =~ s/^ //;
- $ts =~ s/ $//;
- $ts =~ s/ / & /g;
- $ts =~ s/(?:^| )-([^ ]+)/ !$1 /;
+ # Use websearch_to_tsquery() to convert the query string into a tsquery.
+ # Also match against an empty string to see if the query doesn't consist of only negative matches.
+ my $ts = tuwf->dbVali('
+ WITH q(q) AS (SELECT websearch_to_tsquery(', \$filt->{bq}, '))
+ SELECT CASE WHEN numnode(q) = 0 OR q @@ \'\' THEN NULL ELSE q END FROM q');
+ return noresults_ if !$ts;
+
+ my $reviews = grep $_ eq 'w', $filt->{b}->@*;
+ my @tboards = grep $_ ne 'w', $filt->{b}->@*;
+ return noresults_ if !$reviews && !@tboards;
# HACK: The bbcodes are stripped from the original messages when creating
# the headline, so they are guaranteed not to show up in the message. This
@@ -69,26 +75,43 @@ sub posts_ {
# conflict with the message contents.
my($posts, $np) = tuwf->dbPagei({ results => 20, page => $filt->{p} }, q{
- SELECT tp.tid, tp.num, t.title
+ SELECT m.id, m.num, m.title
, }, sql_user(), q{
- , }, sql_totime('tp.date'), q{as date
- , ts_headline('english', strip_bb_tags(strip_spoilers(tp.msg)), to_tsquery(}, \$ts, '),',
+ , }, sql_totime('m.date'), q{as date
+ , ts_headline('english', strip_bb_tags(strip_spoilers(m.msg)),}, \$ts, ',',
\'MaxFragments=2,MinWords=15,MaxWords=40,StartSel=[raw],StopSel=[/raw],FragmentDelimiter=[code]',
- q{) as headline
- FROM threads_posts tp
- JOIN threads t ON t.id = tp.tid
- JOIN users u ON u.id = tp.uid
- WHERE NOT t.hidden AND NOT t.private AND NOT tp.hidden
- AND bb_tsvector(tp.msg) @@ to_tsquery(}, \$ts, ')',
- $filt->{b}->@* < keys %BOARD_TYPE ? ('AND t.id IN(SELECT tid FROM threads_boards WHERE type IN', $filt->{b}, ')') : (), q{
- ORDER BY tp.date DESC
- });
+ ') as headline
+ FROM (', sql_join('UNION',
+ @tboards ?
+ sql('SELECT tp.tid, tp.num, t.title, tp.uid, tp.date, tp.msg
+ FROM threads_posts tp
+ JOIN threads t ON t.id = tp.tid
+ WHERE NOT t.hidden AND NOT t.private AND tp.hidden IS NULL
+ AND bb_tsvector(tp.msg) @@', \$ts,
+ $u ? ('AND tp.uid =', \$u) : (),
+ @tboards < keys %BOARD_TYPE ? ('AND t.id IN(SELECT tid FROM threads_boards WHERE type IN', \@tboards, ')') : ()
+ ) : (), $reviews ? (
+ sql('SELECT w.id, 0, v.title[1+1], w.uid, w.date, w.text
+ FROM reviews w
+ JOIN', vnt, 'v ON v.id = w.vid
+ WHERE NOT w.c_flagged AND bb_tsvector(w.text) @@', \$ts,
+ $u ? ('AND w.uid =', \$u) : ()),
+ sql('SELECT wp.id, wp.num, v.title[1+1], wp.uid, wp.date, wp.msg
+ FROM reviews_posts wp
+ JOIN reviews w ON w.id = wp.id
+ JOIN', vnt, 'v ON v.id = w.vid
+ WHERE NOT w.c_flagged AND wp.hidden IS NULL AND bb_tsvector(wp.msg) @@', \$ts,
+ $u ? ('AND wp.uid =', \$u) : ()),
+ ) : ()), ') m (id, num, title, uid, date, msg)
+ LEFT JOIN users u ON u.id = m.uid
+ ORDER BY m.date DESC'
+ );
return noresults_ if !@$posts;
my sub url { '?'.query_encode %$filt, @_ }
paginate_ \&url, $filt->{p}, $np, 't';
- div_ class => 'mainbox browse postsearch', sub {
+ article_ class => 'browse postsearch', sub {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
td_ class => 'tc1_1', 'Id';
@@ -99,18 +122,18 @@ sub posts_ {
}};
tr_ sub {
my $l = $_;
- my $link = "/t$l->{tid}.$l->{num}";
- td_ class => 'tc1_1', sub { a_ href => $link, 't'.$l->{tid} };
- td_ class => 'tc1_2', sub { a_ href => $link, '.'.$l->{num} };
+ my $link = "/$l->{id}".($l->{num}?".$l->{num}":'');
+ td_ class => 'tc1_1', sub { a_ href => $link, $l->{id} };
+ td_ class => 'tc1_2', sub { a_ href => $link, '.'.$l->{num} if $l->{num} };
td_ class => 'tc2', fmtdate $l->{date};
td_ class => 'tc3', sub { user_ $l };
td_ class => 'tc4', sub {
div_ class => 'title', sub { a_ href => $link, $l->{title} };
div_ class => 'thread', sub { lit_(
- TUWF::XML::xml_escape($l->{headline})
- =~ s/\[raw\]/<b class="standout">/gr
+ xml_escape($l->{headline})
+ =~ s/\[raw\]/<b>/gr
=~ s/\[\/raw\]/<\/b>/gr
- =~ s/\[code\]/<b class="grayedout">...<\/b><br \/>/gr
+ =~ s/\[code\]/<small>...<\/small><br \/>/gr
)};
};
} for @$posts;
@@ -121,11 +144,15 @@ sub posts_ {
sub threads_ {
- my($filt) = @_;
+ my($filt, $u) = @_;
+
+ my @boards = grep $_ ne 'w', $filt->{b}->@*; # Can't search reviews by title
+ return noresults_ if !@boards;
my $where = sql_and
- $filt->{b}->@* < keys %BOARD_TYPE ? sql('t.id IN(SELECT tid FROM threads_boards WHERE type IN', $filt->{b}, ')') : (),
- map sql('t.title ilike', \('%'.($_ =~ s/%//gr).'%')), grep length($_) > 0, split /[ -,._]/, $filt->{bq};
+ @boards < keys %BOARD_TYPE ? sql('t.id IN(SELECT tid FROM threads_boards WHERE type IN', \@boards, ')') : (),
+ $u ? sql('EXISTS(SELECT 1 FROM threads_posts tp WHERE tp.tid = t.id AND tp.num = 1 AND tp.uid =', \$u, ')') : (),
+ map sql('t.title ilike', \('%'.sql_like($_).'%')), grep length($_) > 0, split /[ ,._-]/, $filt->{bq};
noresults_ if !threadlist_
where => $where,
@@ -138,13 +165,13 @@ sub threads_ {
TUWF::get qr{/t/search}, sub {
framework_ title => 'Search the discussion board',
sub {
- my $filt;
- div_ class => 'mainbox', sub {
+ my($filt, $u);
+ article_ sub {
h1_ 'Search the discussion board';
- $filt = filters_;
+ ($filt, $u) = filters_;
};
- posts_ $filt if $filt->{bq} && !$filt->{t};
- threads_ $filt if $filt->{bq} && $filt->{t};
+ posts_ $filt, $u if $filt->{bq} && !$filt->{t};
+ threads_ $filt, $u if $filt->{bq} && $filt->{t};
};
};
diff --git a/lib/VNWeb/Discussions/Thread.pm b/lib/VNWeb/Discussions/Thread.pm
index e410c920..b3820dd7 100644
--- a/lib/VNWeb/Discussions/Thread.pm
+++ b/lib/VNWeb/Discussions/Thread.pm
@@ -10,7 +10,7 @@ my $POLL_OUT = form_compile any => {
num_votes => { uint => 1 },
can_vote => { anybool => 1 },
preview => { anybool => 1 },
- tid => { id => 1 },
+ tid => { vndbid => 't' },
options => { aoh => {
id => { id => 1 },
option => {},
@@ -20,7 +20,7 @@ my $POLL_OUT = form_compile any => {
};
my $POLL_IN = form_compile any => {
- tid => { id => 1 },
+ tid => { vndbid => 't' },
options => { type => 'array', values => { id => 1 } },
};
@@ -32,59 +32,62 @@ elm_api DiscussionsPoll => $POLL_OUT, $POLL_IN, sub {
return tuwf->resNotFound if !$t->{poll_question};
die 'Too many options' if $data->{options}->@* > $t->{poll_max_options};
- validate_dbid sql('SELECT id FROM threads_poll_options WHERE tid =', \$data->{tid}, 'AND id IN'), $data->{options}->@*;
+ my %opt = map +($_->{id},1), tuwf->dbAlli('SELECT id FROM threads_poll_options WHERE tid =', \$data->{tid})->@*;
+ die 'Invalid option' if grep !$opt{$_}, $data->{options}->@*;
- tuwf->dbExeci('DELETE FROM threads_poll_votes WHERE tid =', \$data->{tid}, 'AND uid =', \auth->uid);
- tuwf->dbExeci('INSERT INTO threads_poll_votes', { tid => $data->{tid}, uid => auth->uid, optid => $_ }) for $data->{options}->@*;
+ tuwf->dbExeci('DELETE FROM threads_poll_votes WHERE optid IN', [ keys %opt ], 'AND uid =', \auth->uid);
+ tuwf->dbExeci('INSERT INTO threads_poll_votes', { uid => auth->uid, optid => $_ }) for $data->{options}->@*;
elm_Success
};
-my $REPLY = {
- tid => { id => 1 },
- old => { _when => 'out', anybool => 1 },
- msg => { _when => 'in', maxlength => 32768 }
+my $REPLY = form_compile any => {
+ tid => { vndbid => 't' },
+ old => { anybool => 1 },
+ msg => { maxlength => 32768 }
};
-my $REPLY_IN = form_compile in => $REPLY;
-my $REPLY_OUT = form_compile out => $REPLY;
-
-elm_api DiscussionsReply => $REPLY_OUT, $REPLY_IN, sub {
+js_api DiscussionReply => $REPLY, sub {
my($data) = @_;
- my $t = tuwf->dbRowi('SELECT id, locked, count FROM threads t WHERE id =', \$data->{tid}, 'AND', sql_visible_threads());
+ my $t = tuwf->dbRowi('SELECT id, locked FROM threads t WHERE id =', \$data->{tid}, 'AND', sql_visible_threads());
return tuwf->resNotFound if !$t->{id};
- return elm_Unauth if !can_edit t => $t;
+ return tuwf->resDenied if !can_edit t => $t;
- my $num = $t->{count}+1;
+ my $num = sql '(SELECT MAX(num)+1 FROM threads_posts WHERE tid =', \$data->{tid}, ')';
my $msg = bb_subst_links $data->{msg};
- tuwf->dbExeci('INSERT INTO threads_posts', { tid => $t->{id}, num => $num, uid => auth->uid, msg => $msg });
- tuwf->dbExeci('UPDATE threads SET count =', \$num, 'WHERE id =', \$t->{id});
- elm_Redirect post_url $t->{id}, $num, 'last';
+ $num = tuwf->dbVali('INSERT INTO threads_posts', { tid => $t->{id}, num => $num, uid => auth->uid, msg => $msg }, 'RETURNING num');
+ +{ _redir => "/$t->{id}.$num#last" };
};
sub metabox_ {
- my($t) = @_;
- div_ class => 'mainbox', sub {
- h1_ $t->{title};
+ my($t, $posts) = @_;
+ article_ sub {
+ h1_ sub { lit_ bb_format $t->{title}, idonly => 1 };
+ # UGLY hack: private threads from Multi (u1) are sometimes (ab)used for system notifications, treat that case differently.
+ if ($t->{private} && $posts->[0]{user_id} && $posts->[0]{user_id} eq 'u1') {
+ h2_ 'System notification';
+ return;
+ }
h2_ 'Hidden' if $t->{hidden};
h2_ 'Private' if $t->{private};
+ h2_ 'Locked' if $t->{locked};
h2_ 'Posted in';
ul_ sub {
li_ sub {
a_ href => "/t/$_->{btype}", $BOARD_TYPE{$_->{btype}}{txt};
if($_->{iid}) {
txt_ ' > ';
- a_ style => 'font-weight: bold', href => "/t/$_->{btype}$_->{iid}", "$_->{btype}$_->{iid}";
+ a_ style => 'font-weight: bold', href => "/t/$_->{iid}", $_->{iid};
txt_ ':';
if($_->{title}) {
- a_ href => "/$_->{btype}$_->{iid}", title => $_->{original}||$_->{title}, $_->{title};
+ a_ href => "/$_->{iid}", tattr $_;
} else {
- b_ '[deleted]';
+ strong_ '[deleted]';
}
}
} for $t->{boards}->@*;
@@ -93,17 +96,18 @@ sub metabox_ {
}
+# Also used by Reviews::Page for review comments.
sub posts_ {
my($t, $posts, $page) = @_;
- my sub url { "/t$t->{id}".($_?"/$_":'') }
+ my sub url { "/$t->{id}".($_?"/$_":'') }
paginate_ \&url, $page, [ $t->{count}, 25 ], 't';
- div_ class => 'mainbox thread', sub {
+ article_ class => 'thread', id => 'threadstart', sub {
table_ class => 'stripe', sub {
- tr_ mkclass(deleted => $_->{hidden}), id => $_->{num}, sub {
- td_ class => 'tc1', $t->{count} == $_->{num} ? (id => 'last') : (), sub {
- a_ href => "/t$t->{id}.$_->{num}", "#$_->{num}";
- if(!$_->{hidden} || auth->permBoard) {
+ tr_ mkclass(deleted => defined $_->{hidden}), id => "p$_->{num}", sub {
+ td_ class => 'tc1', $_ == $posts->[$#$posts] ? (id => 'last') : (), sub {
+ a_ href => "/$t->{id}.$_->{num}", "#$_->{num}";
+ if(!defined $_->{hidden} || auth->permBoard) {
txt_ ' by ';
user_ $_;
br_;
@@ -111,16 +115,23 @@ sub posts_ {
}
};
td_ class => 'tc2', sub {
- i_ class => 'edit', sub {
+ small_ class => 'edit', sub {
txt_ '< ';
- a_ href => "/t$t->{id}.$_->{num}/edit", 'edit';
+ if(can_edit t => $_) {
+ a_ href => "/$t->{id}.$_->{num}/edit", 'edit';
+ txt_ ' - ';
+ }
+ a_ href => "/report/$t->{id}.$_->{num}", 'report';
txt_ ' >';
- } if can_edit t => $_;
- if($_->{hidden}) {
- i_ class => 'deleted', 'Post deleted.';
+ } if !defined $_->{hidden} || can_edit t => $_;
+ if(defined $_->{hidden}) {
+ small_ sub {
+ txt_ 'Post deleted';
+ lit_ length $_->{hidden} ? ': '.bb_format $_->{hidden}, inline => 1 : '.';
+ };
} else {
- lit_ bb2html $_->{msg};
- i_ class => 'lastmod', 'Last modified on '.fmtdate($_->{edited}, 'full') if $_->{edited};
+ lit_ bb_format $_->{msg};
+ small_ class => 'lastmod', 'Last modified on '.fmtdate($_->{edited}, 'full') if $_->{edited};
}
};
} for @$posts;
@@ -134,9 +145,9 @@ sub reply_ {
my($t, $posts, $page) = @_;
return if $t->{count} > $page*25;
if(can_edit t => $t) {
- elm_ 'Discussions.Reply' => $REPLY_OUT, { tid => $t->{id}, old => $posts->[$#$posts]{date} < time-182*24*3600 };
+ div_ widget(DiscussionReply => $REPLY, { tid => $t->{id}, old => $posts->[$#$posts]{date} < time-182*24*3600 }), '';
} else {
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ 'Reply';
p_ class => 'center',
!auth ? 'You must be logged in to reply to this thread.' :
@@ -146,12 +157,13 @@ sub reply_ {
}
-TUWF::get qr{/$RE{tid}(?:/$RE{num})?}, sub {
- my($id, $page) = (tuwf->capture('id'), tuwf->capture('num')||1);
+TUWF::get qr{/$RE{tid}(?:(?<sep>[\./])$RE{num})?}, sub {
+ my($id, $sep, $num) = (tuwf->capture('id'), tuwf->capture('sep')||'', tuwf->capture('num'));
my $t = tuwf->dbRowi(
- 'SELECT id, title, count, hidden, locked, private
+ 'SELECT id, title, hidden, locked, private
, poll_question, poll_max_options
+ , (SELECT COUNT(*) FROM threads_posts WHERE tid = id) AS count
FROM threads t
WHERE', sql_visible_threads(), 'AND id =', \$id
);
@@ -159,16 +171,21 @@ TUWF::get qr{/$RE{tid}(?:/$RE{num})?}, sub {
enrich_boards '', $t;
+ my $page = $sep eq '/' ? $num||1 : $sep ne '.' ? 1
+ : ceil((tuwf->dbVali('SELECT COUNT(*) FROM threads_posts WHERE num <=', \$num, 'AND tid =', \$id)||9999)/25);
+ $num = 0 if $sep ne '.';
+
my $posts = tuwf->dbPagei({ results => 25, page => $page },
'SELECT tp.tid as id, tp.num, tp.hidden, tp.msg',
',', sql_user(),
',', sql_totime('tp.date'), ' as date',
',', sql_totime('tp.edited'), ' as edited
FROM threads_posts tp
- JOIN users u ON tp.uid = u.id
+ LEFT JOIN users u ON tp.uid = u.id
WHERE tp.tid =', \$id, '
ORDER BY tp.num'
);
+ return tuwf->resNotFound if !@$posts || ($num && !grep $_->{num} == $num, @$posts);
my $poll_options = $t->{poll_question} && tuwf->dbAlli(
'SELECT tpo.id, tpo.option, count(u.id) as votes, tpm.optid IS NOT NULL as my
@@ -177,15 +194,23 @@ TUWF::get qr{/$RE{tid}(?:/$RE{num})?}, sub {
LEFT JOIN users u ON tpv.uid = u.id AND NOT u.ign_votes
LEFT JOIN threads_poll_votes tpm ON tpm.optid = tpo.id AND tpm.uid =', \auth->uid, '
WHERE tpo.tid =', \$id, '
- GROUP BY tpo.id, tpo.option, tpm.optid'
+ GROUP BY tpo.id, tpo.option, tpm.optid
+ ORDER BY tpo.id'
);
- framework_ title => $t->{title}, sub {
- metabox_ $t;
+ auth->notiRead($id, [ map $_->{num}, $posts->@* ]) if @$posts;
+
+ framework_ title => $t->{title}, dbobj => $t, $num ? (js => 1, pagevars => {sethash=>"p$num"}) : (), sub {
+ metabox_ $t, $posts;
elm_ 'Discussions.Poll' => $POLL_OUT, {
question => $t->{poll_question},
max_options => $t->{poll_max_options},
- num_votes => tuwf->dbVali('SELECT COUNT(DISTINCT tpv.uid) FROM threads_poll_votes tpv JOIN users u ON tpv.uid = u.id WHERE NOT u.ign_votes AND tid =', \$id),
+ num_votes => tuwf->dbVali(
+ 'SELECT COUNT(DISTINCT tpv.uid)
+ FROM threads_poll_votes tpv
+ JOIN threads_poll_options tpo ON tpo.id = tpv.optid
+ JOIN users u ON tpv.uid = u.id
+ WHERE NOT u.ign_votes AND tpo.tid =', \$id),
preview => !!tuwf->reqGet('pollview'), # Old non-Elm way to preview poll results
can_vote => !!auth,
tid => $id,
@@ -196,10 +221,4 @@ TUWF::get qr{/$RE{tid}(?:/$RE{num})?}, sub {
}
};
-
-TUWF::get qr{/$RE{postid}}, sub {
- my($id, $num) = (tuwf->capture('id'), tuwf->capture('num'));
- tuwf->resRedirect(post_url($id, $num, $num), 'perm')
-};
-
1;
diff --git a/lib/VNWeb/Discussions/UPosts.pm b/lib/VNWeb/Discussions/UPosts.pm
index 45be3f0b..aaa75c1e 100644
--- a/lib/VNWeb/Discussions/UPosts.pm
+++ b/lib/VNWeb/Discussions/UPosts.pm
@@ -9,7 +9,7 @@ sub listing_ {
my sub url { '?'.query_encode @_ }
paginate_ \&url, $page, [ $count, 50 ], 't';
- div_ class => 'mainbox browse uposts', sub {
+ article_ class => 'browse uposts', sub {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
td_ class => 'tc1', sub { debug_ $list };
@@ -18,13 +18,13 @@ sub listing_ {
td_ class => 'tc4', 'Title';
}};
tr_ sub {
- my $url = "/t$_->{tid}.$_->{num}";
- td_ class => 'tc1', sub { a_ href => $url, 't'.$_->{tid} };
- td_ class => 'tc2', sub { a_ href => $url, '.'.$_->{num} };
+ my $url = "/$_->{id}.$_->{num}";
+ td_ class => 'tc1', sub { a_ href => $url, $_->{hidden} ? (class => 'grayedout') : (), $_->{id} };
+ td_ class => 'tc2', sub { a_ href => $url, $_->{hidden} ? (class => 'grayedout') : (), '.'.$_->{num} };
td_ class => 'tc3', fmtdate $_->{date};
td_ class => 'tc4', sub {
a_ href => $url, $_->{title};
- b_ class => 'grayedout', sub { lit_ bb2html $_->{msg}, 150 };
+ small_ sub { lit_ bb_format $_->{msg}, maxlength => 150, inline => 1 };
};
} for @$list;
}
@@ -36,28 +36,34 @@ sub listing_ {
TUWF::get qr{/$RE{uid}/posts}, sub {
my $u = tuwf->dbRowi('SELECT id, ', sql_user(), 'FROM users u WHERE id =', \tuwf->capture('id'));
- return tuwf->resNotFound if !$u->{id};
+ return tuwf->resNotFound if !$u->{id} || (!$u->{user_name} && !auth->isMod);
my $page = tuwf->validate(get => p => { upage => 1 })->data;
- my $from_and_where = sql
- 'FROM threads_posts tp
- JOIN threads t ON t.id = tp.tid
- WHERE NOT t.private AND NOT t.hidden AND NOT tp.hidden AND tp.uid =', \$u->{id};
+ my $sql = sql '(
+ SELECT tp.tid, tp.num, tp.msg, t.title, tp.date, t.hidden OR tp.hidden IS NOT NULL
+ FROM threads_posts tp
+ JOIN threads t ON t.id = tp.tid
+ WHERE tp.uid =', \$u->{id}, 'AND NOT t.private', auth->permBoardmod ? () : 'AND NOT t.hidden AND tp.hidden IS NULL', '
+ UNION ALL
+ SELECT rp.id, rp.num, rp.msg, v.title[1+1], rp.date, rp.hidden IS NOT NULL
+ FROM reviews_posts rp
+ JOIN reviews r ON r.id = rp.id
+ JOIN', vnt, 'v ON v.id = r.vid
+ WHERE rp.uid =', \$u->{id}, auth->permBoardmod ? () : 'AND rp.hidden IS NULL', '
+ ) p(id,num,msg,title,date,hidden)';
- my $count = tuwf->dbVali('SELECT count(*)', $from_and_where);
- my $list = $count && tuwf->dbPagei(
- { results => 50, page => $page },
- 'SELECT tp.tid, tp.num, substring(tp.msg from 1 for 1000) as msg, t.title
- , ', sql_totime('tp.date'), 'as date',
- $from_and_where, 'ORDER BY tp.date DESC'
+ my $count = tuwf->dbVali('SELECT count(*) FROM', $sql);
+ my $list = $count && tuwf->dbPagei({ results => 50, page => $page },
+ 'SELECT id, num, substring(msg from 1 for 1000) as msg, title, ', sql_totime('date'), 'as date, hidden
+ FROM ', $sql, 'ORDER BY date DESC'
);
- my $own = auth && $u->{id} == auth->uid;
+ my $own = auth && $u->{id} eq auth->uid;
my $title = $own ? 'My posts' : 'Posts by '.user_displayname $u;
- framework_ title => $title, type => 'u', dbobj => $u, tab => 'posts',
+ framework_ title => $title, dbobj => $u, tab => 'posts',
sub {
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ $title;
if(!$count) {
p_ +($own ? 'You have' : user_displayname($u).' has').' not posted anything on the forums yet.';
diff --git a/lib/VNWeb/Docs/Edit.pm b/lib/VNWeb/Docs/Edit.pm
index dfab77a3..2e33432a 100644
--- a/lib/VNWeb/Docs/Edit.pm
+++ b/lib/VNWeb/Docs/Edit.pm
@@ -5,9 +5,9 @@ use VNWeb::Docs::Lib;
my $FORM = {
- id => { id => 1 },
- title => { maxlength => 200 },
- content => { required => 0, default => '' },
+ id => { vndbid => 'd' },
+ title => { sl => 1, maxlength => 200 },
+ content => { default => '' },
hidden => { anybool => 1 },
locked => { anybool => 1 },
@@ -20,36 +20,36 @@ my $FORM_CMP = form_compile cmp => $FORM;
TUWF::get qr{/$RE{drev}/edit} => sub {
- my $d = db_entry d => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ my $d = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound;
return tuwf->resDenied if !can_edit d => $d;
- $d->{editsum} = $d->{chrev} == $d->{maxrev} ? '' : "Reverted to revision d$d->{id}.$d->{chrev}";
+ $d->{editsum} = $d->{chrev} == $d->{maxrev} ? '' : "Reverted to revision $d->{id}.$d->{chrev}";
- framework_ title => "Edit $d->{title}", type => 'd', dbobj => $d, tab => 'edit',
+ framework_ title => "Edit $d->{title}", dbobj => $d, tab => 'edit',
sub {
- elm_ DocEdit => $FORM_OUT, $d;
+ div_ widget(DocEdit => $FORM_OUT, $d), '';
};
};
-elm_api DocEdit => $FORM_OUT, $FORM_IN, sub {
+js_api DocEdit => $FORM_IN, sub {
my $data = shift;
- my $doc = db_entry d => $data->{id} or return tuwf->resNotFound;
+ my $doc = db_entry $data->{id} or return tuwf->resNotFound;
- return elm_Unauth if !can_edit d => $doc;
- return elm_Unchanged if !form_changed $FORM_CMP, $data, $doc;
+ return tuwf->resDenied if !can_edit d => $doc;
+ return +{ _err => 'No changes' } if !form_changed $FORM_CMP, $data, $doc;
$data->{html} = md2html $data->{content};
- my($id,undef,$rev) = db_edit d => $doc->{id}, $data;
- elm_Redirect "/d$id.$rev";
+ my $c = db_edit d => $doc->{id}, $data;
+ +{ _redir => "/$c->{nitemid}.$c->{nrev}" };
};
-elm_api Markdown => undef, {
- content => { required => 0, default => '' }
+js_api Markdown => {
+ content => { default => '' }
}, sub {
- return elm_Unauth if !auth->permDbmod;
- elm_Content enrich_html md2html shift->{content};
+ return tuwf->resDenied if !auth->permDbmod;
+ +{ html => enrich_html md2html shift->{content} };
};
diff --git a/lib/VNWeb/Docs/Lib.pm b/lib/VNWeb/Docs/Lib.pm
index e6805d45..9a0cb6f9 100644
--- a/lib/VNWeb/Docs/Lib.pm
+++ b/lib/VNWeb/Docs/Lib.pm
@@ -1,20 +1,24 @@
package VNWeb::Docs::Lib;
use VNWeb::Prelude;
+use VNDB::Skins;
our @EXPORT = qw/enrich_html/;
+my @special_perms = qw/boardmod dbmod usermod tagmod/;
+
sub _moderators {
- my $l = tuwf->dbAlli('SELECT id, username, perm FROM users WHERE (perm & ', \(auth->allPerms &~ auth->defaultPerms), ') > 0 ORDER BY id LIMIT 100');
- my @modperms = grep 0 == (auth->listPerms->{$_} & auth->defaultPerms), keys auth->listPerms->%*;
+ my $cols = sql_comma map "perm_$_", @special_perms;
+ my $where = sql_or map "perm_$_", @special_perms;
+ state $l //= tuwf->dbAlli("SELECT u.id, username, $cols FROM users u JOIN users_shadow us ON us.id = u.id WHERE $where ORDER BY u.id LIMIT 100");
xml_string sub {
dl_ sub {
for my $u (@$l) {
- dt_ sub { a_ href => "/u$u->{id}", $u->{username} };
- dd_ auth->allPerms == ($u->{perm} & auth->allPerms) ? 'admin'
- : join ', ', sort grep $u->{perm} & auth->listPerms->{$_}, @modperms;
+ dt_ sub { a_ href => "/$u->{id}", $u->{username} };
+ dd_ @special_perms == grep($u->{"perm_$_"}, @special_perms) ? 'admin'
+ : join ', ', grep $u->{"perm_$_"}, @special_perms;
}
}
}
@@ -23,15 +27,15 @@ sub _moderators {
sub _skincontrib {
my %users;
- push $users{ tuwf->{skins}{$_}[1] }->@*, [ $_, tuwf->{skins}{$_}[0] ]
- for sort { tuwf->{skins}{$a}[0] cmp tuwf->{skins}{$b}[0] } keys tuwf->{skins}->%*;
+ push $users{ skins->{$_}{userid} }->@*, [ $_, skins->{$_}{name} ]
+ for sort { skins->{$a}{name} cmp skins->{$b}{name} } keys skins->%*;
- my $u = tuwf->dbAlli('SELECT id, username FROM users WHERE id IN', [keys %users]);
+ my $u = tuwf->dbAlli('SELECT id, username FROM users WHERE id IN', [keys %users], 'ORDER BY id');
xml_string sub {
dl_ sub {
for my $u (@$u) {
- dt_ sub { a_ href => "/u$u->{id}", $u->{username} };
+ dt_ sub { a_ href => "/$u->{id}", $u->{username} };
dd_ sub {
join_ ', ', sub { a_ href => "?skin=$_->[0]", $_->[1] }, $users{$u->{id}}->@*
}
diff --git a/lib/VNWeb/Docs/Page.pm b/lib/VNWeb/Docs/Page.pm
index 4c12f668..e9949ab3 100644
--- a/lib/VNWeb/Docs/Page.pm
+++ b/lib/VNWeb/Docs/Page.pm
@@ -6,7 +6,7 @@ use VNWeb::Docs::Lib;
sub _index_ {
ul_ class => 'index', sub {
- li_ sub { b_ 'Guidelines' };
+ li_ sub { strong_ 'Guidelines' };
li_ sub { a_ href => '/d5', 'Editing Guidelines' };
li_ sub { a_ href => '/d2', 'Visual Novels' };
li_ sub { a_ href => '/d15', 'Special Games' };
@@ -15,15 +15,15 @@ sub _index_ {
li_ sub { a_ href => '/d16', 'Staff' };
li_ sub { a_ href => '/d12', 'Characters' };
li_ sub { a_ href => '/d10', 'Tags & Traits' };
+ li_ sub { a_ href => '/d19', 'Image Flagging' };
li_ sub { a_ href => '/d13', 'Capturing Screenshots' };
- li_ sub { b_ 'About VNDB' };
+ li_ sub { strong_ 'About VNDB' };
li_ sub { a_ href => '/d9', 'Discussion Board' };
li_ sub { a_ href => '/d6', 'FAQ' };
li_ sub { a_ href => '/d7', 'About Us' };
li_ sub { a_ href => '/d17', 'Privacy Policy & Licensing' };
li_ sub { a_ href => '/d11', 'Database API' };
li_ sub { a_ href => '/d14', 'Database Dumps' };
- li_ sub { a_ href => '/d18', 'Database Querying' };
li_ sub { a_ href => '/d8', 'Development' };
}
}
@@ -31,20 +31,21 @@ sub _index_ {
sub _rev_ {
my $d = shift;
- revision_ d => $d, sub {},
+ revision_ $d, sub {},
[ title => 'Title' ],
[ content => 'Contents' ];
}
TUWF::get qr{/$RE{drev}} => sub {
- my $d = db_entry d => tuwf->capture('id'), tuwf->capture('rev');
+ my $d = db_entry tuwf->captures('id', 'rev');
return tuwf->resNotFound if !$d;
- framework_ title => $d->{title}, index => 1, type => 'd', dbobj => $d, hiddenmsg => 1,
+ framework_ title => $d->{title}, index => !tuwf->capture('rev'), dbobj => $d, hiddenmsg => 1,
sub {
_rev_ $d if tuwf->capture('rev');
- div_ class => 'mainbox', sub {
+ article_ sub {
+ itemmsg_ $d;
h1_ $d->{title};
div_ class => 'docs', sub {
_index_;
diff --git a/lib/VNWeb/Elm.pm b/lib/VNWeb/Elm.pm
index d98d1967..ad4f80a3 100644
--- a/lib/VNWeb/Elm.pm
+++ b/lib/VNWeb/Elm.pm
@@ -1,4 +1,4 @@
-# This module is responsible for generating elm/Gen/*.
+# This module is responsible for generating elm/Gen/*;
#
# It exports an `elm_api` function to create an API endpoint, type definitions,
# a JSON encoder and HTML5 validation attributes to simplify and synchronize
@@ -17,10 +17,13 @@ use List::Util 'max';
use VNDB::Config;
use VNDB::Types;
use VNDB::Func 'fmtrating';
+use VNDB::ExtLinks ();
+use VNDB::Skins;
+use VNWeb::Validation;
use VNWeb::Auth;
our @EXPORT = qw/
- elm_api
+ elm_api elm_empty
/;
@@ -30,57 +33,167 @@ our @EXPORT = qw/
# elm_Changed $id, $revision;
#
# These API responses are available in Elm in the `Gen.Api.Response` union type.
-my %apis = (
+our %apis = (
Unauth => [], # Not authorized
Unchanged => [], # No changes
Success => [],
Redirect => [{}], # Redirect to the given URL
- CSRF => [], # Invalid CSRF token
Invalid => [], # POST data did not validate the schema
+ Editsum => [], # Invalid edit summary
Content => [{}], # Rendered HTML content (for markdown/bbcode APIs)
- BadLogin => [], # Invalid user or pass
- LoginThrottle => [], # Too many failed login attempts
- InsecurePass => [], # Password is in a dictionary or breach database
- BadEmail => [], # Unknown email address in password reset form
- Bot => [], # User didn't pass bot verification
- Taken => [], # Username already taken
- DoubleEmail => [], # Account with same email already exists
- DoubleIP => [], # Account with same IP already exists
- BadCurPass => [], # Current password is incorrect when changing password
- MailChange => [], # A confirmation mail has been sent to change a user's email address
+ ImgFormat => [], # Unrecognized image format
+ LabelId => [{uint => 1}], # Label created
+ DupNames => [ { aoh => { # Duplicate names/aliases (for tags & traits)
+ id => { vndbid => ['i','g'] },
+ name => {},
+ } } ],
Releases => [ { aoh => { # Response to 'Release'
- id => { id => 1 },
+ id => { vndbid => 'r' },
title => {},
- original => { required => 0, default => '' },
+ alttitle => { default => '' },
released => { uint => 1 },
rtype => {},
+ reso_x => { uint => 1 },
+ reso_y => { uint => 1 },
lang => { type => 'array', values => {} },
platforms=> { type => 'array', values => {} },
} } ],
+ Resolutions => [ { aoh => { # Response to 'Resolutions'
+ resolution => {},
+ count => { uint => 1 },
+ } } ],
+ Engines => [ { aoh => { # Response to 'Engines'
+ engine => {},
+ count => { uint => 1 },
+ } } ],
+ DRM => [ { aoh => { # Response to 'DRM'
+ name => {},
+ count => { uint => 1 },
+ } } ],
BoardResult => [ { aoh => { # Response to 'Boards'
- btype => {},
- iid => { required => 0, default => 0, id => 1 },
- title => { required => 0 },
+ btype => { enum => \%BOARD_TYPE },
+ iid => { default => undef, vndbid => ['p','v','u'] },
+ title => { default => undef },
} } ],
TagResult => [ { aoh => { # Response to 'Tags'
- id => { id => 1 },
+ id => { vndbid => 'g' },
+ name => {},
+ searchable => { anybool => 1 },
+ applicable => { anybool => 1 },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+ } } ],
+ TraitResult => [ { aoh => { # Response to 'Traits'
+ id => { vndbid => 'i' },
name => {},
searchable => { anybool => 1 },
applicable => { anybool => 1 },
- state => { int => 1 },
+ defaultspoil => { uint => 1 },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+ group_id => { default => undef, vndbid => 'i' },
+ group_name => { default => undef },
+ } } ],
+ VNResult => [ { aoh => { # Response to 'VN'
+ id => { vndbid => 'v' },
+ title => {},
+ hidden => { anybool => 1 },
+ } } ],
+ ProducerResult => [ { aoh => { # Response to 'Producers'
+ id => { vndbid => 'p' },
+ name => {},
+ altname => { default => undef },
+ } } ],
+ StaffResult => [ { aoh => { # Response to 'Staff'
+ id => { vndbid => 's' },
+ lang => {},
+ aid => { id => 1 },
+ title => {},
+ alttitle => {},
+ } } ],
+ CharResult => [ { aoh => { # Response to 'Chars'
+ id => { vndbid => 'c' },
+ title => {},
+ alttitle => {},
+ main => { default => undef, type => 'hash', keys => {
+ id => { vndbid => 'c' },
+ title => {},
+ alttitle => {},
+ } }
+ } } ],
+ AnimeResult => [ { aoh => { # Response to 'Anime'
+ id => { id => 1 },
+ title => {},
+ original => { default => '' },
+ } } ],
+ ImageResult => [ { aoh => { # Response to 'Images'
+ id => { vndbid => ['ch','cv','sf'] },
+ token => { default => undef },
+ width => { uint => 1 },
+ height => { uint => 1 },
+ votecount => { uint => 1 },
+ sexual_avg => { num => 1, default => undef },
+ sexual_stddev => { num => 1, default => undef },
+ violence_avg => { num => 1, default => undef },
+ violence_stddev => { num => 1, default => undef },
+ my_sexual => { uint => 1, default => undef },
+ my_violence => { uint => 1, default => undef },
+ my_overrule => { anybool => 1 },
+ entry => { default => undef, type => 'hash', keys => {
+ id => {},
+ title => {},
+ } },
+ votes => { unique => 0, aoh => {
+ user => {},
+ uid => { vndbid => 'u', default => undef },
+ sexual => { uint => 1 },
+ violence => { uint => 1 },
+ ignore => { anybool => 1 },
+ } },
} } ],
);
-
-
-# Generate the elm_Response() functions
+# (These references to other API results cause redundant Elm code - can be deduplicated)
+$apis{AdvSearchQuery} = [ { type => 'hash', keys => { # Response to 'AdvSearchLoad'
+ qtype => {},
+ query => { type => 'any' },
+ producers => $apis{ProducerResult}[0],
+ staff => $apis{StaffResult}[0],
+ tags => $apis{TagResult}[0],
+ traits => $apis{TraitResult}[0],
+ anime => $apis{AnimeResult}[0],
+} } ];
+$apis{UListWidget} = [ { type => 'hash', keys => { # Initialization for UList.Widget and response to UListWidget
+ uid => { vndbid => 'u' },
+ vid => { vndbid => 'v' },
+ # Only includes selected labels, null if the VN is not on the list at all.
+ labels => { default => undef, aoh => { id => { int => 1 }, label => {default => ''} } },
+ # Can be set to null to lazily load the extra data as needed
+ full => { default => undef, type => 'hash', keys => {
+ title => {},
+ labels => { aoh => { id => { int => 1 }, label => {}, private => { anybool => 1 } } },
+ canvote => { anybool => 1 },
+ canreview => { anybool => 1 },
+ vote => { vnvote => 1 },
+ review => { default => undef, vndbid => 'w' },
+ notes => { default => '' },
+ started => { default => '' },
+ finished => { default => '' },
+ releases => $apis{Releases}[0],
+ rlist => { aoh => { id => { vndbid => 'r' }, status => { uint => 1 } } },
+ } },
+} } ];
+
+
+# Compile %apis into a %schema and generate the elm_Response() functions
+my %schemas;
for my $name (keys %apis) {
no strict 'refs';
- $apis{$name} = [ map tuwf->compile($_), $apis{$name}->@* ];
+ $schemas{$name} = [ map tuwf->compile($_), $apis{$name}->@* ];
*{'elm_'.$name} = sub {
my @args = map {
- $apis{$name}[$_]->validate($_[$_])->data if tuwf->debug;
- $apis{$name}[$_]->analyze->coerce_for_json($_[$_], unknown => 'reject')
- } 0..$#{$apis{$name}};
+ $schemas{$name}[$_]->validate($_[$_])->data if tuwf->debug;
+ $schemas{$name}[$_]->analyze->coerce_for_json($_[$_], unknown => 'reject')
+ } 0..$#{$schemas{$name}};
tuwf->resJSON({$name, \@args})
};
push @EXPORT, 'elm_'.$name;
@@ -107,14 +220,16 @@ sub def_type {
my $data = '';
my @keys = $obj->{keys} ? grep $obj->{keys}{$_}{keys}||($obj->{keys}{$_}{values}&&$obj->{keys}{$_}{values}{keys}), sort keys $obj->{keys}->%* : ();
- $data .= def_type($name . to_camel($_), $obj->{keys}{$_}{values} || $obj->{keys}{$_}) for @keys;
+ $data .= def_type($name . to_camel($_), $obj->{keys}{$_}{values} || bless { $obj->{keys}{$_}->%*, required => 1 }, ref $obj->{keys}{$_} ) for @keys;
$data .= sprintf "\ntype alias %s = %s\n\n", $name, $obj->elm_type(
+ any => 'JE.Value',
keys => +{ map {
my $t = $obj->{keys}{$_};
my $n = $name . to_camel($_);
$n = "List $n" if $t->{values};
$n = "Maybe ($n)" if $t->{values} && !$t->{required} && !defined $t->{default};
+ $n = "Maybe $n" if $t->{keys} && !$t->{required} && !defined $t->{default};
($_, $n)
} @keys }
);
@@ -134,12 +249,12 @@ sub def_validation {
my %v = $obj->html5_validation();
$data .= def $name, 'List (Html.Attribute msg)', '[ '.join(', ',
- $v{required} ? 'A.required True' : (),
- $v{minlength} ? "A.minlength $v{minlength}" : (),
- $v{maxlength} ? "A.maxlength $v{maxlength}" : (),
- $v{min} ? 'A.min '.string($v{min}) : (),
- $v{max} ? 'A.max '.string($v{max}) : (),
- $v{pattern} ? 'A.pattern '.string($v{pattern}) : ()
+ $v{required} ? 'A.required True' : (),
+ defined $v{minlength} ? "A.minlength $v{minlength}" : (),
+ defined $v{maxlength} ? "A.maxlength $v{maxlength}" : (),
+ defined $v{min} ? 'A.min '.string($v{min}) : (),
+ defined $v{max} ? 'A.max '.string($v{max}) : (),
+ $v{pattern} ? 'A.pattern '.string($v{pattern}) : ()
).']' if !$obj->{keys};
$data;
}
@@ -148,7 +263,7 @@ sub def_validation {
# Generate an Elm JSON encoder taking a corresponding def_type() as input
sub encoder {
my($name, $type, $obj) = @_;
- def $name, "$type -> JE.Value", $obj->elm_encoder(json_encode => 'JE.');
+ def $name, "$type -> JE.Value", $obj->elm_encoder(any => ' ', json_encode => 'JE.');
}
@@ -156,13 +271,14 @@ sub encoder {
sub write_module {
my($module, $contents) = @_;
- my $fn = sprintf '%s/elm/Gen/%s.elm', config->{root}, $module;
+ my $fn = sprintf '%s/elm/Gen/%s.elm', config->{gen_path}, $module;
# The imports aren't necessary in all the files, but might as well add them.
$contents = <<~"EOF";
-- This file is automatically generated from lib/VNWeb/Elm.pm.
-- Do not edit, your changes will be lost.
module Gen.$module exposing (..)
+ import Dict
import Http
import Html
import Html.Attributes as A
@@ -191,7 +307,7 @@ sub write_module {
# elm_api FormName => $OUT_SCHEMA, $IN_SCHEMA, sub {
# my($data) = @_;
# elm_Success # Or any other elm_Response() function
-# };
+# }, %extra_schemas;
#
# That will create an endpoint at `POST /elm/FormName.json` that accepts JSON
# data that must validate $IN_SCHEMA. The subroutine is given the validated
@@ -209,19 +325,19 @@ sub write_module {
# -- Command to send an API request to the endpoint and receive a response
# send : Send -> (Gen.Api.Response -> msg) -> Cmd msg
#
+# Extra type aliases can be added using %extra_schemas.
sub elm_api {
- my($name, $out, $in, $sub) = @_;
+ my($name, $out, $in, $sub, %extra) = @_;
- $in = ref $in eq 'HASH' ? tuwf->compile({ type => 'hash', keys => $in }) : $in;
- $out = ref $out eq 'HASH' ? tuwf->compile({ type => 'hash', keys => $out }) : $out;
+ my sub comp { ref $_[0] eq 'HASH' ? tuwf->compile({ type => 'hash', keys => $_[0] }) : $_[0] }
+ $in = comp $in;
TUWF::post qr{/elm/\Q$name\E\.json} => sub {
- if(!auth->csrfcheck(tuwf->reqHeader('X-CSRF-Token')||'')) {
- warn "Invalid CSRF token in request\n";
- return elm_CSRF();
- }
-
my $data = tuwf->validate(json => $in);
+ # Handle failure of the 'editsum' validation as a special case and return elm_Editsum().
+ if(!$data && $data->err->{errors} && grep $_->{validation} eq 'editsum' || ($_->{validation} eq 'required' && $_->{key} eq 'editsum'), $data->err->{errors}->@*) {
+ return elm_Editsum();
+ }
if(!$data) {
warn "JSON validation failed\ninput: " . JSON::XS->new->allow_nonref->pretty->canonical->encode(tuwf->reqJSON) . "\nerror: " . JSON::XS->new->encode($data->err) . "\n";
return elm_Invalid();
@@ -234,8 +350,9 @@ sub elm_api {
if(tuwf->{elmgen}) {
my $data = "import Gen.Api as GApi\n";
$data .= "import Lib.Api as Api\n";
- $data .= def_type Recv => $out->analyze if $out;
+ $data .= def_type Recv => comp($out)->analyze if $out;
$data .= def_type Send => $in->analyze;
+ $data .= def_type $_ => comp($extra{$_})->analyze for sort keys %extra;
$data .= def_validation val => $in->analyze;
$data .= encoder encode => 'Send', $in->analyze;
$data .= "send : Send -> (GApi.Response -> msg) -> Cmd msg\n";
@@ -245,6 +362,27 @@ sub elm_api {
}
+# Return a new, empty value that conforms to the given schema and can be parsed
+# by the generated Elm/json decoder for the same schema. It may not actually
+# validate according to the schema (e.g. required fields may be left empty).
+# Values are initialized as follows:
+# - If a 'default' has been set in the schema, that will be used.
+# - Nullable fields are initialized to undef
+# - Integers are initialized to 0
+# - Strings are initialized to ""
+# - Arrays are initialized to []
+sub elm_empty {
+ my($schema) = @_;
+ $schema = $schema->analyze if ref $schema eq 'TUWF::Validate';
+ return $schema->{default} if exists $schema->{default};
+ return undef if !$schema->{required};
+ return [] if $schema->{type} eq 'array';
+ return '' if $schema->{type} eq 'bool' || $schema->{type} eq 'scalar';
+ return 0 if $schema->{type} eq 'num' || $schema->{type} eq 'int';
+ return +{ map +($_, elm_empty($schema->{keys}{$_})), $schema->{keys} ? keys $schema->{keys}->%* : () } if $schema->{type} eq 'hash';
+ die "Unable to initialize required value of type '$schema->{type}' without a default";
+}
+
# Generate the Gen.Api module with the Response type and decoder.
sub write_api {
@@ -254,9 +392,9 @@ sub write_api {
# of the Elm code, similar to def_type().
my(@union, @decode);
my $data = '';
- my $len = max map length, keys %apis;
- for (sort keys %apis) {
- my($name, $schema) = ($_, $apis{$_});
+ my $len = max map length, keys %schemas;
+ for (sort keys %schemas) {
+ my($name, $schema) = ($_, $schemas{$_});
my $def = $name;
my $dec = sprintf 'JD.field "%s"%s <| %s', $name,
' 'x($len-(length $name)),
@@ -290,28 +428,66 @@ sub write_api {
sub write_types {
my $data = '';
- $data .= def urlStatic => String => string config->{url_static};
- $data .= def adminEMail => String => string config->{admin_email};
- $data .= def userPerms => 'List (Int, String)' => list map tuple(VNWeb::Auth::listPerms->{$_}, string $_), sort keys VNWeb::Auth::listPerms->%*;
- $data .= def skins => 'List (String, String)' =>
- list map tuple(string $_, string tuwf->{skins}{$_}[0]),
- sort { tuwf->{skins}{$a}[0] cmp tuwf->{skins}{$b}[0] } keys tuwf->{skins}->%*;
- $data .= def languages => 'List (String, String)' => list map tuple(string $_, string $LANGUAGE{$_}), sort { $LANGUAGE{$a} cmp $LANGUAGE{$b} } keys %LANGUAGE;
+ $data .= def languages => 'List (String, String)' => list map tuple(string $_, string $LANGUAGE{$_}{txt}), sort { $LANGUAGE{$a}{txt} cmp $LANGUAGE{$b}{txt} } keys %LANGUAGE;
$data .= def platforms => 'List (String, String)' => list map tuple(string $_, string $PLATFORM{$_}), keys %PLATFORM;
$data .= def releaseTypes => 'List (String, String)' => list map tuple(string $_, string $RELEASE_TYPE{$_}), keys %RELEASE_TYPE;
- $data .= def rlistStatus => 'List (Int, String)' => list map tuple($_, string $RLIST_STATUS{$_}), keys %RLIST_STATUS;
+ $data .= def media => 'List (String, String, Bool)' => list map tuple(string $_, string $MEDIUM{$_}{txt}, $MEDIUM{$_}{qty}?'True':'False'), keys %MEDIUM;
+ $data .= def rlistStatus=> 'List (Int, String)' => list map tuple($_, string $RLIST_STATUS{$_}), keys %RLIST_STATUS;
$data .= def boardTypes => 'List (String, String)' => list map tuple(string $_, string $BOARD_TYPE{$_}{txt}), keys %BOARD_TYPE;
- $data .= def ratings => 'List String' => list map string(fmtrating $_), 1..10;
+ $data .= def ratings => 'List String' => list map string(fmtrating $_), 1..10;
+ $data .= def ageRatings => 'List (Int, String)' => list map tuple($_, string $AGE_RATING{$_}{txt}.($AGE_RATING{$_}{ex}?" ($AGE_RATING{$_}{ex})":'')), keys %AGE_RATING;
+ $data .= def devStatus => 'List (Int, String)' => list map tuple($_, string $DEVSTATUS{$_}), keys %DEVSTATUS;
+ $data .= def voiced => 'List (Int, String)' => list map tuple($_, string $VOICED{$_}{txt}), keys %VOICED;
+ $data .= def animated => 'List (Int, String)' => list map tuple($_, string $ANIMATED{$_}{txt}), keys %ANIMATED;
+ $data .= def genders => 'List (String, String)' => list map tuple(string $_, string $GENDER{$_}), keys %GENDER;
+ $data .= def cupSizes => 'List (String, String)' => list map tuple(string $_, string $CUP_SIZE{$_}), keys %CUP_SIZE;
+ $data .= def bloodTypes => 'List (String, String)' => list map tuple(string $_, string $BLOOD_TYPE{$_}), keys %BLOOD_TYPE;
+ $data .= def charRoles => 'List (String, String)' => list map tuple(string $_, string $CHAR_ROLE{$_}{txt}), keys %CHAR_ROLE;
+ $data .= def vnLengths => 'List (Int, String)' => list map tuple($_, string $VN_LENGTH{$_}{txt}.($VN_LENGTH{$_}{time}?" ($VN_LENGTH{$_}{time})":'')), keys %VN_LENGTH;
+ $data .= def vnRelations=> 'List (String, String)' => list map tuple(string $_, string $VN_RELATION{$_}{txt}), keys %VN_RELATION;
+ $data .= def creditTypes=> 'List (String, String)' => list map tuple(string $_, string $CREDIT_TYPE{$_}), keys %CREDIT_TYPE;
+ $data .= def producerRelations=> 'List (String, String)' => list map tuple(string $_, string $PRODUCER_RELATION{$_}{txt}), keys %PRODUCER_RELATION;
+ $data .= def producerTypes=> 'List (String, String)' => list map tuple(string $_, string $PRODUCER_TYPE{$_}), keys %PRODUCER_TYPE;
+ $data .= def tagCategories=> 'List (String, String)' => list map tuple(string $_, string $TAG_CATEGORY{$_}), keys %TAG_CATEGORY;
+ $data .= def curYear => Int => (gmtime)[5]+1900;
write_module Types => $data;
}
+sub write_extlinks {
+ my $data =<<~'_';
+ import Regex
+
+ type alias Site =
+ { name : String
+ , advid : String
+ }
+ _
+
+ my sub links {
+ my($name, @links) = @_;
+ $data .= def $name.'Sites' => "List (Site)" => list map {
+ my $l = $_;
+ my $addval = $l->{int} ? 'toint v' : 'v';
+ '{ '.join("\n , ",
+ 'name = '.string($l->{name}),
+ 'advid = '.string($l->{id} =~ s/^l_//r),
+ )."\n }";
+ } @links;
+ }
+ links release => VNDB::ExtLinks::extlinks_sites('r');
+ links staff => VNDB::ExtLinks::extlinks_sites('s');
+
+ write_module ExtLinks => $data;
+}
+
+
if(tuwf->{elmgen}) {
- mkdir config->{root}.'/elm/Gen';
write_api;
write_types;
- open my $F, '>', config->{root}.'/elm/Gen/.generated';
+ write_extlinks;
+ open my $F, '>', config->{gen_path}.'/elm/Gen/.generated';
print $F scalar gmtime;
}
diff --git a/lib/VNWeb/Filters.pm b/lib/VNWeb/Filters.pm
new file mode 100644
index 00000000..b422ad8c
--- /dev/null
+++ b/lib/VNWeb/Filters.pm
@@ -0,0 +1,246 @@
+package VNWeb::Filters;
+
+# This module implements validating old search filters and converting them to
+# the new AdvSearch system. It only exists for compatibility with old URLs.
+
+use v5.26;
+use TUWF;
+use VNDB::Types;
+use VNWeb::Auth;
+use VNWeb::Validation;
+use Exporter 'import';
+
+our @EXPORT = qw/filter_parse filter_vn_adv filter_release_adv filter_char_adv filter_staff_adv/;
+
+
+my $VN = form_compile any => {
+ date_before => { default => undef, uint => 1, range => [0, 99999999] }, # don't use 'rdate' validation here, the search form allows invalid dates
+ date_after => { default => undef, uint => 1, range => [0, 99999999] }, # ^
+ released => { undefbool => 1 },
+ length => { undefarray => { enum => \%VN_LENGTH } },
+ hasani => { undefbool => 1 },
+ hasshot => { undefbool => 1 },
+ tag_inc => { undefarray => { id => 1 } },
+ tag_exc => { undefarray => { id => 1 } },
+ taginc => { undefarray => {} }, # [old] Tag search by name
+ tagexc => { undefarray => {} }, # [old] Tag search by name
+ tagspoil => { default => 0, uint => 1, range => [0,2] },
+ lang => { undefarray => { enum => \%LANGUAGE } },
+ olang => { undefarray => { enum => \%LANGUAGE } },
+ plat => { undefarray => { enum => \%PLATFORM } },
+ staff_inc => { undefarray => { id => 1 } },
+ staff_exc => { undefarray => { id => 1 } },
+ ul_notblack => { undefbool => 1 },
+ ul_onwish => { undefbool => 1 },
+ ul_voted => { undefbool => 1 },
+ ul_onlist => { undefbool => 1 },
+};
+
+my $RELEASE = form_compile any => {
+ type => { default => undef, enum => \%RELEASE_TYPE },
+ patch => { undefbool => 1 },
+ freeware => { undefbool => 1 },
+ doujin => { undefbool => 1 },
+ uncensored => { undefbool => 1 },
+ date_before => { default => undef, range => [0, 99999999] }, # don't use 'rdate' validation here, the search form allows invalid dates
+ date_after => { default => undef, range => [0, 99999999] }, # ^
+ released => { undefbool => 1 },
+ minage => { undefarray => { enum => [-1, keys %AGE_RATING] } },
+ lang => { undefarray => { enum => \%LANGUAGE } },
+ olang => { undefarray => { enum => \%LANGUAGE } },
+ resolution => { undefarray => {} },
+ plat => { undefarray => { enum => [ 'unk', keys %PLATFORM ] } },
+ prod_inc => { undefarray => { id => 1 } },
+ prod_exc => { undefarray => { id => 1 } },
+ med => { undefarray => { enum => [ 'unk', keys %MEDIUM ] } },
+ voiced => { undefarray => { enum => \%VOICED } },
+ ani_story => { undefarray => { enum => \%ANIMATED } },
+ ani_ero => { undefarray => { enum => \%ANIMATED } },
+ engine => { default => undef },
+};
+
+my $CHAR = form_compile any => {
+ gender => { undefarray => { enum => \%GENDER } },
+ bloodt => { undefarray => { enum => \%BLOOD_TYPE } },
+ bust_min => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ bust_max => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ waist_min => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ waist_max => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ hip_min => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ hip_max => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ height_min => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ height_max => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ weight_min => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ weight_max => { default => undef, uint => 1, range => [ 0, 32767 ] },
+ cup_min => { default => undef, enum => \%CUP_SIZE },
+ cup_max => { default => undef, enum => \%CUP_SIZE },
+ va_inc => { undefarray => { id => 1 } },
+ va_exc => { undefarray => { id => 1 } },
+ trait_inc => { undefarray => { id => 1 } },
+ trait_exc => { undefarray => { id => 1 } },
+ tagspoil => { default => 0, uint => 1, range => [0,2] },
+ role => { undefarray => { enum => \%CHAR_ROLE } },
+};
+
+my $STAFF = form_compile any => {
+ gender => { undefarray => { enum => [qw[unknown m f]] } },
+ role => { undefarray => { enum => [ 'seiyuu', keys %CREDIT_TYPE ] } },
+ truename => { undefbool => 1 },
+ lang => { undefarray => { enum => \%LANGUAGE } },
+};
+
+
+
+# Compatibility with old VN filters. Modifies the filter in-place and returns the number of changes made.
+sub filter_vn_compat {
+ my($fil) = @_; #XXX: This function is called from old VNDB:: code and the filter data may not have been normalized as per the schema.
+ my $mod = 0;
+
+ # older tag specification (by name rather than ID)
+ for ('taginc', 'tagexc') {
+ my $l = delete $fil->{$_};
+ next if !$l;
+ $l = [ map lc($_), ref $l ? @$l : $l ];
+ $fil->{ s/^tag/tag_/rg } ||= [ map $_->{id}, tuwf->dbAlli(
+ 'SELECT DISTINCT id FROM tags WHERE searchable AND lower(name) IN', $l
+ )->@* ];
+ $mod++;
+ }
+
+ $mod;
+}
+
+
+# Resolutions were passed as integers into an array index before 6bd0b0cd1f3892253d881f71533940f0cf07c13d.
+# New resolutions have been added to this array in the past, so some older filters may reference the wrong resolution.
+my @OLDRES = (qw/unknown nonstandard 640x480 800x600 1024x768 1280x960 1600x1200 640x400 960x600 1024x576 1024x600 1024x640 1280x720 1280x800 1366x768 1600x900 1920x1080/);
+
+sub filter_release_compat {
+ my($fil) = @_;
+ my $mod = 0;
+ $fil->{resolution} &&= [ map /^(?:0|[1-9][0-9]*)$/ && $_ <= $#OLDRES ? do { $mod++; $OLDRES[$_] } : $_, $fil->{resolution}->@* ];
+ $mod;
+}
+
+
+
+my @fil_escape = split //, '_ !"#$%&\'()*+,-./:;<=>?@[\]^`{}~';
+
+sub _fil_parse {
+ my $str = shift;
+ my %r;
+ for (split /\./, $str) {
+ next if !/^([a-z0-9_]+)-([a-zA-Z0-9_~\x81-\x{ffffff}]+)$/;
+ my($f, $v) = ($1, $2);
+ my @v = split /~/, $v;
+ s/_([0-9]{2})/$1 > $#fil_escape ? '' : $fil_escape[$1]/eg for(@v);
+ $r{$f} = @v > 1 ? \@v : $v[0]
+ }
+ return \%r;
+}
+
+
+# Throws error on failure.
+sub filter_parse {
+ my($type, $str) = @_;
+ return {} if !$str;
+ my $s = {v => $VN, r => $RELEASE, c => $CHAR, s => $STAFF}->{$type};
+ my $data = ref $str ? $str : $str =~ /^{/ ? JSON::XS->new->decode($str) : _fil_parse $str;
+ die "Invalid filter data: $str\n" if !$data;
+ my $f = $s->validate($data)->data;
+ filter_vn_compat $f if $type eq 'v';
+ filter_release_compat $f if $type eq 'r';
+ $f
+}
+
+
+sub filter_vn_adv {
+ my($fil) = @_;
+ [ 'and',
+ defined $fil->{date_before} ? [ 'released', '<=', $fil->{date_before} ] : (),
+ defined $fil->{date_after} ? [ 'released', '>=', $fil->{date_after} ] : (),
+ defined $fil->{released} ? [ 'released', $fil->{released} ? '<=' : '>', 1 ] : (),
+ defined $fil->{length} ? [ 'or', map [ 'length', '=', $_ ], $fil->{length}->@* ] : (),
+ defined $fil->{hasani} ? [ 'has_anime', $fil->{hasani} ? '=' : '!=', 1 ] : (),
+ defined $fil->{hasshot} ? [ 'has_screenshot', $fil->{hasshot} ? '=' : '!=', 1 ] : (),
+ defined $fil->{tag_inc} ? [ 'and', map [ 'tag', '=', [ $_, $fil->{tagspoil}, 0 ] ], $fil->{tag_inc}->@* ] : (),
+ defined $fil->{tag_exc} ? [ 'and', map [ 'tag', '!=', [ $_, 2, 0 ] ], $fil->{tag_exc}->@* ] : (),
+ defined $fil->{lang} ? [ 'or', map [ 'lang', '=', $_ ], $fil->{lang}->@* ] : (),
+ defined $fil->{olang} ? [ 'or', map [ 'olang', '=', $_ ], $fil->{olang}->@* ] : (),
+ defined $fil->{plat} ? [ 'or', map [ 'platform', '=', $_ ], $fil->{plat}->@* ] : (),
+ defined $fil->{staff_inc} ? [ 'staff', '=', [ 'or', map [ 'id', '=', $_ ], $fil->{staff_inc}->@* ] ] : (),
+ defined $fil->{staff_exc} ? [ 'staff', '!=', [ 'or', map [ 'id', '=', $_ ], $fil->{staff_exc}->@* ] ] : (),
+ auth ? (
+ defined $fil->{ul_notblack} ? [ 'label', '!=', [ auth->uid, 6 ] ] : (),
+ defined $fil->{ul_onwish} ? [ 'label', $fil->{ul_onwish} ? '=' : '!=', [ auth->uid, 5 ] ] : (),
+ defined $fil->{ul_voted} ? [ 'label', $fil->{ul_voted} ? '=' : '!=', [ auth->uid, 7 ] ] : (),
+ defined $fil->{ul_onlist} ? [ 'on-list', $fil->{ul_onlist} ? '=' : '!=', 1 ] : (),
+ ) : ()
+ ]
+}
+
+
+sub filter_release_adv {
+ my($fil) = @_;
+ [ 'and',
+ defined $fil->{type} ? [ 'rtype', '=', $fil->{type} ] : (),
+ defined $fil->{patch} ? [ 'patch', $fil->{patch} ? '=' : '!=', 1 ] : (),
+ defined $fil->{freeware} ? [ 'freeware', $fil->{freeware} ? '=' : '!=', 1 ] : (),
+ defined $fil->{doujin} ? [ 'doujin', $fil->{doujin} ? '=' : '!=', 1 ] : (),
+ defined $fil->{uncensored} ? [ 'uncensored', $fil->{uncensored} ? '=' : '!=', 1 ] : (),
+ defined $fil->{date_before} ? [ 'released', '<=', $fil->{date_before} ] : (),
+ defined $fil->{date_after} ? [ 'released', '>=', $fil->{date_after} ] : (),
+ defined $fil->{released} ? [ 'released', $fil->{released} ? '<=' : '>', 1 ] : (),
+ defined $fil->{minage} ? [ 'or', map [ 'minage', '=', $_ == -1 ? undef : $_ ], $fil->{minage}->@* ] : (),
+ defined $fil->{lang} ? [ 'or', map [ 'lang', '=', $_ ], $fil->{lang}->@* ] : (),
+ defined $fil->{olang} ? [ 'vn', '=', [ 'or', map [ 'olang', '=', $_ ], $fil->{olang}->@* ] ] : (),
+ defined $fil->{resolution} ? [ 'or', map [ 'resolution', '=', $_ eq 'unknown' ? [0,0] : $_ eq 'nonstandard' ? [0,1] : [split /x/] ], $fil->{resolution}->@* ] : (),
+ defined $fil->{plat} ? [ 'or', map [ 'platform', '=', $_ eq 'unk' ? '' : $_ ], $fil->{plat}->@* ] : (),
+ defined $fil->{prod_inc} ? [ 'or', map [ 'producer-id', '=', $_ ], $fil->{prod_inc}->@* ] : (),
+ defined $fil->{prod_exc} ? [ 'and', map [ 'producer-id', '!=', $_ ], $fil->{prod_exc}->@* ] : (),
+ defined $fil->{med} ? [ 'or', map [ 'medium', '=', $_ eq 'unk' ? '' : $_ ], $fil->{med}->@* ] : (),
+ defined $fil->{voiced} ? [ 'or', map [ 'voiced', '=', $_ ], $fil->{voiced}->@* ] : (),
+ defined $fil->{ani_story} ? [ 'or', map [ 'animation-story', '=', $_ ], $fil->{ani_story}->@* ] : (),
+ defined $fil->{ani_ero} ? [ 'or', map [ 'animation-ero', '=', $_ ], $fil->{ani_ero}->@* ] : (),
+ defined $fil->{engine} ? [ 'engine', '=', $fil->{engine} ] : (),
+ ]
+}
+
+
+sub filter_char_adv {
+ my($fil) = @_;
+ [ 'and',
+ defined $fil->{gender} ? [ 'or', map [ 'sex', '=', $_ ], $fil->{gender}->@* ] : (),
+ defined $fil->{bloodt} ? [ 'or', map [ 'blood_type', '=', $_ ], $fil->{bloodt}->@* ] : (),
+ defined $fil->{bust_min} ? [ 'bust', '>=', $fil->{bust_min} ] : (),
+ defined $fil->{bust_max} ? [ 'bust', '<=', $fil->{bust_max} ] : (),
+ defined $fil->{waist_min} ? [ 'waist', '>=', $fil->{waist_min} ] : (),
+ defined $fil->{waist_max} ? [ 'waist', '<=', $fil->{waist_max} ] : (),
+ defined $fil->{hip_min} ? [ 'hips', '>=', $fil->{hip_min} ] : (),
+ defined $fil->{hip_max} ? [ 'hips', '<=', $fil->{hip_max} ] : (),
+ defined $fil->{height_min} ? [ 'height', '>=', $fil->{height_min} ] : (),
+ defined $fil->{height_max} ? [ 'height', '<=', $fil->{height_max} ] : (),
+ defined $fil->{weight_min} ? [ 'weight', '>=', $fil->{weight_min} ] : (),
+ defined $fil->{weight_max} ? [ 'weight', '<=', $fil->{weight_max} ] : (),
+ defined $fil->{cup_min} ? [ 'cup', '>=', $fil->{cup_min} ] : (),
+ defined $fil->{cup_max} ? [ 'cup', '<=', $fil->{cup_max} ] : (),
+ defined $fil->{va_inc} ? [ 'seiyuu', '=', [ 'or', map [ 'id', '=', $_ ], $fil->{va_inc}->@* ] ] : (),
+ defined $fil->{va_exc} ? [ 'seiyuu', '!=', [ 'or', map [ 'id', '=', $_ ], $fil->{va_exc}->@* ] ] : (),
+ defined $fil->{trait_inc} ? [ 'and', map [ 'trait', '=', [ $_, $fil->{tagspoil} ] ], $fil->{trait_inc}->@* ] : (),
+ defined $fil->{trait_exc} ? [ 'and', map [ 'trait', '!=', [ $_, 2 ] ], $fil->{trait_exc}->@* ] : (),
+ defined $fil->{role} ? [ 'or', map [ 'role', '=', $_ ], $fil->{role}->@* ] : (),
+ ]
+}
+
+
+# 'truename' filter is ignored, not part of the AdvSearch interface
+sub filter_staff_adv {
+ my($fil) = @_;
+ [ 'and',
+ defined $fil->{gender} ? [ 'or', map [ 'gender', '=', $_ ], $fil->{gender}->@* ] : (),
+ defined $fil->{role} ? [ 'or', map [ 'role', '=', $_ ], $fil->{role}->@* ] : (),
+ defined $fil->{lang} ? [ 'or', map [ 'lang', '=', $_ ], $fil->{lang}->@* ] : (),
+ ]
+}
+
+1;
diff --git a/lib/VNWeb/Graph.pm b/lib/VNWeb/Graph.pm
new file mode 100644
index 00000000..8505923c
--- /dev/null
+++ b/lib/VNWeb/Graph.pm
@@ -0,0 +1,119 @@
+package VNWeb::Graph;
+
+# Utility functions for VNWeb::Producers::Graph anv VNWeb::VN::Graph.
+
+use v5.26;
+use AnyEvent::Util;
+use TUWF::XML 'xml_escape';
+use Exporter 'import';
+use List::Util 'max';
+use VNDB::Config;
+use VNDB::Func 'idcmp';
+
+our @EXPORT = qw/gen_nodes dot2svg val_escape node_more gen_dot/;
+
+
+# Given a starting ID, an array of {id0,id1} relation hashes and a number of
+# nodes to be included, returns a hash of (id=>{id, distance, rels}) nodes.
+#
+# This is basically a breath-first search that prioritizes nodes with fewer
+# relations. Direct relations with the starting node are always included,
+# regardless of $num.
+sub gen_nodes {
+ my($id, $rel, $num) = @_;
+
+ my %rels;
+ push $rels{$_->{id0}}->@*, $_->{id1} for @$rel;
+
+ my %nodes;
+ my @q = ({ id => $id, distance => 0 });
+ while(my $n = shift @q) {
+ next if $nodes{$n->{id}};
+ last if $num <= 0 && $n->{distance} > 1;
+ $num--;
+ $n->{rels} = $rels{$n->{id}};
+ $nodes{$n->{id}} = $n;
+ push @q, map +{ id => $_, distance => $n->{distance}+1 }, sort { $rels{$a}->@* <=> $rels{$b}->@* } grep !$nodes{$_}, $n->{rels}->@*;
+ }
+
+ \%nodes;
+}
+
+
+sub dot2svg {
+ my($dot) = @_;
+
+ utf8::encode $dot;
+ my $e = run_cmd([config->{graphviz_path},'-Tsvg'], '<', \$dot, '>', \my $out, '2>', \my $err)->recv;
+ warn "graphviz STDERR: $err\n" if chomp $err;
+ $e and die "Failed to run graphviz";
+
+ # - Remove <?xml> declaration and <!DOCTYPE> (not compatible with embedding in HTML5)
+ # - Remove comments (unused)
+ # - Remove <title> elements (unused)
+ # - Remove first <polygon> element (emulates a background color)
+ # - Replace stroke and fill attributes with classes (so that coloring is done in CSS)
+ # (I used to have an implementation based on XML::Parser, but regexes are so much faster...)
+ utf8::decode $out or die;
+ $out=~ s/<\?xml.+?\?>//r
+ =~ s/<!DOCTYPE[^>]*>//r
+ =~ s/<!--.*?-->//srg
+ =~ s/<title>.+?<\/title>//gr
+ =~ s/<polygon.+?\/>//r
+ =~ s/ font-size="9[^"]+"/ class="title"/gr
+ =~ s/ font-size="[^"]+"//gr
+ =~ s/ font-family="[^"]+"//gr
+ =~ s/ (?:stroke|fill)="([^"]+)"/$1 eq '#111111' ? ' class="border"' : $1 eq '#222222' ? ' class="nodebg"' : ''/egr;
+}
+
+
+sub val_escape { $_[0] =~ s/&/&amp;/rg =~ s/\\/\\\\/rg =~ s/"/&quot;/rg =~ s/</&lt;/rg =~ s/>/&gt;/rg }
+
+
+sub node_more {
+ my($id, $url, $number) = @_;
+ return () if !$number;
+ (
+ qq|\tns$id [ URL = "$url", label="$number more..." ]|,
+ qq|\tn$id -- ns$id [ dir = "forward", style = "dashed" ]|
+ )
+}
+
+
+sub gen_dot {
+ my($lines, $nodes, $rel, $rel_types) = @_;
+
+ # Attempt to figure out a good 'rankdir' to minimize the width of the
+ # graph. Ideally we'd just generate two graphs and pick the least wide one,
+ # but that's way too slow. Graphviz tends to put adjacent nodes next to
+ # each other, so going for the LR (left-right) rank order tends to work
+ # better with large fan-out, while TB (top-bottom) often results in less
+ # wide graphs for large depths.
+ #my $max_distance = max map $_->{distance}, values %$nodes;
+ my $max_fanout = max map scalar grep($nodes->{$_}, $_->{rels}->@*), values %$nodes;
+ my $rankdir = $max_fanout > 6 ? 'LR' : 'TB';
+
+ for (@$rel) {
+ next if idcmp($_->{id0}, $_->{id1}) < 0;
+ my $r1 = $rel_types->{$_->{relation}};
+ my $r2 = $rel_types->{ $r1->{reverse} };
+ my $style = exists $_->{official} && !$_->{official} ? 'style="dotted", ' : '';
+ push @$lines,
+ qq|n$_->{id0} -- n$_->{id1} [$style|.(
+ $r1 == $r2 ? qq|label="$r1->{txt}"| :
+ $r1->{pref} ? qq|headlabel="$r1->{txt}", dir = "forward"| :
+ $r2->{pref} ? qq|taillabel="$r2->{txt}", dir = "back"| :
+ qq|headlabel="$r1->{txt}", taillabel="$r2->{txt}"|
+ ).']';
+ }
+
+ qq|graph rgraph {\n|.
+ qq|\trankdir = "$rankdir"\n|.
+ qq|\tnode [ fontname = "Arial", shape = "plaintext", fontsize = 8, color = "#111111" ]\n|.
+ qq|\tedge [ labeldistance = 2.5, labelangle = -20, labeljust = 1, minlen = 2, dir = "both",|.
+ qq| fontname = "Arial", fontsize = 7, arrowsize = 0.7, color = "#111111" ]\n|.
+ join("\n", @$lines).
+ qq|\n}\n|;
+}
+
+1;
diff --git a/lib/VNWeb/HTML.pm b/lib/VNWeb/HTML.pm
index d4bffb4c..13df2256 100644
--- a/lib/VNWeb/HTML.pm
+++ b/lib/VNWeb/HTML.pm
@@ -4,29 +4,34 @@ use v5.26;
use warnings;
use utf8;
use Algorithm::Diff::XS 'sdiff', 'compact_diff';
-use Encode 'encode_utf8', 'decode_utf8';
use JSON::XS;
use TUWF ':html5_', 'uri_escape', 'html_escape', 'mkclass';
use Exporter 'import';
-use POSIX 'ceil', 'strftime';
+use POSIX 'ceil', 'floor', 'strftime';
use Carp 'croak';
+use Digest::SHA;
use JSON::XS;
use VNDB::Config;
use VNDB::BBCode;
+use VNDB::Skins;
+use VNDB::Types;
use VNWeb::Auth;
use VNWeb::Validation;
use VNWeb::DB;
-use VNDB::Func 'fmtdate';
+use VNDB::Func 'fmtdate', 'rdate', 'tattr';
our @EXPORT = qw/
clearfloat_
+ platform_
debug_
join_
- user_ user_displayname
+ user_maybebanned_ user_ user_displayname
rdate_
- elm_
+ vnlength_
+ spoil_
+ elm_ widget
framework_
- revision_
+ revision_patrolled_ revision_
paginate_
sortable_
searchbox_
@@ -35,14 +40,16 @@ our @EXPORT = qw/
/;
-# Encoded as JSON and appended to the end of the page, to be read by pagevars.js.
-our %pagevars;
-
-
# Ugly hack to move rendering down below the float object.
sub clearfloat_ { div_ class => 'clearfloat', '' }
+# Platform icon
+sub platform_ {
+ abbr_ class => "icon-plat-$_[0]", title => $PLATFORM{$_[0]}, '';
+}
+
+
# Throw any data structure on the page for inspection.
sub debug_ {
return if !tuwf->debug;
@@ -65,6 +72,17 @@ sub join_($&@) {
}
+sub user_maybebanned_ {
+ my($obj) = shift;
+ my($prefix) = shift||'user_';
+ my sub f($) { $obj->{"${prefix}$_[0]"} }
+ span_ title => join("\n",
+ !f 'perm_board' ? "Banned from posting" : (),
+ !f 'perm_edit' ? "Banned from editing" : (),
+ ), '🚫' if defined f 'perm_board' && (!f 'perm_board' || !f 'perm_edit');
+}
+
+
# Display a user link, the given object must have the columns as fetched using DB::sql_user().
# Args: $object, $prefix, $capital
sub user_ {
@@ -73,13 +91,16 @@ sub user_ {
my $capital = shift;
my sub f($) { $obj->{"${prefix}$_[0]"} }
- return b_ class => 'grayedout', 'anonymous' if !f 'id';
+ my $softdel = !defined f 'name';
+ return small_ 'anonymous' if ($softdel && !auth->isMod) || !f 'id';
my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy'));
my $uniname = f 'uniname_can' && f 'uniname';
- a_ href => '/u'.f('id'),
+ a_ href => '/'.f('id'),
+ $softdel ? (class => 'grayedout') : (),
$fancy && $uniname ? (title => f('name'), $uniname) :
- (!$fancy && $uniname ? (title => $uniname) : (), $capital ? ucfirst f 'name' : f 'name');
+ (!$fancy && $uniname ? (title => $uniname) : (), ($capital ? f 'name' : f 'name') // f 'id');
txt_ '⭐' if $fancy && f 'support_can' && f 'support_enabled';
+ user_maybebanned_ $obj, $prefix;
}
@@ -91,52 +112,68 @@ sub user_displayname {
return 'anonymous' if !f 'id';
my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy'));
- $fancy && f 'uniname_can' && f 'uniname' ? f 'uniname' : f 'name'
+ $fancy && f 'uniname_can' && f 'uniname' ? f 'uniname' : f('name') // f 'id'
}
-
# Display a release date.
sub rdate_ {
- my $date = sprintf '%08d', shift||0;
- my $future = $date > strftime '%Y%m%d', gmtime;
- my($y, $m, $d) = ($1, $2, $3) if $date =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/;
+ my $str = rdate $_[0];
+ $_[0] > strftime('%Y%m%d', gmtime) ? b_ class => 'future', $str : txt_ $str;
+}
+
+
+sub vnlength_ {
+ my($l) = @_;
+ my $h = floor($l/60);
+ my $m = $l % 60;
+ txt_ "${h}h" if $h;
+ span_ class => 'small', "${m}m" if $h && $m;
+ txt_ "${m}m" if !$h && $m;
+}
- my $str = $y == 0 ? 'unknown' :
- $y == 9999 ? 'TBA' :
- $m == 99 ? sprintf('%04d', $y) :
- $d == 99 ? sprintf('%04d-%02d', $y, $m) :
- sprintf('%04d-%02d-%02d', $y, $m, $d);
- $future ? b_ class => 'future', $str : txt_ $str
+# Spoiler indication supscript (used for tags & traits)
+sub spoil_ {
+ sup_ title => 'Minor spoiler', 'S' if $_[0] == 1;
+ sup_ title => 'Major spoiler', class => 'standout', 'S' if $_[0] == 2;
}
-# Instantiate an Elm module
+# Instantiate an Elm module.
+# $schema can be set to the string 'raw' to encode the JSON directly, without a normalizing through a schema.
sub elm_ {
my($mod, $schema, $data, $placeholder) = @_;
- $pagevars{elm} ||= [];
- push $pagevars{elm}->@*, [ $mod, $data ? ($schema ? $schema->analyze->coerce_for_json($data, unknown => 'remove') : $data) : () ];
- div_ id => "elm$#{$pagevars{elm}}", $placeholder//'';
+ die "Elm data without a schema" if defined $data && !defined $schema;
+ tuwf->req->{js}{elm} = 1;
+ push tuwf->req->{pagevars}{elm}->@*, [ $mod, $data ? ($schema eq 'raw' ? $data : $schema->analyze->coerce_for_json($data, unknown => 'remove')) : () ];
+ my @arg = (id => sprintf 'elm%d', $#{ tuwf->req->{pagevars}{elm} });
+ $placeholder ? $placeholder->(@arg) : div_ @arg, '';
}
+# Instantiate a JS widget.
+# Used as attribute to a html tag, which will then be used as parent node for the widget.
+# $schema is optional, if present it is used to normalize the data.
+sub widget {
+ my($name, $schema, $data) = @_;
+ $data = $data ? $schema->analyze->coerce_for_json($data, unknown => 'remove') : $schema;
+ tuwf->req->{widget_id} //= 0;
+ tuwf->req->{js}{ VNWeb::JS::widgets()->{$name} // die "No bundle found for widget '$name'" } = 1;
+ my $id = ++tuwf->req->{widget_id};
+ push tuwf->req->{pagevars}{widget}{$name}->@*, [ $id, $data ];
+ (id => sprintf 'widget%d', $id)
+}
+
-sub _sanitize_css {
- # This function is attempting to do the impossible: Sanitize user provided
- # CSS against various attacks. I'm not expecting this to be bullet-proof.
- # This function doesn't bother with HTML injection as the output will go
- # through xml_escape(). Fortunately, we also have CSP in place to mitigate
- # some problems if they arise, but I'd rather not rely on it.
- # I'd *love* to disable support for external url()'s, but unfortunately
- # many people use that to load images. I'm afraid the only way to work
- # around that is to fetch and cache those URLs on the server.
- local $_ = $_[0];
- s/\\//g; # Get rid of backslashes, could be used to bypass the other regexes.
- s/@(import|charset|font-face)[^\n\;]*.//ig;
- s/javascript\s*://ig; # Not sure 'javascript:' URLs do anything, but just in case.
- s/expression\s*\(//ig; # An old IE thing I guess.
- s/binding\s*://ig; # Definitely don't want bindings.
- $_;
+# Generate a url to a file in gen/static/ and append a checksum.
+sub _staticurl {
+ my($file) = @_;
+ state %urls;
+ $urls{$file} //= do {
+ my $c = Digest::SHA->new('sha1');
+ $c->addfile(config->{gen_path}.'/static/'.$file);
+ sprintf '%s/%s?%s', config->{url_static}, $file, substr $c->hexdigest(), 0, 8;
+ };
}
@@ -144,33 +181,34 @@ sub _head_ {
my $o = shift;
my $fancy = !(auth->pref('nodistract_can') && auth->pref('nodistract_nofancy'));
- my $pubskin = $fancy && $o->{type} && $o->{type} eq 'u' && $o->{dbobj} ? tuwf->dbRowi(
- 'SELECT customcss, skin FROM users WHERE pubskin_can AND pubskin_enabled AND id =', \$o->{dbobj}{id}
+ my $pubskin = $fancy && $o->{dbobj} && $o->{dbobj}{id} =~ /^u/ ? tuwf->dbRowi(
+ 'SELECT u.id, customcss_csum, skin FROM users u JOIN users_prefs up ON up.id = u.id WHERE pubskin_can AND pubskin_enabled AND u.id =', \$o->{dbobj}{id}
) : {};
my $skin = tuwf->reqGet('skin') || $pubskin->{skin} || auth->pref('skin') || '';
- $skin = config->{skin_default} if !tuwf->{skins}{$skin};
- my $customcss = $pubskin->{customcss} || auth->pref('customcss');
+ $skin = config->{skin_default} if !skins->{$skin};
+ my $customcss = $pubskin->{customcss_csum} ? [ $pubskin->{id}, $pubskin->{customcss_csum} ] :
+ auth->pref('customcss_csum') ? [ auth->uid, auth->pref('customcss_csum') ] : undef;
meta_ charset => 'utf-8';
title_ $o->{title}.' | vndb';
base_ href => tuwf->reqURI();
link_ rel => 'shortcut icon', href => '/favicon.ico', type => 'image/x-icon';
- link_ rel => 'stylesheet', href => config->{url_static}.'/s/'.$skin.'/style.css?'.config->{version}, type => 'text/css', media => 'all';
- link_ rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB VN Search', href => tuwf->reqBaseURI().'/opensearch.xml';
- style_ type => 'text/css', _sanitize_css($customcss) if $customcss;
+ link_ rel => 'stylesheet', href => _staticurl("$skin.css"), type => 'text/css', media => 'all';
+ link_ rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB Visual Novel Search', href => tuwf->reqBaseURI().'/opensearch.xml';
+ link_ rel => 'stylesheet', href => sprintf '/%s.css?%x', $customcss->[0], $customcss->[1] if $customcss;
+ meta_ name => 'viewport', content => 'width=device-width, initial-scale=1.0, user-scalable=yes' if tuwf->reqGet('mobile-test');
if($o->{feeds}) {
link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/announcements.atom", title => 'Site Announcements';
link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/changes.atom", title => 'Recent Changes';
link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/posts.atom", title => 'Recent Posts';
}
- meta_ name => 'csrf-token', content => auth->csrftoken;
meta_ name => 'robots', content => 'noindex' if !$o->{index} || tuwf->reqGet('view');
# Opengraph metadata
if($o->{og}) {
$o->{og}{site_name} ||= 'The Visual Novel Database';
$o->{og}{type} ||= 'object';
- $o->{og}{image} ||= 'https://s.vndb.org/s/angel/bg.jpg'; # TODO: Something better
+ $o->{og}{image} ||= config->{placeholder_img};
$o->{og}{url} ||= tuwf->reqURI;
$o->{og}{title} ||= $o->{title};
meta_ property => "og:$_", content => ($o->{og}{$_} =~ s/\n/ /gr) for sort keys $o->{og}->%*;
@@ -182,25 +220,24 @@ sub _menu_ {
my $o = shift;
div_ id => 'support', sub {
- a_ href => 'https://www.patreon.com/vndb', id => 'patreon', sub {
- img_ src => config->{url_static}.'/f/patreon.png', alt => 'Support VNDB on Patreon', width => 160, height => 38;
- };
- a_ href => 'https://www.subscribestar.com/vndb', id => 'subscribestar', sub {
- img_ src => config->{url_static}.'/f/subscribestar.png', alt => 'Support VNDB on SubscribeStar', width => 160, height => 38;
- };
+ strong_ 'Support VNDB';
+ p_ sub {
+ a_ href => 'https://www.patreon.com/vndb', 'Patreon';
+ a_ href => 'https://www.subscribestar.com/vndb', 'SubscribeStar';
+ }
} if !(auth->pref('nodistract_can') && auth->pref('nodistract_noads'));
- div_ class => 'menubox', sub {
+ article_ sub {
h2_ 'Menu';
div_ sub {
a_ href => '/', 'Home'; br_;
- a_ href => '/v/all', 'Visual novels'; br_;
- b_ class => 'grayedout', '> '; a_ href => '/g', 'Tags'; br_;
+ a_ href => '/v', 'Visual novels'; br_;
+ small_ '> '; a_ href => '/g', 'Tags'; br_;
a_ href => '/r', 'Releases'; br_;
- a_ href => '/p/all', 'Producers'; br_;
- a_ href => '/s/all', 'Staff'; br_;
- a_ href => '/c/all', 'Characters'; br_;
- b_ class => 'grayedout', '> '; a_ href => '/i', 'Traits'; br_;
+ a_ href => '/p', 'Producers'; br_;
+ a_ href => '/s', 'Staff'; br_;
+ a_ href => '/c', 'Characters'; br_;
+ small_ '> '; a_ href => '/i', 'Traits'; br_;
a_ href => '/u/all', 'Users'; br_;
a_ href => '/hist', 'Recent changes'; br_;
a_ href => '/t', 'Discussion board'; br_;
@@ -208,36 +245,48 @@ sub _menu_ {
a_ href => '/v/rand','Random visual novel'; br_;
a_ href => '/d11', 'API'; lit_ ' - ';
a_ href => '/d14', 'Dumps'; lit_ ' - ';
- a_ href => '/d18', 'Query';
+ a_ href => 'https://query.vndb.org/about', 'Query';
};
- form_ action => '/v/all', method => 'get', id => 'search', sub {
+ form_ action => '/v', method => 'get', sub {
fieldset_ sub {
- legend_ 'Search';
input_ type => 'text', class => 'text', id => 'sq', name => 'sq', value => $o->{search}||'', placeholder => 'search';
- input_ type => 'submit', class => 'submit', value => 'Search';
+ input_ type => 'submit', class => 'hidden', value => 'Search';
}
}
};
- div_ class => 'menubox', sub {
- my $uid = sprintf '/u%d', auth->uid;
- my $nc = auth && tuwf->dbVali('SELECT count(*) FROM notifications WHERE uid =', \auth->uid, 'AND read IS NULL');
- my $support_opt = auth->pref('nodistract_can') || auth->pref('support_can') || auth->pref('uniname_can') || auth->pref('pubskin_can');
+ article_ sub {
+ my $uid = '/'.auth->uid;
h2_ sub { user_ auth->user, 'user_', 1 };
div_ sub {
- a_ href => "$uid/edit", 'My Profile'; txt_ '⭐' if $support_opt && !auth->pref('nodistract_nofancy'); br_;
+ a_ href => "$uid/edit", 'My Profile'; txt_ '⭐' if auth->pref('nodistract_can') && !auth->pref('nodistract_nofancy'); br_;
a_ href => "$uid/ulist?vnlist=1", 'My Visual Novel List'; br_;
a_ href => "$uid/ulist?votes=1",'My Votes'; br_;
a_ href => "$uid/ulist?wishlist=1", 'My Wishlist'; br_;
- a_ href => "$uid/notifies", $nc ? (class => 'notifyget') : (), 'My Notifications'.($nc?" ($nc)":''); br_;
+ a_ href => "$uid/notifies", $o->{unread_noti} ? (class => 'notifyget') : (), 'My Notifications'.($o->{unread_noti}?" ($o->{unread_noti})":''); br_;
a_ href => "$uid/hist", 'My Recent Changes'; br_;
a_ href => '/g/links?u='.auth->uid, 'My Tags'; br_;
br_;
- if(auth->permEdit) {
+ if(VNWeb::Images::Vote::can_vote()) {
+ a_ href => '/img/vote', 'Image Flagging'; br_;
+ }
+ if(can_edit v => {}) {
a_ href => '/v/add', 'Add Visual Novel'; br_;
a_ href => '/p/add', 'Add Producer'; br_;
a_ href => '/s/new', 'Add Staff'; br_;
- a_ href => '/c/new', 'Add Character'; br_;
+ }
+ if(auth->isMod) {
+ my $stats = tuwf->dbRowi("SELECT
+ (SELECT count(*) FROM reports WHERE status = 'new') as new,
+ (SELECT count(*) FROM reports WHERE status = 'new' AND date > (SELECT last_reports FROM users_prefs WHERE id =", \auth->uid, ")) AS unseen,
+ (SELECT count(*) FROM reports WHERE lastmod > (SELECT last_reports FROM users_prefs WHERE id =", \auth->uid, ")) AS upd
+ ");
+ a_ $stats->{unseen} ? (class => 'standout') : (), href => '/report/list?status=new', sprintf 'Reports %d/%d', $stats->{unseen}, $stats->{new};
+ small_ ' | ';
+ a_ href => '/report/list?s=lastmod', sprintf '%d upd', $stats->{upd};
+ br_;
+ a_ global_settings->{lockdown_edit} || global_settings->{lockdown_board} || global_settings->{lockdown_registration} ? (class => 'standout') : (), href => '/lockdown', 'Lockdown';
+ br_;
}
br_;
form_ action => "$uid/logout", method => 'post', sub {
@@ -247,29 +296,29 @@ sub _menu_ {
}
} if auth;
- div_ class => 'menubox', sub {
+ article_ sub {
h2_ 'User menu';
div_ sub {
- my $ref = uri_escape tuwf->reqPath().tuwf->reqQuery();
+ my $ref = uri_escape(tuwf->reqGet('ref') || tuwf->reqPath().tuwf->reqQuery());
a_ href => "/u/login?ref=$ref", 'Login'; br_;
- a_ href => '/u/newpass', 'Password reset'; br_;
a_ href => '/u/register', 'Register'; br_;
}
- } if !auth;
+ } if !auth && !config->{read_only};
- div_ class => 'menubox', sub {
+ article_ sub {
h2_ 'Database Statistics';
div_ sub {
dl_ sub {
- dt_ 'Visual Novels'; dd_ tuwf->{stats}{vn};
- dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Tags' };
- dd_ tuwf->{stats}{tags};
- dt_ 'Releases'; dd_ tuwf->{stats}{releases};
- dt_ 'Producers'; dd_ tuwf->{stats}{producers};
- dt_ 'Staff'; dd_ tuwf->{stats}{staff};
- dt_ 'Characters'; dd_ tuwf->{stats}{chars};
- dt_ sub { b_ class => 'grayedout', '> '; lit_ 'Traits' };
- dd_ tuwf->{stats}{traits};
+ my %stats = map +($_->{section}, $_->{count}), tuwf->dbAll('SELECT * FROM stats_cache')->@*;
+ dt_ 'Visual Novels'; dd_ $stats{vn};
+ dt_ sub { small_ '> '; lit_ 'Tags' };
+ dd_ $stats{tags};
+ dt_ 'Releases'; dd_ $stats{releases};
+ dt_ 'Producers'; dd_ $stats{producers};
+ dt_ 'Staff'; dd_ $stats{staff};
+ dt_ 'Characters'; dd_ $stats{chars};
+ dt_ sub { small_ '> '; lit_ 'Traits' };
+ dd_ $stats{traits};
};
clearfloat_;
}
@@ -278,50 +327,91 @@ sub _menu_ {
sub _footer_ {
- my $q = tuwf->dbRow('SELECT vid, quote FROM quotes ORDER BY RANDOM() LIMIT 1');
- if($q && $q->{vid}) {
+ my($o) = @_;
+ my $q = tuwf->dbRow('SELECT vid, quote FROM quotes WHERE rand <= (SELECT random()) ORDER BY rand DESC LIMIT 1');
+ span_ sub {
lit_ '"';
- a_ href => "/v$q->{vid}", style => 'text-decoration: none', $q->{quote};
- txt_ '"';
+ a_ href => "/$q->{vid}", $q->{quote};
+ txt_ '" ';
br_;
- }
+ } if $q && $q->{vid};
a_ href => config->{source_url}, config->{version};
txt_ ' | ';
+ a_ href => '/d17', 'privacy & content policy';
+ txt_ ' | ';
a_ href => '/d7', 'about us';
lit_ ' | ';
- a_ href => 'irc://irc.synirc.net/vndb', '#vndb';
+ a_ href => '/.env', 'security';
+ lit_ ' | ';
+ a_ href => '/ads.txt', 'advertising';
lit_ ' | ';
a_ href => sprintf('mailto:%s', config->{admin_email}), config->{admin_email};
if(tuwf->debug) {
lit_ ' | ';
+ debug_ tuwf->req->{pagevars};
+ br_;
tuwf->dbCommit; # Hack to measure the commit time
- my $sql = uri_escape join "\n", map {
+ my(@sql_r, @sql_i) = ();
+ for (tuwf->{_TUWF}{DB}{queries}->@*) {
my($sql, $params, $time) = @$_;
- sprintf " [%6.2fms] %s | %s", $time*1000, $sql,
- join ', ', map "$_:".DBI::neat($params->{$_}),
- sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b }
- keys %$params;
- } tuwf->{_TUWF}{DB}{queries}->@*;
- a_ href => 'data:text/plain,'.$sql, 'SQL';
- lit_ ' | ';
-
- my $modules = uri_escape join "\n", sort keys %INC;
- a_ href => 'data:text/plain,'.$modules, 'Modules';
- lit_ ' | ';
- debug_ \%pagevars;
+ my @params = sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b } keys %$params;
+ my $prefix = sprintf " [%6.2fms] ", $time*1000;
+ push @sql_r, sprintf "%s%s | %s", $prefix, $sql, join ', ', map "$_:".DBI::neat($params->{$_}), @params;
+ my $i=1;
+ push @sql_i, $prefix.($sql =~ s/\?/tuwf->dbh->quote($params->{$i++})/egr);
+ }
+ my $sql_r = join "\n", @sql_r;
+ my $sql_i = join "\n", @sql_i;
+ my $modules = join "\n", sort keys %INC;
+ details_ sub {
+ summary_ 'debug info';
+ pre_ style => 'text-align: left; color: black; background: white',
+ "SQL (with placeholders):\n$sql_r\n\nSQL (interpolated, possibly buggy):\n$sql_i\n\nMODULES:\n$modules";
+ };
}
}
+sub _maintabs_subscribe_ {
+ my($o, $id) = @_;
+ return if !auth || $id !~ /^[twvrpcsdig]/;
+
+ my $noti =
+ $id =~ /^t/ ? tuwf->dbVali('SELECT SUM(x) FROM (
+ SELECT 1 FROM threads_posts tp, users u WHERE u.id =', \auth->uid, 'AND tp.uid =', \auth->uid, 'AND tp.tid =', \$id, ' AND u.notify_post
+ UNION SELECT 1+1 FROM threads_boards tb WHERE tb.tid =', \$id, 'AND tb.type = \'u\' AND tb.iid =', \auth->uid, '
+ ) x(x)')
+
+ : $id =~ /^w/ ? (auth->pref('notify_post') || auth->pref('notify_comment')) && tuwf->dbVali('SELECT SUM(x) FROM (
+ SELECT 1 FROM reviews_posts wp, users u WHERE u.id =', \auth->uid, 'AND wp.uid =', \auth->uid, 'AND wp.id =', \$id, 'AND u.notify_post
+ UNION SELECT 1+1 FROM reviews w, users u WHERE u.id =', \auth->uid, 'AND w.uid =', \auth->uid, 'AND w.id =', \$id, 'AND u.notify_comment
+ ) x(x)')
+
+ : $id =~ /^[vrpcsdgi]/ && auth->pref('notify_dbedit') && tuwf->dbVali('
+ SELECT 1 FROM changes WHERE itemid =', \$id, 'AND requester =', \auth->uid);
+
+ my $sub = tuwf->dbRowi('SELECT subnum, subreview, subapply FROM notification_subs WHERE uid =', \auth->uid, 'AND iid =', \$id);
+
+ li_ widget(Subscribe => $VNWeb::User::Notifications::SUB, {
+ id => $id,
+ noti => $noti||0,
+ subnum => $sub->{subnum},
+ subreview => $sub->{subreview}||0,
+ subapply => $sub->{subapply}||0,
+ }), class => 'maintabs-dd subscribe', sub {
+ a_ href => '#', class => ($noti && (!defined $sub->{subnum} || $sub->{subnum})) || $sub->{subnum} || $sub->{subreview} || $sub->{subapply} ? 'active' : 'inactive', '🔔';
+ };
+}
+
+
sub _maintabs_ {
my $opt = shift;
- my($t, $o, $sel) = @{$opt}{qw/type dbobj tab/};
- return if !$t || !$o;
- return if $t eq 'g' && !auth->permTagmod;
+ my($o, $sel) = @{$opt}{qw/dbobj tab/};
- my $id = $t.$o->{id};
+ my $id = $o ? $o->{id} : '';
+ my($t) = $o ? $id =~ /^(.)/ : '';
my sub t {
my($tabname, $url, $text) = @_;
@@ -330,48 +420,53 @@ sub _maintabs_ {
};
};
- div_ class => 'maintabs right', sub {
- ul_ sub {
- t '' => "/$id", $id;
+ nav_ sub {
+ label_ for => 'mainmenu', sub {
+ lit_ 'Menu';
+ b_ " ($opt->{unread_noti})" if $opt->{unread_noti};
+ };
+ menu_ sub {
+ t '' => "/$id", $id if $o && $t ne 't';
t rg => "/$id/rg", 'relations'
- if $t =~ /[vp]/ && (exists $o->{rgraph} ? $o->{rgraph}
- : tuwf->dbVali('SELECT rgraph FROM', $t eq 'v' ? 'vn' : 'producers', 'WHERE id =', \$o->{id}));
+ if $t =~ /[vp]/ && tuwf->dbVali('SELECT 1 FROM', $t eq 'v' ? 'vn_relations' : 'producers_relations', 'WHERE id =', \$o->{id}, 'LIMIT 1');
t releases => "/$id/releases", 'releases' if $t eq 'v';
- t edit => "/$id/edit", 'edit' if can_edit $t, $o;
+ t edit => "/$id/edit", 'edit' if $o && $t ne 't' && can_edit $t, $o;
t copy => "/$id/copy", 'copy' if $t =~ /[rc]/ && can_edit $t, $o;
t tagmod => "/$id/tagmod", 'modify tags' if $t eq 'v' && auth->permTag && !$o->{entry_hidden};
do {
+ t admin => "/$id/admin", 'admin' if auth->isMod;
t list => "/$id/ulist?vnlist=1", 'list';
t votes => "/$id/ulist?votes=1", 'votes';
t wish => "/$id/ulist?wishlist=1", 'wishlist';
+ t reviews => "/w?u=$o->{id}", 'reviews';
+ t posts => "/$id/posts", 'posts';
} if $t eq 'u';
- t posts => "/$id/posts", 'posts' if $t eq 'u';
-
if($t =~ /[uvp]/) {
my $cnt = tuwf->dbVali(q{
SELECT COUNT(*)
FROM threads_boards tb
JOIN threads t ON t.id = tb.tid
- WHERE tb.type =}, \$t, 'AND tb.iid =', \$o->{id}, 'AND', VNWeb::Discussions::Lib::sql_visible_threads());
+ WHERE tb.type =}, \$t, 'AND tb.iid =', \$o->{id}, ' AND', VNWeb::Discussions::Lib::sql_visible_threads());
t disc => "/t/$id", "discussions ($cnt)";
};
- t hist => "/$id/hist", 'history' if $t =~ /[uvrpcsd]/;
+ t hist => "/$id/hist", 'history' if $t =~ /[uvrpcsdgi]/;
+ _maintabs_subscribe_ $o, $id;
}
}
}
-# Attempt to figure out the board id from a database entry ($type, $dbobj) combination
+# Attempt to figure out the board id from a database entry
sub _board_id {
- my($type, $obj) = @_;
- $type =~ /[vp]/ ? $type.$obj->{id} :
- $type eq 'r' && $obj->{vn}->@* ? 'v'.$obj->{vn}[0]{vid} :
- $type eq 'c' && $obj->{vns}->@* ? 'v'.$obj->{vns}[0]{vid} : 'db';
+ my($obj) = @_;
+ $obj->{id} =~ /^[vp]/ ? $obj->{id} :
+ $obj->{id} =~ /^r/ && $obj->{vn} && $obj->{vn}->@* ? $obj->{vn}[0]{vid} :
+ $obj->{id} =~ /^c/ && $obj->{vns} && $obj->{vns}->@* ? $obj->{vns}[0]{vid} : 'db';
}
@@ -379,39 +474,53 @@ sub _board_id {
sub _hidden_msg_ {
my $o = shift;
- die "Can't use hiddenmsg on an object that is missing 'entry_hidden'" if !exists $o->{dbobj}{entry_hidden};
+ die "Can't use hiddenmsg on an object that is missing 'entry_hidden' or 'entry_locked'"
+ if !exists $o->{dbobj}{entry_hidden} || !exists $o->{dbobj}{entry_locked};
+
return 0 if !$o->{dbobj}{entry_hidden};
- my $msg = tuwf->dbVali(
- 'SELECT comments
+ # Awaiting moderation
+ if(!$o->{dbobj}{entry_locked}) {
+ article_ sub {
+ h1_ $o->{title};
+ div_ class => 'notice', sub {
+ h2_ 'Waiting for approval';
+ p_ 'This entry is waiting for a moderator to approve it.';
+ }
+ };
+ return 0;
+ }
+
+ # Deleted.
+ my $msg = tuwf->dbRowi(
+ 'SELECT comments, rev
FROM changes
- WHERE', { type => $o->{type}, itemid => $o->{dbobj}{id} },
+ WHERE itemid =', \$o->{dbobj}{id},
'ORDER BY id DESC LIMIT 1'
);
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ $o->{title};
div_ class => 'warning', sub {
h2_ 'Item deleted';
p_ sub {
+ if($o->{dbobj}{id} =~ /^r/ && $o->{dbobj}{vn}) {
+ txt_ 'This was a release entry for ';
+ join_ ',', sub { a_ href => "/$_->{vid}", tattr $_ }, $o->{dbobj}{vn}->@*;
+ txt_ '.';
+ br_;
+ }
txt_ 'This item has been deleted from the database. You may file a request on the ';
- a_ href => '/t/'._board_id($o->{type}, $o->{dbobj}), "discussion board";
+ a_ href => '/t/'._board_id($o->{dbobj}), "discussion board";
txt_ ' if you believe that this entry should be restored.';
- br_;
- br_;
- lit_ bb2html $msg;
+ if($msg->{rev} > 1) {
+ br_;
+ br_;
+ lit_ bb_format $msg->{comments};
+ }
}
}
};
- !auth->permDbmod # dbmods can still see the page
-}
-
-
-sub v2rwjs_ { # Also used by VNDB::Util::LayoutHTML.
- script_ type => 'application/json', id => 'pagevars', sub {
- # Escaping rules for a JSON <script> context are kinda weird, but more efficient than regular xml_escape().
- lit_(JSON::XS->new->canonical->encode(\%pagevars) =~ s{</}{<\\/}rg =~ s/<!--/<\\u0021--/rg);
- } if keys %pagevars;
- script_ type => 'application/javascript', src => config->{url_static}.'/f/v2rw.js?'.config->{version}, '';
+ $o->{dbobj}{id} !~ /^[gi]/ && !auth->permDbmod # tags/traits are still visible, dbmods can still see all pages
}
@@ -419,49 +528,90 @@ sub v2rwjs_ { # Also used by VNDB::Util::LayoutHTML.
# title => $title
# index => 1/0, default 0
# feeds => 1/0
+# js => 1/0, set to 1 to ensure 'basic.js' is included on the page even if no elm_() modules or JS widgets are loaded.
# search => $query
# og => { opengraph metadata }
-# type => Database entry type (used for the main tabs & hidden message)
# dbobj => Database entry object (used for the main tabs & hidden message)
# Recognized object fields: id, entry_hidden, entry_locked
# tab => Current tab, or empty for the main tab
# hiddenmsg => 1/0, if true and dbobj is 'hidden', a message will be displayed
-# and the content function will not be called.
+# and the content function may not be called.
# sub { content }
sub framework_ {
my $cont = pop;
my %o = @_;
- %pagevars = $o{pagevars} ? $o{pagevars}->%* : ();
-
+ tuwf->req->{pagevars} = { tuwf->req->{pagevars} ? tuwf->req->{pagevars}->%* : (), $o{pagevars}->%* } if $o{pagevars};
+ $o{unread_noti} = auth && tuwf->dbVali('SELECT count(*) FROM notifications WHERE uid =', \auth->uid, 'AND read IS NULL');
+
+ lit_ "<!--\n"
+ ." This HTML is an unreadable auto-generated mess, sorry for that.\n"
+ ." The full source code of this site can be found at ".config->{source_url}."\n"
+ .(tuwf->req->{trace_loc}[0] ?
+ " This particular page was generated by ".config->{source_url}."/src/branch/master/lib/".(tuwf->req->{trace_loc}[0] =~ s/::/\//rg).".pm\n" : '')
+ ."-->\n";
html_ lang => 'en', sub {
head_ sub { _head_ \%o };
body_ sub {
- div_ id => 'bgright', ' ';
- div_ id => 'header', sub { h1_ sub { a_ href => '/', 'the visual novel database' } };
- div_ id => 'menulist', sub { _menu_ \%o };
- div_ id => 'maincontent', sub {
+ input_ type => 'checkbox', class => 'hidden', id => 'mainmenu', name => 'mainmenu';
+ header_ sub {
+ div_ id => 'bgright', ' ';
+ div_ id => 'readonlymode', config->{read_only} eq 1 ? 'The site is in read-only mode, account functionality is currently disabled.' : config->{read_only} if config->{read_only};
+ h1_ sub { a_ href => '/', 'the visual novel database' };
_maintabs_ \%o;
+ };
+ nav_ sub { _menu_ \%o };
+ main_ sub {
$cont->() unless $o{hiddenmsg} && _hidden_msg_ \%o;
- div_ id => 'footer', \&_footer_;
+ footer_ sub { _footer_ \%o };
};
- v2rwjs_;
+
+ # 'basic' bundle is always included if there's any JS at all
+ tuwf->req->{js}{basic} = 1 if tuwf->req->{js}{elm} || tuwf->req->{pagevars}{widget} || $o{js};
+ # 'dbmod' value is used by various widgets
+ tuwf->req->{pagevars}{dbmod} = 1 if tuwf->req->{pagevars}{widget} && auth->permDbmod;
+
+ script_ type => 'application/json', id => 'pagevars', sub {
+ # Escaping rules for a JSON <script> context are kinda weird, but more efficient than regular xml_escape().
+ lit_(JSON::XS->new->canonical->encode(tuwf->req->{pagevars}) =~ s{</}{<\\/}rg =~ s/<!--/<\\u0021--/rg);
+ } if keys tuwf->req->{pagevars}->%*;
+
+ script_ defer => 'defer', src => _staticurl("$_.js"), '' for grep tuwf->req->{js}{$_}, qw/elm basic user contrib graph/;
}
}
}
+sub revision_patrolled_ {
+ my($r) = @_;
+ return span_ class => 'done', title =>
+ "Patrolled by ".join(', ', map user_displayname($_), $r->{rev_patrolled}->@*), '✓'
+ if $r->{rev_patrolled}->@*;
+ return lit_ '✓' if $r->{rev_dbmod};
+ small_ '#';
+}
+
sub _revision_header_ {
- my($type, $obj) = @_;
- b_ "Revision $obj->{chrev}";
+ my($obj) = @_;
+ strong_ "Revision $obj->{chrev}";
debug_ $obj;
if(auth) {
lit_ ' (';
- a_ href => "/$type$obj->{id}.$obj->{chrev}/edit", $obj->{chrev} == $obj->{maxrev} ? 'edit' : 'revert to';
+ a_ href => "/$obj->{id}.$obj->{chrev}/edit", $obj->{chrev} == $obj->{maxrev} ? 'edit' : 'revert to';
if($obj->{rev_user_id}) {
lit_ ' / ';
- a_ href => "/t/u$obj->{rev_user_id}/new?title=Regarding%20$type$obj->{id}.$obj->{chrev}", 'msg user';
+ a_ href => "/t/$obj->{rev_user_id}/new?title=Regarding%20$obj->{id}.$obj->{chrev}", 'msg user';
+ }
+ if(auth->permDbmod) {
+ lit_ ' / ';
+ revision_patrolled_ $obj;
+ if($obj->{rev_user_id} && $obj->{rev_user_id} eq auth->uid) {}
+ elsif(grep $_->{user_id} eq auth->uid, $obj->{rev_patrolled}->@*) {
+ a_ href => "?unpatrolled=$obj->{chid}", 'unmark';
+ } else {
+ a_ href => "?patrolled=$obj->{chid}", 'mark patrolled';
+ }
}
lit_ ')';
}
@@ -474,8 +624,8 @@ sub _revision_header_ {
sub _revision_fmtval_ {
- my($opt, $val) = @_;
- return i_ '[empty]' if !defined $val || !length $val || (defined $opt->{empty} && $val eq $opt->{empty});
+ my($opt, $val, $obj) = @_;
+ return em_ '[empty]' if !defined $val || !length $val || (defined $opt->{empty} && $val eq $opt->{empty});
return lit_ html_escape $val if !$opt->{fmt};
if(ref $opt->{fmt} eq 'HASH') {
my $h = $opt->{fmt}{$val};
@@ -483,17 +633,18 @@ sub _revision_fmtval_ {
}
return txt_ $val ? 'True' : 'False' if $opt->{fmt} eq 'bool';
local $_ = $val;
- $opt->{fmt}->();
+ $opt->{fmt}->($obj);
}
sub _revision_fmtcol_ {
- my($opt, $i, $l) = @_;
+ my($opt, $i, $l, $obj) = @_;
my $ctx = 100; # Number of characters of context in textual diffs
- my sub sep_ { b_ class => 'standout', '<...>' }; # Context separator
+ my sub sep_ { b_ '<...>' }; # Context separator
td_ class => 'tcval', sub {
+ em_ '[empty]' if @$l > 1 && (($i == 1 && !grep $_->[0] ne '+', @$l) || ($i == 2 && !grep $_->[0] ne '-', @$l));
join_ $opt->{join}||\&br_, sub {
my($ch, $old, $new, $diff) = @$_;
my $val = $_->[$i];
@@ -501,12 +652,12 @@ sub _revision_fmtcol_ {
if($diff) {
my $lastchunk = int (($#$diff-2)/2);
for my $n (0..$lastchunk) {
- my $a = decode_utf8 join '', @{$old}[ $diff->[$n*2] .. $diff->[$n*2+2]-1 ];
- my $b = decode_utf8 join '', @{$new}[ $diff->[$n*2+1] .. $diff->[$n*2+3]-1 ];
+ utf8::decode(my $a = join '', @{$old}[ $diff->[$n*2] .. $diff->[$n*2+2]-1 ]);
+ utf8::decode(my $b = join '', @{$new}[ $diff->[$n*2+1] .. $diff->[$n*2+3]-1 ]);
# Difference, highlight and display in full
if($n % 2) {
- b_ class => $i == 1 ? 'diff_del' : 'diff_add', sub { lit_ html_escape $i == 1 ? $a : $b };
+ span_ class => $i == 1 ? 'diff_del' : 'diff_add', sub { lit_ html_escape $i == 1 ? $a : $b };
# Short context, display in full
} elsif(length $a < $ctx*3) {
lit_ html_escape $a;
@@ -523,11 +674,11 @@ sub _revision_fmtcol_ {
}
} elsif(@$l > 1 && $i == 2 && ($ch eq '+' || $ch eq 'c')) {
- b_ class => 'diff_add', sub { _revision_fmtval_ $opt, $val }
+ span_ class => 'diff_add', sub { _revision_fmtval_ $opt, $val, $obj };
} elsif(@$l > 1 && $i == 1 && ($ch eq '-' || $ch eq 'c')) {
- b_ class => 'diff_del', sub { _revision_fmtval_ $opt, $val }
- } elsif($ch eq 'c' || $ch eq 'u' || @$l == 1) {
- _revision_fmtval_ $opt, $val;
+ span_ class => 'diff_del', sub { _revision_fmtval_ $opt, $val, $obj };
+ } elsif($ch eq 'u' || @$l == 1) {
+ _revision_fmtval_ $opt, $val, $obj;
}
}, @$l;
};
@@ -548,13 +699,16 @@ sub _stringify_scalars_rec {
}
sub _revision_diff_ {
- my($type, $old, $new, $field, $name, %opt) = @_;
+ my($old, $new, $field, $name, %opt) = @_;
# First do a diff on the raw field elements.
# (if the field is a scalar, it's considered a single element and the diff just tests equality)
my @old = ref $old->{$field} eq 'ARRAY' ? $old->{$field}->@* : ($old->{$field});
my @new = ref $new->{$field} eq 'ARRAY' ? $new->{$field}->@* : ($new->{$field});
+ @old = map $opt{txt}->(), @old if $opt{txt};
+ @new = map $opt{txt}->(), @new if $opt{txt};
+
my $JS = JSON::XS->new->utf8->canonical->allow_nonref;
my $l = sdiff \@old, \@new, sub { _stringify_scalars_rec($_[0]); $JS->encode($_[0]) };
return if !grep $_->[0] ne 'u', @$l;
@@ -568,42 +722,44 @@ sub _revision_diff_ {
# Do a word-based diff if this is a large chunk of text, otherwise character-based.
my $split = length $item->[1] > 1024 ? qr/([ ,\n]+)/ : qr//;
- $item->[1] = [map encode_utf8($_), split $split, $item->[1]];
- $item->[2] = [map encode_utf8($_), split $split, $item->[2]];
+ $item->[1] = [map { utf8::encode($_); $_ } split $split, $item->[1]];
+ $item->[2] = [map { utf8::encode($_); $_ } split $split, $item->[2]];
$item->[3] = compact_diff $item->[1], $item->[2];
}
tr_ sub {
td_ $name;
- _revision_fmtcol_ \%opt, 1, $l;
- _revision_fmtcol_ \%opt, 2, $l;
+ _revision_fmtcol_ \%opt, 1, $l, $old;
+ _revision_fmtcol_ \%opt, 2, $l, $new;
}
}
sub _revision_cmp_ {
- my($type, $old, $new, @fields) = @_;
+ my($old, $new, @fields) = @_;
+
+ local $old->{_entry_state} = ($old->{hidden}?2:0) + ($old->{locked}?1:0);
+ local $new->{_entry_state} = ($new->{hidden}?2:0) + ($new->{locked}?1:0);
table_ class => 'stripe', sub {
thead_ sub {
tr_ sub {
td_ ' ';
- td_ sub { _revision_header_ $type, $old };
- td_ sub { _revision_header_ $type, $new };
+ td_ sub { _revision_header_ $old };
+ td_ sub { _revision_header_ $new };
};
tr_ sub {
td_ ' ';
td_ colspan => 2, sub {
- b_ "Edit summary for revision $new->{chrev}";
+ strong_ "Edit summary for revision $new->{chrev}";
br_;
br_;
- lit_ bb2html $new->{rev_comments}||'-';
+ lit_ bb_format $new->{rev_comments}||'-';
};
};
};
- _revision_diff_ $type, $old, $new, @$_ for(
- [ hidden => 'Hidden', fmt => 'bool' ],
- [ locked => 'Locked', fmt => 'bool' ],
+ _revision_diff_ $old, $new, @$_ for(
+ [ _entry_state => 'State', fmt => {0 => 'Normal', 1 => 'Locked', 2 => 'Awaiting approval', 3 => 'Deleted'} ],
@fields,
);
};
@@ -612,7 +768,7 @@ sub _revision_cmp_ {
# Revision info box.
#
-# Arguments: $type, $object, \&enrich_for_diff, @fields
+# Arguments: $object, \&enrich_for_diff, @fields
#
# The given $object is assumed to originate from VNWeb::DB::db_entry() and
# should have the 'id', 'hidden', 'locked', 'chrev' and 'maxrev' fields in
@@ -633,37 +789,53 @@ sub _revision_cmp_ {
# If not given, the field is rendered as plain text and changes are highlighted with a diff.
# \%HASH -> Look the field up in the hash table (values should be string or {txt=>string}.
# sub($value) {$_} -> Custom formatting function, should output TUWF::XML data HTML.
+# txt => sub{$_} - Text formatting function for individual values.
+# Alternative to 'fmt' above; the returned value is treated as a text field with diffing support.
# join => sub{} - HTML to join multi-value fields, defaults to \&br_.
# empty => str - What value should be considered "empty", e.g. (empty => 0) for integer fields.
# undef or empty string are always considered empty values.
sub revision_ {
- my($type, $new, $enrich, @fields) = @_;
+ my($new, $enrich, @fields) = @_;
- my $old = $new->{chrev} == 1 ? undef : db_entry $type, $new->{id}, $new->{chrev} - 1;
+ my $old = $new->{chrev} == 1 ? undef : db_entry $new->{id}, $new->{chrev} - 1;
$enrich->($old) if $old;
+ if(auth->permDbmod) {
+ my $f = tuwf->validate(get =>
+ patrolled => { default => 0, uint => 1 },
+ unpatrolled => { default => 0, uint => 1 },
+ )->data;
+ tuwf->dbExeci('INSERT INTO changes_patrolled', {id => $f->{patrolled}, uid => auth->uid}, 'ON CONFLICT (id,uid) DO NOTHING') if $f->{patrolled};
+ tuwf->dbExeci('DELETE FROM changes_patrolled WHERE', {id => $f->{unpatrolled}, uid => auth->uid}) if $f->{unpatrolled};
+ }
+
enrich_merge chid => sql(
- 'SELECT c.id AS chid, c.comments as rev_comments,', sql_totime('c.added'), 'as rev_added, ', sql_user('u', 'rev_user_'), '
+ 'SELECT c.id AS chid, c.comments as rev_comments,', sql_totime('c.added'), 'as rev_added, ', sql_user('u', 'rev_user_'), ', u.perm_dbmod AS rev_dbmod
FROM changes c LEFT JOIN users u ON u.id = c.requester
WHERE c.id IN'),
$new, $old||();
- div_ class => 'mainbox revision', sub {
+ enrich rev_patrolled => chid => id =>
+ sql('SELECT c.id,', sql_user(), 'FROM changes_patrolled c JOIN users u ON u.id = c.uid WHERE c.id IN'),
+ $new, $old||()
+ if auth->permDbmod;
+
+ article_ class => 'revision', sub {
h1_ "Revision $new->{chrev}";
- a_ class => 'prev', href => sprintf('/%s%d.%d', $type, $new->{id}, $new->{chrev}-1), '<- earlier revision' if $new->{chrev} > 1;
- a_ class => 'next', href => sprintf('/%s%d.%d', $type, $new->{id}, $new->{chrev}+1), 'later revision ->' if $new->{chrev} < $new->{maxrev};
- p_ class => 'center', sub { a_ href => "/$type$new->{id}", $type.$new->{id} };
+ a_ class => 'prev', href => sprintf('/%s.%d', $new->{id}, $new->{chrev}-1), '<- earlier revision' if $new->{chrev} > 1;
+ a_ class => 'next', href => sprintf('/%s.%d', $new->{id}, $new->{chrev}+1), 'later revision ->' if $new->{chrev} < $new->{maxrev};
+ p_ class => 'center', sub { a_ href => "/$new->{id}", $new->{id} };
div_ class => 'rev', sub {
- _revision_header_ $type, $new;
+ _revision_header_ $new;
br_;
- b_ 'Edit summary';
+ strong_ 'Edit summary';
br_; br_;
- lit_ bb2html $new->{rev_comments}||'-';
+ lit_ bb_format $new->{rev_comments}||'-';
} if !$old;
- _revision_cmp_ $type, $old, $new, @fields if $old;
+ _revision_cmp_ $old, $new, @fields if $old;
};
}
@@ -674,150 +846,190 @@ sub revision_ {
# current page number (1..n),
# nextpage (0/1 or, if the full count is known: [$total, $perpage]),
# alignment (t/b)
-# func
+# tableopts obj
sub paginate_ {
- my($url, $p, $np, $al, $fun) = @_;
+ my($url, $p, $np, $al, $tbl) = @_;
my($cnt, $pp) = ref($np) ? @$np : ($p+$np, 1);
- return if !$fun && $p == 1 && $cnt <= $pp;
+ return if !$tbl && $p == 1 && $cnt <= $pp;
my sub tab_ {
my($page, $label) = @_;
li_ sub {
local $_ = $page;
my $u = $url->(p => $page);
- a_ href => $u, $label;
+ a_ href => $u,
+ class => $page == $p ? 'highlightselected' : undef,
+ rel => $label && $label =~ /next/ ? 'next' : $label && $label =~ /prev/ ? 'prev' : undef,
+ $label//$page;
}
}
my sub ell_ {
- my($left) = @_;
- li_ mkclass(ellipsis => 1, left => $left), sub { b_ '⋯' };
+ li_ mkclass(ellipsis => 1), '⋯';
}
- my $nc = 5; # max. number of buttons on each side
-
- div_ class => 'maintabs browsetabs '.($al eq 't' ? '' : 'bottom'), sub {
- ul_ sub {
- $p > 2 and ref $np and tab_ 1, '« first';
- $p > $nc+1 and ref $np and ell_;
- $p > $_ and ref $np and tab_ $p-$_, $p-$_ for (reverse 2..($nc>$p-2?$p-2:$nc-1));
- $p > 1 and tab_ $p-1, '‹ previous';
- };
-
- $fun->() if $fun;
- ul_ sub {
- my $l = ceil($cnt/$pp)-$p+1;
- $l > 1 and tab_ $p+1, 'next ›';
- $l > $_ and tab_ $p+$_, $p+$_ for (2..($nc>$l-2?$l-2:$nc-1));
- $l > $nc+1 and ell_;
- $l > 2 and tab_ $l+$p-1, 'last »';
+ nav_ class => $al eq 't' ? undef : 'bottom', sub {
+ my $n = ceil($cnt/$pp);
+ my $l = $n-$p+1;
+ menu_ class => 'browsetabs', sub {
+ $p > 1 and tab_ $p-1, '‹ previous';
+ if(ref $np) {
+ $p > 3 and tab_ 1;
+ $p > 4 and ell_;
+ $_ > 0 and $_ <= $n and tab_ $_ for ($p-2..$p+2);
+ $l > 4 and ell_;
+ $l > 3 and tab_ $n;
+ }
+ $l > 1 and tab_ $p+1, 'next ›';
};
+
+ $tbl->widget_($url) if $tbl;
}
}
# Generate sort buttons for a table header. This function assumes that sorting
-# options are given as query parameters: 's' for the $column_name to sort on
-# and 'o' for order ('a'sc/'d'esc).
+# options are given either as a TableOpts parameter in 's' or as two query
+# parameters: 's' for the $column_name to sort on and 'o' for order ('a'/'d').
# Options: $column_title, $column_name, $opt, $url
# Where $url is a function that is given ('p', undef, 's', $column_name, 'o', $order) and returns a URL.
sub sortable_ {
- my($name, $opt, $url) = @_;
- $opt->{s} eq $name && $opt->{o} eq 'a' ? txt_ ' ▴' : a_ href => $url->(p => undef, s => $name, o => 'a'), ' ▴';
- $opt->{s} eq $name && $opt->{o} eq 'd' ? txt_ '▾' : a_ href => $url->(p => undef, s => $name, o => 'd'), '▾';
+ my($name, $opt, $url, $space) = @_;
+ txt_ ' ' if $space || !defined $space;
+ if(ref $opt->{s}) {
+ my $o = $opt->{s}->sorted($name);
+ $o eq 'a' ? txt_ '▴' : a_ href => $url->(p => undef, s => $opt->{s}->sort_param($name, 'a')), '▴';
+ $o eq 'd' ? txt_ '▾' : a_ href => $url->(p => undef, s => $opt->{s}->sort_param($name, 'd')), '▾';
+ } else {
+ $opt->{s} eq $name && $opt->{o} eq 'a' ? txt_ '▴' : a_ href => $url->(p => undef, s => $name, o => 'a'), '▴';
+ $opt->{s} eq $name && $opt->{o} eq 'd' ? txt_ '▾' : a_ href => $url->(p => undef, s => $name, o => 'd'), '▾';
+ }
}
sub searchbox_ {
- my($sel, $value) = @_;
+ my($sel, $q) = @_;
+ tuwf->req->{js}{basic} = 1;
+
+ # Only fetch counts for queries that can use the trigram index
+ # (This length requirement is not ideal for Kanji, but pg_trgm doesn't
+ # discriminate between scripts)
+ my %counts = $q && (grep length($_)>=3, $q->words->@*) ?
+ map +($_->{type}, $_->{cnt}), tuwf->dbAlli('
+ SELECT vndbid_type(id) AS type, count(*) AS cnt
+ FROM (
+ SELECT DISTINCT id
+ FROM search_cache sc
+ WHERE', sql_and($q->where()), "
+ AND NOT (id BETWEEN '${sel}1' AND vndbid_max('$sel'))
+ ) x
+ GROUP BY vndbid_type(id)
+ ")->@* : ();
+
+ my sub lnk_ {
+ my($type, $label) = @_;
+ a_ href => "/$type", $sel eq $type ? (class => 'sel') : (), sub {
+ txt_ $label;
+ sup_ class => 'standout', $counts{$type} if $counts{$type};
+ };
+ }
+
fieldset_ class => 'search', sub {
p_ id => 'searchtabs', sub {
- a_ href => '/v/all', $sel eq 'v' ? (class => 'sel') : (), 'Visual novels';
- a_ href => '/r', $sel eq 'r' ? (class => 'sel') : (), 'Releases';
- a_ href => '/p/all', $sel eq 'p' ? (class => 'sel') : (), 'Producers';
- a_ href => '/s/all', $sel eq 's' ? (class => 'sel') : (), 'Staff';
- a_ href => '/c/all', $sel eq 'c' ? (class => 'sel') : (), 'Characters';
- a_ href => '/g', $sel eq 'g' ? (class => 'sel') : (), 'Tags';
- a_ href => '/i', $sel eq 'i' ? (class => 'sel') : (), 'Traits';
- a_ href => '/u/all', $sel eq 'u' ? (class => 'sel') : (), 'Users';
+ lnk_ v => 'Visual novels';
+ lnk_ r => 'Releases';
+ lnk_ p => 'Producers';
+ lnk_ s => 'Staff';
+ lnk_ c => 'Characters';
+ lnk_ g => 'Tags';
+ lnk_ i => 'Traits';
};
- input_ type => 'text', name => 'q', id => 'q', class => 'text', value => $value;
- input_ type => 'submit', class => 'submit', value => 'Search!';
+ input_ type => 'text', name => 'q', id => 'q', class => 'text', value => "$q";
+ input_ type => 'submit', class => 'submit', name => 'sb', value => 'Search!';
};
}
-# Generate a message to display on an entry page when the entry has been locked or the user can't edit it.
+# Generate a message to display on an entry page to report the entry and to indicate it has been locked or the user can't edit it.
sub itemmsg_ {
- my($type, $obj) = @_;
- if($obj->{entry_locked}) {
- p_ class => 'locked', 'Locked for editing';
- } elsif(auth && !can_edit $type => $obj) {
- p_ class => 'locked', 'You can not edit this page';
- }
+ my($obj) = @_;
+ p_ class => 'itemmsg', sub {
+ if($obj->{id} !~ /^[dwu]/) {
+ if($obj->{entry_locked} && !$obj->{entry_hidden}) {
+ txt_ 'Locked for editing. ';
+ } elsif(auth && !can_edit(($obj->{id} =~ /^(.)/), $obj)) {
+ txt_ 'You can not edit this page. ';
+ }
+ }
+ a_ href => "/report/$obj->{id}", $obj->{id} =~ /^u/ ? 'report user' : 'Report an issue on this page.';
+ } if !config->{read_only};
}
-# Generate the initial mainbox when adding or editing a database entry, with a
+# Generate the initial box when adding or editing a database entry, with a
# friendly message pointing to the guidelines and stuff.
# Args: $type ('v','r', etc), $obj (from db_entry(), or undef for new page), $page_title, $is_this_a_copy?
sub editmsg_ {
- my($type, $obj, $title, $copy) = @_;
- my $typename = {v => 'visual novel', r => 'release', p => 'producer', c => 'character', s => 'person'}->{$type};
- my $guidelines = {v => 2, r => 3, p => 4, c => 12, s => 16 }->{$type};
- croak "Unknown type: $type" if !$typename;
-
- div_ class => 'mainbox', sub {
- h1_ sub {
- txt_ $title;
- debug_ $obj if $obj;
- };
- if($copy) {
- div_ class => 'warning', sub {
- h2_ "You're not editing an entry!";
- p_ sub {;
- txt_ "You're about to insert a new entry into the database with information based on ";
- a_ href => "/$type$obj->{id}", "$type$obj->{id}";
- txt_ '.';
- br_;
- txt_ "Hit the 'edit' tab on the right-top if you intended to edit the entry instead of creating a new one.";
- }
- }
- }
- # 'lastrev' is for compatibility with VNDB::*
- if($obj && ($obj->{maxrev} ? $obj->{maxrev} != $obj->{chrev} : !$obj->{lastrev})) {
- div_ class => 'warning', sub {
- h2_ 'Reverting';
- p_ "You are editing an old revision of this $typename. If you save it, all changes made after this revision will be reverted!";
- }
- }
- div_ class => 'notice', sub {
- h2_ 'Before editing:';
- ul_ sub {
- li_ sub {
- txt_ 'Read the ';
- a_ href=> "/d$guidelines", 'guidelines';
- txt_ '!';
- };
- if($obj) {
- li_ sub {
- txt_ 'Check for any existing discussions on the ';
- a_ href => '/t/'._board_id($type, $obj), 'discussion board';
- };
- # TODO: Include a list of the most recent edits in this page.
- li_ sub {
- txt_ 'Browse the ';
- a_ href => "/$type$obj->{id}/hist", 'edit history';
- txt_ ' for any recent changes related to what you want to change.';
- };
- } elsif($type ne 'r') {
- li_ sub {
- a_ href => "/$type/all", 'Search the database';
- txt_ " to see if we already have information about this $typename.";
- }
- }
- }
- };
- }
+ my($type, $obj, $title, $copy) = @_;
+ my $typename = {v => 'visual novel', r => 'release', p => 'producer', c => 'character', s => 'person'}->{$type};
+ my $guidelines = {v => 2, r => 3, p => 4, c => 12, s => 16 }->{$type};
+ croak "Unknown type: $type" if !$typename;
+
+ article_ sub {
+ h1_ sub {
+ txt_ $title;
+ debug_ $obj if $obj;
+ };
+ if($obj && config->{data_requests}{$obj->{id}}) {
+ div_ class => 'warning', sub {
+ h2_ '## DATA REMOVAL/CHANGE REQUEST ##';
+ br_;
+ p_ sub { lit_ config->{data_requests}{$obj->{id}} };
+ br_;
+ h2_ '## DATA REMOVAL/CHANGE REQUEST ##';
+ };
+ }
+ if($copy) {
+ div_ class => 'warning', sub {
+ h2_ "You're not editing an entry!";
+ p_ sub {;
+ txt_ "You're about to insert a new entry into the database with information based on ";
+ a_ href => "/$obj->{id}", $obj->{id};
+ txt_ '.';
+ br_;
+ txt_ "Hit the 'edit' tab on the right-top if you intended to edit the entry instead of creating a new one.";
+ }
+ }
+ }
+ if($obj && $obj->{maxrev} != $obj->{chrev}) {
+ div_ class => 'warning', sub {
+ h2_ 'Reverting';
+ p_ "You are editing an old revision of this $typename. If you save it, all changes made after this revision will be reverted!";
+ }
+ }
+ div_ class => 'notice', sub {
+ h2_ 'Before editing:';
+ ul_ sub {
+ li_ sub {
+ txt_ 'Read the ';
+ a_ href=> "/d$guidelines", 'guidelines';
+ txt_ '!';
+ };
+ if($obj) {
+ li_ sub {
+ txt_ 'Check for any existing discussions on the ';
+ a_ href => '/t/'._board_id($obj), 'discussion board';
+ };
+ } elsif($type ne 'r') {
+ li_ sub {
+ a_ href => "/$type/all", 'Search the database';
+ txt_ " to see if we already have information about this $typename.";
+ }
+ }
+ li_ 'Fields marked with (*) may cause other fields to become (un)available depending on the selection.' if $type eq 'r';
+ }
+ };
+ };
+ VNWeb::Misc::History::tablebox_($obj->{id}, {p=>1}, results => 10, nopage => 1) if $obj && !$copy;
}
1;
diff --git a/lib/VNWeb/Images/Lib.pm b/lib/VNWeb/Images/Lib.pm
new file mode 100644
index 00000000..0170d37e
--- /dev/null
+++ b/lib/VNWeb/Images/Lib.pm
@@ -0,0 +1,166 @@
+package VNWeb::Images::Lib;
+
+use VNWeb::Prelude;
+use Exporter 'import';
+
+our @EXPORT = qw/enrich_image validate_token image_flagging_display image_hidden image_ enrich_image_obj/;
+
+
+my @SEX = qw/Safe Suggestive Explicit/;
+my @VIO = qw/Tame Violent Brutal /;
+
+# Enrich images so that they match the format expected by the 'ImageResult' Elm
+# API response.
+#
+# Also adds signed tokens to the image list - indicating that the current user
+# is permitted to vote on these images. These tokens ensure that non-moderators
+# can only vote on images that they have been randomly assigned, thus
+# preventing possible abuse when a single person uses multiple accounts to
+# influence the rating of a single image.
+sub enrich_image {
+ my($canvote, $l) = @_;
+ enrich_merge id => sub { sql q{
+ SELECT i.id, i.width, i.height, i.c_votecount AS votecount
+ , i.c_sexual_avg::real/100 AS sexual_avg, i.c_sexual_stddev::real/100 AS sexual_stddev
+ , i.c_violence_avg::real/100 AS violence_avg, i.c_violence_stddev::real/100 AS violence_stddev
+ , iv.sexual AS my_sexual, iv.violence AS my_violence
+ , COALESCE(EXISTS(SELECT 1 FROM image_votes iv0 WHERE iv0.id = i.id AND iv0.ignore) AND NOT iv.ignore, FALSE) AS my_overrule
+ , COALESCE(v.id, c.id, vsv.id) AS entry_id
+ , COALESCE(v.title[1+1], c.title[1+1], vsv.title[1+1]) AS entry_title
+ FROM images i
+ LEFT JOIN image_votes iv ON iv.id = i.id AND iv.uid =}, \auth->uid, q{
+ LEFT JOIN}, vnt, q{v ON i.id BETWEEN 'cv1' AND vndbid_max('cv') AND v.image = i.id
+ LEFT JOIN}, charst, q{c ON i.id BETWEEN 'ch1' AND vndbid_max('ch') AND c.image = i.id
+ LEFT JOIN vn_screenshots vs ON i.id BETWEEN 'sf1' AND vndbid_max('sf') AND vs.scr = i.id
+ LEFT JOIN}, vnt, q{vsv ON i.id BETWEEN 'sf1' AND vndbid_max('sf') AND vsv.id = vs.id
+ WHERE i.id IN}, $_
+ }, $l;
+
+ enrich votes => id => id => sub { sql '
+ SELECT iv.id, iv.uid, iv.sexual, iv.violence, iv.ignore OR (u.id IS NOT NULL AND NOT u.perm_imgvote) AS ignore, ', sql_user(), '
+ FROM image_votes iv
+ LEFT JOIN users u ON u.id = iv.uid
+ WHERE iv.id IN', $_,
+ auth ? ('AND (iv.uid IS NULL OR iv.uid <> ', \auth->uid, ')') : (), '
+ ORDER BY u.username'
+ }, $l;
+
+ for(grep defined $_->{width}, @$l) {
+ $_->{entry} = $_->{entry_id} ? { id => $_->{entry_id}, title => $_->{entry_title} } : undef;
+ delete $_->{entry_id};
+ delete $_->{entry_title};
+ for my $v ($_->{votes}->@*) {
+ $v->{user} = xml_string sub { user_ $v }; # Easier than duplicating user_() in Elm
+ delete $v->{$_} for grep /^user_/, keys %$v;
+ }
+ $_->{token} = ($_->{votecount} == 0 && auth->permImgvote) || (ref $canvote eq 'CODE' ? $canvote->($_) : $canvote) ? auth->csrftoken(0, "imgvote-$_->{id}") : undef;
+ }
+}
+
+# Validates the token generated by enrich_image;
+sub validate_token {
+ my($l) = @_;
+ my $ok = 1;
+ $ok &&= $_->{token} && auth->csrfcheck($_->{token}, "imgvote-$_->{id}") for @$l;
+ $ok;
+}
+
+
+# Returns a string like 'Not flagged' or 'Safe / Tame (5)'
+sub image_flagging_display {
+ my($img, $small) = @_;
+ !$img->{votecount} ? 'Not flagged' :
+ $small ? sprintf '%s / %s', $SEX[$img->{sexual}], $VIO[$img->{violence}]
+ : sprintf '%s / %s (%d)', $SEX[$img->{sexual}], $VIO[$img->{violence}], $img->{votecount}
+}
+
+
+# Returns whether the image is hidden according to the user's preferences.
+# Return values:
+# 0 -> visible
+# 4 -> hidden for some reason
+# 5 -> hidden because of sexual flag
+# 6 -> hidden because of violence flag
+# 7 -> hidden because both
+sub image_hidden {
+ my($img) = @_;
+ my($sex,$vio) = $img->@{'sexual', 'violence'};
+ my $sexp = auth->pref('max_sexual')||0;
+ my $viop = auth->pref('max_violence')||0;
+ my $sexh = $sex > $sexp && $sexp >= 0 if $img->{votecount};
+ my $vioh = $vio > $viop if $img->{votecount};
+ my $hidden = $sexp < 0 || $sexh || $vioh || (!$img->{votecount} && ($sexp < 2 || $viop < 2));
+ $hidden ? 4 + ($sexh?1:0)+($vioh?2:0) : 0;
+}
+
+
+# Display (or not) an image with preference toggle and hover-information.
+# Given $img is assumed to be an object generated by enrich_image_obj().
+# %opt:
+# alt -> alt text
+# width -> if different from original image
+# height -> if different from original image
+# url -> link the image to a page (if not hidden by settings)
+# overlay -> CODE ref, html to replace the overlay with.
+# XXX: Not all of these options are used, could clean up a few.
+sub image_ {
+ my($img, %opt) = @_;
+ return p_ 'No image' if !$img;
+
+ my($sex,$vio) = $img->@{'sexual', 'violence'};
+ my($w,$h) = $opt{width} ? @opt{'width','height'} : @{$img}{'width', 'height'};
+ my $hidden = image_hidden $img;
+ my $hide_on_click = $opt{url} ? $hidden : $sex || $vio || !$img->{votecount} || (auth->pref('max_sexual')||0) < 0;
+ my $small = $w*$h < 20000;
+
+ label_ class => 'imghover', style => "width: ${w}px; height: ${h}px", sub {
+ input_ type => 'checkbox', class => 'hidden', $hidden ? () : (checked => 'checked') if $hide_on_click;
+ div_ class => 'imghover--visible', sub {
+ a_ href => $opt{url} if $opt{url};
+ img_ src => imgurl($img->{id}), width => $w, height => $h, $opt{alt} ? (alt => $opt{alt}) : ();
+ end_ if $opt{url};
+ if(!exists $opt{overlay}) {
+ a_ class => 'imghover--overlay', href => "/$img->{id}?view=".viewset(show_nsfw=>1), image_flagging_display $img, $small if auth;
+ span_ class => 'imghover--overlay', image_flagging_display $img, $small if !auth;
+ } elsif(ref $opt{overlay} eq 'CODE') {
+ $opt{overlay}->();
+ }
+ };
+ div_ class => 'imghover--warning', sub {
+ if($img->{votecount}) {
+ if(!$small) {
+ txt_ 'This image has been flagged as:';
+ br_; br_;
+ }
+ txt_ 'Sexual: '; $hidden & 1 ? b_ $SEX[$sex] : txt_ $SEX[$sex];
+ br_;
+ txt_ 'Violence: '; $hidden & 2 ? b_ $VIO[$vio] : txt_ $VIO[$vio];
+ } else {
+ txt_ 'This image has not yet been flagged';
+ }
+ if(!$small) {
+ br_; br_;
+ span_ class => 'fake_link', 'Show me anyway';
+ br_; br_;
+ small_ 'This warning can be disabled in your account';
+ }
+ } if $hide_on_click;
+ }
+}
+
+
+sub enrich_image_obj {
+ my $field = shift;
+ enrich_obj $field => id => 'SELECT id, width, height, c_votecount AS votecount, c_sexual_avg::real/100 AS sexual_avg, c_violence_avg::real/100 AS violence_avg FROM images WHERE id IN', @_;
+
+ # Also add our final verdict. Still no clue why I chose these thresholds, but they seem to work.
+ for (map +(ref $_ eq 'ARRAY' ? @$_ : $_), @_) {
+ local $_ = $_->{$field};
+ if(ref $_) {
+ $_->{sexual} = !$_->{votecount} ? 2 : $_->{sexual_avg} > 1.3 ? 2 : $_->{sexual_avg} > 0.4 ? 1 : 0;
+ $_->{violence} = !$_->{votecount} ? 2 : $_->{violence_avg} > 1.3 ? 2 : $_->{violence_avg} > 0.4 ? 1 : 0;
+ }
+ }
+}
+
+1;
diff --git a/lib/VNWeb/Images/List.pm b/lib/VNWeb/Images/List.pm
new file mode 100644
index 00000000..28713316
--- /dev/null
+++ b/lib/VNWeb/Images/List.pm
@@ -0,0 +1,209 @@
+package VNWeb::Images::List;
+
+use VNWeb::Prelude;
+
+
+sub graph_ {
+ my($i, $opt) = @_;
+ my($gw, $go) = (150, 40); # histogram width, x offset
+
+ sub clamp { $_[0] > $_[2] ? $_[0] : $_[1] < $_[2] ? $_[1] : $_[2] }
+
+ my $y;
+ my sub line_ {
+ my($lbl, $left, $mid, $right) = @_;
+ tag_ 'text', x => 0, y => $y+9, $lbl;
+ tag_ 'line', class => 'errorbar', x1 => $go+clamp(0, $gw, $left*$gw/2), y1 => $y+5, x2 => $go+clamp(0, $gw, $right*$gw/2), y2 => $y+5, undef;
+ tag_ 'rect', width => 5, height => 10, x => $go+clamp(0, $gw-5, $mid*$gw/2-2), y => $y, undef;
+ $y += 12;
+ }
+
+ my sub subgraph_ {
+ my($left, $right, $avg, $stddev, $my, $user) = @_;
+ tag_ 'text', x => $go-2, y => 10, $left;
+ tag_ 'text', x => $go+$gw, y => 10, 'text-anchor' => 'end', $right;
+ tag_ 'line', class => 'ruler', x1 => $go, y1 => 12, x2 => $go, y2 => 46, undef;
+ tag_ 'line', class => 'ruler', x1 => $go+$gw/2, y1 => 12, x2 => $go+$gw/2, y2 => 46, undef;
+ tag_ 'line', class => 'ruler', x1 => $go+$gw-2, y1 => 12, x2 => $go+$gw-2, y2 => 46, undef;
+
+ $y = 13;
+ line_ 'Avg', $avg-$stddev, $avg, $avg+$stddev if defined $avg;
+ line_ 'User', $user, $user, $avg if defined $user;
+ line_ 'My', $my, $my, $avg if defined $my && $opt->{u} ne $opt->{u2};
+ }
+
+ tag_ 'svg', width => '190px', height => '100px', viewBox => '0 0 190 100', sub {
+ tag_ 'g', sub {
+ subgraph_ 'Safe', 'Explicit', $i->{sexual_avg}, $i->{sexual_stddev}, $i->{my_sexual}, $i->{user_sexual}
+ };
+ tag_ 'g', transform => 'translate(0,51)', sub {
+ subgraph_ 'Tame', 'Brutal', $i->{violence_avg}, $i->{violence_stddev}, $i->{my_violence}, $i->{user_violence}
+ };
+ };
+}
+
+
+sub listing_ {
+ my($lst, $np, $opt, $url) = @_;
+
+ my $view = viewset(show_nsfw => 1);
+ paginate_ $url, $opt->{p}, $np, 't';
+ article_ class => 'imagebrowse', sub {
+ div_ class => 'imagecard', sub {
+ a_ href => "/$_->{id}?view=$view", style => 'background-image: url('.imgurl($_->{id}, $_->{id} =~ /^sf/ ? 't' : '').')', '';
+ div_ sub {
+ a_ href => "/$_->{id}?view=$view", $_->{id};
+ txt_ sprintf ' / %d', $_->{c_votecount},;
+ small_ sprintf ' / w%d', $_->{c_weight};
+ br_;
+ graph_ $_, $opt;
+ };
+ } for @$lst;
+ };
+ paginate_ $url, $opt->{p}, $np, 'b';
+}
+
+
+sub opts_ {
+ my($opt, $u) = @_;
+
+ my sub opt_ {
+ my($type, $key, $val, $label, $checked) = @_;
+ input_ type => $type, name => $key, id => "form_${key}{$val}", value => $val,
+ $checked // $opt->{$key} eq $val ? (checked => 'checked') : ();
+ label_ for => "form_${key}{$val}", $label;
+ };
+
+ form_ sub {
+ input_ type => 'hidden', class => 'hidden', name => 'u', value => $opt->{u} if $opt->{u};
+ input_ type => 'hidden', class => 'hidden', name => 'u2', value => $opt->{u2} if $opt->{u2} ne (auth->uid||'');
+ input_ type => 'hidden', class => 'hidden', name => 'view', value => viewset(show_nsfw => viewget('show_nsfw'));
+ table_ style => 'margin: auto', sub {
+ tr_ sub {
+ td_ 'User:';
+ td_ sub { user_ $u };
+ } if $u;
+ tr_ sub {
+ td_ 'Image types:';
+ td_ class => 'linkradio', sub {
+ opt_ checkbox => t => 'ch', 'Character images', $opt->{t}->@* == 0 || in ch => $opt->{t}; em_ ' / ';
+ opt_ checkbox => t => 'cv', 'VN images', $opt->{t}->@* == 0 || in cv => $opt->{t}; em_ ' / ';
+ opt_ checkbox => t => 'sf', 'Screenshots', $opt->{t}->@* == 0 || in sf => $opt->{t};
+ };
+ };
+ tr_ sub {
+ td_ 'Minimum votes:';
+ td_ class => 'linkradio', sub { join_ sub { em_ ' / ' }, sub { opt_ radio => m => $_, $_ }, 0..10 };
+ };
+ tr_ sub {
+ td_ '';
+ td_ class => 'linkradio', sub { opt_ checkbox => my => 1, 'Only images I voted on' };
+ } if auth && $opt->{u} ne $opt->{u2};
+ tr_ sub {
+ td_ '';
+ td_ class => 'linkradio', sub { opt_ checkbox => up => 1, 'Only images uploaded by this user' };
+ } if $opt->{u};
+ tr_ sub {
+ td_ 'Time filter';
+ td_ class => 'linkradio', sub {
+ opt_ radio => d => 1, 'Last 24h'; em_ ' / ';
+ opt_ radio => d => 7, 'Last 7d'; em_ ' / ';
+ opt_ radio => d => 30, 'Last 30d'; em_ ' / ';
+ opt_ radio => d => 0, 'Any time';
+ }
+ } if $opt->{u};
+ tr_ sub {
+ td_ 'Order by:';
+ td_ class => 'linkradio', sub {
+ if($u) {
+ opt_ radio => s => 'date', 'Recent'; em_ ' / ';
+ opt_ radio => s => 'diff', 'Vote difference'; em_ ' / ';
+ }
+ opt_ radio => s => 'weight', 'Weight'; em_ ' / ';
+ opt_ radio => s => 'sdev', 'Sexual stddev'; em_ ' / ';
+ opt_ radio => s => 'vdev', 'Violence stddev';
+ }
+ };
+ tr_ sub {
+ td_ '';
+ td_ sub { input_ type => 'submit', class => 'submit', value => 'Update' };
+ }
+ }
+ }
+}
+
+
+TUWF::get qr{/img/list}, sub {
+ # TODO filters: sexual / violence?
+ my $opt = tuwf->validate(get =>
+ s => { onerror => 'date', enum => [qw/ weight sdev vdev date diff/] },
+ t => { onerror => [], scalar => 1, type => 'array', values => { enum => [qw/ ch cv sf /] } },
+ m => { onerror => 0, range => [0,10] },
+ d => { onerror => 0, range => [0,10000] },
+ u => { onerror => '', vndbid => 'u' },
+ u2 => { onerror => '', vndbid => 'u' }, # Hidden option, allows comparing two users by overriding the 'My' user.
+ my => { anybool => 1 },
+ up => { anybool => 1 },
+ p => { page => 1 },
+ )->data;
+
+ $opt->{u2} ||= auth->uid || '';
+ $opt->{s} = 'weight' if !$opt->{u} && ($opt->{s} eq 'date' || $opt->{s} eq 'diff');
+ $opt->{t} = [ List::Util::uniq sort $opt->{t}->@* ];
+ $opt->{t} = [] if $opt->{t}->@* == 3;
+ $opt->{d} = 0 if !$opt->{u};
+
+ my $u = $opt->{u} && tuwf->dbRowi('SELECT id, ', sql_user(), 'FROM users u WHERE id =', \$opt->{u});
+ return tuwf->resNotFound if $opt->{u} && (!$u->{id} || (!defined $u->{user_name} && !auth->isMod));
+
+ my $where = sql_and
+ $opt->{t}->@* ? sql_or(map sql('i.id BETWEEN vndbid(',\"$_",',1) AND vndbid_max(',\"$_",')'), $opt->{t}->@*) : (),
+ $opt->{m} ? sql('i.c_votecount >=', \$opt->{m}) : (),
+ $opt->{d} ? sql('iu.date > NOW()-', \"$opt->{d} days", '::interval') : (),
+ $opt->{up} && $opt->{u} ? sql('i.uploader =', \$opt->{u}) : ();
+
+ my($lst, $np) = tuwf->dbPagei({ results => 100, page => $opt->{p} }, '
+ SELECT i.id, i.width, i.height, i.c_votecount, i.c_weight
+ , i.c_sexual_avg::real/100 AS sexual_avg, i.c_sexual_stddev::real/100 AS sexual_stddev
+ , i.c_violence_avg::real/100 AS violence_avg, i.c_violence_stddev::real/100 AS violence_stddev
+ , iv.sexual as my_sexual, iv.violence as my_violence',
+ $opt->{u} ? ', iu.sexual as user_sexual, iu.violence as user_violence' : (), '
+ FROM images i',
+ $opt->{u} ? ('JOIN image_votes iu ON iu.uid =', \$opt->{u}, ' AND iu.id = i.id') : (),
+ $opt->{my} ? () : 'LEFT', 'JOIN image_votes iv ON iv.uid =', \($opt->{u2}||undef), ' AND iv.id = i.id
+ WHERE', $where, '
+ ORDER BY', {
+ weight => 'i.c_weight DESC',
+ sdev => 'i.c_sexual_stddev DESC NULLS LAST',
+ vdev => 'i.c_violence_stddev DESC NULLS LAST',
+ date => 'iu.date DESC',
+ diff => 'abs(iu.sexual*100-i.c_sexual_avg) + abs(iu.violence*100-i.c_violence_avg) DESC',
+ }->{$opt->{s}}, ', i.id'
+ );
+
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ my $title = $u ? 'Images flagged by '.user_displayname($u) : 'Image browser';
+
+ framework_ title => $title, sub {
+ article_ sub {
+ h1_ $title;
+ opts_ $opt, $u;
+ };
+ my $nsfw = viewget->{show_nsfw};
+ listing_ $lst, $np, $opt, \&url if $nsfw && @$lst;
+ article_ sub {
+ div_ class => 'warning', sub {
+ h2_ 'NSFW Warning';
+ p_ sub {
+ txt_ 'This listing contains images that may contain sexual content or violence. ';
+ a_ href => url(view => viewset show_nsfw => 1), 'I understand, show me.';
+ br_;
+ txt_ '(This warning can be disabled in your profile)';
+ };
+ };
+ } if !$nsfw && @$lst;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Images/Upload.pm b/lib/VNWeb/Images/Upload.pm
new file mode 100644
index 00000000..113ef9c8
--- /dev/null
+++ b/lib/VNWeb/Images/Upload.pm
@@ -0,0 +1,86 @@
+package VNWeb::Misc::ImageUpload;
+
+use VNWeb::Prelude;
+use VNWeb::Images::Lib;
+use AnyEvent::Util;
+
+
+TUWF::post qr{/elm/ImageUpload.json}, sub {
+ # Have to require the samesite cookie here as CSRF protection, because this API can be triggered as a regular HTML form post.
+ return elm_Unauth if !samesite || !(auth->permDbmod || (auth->permEdit && !global_settings->{lockdown_edit}));
+
+ my $type = tuwf->validate(post => type => { enum => [qw/cv ch sf/] })->data;
+ my $imgdata = tuwf->reqUploadRaw('img');
+ my $fmt =
+ $imgdata =~ /^\xff\xd8/ ? 'jpg' :
+ $imgdata =~ /^\x89\x50/ ? 'png' :
+ $imgdata =~ /^RIFF....WEBP/s ? 'webp' :
+ $imgdata =~ /^....ftyp/s ? 'avif' : # Considers every heif file to be AVIF, not entirely correct but works fine.
+ $imgdata =~ /^\xff\x0a/ ? 'jxl' :
+ $imgdata =~ /^\x00\x00\x00\x00\x0CJXL / ? 'jxl' : undef;
+ return elm_ImgFormat if !$fmt;
+
+ my $seq = {qw/sf screenshots_seq cv covers_seq ch charimg_seq/}->{$type}||die;
+ my $id = tuwf->dbVali('INSERT INTO images', {
+ id => sql_func(vndbid => \$type, sql(sql_func(nextval => \$seq), '::int')),
+ uploader => \auth->uid,
+ width => 0,
+ height => 0
+ }, 'RETURNING id');
+
+ my $fno = imgpath($id, 'orig', $fmt);
+ my $fn0 = imgpath($id);
+ my $fn1 = imgpath($id, 't');
+
+ {
+ open my $F, '>', $fno or die $!;
+ print $F $imgdata;
+ }
+
+ my $rc = run_cmd(
+ [
+ config->{imgproc_path},
+ $type eq 'ch' ? (fit => config->{ch_size}->@*, size => jpeg => 1) :
+ $type eq 'cv' ? (fit => config->{cv_size}->@*, size => jpeg => 1) :
+ $type eq 'sf' ? (size => jpeg => 1 => fit => config->{scr_size}->@*, jpeg => 3) : die
+ ],
+ '<', \$imgdata,
+ '>', $fn0,
+ '2>', \my $err,
+ $type eq 'sf' ? ('3>', $fn1) : (),
+ close_all => 1,
+ on_prepare => sub { %ENV = () },
+ )->recv;
+ chomp($err);
+
+ if($rc || !-s $fn0 || $err !~ /^([0-9]+)x([0-9]+)$/) {
+ warn "imgproc: $err\n" if $err;
+ warn "Failed to run imgproc for $id\n";
+ # keep original for troubleshooting
+ rename $fno, config->{var_path}."/tmp/error-${id}.${fmt}";
+ unlink $fn0;
+ unlink $fn1;
+ tuwf->dbRollBack;
+ return elm_ImgFormat;
+ }
+ my($w,$h) = ($1,$2);
+ tuwf->dbExeci('UPDATE images SET', { width => $w, height => $h }, 'WHERE id =', \$id);
+
+ chmod 0666, $fno;
+ chmod 0666, $fn0;
+ chmod 0666, $fn1;
+
+ my $l = [{id => $id}];
+ enrich_image 1, $l;
+ elm_ImageResult $l;
+};
+
+
+elm_api Image => undef, { id => { vndbid => [qw/ch cv sf/] } }, sub {
+ my($data) = @_;
+ my $l = tuwf->dbAlli('SELECT id FROM images WHERE id =', \$data->{id});
+ enrich_image 0, $l;
+ elm_ImageResult $l;
+};
+
+1;
diff --git a/lib/VNWeb/Images/Vote.pm b/lib/VNWeb/Images/Vote.pm
new file mode 100644
index 00000000..48c1fffb
--- /dev/null
+++ b/lib/VNWeb/Images/Vote.pm
@@ -0,0 +1,138 @@
+package VNWeb::Images::Vote;
+
+use VNWeb::Prelude;
+use VNWeb::Images::Lib;
+
+
+my $SEND = form_compile any => {
+ images => $VNWeb::Elm::apis{ImageResult}[0],
+ single => { anybool => 1 },
+ warn => { anybool => 1 },
+ mod => { anybool => 1 },
+ my_votes => { uint => 1 },
+ pWidth => { uint => 1 }, # Set by JS
+ pHeight => { uint => 1 }, # ^
+ nsfw_token => {},
+};
+
+
+sub can_vote { auth->permDbmod || (auth->permImgvote && !global_settings->{lockdown_edit}) }
+
+
+# Fetch a list of images for the user to vote on.
+elm_api Images => $SEND, { excl_voted => { anybool => 1 } }, sub {
+ my($data) = @_;
+ return elm_Unauth if !can_vote;
+
+ state $stats = tuwf->dbRowi('SELECT COUNT(*) as total, COUNT(*) FILTER (WHERE c_weight > 1) AS referenced FROM images');
+
+ # Performing a proper weighted sampling on the entire images table is way
+ # too slow, so we do a TABLESAMPLE to first randomly select a number of
+ # rows and then get a weighted sampling from that. The TABLESAMPLE fraction
+ # is adjusted so that we get approximately 5000 rows to work with. This is
+ # hopefully enough to get a good (weighted) sample and should have a good
+ # chance at selecting images even when the user has voted on 90%.
+ #
+ # TABLESAMPLE is not used if there are only few images to select from, i.e.
+ # when the user has already voted on 99% of all images. Finding all
+ # applicable images in that case is slow, but at least there aren't many
+ # rows for the final ORDER BY.
+ my $tablesample =
+ !$data->{excl_voted} || tuwf->dbVali('SELECT c_imgvotes FROM users WHERE id =', \auth->uid) < $stats->{referenced}*0.99
+ ? 100 * min 1, (5000 / $stats->{referenced}) * ($stats->{total} / $stats->{referenced})
+ : 100;
+
+ # NOTE: Elm assumes that, if it receives less than 30 images, we've reached
+ # the end of the list and will not attempt to load more.
+ my $l = tuwf->dbAlli('
+ SELECT id
+ FROM images TABLESAMPLE SYSTEM (', \$tablesample, ')
+ WHERE c_weight > 1',
+ $data->{excl_voted} ? ('AND NOT (c_uids && ARRAY[', \auth->uid, '::vndbid])') : (), '
+ ORDER BY random() ^ (1.0/c_weight) DESC
+ LIMIT', \30
+ );
+ warn sprintf 'Weighted random image sampling query returned %d < 30 rows for %s with a sample fraction of %f', scalar @$l, auth->uid(), $tablesample if @$l < 30;
+ enrich_image 1, $l;
+ elm_ImageResult $l;
+};
+
+
+elm_api ImageVote => undef, {
+ votes => { sort_keys => 'id', aoh => {
+ id => { vndbid => [qw/ch cv sf/] },
+ token => {},
+ sexual => { uint => 1, range => [0,2] },
+ violence => { uint => 1, range => [0,2] },
+ overrule => { anybool => 1 },
+ } },
+}, sub {
+ my($data) = @_;
+ return elm_Unauth if !can_vote;
+ return elm_Unauth if !validate_token $data->{votes};
+
+ # Lock the users table early to prevent deadlock with a concurrent DB edit that attempts to update c_changes.
+ tuwf->dbExeci('SELECT c_imgvotes FROM users WHERE id =', \auth->uid, 'FOR UPDATE');
+
+ # Find out if any of these images are being overruled
+ enrich_merge id => sub { sql 'SELECT id, bool_or(ignore) AS overruled FROM image_votes WHERE id IN', $_, 'GROUP BY id' }, $data->{votes};
+ enrich_merge id => sql('SELECT id, NOT ignore AS my_overrule FROM image_votes WHERE uid =', \auth->uid, 'AND id IN'),
+ grep $_->{overruled}, $data->{votes}->@* if auth->permDbmod;
+
+ for($data->{votes}->@*) {
+ $_->{overrule} = 0 if !auth->permDbmod;
+ my $d = {
+ id => $_->{id},
+ uid => auth->uid(),
+ sexual => $_->{sexual},
+ violence => $_->{violence},
+ ignore => !$_->{overrule} && !$_->{my_overrule} && $_->{overruled} ? 1 : 0,
+ };
+ tuwf->dbExeci('INSERT INTO image_votes', $d, 'ON CONFLICT (id, uid) DO UPDATE SET', $d, ', date = now()');
+ tuwf->dbExeci('UPDATE image_votes SET ignore =', \($_->{overrule}?1:0), 'WHERE uid IS DISTINCT FROM', \auth->uid, 'AND id =', \$_->{id})
+ if !$_->{overrule} != !$_->{my_overrule};
+ }
+ elm_Success
+};
+
+
+sub my_votes {
+ auth ? tuwf->dbVali('SELECT c_imgvotes FROM users WHERE id =', \auth->uid) : 0
+}
+
+
+sub imgflag_ {
+ elm_ 'ImageFlagging', $SEND, {
+ my_votes => my_votes(),
+ nsfw_token => viewset(show_nsfw => 1),
+ mod => auth->permDbmod()||0,
+ @_
+ };
+}
+
+
+TUWF::get qr{/img/vote}, sub {
+ return tuwf->resDenied if !can_vote;
+
+ my $recent = tuwf->dbAlli('SELECT id FROM image_votes WHERE uid =', \auth->uid, 'ORDER BY date DESC LIMIT', \30);
+ enrich_image 1, $recent;
+
+ framework_ title => 'Image flagging', sub {
+ imgflag_ images => [ reverse @$recent ], single => 0, warn => 1;
+ };
+};
+
+
+TUWF::get qr{/$RE{imgid}}, sub {
+ my $id = tuwf->capture('id');
+
+ my $l = [{ id => $id }];
+ enrich_image auth->permDbmod() || sub { defined $_[0]{my_sexual} }, $l;
+ return tuwf->resNotFound if !defined $l->[0]{width};
+
+ framework_ title => "Image flagging for $id", sub {
+ imgflag_ images => $l, single => 1, warn => !viewget->{show_nsfw};
+ };
+};
+
+1;
diff --git a/lib/VNWeb/JS.pm b/lib/VNWeb/JS.pm
new file mode 100644
index 00000000..6a81c757
--- /dev/null
+++ b/lib/VNWeb/JS.pm
@@ -0,0 +1,73 @@
+package VNWeb::JS;
+
+use v5.26;
+use TUWF;
+use VNDB::Config;
+use VNWeb::Validation ();
+use Exporter 'import';
+
+our @EXPORT = qw/js_api/;
+
+
+# Provide a '/js/<endpoint>.json' API for the JS front-end.
+# The $fun callback is given the validated json request object as argument.
+# It should return a string on error or a hash on success.
+sub js_api {
+ my($endpoint, $schema, $fun) = @_;
+ $schema = tuwf->compile({ type => 'hash', keys => $schema }) if ref $schema eq 'HASH';
+
+ TUWF::post qr{/js/\Q$endpoint\E\.json} => sub {
+ my $data = tuwf->validate(json => $schema);
+ if(!$data) {
+ my $err = $data->err;
+ warn "JSON validation failed\ninput: " . JSON::XS->new->allow_nonref->pretty->canonical->encode(tuwf->reqJSON) . "\nerror: " . JSON::XS->new->encode($err) . "\n";
+ $err = $err->{errors}[0]//{};
+ return tuwf->resJSON({_err => 'Form validation failed'.($err->{key} ? " ($err->{key})." : '.')});
+ }
+ my $res = $fun->($data->data);
+ tuwf->resJSON(ref $res ? $res : {_err => $res});
+ };
+}
+
+
+# Log errors from JS.
+TUWF::post qr{/js-error}, sub {
+ my($ev, $source, $lineno, $colno, $stack) = map tuwf->reqPost($_)//'-', qw/ev source lineno colno stack/;
+ return if $source =~ /elm\.js/ && $ev =~ /InvalidStateError/;
+ my $msg = sprintf
+ "\nMessage: %s"
+ ."\nSource: %s %s:%s\n", $ev, $source, $lineno, $colno;
+ $msg .= "Referer: ".tuwf->reqHeader('referer')."\n" if tuwf->reqHeader('referer');
+ $msg .= "Browser: ".tuwf->reqHeader('user-agent')."\n" if tuwf->reqHeader('user-agent');
+ $msg .= ($stack =~ s/[\r\n]+$//r)."\n" if $stack ne '-' && $stack ne 'undefined' && $stack ne 'null';
+ warn $msg;
+};
+
+
+# Returns a hashref with widget_name => bundle_name.
+sub widgets {
+ state $w ||= do {
+ my %w;
+ my sub grab {
+ $w{$1} = $_[0] if $_[1] =~ /(?:^|\W)widget\s*\(\s*['"]([^'"]+)['"]/;
+ }
+ for my $index (glob config->{root}."/js/*/index.js") {
+ my $bundle = $index =~ s#.+/([^/]+)/index\.js$#$1#r;
+ my @f;
+ {
+ open my $F, '<', $index or die $!;
+ while (local $_ = <$F>) {
+ grab($bundle, $_);
+ push @f, $1 if /^\@include (.+)/ && !/ \.gen\//;
+ }
+ };
+ for (@f) {
+ open my $F, '<', config->{root}."/js/$bundle/$_" or die $!;
+ grab($bundle, $_) while (<$F>);
+ }
+ }
+ \%w;
+ };
+}
+
+1;
diff --git a/lib/VNWeb/Misc/AdvSearch.pm b/lib/VNWeb/Misc/AdvSearch.pm
new file mode 100644
index 00000000..ea101ff9
--- /dev/null
+++ b/lib/VNWeb/Misc/AdvSearch.pm
@@ -0,0 +1,31 @@
+package VNWeb::Misc::AdvSearch;
+
+use VNWeb::Prelude;
+use VNWeb::AdvSearch;
+
+
+elm_api 'AdvSearchSave' => undef, {
+ name => { default => '', length => [1,50] },
+ qtype => { enum => \%VNWeb::AdvSearch::FIELDS },
+ query => {},
+}, sub {
+ my($d) = @_;
+ my $q = tuwf->compile({ advsearch => $d->{qtype} })->validate($d->{query})->data->query_encode;
+ tuwf->dbExeci(
+ 'INSERT INTO saved_queries', { uid => auth->uid, qtype => $d->{qtype}, name => $d->{name}, query => $q },
+ 'ON CONFLICT (uid, qtype, name) DO UPDATE SET query =', \$q
+ );
+ elm_Success
+};
+
+
+elm_api 'AdvSearchDel' => undef, {
+ name => { type => 'array', minlength => 1, values => { default => '', length => [1,50] } },
+ qtype => { enum => \%VNWeb::AdvSearch::FIELDS },
+}, sub {
+ my($d) = @_;
+ tuwf->dbExeci('DELETE FROM saved_queries WHERE uid =', \auth->uid, 'AND qtype =', \$d->{qtype}, 'AND name IN', $d->{name});
+ elm_Success
+};
+
+1;
diff --git a/lib/VNWeb/Misc/BBCode.pm b/lib/VNWeb/Misc/BBCode.pm
index 5d6f2e0b..ddc744b2 100644
--- a/lib/VNWeb/Misc/BBCode.pm
+++ b/lib/VNWeb/Misc/BBCode.pm
@@ -3,9 +3,15 @@ package VNWeb::Misc::BBCode;
use VNWeb::Prelude;
elm_api BBCode => undef, {
- content => { required => 0, default => '' }
+ content => { default => '' }
}, sub {
- elm_Content bb2html bb_subst_links shift->{content};
+ elm_Content bb_format bb_subst_links shift->{content};
+};
+
+js_api BBCode => {
+ content => { default => '' }
+}, sub {
+ +{ html => bb_format bb_subst_links shift->{content} };
};
1;
diff --git a/lib/VNWeb/Misc/ElmAnime.pm b/lib/VNWeb/Misc/ElmAnime.pm
new file mode 100644
index 00000000..7910e18e
--- /dev/null
+++ b/lib/VNWeb/Misc/ElmAnime.pm
@@ -0,0 +1,25 @@
+package VNWeb::Misc::ElmAnime;
+
+use VNWeb::Prelude;
+
+elm_api Anime => undef, { search => {}, ref => { anybool => 1 } }, sub {
+ my($d) = @_;
+ my $q = $d->{search};
+ my $qs = sql_like $q;
+
+ elm_AnimeResult tuwf->dbPagei({ results => 15, page => 1 },
+ 'SELECT a.id, a.title_romaji AS title, coalesce(a.title_kanji, \'\') AS original
+ FROM (',
+ sql_join('UNION ALL',
+ $q =~ /^a([0-9]+)$/ ? sql('SELECT 1, id FROM anime WHERE id =', \"$1") : (),
+ sql('SELECT 1+substr_score(lower(title_romaji),', \$qs, '), id FROM anime WHERE title_romaji ILIKE', \"%$qs%"),
+ sql('SELECT 10+substr_score(lower(title_kanji),', \$qs, '), id FROM anime WHERE title_kanji ILIKE', \"%$qs%"),
+ ), ') x(prio, id)
+ JOIN anime a ON a.id = x.id',
+ $d->{ref} ? 'WHERE EXISTS(SELECT 1 FROM vn_anime va WHERE va.aid = a.id)' : (), '
+ GROUP BY a.id, a.title_romaji, a.title_kanji
+ ORDER BY MIN(x.prio), a.title_romaji
+ ');
+};
+
+1;
diff --git a/lib/VNWeb/Misc/Feeds.pm b/lib/VNWeb/Misc/Feeds.pm
new file mode 100644
index 00000000..f24144d5
--- /dev/null
+++ b/lib/VNWeb/Misc/Feeds.pm
@@ -0,0 +1,80 @@
+package VNWeb::Misc::Feeds;
+
+use VNWeb::Prelude;
+use TUWF::XML ':xml';
+
+
+sub datetime { strftime '%Y-%m-%dT%H:%M:%SZ', gmtime shift }
+
+
+sub feed {
+ my($path, $title, $data) = @_;
+ my $base = tuwf->reqBaseURI();
+
+ tuwf->resHeader('Content-Type', 'application/atom+xml; charset=UTF-8');
+ xml;
+ tag feed => xmlns => 'http://www.w3.org/2005/Atom', 'xml:lang' => 'en', 'xml:base' => "$base/", sub {
+ tag title => $title;
+ tag updated => datetime max grep $_, map +($_->{published}, $_->{updated}), @$data;
+ tag id => $base.$path;
+ tag link => rel => 'self', type => 'application/atom+xml', href => $base.tuwf->reqPath(), undef;
+ tag link => rel => 'alternate', type => 'text/html', href => $base.$path, undef;
+
+ tag entry => sub {
+ tag id => "$base/$_->{id}";
+ tag title => $_->{title};
+ tag updated => datetime($_->{updated} || $_->{published});
+ tag published => datetime $_->{published} if $_->{published};
+ tag author => sub {
+ tag name => $_->{user_name};
+ tag uri => "$base/$_->{user_id}";
+ } if $_->{user_id};
+ tag link => rel => 'alternate', type => 'text/html', href => "$base/$_->{id}", undef;
+ tag summary => type => 'html', bb_format $_->{summary}, maxlength => 300 if $_->{summary};
+ } for @$data;
+ }
+}
+
+
+TUWF::get qr{/feeds/announcements.atom}, sub {
+ feed '/t/an', 'VNDB Site Announcements', tuwf->dbAlli('
+ SELECT t.id, t.title, tp.msg AS summary
+ , ', sql_totime('tp.date'), 'AS published,', sql_totime('tp.edited'), 'AS updated,', sql_user(), '
+ FROM threads t
+ JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1
+ JOIN threads_boards tb ON tb.tid = t.id AND tb.type = \'an\'
+ LEFT JOIN users u ON u.id = tp.uid
+ WHERE NOT t.hidden AND NOT t.private
+ ORDER BY tb.tid DESC
+ LIMIT 10'
+ );
+};
+
+
+TUWF::get qr{/feeds/changes.atom}, sub {
+ my($lst) = VNWeb::Misc::History::fetch(undef, {m=>1,h=>1,p=>1}, {results=>25});
+ for (@$lst) {
+ $_->{id} = "$_->{itemid}.$_->{rev}";
+ $_->{title} = $_->{title}[1];
+ $_->{summary} = $_->{comments};
+ $_->{updated} = $_->{added};
+ }
+ feed '/hist', 'VNDB Recent Changes', $lst;
+};
+
+
+TUWF::get qr{/feeds/posts.atom}, sub {
+ feed '/t', 'VNDB Recent Posts', tuwf->dbAlli('
+ SELECT t.id||\'.\'||tp.num AS id, t.title||\' (#\'||tp.num||\')\' AS title, tp.msg AS summary
+ , ', sql_totime('tp.date'), 'AS published,', sql_totime('tp.edited'), 'AS updated,', sql_user(), '
+ FROM threads_posts tp
+ JOIN threads t ON t.id = tp.tid
+ LEFT JOIN users u ON u.id = tp.uid
+ WHERE tp.hidden IS NULL AND NOT t.hidden AND NOT t.private
+ ORDER BY tp.date DESC
+ LIMIT ', \25
+ );
+};
+
+
+1;
diff --git a/lib/VNWeb/Misc/History.pm b/lib/VNWeb/Misc/History.pm
index 26ef5f48..9664363b 100644
--- a/lib/VNWeb/Misc/History.pm
+++ b/lib/VNWeb/Misc/History.pm
@@ -3,84 +3,82 @@ package VNWeb::Misc::History;
use VNWeb::Prelude;
+# Also used by Misc::HomePage and Misc::Feeds
sub fetch {
- my($type, $id, $filt, $opt) = @_;
+ my($id, $filt, $opt) = @_;
+ my $num = $opt->{results}||50;
my $where = sql_and
- !$type ? ()
- : $type eq 'u' ? sql 'c.requester =', \$id
- : sql_or(
- sql('c.type =', \$type, ' AND c.itemid =', \$id),
+ !$id ? ()
+ : $id =~ /^u/ ? sql 'c.requester =', \$id
+ : $id =~ /^v/ && $filt->{r} ? sql 'c.itemid =', \$id, 'OR c.id IN(SELECT chid FROM releases_vn_hist WHERE vid =', \$id, ')' # This may need an index on releases_vn_hist.vid
+ : sql('c.itemid =', \$id),
- # This may need an index on releases_vn_hist.vid
- $type eq 'v' && $filt->{r} ?
- sql 'c.id IN(SELECT chid FROM releases_vn_hist WHERE vid =', \$id, ')' : ()
- ),
-
- $filt->{t} && $filt->{t}->@* ? sql 'c.type IN', \$filt->{t} : (),
- $filt->{m} ? sql 'c.requester <> 1' : (),
+ $filt->{t} && $filt->{t}->@* ? sql_or map sql('c.itemid BETWEEN vndbid(', \"$_", ',1) AND vndbid_max(', \"$_", ')'), $filt->{t}->@* : (),
+ $filt->{m} ? sql 'c.requester IS DISTINCT FROM \'u1\'' : (),
$filt->{e} && $filt->{e} == 1 ? sql 'c.rev <> 1' : (),
$filt->{e} && $filt->{e} ==-1 ? sql 'c.rev = 1' : (),
- $filt->{h} ? sql $filt->{h} == 1 ? 'NOT' : '',
+ # -2 = awaiting mod, -1 = deleted, 0 = all, 1 = approved
+ $filt->{h} ? sql
'EXISTS(SELECT 1 FROM changes c_i
- WHERE c_i.type = c.type AND c_i.itemid = c.itemid AND c_i.ihid
- AND c_i.rev = (SELECT MAX(c_ii.rev) FROM changes c_ii WHERE c_ii.type = c.type AND c_ii.itemid = c.itemid))' : ();
-
- my($lst, $np) = tuwf->dbPagei({ page => $filt->{p}, results => $opt->{results}||50 }, q{
- SELECT c.id, c.type, c.itemid, c.comments, c.rev,}, sql_totime('c.added'), q{ AS added, }, sql_user(), q{
- FROM changes c
- JOIN users u ON c.requester = u.id
- WHERE}, $where, q{
- ORDER BY c.id DESC
- });
-
- # Fetching the titles in a separate query is faster, for some reason.
- enrich_merge id => sql(q{
- SELECT id, title, original FROM (
- SELECT chid, title, original FROM vn_hist
- UNION ALL SELECT chid, title, original FROM releases_hist
- UNION ALL SELECT chid, name, original FROM producers_hist
- UNION ALL SELECT chid, name, original FROM chars_hist
- UNION ALL SELECT chid, title, '' AS original FROM docs_hist
- UNION ALL SELECT sh.chid, name, original FROM staff_hist sh JOIN staff_alias_hist sah ON sah.chid = sh.chid AND sah.aid = sh.aid
- ) t(id, title, original)
- WHERE id IN}), $lst;
+ WHERE c_i.itemid = c.itemid AND',
+ $filt->{h} == -2 ? 'c_i.ihid AND NOT c_i.ilock' :
+ $filt->{h} == -1 ? 'c_i.ihid AND c_i.ilock' : 'NOT c_i.ihid', '
+ AND c_i.rev = (SELECT MAX(c_ii.rev) FROM changes c_ii WHERE c_ii.itemid = c.itemid))' : ();
+
+ my $lst = tuwf->dbAlli('
+ SELECT c.id, c.itemid, c.comments, c.rev,', sql_totime('c.added'), 'AS added,', sql_user(), ', x.title, u.perm_dbmod AS rev_dbmod
+ FROM (SELECT * FROM changes c WHERE', $where, ' ORDER BY c.id DESC LIMIT', \($num+1), 'OFFSET', \($num*($filt->{p}-1)), ') c
+ JOIN item_info(NULL, c.itemid, c.rev) x ON true
+ LEFT JOIN users u ON c.requester = u.id
+ ORDER BY c.id DESC'
+ );
+ enrich rev_patrolled => id => id =>
+ sql('SELECT c.id,', sql_user(), 'FROM changes_patrolled c JOIN users u ON u.id = c.uid WHERE c.id IN'), $lst
+ if auth->permDbmod;
+ my $np = @$lst > $num ? pop(@$lst)&&1 : 0;
($lst, $np)
}
-# Also used by User::Page.
-# %opt: nopage => 1/0, results => $num
+# Also used by User::Page and VNWeb::HTML.
+# %opt: nopage => 1/0, nouser => 1/0, results => $num
sub tablebox_ {
- my($type, $id, $filt, %opt) = @_;
+ my($id, $filt, %opt) = @_;
- my($lst, $np) = fetch $type, $id, $filt, \%opt;
+ my($lst, $np) = fetch $id, $filt, \%opt;
my sub url { '?'.query_encode %$filt, p => $_ }
paginate_ \&url, $filt->{p}, $np, 't' unless $opt{nopage};
- div_ class => 'mainbox browse history mainbox-overflow-hack', sub {
+ article_ class => 'browse history overflow-hack', sub {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
+ td_ class => 'tc1_0', '' if auth->permDbmod;
td_ class => 'tc1_1', 'Rev.';
td_ class => 'tc1_2', '';
td_ class => 'tc2', 'Date';
- td_ class => 'tc3', 'User';
+ td_ class => 'tc3', 'User' unless $opt{nouser};
td_ class => 'tc4', sub { txt_ 'Page'; debug_ $lst; };
}};
tr_ sub {
my $i = $_;
- my $revurl = "/$i->{type}$i->{itemid}.$i->{rev}";
-
- td_ class => 'tc1_1', sub { a_ href => $revurl, "$i->{type}$i->{itemid}" };
+ my $revurl = "/$i->{itemid}.$i->{rev}";
+
+ td_ class => 'tc1_0', sub {
+ a_ href => "$revurl?patrolled=$i->{id}", sub {
+ revision_patrolled_ $i;
+ }
+ } if auth->permDbmod;
+ td_ class => 'tc1_1', sub { a_ href => $revurl, $i->{itemid} };
td_ class => 'tc1_2', sub { a_ href => $revurl, ".$i->{rev}" };
td_ class => 'tc2', fmtdate $i->{added}, 'full';
- td_ class => 'tc3', sub { user_ $i };
+ td_ class => 'tc3', sub { user_ $i } unless $opt{nouser};
td_ class => 'tc4', sub {
- a_ href => $revurl, title => $i->{original}, shorten $i->{title}, 80;
- b_ class => 'grayedout', sub { lit_ bb2html $i->{comments}, 150 };
+ a_ href => $revurl, tattr $i;
+ small_ sub { lit_ bb_format $i->{comments}, maxlength => 150, inline => 1 };
};
} for @$lst;
};
@@ -94,18 +92,20 @@ sub filters_ {
my @types = (
[ v => 'Visual novels' ],
+ [ g => 'Tags' ],
[ r => 'Releases' ],
[ p => 'Producers' ],
[ s => 'Staff' ],
[ c => 'Characters' ],
- [ d => 'Docs' ]
+ [ i => 'Traits' ],
+ [ d => 'Docs' ],
);
state $schema = tuwf->compile({ type => 'hash', keys => {
# Types
t => { type => 'array', scalar => 1, onerror => [map $_->[0], @types], values => { enum => [(map $_->[0], @types), 'a'] } },
m => { onerror => undef, enum => [ 0, 1 ] }, # Automated edits
- h => { onerror => 0, enum => [ -1..1 ] }, # Hidden items
+ h => { onerror => 0, enum => [ -2..1 ] }, # Item status (the numbers dont make sense)
e => { onerror => 0, enum => [ -1..1 ] }, # Existing/new items
r => { onerror => 0, enum => [ 0, 1 ] }, # Include releases
p => { page => 1 },
@@ -131,16 +131,14 @@ sub filters_ {
};
form_ method => 'get', action => tuwf->reqPath(), sub {
- table_ style => 'margin: 0 auto', sub { tr_ sub {
- td_ style => 'padding: 10px', sub {
- p_ class => 'linkradio', sub {
- join_ \&br_, sub {
- opt_ checkbox => t => $_->[0], $_->[1], $t{$_->[0]}||0;
- }, @types;
+ table_ class => 'histoptions', sub { tr_ sub {
+ td_ sub {
+ select_ multiple => 1, size => scalar @types, name => 't', sub {
+ option_ $t{$_->[0]} ? (selected => 1) : (), value => $_->[0], $_->[1] for @types;
}
} if exists $filt->{t};
- td_ style => 'padding: 10px', sub {
+ td_ sub {
p_ class => 'linkradio', sub {
opt_ radio => e => 0, 'All'; em_ ' | ';
opt_ radio => e => 1, 'Only changes to existing items'; em_ ' | ';
@@ -148,8 +146,9 @@ sub filters_ {
} if exists $filt->{e};
p_ class => 'linkradio', sub {
opt_ radio => h => 0, 'All'; em_ ' | ';
- opt_ radio => h => 1, 'Only non-deleted items'; em_ ' | ';
- opt_ radio => h =>-1, 'Only deleted';
+ opt_ radio => h => 1, 'Only public items'; em_ ' | ';
+ opt_ radio => h =>-1, 'Only deleted'; em_ ' | ';
+ opt_ radio => h =>-2, 'Only unapproved';
} if exists $filt->{h};
p_ class => 'linkradio', sub {
opt_ checkbox => m => 0, 'Show automated edits' if !$type;
@@ -167,35 +166,22 @@ sub filters_ {
}
-TUWF::get qr{/(?:([upvrcsd])([1-9]\d*)/)?hist} => sub {
- my($type, $id) = (tuwf->capture(1)||'', tuwf->capture(2));
-
- my sub dbitem {
- my($table, $title) = @_;
- tuwf->dbRowi('SELECT id,', $title, ' AS title, hidden AS entry_hidden, locked AS entry_locked FROM', $table, 'WHERE id =', \$id);
- };
-
- my $obj = !$type ? undef :
- $type eq 'u' ? tuwf->dbRowi('SELECT id, ', sql_user(), 'FROM users u WHERE id =', \$id) :
- $type eq 'p' ? dbitem producers => 'name' :
- $type eq 'v' ? dbitem vn => 'title' :
- $type eq 'r' ? dbitem releases => 'title' :
- $type eq 'c' ? dbitem chars => 'name' :
- $type eq 's' ? dbitem staff => '(SELECT name FROM staff_alias WHERE aid = staff.aid)' :
- $type eq 'd' ? dbitem docs => 'title' : die;
+TUWF::get qr{/(?:([upvrcsdgi][1-9][0-9]{0,6})/)?hist} => sub {
+ my $id = tuwf->capture(1)||'';
+ my $obj = dbobj $id;
- return tuwf->resNotFound if $type && !$obj->{id};
- $obj->{title} = user_displayname $obj if $type eq 'u';
+ return tuwf->resNotFound if $id && !$obj->{id};
+ return tuwf->resNotFound if $id =~ /^u/ && $obj->{entry_hidden} && !auth->isMod;
- my $title = $type ? "Edit history of $obj->{title}" : 'Recent changes';
- framework_ title => $title, type => $type, dbobj => $obj, tab => 'hist',
+ my $title = $id ? "Edit history of $obj->{title}[1]" : 'Recent changes';
+ framework_ title => $title, dbobj => $obj, tab => 'hist',
sub {
my $filt;
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ $title;
- $filt = filters_ $type;
+ $filt = filters_($id =~ /^(.)/ ? $1 : '');
};
- tablebox_ $type, $id, $filt;
+ tablebox_ $id, $filt, nouser => scalar $id =~ /^u/;
};
};
diff --git a/lib/VNWeb/Misc/HomePage.pm b/lib/VNWeb/Misc/HomePage.pm
new file mode 100644
index 00000000..86254fcd
--- /dev/null
+++ b/lib/VNWeb/Misc/HomePage.pm
@@ -0,0 +1,286 @@
+package VNWeb::Misc::HomePage;
+
+use VNWeb::Prelude;
+use VNWeb::AdvSearch;
+use VNWeb::Discussions::Lib 'enrich_boards';
+
+
+sub screens {
+ state $where ||= sql 'i.c_weight > 0 and vndbid_type(i.id) =', \'sf', 'and i.c_sexual_avg <', \40, 'and i.c_violence_avg <', \40;
+ state $stats ||= tuwf->dbRowi('SELECT count(*) as total, count(*) filter(where', $where, ') as subset from images i');
+ state $sample ||= 100*min 1, (200 / (1+$stats->{subset})) * ($stats->{total} / (1+$stats->{subset}));
+
+ my $filt = advsearch_default 'v';
+ my $start = time;
+ my $lst = $filt->{query} ? tuwf->dbAlli(
+ # Assumption: If we randomly select 30 matching VNs, there'll be at least 4 VNs with qualified screenshots
+ # (As of Sep 2020, over half of the VNs in the database have screenshots, so that assumption usually works)
+ 'SELECT * FROM (
+ SELECT DISTINCT ON (v.id) i.id, i.width, i,height, v.id AS vid, v.title
+ FROM (SELECT id, title FROM', vnt, 'v WHERE NOT v.hidden AND ', $filt->sql_where(), ' ORDER BY random() LIMIT', \30, ') v
+ JOIN vn_screenshots vs ON v.id = vs.id
+ JOIN images i ON i.id = vs.scr
+ WHERE ', $where, '
+ ORDER BY v.id
+ ) x ORDER BY random() LIMIT', \4
+ ) : tuwf->dbAlli('
+ SELECT i.id, i.width, i.height, v.id AS vid, v.title
+ FROM (SELECT id, width, height FROM images i TABLESAMPLE SYSTEM (', \$sample, ') WHERE', $where, ' ORDER BY random() LIMIT', \4, ') i(id)
+ JOIN vn_screenshots vs ON vs.scr = i.id
+ JOIN', vnt, 'v ON v.id = vs.id
+ WHERE NOT v.hidden
+ ORDER BY random()
+ LIMIT', \4
+ );
+ ($lst, $filt->{query} && time - $start > 0.3)
+}
+
+
+sub recent_changes_ {
+ my($lst) = VNWeb::Misc::History::fetch(undef, {m=>1,h=>1,p=>1}, {results=>10});
+ h1_ sub {
+ a_ href => '/hist', 'Recent Changes'; txt_ ' ';
+ a_ href => '/feeds/changes.atom', sub {
+ abbr_ class => 'icon-rss', title => 'Atom feed', '';
+ }
+ };
+ ul_ sub {
+ li_ sub {
+ span_ sub {
+ txt_ "$1:" if $_->{itemid} =~ /^(.)/;
+ a_ href => "/$_->{itemid}.$_->{rev}", tattr $_;
+ };
+ span_ sub {
+ lit_ " by ";
+ user_ $_;
+ }
+ } for @$lst;
+ };
+}
+
+
+sub recent_db_posts_ {
+ my $an = tuwf->dbAlli('
+ SELECT t.id, t.title,', sql_totime('tp.date'), 'AS date
+ FROM threads t
+ JOIN threads_boards tb ON tb.tid = t.id AND tb.type = \'an\'
+ JOIN threads_posts tp ON tp.tid = t.id AND tp.num = 1
+ WHERE NOT t.hidden AND NOT t.private AND tp.date >', sql_fromtime(time-30*24*3600), '
+ ORDER BY tb.tid DESC
+ LIMIT 1+1'
+ );
+ my $lst = tuwf->dbAlli('
+ SELECT t.id, t.title, tp.num,', sql_totime('tp.date'), 'AS date, ', sql_user(), '
+ FROM threads t
+ JOIN threads_posts tp ON tp.tid = t.id AND tp.num = t.c_lastnum
+ LEFT JOIN users u ON tp.uid = u.id
+ WHERE EXISTS(SELECT 1 FROM threads_boards tb WHERE tb.tid = t.id AND tb.type IN(\'db\',\'an\'))
+ AND NOT t.hidden AND NOT t.private
+ ORDER BY tp.date DESC
+ LIMIT', \(10-@$an)
+ );
+ enrich_boards undef, $lst;
+ p_ class => 'mainopts', sub {
+ a_ href => '/t/an', 'Announcements';
+ small_ '&';
+ a_ href => '/t/db', 'VNDB';
+ };
+ h1_ sub {
+ txt_ 'DB Discussions';
+ };
+ ul_ sub {
+ li_ class => 'announcement', sub {
+ a_ href => "/$_->{id}", $_->{title};
+ } for @$an;
+ li_ sub {
+ my $boards = join ', ', map $BOARD_TYPE{$_->{btype}}{txt}.($_->{iid}?' > '.$_->{title}[1]:''), $_->{boards}->@*;
+ span_ sub {
+ txt_ fmtage($_->{date}).' ';
+ a_ href => "/$_->{id}.$_->{num}#last", title => "Posted in $boards", $_->{title};
+ };
+ span_ sub {
+ lit_ ' by ';
+ user_ $_;
+ }
+ } for @$lst;
+ };
+}
+
+
+sub recent_vn_posts_ {
+ my $lst = tuwf->dbAlli('
+ WITH tposts (id,title,num,date,uid) AS (
+ SELECT t.id, ARRAY[NULL, t.title], tp.num, tp.date, tp.uid
+ FROM threads t
+ JOIN threads_posts tp ON tp.tid = t.id AND tp.num = t.c_lastnum
+ WHERE NOT EXISTS(SELECT 1 FROM threads_boards tb WHERE tb.tid = t.id AND tb.type IN(\'an\',\'db\',\'u\'))
+ AND NOT t.hidden AND NOT t.private
+ ORDER BY tp.date DESC LIMIT 10
+ ), wposts (id,title,num,date,uid) AS (
+ SELECT w.id, v.title, wp.num, wp.date, wp.uid
+ FROM reviews w
+ JOIN reviews_posts wp ON wp.id = w.id AND wp.num = w.c_lastnum
+ JOIN', vnt, 'v ON v.id = w.vid
+ LEFT JOIN users u ON wp.uid = u.id
+ WHERE NOT w.c_flagged AND wp.hidden IS NULL
+ ORDER BY wp.date DESC LIMIT 10
+ ) SELECT x.id, x.num, x.title,', sql_totime('x.date'), 'AS date, ', sql_user(), '
+ FROM (SELECT * FROM tposts UNION ALL SELECT * FROM wposts) x
+ LEFT JOIN users u ON u.id = x.uid
+ ORDER BY date DESC
+ LIMIT 10'
+ );
+ enrich_boards undef, $lst;
+ p_ class => 'mainopts', sub {
+ a_ href => '/t/all', 'Forums';
+ small_ '&';
+ a_ href => '/w?o=d&s=lastpost', 'Reviews';
+ };
+ h1_ sub {
+ a_ href => '/t/all', 'VN Discussions';
+ };
+ ul_ sub {
+ li_ sub {
+ span_ sub {
+ my $boards = join ', ', map $BOARD_TYPE{$_->{btype}}{txt}.($_->{iid}?' > '.$_->{title}[1]:''), $_->{boards}->@*;
+ txt_ fmtage($_->{date}).' ';
+ a_ href => "/$_->{id}.$_->{num}#last", title => $boards ? "Posted in $boards" : 'Review', tlang(@{$_->{title}}[0,1]), $_->{title}[1];
+ };
+ span_ sub {
+ lit_ ' by ';
+ user_ $_;
+ }
+ } for @$lst;
+ };
+}
+
+
+
+sub releases {
+ my($released) = @_;
+
+ my $filt = advsearch_default 'r';
+
+ # Drop any top-level date filters
+ $filt->{query} = [ grep !(ref $_ eq 'ARRAY' && $_->[0] eq 'released'), $filt->{query}->@* ] if $filt->{query};
+ delete $filt->{query} if $filt->{query} && ($filt->{query}[0] eq 'released' || $filt->{query}->@* < 2);
+ my $has_saved = !!$filt->{query};
+
+ # Add the release date as filter, we need to construct a filter for the header link anyway
+ $filt->{query} = [ 'and', [ released => $released ? '<=' : '>', 1 ], $filt->{query} || () ];
+
+ my $start = time;
+ my $lst = tuwf->dbAlli('
+ SELECT id, title, released
+ FROM', releasest, 'r
+ WHERE NOT hidden AND ', $filt->sql_where(), '
+ AND NOT EXISTS(SELECT 1 FROM releases_titles rt WHERE rt.id = r.id AND rt.mtl)
+ ORDER BY released', $released ? 'DESC' : '', ', id LIMIT 10'
+ );
+ my $end = time;
+ enrich_flatten plat => id => id => 'SELECT id, platform FROM releases_platforms WHERE id IN', $lst;
+ enrich_flatten lang => id => id => 'SELECT id, lang FROM releases_titles WHERE id IN', $lst;
+ ($lst, $filt, $has_saved && $end-$start > 0.3)
+}
+
+
+sub releases_ {
+ my($lst, $filt, $released) = @_;
+
+ h1_ sub {
+ a_ href => '/r?f='.$filt->query_encode().';o=a;s=released', 'Upcoming Releases' if !$released;
+ a_ href => '/r?f='.$filt->query_encode().';o=d;s=released', 'Just Released' if $released;
+ };
+ ul_ sub {
+ li_ sub {
+ span_ sub {
+ rdate_ $_->{released};
+ txt_ ' ';
+ platform_ $_ for $_->{plat}->@*;
+ abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for $_->{lang}->@*;
+ txt_ ' ';
+ a_ href => "/$_->{id}", tattr $_;
+ }
+ } for @$lst;
+ };
+}
+
+
+sub reviews_ {
+ my $lst = tuwf->dbAlli('
+ SELECT w.id, v.title, w.isfull, ', sql_user(), ',', sql_totime('w.date'), 'AS date
+ FROM reviews w
+ JOIN', vnt, 'v ON v.id = w.vid
+ LEFT JOIN users u ON u.id = w.uid
+ WHERE NOT w.c_flagged
+ ORDER BY w.id DESC LIMIT 10'
+ );
+ h1_ sub {
+ a_ href => '/w', 'Latest Reviews';
+ };
+ ul_ sub {
+ li_ sub {
+ span_ sub {
+ txt_ fmtage($_->{date}).' ';
+ small_ $_->{isfull} ? ' Full ' : ' Mini ';
+ a_ href => "/$_->{id}", tattr $_;
+ };
+ span_ sub {
+ lit_ 'by ';
+ user_ $_;
+ }
+ } for @$lst;
+ }
+}
+
+
+TUWF::get qr{/}, sub {
+ my %meta = (
+ 'type' => 'website',
+ 'title' => 'The Visual Novel Database',
+ 'description' => 'VNDB.org strives to be a comprehensive database for information about visual novels.',
+ );
+
+ my($screens, $slowscreens) = screens;
+ my($rel0, $filt0, $slowrel0) = releases 0;
+ my($rel1, $filt1, $slowrel1) = releases 1;
+ my $slowrel = $slowrel0 || $slowrel1;
+
+ framework_ title => $meta{title}, feeds => 1, og => \%meta, index => 1, sub {
+ article_ sub {
+ h1_ $meta{title};
+ p_ class => 'description', sub {
+ txt_ $meta{description};
+ br_;
+ txt_ q{
+ This website is built as a wiki, meaning that anyone can freely add
+ and contribute information to the database, allowing us to create the
+ largest, most accurate and most up-to-date visual novel database on the web.
+ };
+ };
+ p_ class => 'screenshots', sub {
+ a_ href => "/$_->{vid}", title => $_->{title}[1], sub {
+ my($w, $h) = imgsize $_->{width}, $_->{height}, config->{scr_size}->@*;
+ img_ src => imgurl($_->{id}, 't'), alt => $_->{title}[1], width => $w, height => $h;
+ } for @$screens;
+ };
+ p_ class => 'center standout', sub {
+ txt_ 'If VNDB appears to load a little slow for you, try clearing or adjusting your ';
+ a_ href => '/v', 'saved visual novel filters' if $slowscreens;
+ txt_ ' or ' if $slowscreens && $slowrel;
+ a_ href => '/r', 'saved release filters' if $slowrel;
+ txt_ '.';
+ } if $slowscreens || $slowrel;
+ };
+ div_ class => 'homepage', sub {
+ article_ \&recent_changes_;
+ article_ \&recent_db_posts_;
+ article_ \&recent_vn_posts_;
+ article_ sub { reviews_ };
+ article_ sub { releases_ $rel0, $filt0, 0 };
+ article_ sub { releases_ $rel1, $filt1, 1 };
+ };
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Misc/Lockdown.pm b/lib/VNWeb/Misc/Lockdown.pm
new file mode 100644
index 00000000..ad0d4bb2
--- /dev/null
+++ b/lib/VNWeb/Misc/Lockdown.pm
@@ -0,0 +1,54 @@
+package VNWeb::Misc::Lockdown;
+
+use VNWeb::Prelude;
+
+TUWF::get '/lockdown', sub {
+ return tuwf->resDenied if !auth->isMod;
+
+ sub chk_ {
+ my($name, $lbl) = @_;
+ label_ sub {
+ input_ type => 'checkbox', name => $name, global_settings->{$name} ? (checked => 'checked') : ();
+ txt_ $lbl;
+ };
+ br_;
+ }
+
+ framework_ title => 'Database lockdown', sub {
+ article_ sub {
+ h1_ 'Database lockdown';
+
+ p_ sub {
+ txt_ 'This form provides a sledghehammer approach to dealing with
+ targeted vandalism or spam attacks on the site. The goal of
+ these options is to put the website in a temporary lockdown
+ while waiting for Yorhel to wake up or while a better solution
+ is being worked on.';
+ br_;
+ txt_ 'Moderators can keep using the site as usual regardless of these settings.';
+ };
+
+ form_ action => '/lockdown', method => 'post', style => 'margin: 20px', sub {
+ chk_ lockdown_registration => ' Disable account creation.';
+ chk_ lockdown_edit => ' Disable database editing globally. Also disables image and tag voting.';
+ chk_ lockdown_board => ' Disable forum and review posting globally.';
+ input_ type => 'submit', name => 'submit', class => 'submit', value => 'Submit';
+ };
+ };
+ };
+};
+
+
+TUWF::post '/lockdown', sub {
+ return auth->resDenied if !auth->isMod || !samesite;
+ my $frm = tuwf->validate(post =>
+ lockdown_registration => { anybool => 1 },
+ lockdown_edit => { anybool => 1 },
+ lockdown_board => { anybool => 1 },
+ )->data;
+ tuwf->dbExeci('UPDATE global_settings SET', $frm);
+ auth->audit(0, 'lockdown', JSON::XS->new->encode($frm));
+ tuwf->resRedirect('/lockdown', 'post');
+};
+
+1;
diff --git a/lib/VNWeb/Misc/OpenSearch.pm b/lib/VNWeb/Misc/OpenSearch.pm
new file mode 100644
index 00000000..1f74496b
--- /dev/null
+++ b/lib/VNWeb/Misc/OpenSearch.pm
@@ -0,0 +1,22 @@
+package VNWeb::Misc::OpenSearch;
+
+use VNWeb::Prelude;
+use TUWF::XML 'xml', 'tag';
+
+TUWF::get qr{/opensearch\.xml}, sub {
+ my $h = tuwf->reqBaseURI;
+ tuwf->resHeader('Content-Type' => 'application/opensearchdescription+xml');
+ xml;
+ tag 'OpenSearchDescription', xmlns => 'http://a9.com/-/spec/opensearch/1.1/', 'xmlns:moz' => 'http://www.mozilla.org/2006/browser/search/', sub {
+ tag 'ShortName', 'VNDB';
+ tag 'LongName', 'VNDB.org Visual Vovel Search';
+ tag 'Description', 'Search visual novels on VNDB.org';
+ tag 'Image', width => 16, height => 16, type => 'image/x-icon', "$h/favicon.ico";
+ tag 'Url', type => 'text/html', method => 'get', template => "$h/v?q={searchTerms}", undef;
+ tag 'Url', type => 'application/opensearchdescription+xml', rel => 'self', template => "$h/opensearch.xml", undef;
+ tag 'Query', role => 'example', searchTerms => 'Tsukihime', undef;
+ tag 'moz:SearchForm', "$h/v";
+ }
+};
+
+1;
diff --git a/lib/VNWeb/Misc/Redirects.pm b/lib/VNWeb/Misc/Redirects.pm
new file mode 100644
index 00000000..e16cf495
--- /dev/null
+++ b/lib/VNWeb/Misc/Redirects.pm
@@ -0,0 +1,46 @@
+package VNWeb::Misc::Redirects;
+
+use VNWeb::Prelude;
+use VNWeb::AdvSearch;
+
+
+# VNDB URLs don't have a trailing /, redirect if we get one.
+TUWF::get qr{(/.+?)/+}, sub { tuwf->resRedirect(tuwf->capture(1).tuwf->reqQuery(), 'perm') };
+
+# These two are ancient.
+TUWF::get qr{/notes}, sub { tuwf->resRedirect('/d8', 'perm') };
+TUWF::get qr{/faq}, sub { tuwf->resRedirect('/d6', 'perm') };
+
+TUWF::get qr{/v/search}, sub { tuwf->resRedirect('/v'.tuwf->reqQuery(), 'perm') };
+
+TUWF::get qr{/experimental/v}, sub { tuwf->resRedirect('/v'.tuwf->reqQuery(), 'perm') };
+TUWF::get qr{/experimental/r}, sub { tuwf->resRedirect('/r'.tuwf->reqQuery(), 'perm') };
+
+TUWF::get qr{/u/list(/[a-z0]|/all)?}, sub { tuwf->resRedirect('/u'.(tuwf->capture(1)//'/all'), 'perm') };
+
+TUWF::get qr{/$RE{uid}/tags}, sub { tuwf->resRedirect('/g/links?u='.tuwf->capture('id'), 'perm') };
+
+TUWF::get qr{/$RE{vid}/staff}, sub { tuwf->resRedirect(sprintf '/%s#staff', tuwf->capture('id')) };
+TUWF::get qr{/$RE{vid}/stats}, sub { tuwf->resRedirect(sprintf '/%s#stats', tuwf->capture('id')) };
+TUWF::get qr{/$RE{vid}/scr}, sub { tuwf->resRedirect(sprintf '/%s#screenshots', tuwf->capture('id')) };
+TUWF::get qr{/img/$RE{imgid}}, sub { tuwf->resRedirect('/'.tuwf->capture(1).tuwf->reqQuery(), 'perm') };
+
+TUWF::get qr{/u/tokens}, sub { tuwf->resRedirect(auth ? '/'.auth->uid.'/edit#api' : '/u/login?ref=/u/tokens', 'temp') };
+
+
+TUWF::get qr{/v/rand}, sub {
+ state $stats ||= tuwf->dbRowi('SELECT COUNT(*) AS total, COUNT(*) FILTER(WHERE NOT hidden) AS subset FROM vn');
+ state $sample ||= 100*min 1, (1000 / $stats->{subset}) * ($stats->{total} / $stats->{subset});
+
+ my $filt = advsearch_default 'v';
+ my $vn = tuwf->dbVali('
+ SELECT id
+ FROM vn v', $filt->{query} ? '' : ('TABLESAMPLE SYSTEM (', \$sample, ')'), '
+ WHERE NOT hidden AND', $filt->sql_where(), '
+ ORDER BY random() LIMIT 1'
+ );
+ return tuwf->resNotFound if !$vn;
+ tuwf->resRedirect("/$vn", 'temp');
+};
+
+1;
diff --git a/lib/VNWeb/Misc/Reports.pm b/lib/VNWeb/Misc/Reports.pm
new file mode 100644
index 00000000..5c5dcac6
--- /dev/null
+++ b/lib/VNWeb/Misc/Reports.pm
@@ -0,0 +1,271 @@
+package VNWeb::Misc::Reports;
+
+use VNWeb::Prelude;
+
+my $reportsperday = 5;
+
+my @STATUS = qw/new busy done dismissed/;
+my $STATUSRE = '(?:'.join('|', @STATUS).')';
+
+
+# Returns the object associated with the vndbid.num; Returns false if the object can't be reported.
+sub obj {
+ my($id, $num) = @_;
+ my $o = tuwf->dbRowi('SELECT x.*, ', sql_user(), 'FROM', item_info(\$id, \$num), 'x LEFT JOIN users u ON u.id = x.uid');
+ $o->{object} = $id;
+ $o->{objectnum} = $num;
+ $o->{title} //= [undef,$o->{object},undef,$o->{object}];
+ my $can = !defined $o->{title} ? 0
+ : $id =~ /^[vrpcsdu]/ ? !$num
+ : $id =~ /^w/ ? 1
+ : $id =~ /^t/ ? $num && !$o->{hidden} : 0;
+ $can && $o
+}
+
+
+sub obj_ {
+ my($o) = @_;
+ my $lnk = $o->{object} . ($o->{objectnum} ? ".$o->{objectnum}" : '');
+ if($o->{object} =~ /^(?:$RE{wid}|$RE{tid})$/ && $o->{objectnum}) {
+ txt_ 'Comment ';
+ a_ href => "/$lnk", "#$o->{objectnum}";
+ txt_ ' on ';
+ a_ href => "/$lnk", $o->{title} ? tattr $o : '<deleted>';
+ txt_ ' by ';
+ user_ $o;
+
+ } else {
+ txt_ {qw/v VN r Release p Producer c Character s Staff d Doc w Review t Thread u User/}->{substr $o->{object}, 0, 1};
+ txt_ ': ';
+ a_ href => "/$lnk", tattr $o;
+ if($o->{user_name}) {
+ txt_ ' by ';
+ user_ $o;
+ }
+ }
+}
+
+
+sub is_throttled {
+ tuwf->dbVali('SELECT COUNT(*) FROM reports WHERE date > NOW()-\'1 day\'::interval AND', auth ? ('uid =', \auth->uid) : ('(ip).ip =', \tuwf->reqIP)) >= $reportsperday
+}
+
+
+my $FORM = form_compile any => {
+ object => {},
+ objectnum=> { default => undef, uint => 1 },
+ title => {},
+ reason => { maxlength => 50 },
+ message => { default => '', maxlength => 50000 },
+ loggedin => { anybool => 1 },
+};
+
+js_api Report => $FORM, sub {
+ return tuwf->resDenied if is_throttled;
+ my($data) = @_;
+ my $obj = obj $data->{object}, $data->{objectnum};
+ return 'Invalid object' if !$data;
+
+ tuwf->dbExeci('INSERT INTO reports', {
+ uid => auth->uid,
+ ip => auth ? undef : ipinfo(),
+ object => $data->{object},
+ objectnum=> $data->{objectnum},
+ reason => $data->{reason},
+ message => $data->{message},
+ });
+ +{}
+};
+
+
+TUWF::get qr{/report/(?<object>[vrpcsdtwu]$RE{num})(?:\.(?<subid>$RE{num}))?}, sub {
+ my $obj = obj tuwf->captures('object', 'subid');
+ return tuwf->resNotFound if !$obj || config->{read_only};
+
+ framework_ title => 'Submit report', sub {
+ if(is_throttled) {
+ article_ sub {
+ h1_ 'Submit report';
+ p_ "Sorry, you can only submit $reportsperday reports per day. If you wish to report more, you can do so by sending an email to ".config->{admin_email}
+ }
+ } else {
+ div_ widget(Report => $FORM, { elm_empty($FORM)->%*, %$obj, loggedin => !!auth, title => xml_string sub { obj_ $obj } }), '';
+ }
+ };
+};
+
+
+sub report_ {
+ my($r, $url) = @_;
+ my $objid = $r->{object}.(defined $r->{objectnum} ? ".$r->{objectnum}" : '');
+ td_ style => 'padding: 3px 5px 5px 20px', sub {
+ a_ href => "?id=$r->{id}", "#$r->{id}";
+ small_ ' '.fmtdate $r->{date}, 'full';
+ txt_ ' by ';
+ if($r->{uid}) {
+ a_ href => "/$r->{uid}", $r->{username};
+ txt_ ' (';
+ a_ href => "/t/$r->{uid}/new?title=Regarding your report on $objid&priv=1", 'pm';
+ txt_ ')';
+ } else {
+ txt_ $r->{ip}||'[anonymous]';
+ }
+ br_;
+ obj_ $r;
+ br_;
+ if($r->{message} && $r->{reason} =~ /spoilers/i) {
+ details_ sub {
+ summary_ $r->{reason};
+ div_ class => 'quote', sub { lit_ bb_format $r->{message} };
+ };
+ } else {
+ txt_ $r->{reason};
+ div_ class => 'quote', sub { lit_ bb_format $r->{message} } if $r->{message};
+ }
+ };
+ td_ style => 'width: 300px', sub {
+ form_ method => 'post', action => '/report/edit', sub {
+ input_ type => 'hidden', name => 'id', value => $r->{id};
+ input_ type => 'hidden', name => 'url', value => $url;
+ textarea_ name => 'comment', rows => 2, cols => 25, style => 'width: 290px', placeholder => 'Mod comment... (optional)', '';
+ br_;
+ input_ type => 'submit', class => 'submit', value => 'Post';
+ txt_ ' & ';
+ input_ type => 'submit', class => 'submit', name => 'status', value => $_, $_ eq $r->{status} ? (style => 'font-weight: bold') : () for @STATUS;
+ };
+ };
+ td_ sub {
+ lit_ bb_format $r->{log};
+ my $status = $r->{log} =~ /$STATUSRE -> ($STATUSRE).*$/ ? $1 : 'new';
+ for ($r->{elog}->@*) {
+ txt_ fmtdate $_->{date}, 'full';
+ small_ ' <';
+ user_ $_;
+ small_ '> ';
+ em_ "$status -> $_->{status}. " if $status ne $_->{status};
+ $status = $_->{status};
+ lit_ bb_format $_->{message};
+ br_;
+ }
+ };
+}
+
+
+TUWF::get qr{/report/list}, sub {
+ return tuwf->resDenied if !auth->isMod;
+
+ my $opt = tuwf->validate(get =>
+ p => { upage => 1 },
+ s => { enum => ['id','lastmod'], default => 'id' },
+ status => { enum => \@STATUS, default => undef },
+ id => { id => 1, default => undef },
+ )->data;
+
+ my $where = sql_and
+ $opt->{id} ? sql 'r.id =', \$opt->{id} : (),
+ $opt->{status} ? sql 'r.status =', \$opt->{status} : (),
+ $opt->{s} eq 'lastmod' ? 'r.lastmod IS NOT NULL' : ();
+
+ my $cnt = tuwf->dbVali('SELECT count(*) FROM reports r WHERE', $where);
+ my $lst = tuwf->dbPagei({results => 25, page => $opt->{p}},
+ 'SELECT r.id,', sql_totime('r.date'), 'as date, r.uid, ur.username, fmtip(r.ip) as ip, r.reason, r.status, r.message, r.log
+ , r.object, r.objectnum, x.title, x.uid as by_uid,', sql_user('uo'), '
+ FROM reports r
+ LEFT JOIN', item_info('r.object', 'r.objectnum'), 'x ON true
+ LEFT JOIN users ur ON ur.id = r.uid
+ LEFT JOIN users uo ON uo.id = x.uid
+ WHERE', $where, '
+ ORDER BY', {id => 'r.id DESC', lastmod => 'r.lastmod DESC'}->{$opt->{s}}
+ );
+ enrich elog => id => id => sub { sql '
+ SELECT l.id, l.status, l.message, ', sql_totime('l.date'), 'date,', sql_user(), '
+ FROM reports_log l
+ LEFT JOIN users u ON u.id = l.uid
+ WHERE l.id IN', $_[0], '
+ ORDER BY l.date'
+ }, $lst;
+
+ tuwf->dbExeci(
+ 'UPDATE users_prefs SET last_reports = NOW()
+ WHERE (last_reports IS NULL OR EXISTS(SELECT 1 FROM reports WHERE lastmod > last_reports OR date > last_reports))
+ AND id =', \auth->uid
+ );
+
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ framework_ title => 'Reports', sub {
+ article_ sub {
+ h1_ 'Reports';
+ p_ 'Welcome to the super advanced reports handling interface. Reports can have the following statuses:';
+ ul_ sub {
+ li_ 'New: Default status for newly submitted reports';
+ li_ 'Busy: You can use this state to indicate that you\'re working on it.';
+ li_ 'Done: Report handled.';
+ li_ 'Dismissed: Report ignored.';
+ };
+ p_ q{
+ There's no flowchart you have to follow, if you can quickly handle a report you can go directly from 'New' to 'Done' or 'Dismissed'.
+ If you want to bring an older report to other's attention you can go back from any existing state to 'New'.
+ };
+ p_ q{
+ Feel free to skip over reports that you can't or don't want to handle, someone else will eventually pick it up.
+ };
+ p_ q{
+ Changing the status and/or adding a comment will add an entry to the log, so other mods can see what is going on. Everything on this page is only visible to moderators.
+ };
+ p_ q{
+ BUG: Deleting the last post from a thread (not "hiding", but actually deleting it) will cause the report
+ to refer to an innocent post when someone adds a new post to that thread, as the reply will get the same number as the deleted post.
+ Not a huge problem, but something to be aware of when browsing through handled reports.
+ };
+ br_;
+ br_;
+ p_ class => 'browseopts', sub {
+ a_ href => url(p => undef, status => undef), !$opt->{status} ? (class => 'optselected') : (), 'All';
+ a_ href => url(p => undef, status => $_), $opt->{status} && $opt->{status} eq $_ ? (class => 'optselected') : (), ucfirst $_ for @STATUS;
+ };
+ p_ class => 'browseopts', sub {
+ txt_ 'Sort by ';
+ a_ href => url(p => undef, s => 'id'), $opt->{s} eq 'id' ? (class => 'optselected') : (), 'newest';
+ a_ href => url(p => undef, s => 'lastmod'), $opt->{s} eq 'lastmod' ? (class => 'optselected') : (), 'last updated';
+ };
+ };
+
+ paginate_ \&url, $opt->{p}, [$cnt, 25], 't';
+ article_ class => 'thread', sub {
+ table_ class => 'stripe', sub {
+ my $url = '/report/list'.url;
+ tr_ sub { report_ $_, $url } for @$lst;
+ tr_ sub { td_ style => 'text-align: center', 'Nothing to report! (heh)' } if !@$lst;
+ };
+ };
+ paginate_ \&url, $opt->{p}, [$cnt, 25], 'b';
+ };
+};
+
+
+TUWF::post qr{/report/edit}, sub {
+ return tuwf->resDenied if !auth->isMod;
+ my $frm = tuwf->validate(post =>
+ id => { id => 1 },
+ url => { regex => qr{^/report/list} },
+ status => { enum => \@STATUS, default => undef },
+ comment => { default => '' },
+ )->data;
+ my $r = tuwf->dbRowi('SELECT id, status FROM reports WHERE id =', \$frm->{id});
+ return tuwf->resNotFound if !$r->{id};
+
+ if(($frm->{status} && $r->{status} ne $frm->{status}) || length $frm->{comment}) {
+ tuwf->dbExeci('UPDATE reports SET', {
+ lastmod => sql('NOW()'),
+ $frm->{status} ? (status => $frm->{status}) : (),
+ }, 'WHERE id =', \$r->{id});
+ tuwf->dbExeci('INSERT INTO reports_log', {
+ id => $r->{id}, uid => auth->uid,
+ status => $frm->{status}//$r->{status}, message => $frm->{comment}
+ });
+ }
+ tuwf->resRedirect($frm->{url}, 'post');
+};
+
+1;
diff --git a/lib/VNWeb/Prelude.pm b/lib/VNWeb/Prelude.pm
index 0a596bf6..f422aa50 100644
--- a/lib/VNWeb/Prelude.pm
+++ b/lib/VNWeb/Prelude.pm
@@ -4,25 +4,27 @@
# use warnings;
# use utf8;
#
-# use TUWF ':html5_', 'mkclass', 'xml_string';
+# use TUWF ':html5_', 'mkclass', 'xml_string', 'xml_escape';
# use Exporter 'import';
# use Time::HiRes 'time';
# use List::Util 'min', 'max', 'sum';
-# use POSIX 'ceil', 'floor';
+# use POSIX 'ceil', 'floor', 'strftime';
#
-# use VNDBUtil;
# use VNDB::BBCode;
# use VNDB::Types;
# use VNDB::Config;
-# use VNDB::Func qw/fmtdate fmtage fmtvote fmtspoil fmtmedia minage query_encode lang_attr md2html/;
+# use VNDB::Func;
# use VNDB::ExtLinks;
# use VNWeb::Auth;
# use VNWeb::HTML;
# use VNWeb::DB;
# use VNWeb::Validation;
+# use VNWeb::JS;
# use VNWeb::Elm;
+# use VNWeb::TableOpts;
+# use VNWeb::TitlePrefs;
#
-# + A few other handy tools.
+# + A handy dbobj() function.
#
# WARNING: This should not be used from the above modules.
package VNWeb::Prelude;
@@ -33,8 +35,8 @@ use feature ':5.26';
use utf8;
use VNWeb::Elm;
use VNWeb::Auth;
+use VNWeb::DB;
use TUWF;
-use JSON::XS;
sub import {
@@ -48,68 +50,46 @@ sub import {
die $@ if !eval <<" EOM;";
package $c;
- use TUWF ':html5_', 'mkclass', 'xml_string';
+ use TUWF ':html5_', 'mkclass', 'xml_string', 'xml_escape';
use Exporter 'import';
use Time::HiRes 'time';
use List::Util 'min', 'max', 'sum';
- use POSIX 'ceil', 'floor';
+ use POSIX 'ceil', 'floor', 'strftime';
- use VNDBUtil;
use VNDB::BBCode;
use VNDB::Types;
use VNDB::Config;
- use VNDB::Func qw/fmtdate fmtage fmtvote fmtspoil fmtmedia minage query_encode lang_attr md2html/;
+ use VNDB::Func;
use VNDB::ExtLinks;
use VNWeb::Auth;
use VNWeb::HTML;
use VNWeb::DB;
use VNWeb::Validation;
+ use VNWeb::JS;
use VNWeb::Elm;
+ use VNWeb::TableOpts;
+ use VNWeb::TitlePrefs;
1;
EOM;
no strict 'refs';
- *{$c.'::RE'} = *RE;
- *{$c.'::in'} = \&in;
+ *{$c.'::dbobj'} = \&dbobj;
}
-# Regular expressions for use in path registration
-my $num = qr{[1-9][0-9]{0,8}};
-my $id = qr{(?<id>$num)};
-my $rev = qr{(?:\.(?<rev>$num))};
-our %RE = (
- num => qr{(?<num>$num)},
- uid => qr{u$id},
- vid => qr{v$id},
- rid => qr{r$id},
- sid => qr{s$id},
- cid => qr{c$id},
- pid => qr{p$id},
- iid => qr{i$id},
- did => qr{d$id},
- tid => qr{t$id},
- gid => qr{g$id},
- vrev => qr{v$id$rev?},
- rrev => qr{r$id$rev?},
- prev => qr{p$id$rev?},
- srev => qr{s$id$rev?},
- crev => qr{c$id$rev?},
- drev => qr{d$id$rev?},
- postid => qr{t$id\.(?<num>$num)},
-);
+# Returns very generic information on a DB entry object.
+# Suitable for passing to HTML::framework_'s dbobj argument.
+sub dbobj {
+ my($id) = @_;
+ return undef if !$id;
+ if($id =~ /^u/) {
+ my $o = tuwf->dbRowi('SELECT id, username IS NULL AS entry_hidden,', sql_user(), 'FROM users u WHERE id =', \$id);
+ $o->{title} = [(undef, VNWeb::HTML::user_displayname $o)x2];
+ return $o;
+ }
-# Simple "is this element in the array?" function, using 'eq' to test equality.
-# Supports both an @array and \@array.
-# Usage:
-#
-# my $contains_hi = in 'hi', qw/ a b hi c /; # true
-#
-sub in {
- my($q, @a) = @_;
- $_ eq $q && return 1 for map ref $_ eq 'ARRAY' ? @$_ : ($_), @a;
- 0
+ tuwf->dbRowi('SELECT', \$id, 'AS id, title, hidden AS entry_hidden, locked AS entry_locked FROM', VNWeb::TitlePrefs::item_info(\$id, 'NULL'), ' x');
}
1;
diff --git a/lib/VNWeb/Producers/Edit.pm b/lib/VNWeb/Producers/Edit.pm
new file mode 100644
index 00000000..56df8aa3
--- /dev/null
+++ b/lib/VNWeb/Producers/Edit.pm
@@ -0,0 +1,114 @@
+package VNWeb::Producers::Edit;
+
+use VNWeb::Prelude;
+
+
+my $FORM = {
+ id => { default => undef, vndbid => 'p' },
+ type => { default => 'co', enum => \%PRODUCER_TYPE },
+ name => { sl => 1, maxlength => 200 },
+ latin => { default => undef, sl => 1, maxlength => 200 },
+ alias => { default => '', maxlength => 500 },
+ lang => { enum => \%LANGUAGE },
+ website => { default => '', weburl => 1 },
+ l_wikidata => { default => undef, uint => 1, max => (1<<31)-1 },
+ description => { default => '', maxlength => 5000 },
+ relations => { sort_keys => 'pid', aoh => {
+ pid => { vndbid => 'p' },
+ relation => { enum => \%PRODUCER_RELATION },
+ name => { _when => 'out' },
+ } },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+};
+
+my $FORM_OUT = form_compile out => $FORM;
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_CMP = form_compile cmp => $FORM;
+
+
+TUWF::get qr{/$RE{prev}/edit} => sub {
+ my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit p => $e;
+
+ $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}";
+
+ enrich_merge pid => sql('SELECT id AS pid, title[1+1] AS name FROM', producerst, 'p WHERE id IN'), $e->{relations};
+
+ my $title = titleprefs_swap @{$e}{qw/ lang name latin /};
+ framework_ title => "Edit $title->[1]", dbobj => $e, tab => 'edit',
+ sub {
+ editmsg_ p => $e, "Edit $title->[1]";
+ div_ widget(ProducerEdit => $FORM_OUT, $e), '';
+ };
+};
+
+
+TUWF::get qr{/p/add}, sub {
+ return tuwf->resDenied if !can_edit p => undef;
+
+ framework_ title => 'Add producer',
+ sub {
+ editmsg_ p => undef, 'Add producer';
+ div_ widget(ProducerEdit => $FORM_OUT, elm_empty $FORM_OUT), '';
+ };
+};
+
+
+js_api ProducerEdit => $FORM_IN, sub {
+ my $data = shift;
+ my $new = !$data->{id};
+ my $e = $new ? { id => 0 } : db_entry $data->{id} or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit p => $e;
+
+ if(!auth->permDbmod) {
+ $data->{hidden} = $e->{hidden}||0;
+ $data->{locked} = $e->{locked}||0;
+ }
+ $data->{description} = bb_subst_links $data->{description};
+ $data->{alias} =~ s/\n\n+/\n/;
+
+ $data->{relations} = [] if $data->{hidden};
+ validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{pid}, $data->{relations}->@*;
+ die "Relation with self" if grep $_->{pid} eq $e->{id}, $data->{relations}->@*;
+
+ return +{ _err => 'No changes.' } if !$new && !form_changed $FORM_CMP, $data, $e;
+ my $ch = db_edit p => $e->{id}, $data;
+ update_reverse($ch->{nitemid}, $ch->{nrev}, $e, $data);
+ +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" };
+};
+
+
+sub update_reverse {
+ my($id, $rev, $old, $new) = @_;
+
+ my %old = map +($_->{pid}, $_), $old->{relations} ? $old->{relations}->@* : ();
+ my %new = map +($_->{pid}, $_), $new->{relations}->@*;
+
+ # Updates to be performed, pid => { pid => x, relation => y } or undef if the relation should be removed.
+ my %upd;
+
+ for my $i (keys %old, keys %new) {
+ if($old{$i} && !$new{$i}) {
+ $upd{$i} = undef;
+ } elsif(!$old{$i} || $old{$i}{relation} ne $new{$i}{relation}) {
+ $upd{$i} = {
+ pid => $id,
+ relation => $PRODUCER_RELATION{ $new{$i}{relation} }{reverse},
+ };
+ }
+ }
+
+ for my $i (keys %upd) {
+ my $e = db_entry $i;
+ $e->{relations} = [
+ $upd{$i} ? $upd{$i} : (),
+ grep $_->{pid} ne $id, $e->{relations}->@*
+ ];
+ $e->{editsum} = "Reverse relation update caused by revision $id.$rev";
+ db_edit p => $i, $e, 'u1';
+ }
+}
+
+1;
diff --git a/lib/VNWeb/Producers/Elm.pm b/lib/VNWeb/Producers/Elm.pm
new file mode 100644
index 00000000..cde3bd39
--- /dev/null
+++ b/lib/VNWeb/Producers/Elm.pm
@@ -0,0 +1,34 @@
+package VNWeb::Producers::Elm;
+
+use VNWeb::Prelude;
+
+elm_api Producers => undef, {
+ search => { type => 'array', values => { searchquery => 1 } },
+}, sub {
+ my($data) = @_;
+ my @q = grep $_, $data->{search}->@*;
+
+ elm_ProducerResult @q ? tuwf->dbPagei({ results => 15, page => 1 },
+ 'SELECT p.id, p.title[1+1] AS name, p.title[1+1+1+1] AS altname
+ FROM', producerst, 'p', VNWeb::Validate::SearchQuery::sql_joina(\@q, 'p', 'p.id'), '
+ WHERE NOT p.hidden
+ ORDER BY sc.score DESC, p.sorttitle
+ ') : [];
+};
+
+js_api Producers => {
+ search => { type => 'array', values => { searchquery => 1 } },
+}, sub {
+ my($data) = @_;
+ my @q = grep $_, $data->{search}->@*;
+
+ +{ results => @q ? tuwf->dbAlli(
+ 'SELECT p.id, p.title[1+1] AS name, p.title[1+1+1+1] AS altname
+ FROM', producerst, 'p', VNWeb::Validate::SearchQuery::sql_joina(\@q, 'p', 'p.id'), '
+ WHERE NOT p.hidden
+ ORDER BY sc.score DESC, p.sorttitle
+ LIMIT', \30
+ ) : [] };
+};
+
+1;
diff --git a/lib/VNWeb/Producers/Graph.pm b/lib/VNWeb/Producers/Graph.pm
new file mode 100644
index 00000000..4ac14c62
--- /dev/null
+++ b/lib/VNWeb/Producers/Graph.pm
@@ -0,0 +1,72 @@
+package VNWeb::Producers::Graph;
+
+use VNWeb::Prelude;
+use VNWeb::Graph;
+
+
+TUWF::get qr{/$RE{pid}/rg}, sub {
+ my $num = tuwf->validate(get => num => { uint => 1, onerror => 15 })->data;
+ my $p = dbobj tuwf->capture(1);
+
+ # Big list of { id0, id1, relation } hashes.
+ # Each relation is included twice, with id0 and id1 reversed.
+ my $rel = tuwf->dbAlli(q{
+ WITH RECURSIVE rel(id0, id1, relation) AS (
+ SELECT id, pid, relation FROM producers_relations WHERE id =}, \$p->{id}, q{
+ UNION
+ SELECT id, pid, pr.relation FROM producers_relations pr JOIN rel r ON pr.id = r.id1
+ ) SELECT * FROM rel ORDER BY id0
+ });
+ return tuwf->resNotFound if !@$rel;
+
+ # Fetch the nodes
+ my $nodes = gen_nodes $p->{id}, $rel, $num;
+ enrich_merge id => sql('SELECT id, title[1+1] AS name, lang, type FROM', producerst, 'p WHERE id IN'), values %$nodes;
+
+ my $total_nodes = keys { map +($_->{id0},1), @$rel }->%*;
+ my $visible_nodes = keys %$nodes;
+
+ my @lines;
+ my $params = $num == 15 ? '' : "?num=$num";
+ for my $n (sort { idcmp $a->{id}, $b->{id} } values %$nodes) {
+ my $name = val_escape shorten $n->{name}, 27;
+ my $tooltip = val_escape $n->{name};
+ my $nodeid = $n->{distance} == 0 ? 'id = "graph_current", ' : '';
+ push @lines,
+ qq|n$n->{id} [ $nodeid URL = "/$n->{id}", tooltip = "$tooltip", label=<|.
+ qq|<TABLE CELLSPACING="0" CELLPADDING="2" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|.
+ qq|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="3"><FONT POINT-SIZE="9"> $name </FONT></TD></TR>|.
+ qq|<TR><TD ALIGN="CENTER"> $LANGUAGE{$n->{lang}}{txt} </TD><TD ALIGN="CENTER"> $PRODUCER_TYPE{$n->{type}} </TD></TR>|.
+ qq|</TABLE>> ]|;
+
+ push @lines, node_more $n->{id}, "/$n->{id}/rg$params", scalar grep !$nodes->{$_}, $n->{rels}->@*;
+ }
+
+ $rel = [ grep $nodes->{$_->{id0}} && $nodes->{$_->{id1}}, @$rel ];
+ my $dot = gen_dot \@lines, $nodes, $rel, \%PRODUCER_RELATION;
+
+ framework_ title => "Relations for $p->{title}[1]", dbobj => $p, tab => 'rg',
+ sub {
+ article_ class => 'relgraph', sub {
+ h1_ "Relations for $p->{title}[1]";
+ p_ sub {
+ txt_ sprintf "Displaying %d out of %d related producers.", $visible_nodes, $total_nodes;
+ debug_ +{ nodes => $nodes, rel => $rel };
+ br_;
+ txt_ "Adjust graph size: ";
+ join_ ', ', sub {
+ if($_ == min $num, $total_nodes) {
+ txt_ $_ ;
+ } else {
+ a_ href => "/$p->{id}/rg?num=$_", $_;
+ }
+ }, grep($_ < $total_nodes, 10, 15, 25, 50, 75, 100, 150, 250, 500, 750, 1000), $total_nodes;
+ txt_ '.';
+ } if $total_nodes > 10;
+ p_ class => 'center', sub { lit_ dot2svg $dot };
+ };
+ clearfloat_;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Producers/List.pm b/lib/VNWeb/Producers/List.pm
new file mode 100644
index 00000000..4b8112f0
--- /dev/null
+++ b/lib/VNWeb/Producers/List.pm
@@ -0,0 +1,75 @@
+package VNWeb::Producers::List;
+
+use VNWeb::Prelude;
+use VNWeb::AdvSearch;
+
+
+sub listing_ {
+ my($opt, $list, $count) = @_;
+
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ paginate_ \&url, $opt->{p}, [$count, 150], 't';
+ article_ class => 'producerbrowse', sub {
+ h1_ $opt->{q} ? 'Search results' : 'Browse producers';
+ ul_ sub {
+ li_ sub {
+ abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, '';
+ a_ href => "/$_->{id}", tattr $_;
+ } for @$list;
+ }
+ };
+ paginate_ \&url, $opt->{p}, [$count, 150], 'b';
+}
+
+
+TUWF::get qr{/p(?:/(?<char>all|[a-z0]))?}, sub {
+ my $char = tuwf->capture('char');
+ my $opt = tuwf->validate(get =>
+ p => { upage => 1 },
+ q => { searchquery => 1 },
+ f => { advsearch_err => 'p' },
+ ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } },
+ )->data;
+ $opt->{ch} = $opt->{ch}[0];
+
+ # compat with old URLs
+ my $oldch = tuwf->capture('char');
+ $opt->{ch} //= $oldch if defined $oldch && $oldch ne 'all';
+
+ $opt->{f} = advsearch_default 'p' if !$opt->{f}{query} && !defined tuwf->reqGet('f');
+
+ my $where = sql_and 'NOT p.hidden', $opt->{f}->sql_where(),
+ defined($opt->{ch}) ? sql 'match_firstchar(p.sorttitle, ', \$opt->{ch}, ')' : ();
+
+ my $time = time;
+ my($count, $list);
+ db_maytimeout {
+ $count = tuwf->dbVali('SELECT COUNT(*) FROM', producerst, 'p WHERE', sql_and $where, $opt->{q}->sql_where('p', 'p.id'));
+ $list = $count ? tuwf->dbPagei({ results => 150, page => $opt->{p} },
+ 'SELECT p.id, p.title, p.lang
+ FROM', producerst, 'p', $opt->{q}->sql_join('p', 'p.id'), '
+ WHERE', $where, '
+ ORDER BY', $opt->{q} ? 'sc.score DESC, ' : (), 'p.sorttitle'
+ ) : [];
+ } || (($count, $list) = (undef, []));
+ $time = time - $time;
+
+ framework_ title => 'Browse producers', sub {
+ article_ sub {
+ h1_ 'Browse producers';
+ form_ action => '/p', method => 'get', sub {
+ searchbox_ p => $opt->{q};
+ p_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'ch', value => ($_//''), ($_//'') eq ($opt->{ch}//'') ? (class => 'optselected') : (), !defined $_ ? 'ALL' : $_ ? uc $_ : '#'
+ for (undef, 'a'..'z', 0);
+ };
+ input_ type => 'hidden', name => 'ch', value => $opt->{ch}//'';
+ $opt->{f}->elm_($count, $time);
+ };
+ };
+ listing_ $opt, $list, $count if $count;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Producers/Page.pm b/lib/VNWeb/Producers/Page.pm
new file mode 100644
index 00000000..5453d777
--- /dev/null
+++ b/lib/VNWeb/Producers/Page.pm
@@ -0,0 +1,183 @@
+package VNWeb::Producers::Page;
+
+use VNWeb::Prelude;
+use VNWeb::Releases::Lib;
+use VNWeb::ULists::Lib;
+
+
+sub enrich_item {
+ my($p) = @_;
+ enrich_extlinks p => 0, $p;
+ enrich_merge pid => sql('SELECT id AS pid, title, sorttitle FROM', producerst, 'p WHERE id IN'), $p->{relations};
+ $p->{relations} = [ sort { $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{pid}, $b->{pid}) } $p->{relations}->@* ];
+}
+
+
+sub rev_ {
+ my($p) = @_;
+ revision_ $p, \&enrich_item,
+ [ name => 'Name' ],
+ [ latin => 'Name (latin)' ],
+ [ alias => 'Aliases' ],
+ [ description=> 'Description' ],
+ [ type => 'Type', fmt => \%PRODUCER_TYPE ],
+ [ lang => 'Language', fmt => \%LANGUAGE ],
+ [ relations => 'Relations', fmt => sub {
+ txt_ $PRODUCER_RELATION{$_->{relation}}{txt}.': ';
+ a_ href => "/$_->{pid}", tattr $_;
+ } ],
+ revision_extlinks 'p'
+}
+
+
+sub info_ {
+ my($p) = @_;
+
+ p_ class => 'center', sub {
+ txt_ $PRODUCER_TYPE{$p->{type}};
+ br_;
+ txt_ "Primary language: $LANGUAGE{$p->{lang}}{txt}";
+ if(length $p->{alias}) {
+ br_;
+ txt_ 'a.k.a. ';
+ txt_ $p->{alias} =~ s/\n/, /gr;
+ }
+ br_ if $p->{extlinks}->@*;
+ join_ ' - ', sub { a_ href => $_->{url2}, $_->{label} }, $p->{extlinks}->@*;
+ };
+
+ p_ class => 'center', sub {
+ my %rel;
+ push $rel{$_->{relation}}->@*, $_ for $p->{relations}->@*;
+ br_;
+ join_ \&br_, sub {
+ txt_ $PRODUCER_RELATION{$_}{txt}.': ';
+ join_ ', ', sub { a_ href => "/$_->{pid}", tattr $_ }, $rel{$_}->@*;
+ }, grep $rel{$_}, keys %PRODUCER_RELATION;
+ } if $p->{relations}->@*;
+
+ div_ class => 'description', sub { lit_ bb_format $p->{description} } if length $p->{description};
+}
+
+
+sub rel_ {
+ my($p) = @_;
+
+ my $r = tuwf->dbAlli('
+ SELECT r.id, r.patch, r.released, r.gtin, rp.publisher, rp.developer, ', sql_extlinks(r => 'r.'), '
+ FROM releases r
+ JOIN releases_producers rp ON rp.id = r.id
+ WHERE rp.pid =', \$p->{id}, ' AND NOT r.hidden
+ ORDER BY r.released
+ ');
+ $_->{rtype} = 1 for @$r; # prevent enrich_release() from fetching rtypes
+ enrich_extlinks r => 0, $r;
+ enrich_release $r;
+ enrich vn => id => rid => sub { sql '
+ SELECT rv.id as rid, rv.rtype, v.id, v.title
+ FROM', vnt, 'v
+ JOIN releases_vn rv ON rv.vid = v.id
+ WHERE NOT v.hidden AND rv.id IN', $_, '
+ ORDER BY v.title
+ '}, $r;
+
+ my(%vn, @vn);
+ for my $rel (@$r) {
+ for ($rel->{vn}->@*) {
+ push @vn, $_ if !$vn{$_->{id}};
+ push $vn{$_->{id}}->@*, [ $_->{rtype}, $rel ];
+ }
+ }
+ enrich_ulists_widget \@vn;
+
+ h1_ 'Releases';
+ debug_ $r;
+ table_ class => 'releases', sub {
+ for my $v (@vn) {
+ tr_ class => 'vn', sub {
+ td_ colspan => 8, sub {
+ ulists_widget_ $v;
+ a_ href => "/$v->{id}", tattr $v;
+ };
+ my $ropt = { id => $v->{id}, prod => 1 };
+ release_row_ $_, $ropt for sort_releases(
+ [ map { $_->[1]{rtype} = $_->[0]; $_->[1] } $vn{$v->{id}}->@* ]
+ )->@*;
+ };
+ }
+ } if @$r;
+ p_ 'This producer has no releases in the database.' if !@$r;
+}
+
+
+sub vns_ {
+ my($p) = @_;
+ my $v = tuwf->dbAlli(q{
+ SELECT v.id, v.title, rels.developer, rels.publisher, rels.released
+ FROM}, vnt, q{v
+ JOIN (
+ SELECT rv.vid, bool_or(rp.developer), bool_or(rp.publisher)
+ , COALESCE(MIN(r.released) FILTER(WHERE rv.rtype <> 'trial'), MIN(r.released))
+ FROM releases_vn rv
+ JOIN releases r ON r.id = rv.id
+ JOIN releases_producers rp ON rp.id = rv.id
+ WHERE NOT r.hidden AND rp.pid =}, \$p->{id}, '
+ GROUP BY rv.vid
+ ) rels(vid, developer, publisher, released) ON rels.vid = v.id
+ WHERE NOT v.hidden
+ ORDER BY rels.released, v.sorttitle
+ ');
+
+ h1_ 'Visual Novels';
+ debug_ $v;
+ enrich_ulists_widget $v;
+ # TODO: Perhaps something more table-like, also showing languages, platforms & VN list status
+ ul_ class => 'prodvns', sub {
+ li_ sub {
+ span_ sub { rdate_ $_->{released} };
+ ulists_widget_ $_;
+ a_ href => "/$_->{id}", tattr $_;
+ span_ join ' & ',
+ $_->{publisher} ? 'Publisher' : (),
+ $_->{developer} ? 'Developer' : ();
+ } for @$v;
+ };
+ p_ 'This producer has no releases in the database.' if !@$v;
+}
+
+
+TUWF::get qr{/$RE{prev}(?:/(?<tab>vn|rel))?}, sub {
+ my $p = db_entry tuwf->captures('id', 'rev');
+ return tuwf->resNotFound if !$p;
+ enrich_item $p;
+
+ my $tab = tuwf->capture('tab')
+ || (auth && (tuwf->dbVali('SELECT prodrelexpand FROM users_prefs WHERE id=', \auth->uid) ? 'rel' : 'vn'))
+ || 'rel';
+
+ my $title = titleprefs_swap @{$p}{qw/ lang name latin /};
+ framework_ title => $title->[1], index => !tuwf->capture('rev'), dbobj => $p, hiddenmsg => 1,
+ og => {
+ title => $title->[1],
+ description => bb_format($p->{description}, text => 1),
+ },
+ sub {
+ rev_ $p if tuwf->capture('rev');
+ article_ sub {
+ itemmsg_ $p;
+ h1_ tlang(@{$title}[0,1]), $title->[1];
+ h2_ class => 'alttitle', tlang(@{$title}[2,3]), $title->[3] if $title->[3] && $title->[3] ne $title->[1];
+ info_ $p;
+ };
+ nav_ class => 'right', sub {
+ menu_ sub {
+ li_ mkclass(tabselected => $tab eq 'vn'), sub { a_ href => "/$p->{id}/vn", 'Visual Novels' };
+ li_ mkclass(tabselected => $tab eq 'rel'), sub { a_ href => "/$p->{id}/rel", 'Releases' };
+ };
+ };
+ article_ sub { rel_ $p } if $tab eq 'rel';
+ article_ sub { vns_ $p } if $tab eq 'vn';
+ }
+};
+
+1;
diff --git a/lib/VNWeb/Releases/DRM.pm b/lib/VNWeb/Releases/DRM.pm
new file mode 100644
index 00000000..7ac7add3
--- /dev/null
+++ b/lib/VNWeb/Releases/DRM.pm
@@ -0,0 +1,120 @@
+package VNWeb::Releases::DRM;
+
+use VNWeb::Prelude;
+use TUWF 'uri_escape';
+
+TUWF::get '/r/drm', sub {
+ my $opt = tuwf->validate(get =>
+ n => { onerror => '' },
+ s => { onerror => '' },
+ t => { onerror => undef, enum => [0,1,2] },
+ u => { anybool => 1 },
+ )->data;
+ my $where = sql_and
+ $opt->{s} ? sql 'name ILIKE', \('%'.sql_like($opt->{s}).'%') : (),
+ defined $opt->{t} ? sql 'state =', \$opt->{t} : ();
+
+ my $lst = tuwf->dbAlli('
+ SELECT id, state, name, description, c_ref, ', sql_comma(keys %DRM_PROPERTY), '
+ FROM drm
+ WHERE', $where, $opt->{u} ? () : 'AND c_ref > 0',
+ 'ORDER BY c_ref DESC
+ ');
+ my $missing = $opt->{u} ? 0 : tuwf->dbVali('SELECT COUNT(*) FROM drm WHERE', $where, 'AND c_ref = 0');
+
+ framework_ title => 'List of DRM implementations', sub {
+ article_ sub {
+ h1_ 'List of DRM implementations';
+ form_ action => '/r/drm', method => 'get', sub {
+ fieldset_ class => 'search', sub {
+ input_ type => 'text', name => 's', id => 's', class => 'text', value => $opt->{s};
+ input_ type => 'submit', class => 'submit', value => 'Search!';
+ }
+ };
+ my sub opt_ {
+ my($k,$v,$lbl) = @_;
+ a_ href => '?'.query_encode(%$opt,$k=>$v), defined $opt->{$k} eq defined $v && (!defined $v || $opt->{$k} == $v) ? (class => 'optselected') : (), $lbl;
+ }
+ p_ class => 'browseopts', sub {
+ a_ href => '?'.query_encode(%$opt,t=>undef), !defined $opt->{t} ? (class => 'optselected') : (), 'All';
+ a_ href => '?'.query_encode(%$opt,t=>0), defined $opt->{t} && $opt->{t} == 0 ? (class => 'optselected') : (), 'New';
+ a_ href => '?'.query_encode(%$opt,t=>1), defined $opt->{t} && $opt->{t} == 1 ? (class => 'optselected') : (), 'Approved';
+ a_ href => '?'.query_encode(%$opt,t=>2), defined $opt->{t} && $opt->{t} == 2 ? (class => 'optselected') : (), 'Deleted';
+ };
+ my $unused = 0;
+ section_ class => 'drmlist', sub {
+ my $d = $_;
+ h2_ !$d->{c_ref} && !$unused++ ? (id => 'unused') : (), sub {
+ span_ class => 'strikethrough', $d->{name} if $d->{state} == 2;
+ txt_ $d->{name} if $d->{state} != 2;
+ a_ href => '/r?f='.tuwf->compile({advsearch => 'r'})->validate(['drm','=',$d->{name}])->data->query_encode, " ($d->{c_ref})";
+ b_ ' (new)' if $d->{state} == 0;
+ a_ href => "/r/drm/edit/$d->{id}?ref=".uri_escape(query_encode(%$opt)), ' edit' if auth->permDbmod;
+ };
+ my @prop = grep $d->{$_}, keys %DRM_PROPERTY;
+ p_ sub {
+ join_ ' ', sub {
+ abbr_ class => "icon-drm-$_", title => $DRM_PROPERTY{$_}, '';
+ txt_ $DRM_PROPERTY{$_};
+ }, @prop;
+ if (!@prop) {
+ abbr_ class => 'icon-drm-free', title => 'DRM-free', '';
+ txt_ 'DRM-free';
+ }
+ };
+ div_ sub { lit_ bb_format $d->{description} if $d->{description} };
+ } for @$lst;
+ p_ class => 'center', sub {
+ txt_ "$missing unused DRM type(s) not shown. ";
+ a_ href => '?'.query_encode(%$opt,u=>1).'#unused', 'Show all';
+ } if $missing;
+ };
+ };
+};
+
+
+my $FORM = form_compile any => {
+ id => { uint => 1 },
+ state => { uint => 1, range => [0,2] },
+ name => { sl => 1, maxlength => 128 },
+ description => { default => '', maxlength => 10240 },
+ ref => { default => '' },
+ map +($_,{anybool=>1}), keys %DRM_PROPERTY
+};
+
+
+sub info_ {
+ tuwf->dbRowi('
+ SELECT id, state, name, description,', sql_comma(keys %DRM_PROPERTY), '
+ FROM drm WHERE id =', \shift
+ );
+}
+
+TUWF::get qr{/r/drm/edit/(0|$RE{num})}, sub {
+ return tuwf->resDenied if !auth->permDbmod;
+ my $d = info_ tuwf->capture(1);
+ return tuwf->resNotFound if !defined $d->{id};
+ $d->{ref} = tuwf->reqGet('ref');
+ framework_ title => "Edit DRM: $d->{name}", sub {
+ div_ widget(DRMEdit => $FORM, $d), '';
+ };
+};
+
+js_api DRMEdit => $FORM, sub {
+ my $data = shift;
+ return tuwf->resDenied if !auth->permDbmod;
+ my $d = info_ delete $data->{id};
+ return tuwf->resNotFound if !defined $d->{id};
+ my $ref = delete $data->{ref};
+
+ return +{ _er => 'Duplicate DRM name' }
+ if tuwf->dbVali('SELECT 1 FROM drm WHERE id <>', \$d->{id}, 'AND name =', \$d->{name});
+
+ tuwf->dbExeci('UPDATE drm SET', $data, 'WHERE id =', \$d->{id});
+
+ my @diff = grep $d->{$_} ne $data->{$_}, qw/state name description/, keys %DRM_PROPERTY;
+ auth->audit(undef, 'drm edit', join '; ', map "$_: $d->{$_} -> $data->{$_}", @diff) if @diff;
+ +{ _redir => "/r/drm?$ref" };
+};
+
+1;
diff --git a/lib/VNWeb/Releases/Edit.pm b/lib/VNWeb/Releases/Edit.pm
new file mode 100644
index 00000000..b004b7e1
--- /dev/null
+++ b/lib/VNWeb/Releases/Edit.pm
@@ -0,0 +1,220 @@
+package VNWeb::Releases::Edit;
+
+use VNWeb::Prelude;
+
+
+my $FORM = {
+ id => { default => undef, vndbid => 'r' },
+ official => { anybool => 1 },
+ patch => { anybool => 1 },
+ freeware => { anybool => 1 },
+ doujin => { anybool => 1 },
+ has_ero => { anybool => 1 },
+ titles => { minlength => 1, sort_keys => 'lang', aoh => {
+ lang => { enum => \%LANGUAGE },
+ mtl => { anybool => 1 },
+ title => { default => undef, sl => 1, maxlength => 300 },
+ latin => { default => undef, sl => 1, maxlength => 300 },
+ } },
+ # Titles fetched from the VN entry, for auto-filling
+ vntitles => { _when => 'out', aoh => {
+ lang => {},
+ title => {},
+ latin => { default => undef },
+ } },
+ olang => { enum => \%LANGUAGE, default => 'ja' },
+ platforms => { aoh => { platform => { enum => \%PLATFORM } } },
+ media => { aoh => {
+ medium => { enum => \%MEDIUM },
+ qty => { uint => 1, range => [0,40] },
+ } },
+ drm => { sort_keys => 'name', aoh => {
+ name => { sl => 1, maxlength => 128 },
+ notes => { default => '' },
+ description => { default => '', maxlength => 10240 },
+ map +($_,{anybool=>1}), keys %DRM_PROPERTY
+ } },
+ gtin => { gtin => 1 },
+ catalog => { default => '', sl => 1, maxlength => 50 },
+ released => { default => 99999999, min => 1, rdate => 1 },
+ minage => { default => undef, int => 1, enum => \%AGE_RATING },
+ uncensored => { undefbool => 1 },
+ reso_x => { uint => 1, range => [0,32767] },
+ reso_y => { uint => 1, range => [0,32767] },
+ voiced => { uint => 1, enum => \%VOICED },
+ ani_story => { uint => 1, enum => \%ANIMATED },
+ ani_ero => { uint => 1, enum => \%ANIMATED },
+ ani_story_sp => { default => undef, uint => 1, range => [0,32767] },
+ ani_story_cg => { default => undef, uint => 1, range => [0,32767] },
+ ani_cutscene => { default => undef, uint => 1, range => [0,32767] },
+ ani_ero_sp => { default => undef, uint => 1, range => [0,32767] },
+ ani_ero_cg => { default => undef, uint => 1, range => [0,32767] },
+ ani_face => { undefbool => 1 },
+ ani_bg => { undefbool => 1 },
+ website => { default => '', weburl => 1 },
+ engine => { default => '', sl => 1, maxlength => 50 },
+ notes => { default => '', maxlength => 10240 },
+ vn => { sort_keys => 'vid', aoh => {
+ vid => { vndbid => 'v' },
+ title => { _when => 'out' },
+ rtype => { default => 'complete', enum => \%RELEASE_TYPE },
+ } },
+ producers => { sort_keys => 'pid', aoh => {
+ pid => { vndbid => 'p' },
+ developer => { anybool => 1 },
+ publisher => { anybool => 1 },
+ name => { _when => 'out' },
+ } },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+ validate_extlinks 'r'
+};
+
+my $FORM_OUT = form_compile out => $FORM;
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_CMP = form_compile cmp => $FORM;
+
+
+TUWF::get qr{/$RE{rrev}/(?<action>edit|copy)} => sub {
+ my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound;
+ my $copy = tuwf->capture('action') eq 'copy';
+ return tuwf->resDenied if !can_edit r => $copy ? {} : $e;
+
+ $e->{editsum} = $copy ? "Copied from $e->{id}.$e->{chrev}" : $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}";
+
+ $e->{titles} = [ sort { $a->{lang} cmp $b->{lang} } $e->{titles}->@* ];
+
+ $e->{vntitles} = $e->{vn}->@* == 1 ? tuwf->dbAlli('SELECT lang, title, latin FROM vn_titles WHERE id =', \$e->{vn}[0]{vid}) : [];
+
+ enrich_merge vid => sql('SELECT id AS vid, title[1+1] FROM', vnt, 'v WHERE id IN'), $e->{vn};
+ enrich_merge pid => sql('SELECT id AS pid, title[1+1] AS name FROM', producerst, 'p WHERE id IN'), $e->{producers};
+ enrich_merge drm => sql('SELECT id AS drm, name FROM drm WHERE id IN'), $e->{drm};
+
+ my @empty_fields = ('gtin', 'catalog', grep /^l_/, keys %$e);
+ $e->@{@empty_fields} = elm_empty($FORM_OUT)->@{@empty_fields} if $copy;
+
+ my $title = ($copy ? 'Copy ' : 'Edit ').titleprefs_obj($e->{olang}, $e->{titles})->[1];
+ framework_ title => $title, dbobj => $e, tab => tuwf->capture('action'),
+ sub {
+ editmsg_ r => $e, $title, $copy;
+ div_ widget(ReleaseEdit => $FORM_OUT, $copy ? {%$e, id=>undef} : $e), '';
+ };
+};
+
+
+TUWF::get qr{/$RE{vid}/add}, sub {
+ return tuwf->resDenied if !can_edit r => undef;
+ my $v = tuwf->dbRowi('SELECT id, title FROM', vnt, 'v WHERE NOT hidden AND v.id =', \tuwf->capture('id'));
+ return tuwf->resNotFound if !$v->{id};
+
+ my $delrel = tuwf->dbAlli('SELECT r.id, r.title FROM', releasest, 'r JOIN releases_vn rv ON rv.id = r.id WHERE r.hidden AND rv.vid =', \$v->{id}, 'ORDER BY id');
+ enrich_flatten languages => id => id => 'SELECT id, lang FROM releases_titles WHERE id IN', $delrel;
+
+ my $e = {
+ elm_empty($FORM_OUT)->%*,
+ vn => [{vid => $v->{id}, title => $v->{title}[1], rtype => 'complete'}],
+ vntitles => tuwf->dbAlli('SELECT lang, title, latin FROM vn_titles WHERE id =', \$v->{id}),
+ official => 1,
+ };
+
+ framework_ title => "Add release to $v->{title}[1]",
+ sub {
+ editmsg_ r => undef, "Add release to $v->{title}[1]";
+
+ article_ sub {
+ h1_ 'Deleted releases';
+ div_ class => 'warning', sub {
+ p_ q{This visual novel has releases that have been deleted
+ before. Please review this list to make sure you're not
+ adding a release that has already been deleted.};
+ br_;
+ ul_ sub {
+ li_ sub {
+ txt_ '['.join(',', $_->{languages}->@*)."] $_->{id}:";
+ a_ href => "/$_->{id}", tattr $_;
+ } for @$delrel;
+ }
+ }
+ } if @$delrel;
+
+ div_ widget(ReleaseEdit => $FORM_OUT, $e), '';
+ };
+};
+
+
+js_api ReleaseEdit => $FORM_IN, sub {
+ my $data = shift;
+ my $new = !$data->{id};
+ my $e = $new ? { id => 0 } : db_entry $data->{id} or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit r => $e;
+
+ if(!auth->permDbmod) {
+ $data->{hidden} = $e->{hidden}||0;
+ $data->{locked} = $e->{locked}||0;
+ }
+
+ if($data->{patch}) {
+ $data->{doujin} = $data->{voiced} = $data->{ani_story} = $data->{ani_ero} = 0;
+ $data->{reso_x} = $data->{reso_y} = 0;
+ $data->{ani_story_sp} = $data->{ani_story_cg} = $data->{ani_cutscene} = $data->{ani_ero_sp} = $data->{ani_ero_cg} = $data->{ani_face} = $data->{ani_bg} = undef;
+ $data->{engine} = '';
+ }
+ if(!$data->{has_ero}) {
+ $data->{uncensored} = undef;
+ $data->{ani_ero} = 0;
+ $data->{ani_ero_sp} = $data->{ani_ero_cg} = undef;
+ }
+ ani_compat($data, $e);
+
+ die "No title in main language" if !length [grep $_->{lang} eq $data->{olang}, $data->{titles}->@*]->[0]{title};
+
+ $_->{qty} = $MEDIUM{$_->{medium}}{qty} ? $_->{qty}||1 : 0 for $data->{media}->@*;
+ $data->{notes} = bb_subst_links $data->{notes};
+ die "No VNs selected" if !$data->{vn}->@*;
+ die "Invalid resolution: ($data->{reso_x},$data->{reso_y})" if (!$data->{reso_x} && $data->{reso_y} > 1) || ($data->{reso_x} && !$data->{reso_y});
+
+ # We need the DRM names for form_changed()
+ enrich_merge drm => sql('SELECT id AS drm, name FROM drm WHERE id IN'), $e->{drm};
+ # And the DRM identifiers to actually save the new form.
+ enrich_merge name => sql('SELECT name, id AS drm FROM drm WHERE name IN'), $data->{drm};
+ for my $d ($data->{drm}->@*) {
+ $d->{notes} = bb_subst_links $d->{notes};
+ $d->{drm} = tuwf->dbVali('INSERT INTO drm', {map +($_,$d->{$_}), 'name', 'description', keys %DRM_PROPERTY}, 'RETURNING id')
+ if !defined $d->{drm};
+ }
+
+ return 'No changes' if !$new && !form_changed $FORM_CMP, $data, $e;
+
+ my $ch = db_edit r => $e->{id}, $data;
+ +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" };
+};
+
+
+# Set the old ani_story and ani_ero fields to some sort of value based on the
+# new ani_* fields, if they've been changed.
+sub ani_compat {
+ my($r, $old) = @_;
+ return if !grep +($r->{$_}//'_undef_') ne ($old->{$_}//'_undef_'),
+ qw{ ani_story_sp ani_story_cg ani_cutscene ani_ero_sp ani_ero_cg ani_face ani_bg };
+
+ my sub known($) { defined $r->{"ani_$_[0]"} }
+ my sub hasani($) { $r->{"ani_$_[0]"} && $r->{"ani_$_[0]"} > 1 }
+ my sub someani($) { hasani $_[0] && ($r->{"ani_$_[0]"} & 512) == 0 }
+ my sub fullani($) { defined $r->{"ani_$_[0]"} && ($r->{"ani_$_[0]"} & 512) > 0 }
+
+ $r->{ani_story} =
+ !known 'story_sp' && !known 'story_cg' && !known 'cutscene' ? 0 :
+ !hasani 'story_sp' && !hasani 'story_cg' && !hasani 'cutscene' ? 1 :
+ (fullani 'story_sp' || fullani 'story_cg') && !(someani 'story_sp' || someani 'story_cg') ? 4 : 3;
+
+ $r->{ani_ero} =
+ !known 'ero_sp' && !known 'ero_cg' ? 0 :
+ !hasani 'ero_sp' && !hasani 'ero_cg' ? 1 :
+ (fullani 'ero_sp' || fullani 'ero_cg') && !(someani 'ero_sp' || someani 'ero_cg') ? 4 : 3;
+
+ $r->{ani_story} = 2 if $r->{ani_story} < 2 && ($r->{ani_face} || $r->{ani_bg});
+}
+
+
+1;
diff --git a/lib/VNWeb/Releases/Elm.pm b/lib/VNWeb/Releases/Elm.pm
index 32dd89ca..4abe0b12 100644
--- a/lib/VNWeb/Releases/Elm.pm
+++ b/lib/VNWeb/Releases/Elm.pm
@@ -1,22 +1,57 @@
package VNWeb::Releases::Elm;
use VNWeb::Prelude;
+use VNWeb::Releases::Lib;
-# Used by UList.Opt to fetch releases from a VN id.
-elm_api Release => undef, { vid => { id => 1 } }, sub {
+# Used by UList.Opt and CharEdit to fetch releases from a VN id.
+elm_api Release => undef, { vid => { vndbid => 'v' } }, sub {
my($data) = @_;
- my $l = tuwf->dbAlli(
- 'SELECT r.id, r.title, r.original, r.type AS rtype, r.released
- FROM releases r
- JOIN releases_vn rv ON rv.id = r.id
- WHERE NOT r.hidden
- AND rv.vid =', \$data->{vid},
- 'ORDER BY r.released, r.title, r.id'
- );
- enrich_flatten lang => id => id => sub { sql('SELECT id, lang FROM releases_lang WHERE id IN', $_, 'ORDER BY lang') }, $l;
- enrich_flatten platforms => id => id => sub { sql('SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY platform') }, $l;
- elm_Releases $l;
+ elm_Releases releases_by_vn $data->{vid};
+};
+
+
+elm_api Resolutions => undef, {}, sub {
+ elm_Resolutions [ map +{ resolution => resolution($_), count => $_->{count} }, tuwf->dbAlli(q{
+ SELECT reso_x, reso_y, count(*) AS count FROM releases WHERE NOT hidden AND NOT (reso_x = 0 AND reso_y = 0)
+ GROUP BY reso_x, reso_y ORDER BY count(*) DESC
+ })->@* ];
+};
+
+
+elm_api Engines => undef, {}, sub {
+ elm_Engines tuwf->dbAlli(q{
+ SELECT engine, count(*) AS count FROM releases WHERE NOT hidden AND engine <> ''
+ GROUP BY engine ORDER BY count(*) DESC, engine
+ });
+};
+
+
+elm_api DRM => undef, {}, sub {
+ elm_DRM tuwf->dbAlli(q{
+ SELECT name, c_ref AS count FROM drm WHERE c_ref > 0 ORDER BY state = 1+1, c_ref DESC, name
+ });
+};
+
+
+js_api Resolutions => {}, sub {
+ +{ results => [ map +{ id => resolution($_), count => $_->{count} }, tuwf->dbAlli(q{
+ SELECT reso_x, reso_y, count(*) AS count FROM releases WHERE NOT hidden AND NOT (reso_x = 0 AND reso_y = 0)
+ GROUP BY reso_x, reso_y ORDER BY count(*) DESC
+ })->@* ] };
+};
+
+
+js_api Engines => {}, sub {
+ +{ results => tuwf->dbAlli(q{
+ SELECT engine AS id, count(*) AS count FROM releases WHERE NOT hidden AND engine <> ''
+ GROUP BY engine ORDER BY count(*) DESC, engine
+ }) };
+};
+
+
+js_api DRM => {}, sub {
+ +{ results => tuwf->dbAlli('SELECT name AS id, c_ref AS count, state FROM drm ORDER BY state = 1+1, c_ref DESC, name') };
};
1;
diff --git a/lib/VNWeb/Releases/Engines.pm b/lib/VNWeb/Releases/Engines.pm
new file mode 100644
index 00000000..f5e7e812
--- /dev/null
+++ b/lib/VNWeb/Releases/Engines.pm
@@ -0,0 +1,43 @@
+package VNWeb::Releases::Engines;
+
+use VNWeb::Prelude;
+use VNWeb::AdvSearch;
+
+
+TUWF::get qr{/r/engines}, sub {
+ my $list = tuwf->dbAlli('
+ SELECT engine, count(*) AS cnt
+ FROM releases
+ WHERE NOT hidden AND engine <> \'\'
+ GROUP BY engine
+ ORDER BY count(*) DESC'
+ );
+
+ framework_ title => 'Engine list', sub {
+ article_ sub {
+ h1_ 'Engine list';
+ p_ sub {
+ lit_ q{
+ This is a list of all engines currently associated with releases. This
+ list can be used as reference when filling out the engine field for a
+ release and to find inconsistencies in the engine names. See the <a
+ href="/d3#3">releases guidelines</a> for more information.
+ };
+ };
+ };
+ article_ class => 'browse', sub {
+ table_ class => 'stripe', sub {
+ my $c = tuwf->compile({advsearch => 'r'});
+ tr_ sub {
+ td_ class => 'tc1', style => 'text-align: right; width: 80px', $_->{cnt};
+ td_ class => 'tc2', sub {
+ a_ href => '/r?f='.$c->validate([engine => '=', $_->{engine}])->data->query_encode(), $_->{engine};
+ }
+ } for @$list;
+ };
+ };
+ };
+};
+
+
+1;
diff --git a/lib/VNWeb/Releases/Lib.pm b/lib/VNWeb/Releases/Lib.pm
new file mode 100644
index 00000000..708ed95b
--- /dev/null
+++ b/lib/VNWeb/Releases/Lib.pm
@@ -0,0 +1,185 @@
+package VNWeb::Releases::Lib;
+
+use VNWeb::Prelude;
+use Exporter 'import';
+
+our @EXPORT = qw/enrich_release_elm releases_by_vn enrich_release sort_releases release_row_/;
+
+
+# Enrich a list of releases so that it's suitable as 'Releases' Elm response.
+# Given objects must have 'id' and 'rtype' fields (appropriate for the VN in context).
+sub enrich_release_elm {
+ enrich_merge id => sql('SELECT id, title[1+1] AS title, title[1+1+1+1] AS alttitle, released, reso_x, reso_y FROM', releasest, 'r WHERE id IN'), @_;
+ enrich_flatten lang => id => id => sub { sql('SELECT id, lang FROM releases_titles WHERE id IN', $_, 'ORDER BY lang') }, @_;
+ enrich_flatten platforms => id => id => sub { sql('SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY platform') }, @_;
+}
+
+# Return the list of releases associated with a VN in the format suitable as 'Releases' Elm response.
+sub releases_by_vn {
+ my($id) = @_;
+ my $l = tuwf->dbAlli('SELECT r.id, rv.rtype FROM', releasest, 'r JOIN releases_vn rv ON rv.id = r.id WHERE NOT r.hidden AND rv.vid =', \$id, 'ORDER BY r.released, r.sorttitle, r.id');
+ enrich_release_elm $l;
+ $l
+}
+
+
+# Enrich a list of releases so that it's suitable for release_row_().
+# Assumption: Each release already has id, patch, released, gtin and enrich_extlinks().
+sub enrich_release {
+ my($r) = @_;
+ enrich_merge id => sql(
+ 'SELECT id, title, olang, notes, minage, official, freeware, has_ero, reso_x, reso_y, voiced, uncensored
+ , ani_story, ani_ero, ani_story_sp, ani_story_cg, ani_cutscene, ani_ero_sp, ani_ero_cg, ani_face, ani_bg
+ FROM', releasest, 'r WHERE id IN'), $r;
+ enrich_merge id => sub { sql 'SELECT id, MAX(rtype) AS rtype FROM releases_vn WHERE id IN', $_, 'GROUP BY id' }, grep !$_->{rtype}, ref $r ? @$r : $r;
+ enrich_merge id => sql('SELECT rid as id, status as rlist_status FROM rlists WHERE uid =', \auth->uid, 'AND rid IN'), $r if auth;
+ enrich_flatten platforms => id => id => sub { sql 'SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY id, platform' }, $r;
+ enrich titles => id => id => sub { 'SELECT id, lang, mtl, title, latin FROM releases_titles WHERE id IN', $_, 'ORDER BY id, mtl, lang' }, $r;
+ enrich media => id => id => sub { 'SELECT id, medium, qty FROM releases_media WHERE id IN', $_, 'ORDER BY id, medium' }, $r;
+ enrich drm => id => id => sub { 'SELECT r.id, r.drm, r.notes, d.name,', sql_comma(keys %DRM_PROPERTY), 'FROM releases_drm r JOIN drm d ON d.id = r.drm WHERE r.id IN', $_, 'ORDER BY r.id, r.drm' }, $r;
+}
+
+
+# Sort an array of releases, assumes the objects come from enrich_release()
+# (Not always possible with an SQL ORDER BY due to rtype being context-dependent and platforms coming from other tables)
+sub sort_releases {
+ return [ sort {
+ $a->{released} <=> $b->{released} ||
+ $b->{rtype} cmp $a->{rtype} ||
+ $b->{official} cmp $a->{official} ||
+ $a->{patch} cmp $b->{patch} ||
+ ($a->{platforms}[0]||'') cmp ($b->{platforms}[0]||'') ||
+ $a->{title}[1] cmp $b->{title}[1] ||
+ idcmp($a->{id}, $b->{id})
+ } $_[0]->@* ];
+}
+
+
+sub release_extlinks_ {
+ my($r, $id) = @_;
+ return if !$r->{extlinks}->@*;
+
+ if($r->{extlinks}->@* == 1 && $r->{website}) {
+ a_ href => $r->{extlinks}[0]{url2}, sub {
+ abbr_ class => 'icon-external', title => 'Official website', '';
+ };
+ return
+ }
+
+ div_ class => 'elm_dd_noarrow elm_dd_hover elm_dd_left elm_dd_relextlink', sub {
+ div_ class => 'elm_dd', sub {
+ a_ href => $r->{website}||'#', sub {
+ txt_ scalar $r->{extlinks}->@*;
+ abbr_ class => 'icon-external', title => 'External link', '';
+ };
+ div_ sub {
+ div_ sub {
+ ul_ sub {
+ li_ sub {
+ a_ href => $_->{url2}, sub {
+ span_ $_->{price} if length $_->{price};
+ txt_ $_->{label};
+ }
+ } for $r->{extlinks}->@*;
+ }
+ }
+ }
+ }
+ }
+}
+
+
+# Options
+# id: unique identifier if the same release may be listed on a page twice.
+# lang: $lang, whether to display language icons and which language to use for the title and MTL flag.
+# prod: 0/1 whether to display Pub/Dev indication
+sub release_row_ {
+ my($r, $opt) = @_;
+
+ my $lang = $opt->{lang} && (grep $_->{lang} eq $opt->{lang}, $r->{titles}->@*)[0];
+ my $mtl = $lang ? $lang->{mtl} : (grep $_->{mtl}, $r->{titles}->@*) == $r->{titles}->@*;
+
+ my $storyani = join "\n", map "$_.",
+ $r->{ani_story} == 1 ? 'Not animated' :
+ defined $r->{ani_story_sp} || defined $r->{ani_story_cg} || defined $r->{ani_cutscene} || defined $r->{ani_bg} || defined $r->{ani_face} ? (
+ defined $r->{ani_story_sp} ? fmtanimation $r->{ani_story_sp}, 'sprites' : (),
+ defined $r->{ani_story_cg} ? fmtanimation $r->{ani_story_cg}, 'CGs' : (),
+ defined $r->{ani_cutscene} ? fmtanimation $r->{ani_cutscene}, 'cutscenes' : (),
+ defined $r->{ani_bg} ? ($r->{ani_bg} ? 'Animated background effects' : 'No background effects') : (),
+ defined $r->{ani_face} ? ($r->{ani_face} ? 'Lip and/or eye movement' : 'No facial animations') : (),
+ ) : $ANIMATED{$r->{ani_story}}{txt};
+
+ my $eroani = join "\n", map "$_.",
+ $r->{ani_ero} == 1 ? 'Not animated' :
+ defined $r->{ani_ero_sp} || defined $r->{ani_ero_cg} ? (
+ defined $r->{ani_ero_sp} ? fmtanimation $r->{ani_ero_sp}, 'sprites' : (),
+ defined $r->{ani_ero_cg} ? fmtanimation $r->{ani_ero_cg}, 'CGs' : (),
+ ) : $ANIMATED{$r->{ani_ero}}{txt};
+
+ my sub icon_ {
+ my($img, $label, $class) = @_;
+ $class = $class ? " icon-rel-$class" : '';
+ abbr_ class => "icon-rel-$img$class", title => $label, '';
+ }
+
+ my sub icons_ {
+ my($r) = @_;
+ icon_ 'notes', bb_format $r->{notes}, text => 1 if $r->{notes};
+ icon_ $MEDIUM{ $r->{media}[0]{medium} }{icon}, join ', ', map fmtmedia($_->{medium}, $_->{qty}), $r->{media}->@* if $r->{media}->@*;
+ if($r->{reso_y}) {
+ my $ratio = $r->{reso_x} / $r->{reso_y};
+ my $type = $ratio == 4/3 ? '43' : $ratio == 16/9 ? '169' : 'custom';
+ # Ugly workaround: PC-98 has non-square pixels, thus not widescreen
+ $type = '43' if $ratio > 4/3 && grep $_ eq 'p98', $r->{platforms}->@*;
+ icon_ "reso-$type", resolution $r;
+ }
+ icon_ 'free', 'Freeware' if $r->{freeware};
+ icon_ 'nonfree', 'Non-free' if !$r->{freeware};
+ icon_ 'ani-ero', "Erotic scene animation:\n$eroani", "a$r->{ani_ero}" if $r->{ani_ero};
+ icon_ 'ani-story', "Story scene animation:\n$storyani", "a$r->{ani_story}" if $r->{ani_story};
+ icon_ 'voiced', $VOICED{$r->{voiced}}{txt}, "v$r->{voiced}" if $r->{voiced};
+ }
+
+ tr_ $mtl ? (class => 'mtl') : (), sub {
+ td_ class => 'tc1', sub { rdate_ $r->{released} };
+ td_ class => 'tc2', sub {
+ span_ class => 'releaseero releaseero_'.(!$r->{has_ero} ? 'no' : $r->{uncensored} ? 'unc' : defined $r->{uncensored} ? 'cen' : 'yes'),
+ title => !$r->{has_ero} ? 'No erotic scenes' :
+ $r->{uncensored} ? 'Contains uncensored erotic scenes'
+ : defined $r->{uncensored} ? 'Contains erotic scenes with optical censoring' : 'Contains erotic scenes', '♥';
+ txt_ !$r->{minage} ? 'All' : minage $r->{minage} if defined $r->{minage};
+ };
+ td_ class => 'tc3', sub {
+ platform_ $_ for $r->{platforms}->@*;
+ if(!$opt->{lang}) {
+ abbr_ class => "icon-lang-$_->{lang}".($_->{mtl}?' mtl':''), title => $LANGUAGE{$_->{lang}}{txt}, '' for $r->{titles}->@*;
+ }
+ abbr_ class => "icon-rt$r->{rtype}", title => $r->{rtype}, '';
+ };
+ td_ class => 'tc4', sub {
+ my $title =
+ $lang && defined $lang->{title} ? titleprefs_obj $lang->{lang}, [$lang] :
+ $lang ? titleprefs_obj $r->{olang}, [grep $_->{lang} eq $r->{olang}, $r->{titles}->@*]
+ : $r->{title};
+ a_ href => "/$r->{id}", tattr $title;
+ my $note = join ' ', $r->{official} ? () : 'unofficial', $mtl ? 'machine translation' : (), $r->{patch} ? 'patch' : ();
+ small_ " ($note)" if $note;
+ if ($r->{drm}->@*) {
+ my($free,$drm);
+ for my $d ($r->{drm}->@*) {
+ ${ (grep $d->{$_}, keys %DRM_PROPERTY)[0] ? \$drm : \$free } = 1
+ }
+ my $nfo = join "\n", map $_->{name}.($_->{notes} ? ' ('.bb_format($_->{notes}, text => 1).')' : ''), $r->{drm}->@*;
+ ($free && $drm ? \&span_ : $drm ? \&b_ : \&small_)->(title => $nfo, $free && !$drm ? ' (drm-free)' : ' (drm)');
+ }
+ };
+ td_ class => 'tc_icons', sub { icons_ $r };
+ td_ class => 'tc_prod', join ' & ', $r->{publisher} ? 'Pub' : (), $r->{developer} ? 'Dev' : () if $opt->{prod};
+ td_ class => 'tc5 elm_dd_left', sub {
+ elm_ 'UList.ReleaseEdit', $VNWeb::ULists::Elm::RLIST_STATUS, { rid => $r->{id}, uid => auth->uid, status => $r->{rlist_status}, empty => '--' } if auth;
+ };
+ td_ class => 'tc6', sub { release_extlinks_ $r, "$opt->{id}_$r->{id}" };
+ }
+}
+
+1;
diff --git a/lib/VNWeb/Releases/List.pm b/lib/VNWeb/Releases/List.pm
new file mode 100644
index 00000000..a6618dd1
--- /dev/null
+++ b/lib/VNWeb/Releases/List.pm
@@ -0,0 +1,92 @@
+package VNWeb::Releases::List;
+
+use VNDB::Func 'gtintype';
+use VNWeb::Prelude;
+use VNWeb::AdvSearch;
+use VNWeb::Filters;
+use VNWeb::Releases::Lib;
+
+
+sub listing_ {
+ my($opt, $list, $count) = @_;
+ my sub url { '?'.query_encode %$opt, @_ }
+ paginate_ \&url, $opt->{p}, [$count, 50], 't';
+ article_ class => 'browse', sub {
+ table_ class => 'stripe releases', sub {
+ thead_ sub { tr_ sub {
+ td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'released',$opt, \&url; debug_ $list; };
+ td_ class => 'tc2', sub { txt_ 'Rating'; sortable_ 'minage', $opt, \&url };
+ td_ class => 'tc3', '';
+ td_ class => 'tc4', sub { txt_ 'Title'; sortable_ 'title', $opt, \&url };
+ td_ class => 'tc_icons', '';
+ td_ class => 'tc5', '';
+ td_ class => 'tc6', '';
+ } };
+ my $ropt = { id => '' };
+ release_row_ $_, $ropt for @$list;
+ }
+ };
+ paginate_ \&url, $opt->{p}, [$count, 50], 'b';
+}
+
+
+TUWF::get qr{/r}, sub {
+ my $opt = tuwf->validate(get =>
+ q => { searchquery => 1 },
+ p => { upage => 1 },
+ f => { advsearch_err => 'r' },
+ s => { onerror => 'qscore', enum => [qw/qscore released minage title/] },
+ o => { onerror => 'a', enum => ['a','d'] },
+ fil => { onerror => '' },
+ )->data;
+ $opt->{s} = 'qscore' if $opt->{q} && tuwf->reqGet('sb');
+ $opt->{s} = 'title' if $opt->{s} eq 'qscore' && !$opt->{q};
+
+ # URL compatibility with old filters
+ if(!$opt->{f}->{query} && $opt->{fil}) {
+ my $q = eval {
+ tuwf->compile({ advsearch => 'r' })->validate(filter_release_adv filter_parse r => $opt->{fil})->data;
+ };
+ return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q;
+ }
+
+ $opt->{f} = advsearch_default 'r' if !$opt->{f}{query} && !defined tuwf->reqGet('f');
+
+ my $where = sql_and 'NOT r.hidden', $opt->{f}->sql_where();
+
+ my $time = time;
+ my($count, $list);
+ db_maytimeout {
+ $count = tuwf->dbVali('SELECT count(*) FROM releases r WHERE', sql_and $where, $opt->{q}->sql_where('r', 'r.id'));
+ $list = $count ? tuwf->dbPagei({results => 50, page => $opt->{p}}, '
+ SELECT r.id, r.patch, r.released, r.gtin, ', sql_extlinks(r => 'r.'), '
+ FROM', releasest, 'r', $opt->{q}->sql_join('r', 'r.id'), '
+ WHERE', $where, '
+ ORDER BY', sprintf {
+ qscore => '10 - sc.score %s, r.sorttitle %1$s',
+ title => 'r.sorttitle %s, r.released %1$s',
+ minage => 'r.minage %s, r.sorttitle %1$s, r.released %1$s',
+ released => 'r.released %s, r.sorttitle %1$s, r.id %1$s',
+ }->{$opt->{s}}, $opt->{o} eq 'a' ? 'ASC' : 'DESC'
+ ) : [];
+ } || (($count, $list) = (undef, []));
+
+ enrich_extlinks r => 0, $list;
+ enrich_release $list;
+ $time = time - $time;
+
+ framework_ title => 'Browse releases', sub {
+ article_ sub {
+ h1_ 'Browse releases';
+ form_ action => '/r', method => 'get', sub {
+ searchbox_ r => $opt->{q}//'';
+ input_ type => 'hidden', name => 'o', value => $opt->{o};
+ input_ type => 'hidden', name => 's', value => $opt->{s};
+ $opt->{f}->elm_($count, $time);
+ };
+ };
+ listing_ $opt, $list, $count if $count;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Releases/Page.pm b/lib/VNWeb/Releases/Page.pm
index d0c6d620..17befb1f 100644
--- a/lib/VNWeb/Releases/Page.pm
+++ b/lib/VNWeb/Releases/Page.pm
@@ -1,56 +1,135 @@
package VNWeb::Releases::Page;
use VNWeb::Prelude;
+use TUWF 'uri_escape';
+use VNWeb::Releases::Lib;
sub enrich_item {
my($r) = @_;
- enrich_merge pid => 'SELECT id AS pid, name, original FROM producers WHERE id IN', $r->{producers};
- enrich_merge vid => 'SELECT id AS vid, title, original FROM vn WHERE id IN', $r->{vn};
+ enrich_merge pid => sql('SELECT id AS pid, title, sorttitle FROM', producerst, 'p WHERE id IN'), $r->{producers};
+ enrich_merge vid => sql('SELECT id AS vid, title, sorttitle FROM', vnt, 'v WHERE id IN'), $r->{vn};
+ enrich_merge drm => sql('SELECT id AS drm, name,', sql_join(',', keys %DRM_PROPERTY), 'FROM drm WHERE id IN'), $r->{drm};
- $r->{lang} = [ sort map $_->{lang}, $r->{lang}->@* ];
+ $r->{titles} = [ sort { ($b->{lang} eq $r->{olang}) cmp ($a->{lang} eq $r->{olang}) || ($a->{mtl}?1:0) <=> ($b->{mtl}?1:0) || $a->{lang} cmp $b->{lang} } $r->{titles}->@* ];
$r->{platforms} = [ sort map $_->{platform}, $r->{platforms}->@* ];
- $r->{vn} = [ sort { $a->{title} cmp $b->{title} || $a->{vid} <=> $b->{vid} } $r->{vn}->@* ];
- $r->{producers} = [ sort { $a->{name} cmp $b->{name} || $a->{pid} <=> $b->{pid} } $r->{producers}->@* ];
+ $r->{vn} = [ sort { $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{vid}, $b->{vid}) } $r->{vn}->@* ];
+ $r->{producers} = [ sort { $a->{sorttitle} cmp $b->{sorttitle} || idcmp($a->{pid}, $b->{pid}) } $r->{producers}->@* ];
$r->{media} = [ sort { $a->{medium} cmp $b->{medium} || $a->{qty} <=> $b->{qty} } $r->{media}->@* ];
+ $r->{drm} = [ sort { !$a->{drm} || !$b->{drm} ? $b->{drm} <=> $a->{drm} : $a->{name} cmp $b->{name} } $r->{drm}->@* ];
+
+ $r->{resolution} = resolution $r;
}
sub _rev_ {
my($r) = @_;
- revision_ r => $r, \&enrich_item,
- [ vn => 'Relations', fmt => sub { a_ href => "/v$_->{vid}", title => $_->{original}||$_->{title}, $_->{title} } ],
- [ type => 'Type' ],
+ # The old ani_* fields are automatically inferred from the new ani_* fields
+ # for edits made after the fields were introduced. Hide the old fields for
+ # such revisions to remove some clutter.
+ my $newani = $r->{chid} > 1110896;
+ revision_ $r, \&enrich_item,
+ [ vn => 'Relations', fmt => sub {
+ abbr_ class => "icon-rt$_->{rtype}", title => $_->{rtype}, ' ';
+ a_ href => "/$_->{vid}", tattr $_;
+ txt_ " ($_->{rtype})" if $_->{rtype} ne 'complete';
+ } ],
+ [ official => 'Official', fmt => 'bool' ],
[ patch => 'Patch', fmt => 'bool' ],
[ freeware => 'Freeware', fmt => 'bool' ],
+ [ has_ero => 'Has ero', fmt => 'bool' ],
[ doujin => 'Doujin', fmt => 'bool' ],
[ uncensored => 'Uncensored', fmt => 'bool' ],
- [ title => 'Title (Romaji)' ],
- [ original => 'Original title' ],
- [ gtin => 'JAN/EAN/UPC', empty => 0 ],
+ [ gtin => 'JAN/EAN/UPC/ISBN',empty => 0 ],
[ catalog => 'Catalog number' ],
- [ lang => 'Languages', fmt => \%LANGUAGE ],
+ [ titles => 'Languages', txt => sub {
+ '['.$_->{lang}.($_->{mtl} ? ' machine translation' : '').'] '.($_->{title}//'').(length $_->{latin} ? " / $_->{latin}" : '')
+ }],
+ [ olang => 'Main title', fmt => \%LANGUAGE ],
[ released => 'Release date', fmt => sub { rdate_ $_ } ],
[ minage => 'Age rating', fmt => sub { txt_ minage $_ } ],
[ notes => 'Notes' ],
[ platforms => 'Platforms', fmt => \%PLATFORM ],
[ media => 'Media', fmt => sub { txt_ fmtmedia $_->{medium}, $_->{qty}; } ],
- [ resolution => 'Resolution', fmt => \%RESOLUTION ],
+ [ resolution => 'Resolution' ],
[ voiced => 'Voiced', fmt => \%VOICED ],
- [ ani_story => 'Story animation', fmt => \%ANIMATED ],
- [ ani_ero => 'Ero animation', fmt => \%ANIMATED ],
+ $newani ? () :
+ [ ani_story => 'Story animation', fmt => \%ANIMATED ],
+ [ ani_story_sp => 'Story animation/sprites',fmt => sub { txt_ fmtanimation $_, 'sprites' } ],
+ [ ani_story_cg => 'Story animation/cg', fmt => sub { txt_ fmtanimation $_, 'CGs' } ],
+ [ ani_cutscene => 'Cutscene animation', fmt => sub { txt_ fmtanimation $_, 'cutscenes' } ],
+ $newani ? () :
+ [ ani_ero => 'Ero animation', fmt => \%ANIMATED ],
+ [ ani_ero_sp => 'Ero animation/sprites',fmt=> sub { txt_ fmtanimation $_, 'sprites' } ],
+ [ ani_ero_cg => 'Ero animation/cg', fmt => sub { txt_ fmtanimation $_, 'CGs' } ],
+ [ ani_face => 'Lip/eye animation', fmt => 'bool' ],
+ [ ani_bg => 'Background effects', fmt => 'bool' ],
[ engine => 'Engine' ],
[ producers => 'Producers', fmt => sub {
- a_ href => "/p$_->{pid}", title => $_->{original}||$_->{name}, $_->{name};
+ a_ href => "/$_->{pid}", tattr $_;
txt_ ' (';
txt_ join ', ', $_->{developer} ? 'developer' : (), $_->{publisher} ? 'publisher' : ();
txt_ ')';
} ],
+ [ drm => 'DRM', fmt => sub {
+ a_ href => '/r/drm?s='.uri_escape($_->{name}), $_->{name};
+ txt_ " ($_->{notes})" if length $_->{notes};
+ } ],
revision_extlinks 'r'
}
+sub _infotable_animation_ {
+ my($r) = @_;
+ state @fields = qw|ani_story_sp ani_story_cg ani_cutscene ani_ero_sp ani_ero_cg ani_bg ani_face|;
+
+ return if !$r->{ani_story} && !$r->{ani_ero};
+
+ my sub txtc {
+ my($bool, $txt) = @_;
+ +(sub { $bool ? txt_ $txt : small_ $txt })
+ }
+
+ my sub sect {
+ my($val, $lbl) = @_;
+ defined $val ? txtc $val > 2, fmtanimation $val, $lbl : ();
+ }
+
+ my @story = !$r->{ani_story} ? () :
+ defined $r->{ani_story_sp} || defined $r->{ani_story_cg} || defined $r->{ani_cutscene} || defined $r->{ani_bg} || defined $r->{ani_face} ? (
+ defined $r->{ani_story_sp} ? sect $r->{ani_story_sp}, 'sprites' : (),
+ defined $r->{ani_story_cg} ? sect $r->{ani_story_cg}, 'CGs' : (),
+ defined $r->{ani_cutscene} ? sect $r->{ani_cutscene}, 'cutscenes' : (),
+ ) : txtc $r->{ani_story} > 1, $ANIMATED{$r->{ani_story}}{txt};
+
+ my @ero = !$r->{ani_ero} ? () :
+ defined $r->{ani_ero_sp} || defined $r->{ani_ero_cg} ? (
+ defined $r->{ani_ero_sp} ? sect $r->{ani_ero_sp}, 'sprites' : (),
+ defined $r->{ani_ero_cg} ? sect $r->{ani_ero_cg}, 'CGs' : (),
+ ) : txtc $r->{ani_ero} > 1, $ANIMATED{$r->{ani_ero}}{txt};
+
+ tr_ sub {
+ td_ 'Animation';
+ td_ sub {
+ dl_ sub {
+ if(@story) {
+ dt_ 'Story scenes';
+ dd_ sub { join_ \&br_, sub { $_->() }, @story };
+ }
+ if(@ero) {
+ dt_ 'Erotic scenes';
+ dd_ sub { join_ \&br_, sub { $_->() }, @ero };
+ }
+ } if @story || @ero;
+ join_ \&br_, sub { $_->() },
+ defined $r->{ani_bg} ? (txtc $r->{ani_bg}, $r->{ani_bg} ? 'Animated background effects' : 'No background effects') : (),
+ defined $r->{ani_face} ? (txtc $r->{ani_face}, $r->{ani_face} ? 'Lip and/or eye movement' : 'No facial animations') : ();
+ };
+ };
+}
+
+
sub _infotable_ {
my($r) = @_;
@@ -59,52 +138,53 @@ sub _infotable_ {
td_ class => 'key', 'Relation';
td_ sub {
join_ \&br_, sub {
- a_ href => "/v$_->{vid}", title => $_->{original}||$_->{title}, $_->{title};
+ abbr_ class => "icon-rt$_->{rtype}", title => $_->{rtype}, ' ';
+ a_ href => "/$_->{vid}", tattr $_;
+ txt_ " ($_->{rtype})" if $_->{rtype} ne 'complete';
}, $r->{vn}->@*
}
};
- tr_ sub {
- td_ 'Title';
- td_ $r->{title};
- };
-
- tr_ sub {
- td_ 'Original title';
- td_ lang_attr($r->{lang}), $r->{original};
- } if $r->{original};
-
- tr_ sub {
- td_ 'Type';
+ tr_ class => 'titles', sub {
+ td_ $r->{titles}->@* == 1 ? 'Title' : 'Titles';
td_ sub {
- abbr_ class => "icons rt$r->{type}", title => $r->{type}, ' ';
- txt_ ' '.$RELEASE_TYPE{$r->{type}};
- txt_ ', patch' if $r->{patch};
- }
+ table_ sub {
+ my($olang) = grep $_->{lang} eq $r->{olang}, $r->{titles}->@*;
+ tr_ class => 'nostripe title', sub {
+ td_ style => 'white-space: nowrap', sub {
+ abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, '';
+ };
+ td_ sub {
+ my $title = $_->{title}//$olang->{title};
+ span_ tlang($_->{lang}, $title), $title;
+ small_ ' (machine translation)' if $_->{mtl};
+ my $latin = defined $_->{title} ? $_->{latin} : $olang->{latin};
+ if(defined $latin) {
+ br_;
+ txt_ $latin;
+ }
+ }
+ } for $r->{titles}->@*;
+ };
+ };
};
tr_ sub {
- td_ 'Language';
- td_ sub {
- join_ \&br_, sub {
- abbr_ class => "icons lang $_", title => $LANGUAGE{$_}, ' ';
- txt_ ' '.$LANGUAGE{$_};
- }, $r->{lang}->@*;
- }
- };
+ td_ 'Type';
+ td_ !$r->{official} && $r->{patch} ? 'Unofficial patch' :
+ !$r->{official} ? 'Unofficial' : 'Patch';
+ } if !$r->{official} || $r->{patch};
tr_ sub {
td_ 'Publication';
- td_ join ', ',
- $r->{freeware} ? 'Freeware' : 'Non-free',
- $r->{patch} ? () : ($r->{doujin} ? 'doujin' : 'commercial');
+ td_ $r->{freeware} ? 'Freeware' : 'Non-free';
};
tr_ sub {
td_ 'Platform'.($r->{platforms}->@* == 1 ? '' : 's');
td_ sub {
join_ \&br_, sub {
- abbr_ class => "icons $_", title => $PLATFORM{$_}, ' ';
+ platform_ $_;
txt_ ' '.$PLATFORM{$_};
}, $r->{platforms}->@*;
}
@@ -119,32 +199,36 @@ sub _infotable_ {
tr_ sub {
td_ 'Resolution';
- td_ $RESOLUTION{$r->{resolution}}{txt};
- } if $r->{resolution} ne 'unknown';
+ td_ resolution $r;
+ } if $r->{reso_y};
tr_ sub {
td_ 'Voiced';
td_ $VOICED{$r->{voiced}}{txt};
} if $r->{voiced};
- tr_ sub {
- td_ 'Animation';
- td_ sub {
- join_ \&br_, sub { txt_ $_ },
- $r->{ani_story} ? "Story: $ANIMATED{$r->{ani_story}}{txt}" : (),
- $r->{ani_ero} ? "Ero scenes: $ANIMATED{$r->{ani_ero}}{txt}" : ();
- }
- } if $r->{ani_story} || $r->{ani_ero};
+ _infotable_animation_ $r;
tr_ sub {
td_ 'Engine';
td_ sub {
- # TODO: Should not rely on legacy VNDB::* functions!
- a_ href => '/r?fil='.VNDB::Util::Misc::fil_serialize({engine => $r->{engine}}), $r->{engine};
+ a_ href => '/r?f='.tuwf->compile({advsearch => 'r'})->validate(['engine', '=', $r->{engine}])->data->query_encode, $r->{engine};
}
} if length $r->{engine};
tr_ sub {
+ td_ 'DRM';
+ td_ sub { join_ \&br_, sub {
+ my $d = $_;
+ my @prop = grep $d->{$_}, keys %DRM_PROPERTY;
+ abbr_ class => "icon-drm-$_", title => $DRM_PROPERTY{$_}, '' for @prop;
+ abbr_ class => 'icon-drm-free', title => 'DRM-free', '' if !@prop;
+ a_ href => '/r/drm?s='.uri_escape($d->{name}), $d->{name};
+ lit_ ' ('.bb_format($d->{notes}, inline => 1).')' if length $d->{notes};
+ }, $r->{drm}->@* };
+ } if $r->{drm}->@*;
+
+ tr_ sub {
td_ 'Released';
td_ sub { rdate_ $r->{released} };
};
@@ -152,12 +236,12 @@ sub _infotable_ {
tr_ sub {
td_ 'Age rating';
td_ minage $r->{minage};
- } if $r->{minage} >= 0;
+ } if defined $r->{minage};
tr_ sub {
- td_ 'Censoring';
- td_ $r->{uncensored} ? 'No optical censoring (e.g. mosaics)' : 'May include optical censoring (e.g. mosaics)';
- } if $r->{minage} == 18;
+ td_ 'Erotic content';
+ td_ $r->{uncensored} ? 'Contains uncensored erotic scenes' : defined $r->{uncensored} ? 'Contains erotic scenes with optical censoring' : 'Contains erotic scenes',
+ } if $r->{has_ero};
for my $t (qw|developer publisher|) {
my @prod = grep $_->{$t}, @{$r->{producers}};
@@ -165,7 +249,7 @@ sub _infotable_ {
td_ ucfirst($t).(@prod == 1 ? '' : 's');
td_ sub {
join_ \&br_, sub {
- a_ href => "/p$_->{pid}", title => $_->{original}||$_->{name}, $_->{name};
+ a_ href => "/$_->{pid}", tattr $_;
}, @prod
}
} if @prod;
@@ -184,7 +268,7 @@ sub _infotable_ {
tr_ sub {
td_ 'Links';
td_ sub {
- join_ ', ', sub { a_ href => $_->[1], $_->[0] }, $r->{extlinks}->@*;
+ join_ ', ', sub { a_ href => $_->{url2}, $_->{label} }, $r->{extlinks}->@*;
}
} if $r->{extlinks}->@*;
@@ -193,7 +277,7 @@ sub _infotable_ {
td_ sub {
div_ class => 'elm_dd_input', style => 'width: 150px', sub {
my $d = tuwf->dbVali('SELECT status FROM rlists WHERE', { rid => $r->{id}, uid => auth->uid });
- elm_ 'UList.ReleaseEdit', $VNWeb::User::Lists::RLIST_STATUS, { rid => $r->{id}, uid => auth->uid, status => $d };
+ elm_ 'UList.ReleaseEdit', $VNWeb::ULists::Elm::RLIST_STATUS, { rid => $r->{id}, uid => auth->uid, status => $d, empty => 'not on your list' };
}
};
} if auth;
@@ -202,24 +286,25 @@ sub _infotable_ {
TUWF::get qr{/$RE{rrev}} => sub {
- my $r = db_entry r => tuwf->capture('id'), tuwf->capture('rev');
+ my $r = db_entry tuwf->captures('id','rev');
return tuwf->resNotFound if !$r;
+ $r->{title} = titleprefs_obj $r->{olang}, $r->{titles};
enrich_item $r;
- enrich_extlinks r => $r;
+ enrich_extlinks r => 0, $r;
- framework_ title => $r->{title}, index => !tuwf->capture('rev'), type => 'r', dbobj => $r, hiddenmsg => 1,
+ framework_ title => $r->{title}[1], index => !tuwf->capture('rev'), dbobj => $r, hiddenmsg => 1,
og => {
- description => bb2text $r->{notes}
+ description => bb_format $r->{notes}, text => 1
},
sub {
_rev_ $r if tuwf->capture('rev');
- div_ class => 'mainbox release', sub {
- itemmsg_ r => $r;
- h1_ sub { txt_ $r->{title}; debug_ $r };
- h2_ class => 'alttitle', lang_attr($r->{lang}), $r->{original} if length $r->{original};
+ article_ class => 'release', sub {
+ itemmsg_ $r;
+ h1_ tlang($r->{title}[0], $r->{title}[1]), $r->{title}[1];
+ h2_ class => 'alttitle', tlang(@{$r->{title}}[2,3]), $r->{title}[3] if $r->{title}[3] && $r->{title}[3] ne $r->{title}[1];
_infotable_ $r;
- p_ class => 'description', sub { lit_ bb2html $r->{notes} } if $r->{notes};
+ div_ class => 'description', sub { lit_ bb_format $r->{notes} } if $r->{notes};
};
};
};
diff --git a/lib/VNWeb/Releases/VNTab.pm b/lib/VNWeb/Releases/VNTab.pm
new file mode 100644
index 00000000..33df7207
--- /dev/null
+++ b/lib/VNWeb/Releases/VNTab.pm
@@ -0,0 +1,263 @@
+# TODO: This code is kind of obsolete. It's not been updated with recently
+# added release fields and all fields are already displayed more concisely in
+# the releases box on the main VN page. The filtering and display options on
+# this page can still be useful, though, so need to figure out what to do with
+# this in the future.
+# Maybe update/modernize this page with the latest fields and icons and
+# shorten/simplify the long list of releases on the main VN page? Or expand the
+# list on VN pages with filters and display options?
+
+package VNWeb::Releases::VNTab;
+
+use VNWeb::Prelude;
+use VNWeb::Releases::Lib 'enrich_release';
+
+
+# Description of each column, field:
+# id: Identifier used in URLs
+# sort_field: Name of the field when sorting
+# sort_sql: ORDER BY clause when sorting
+# column_string: String to use as column header
+# column_width: Maximum width (in pixels) of the column in 'restricted width' mode
+# button_string: String to use for the hide/unhide button
+# na_for_patch: When the field is N/A for patch releases
+# default: Set when it's visible by default
+# has_data: Subroutine called with a release object, should return true if the release has data for the column
+# draw: Subroutine called with a release object, should draw its column contents
+my @rel_cols = (
+ { # Title
+ id => 'tit',
+ sort_field => 'title',
+ sort_sql => 'r.sorttitle %s, r.released %1$s',
+ column_string => 'Title',
+ draw => sub { a_ href => "/$_[0]{id}", tattr $_[0] },
+ }, { # Type
+ id => 'typ',
+ sort_field => 'type',
+ sort_sql => 'r.patch %s, rv.rtype %1$s, r.released %1$s, r.sorttitle %1$s',
+ button_string => 'Type',
+ default => 1,
+ draw => sub { abbr_ class => "icon-rt$_[0]{rtype}", title => $_[0]{rtype}, ''; txt_ '(patch)' if $_[0]{patch} },
+ }, { # Languages
+ id => 'lan',
+ button_string => 'Language',
+ default => 1,
+ draw => sub { join_ \&br_, sub { abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, ''; }, $_[0]{titles}->@* },
+ }, { # Publication
+ id => 'pub',
+ sort_field => 'publication',
+ sort_sql => 'r.freeware %1$s, r.patch %1$s, r.released %1$s, r.sorttitle %1$s',
+ column_string => 'Publication',
+ column_width => 70,
+ button_string => 'Publication',
+ default => 1,
+ draw => sub { txt_ $_[0]{freeware} ? 'Freeware' : 'Non-free' },
+ }, { # Platforms
+ id => 'pla',
+ button_string => 'Platforms',
+ default => 1,
+ has_data => sub { !!@{$_[0]{platforms}} },
+ draw => sub {
+ join_ \&br_, sub { platform_ $_ }, $_[0]{platforms}->@*;
+ txt_ 'Unknown' if !$_[0]{platforms}->@*;
+ },
+ }, { # Media
+ id => 'med',
+ column_string => 'Media',
+ button_string => 'Media',
+ has_data => sub { !!@{$_[0]{media}} },
+ draw => sub {
+ join_ \&br_, sub { txt_ fmtmedia $_->{medium}, $_->{qty} }, $_[0]{media}->@*;
+ txt_ 'Unknown' if !$_[0]{media}->@*;
+ },
+ }, { # Resolution
+ id => 'res',
+ sort_field => 'resolution',
+ sort_sql => 'r.reso_x %s, r.reso_y %1$s, r.patch %1$s, r.released %1$s, r.sorttitle %1$s',
+ column_string => 'Resolution',
+ button_string => 'Resolution',
+ na_for_patch => 1,
+ default => 1,
+ has_data => sub { !!$_[0]{reso_y} },
+ draw => sub { txt_ resolution($_[0]) || 'Unknown' },
+ }, { # Voiced
+ id => 'voi',
+ sort_field => 'voiced',
+ sort_sql => 'r.voiced %s, r.patch %1$s, r.released %1$s, r.sorttitle %1$s',
+ column_string => 'Voiced',
+ column_width => 70,
+ button_string => 'Voiced',
+ na_for_patch => 1,
+ default => 1,
+ has_data => sub { !!$_[0]{voiced} },
+ draw => sub { txt_ $VOICED{$_[0]{voiced}}{txt} },
+ }, { # Animation
+ id => 'ani',
+ sort_field => 'ani_ero',
+ sort_sql => 'r.ani_story %s, r.ani_ero %1$s, r.patch %1$s, r.released %1$s, r.sorttitle %1$s',
+ column_string => 'Animation',
+ column_width => 110,
+ button_string => 'Animation',
+ na_for_patch => '1',
+ has_data => sub { !!($_[0]{ani_story} || $_[0]{ani_ero}) },
+ draw => sub {
+ txt_ join ', ',
+ $_[0]{ani_story} ? "Story: $ANIMATED{$_[0]{ani_story}}{txt}" :(),
+ $_[0]{ani_ero} ? "Ero scenes: $ANIMATED{$_[0]{ani_ero}}{txt}":();
+ txt_ 'Unknown' if !$_[0]{ani_story} && !$_[0]{ani_ero};
+ },
+ }, { # Released
+ id => 'rel',
+ sort_field => 'released',
+ sort_sql => 'r.released %s, r.id %1$s',
+ column_string => 'Released',
+ button_string => 'Released',
+ default => 1,
+ draw => sub { rdate_ $_[0]{released} },
+ }, { # Age rating
+ id => 'min',
+ sort_field => 'minage',
+ sort_sql => 'r.minage %s, r.released %1$s, r.sorttitle %1$s',
+ button_string => 'Age rating',
+ default => 1,
+ has_data => sub { defined $_[0]{minage} },
+ draw => sub { txt_ minage $_[0]{minage} },
+ }, { # Notes
+ id => 'not',
+ sort_field => 'notes',
+ sort_sql => 'r.notes %s, r.released %1$s, r.sorttitle %1$s',
+ column_string => 'Notes',
+ column_width => 400,
+ button_string => 'Notes',
+ default => 1,
+ has_data => sub { !!$_[0]{notes} },
+ draw => sub { lit_ bb_format $_[0]{notes} },
+ }
+);
+
+
+
+sub buttons_ {
+ my($opt, $url, $r) = @_;
+
+ # Column visibility
+ p_ class => 'browseopts', sub {
+ a_ href => $url->($_->{id}, $opt->{$_->{id}} ? 0 : 1), $opt->{$_->{id}} ? (class => 'optselected') : (), $_->{button_string}
+ for grep $_->{button_string}, @rel_cols;
+ };
+
+ # Misc options
+ my $all_selected = !grep $_->{button_string} && !$opt->{$_->{id}}, @rel_cols;
+ my $all_unselected = !grep $_->{button_string} && $opt->{$_->{id}}, @rel_cols;
+ my $all_url = sub { $url->(map +($_->{id},$_[0]), grep $_->{button_string}, @rel_cols); };
+ p_ class => 'browseopts', sub {
+ a_ href => $all_url->(1), $all_selected ? (class => 'optselected') : (), 'All on';
+ a_ href => $all_url->(0), $all_unselected ? (class => 'optselected') : (), 'All off';
+ a_ href => $url->('cw', $opt->{cw} ? 0 : 1), $opt->{cw} ? (class => 'optselected') : (), 'Restrict column width';
+ };
+
+ my sub pl {
+ my($option, $icon, @lst) = @_;
+ my %opts = map +($_,1), @lst;
+ return if !keys %opts;
+ p_ class => 'browseopts', sub {
+ a_ href => $url->($option, $_), $_ eq $opt->{$option} ? (class => 'optselected') : (), sub {
+ $_ eq 'all' ? txt_ 'All' : $icon->($_);
+ } for ('all', sort keys %opts);
+ }
+ };
+ pl 'os', \&platform_, map $_->{platforms}->@*, @$r if $opt->{pla};
+ pl 'lang', sub { abbr_ class => "icon-lang-$_[0]", title => $LANGUAGE{$_[0]}{txt}, '' }, map $_->{lang}, map $_->{titles}->@*, @$r if $opt->{lan};
+}
+
+
+sub listing_ {
+ my($opt, $url, $r) = @_;
+
+ # Apply language and platform filters
+ my @r = grep +
+ ($opt->{os} eq 'all' || ($_->{platforms} && grep $_ eq $opt->{os}, $_->{platforms}->@*)) &&
+ ($opt->{lang} eq 'all' || ($_->{titles} && grep $_ eq $opt->{lang}, map $_->{lang}, $_->{titles}->@*)), @$r;
+
+ # Figure out which columns to display
+ my @col;
+ for my $c (@rel_cols) {
+ next if $c->{button_string} && !$opt->{$c->{id}}; # Hidden by settings
+ push @col, $c if !@r || !$c->{has_data} || grep $c->{has_data}->($_), @r; # Must have relevant data
+ }
+
+ article_ class => 'releases_compare', sub {
+ table_ sub {
+ thead_ sub { tr_ sub {
+ td_ class => 'key', sub {
+ txt_ $_->{column_string} if $_->{column_string};
+ sortable_ $_->{sort_field}, $opt, $url if $_->{sort_field};
+ } for @col;
+ } };
+ tr_ sub {
+ my $r = $_;
+ # Combine "N/A for patches" columns
+ my $cspan = 1;
+ for my $c (0..$#col) {
+ if($r->{patch} && $col[$c]{na_for_patch} && $c < $#col && $col[$c+1]{na_for_patch}) {
+ $cspan++;
+ next;
+ }
+ td_ $cspan > 1 ? (colspan => $cspan) : (),
+ $col[$c]{column_width} && $opt->{cw} ? (style => "max-width: $col[$c]{column_width}px") : ();
+ if($r->{patch} && $col[$c]{na_for_patch}) {
+ txt_ 'NA for patches';
+ } else {
+ $col[$c]{draw}->($r);
+ }
+ end_;
+ $cspan = 1;
+ }
+ } for @r;
+ }
+ }
+}
+
+
+TUWF::get qr{/$RE{vid}/releases} => sub {
+ my $v = dbobj tuwf->capture('id');
+ return tuwf->resNotFound if !$v->{id};
+
+ my $opt = tuwf->validate(get =>
+ cw => { anybool => 1 },
+ o => { onerror => 'a', enum => [0,1,'d','a'] },
+ s => { onerror => 'released', enum => [ map $_->{sort_field}, grep $_->{sort_field}, @rel_cols ]},
+ os => { onerror => 'all', enum => [ 'all', keys %PLATFORM ] },
+ lang => { onerror => 'all', enum => [ 'all', keys %LANGUAGE ] },
+ map +($_->{id}, { anybool => 1, default => $_->{default} }), grep $_->{button_string}, @rel_cols
+ )->data;
+ # Compat with old URLs
+ $opt->{o} = 'a' if $opt->{o} eq 0;
+ $opt->{o} = 'd' if $opt->{o} eq 1;
+
+ my $r = tuwf->dbAlli('
+ SELECT r.id, rv.rtype, r.patch, r.released, r.gtin
+ FROM', releasest, 'r
+ JOIN releases_vn rv ON rv.id = r.id
+ WHERE NOT hidden AND rv.vid =', \$v->{id}, '
+ ORDER BY', sprintf(+(grep $opt->{s} eq ($_->{sort_field}//''), @rel_cols)[0]{sort_sql}, $opt->{o} eq 'a' ? 'ASC' : 'DESC')
+ );
+ enrich_release $r;
+
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ framework_ title => "Releases for $v->{title}[1]", dbobj => $v, tab => 'releases', sub {
+ article_ class => 'releases_compare', sub {
+ h1_ "Releases for $v->{title}[1]";
+ if(!@$r) {
+ p_ 'We don\'t have any information about releases of this visual novel yet...';
+ } else {
+ buttons_($opt, \&url, $r);
+ }
+ };
+ listing_ $opt, \&url, $r if @$r;
+ };
+};
+
+
+1;
diff --git a/lib/VNWeb/Reviews/Edit.pm b/lib/VNWeb/Reviews/Edit.pm
new file mode 100644
index 00000000..925206d2
--- /dev/null
+++ b/lib/VNWeb/Reviews/Edit.pm
@@ -0,0 +1,122 @@
+package VNWeb::Reviews::Edit;
+
+use VNWeb::Prelude;
+use VNWeb::Releases::Lib;
+
+
+my $FORM = {
+ id => { vndbid => 'w', default => undef },
+ vid => { vndbid => 'v' },
+ vntitle => { _when => 'out' },
+ rid => { vndbid => 'r', default => undef },
+ spoiler => { anybool => 1 },
+ isfull => { anybool => 1 },
+ modnote => { maxlength => 1024, default => '' },
+ text => { maxlength => 100_000, default => '' },
+ locked => { anybool => 1 },
+
+ mod => { _when => 'out', anybool => 1 },
+ releases => { _when => 'out', $VNWeb::Elm::apis{Releases}[0]->%* },
+};
+
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_OUT = form_compile out => $FORM;
+
+
+sub throttled { tuwf->dbVali('SELECT COUNT(*) FROM reviews WHERE uid =', \auth->uid, 'AND date > date_trunc(\'day\', NOW())') >= 5 }
+
+sub releases {
+ my($vid) = @_;
+ my $today = strftime '%Y%m%d', gmtime;
+ [ grep $_->{released} <= $today, releases_by_vn($vid)->@* ]
+}
+
+
+TUWF::get qr{/$RE{vid}/addreview}, sub {
+ my $v = tuwf->dbRowi('SELECT id, title[1+1] FROM', vnt, 'v WHERE NOT hidden AND id =', \tuwf->capture('id'));
+ return tuwf->resNotFound if !$v->{id};
+
+ my $id = tuwf->dbVali('SELECT id FROM reviews WHERE vid =', \$v->{id}, 'AND uid =', \auth->uid);
+ return tuwf->resRedirect("/$id/edit") if $id;
+ return tuwf->resDenied if !can_edit w => {};
+
+ framework_ title => "Write review for $v->{title}", sub {
+ if(throttled) {
+ article_ sub {
+ h1_ 'Throttled';
+ p_ 'You can only submit 5 reviews per day. Check back later!';
+ };
+ } else {
+ elm_ 'Reviews.Edit' => $FORM_OUT, { elm_empty($FORM_OUT)->%*,
+ vid => $v->{id}, vntitle => $v->{title}, releases => releases($v->{id}), mod => auth->permBoardmod()
+ };
+ }
+ };
+};
+
+
+TUWF::get qr{/$RE{wid}/edit}, sub {
+ my $e = tuwf->dbRowi(
+ 'SELECT r.id, r.uid AS user_id, r.vid, r.rid, r.isfull, r.modnote, r.text, r.spoiler, r.locked, v.title[1+1] AS vntitle
+ FROM reviews r JOIN', vnt, 'v ON v.id = r.vid WHERE r.id =', \tuwf->capture('id')
+ );
+ return tuwf->resNotFound if !$e->{id};
+ return tuwf->resDenied if !can_edit w => $e;
+
+ $e->{releases} = releases $e->{vid};
+ $e->{mod} = auth->permBoardmod;
+ framework_ title => "Edit review for $e->{vntitle}", dbobj => $e, tab => 'edit', sub {
+ elm_ 'Reviews.Edit' => $FORM_OUT, $e;
+ };
+};
+
+
+
+elm_api ReviewsEdit => $FORM_OUT, $FORM_IN, sub {
+ my($data) = @_;
+ my $id = delete $data->{id};
+
+ my $review = $id ? tuwf->dbRowi('SELECT id, locked, modnote, text, uid AS user_id FROM reviews WHERE id =', \$id) : {};
+ return tuwf->resNotFound if $id && !$review->{id};
+ return elm_Unauth if !can_edit w => $review;
+
+ if(!auth->permBoardmod) {
+ $data->{locked} = $review->{locked}||0;
+ $data->{modnote} = $review->{modnote}||'';
+ }
+
+ validate_dbid 'SELECT id FROM vn WHERE id IN', $data->{vid};
+ validate_dbid 'SELECT id FROM releases WHERE id IN', $data->{rid} if defined $data->{rid};
+
+ die "Review too long" if !$data->{isfull} && length $data->{text} > 800;
+ $data->{text} = bb_subst_links $data->{text} if $data->{isfull};
+
+ if($id) {
+ $data->{lastmod} = sql 'NOW()' if $review->{text} ne $data->{text};
+ tuwf->dbExeci('UPDATE reviews SET', $data, 'WHERE id =', \$id) if $id;
+ auth->audit($review->{user_id}, 'review edit', "edited $review->{id}") if auth->uid ne $review->{user_id};
+
+ } else {
+ return elm_Unauth if tuwf->dbVali('SELECT 1 FROM reviews WHERE vid =', \$data->{vid}, 'AND uid =', \auth->uid);
+ return elm_Unauth if throttled;
+ $data->{uid} = auth->uid;
+ $id = tuwf->dbVali('INSERT INTO reviews', $data, 'RETURNING id');
+ }
+
+ elm_Redirect "/$id".($data->{uid}?'?submit=1':'')
+};
+
+
+elm_api ReviewsDelete => undef, { id => { vndbid => 'w' } }, sub {
+ my($data) = @_;
+ my $review = tuwf->dbRowi('SELECT id, uid AS user_id FROM reviews WHERE id =', \$data->{id});
+ return tuwf->resNotFound if !$review->{id};
+ return elm_Unauth if !can_edit w => $review;
+ auth->audit($review->{user_id}, 'review delete', "deleted $review->{id}");
+ tuwf->dbExeci('DELETE FROM notifications WHERE iid =', \$data->{id});
+ tuwf->dbExeci('DELETE FROM reviews WHERE id =', \$data->{id});
+ elm_Success
+};
+
+
+1;
diff --git a/lib/VNWeb/Reviews/JS.pm b/lib/VNWeb/Reviews/JS.pm
new file mode 100644
index 00000000..32489a33
--- /dev/null
+++ b/lib/VNWeb/Reviews/JS.pm
@@ -0,0 +1,24 @@
+package VNWeb::Reviews::JS;
+
+use VNWeb::Prelude;
+
+our $VOTE = form_compile any => {
+ id => { vndbid => 'w' },
+ my => { undefbool => 1 },
+ overrule => { anybool => 1 },
+ mod => { anybool => 1 },
+};
+
+js_api ReviewsVote => $VOTE, sub {
+ my($data) = @_;
+ my %id = (auth ? (uid => auth->uid) : (ip => norm_ip tuwf->reqIP), id => $data->{id});
+ my %val = (vote => $data->{my}, overrule => auth->permBoardmod ? $data->{overrule} : 0, date => sql 'NOW()');
+ tuwf->dbExeci(
+ defined $data->{my}
+ ? sql 'INSERT INTO reviews_votes', {%id,%val}, 'ON CONFLICT (id,', auth ? 'uid' : 'ip', ') DO UPDATE SET', \%val
+ : sql 'DELETE FROM reviews_votes WHERE', \%id
+ );
+ +{}
+};
+
+1;
diff --git a/lib/VNWeb/Reviews/Lib.pm b/lib/VNWeb/Reviews/Lib.pm
new file mode 100644
index 00000000..8ea54a09
--- /dev/null
+++ b/lib/VNWeb/Reviews/Lib.pm
@@ -0,0 +1,30 @@
+package VNWeb::Reviews::Lib;
+
+use VNWeb::Prelude;
+use Exporter 'import';
+our @EXPORT = qw/reviews_helpfulness reviews_vote_ reviews_format/;
+
+sub reviews_helpfulness {
+ my($w) = @_;
+ my ($uup, $aup, $udown, $adown) = (floor($w->{c_up}/100), $w->{c_up}%100, floor($w->{c_down}/100), $w->{c_down}%100);
+ return sprintf '%.0f', max 0, ($uup + 0.3*$aup) - ($udown + 0.3*$adown);
+}
+
+sub reviews_vote_ {
+ my($w) = @_;
+ span_ sub {
+ span_ widget(ReviewsVote => $VNWeb::Reviews::JS::VOTE, {%$w, mod => auth->permBoardmod||0}), ''
+ if !config->{read_only} && ($w->{can} || auth->permBoardmod);
+ my $p = reviews_helpfulness $w;
+ small_ sprintf ' %d point%s', $p, $p == 1 ? '' : 's';
+ small_ sprintf ' %.2f/%.2f', $w->{c_up}/100, $w->{c_down}/100 if auth->permBoardmod;
+ }
+}
+
+# Mini-reviews don't expand vndbids on submission, so they need an extra bb_subst_links() pass.
+sub reviews_format {
+ my($w, @opt) = @_;
+ bb_format($w->{isfull} ? $w->{text} : bb_subst_links($w->{text}), @opt);
+}
+
+1;
diff --git a/lib/VNWeb/Reviews/List.pm b/lib/VNWeb/Reviews/List.pm
new file mode 100644
index 00000000..84985de0
--- /dev/null
+++ b/lib/VNWeb/Reviews/List.pm
@@ -0,0 +1,87 @@
+package VNWeb::Reviews::List;
+
+use VNWeb::Prelude;
+
+
+sub tablebox_ {
+ my($opt, $lst, $count) = @_;
+
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ paginate_ \&url, $opt->{p}, [$count, 50], 't';
+ article_ class => 'browse reviewlist', sub {
+ table_ class => 'stripe', sub {
+ thead_ sub { tr_ sub {
+ td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'id', $opt, \&url; debug_ $lst };
+ td_ class => 'tc2', 'By';
+ td_ class => 'tc3', 'Vote';
+ td_ class => 'tc4', 'Type';
+ td_ class => 'tc5', 'Review';
+ td_ class => 'tc6', sub { txt_ 'Score*'; sortable_ 'rating', $opt, \&url } if auth->isMod;
+ td_ class => 'tc7', 'C#';
+ td_ class => 'tc8', sub { txt_ 'Last comment'; sortable_ 'lastpost', $opt, \&url };
+ } };
+ tr_ sub {
+ td_ class => 'tc1', fmtdate $_->{date}, 'compact';
+ td_ class => 'tc2', sub { user_ $_ };
+ td_ class => 'tc3', fmtvote $_->{vote};
+ td_ class => 'tc4', $_->{isfull} ? 'Full' : 'Mini';
+ td_ class => 'tc5', sub { a_ href => "/$_->{id}", tattr $_; small_ ' (flagged)' if $_->{c_flagged} };
+ td_ class => 'tc6', sprintf '👍 %.2f 👎 %.2f', $_->{c_up}/100, $_->{c_down}/100 if auth->isMod;
+ td_ class => 'tc7', $_->{c_count};
+ td_ class => 'tc8', $_->{c_lastnum} ? sub {
+ user_ $_, 'lu_';
+ txt_ ' @ ';
+ a_ href => "/$_->{id}.$_->{c_lastnum}#last", fmtdate $_->{ldate}, 'full';
+ } : '';
+ } for @$lst;
+ };
+ };
+ paginate_ \&url, $opt->{p}, [$count, 50], 'b';
+}
+
+
+TUWF::get qr{/w}, sub {
+ my $opt = tuwf->validate(get =>
+ p => { page => 1 },
+ s => { onerror => 'id', enum => [qw[id lastpost rating]] },
+ o => { onerror => 'd', enum => [qw[a d]] },
+ u => { onerror => 0, vndbid => 'u' },
+ )->data;
+ $opt->{s} = 'id' if $opt->{s} eq 'rating' && !auth->isMod;
+
+ my $u = $opt->{u} && tuwf->dbRowi('SELECT id, ', sql_user(), 'FROM users u WHERE id =', \$opt->{u});
+ return tuwf->resNotFound if $u && (!$u->{id} || (!$u->{user_name} && !auth->isMod));
+
+ my $where = sql_and
+ $u ? sql 'w.uid =', \$u->{id} : (),
+ auth->isMod ? () : 'NOT w.c_flagged';
+ my $count = tuwf->dbVali('SELECT COUNT(*) FROM reviews w WHERE', $where);
+ my $lst = tuwf->dbPagei({results => 50, page => $opt->{p}}, '
+ SELECT w.id, w.vid, w.isfull, w.c_up, w.c_down, w.c_flagged, w.c_count, w.c_lastnum, v.title, uv.vote
+ , ', sql_user(), ',', sql_totime('w.date'), 'as date
+ , ', sql_user('wpu','lu_'), ',', sql_totime('wp.date'), 'as ldate
+ FROM reviews w
+ JOIN', vnt, 'v ON v.id = w.vid
+ LEFT JOIN users u ON u.id = w.uid
+ LEFT JOIN reviews_posts wp ON w.id = wp.id AND w.c_lastnum = wp.num
+ LEFT JOIN users wpu ON wpu.id = wp.uid
+ LEFT JOIN ulist_vns uv ON uv.uid = w.uid AND uv.vid = w.vid
+ WHERE', $where, '
+ ORDER BY', {id => 'w.id', lastpost => 'wp.date', rating => 'w.c_up-w.c_down'}->{$opt->{s}}, {a=>'ASC',d=>'DESC'}->{$opt->{o}}, 'NULLS LAST'
+ );
+
+ my $title = $u ? 'Reviews by '.user_displayname($u) : 'Browse reviews';
+ framework_ title => $title, $u ? (dbobj => $u, tab => 'reviews') : (), sub {
+ article_ sub {
+ h1_ $title;
+ if($u && !$count) {
+ p_ +(auth && $u->{id} eq auth->uid ? 'You have' : user_displayname($u).' has').' not submitted any reviews yet.';
+ }
+ p_ 'Note: The score column is only visible to moderators.' if $count && auth->isMod;
+ };
+ tablebox_ $opt, $lst, $count if $count;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Reviews/Page.pm b/lib/VNWeb/Reviews/Page.pm
new file mode 100644
index 00000000..3f58905b
--- /dev/null
+++ b/lib/VNWeb/Reviews/Page.pm
@@ -0,0 +1,166 @@
+package VNWeb::Reviews::Page;
+
+use VNWeb::Prelude;
+use VNWeb::Releases::Lib;
+use VNWeb::Reviews::Lib;
+
+
+my $COMMENT = form_compile any => {
+ id => { vndbid => 'w' },
+ msg => { maxlength => 32768 }
+};
+
+js_api ReviewComment => $COMMENT, sub {
+ my($data) = @_;
+ my $w = tuwf->dbRowi('SELECT id, locked FROM reviews WHERE id =', \$data->{id});
+ return tuwf->resNotFound if !$w->{id};
+ return tuwf->resDenied if !can_edit t => $w;
+
+ my $num = sql 'COALESCE((SELECT MAX(num)+1 FROM reviews_posts WHERE id =', \$data->{id}, '),1)';
+ my $msg = bb_subst_links $data->{msg};
+ $num = tuwf->dbVali('INSERT INTO reviews_posts', { id => $w->{id}, num => $num, uid => auth->uid, msg => $msg }, 'RETURNING num');
+ +{ _redir => "/$w->{id}.$num#last" };
+};
+
+
+
+sub review_ {
+ my($w) = @_;
+
+ input_ type => 'checkbox', class => 'hidden', id => 'reviewspoil', (auth->pref('spoilers')||0) == 2 ? ('checked', 'checked') : (), undef;
+ my @spoil = $w->{spoiler} ? (class => 'reviewspoil') : ();
+ table_ class => 'fullreview', sub {
+ tr_ sub {
+ td_ 'Subject';
+ td_ sub {
+ a_ href => "/$w->{vid}", tattr $w;
+ if($w->{rid}) {
+ br_;
+ platform_ $_ for $w->{platforms}->@*;
+ abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for $w->{lang}->@*;
+ abbr_ class => "icon-rt$w->{rtype}", title => $w->{rtype}, '' if $w->{rtype};
+ a_ href => "/$w->{rid}", tattr $w->{rtitle};
+ b_ ' (different visual novel)' if !$w->{rtype};
+ }
+ };
+ };
+ tr_ sub {
+ td_ 'By';
+ td_ sub {
+ span_ style => 'float: right; padding-left: 25px; text-align: right', sub {
+ txt_ 'Helpfulness: '.reviews_helpfulness($w);
+ br_;
+ strong_ 'Vote: '.fmtvote($w->{vote}) if $w->{vote};
+ };
+ user_ $w;
+ my($date, $lastmod) = map $_&&fmtdate($_,'compact'), $w->@{'date', 'lastmod'};
+ txt_ " on $date";
+ small_ " last updated on $lastmod" if $lastmod && $date ne $lastmod;
+ br_ if $w->{c_flagged} || $w->{locked} || ($w->{spoiler} && (auth->pref('spoilers')||0) == 2);
+ if($w->{c_flagged}) {
+ br_;
+ small_ 'Flagged: this review is below the voting threshold and not visible on the VN page.';
+ }
+ if($w->{locked}) {
+ br_;
+ small_ 'Locked: commenting on this review has been disabled.';
+ }
+ if($w->{spoiler} && (auth->pref('spoilers')||0) == 2) {
+ br_;
+ strong_ 'This review contains spoilers.';
+ }
+ }
+ };
+ tr_ sub {
+ td_ 'Moderator note';
+ td_ sub { lit_ bb_format $w->{modnote} };
+ } if $w->{modnote};
+ tr_ class => 'reviewnotspoil', sub {
+ td_ '';
+ td_ sub {
+ label_ class => 'fake_link', for => 'reviewspoil', 'This review contains spoilers, click to view.';
+ };
+ } if $w->{spoiler};
+ tr_ @spoil, sub {
+ td_ 'Review';
+ td_ sub { lit_ reviews_format $w }
+ };
+ tr_ @spoil, sub {
+ td_ '';
+ td_ style => 'text-align: right', sub {
+ reviews_vote_ $w;
+ };
+ };
+ }
+}
+
+
+TUWF::get qr{/$RE{wid}(?:(?<sep>[\./])$RE{num})?}, sub {
+ my($id, $sep, $num) = (tuwf->capture('id'), tuwf->capture('sep')||'', tuwf->capture('num'));
+ my $w = tuwf->dbRowi(
+ 'SELECT r.id, r.vid, r.rid, r.isfull, r.modnote, r.text, r.spoiler, r.locked, COALESCE(c.count,0) AS count, r.c_flagged, r.c_up, r.c_down, uv.vote, rm.id IS NULL AS can
+ , v.title, rel.title AS rtitle, relv.rtype, rv.vote AS my, COALESCE(rv.overrule,false) AS overrule
+ , ', sql_user(), ',', sql_totime('r.date'), 'AS date,', sql_totime('r.lastmod'), 'AS lastmod
+ FROM reviews r
+ JOIN', vnt, 'v ON v.id = r.vid
+ LEFT JOIN', releasest, 'rel ON rel.id = r.rid
+ LEFT JOIN releases_vn relv ON relv.id = r.rid AND relv.vid = r.vid
+ LEFT JOIN users u ON u.id = r.uid
+ LEFT JOIN ulist_vns uv ON uv.uid = r.uid AND uv.vid = r.vid
+ LEFT JOIN (SELECT id, COUNT(*) FROM reviews_posts GROUP BY id) AS c(id,count) ON c.id = r.id
+ LEFT JOIN reviews_votes rv ON rv.id = r.id AND', auth ? ('rv.uid =', \auth->uid) : ('rv.ip =', \norm_ip tuwf->reqIP), '
+ LEFT JOIN reviews rm ON rm.vid = r.vid AND rm.uid =', \auth->uid, '
+ WHERE r.id =', \$id
+ );
+ return tuwf->resNotFound if !$w->{id};
+
+ enrich_flatten lang => rid => id => sub { sql 'SELECT id, lang FROM releases_titles WHERE id IN', $_, 'ORDER BY id, lang' }, $w;
+ enrich_flatten platforms => rid => id => sub { sql 'SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY id, platform' }, $w;
+
+ my $page = $sep eq '/' ? $num||1 : $sep ne '.' ? 1
+ : ceil((tuwf->dbVali('SELECT COUNT(*) FROM reviews_posts WHERE num <=', \$num, 'AND id =', \$id)||9999)/25);
+ $num = 0 if $sep ne '.';
+
+ my $posts = tuwf->dbPagei({ results => 25, page => $page },
+ 'SELECT rp.id, rp.num, rp.hidden, rp.msg',
+ ',', sql_user(),
+ ',', sql_totime('rp.date'), ' as date',
+ ',', sql_totime('rp.edited'), ' as edited
+ FROM reviews_posts rp
+ LEFT JOIN users u ON rp.uid = u.id
+ WHERE rp.id =', \$id, '
+ ORDER BY rp.num'
+ );
+ return tuwf->resNotFound if $num && !grep $_->{num} == $num, @$posts;
+
+ auth->notiRead($id, undef);
+ auth->notiRead($id, [ map $_->{num}, $posts->@* ]) if @$posts;
+
+ my $newreview = auth && $w->{user_id} && auth->uid eq $w->{user_id} && tuwf->reqGet('submit');
+
+ my $title = "Review of $w->{title}[1]";
+ framework_ title => $title, index => 1, dbobj => $w,
+ $num||$page>1 ? (pagevars => {sethash=>$num?"p$num":'threadstart'}) : (),
+ sub {
+ article_ sub {
+ itemmsg_ $w;
+ h1_ $title;
+ div_ class => 'notice', sub {
+ h2_ 'Review has been successfully submitted! ';
+ a_ href => "/$w->{id}", "dismiss";
+ } if $newreview;
+ review_ $w;
+ };
+ if(grep !defined $_->{hidden}, @$posts) {
+ nav_ sub {
+ h1_ 'Comments';
+ };
+ VNWeb::Discussions::Thread::posts_($w, $posts, $page);
+ } else {
+ div_ id => 'threadstart', '';
+ }
+ div_ widget(ReviewComment => $COMMENT, { id => $w->{id}, msg => '' }), '' if !$newreview && $w->{count} <= $page*25 && can_edit t => $w;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Reviews/VNTab.pm b/lib/VNWeb/Reviews/VNTab.pm
new file mode 100644
index 00000000..c0e6cbbb
--- /dev/null
+++ b/lib/VNWeb/Reviews/VNTab.pm
@@ -0,0 +1,93 @@
+package VNWeb::Reviews::VNTab;
+
+use VNWeb::Prelude;
+use VNWeb::Reviews::Lib;
+
+
+sub reviews_ {
+ my($v, $mini) = @_;
+
+ # TODO: Better order, pagination, option to show flagged reviews
+ my $lst = tuwf->dbAlli(
+ 'SELECT r.id, r.rid, r.modnote, r.text, r.spoiler, r.c_count, r.c_up, r.c_down, uv.vote, rv.vote AS my
+ , COALESCE(rv.overrule,false) AS overrule, NOT r.isfull AND rm.id IS NULL AS can
+ , ', sql_totime('r.date'), 'AS date, ', sql_user(), '
+ FROM reviews r
+ LEFT JOIN users u ON r.uid = u.id
+ LEFT JOIN ulist_vns uv ON uv.uid = r.uid AND uv.vid = r.vid
+ LEFT JOIN reviews_votes rv ON rv.id = r.id AND', auth ? ('rv.uid =', \auth->uid) : ('rv.ip =', \norm_ip tuwf->reqIP), '
+ LEFT JOIN reviews rm ON rm.vid = r.vid AND rm.uid =', \auth->uid, '
+ WhERE NOT r.c_flagged AND r.vid =', \$v->{id}, 'AND', ($mini ? 'NOT' : ''), 'r.isfull
+ ORDER BY r.c_up-r.c_down DESC'
+ );
+ return if !@$lst;
+
+ article_ sub {
+ h1_ $mini ? 'Mini reviews' : 'Full reviews';
+ debug_ $lst;
+ };
+ div_ class => 'reviews', sub {
+ article_ sub {
+ my $r = $_;
+ div_ sub {
+ span_ sub {
+ txt_ 'By '; user_ $r; txt_ ' on '.fmtdate $r->{date}, 'compact';
+ small_ ' contains spoilers' if $r->{spoiler} && (auth->pref('spoilers')||0) == 2;
+ };
+ a_ href => "/$r->{rid}", $r->{rid} if $r->{rid};
+ span_ "Vote: ".fmtvote($r->{vote}) if $r->{vote};
+ };
+ div_ sub {
+ p_ sub { lit_ bb_format $r->{modnote} } if $r->{modnote};
+ };
+ div_ sub {
+ span_ sub {
+ txt_ '<';
+ if(can_edit w => $r) {
+ a_ href => "/$r->{id}/edit", 'edit';
+ txt_ ' - ';
+ }
+ a_ href => "/report/$r->{id}", 'report';
+ txt_ '>';
+ };
+ my $html = reviews_format $r, maxlength => $mini ? undef : 700;
+ $html .= xml_string sub { txt_ '... '; a_ href => "/$r->{id}#review", ' Read more »' } if !$mini;
+ if($r->{spoiler}) {
+ label_ class => 'review_spoil', sub {
+ input_ type => 'checkbox', class => 'hidden', (auth->pref('spoilers')||0) == 2 ? ('checked', 'checked') : (), undef;
+ div_ sub { lit_ $html };
+ span_ class => 'fake_link', 'This review contains spoilers, click to view.';
+ }
+ } else {
+ lit_ $html;
+ }
+ };
+ div_ sub {
+ a_ href => "/$r->{id}#threadstart", $r->{c_count} == 1 ? '1 comment' : "$r->{c_count} comments";
+ reviews_vote_ $r;
+ };
+ } for @$lst;
+ };
+}
+
+
+TUWF::get qr{/$RE{vid}/(?<mini>mini|full)?reviews}, sub {
+ my $mini = !tuwf->capture('mini') ? undef : tuwf->capture('mini') eq 'mini' ? 1 : 0;
+ my $v = db_entry tuwf->capture('id');
+ return tuwf->resNotFound if !$v;
+ VNWeb::VN::Page::enrich_vn($v);
+
+ framework_ title => ($mini?'Mini reviews':'Reviews')." for $v->{title}[1]", index => 1, dbobj => $v, hiddenmsg => 1,
+ sub {
+ VNWeb::VN::Page::infobox_($v);
+ VNWeb::VN::Page::tabs_($v, !defined $mini ? 'reviews' : $mini ? 'minireviews' : 'fullreviews');
+ if(defined $mini) {
+ reviews_ $v, $mini;
+ } else {
+ reviews_ $v, 1;
+ reviews_ $v, 0;
+ }
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Staff/Edit.pm b/lib/VNWeb/Staff/Edit.pm
index 227da7f2..42ef2a3d 100644
--- a/lib/VNWeb/Staff/Edit.pm
+++ b/lib/VNWeb/Staff/Edit.pm
@@ -4,27 +4,23 @@ use VNWeb::Prelude;
my $FORM = {
- id => { required => 0, id => 1 },
- aid => { int => 1, range => [ -1000, 1<<40 ] }, # X
+ id => { default => undef, vndbid => 's' },
+ main => { int => 1, range => [ -1000, 1<<40 ] }, # X
alias => { maxlength => 100, sort_keys => 'aid', aoh => {
aid => { int => 1, range => [ -1000, 1<<40 ] }, # X, negative IDs are for new aliases
- name => { maxlength => 200 },
- original => { maxlength => 200, required => 0, default => '' },
+ name => { sl => 1, maxlength => 200 },
+ latin => { sl => 1, maxlength => 200, default => undef },
inuse => { anybool => 1, _when => 'out' },
+ wantdel => { anybool => 1, _when => 'out' },
} },
- desc => { required => 0, default => '', maxlength => 5000 },
- gender => { required => 0, default => 'unknown', enum => [qw[unknown m f]] },
+ description=> { default => '', maxlength => 5000 },
+ gender => { default => 'unknown', enum => [qw[unknown m f]] },
lang => { language => 1 },
- l_site => { required => 0, default => '', weburl => 1 },
- l_wikidata => { required => 0, id => 1 },
- l_twitter => { required => 0, default => '', regex => qr/^\S+$/, maxlength => 16 },
- l_anidb => { required => 0, id => 1, default => undef },
- l_pixiv => { required => 0, id => 1, default => 0 },
+ l_site => { default => '', weburl => 1 },
hidden => { anybool => 1 },
locked => { anybool => 1 },
-
- authmod => { _when => 'out', anybool => 1 },
editsum => { _when => 'in out', editsum => 1 },
+ validate_extlinks 's'
};
my $FORM_OUT = form_compile out => $FORM;
@@ -33,22 +29,28 @@ my $FORM_CMP = form_compile cmp => $FORM;
TUWF::get qr{/$RE{srev}/edit} => sub {
- my $e = db_entry s => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound;
return tuwf->resDenied if !can_edit s => $e;
- $e->{authmod} = auth->permDbmod;
- $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision s$e->{id}.$e->{chrev}";
+ $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}";
+
+ my $alias_inuse = 'EXISTS(SELECT 1 FROM vn_staff WHERE aid = sa.aid UNION ALL SELECT 1 FROM vn_seiyuu WHERE aid = sa.aid)';
+ enrich_merge aid => sub { "SELECT aid, $alias_inuse AS inuse, false AS wantdel FROM unnest(", sql_array(@$_), '::int[]) AS sa(aid)' }, $e->{alias};
+
+ # If we're reverting to an older revision, we have to make sure all the
+ # still referenced aliases are included.
+ push $e->{alias}->@*, tuwf->dbAlli(
+ "SELECT aid, name, latin, true AS inuse, true AS wantdel
+ FROM staff_alias sa WHERE $alias_inuse AND sa.id =", \$e->{id}, 'AND sa.aid NOT IN', [ map $_->{aid}, $e->{alias}->@* ]
+ )->@* if $e->{chrev} != $e->{maxrev};
- enrich_merge aid => sub {
- 'SELECT aid, EXISTS(SELECT 1 FROM vn_staff WHERE aid = x.aid UNION ALL SELECT 1 FROM vn_seiyuu WHERE aid = x.aid) AS inuse
- FROM unnest(', sql_array(@$_), '::int[]) AS x(aid)'
- }, $e->{alias};
+ $e->{alias} = [ sort { ($a->{latin}//$a->{name}) cmp ($b->{latin}//$b->{name}) } $e->{alias}->@* ];
- my $name = (grep $_->{aid} == $e->{aid}, @{$e->{alias}})[0]{name};
- framework_ title => "Edit $name", type => 's', dbobj => $e, tab => 'edit',
+ my $name = titleprefs_swap($e->{lang}, @{ (grep $_->{aid} == $e->{main}, @{$e->{alias}})[0] }{qw/ name latin /})->[1];
+ framework_ title => "Edit $name", dbobj => $e, tab => 'edit',
sub {
editmsg_ s => $e, "Edit $name";
- elm_ 'StaffEdit.Main' => $FORM_OUT, $e;
+ div_ widget(StaffEdit => $FORM_OUT, $e), '';
};
};
@@ -58,45 +60,50 @@ TUWF::get qr{/s/new}, sub {
framework_ title => 'Add staff member',
sub {
editmsg_ s => undef, 'Add staff member';
- elm_ 'StaffEdit.New';
+ div_ widget(StaffEdit => $FORM_OUT, {
+ elm_empty($FORM_OUT)->%*,
+ alias => [ { aid => -1, name => '', latin => undef, inuse => 0, wantdel => 0 } ],
+ main => -1
+ }), '';
};
};
-elm_api StaffEdit => $FORM_OUT, $FORM_IN, sub {
+js_api StaffEdit => $FORM_IN, sub {
my $data = shift;
my $new = !$data->{id};
- my $e = $new ? { id => 0 } : db_entry s => $data->{id} or return tuwf->resNotFound;
- return elm_Unauth if !can_edit s => $e;
+ my $e = $new ? { id => 0 } : db_entry $data->{id} or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit s => $e;
if(!auth->permDbmod) {
$data->{hidden} = $e->{hidden}||0;
$data->{locked} = $e->{locked}||0;
}
$data->{l_wp} = $e->{l_wp}||'';
- $data->{desc} = bb_subst_links $data->{desc};
+ $data->{description} = bb_subst_links $data->{description};
- # The form validation only checks for duplicate aid's, but the name+original should also be unique.
+ # The form validation only checks for duplicate aid's, but the name+latin should also be unique.
my %names;
- die "Duplicate aliases" if grep $names{"$_->{name}\x00$_->{original}"}++, $data->{alias}->@*;
- die "Original = name" if grep $_->{name} eq $_->{original}, $data->{alias}->@*;
+ die "Duplicate aliases" if grep $names{"$_->{name}\x00".($_->{latin}//'')}++, $data->{alias}->@*;
+ die "Latin = name" if grep $_->{latin} && $_->{name} eq $_->{latin}, $data->{alias}->@*;
- # For positive alias IDs: Make sure they exist and are owned by this entry.
+ # For positive alias IDs: Make sure they exist and are (or were) owned by this entry.
validate_dbid
- sql('SELECT aid FROM staff_alias WHERE id =', \$e->{id}, 'AND aid IN'),
+ sql('SELECT aid FROM staff_alias_hist WHERE chid IN(SELECT id FROM changes WHERE itemid =', \$e->{id}, ') AND aid IN'),
grep $_>=0, map $_->{aid}, $data->{alias}->@*;
# For negative alias IDs: Assign a new ID.
for my $alias (grep $_->{aid} < 0, $data->{alias}->@*) {
my $new = tuwf->dbVali(select => sql_func nextval => \'staff_alias_aid_seq');
- $data->{aid} = $new if $alias->{aid} == $data->{aid};
+ $data->{main} = $new if $alias->{aid} == $data->{main};
$alias->{aid} = $new;
}
# We rely on Postgres to throw an error if we attempt to delete an alias that is still being referenced.
- return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e;
- my($id,undef,$rev) = db_edit s => $e->{id}, $data;
- elm_Redirect "/s$id.$rev";
+ return +{ _err => 'No changes.' } if !$new && !form_changed $FORM_CMP, $data, $e;
+
+ my $ch = db_edit s => $e->{id}, $data;
+ +{ _redir => "/$ch->{nitemid}.$ch->{nrev}" };
};
1;
diff --git a/lib/VNWeb/Staff/Elm.pm b/lib/VNWeb/Staff/Elm.pm
new file mode 100644
index 00000000..43cff16a
--- /dev/null
+++ b/lib/VNWeb/Staff/Elm.pm
@@ -0,0 +1,34 @@
+package VNWeb::Staff::Elm;
+
+use VNWeb::Prelude;
+
+elm_api Staff => undef, {
+ search => { type => 'array', values => { searchquery => 1 } },
+}, sub {
+ my($data) = @_;
+ my @q = grep $_, $data->{search}->@*;
+
+ elm_StaffResult @q ? tuwf->dbPagei({ results => 15, page => 1 },
+ 'SELECT s.id, s.lang, s.aid, s.title[1+1], s.title[1+1+1+1] as alttitle
+ FROM', staff_aliast, 's', VNWeb::Validate::SearchQuery::sql_joina(\@q, 's', 's.id', 's.aid'), '
+ WHERE NOT s.hidden
+ ORDER BY sc.score DESC, s.sorttitle
+ ') : [];
+};
+
+js_api Staff => {
+ search => { type => 'array', values => { searchquery => 1 } },
+}, sub {
+ my($data) = @_;
+ my @q = grep $_, $data->{search}->@*;
+
+ +{ results => @q ? tuwf->dbAlli(
+ 'SELECT s.id, s.lang, s.aid, s.title[1+1], s.title[1+1+1+1] as alttitle
+ FROM', staff_aliast, 's', VNWeb::Validate::SearchQuery::sql_joina(\@q, 's', 's.id', 's.aid'), '
+ WHERE NOT s.hidden
+ ORDER BY sc.score DESC, s.sorttitle
+ LIMIT', \30
+ ) : [] };
+};
+
+1;
diff --git a/lib/VNWeb/Staff/List.pm b/lib/VNWeb/Staff/List.pm
new file mode 100644
index 00000000..fb92db52
--- /dev/null
+++ b/lib/VNWeb/Staff/List.pm
@@ -0,0 +1,94 @@
+package VNWeb::Staff::List;
+
+use VNWeb::Prelude;
+use VNWeb::AdvSearch;
+use VNWeb::Filters;
+
+
+sub listing_ {
+ my($opt, $list, $count) = @_;
+ my sub url { '?'.query_encode %$opt, @_ }
+ paginate_ \&url, $opt->{p}, [$count, 150], 't';
+ article_ class => 'staffbrowse', sub {
+ h1_ 'Staff list';
+ ul_ sub {
+ li_ sub {
+ abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, '';
+ a_ href => "/$_->{id}", tattr $_;
+ } for @$list;
+ };
+ };
+ paginate_ \&url, $opt->{p}, [$count, 150], 'b';
+}
+
+
+TUWF::get qr{/s(?:/(?<char>all|[a-z0]))?}, sub {
+ my $opt = tuwf->validate(get =>
+ q => { searchquery => 1 },
+ p => { upage => 1 },
+ f => { advsearch_err => 's' },
+ n => { onerror => [], type => 'array', scalar => 1, values => { anybool => 1 } },
+ ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } },
+ fil => { onerror => '' },
+ )->data;
+ $opt->{ch} = $opt->{ch}[0];
+ $opt->{n} = $opt->{n}[0];
+
+ # compat with old URLs
+ my $oldch = tuwf->capture('char');
+ $opt->{ch} //= $oldch if defined $oldch && $oldch ne 'all';
+
+ # URL compatibility with old filters
+ if(!$opt->{f}->{query} && $opt->{fil}) {
+ my $q = eval {
+ my $f = filter_parse s => $opt->{fil};
+ $opt->{n} = $f->{truename} if defined $f->{truename};
+ $f = filter_staff_adv $f;
+ tuwf->compile({ advsearch => 's' })->validate(@$f > 1 ? $f : undef)->data;
+ };
+ return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q;
+ }
+
+ $opt->{f} = advsearch_default 's' if !$opt->{f}{query} && !defined tuwf->reqGet('f');
+
+ my $where = sql_and
+ $opt->{n} ? 's.main = s.aid' : (),
+ 'NOT s.hidden', $opt->{f}->sql_where(),
+ defined($opt->{ch}) ? sql 'match_firstchar(s.sorttitle, ', \$opt->{ch}, ')' : ();
+
+ my $time = time;
+ my($count, $list);
+ db_maytimeout {
+ $count = tuwf->dbVali('SELECT count(*) FROM', staff_aliast, 's WHERE', sql_and $where, $opt->{q}->sql_where('s', 's.id', 's.aid'));
+ $list = $count ? tuwf->dbPagei({results => 150, page => $opt->{p}}, '
+ SELECT s.id, s.title, s.lang
+ FROM', staff_aliast, 's', $opt->{q}->sql_join('s', 's.id', 's.aid'), '
+ WHERE', $where,
+ 'ORDER BY', $opt->{q} ? 'sc.score DESC, ' : (), 's.sorttitle, s.aid'
+ ) : [];
+ } || (($count, $list) = (undef, []));
+ $time = time - $time;
+
+ framework_ title => 'Browse staff', sub {
+ article_ sub {
+ h1_ 'Browse staff';
+ form_ action => '/s', method => 'get', sub {
+ searchbox_ s => $opt->{q}//'';
+ p_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'ch', value => ($_//''), ($_//'') eq ($opt->{ch}//'') ? (class => 'optselected') : (), !defined $_ ? 'ALL' : $_ ? uc $_ : '#'
+ for (undef, 'a'..'z', 0);
+ };
+ p_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'n', value => 0, !$opt->{n} ? (class => 'optselected') : (), 'Display aliases';
+ button_ type => 'submit', name => 'n', value => 1, $opt->{n} ? (class => 'optselected') : (), 'Hide aliases';
+ };
+ input_ type => 'hidden', name => 'ch', value => $opt->{ch}//'';
+ input_ type => 'hidden', name => 'n', value => $opt->{n}//0;
+ $opt->{f}->elm_($count, $time);
+ };
+ };
+ listing_ $opt, $list, $count if $count;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/Staff/Page.pm b/lib/VNWeb/Staff/Page.pm
index 72227559..0dc1a856 100644
--- a/lib/VNWeb/Staff/Page.pm
+++ b/lib/VNWeb/Staff/Page.pm
@@ -1,30 +1,37 @@
package VNWeb::Staff::Page;
use VNWeb::Prelude;
+use VNWeb::ULists::Lib;
sub enrich_item {
my($s) = @_;
- # Add a 'main' flag to each alias
- $_->{main} = $s->{aid} == $_->{aid} for $s->{alias}->@*;
+ # Add a 'main' flag and title field to each alias
+ for ($s->{alias}->@*) {
+ $_->{main} = $s->{main} == $_->{aid};
+ $_->{title} = titleprefs_swap $s->{lang}, $_->{name}, $_->{latin};
+ }
- # Sort aliases by name
- $s->{alias} = [ sort { $a->{name} cmp $b->{name} || ($a->{original}||'') cmp ($b->{original}||'') } $s->{alias}->@* ];
+ # Sort aliases by aid for more readable comparison at revisions.
+ $s->{alias} = [ sort { $a->{aid} <=> $b->{aid} } $s->{alias}->@* ];
}
sub _rev_ {
my($s) = @_;
- revision_ s => $s, \&enrich_item,
+ my %aid;
+ revision_ $s, \&enrich_item,
[ alias => 'Names', fmt => sub {
+ my $num = ($aid{$_->{aid}} ||= keys %aid);
+ strong_ "$num: ";
txt_ $_->{name};
- txt_ " ($_->{original})" if $_->{original};
- b_ class => 'grayedout', ' (primary)' if $_->{main};
+ txt_ " ($_->{latin})" if $_->{latin};
+ small_ ' (primary)' if $_->{main};
} ],
[ gender => 'Gender', fmt => \%GENDER ],
[ lang => 'Language', fmt => \%LANGUAGE ],
- [ desc => 'Description' ],
+ [ description => 'Description' ],
revision_extlinks 's'
}
@@ -34,25 +41,25 @@ sub _infotable_ {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
td_ colspan => 2, sub {
- b_ style => 'margin-right: 10px', $main->{name};
- b_ class => 'grayedout', style => 'margin-right: 10px', lang => $s->{lang}, $main->{original} if $main->{original};
- abbr_ class => "icons gen $s->{gender}", title => $GENDER{$s->{gender}}, '' if $s->{gender} ne 'unknown';
+ span_ style => 'margin-right: 10px', tlang($main->{title}[0], $main->{title}[1]), $main->{title}[1];
+ small_ style => 'margin-right: 10px', tlang($main->{title}[2], $main->{title}[3]), $main->{title}[3] if $main->{title}[1] ne $main->{title}[3];
+ abbr_ class => "icon-gen-$s->{gender}", title => $GENDER{$s->{gender}}, '' if $s->{gender} ne 'unknown';
}
} };
tr_ sub {
td_ class => 'key', 'Language';
- td_ $LANGUAGE{$s->{lang}};
+ td_ $LANGUAGE{$s->{lang}}{txt};
};
- my @alias = grep !$_->{main}, $s->{alias}->@*;
+ my @alias = sort { ($a->{latin}//$a->{name}) cmp ($b->{latin}//$b->{name}) } grep !$_->{main}, $s->{alias}->@*;
tr_ sub {
td_ @alias == 1 ? 'Alias' : 'Aliases';
td_ sub {
table_ class => 'aliases', sub {
tr_ class => 'nostripe', sub {
- td_ class => 'key', $_->{original} ? () : (colspan => 2), $_->{name};
- td_ lang => $s->{lang}, $_->{original} if $_->{original};
+ td_ class => 'key', $_->{latin} ? () : (colspan => 2), tlang($s->{lang}, $_->{name}), $_->{name};
+ td_ tlang($s->{lang}, $_->{latin}), $_->{latin} if $_->{latin};
} for @alias;
};
};
@@ -61,7 +68,7 @@ sub _infotable_ {
tr_ sub {
td_ class => 'key', 'Links';
td_ sub {
- join_ \&br_, sub { a_ href => $_->[1], $_->[0] }, $s->{extlinks}->@*;
+ join_ \&br_, sub { a_ href => $_->{url2}, $_->{label} }, $s->{extlinks}->@*;
};
} if $s->{extlinks}->@*;
};
@@ -72,34 +79,45 @@ sub _roles_ {
my($s) = @_;
my %alias = map +($_->{aid}, $_), $s->{alias}->@*;
- my $roles = tuwf->dbAlli(q{
- SELECT v.id, vs.aid, vs.role, vs.note, v.c_released, v.title, v.original
+ my $roles = tuwf->dbAlli('
+ SELECT v.id, vs.aid, vs.role, vs.note, ve.name, ve.official, ve.lang, v.c_released, v.title
FROM vn_staff vs
- JOIN vn v ON v.id = vs.id
- WHERE vs.aid IN}, [ keys %alias ], q{
+ JOIN', vnt, 'v ON v.id = vs.id
+ LEFT JOIN vn_editions ve ON ve.id = vs.id AND ve.eid = vs.eid
+ WHERE vs.aid IN', [ keys %alias ], '
AND NOT v.hidden
- ORDER BY v.c_released ASC, v.title ASC, vs.role ASC
- });
+ ORDER BY v.c_released ASC, v.sorttitle ASC, ve.lang NULLS FIRST, ve.name NULLS FIRST, vs.role ASC
+ ');
return if !@$roles;
+ enrich_ulists_widget $roles;
- h1_ class => 'boxtitle', sprintf 'Credits (%d)', scalar @$roles;
- div_ class => 'mainbox browse staffroles', sub {
+ nav_ sub {
+ h1_ sprintf 'Credits (%d)', scalar @$roles;
+ };
+ article_ class => 'browse staffroles', sub {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
+ td_ class => 'tc_ulist', '' if auth;
td_ class => 'tc1', 'Title';
td_ class => 'tc2', 'Released';
td_ class => 'tc3', 'Role';
td_ class => 'tc4', 'As';
td_ class => 'tc5', 'Note';
}};
+ my %vns;
tr_ sub {
my($v, $a) = ($_, $alias{$_->{aid}});
+ td_ class => 'tc_ulist', sub { ulists_widget_ $v if !$vns{$v->{id}}++ } if auth;
td_ class => 'tc1', sub {
- a_ href => "/v$v->{id}", title => $v->{original}||$v->{title}, shorten $v->{title}, 60;
+ a_ href => "/$v->{id}", tattr $v;
+ lit_ ' ' if $v->{name};
+ abbr_ class => "icon-lang-$v->{lang}", title => $LANGUAGE{$v->{lang}}{txt}, '' if $v->{lang};
+ txt_ $v->{name} if $v->{name} && $v->{official};
+ small_ $v->{name} if $v->{name} && !$v->{official};
};
td_ class => 'tc2', sub { rdate_ $v->{c_released} };
td_ class => 'tc3', $CREDIT_TYPE{$v->{role}};
- td_ class => 'tc4', title => $a->{original}||$a->{name}, $a->{name};
+ td_ class => 'tc4', tattr $a;
td_ class => 'tc5', $v->{note};
} for @$roles;
};
@@ -111,49 +129,54 @@ sub _cast_ {
my($s) = @_;
my %alias = map +($_->{aid}, $_), $s->{alias}->@*;
- my $cast = tuwf->dbAlli(q{
- SELECT vs.aid, v.id, v.c_released, v.title, v.original, c.id AS cid, c.name AS c_name, c.original AS c_original, vs.note,
+ my $cast = [ grep defined $_->{spoil}, tuwf->dbAlli('
+ SELECT vs.aid, v.id, v.c_released, v.title, c.id AS cid, c.title AS c_title, vs.note,
(SELECT MIN(cv.spoil) FROM chars_vns cv WHERE cv.id = c.id AND cv.vid = v.id) AS spoil
FROM vn_seiyuu vs
- JOIN vn v ON v.id = vs.id
- JOIN chars c ON c.id = vs.cid
- WHERE vs.aid IN}, [ keys %alias ], q{
+ JOIN', vnt, 'v ON v.id = vs.id
+ JOIN', charst, 'c ON c.id = vs.cid
+ WHERE vs.aid IN', [ keys %alias ], '
AND NOT v.hidden
AND NOT c.hidden
- ORDER BY v.c_released ASC, v.title ASC
- });
+ ORDER BY v.c_released ASC, v.sorttitle ASC
+ ')->@* ];
return if !@$cast;
+ enrich_ulists_widget $cast;
my $spoilers = viewget->{spoilers};
my $max_spoil = max(map $_->{spoil}, @$cast);
- div_ class => 'maintabs', sub {
+ nav_ sub {
h1_ sprintf 'Voiced characters (%d)', scalar @$cast;
- ul_ sub {
+ menu_ sub {
li_ mkclass(tabselected => $spoilers == 0), sub { a_ href => '?view='.viewset(spoilers => 0), 'hide spoilers' };
li_ mkclass(tabselected => $spoilers == 1), sub { a_ href => '?view='.viewset(spoilers => 1), 'minor spoilers' };
li_ mkclass(tabselected => $spoilers == 2), sub { a_ href => '?view='.viewset(spoilers => 2), 'spoil me!' } if $max_spoil == 2;
} if $max_spoil;
};
- div_ class => "mainbox browse staffroles", sub {
+ article_ class => "browse staffroles", sub {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
+ td_ class => 'tc_ulist', '' if auth;
td_ class => 'tc1', sub { txt_ 'Title'; debug_ $cast };
td_ class => 'tc2', 'Released';
td_ class => 'tc3', 'Cast';
td_ class => 'tc4', 'As';
td_ class => 'tc5', 'Note';
}};
+ my %vns;
tr_ sub {
my($v, $a) = ($_, $alias{$_->{aid}});
+ td_ class => 'tc_ulist', sub { ulists_widget_ $v if !$vns{$v->{id}}++ } if auth;
td_ class => 'tc1', sub {
- a_ href => "/v$v->{id}", title => $v->{original}||$v->{title}, shorten $v->{title}, 60;
+ a_ href => "/$v->{id}", tattr $v;
};
td_ class => 'tc2', sub { rdate_ $v->{c_released} };
td_ class => 'tc3', sub {
- a_ href => "/c$v->{cid}", title => $v->{c_original}||$v->{c_name}, $v->{c_name};
+ a_ href => "/$v->{cid}", tattr $v->{c_title};
+ spoil_ $_->{spoil};
};
- td_ class => 'tc4', title => $a->{original}||$a->{name}, $a->{name};
+ td_ class => 'tc4', tattr $a;
td_ class => 'tc5', $v->{note};
} for grep $_->{spoil} <= $spoilers, @$cast;
};
@@ -162,25 +185,25 @@ sub _cast_ {
TUWF::get qr{/$RE{srev}} => sub {
- my $s = db_entry s => tuwf->capture('id'), tuwf->capture('rev');
+ my $s = db_entry tuwf->captures('id', 'rev');
return tuwf->resNotFound if !$s;
enrich_item $s;
- enrich_extlinks s => $s;
- my($main) = grep $_->{aid} == $s->{aid}, $s->{alias}->@*;
+ enrich_extlinks s => 0, $s;
+ my($main) = grep $_->{aid} == $s->{main}, $s->{alias}->@*;
- framework_ title => $main->{name}, index => !tuwf->capture('rev'), type => 's', dbobj => $s, hiddenmsg => 1,
+ framework_ title => $main->{title}[1], index => !tuwf->capture('rev'), dbobj => $s, hiddenmsg => 1,
og => {
- description => bb2text $s->{desc}
+ description => bb_format $s->{description}, text => 1
},
sub {
_rev_ $s if tuwf->capture('rev');
- div_ class => 'mainbox staffpage', sub {
- itemmsg_ s => $s;
- h1_ sub { txt_ $main->{name}; debug_ $s };
- h2_ class => 'alttitle', lang => $s->{lang}, $main->{original} if $main->{original};
+ article_ class => 'staffpage', sub {
+ itemmsg_ $s;
+ h1_ tlang(@{$main->{title}}[0,1]), $main->{title}[1];
+ h2_ class => 'alttitle', tlang(@{$main->{title}}[2,3]), $main->{title}[3] if $main->{title}[3] && $main->{title}[3] ne $main->{title}[1];
_infotable_ $main, $s;
- p_ class => 'description', sub { lit_ bb2html $s->{desc} };
+ div_ class => 'description', sub { lit_ bb_format $s->{description} };
};
_roles_ $s;
diff --git a/lib/VNWeb/TT/Elm.pm b/lib/VNWeb/TT/Elm.pm
new file mode 100644
index 00000000..b30aeff1
--- /dev/null
+++ b/lib/VNWeb/TT/Elm.pm
@@ -0,0 +1,56 @@
+package VNWeb::TT::Elm;
+
+use VNWeb::Prelude;
+
+elm_api Tags => undef, { search => { searchquery => 1 } }, sub {
+ my $q = shift->{search};
+
+ elm_TagResult $q ? tuwf->dbPagei({ results => 15, page => 1 },
+ 'SELECT t.id, t.name, t.searchable, t.applicable, t.hidden, t.locked
+ FROM tags t', $q->sql_join('g', 't.id'), '
+ WHERE NOT (t.hidden AND t.locked)
+ ORDER BY sc.score DESC, t.name
+ ') : [];
+};
+
+
+js_api Tags => { search => { searchquery => 1 } }, sub {
+ my $q = shift->{search};
+
+ +{ results => $q ? tuwf->dbAlli(
+ 'SELECT t.id, t.name, t.searchable, t.applicable, t.hidden, t.locked
+ FROM tags t', $q->sql_join('g', 't.id'), '
+ WHERE NOT (t.hidden AND t.locked)
+ ORDER BY sc.score DESC, t.name
+ LIMIT', \30
+ ) : [] }
+};
+
+
+elm_api Traits => undef, { search => { searchquery => 1 } }, sub {
+ my $q = shift->{search};
+
+ elm_TraitResult $q ? tuwf->dbPagei({ results => 15, page => 1 },
+ 'SELECT t.id, t.name, t.searchable, t.applicable, t.defaultspoil, t.hidden, t.locked, g.id AS group_id, g.name AS group_name
+ FROM traits t', $q->sql_join('i', 't.id'), '
+ LEFT JOIN traits g ON g.id = t.gid
+ WHERE NOT (t.hidden AND t.locked)
+ ORDER BY sc.score DESC, t.name
+ ') : [];
+};
+
+
+js_api Traits => { search => { searchquery => 1 } }, sub {
+ my $q = shift->{search};
+
+ +{ results => $q ? tuwf->dbAlli(
+ 'SELECT t.id, t.name, t.searchable, t.applicable, t.defaultspoil, t.hidden, t.locked, g.id AS group_id, g.name AS group_name
+ FROM traits t', $q->sql_join('i', 't.id'), '
+ LEFT JOIN traits g ON g.id = t.gid
+ WHERE NOT (t.hidden AND t.locked)
+ ORDER BY sc.score DESC, t.name
+ LIMIT', \30
+ ) : [] };
+};
+
+1;
diff --git a/lib/VNWeb/TT/Index.pm b/lib/VNWeb/TT/Index.pm
new file mode 100644
index 00000000..7a8ac10b
--- /dev/null
+++ b/lib/VNWeb/TT/Index.pm
@@ -0,0 +1,88 @@
+package VNWeb::TT::Index;
+
+use VNWeb::Prelude;
+use VNWeb::TT::Lib 'enrich_group', 'tree_';
+
+
+sub recent_ {
+ my($type) = @_;
+ my $lst = tuwf->dbAlli('SELECT id, name, ', sql_totime('added'), 'AS added FROM', $type eq 'g' ? 'tags' : 'traits', 'WHERE NOT hidden ORDER BY id DESC LIMIT 10');
+ enrich_group $type, $lst;
+ p_ class => 'mainopts', sub {
+ a_ href => "/$type/list", 'Browse all '.($type eq 'g' ? 'tags' : 'traits');
+ };
+ h1_ 'Recently added';
+ ul_ sub {
+ li_ sub {
+ txt_ fmtage $_->{added};
+ txt_ ' ';
+ small_ "$_->{group} / " if $_->{group};
+ a_ href => "/$_->{id}", $_->{name};
+ } for @$lst;
+ };
+}
+
+
+sub popular_ {
+ my($type) = @_;
+ my $lst = tuwf->dbAlli('SELECT id, name, c_items FROM', $type eq 'g' ? 'tags' : 'traits', 'WHERE NOT hidden AND c_items > 0 AND applicable ORDER BY c_items DESC LIMIT 10');
+ enrich_group $type, $lst;
+ p_ class => 'mainopts', sub {
+ a_ href => '/g/links', 'Recently tagged';
+ } if $type eq 'g';
+ h1_ 'Popular';
+ ul_ sub {
+ li_ sub {
+ small_ "$_->{group} / " if $_->{group};
+ a_ href => "/$_->{id}", $_->{name};
+ txt_ " ($_->{c_items})";
+ } for @$lst;
+ };
+}
+
+
+sub moderation_ {
+ my($type) = @_;
+ my $lst = tuwf->dbAlli('SELECT id, name, ', sql_totime('added'), 'AS added FROM', $type eq 'g' ? 'tags' : 'traits', 'WHERE hidden AND NOT locked ORDER BY added DESC LIMIT 10');
+ enrich_group $type, $lst;
+ h1_ 'Awaiting moderation';
+ ul_ sub {
+ li_ 'The moderation queue is empty!' if !@$lst;
+ li_ sub {
+ txt_ fmtage $_->{added};
+ txt_ ' ';
+ small_ "$_->{group} / " if $_->{group};
+ a_ href => "/$_->{id}", $_->{name};
+ } for @$lst;
+ li_ sub {
+ br_;
+ a_ href => "/$type/list?t=0;o=d;s=added", 'Moderation queue';
+ txt_ ' - ';
+ a_ href => "/$type/list?t=1;o=d;s=added", $type eq 'g' ? 'Denied tags' : 'Denied traits';
+ };
+ };
+}
+
+
+TUWF::get qr{/(?<type>[gi])}, sub {
+ my $type = tuwf->capture('type');
+ framework_ title => $type eq 'g' ? 'Tag index' : 'Trait index', index => 1, sub {
+ article_ sub {
+ p_ class => 'mainopts', sub {
+ a_ href => "/$type/new", 'Create a new '.($type eq 'g' ? 'tag' : 'trait') if can_edit $type => {};
+ };
+ h1_ $type eq 'g' ? 'Search tags' : 'Search traits';
+ form_ action => "/$type/list", sub {
+ searchbox_ $type => '';
+ };
+ };
+ tree_ $type;
+ div_ class => 'threelayout', sub {
+ article_ sub { recent_ $type };
+ article_ sub { popular_ $type };
+ article_ sub { moderation_ $type };
+ };
+ };
+};
+
+1;
diff --git a/lib/VNWeb/TT/Lib.pm b/lib/VNWeb/TT/Lib.pm
new file mode 100644
index 00000000..5ac3e08d
--- /dev/null
+++ b/lib/VNWeb/TT/Lib.pm
@@ -0,0 +1,102 @@
+package VNWeb::TT::Lib;
+
+use VNWeb::Prelude;
+use Exporter 'import';
+
+our @EXPORT = qw/ tagscore_ enrich_group tree_ parents_ /;
+
+sub tagscore_ {
+ my($s, $ign) = @_;
+ div_ mkclass(tagscore => 1, negative => $s <= 0, ignored => $ign), sub {
+ span_ sprintf '%.1f', $s;
+ div_ style => sprintf('width: %.0fpx', abs $s/3*30), '';
+ };
+}
+
+
+# Add a 'group' name for traits
+sub enrich_group {
+ my($type, @lst) = @_;
+ enrich_merge id => 'SELECT t.id, g.name AS "group" FROM traits t JOIN traits g ON g.id = t.gid WHERE t.id IN', @lst if $type eq 'i';
+}
+
+
+sub tree_ {
+ my($type, $id) = @_;
+ my $table = $type eq 'g' ? 'tags' : 'traits';
+ my $top = tuwf->dbAlli(
+ "SELECT id, name, c_items FROM $table t
+ WHERE NOT hidden
+ AND", $id ? sql "id IN(SELECT id FROM ${table}_parents WHERE parent = ", \$id, ')'
+ : "NOT EXISTS(SELECT 1 FROM ${table}_parents tp WHERE tp.id = t.id)", "
+ ORDER BY ", $type eq 'g' || $id ? 'name' : 'gorder'
+ );
+ return if !@$top;
+
+ enrich childs => id => parent => sub { sql
+ "SELECT tp.parent, t.id, t.name, t.c_items FROM $table t JOIN ${table}_parents tp ON tp.id = t.id WHERE NOT hidden AND tp.parent IN", $_, 'ORDER BY name'
+ }, $top;
+ $top = [ sort { $b->{childs}->@* <=> $a->{childs}->@* } @$top ] if $type eq 'g' || $id;
+
+ my sub lnk_ {
+ a_ href => "/$_[0]{id}", $_[0]{name};
+ small_ " ($_[0]{c_items})" if $_[0]{c_items};
+ }
+ article_ sub {
+ h1_ $id ? ($type eq 'g' ? 'Child tags' : 'Child traits') : $type eq 'g' ? 'Tag tree' : 'Trait tree';
+ ul_ class => 'tagtree', sub {
+ li_ sub {
+ lnk_ $_;
+ my $sub = $_->{childs};
+ ul_ sub {
+ li_ sub {
+ txt_ '> ';
+ lnk_ $_;
+ } for grep $_, $sub->@[0 .. (@$sub > 6 ? 4 : 5)];
+ li_ sub {
+ my $num = @$sub-5;
+ txt_ '> ';
+ a_ href => "/$_->{id}", style => 'font-style: italic', sprintf '%d more %s%s', $num, $type eq 'g' ? 'tag' : 'trait', $num == 1 ? '' : 's';
+ } if @$sub > 6;
+ } if @$sub;
+ } for @$top;
+ };
+ clearfloat_;
+ br_;
+ };
+}
+
+
+# Breadcrumbs-style listing of parent tags/traits
+sub parents_ {
+ my($type, $t) = @_;
+
+ my %t;
+ my $table = $type eq 'g' ? 'tags' : 'traits';
+ push $t{$_->{child}}->@*, $_ for tuwf->dbAlli("
+ WITH RECURSIVE p(id,child,name,main) AS (
+ SELECT t.id, tp.id, t.name, tp.main FROM ${table}_parents tp JOIN $table t ON t.id = tp.parent WHERE tp.id =", \$t->{id}, "
+ UNION
+ SELECT t.id, p.id, t.name, tp.main FROM p JOIN ${table}_parents tp ON tp.id = p.id JOIN $table t ON t.id = tp.parent
+ ) SELECT * FROM p ORDER BY main DESC, name
+ ")->@*;
+
+ my sub rec {
+ $t{$_[0]} ? map { my $e=$_; map [ @$_, $e ], __SUB__->($e->{id}) } $t{$_[0]}->@* : []
+ }
+
+ p_ sub {
+ join_ \&br_, sub {
+ a_ href => "/$type", $type eq 'g' ? 'Tags' : 'Traits';
+ for (@$_) {
+ txt_ ' > ';
+ a_ href => "/$_->{id}", $_->{name};
+ }
+ txt_ ' > ';
+ txt_ $t->{name};
+ }, rec($t->{id});
+ };
+}
+
+
+1;
diff --git a/lib/VNWeb/TT/List.pm b/lib/VNWeb/TT/List.pm
new file mode 100644
index 00000000..537c6d3d
--- /dev/null
+++ b/lib/VNWeb/TT/List.pm
@@ -0,0 +1,102 @@
+package VNWeb::TT::List;
+
+use VNWeb::Prelude;
+use VNWeb::TT::Lib 'enrich_group';
+
+
+sub listing_ {
+ my($type, $opt, $list, $count) = @_;
+
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ paginate_ \&url, $opt->{p}, [$count, 50], 't';
+ article_ class => 'browse taglist', sub {
+ table_ class => 'stripe', sub {
+ thead_ sub { tr_ sub {
+ td_ class => 'tc1', sub { txt_ 'Created'; sortable_ 'added', $opt, \&url };
+ td_ class => 'tc2', sub { txt_ $type eq 'g' ? 'VNs' : 'Chars'; sortable_ 'items', $opt, \&url };
+ td_ class => 'tc3', sub { txt_ 'Name'; sortable_ 'name', $opt, \&url };
+ } };
+ tr_ sub {
+ td_ class => 'tc1', fmtage $_->{added};
+ td_ class => 'tc2', $_->{c_items}||'-';
+ td_ class => 'tc3', sub {
+ small_ "$_->{group} / " if $_->{group};
+ a_ href => "/$_->{id}", $_->{name};
+ join_ ',', sub { small_ ' '.$_ },
+ !$_->{hidden} ? () : $_->{locked} ? 'deleted' : 'awaiting moderation',
+ !$_->{applicable} ? 'not applicable' : (),
+ !$_->{searchable} ? 'not searchable' : ();
+ };
+ } for @$list;
+ };
+ };
+ paginate_ \&url, $opt->{p}, [$count, 50], 'b';
+}
+
+
+TUWF::get qr{/(?<type>[gi])/list}, sub {
+ my $type = tuwf->capture('type');
+ my $opt = tuwf->validate(get =>
+ s => { onerror => 'qscore', enum => ['qscore', 'added', 'name', 'vns', 'items'] },
+ o => { onerror => 'a', enum => ['a', 'd'] },
+ p => { upage => 1 },
+ t => { onerror => undef, enum => [ -1..2 ] },
+ a => { undefbool => 1 },
+ b => { undefbool => 1 },
+ q => { searchquery => 1 },
+ )->data;
+ $opt->{s} = 'items' if $opt->{s} eq 'vns';
+ $opt->{s} = 'name' if $opt->{s} eq 'qscore' && !$opt->{q};
+ $opt->{t} = undef if $opt->{t} && $opt->{t} == -1; # for legacy URLs
+
+ my $where = sql_and
+ !defined $opt->{t} ? () :
+ $opt->{t} == 0 ? 'hidden AND NOT locked' :
+ $opt->{t} == 1 ? 'hidden AND locked' : 'NOT hidden',
+ defined $opt->{a} ? sql 'applicable =', \$opt->{a} : (),
+ defined $opt->{b} ? sql 'searchable =', \$opt->{b} : ();
+
+ my $table = $type eq 'g' ? 'tags' : 'traits';
+ my $count = tuwf->dbVali("SELECT COUNT(*) FROM $table t WHERE", sql_and $where, $opt->{q}->sql_where($type, 't.id'));
+ my $list = tuwf->dbPagei({ results => 50, page => $opt->{p} },'
+ SELECT t.id, name, hidden, locked, searchable, applicable, c_items,', sql_totime('added'), "as added
+ FROM $table t", $opt->{q}->sql_join($type, 't.id'), '
+ WHERE ', $where, '
+ ORDER BY', {qscore => '10 - sc.score', qw|added t.id name name items c_items|}->{$opt->{s}}, {qw|a ASC d DESC|}->{$opt->{o}}, ', id'
+ );
+
+ enrich_group $type, $list;
+
+ framework_ title => "Browse $table", index => 1, sub {
+ article_ sub {
+ h1_ "Browse $table";
+ form_ action => "/$type/list", method => 'get', sub {
+ searchbox_ $type => $opt->{q};
+ };
+ my sub opt_ {
+ my($k,$v,$lbl) = @_;
+ a_ href => '?'.query_encode(%$opt,p=>undef,$k=>$v), defined $opt->{$k} eq defined $v && (!defined $v || $opt->{$k} == $v) ? (class => 'optselected') : (), $lbl;
+ }
+ p_ class => 'browseopts', sub {
+ opt_ t => undef, 'All';
+ opt_ t => 0, 'Awaiting moderation';
+ opt_ t => 1, 'Deleted';
+ opt_ t => 2, 'Accepted';
+ };
+ p_ class => 'browseopts', sub {
+ opt_ a => undef, 'All';
+ opt_ a => 0, 'Not applicable';
+ opt_ a => 1, 'Applicable';
+ };
+ p_ class => 'browseopts', sub {
+ opt_ b => undef, 'All';
+ opt_ b => 0, 'Not searchable';
+ opt_ b => 1, 'Searchable';
+ };
+ };
+ listing_ $type, $opt, $list, $count if $count;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/TT/TagEdit.pm b/lib/VNWeb/TT/TagEdit.pm
new file mode 100644
index 00000000..115a24bf
--- /dev/null
+++ b/lib/VNWeb/TT/TagEdit.pm
@@ -0,0 +1,154 @@
+package VNWeb::TT::TagEdit;
+
+use VNWeb::Prelude;
+
+# TODO: Let users edit their own tag while it's still waiting for approval?
+
+my $FORM = {
+ id => { default => undef, vndbid => 'g' },
+ name => { maxlength => 250, regex => qr/^[^,\r\n\t]+$/ },
+ alias => { maxlength => 1024, regex => qr/^[^,]+$/, default => '' },
+ cat => { enum => \%TAG_CATEGORY, default => 'cont' },
+ description => { maxlength => 10240 },
+ searchable => { anybool => 1, default => 1 },
+ applicable => { anybool => 1, default => 1 },
+ defaultspoil => { uint => 1, range => [0,2] },
+ parents => { aoh => {
+ parent => { vndbid => 'g' },
+ main => { anybool => 1 },
+ name => { _when => 'out' },
+ } },
+ wipevotes => { _when => 'in', anybool => 1 },
+ merge => { _when => 'in out', aoh => {
+ id => { vndbid => 'g' },
+ name => { _when => 'out' },
+ } },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+
+ authmod => { _when => 'out', anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+};
+
+my $FORM_OUT = form_compile out => $FORM;
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_CMP = form_compile cmp => $FORM;
+
+
+TUWF::get qr{/$RE{grev}/edit}, sub {
+ my $g = db_entry tuwf->captures('id','rev');
+ return tuwf->resNotFound if !$g->{id};
+ return tuwf->resDenied if !can_edit g => $g;
+
+ enrich_merge parent => 'SELECT id AS parent, name FROM tags WHERE id IN', $g->{parents};
+
+ $g->{authmod} = auth->permTagmod;
+ $g->{editsum} = $g->{chrev} == $g->{maxrev} ? '' : "Reverted to revision $g->{id}.$g->{chrev}";
+ $g->{merge} = [];
+
+ framework_ title => "Edit $g->{name}", dbobj => $g, tab => 'edit', sub {
+ elm_ TagEdit => $FORM_OUT, $g;
+ };
+};
+
+
+TUWF::get qr{/(?:$RE{gid}/add|g/new)}, sub {
+ my $id = tuwf->capture('id');
+ my $g = tuwf->dbRowi('SELECT id, name, cat FROM tags WHERE NOT hidden AND id =', \$id);
+ return tuwf->resDenied if !can_edit g => {};
+ return tuwf->resNotFound if $id && !$g->{id};
+
+ my $e = elm_empty($FORM_OUT);
+ $e->{authmod} = auth->permTagmod;
+ if($id) {
+ $e->{parents} = [{ parent => $g->{id}, main => 1, name => $g->{name} }];
+ $e->{cat} = $g->{cat};
+ }
+
+ framework_ title => 'Submit a new tag', sub {
+ article_ sub {
+ h1_ 'Requesting new tag';
+ div_ class => 'notice', sub {
+ h2_ 'Your tag must be approved';
+ p_ sub {
+ txt_ 'All tags have to be approved by a moderator, so it can take a while before it will show up in the tag list'
+ .' or on visual novel pages. You can still vote on the tag even if it has not been approved yet.';
+ br_;
+ br_;
+ txt_ 'Make sure you\'ve read the '; a_ href => '/d10', 'guidelines'; txt_ ' to increase the chances of getting your tag accepted.';
+ }
+ }
+ } if !auth->permTagmod;
+ elm_ TagEdit => $FORM_OUT, $e;
+ };
+};
+
+
+elm_api TagEdit => $FORM_OUT, $FORM_IN, sub {
+ my($data) = @_;
+ my $new = !$data->{id};
+ my $e = $new ? {} : db_entry $data->{id} or return tuwf->resNotFound;
+ return tuwf->resNotFound if !$new && !$e->{id};
+ return elm_Unauth if !can_edit g => $e;
+
+ if(!auth->permTagmod) {
+ $data->{hidden} = $e->{hidden}//1;
+ $data->{locked} = $e->{locked}//0;
+ }
+
+ my $re = '[\t\s]*\n[\t\s]*';
+ my $dups = tuwf->dbAlli('
+ SELECT id, name
+ FROM (SELECT id, name FROM tags UNION SELECT id, s FROM tags, regexp_split_to_table(alias, ', \$re, ') a(s) WHERE s <> \'\') n(id,name)
+ WHERE ', sql_and(
+ $new ? () : sql('id <>', \$data->{id}),
+ sql 'lower(name) IN', [ map lc($_), $data->{name}, grep length($_), split /$re/, $data->{alias} ]
+ )
+ );
+ return elm_DupNames $dups if @$dups;
+
+ # Make sure parent IDs exists and are not a child tag of the current tag (i.e. don't allow cycles)
+ validate_dbid sub {
+ 'SELECT id FROM tags WHERE', sql_and
+ $new ? () : sql('id NOT IN(WITH RECURSIVE t(id) AS (SELECT', \$data->{id}, '::vndbid UNION SELECT tp.id FROM tags_parents tp JOIN t ON t.id = tp.parent) SELECT id FROM t)'),
+ sql 'id IN', $_[0]
+ }, map $_->{parent}, $data->{parents}->@*;
+ die "No or multiple primary parents" if $data->{parents}->@* && 1 != grep $_->{main}, $data->{parents}->@*;
+
+ $data->{description} = bb_subst_links($data->{description});
+
+ my $changed = 0;
+ if(!$new && auth->permTagmod && $data->{wipevotes}) {
+ my $num = tuwf->dbExeci('DELETE FROM tags_vn WHERE tag =', \$e->{id});
+ auth->audit(undef, 'tag wipe', "Wiped $num votes on $e->{id}");
+ $changed++;
+ }
+
+ if(!$new && auth->permTagmod && $data->{merge}->@*) {
+ my @merge = map $_->{id}, $data->{merge}->@*;
+ # Bugs:
+ # - Arbitrarily takes one vote if there are duplicates, should ideally try to merge them instead.
+ # - The 'ignore' flag will be inconsistent if set and the same VN has been voted on for multiple tags.
+ my $mov = tuwf->dbExeci('
+ INSERT INTO tags_vn (tag,vid,uid,vote,spoiler,date,ignore,notes)
+ SELECT ', \$e->{id}, ',vid,uid,vote,spoiler,date,ignore,notes
+ FROM tags_vn WHERE tag IN', \@merge, '
+ ON CONFLICT (tag,vid,uid) DO NOTHING'
+ );
+ my $del = tuwf->dbExeci('DELETE FROM tags_vn tv WHERE tag IN', \@merge);
+ my $lst = join ',', @merge;
+ auth->audit(undef, 'tag merge', "Moved $mov/$del votes from $lst to $e->{id}");
+ $changed++;
+ }
+
+ if($new || form_changed $FORM_CMP, $data, $e) {
+ my $ch = db_edit g => $e->{id}, $data;
+ elm_Redirect "/$ch->{nitemid}.$ch->{nrev}";
+ } elsif($changed) {
+ elm_Redirect "/$e->{id}";
+ } else {
+ elm_Unchanged;
+ }
+};
+
+1;
diff --git a/lib/VNWeb/Tags/Links.pm b/lib/VNWeb/TT/TagLinks.pm
index e3f74aa6..7b178d58 100644
--- a/lib/VNWeb/Tags/Links.pm
+++ b/lib/VNWeb/TT/TagLinks.pm
@@ -1,14 +1,14 @@
-package VNWeb::Tags::Links;
+package VNWeb::TT::TagLinks;
use VNWeb::Prelude;
-use VNWeb::Tags::Lib;
+use VNWeb::TT::Lib;
sub listing_ {
my($opt, $lst, $np, $url) = @_;
paginate_ $url, $opt->{p}, $np, 't';
- div_ class => 'mainbox browse taglinks', sub {
+ article_ class => 'browse taglinks', sub {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'date', $opt, $url; debug_ $lst; };
@@ -16,31 +16,37 @@ sub listing_ {
td_ class => 'tc3', 'Rating';
td_ class => 'tc4', sub { txt_ 'Tag'; sortable_ 'tag', $opt, $url };
td_ class => 'tc5', 'Spoiler';
- td_ class => 'tc6', 'Visual novel';
- td_ class => 'tc7', 'Note';
+ td_ class => 'tc6', 'Lie';
+ td_ class => 'tc7', 'Visual novel';
+ td_ class => 'tc8', 'Note';
}};
tr_ sub {
my $i = $_;
td_ class => 'tc1', fmtdate $i->{date};
td_ class => 'tc2', sub {
- a_ href => $url->(u => $i->{uid}, p=>undef), class => 'setfil', '> ' if !defined $opt->{u};
+ a_ href => $url->(u => $i->{uid}, p=>undef), class => 'setfil', '> ' if $i->{uid} && !defined $opt->{u} && (defined $i->{user_name} || auth->isMod);
user_ $i;
};
td_ class => 'tc3', sub { tagscore_ $i->{vote}, $i->{ignore} };
td_ class => 'tc4', sub {
a_ href => $url->(t => $i->{tag}, p=>undef), class => 'setfil', '> ' if !defined $opt->{t};
- a_ href => "/g$i->{tag}", $i->{name};
+ a_ href => "/$i->{tag}", $i->{name};
};
td_ class => 'tc5', sub {
my $s = !defined $i->{spoiler} ? '' : fmtspoil $i->{spoiler};
- b_ class => 'grayedout', $s if $i->{ignore};
+ small_ $s if $i->{ignore};
txt_ $s if !$i->{ignore};
};
td_ class => 'tc6', sub {
+ my $s = !defined $i->{lie} ? '' : $i->{lie} ? '+' : '-';
+ small_ $s if $i->{ignore};
+ txt_ $s if !$i->{ignore};
+ };
+ td_ class => 'tc7', sub {
a_ href => $url->(v => $i->{vid}, p=>undef), class => 'setfil', '> ' if !defined $opt->{v};
- a_ href => "/v$i->{vid}", shorten $i->{title}, 50;
+ a_ href => "/$i->{vid}", tattr $i;
};
- td_ class => 'tc7', $i->{notes};
+ td_ class => 'tc8', sub { lit_ bb_format $i->{notes}, inline => 1 };
} for @$lst;
};
};
@@ -53,11 +59,14 @@ TUWF::get qr{/g/links}, sub {
p => { page => 1 },
o => { onerror => 'd', enum => ['a', 'd'] },
s => { onerror => 'date', enum => [qw|date tag|] },
- v => { onerror => undef, id => 1 },
- u => { onerror => undef, id => 1 },
- t => { onerror => undef, id => 1 },
+ v => { onerror => undef, vndbid => 'v' },
+ u => { onerror => undef, vndbid => 'u' },
+ t => { onerror => undef, vndbid => 'g' },
)->data;
+ my $u = $opt->{u} && tuwf->dbRowi('SELECT id,', sql_user(), 'FROM users u WHERE id =', \$opt->{u});
+ return tuwf->resNotFound if $opt->{u} && (!$u->{id} || (!defined $u->{user_name} && !auth->isMod));
+
my $where = sql_and
defined $opt->{v} ? sql('tv.vid =', \$opt->{v}) : (),
defined $opt->{u} ? sql('tv.uid =', \$opt->{u}) : (),
@@ -67,10 +76,11 @@ TUWF::get qr{/g/links}, sub {
my $count = $filt && tuwf->dbVali('SELECT COUNT(*) FROM tags_vn tv WHERE', $where);
my($lst, $np) = tuwf->dbPagei({ page => $opt->{p}, results => 50 }, '
- SELECT tv.vid, tv.uid, tv.tag, tv.vote, tv.spoiler,', sql_totime('tv.date'), 'as date, tv.ignore, tv.notes, v.title,', sql_user(), ', t.name
+ SELECT tv.vid, tv.uid, tv.tag, tv.vote, tv.spoiler, tv.lie,', sql_totime('tv.date'), 'as date
+ , tv.ignore OR (u.id IS NOT NULL AND NOT u.perm_tag) AS ignore, tv.notes, v.title, ', sql_user(), ', t.name
FROM tags_vn tv
- JOIN vn v ON v.id = tv.vid
- JOIN users u ON u.id = tv.uid
+ JOIN', vnt, 'v ON v.id = tv.vid
+ LEFT JOIN users u ON u.id = tv.uid
JOIN tags t ON t.id = tv.tag
WHERE', $where, '
ORDER BY', { date => 'tv.date', tag => 't.name' }->{$opt->{s}}, { a => 'ASC', d => 'DESC' }->{$opt->{o}}
@@ -80,7 +90,7 @@ TUWF::get qr{/g/links}, sub {
my sub url { '?'.query_encode %$opt, @_ }
framework_ title => 'Tag link browser', sub {
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ 'Tag link browser';
if($filt) {
p_ 'Active filters:';
@@ -88,17 +98,18 @@ TUWF::get qr{/g/links}, sub {
li_ sub {
txt_ '['; a_ href => url(u=>undef, p=>undef), 'remove'; txt_ '] ';
txt_ 'User: ';
- user_ tuwf->dbRowi('SELECT', sql_user(), 'FROM users u WHERE id=', \$opt->{u});
+ user_ $u;
} if defined $opt->{u};
li_ sub {
txt_ '['; a_ href => url(t=>undef, p=>undef), 'remove'; txt_ '] ';
txt_ 'Tag:'; txt_ ' ';
- a_ href => "/g$opt->{t}", tuwf->dbVali('SELECT name FROM tags WHERE id=', \$opt->{t})||'Unknown tag';
+ a_ href => "/$opt->{t}", tuwf->dbVali('SELECT name FROM tags WHERE id=', \$opt->{t})||'Unknown tag';
} if defined $opt->{t};
li_ sub {
txt_ '['; a_ href => url(v=>undef, p=>undef), 'remove'; txt_ '] ';
txt_ 'Visual novel'; txt_ ' ';
- a_ href => "/v$opt->{v}", tuwf->dbVali('SELECT title FROM vn WHERE id=', \$opt->{v})||'Unknown VN';
+ my $v = tuwf->dbRowi('SELECT title FROM', vnt, 'v WHERE id=', \$opt->{v});
+ a_ href => "/$opt->{v}", $v->{title} ? tattr $v : ('Unknown VN');
} if defined $opt->{v};
}
}
diff --git a/lib/VNWeb/TT/TagPage.pm b/lib/VNWeb/TT/TagPage.pm
new file mode 100644
index 00000000..c23a7cbe
--- /dev/null
+++ b/lib/VNWeb/TT/TagPage.pm
@@ -0,0 +1,161 @@
+package VNWeb::TT::TagPage;
+
+use VNWeb::Prelude;
+use VNWeb::Filters;
+use VNWeb::AdvSearch;
+use VNWeb::VN::List;
+use VNWeb::TT::Lib 'tree_', 'parents_';
+
+
+sub rev_ {
+ my($t) = @_;
+ sub enrich_item {
+ enrich_merge parent => 'SELECT id AS parent, name FROM tags WHERE id IN', $_[0]{parents};
+ $_[0]{parents} = [ sort { $a->{name} cmp $b->{name} || $a->{parent} <=> $b->{parent} } $_[0]{parents}->@* ];
+ }
+ enrich_item $t;
+ revision_ $t, \&enrich_item,
+ [ name => 'Name' ],
+ [ alias => 'Aliases' ],
+ [ cat => 'Category', fmt => \%TAG_CATEGORY ],
+ [ description => 'Description' ],
+ [ searchable => 'Searchable', fmt => 'bool' ],
+ [ applicable => 'Applicable', fmt => 'bool' ],
+ [ defaultspoil => 'Default spoiler level' ],
+ [ parents => 'Parent tags', fmt => sub { a_ href => "/$_->{parent}", $_->{name}; txt_ ' (primary)' if $_->{main} } ];
+}
+
+
+sub infobox_ {
+ my($t) = @_;
+
+ p_ class => 'mainopts', sub {
+ a_ href => "/$t->{id}/add", 'Create child tag';
+ } if !$t->{hidden} && can_edit g => {};
+ h1_ "Tag: $t->{name}";
+ debug_ $t;
+
+ parents_ g => $t;
+
+ div_ class => 'description', sub {
+ lit_ bb_format $t->{description};
+ } if $t->{description};
+
+ my @prop = (
+ $t->{searchable} ? () : 'Not searchable.',
+ $t->{applicable} ? () : 'Can not be directly applied to visual novels.'
+ );
+ p_ class => 'center', sub {
+ strong_ 'Properties';
+ br_;
+ join_ \&br_, sub { txt_ $_ }, @prop;
+ } if @prop;
+
+ p_ class => 'center', sub {
+ strong_ 'Category';
+ br_;
+ txt_ $TAG_CATEGORY{$t->{cat}};
+ };
+
+ p_ class => 'center', sub {
+ strong_ 'Aliases';
+ br_;
+ join_ \&br_, sub { txt_ $_ }, split /\n/, $t->{alias};
+ } if $t->{alias};
+}
+
+
+my $TABLEOPTS = VNWeb::VN::List::TABLEOPTS('tags');
+
+
+sub vns_ {
+ my($t) = @_;
+
+ my $opt = tuwf->validate(get =>
+ p => { upage => 1 },
+ f => { advsearch_err => 'v' },
+ s => { tableopts => $TABLEOPTS },
+ m => { onerror => [auth->pref('spoilers')||0], type => 'array', scalar => 1, minlength => 1, values => { enum => [0..2] } },
+ l => { onerror => [''], type => 'array', scalar => 1, minlength => 1, values => { anybool => 1 } },
+ fil => { onerror => '' },
+ )->data;
+ $opt->{m} = $opt->{m}[0];
+ $opt->{l} = $opt->{l}[0];
+
+ # URL compatibility with old filters
+ if(!$opt->{f}->{query} && $opt->{fil}) {
+ my $q = eval {
+ my $f = filter_parse v => $opt->{fil};
+ # Old URLs often had the tag ID as part of the filter, let's remove that.
+ $f->{tag_inc} = [ grep "g$_" ne $t->{id}, $f->{tag_inc}->@* ] if $f->{tag_inc};
+ delete $f->{tag_inc} if $f->{tag_inc} && !$f->{tag_inc}->@*;
+ $f = filter_vn_adv $f;
+ tuwf->compile({ advsearch => 'v' })->validate(@$f > 1 ? $f : undef)->data;
+ };
+ return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q;
+ }
+
+ $opt->{f} = advsearch_default 'v' if !$opt->{f}{query} && !defined tuwf->reqGet('f');
+
+ my $where = sql_and
+ 'NOT v.hidden',
+ $opt->{l} ? 'NOT tvi.lie' : (),
+ sql('tvi.tag =', \$t->{id}),
+ sql('tvi.spoiler <=', \$opt->{m}),
+ $opt->{f}->sql_where();
+
+ my $time = time;
+ my($count, $list);
+ db_maytimeout {
+ $count = tuwf->dbVali('SELECT count(*) FROM vn v JOIN tags_vn_inherit tvi ON tvi.vid = v.id WHERE', $where);
+ $list = $count ? tuwf->dbPagei({results => $opt->{s}->results(), page => $opt->{p}}, '
+ SELECT tvi.rating AS tagscore, v.id, v.title, v.c_released, v.c_votecount, v.c_rating, v.c_average
+ , v.image, v.c_platforms::text[] AS platforms, v.c_languages::text[] AS lang',
+ $opt->{s}->vis('length') ? ', v.length, v.c_length, v.c_lengthnum' : (), '
+ FROM', vnt, 'v
+ JOIN tags_vn_inherit tvi ON tvi.vid = v.id
+ WHERE', $where, '
+ ORDER BY', $opt->{s}->sql_order(),
+ ) : [];
+ } || (($count, $list) = (undef, []));
+
+ VNWeb::VN::List::enrich_listing 1, $opt, $list;
+ $time = time - $time;
+
+ form_ action => "/$t->{id}", method => 'get', sub {
+ article_ sub {
+ p_ class => 'mainopts', sub {
+ a_ href => "/g/links?t=$t->{id}", 'Recently tagged';
+ };
+ h1_ 'Visual novels';
+ p_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'm', value => 0, $opt->{m} == 0 ? (class => 'optselected') : (), 'Hide spoilers';
+ button_ type => 'submit', name => 'm', value => 1, $opt->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers';
+ button_ type => 'submit', name => 'm', value => 2, $opt->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!';
+ };
+ p_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'l', value => 0, !$opt->{l} ? (class => 'optselected') : (), 'Include lies';
+ button_ type => 'submit', name => 'l', value => 1, $opt->{l} ? (class => 'optselected') : (), 'Exclude lies';
+ };
+ input_ type => 'hidden', name => 'm', value => $opt->{m};
+ input_ type => 'hidden', name => 'l', value => $opt->{l};
+ $opt->{f}->elm_($count, $time);
+ };
+ VNWeb::VN::List::listing_ $opt, $list, $count, 1 if $count;
+ };
+}
+
+
+TUWF::get qr{/$RE{grev}}, sub {
+ my $t = db_entry tuwf->captures('id', 'rev');
+ return tuwf->resNotFound if !$t->{id};
+
+ framework_ index => !tuwf->capture('rev'), title => "Tag: $t->{name}", dbobj => $t, hiddenmsg => 1, sub {
+ rev_ $t if tuwf->capture('rev');
+ article_ sub { infobox_ $t; };
+ tree_ g => $t->{id};
+ vns_ $t if $t->{searchable} && !$t->{hidden};
+ };
+};
+
+1;
diff --git a/lib/VNWeb/TT/TraitEdit.pm b/lib/VNWeb/TT/TraitEdit.pm
new file mode 100644
index 00000000..f92efd58
--- /dev/null
+++ b/lib/VNWeb/TT/TraitEdit.pm
@@ -0,0 +1,134 @@
+package VNWeb::TT::TraitEdit;
+
+use VNWeb::Prelude;
+
+my $FORM = {
+ id => { default => undef, vndbid => 'i' },
+ name => { maxlength => 250, regex => qr/^[^,\r\n\t]+$/ },
+ alias => { maxlength => 1024, regex => qr/^[^,]+$/, default => '' },
+ sexual => { anybool => 1 },
+ description => { maxlength => 10240 },
+ searchable => { anybool => 1, default => 1 },
+ applicable => { anybool => 1, default => 1 },
+ defaultspoil => { uint => 1, range => [0,2] },
+ parents => { aoh => {
+ parent => { vndbid => 'i' },
+ main => { anybool => 1 },
+ name => { _when => 'out' },
+ group => { _when => 'out', default => undef },
+ } },
+ gorder => { uint => 1 },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+
+ authmod => { _when => 'out', anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+};
+
+my $FORM_OUT = form_compile out => $FORM;
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_CMP = form_compile cmp => $FORM;
+
+
+TUWF::get qr{/$RE{irev}/edit}, sub {
+ my $e = db_entry tuwf->captures('id','rev');
+ return tuwf->resNotFound if !$e->{id};
+ return tuwf->resDenied if !can_edit i => $e;
+
+ enrich_merge parent => '
+ SELECT i.id AS parent, i.name, g.name AS group
+ FROM traits i LEFT JOIN traits g ON g.id = i.gid WHERE i.id IN', $e->{parents};
+
+ $e->{authmod} = auth->permTagmod;
+ $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}";
+
+ framework_ title => "Edit $e->{name}", dbobj => $e, tab => 'edit', sub {
+ elm_ TraitEdit => $FORM_OUT, $e;
+ };
+};
+
+
+TUWF::get qr{/(?:$RE{iid}/add|i/new)}, sub {
+ my $id = tuwf->capture('id');
+ my $i = tuwf->dbRowi('SELECT i.id AS parent, i.name, g.name AS "group", i.sexual FROM traits i LEFT JOIN traits g ON g.id = i.gid WHERE i.id =', \$id);
+ return tuwf->resDenied if !can_edit i => {};
+ return tuwf->resNotFound if $id && !$i->{parent};
+
+ my $e = elm_empty($FORM_OUT);
+ $e->{authmod} = auth->permTagmod;
+ if($id) {
+ $i->{main} = 1;
+ $e->{parents} = [$i];
+ $e->{sexual} = $i->{sexual};
+ }
+
+ framework_ title => 'Submit a new trait', sub {
+ article_ sub {
+ h1_ 'Requesting new trait';
+ div_ class => 'notice', sub {
+ h2_ 'Your trait must be approved';
+ p_ sub {
+ txt_ 'All traits have to be approved by a moderator, so it can take a while before it will show up in the trait list.';
+ br_;
+ br_;
+ txt_ 'Make sure you\'ve read the '; a_ href => '/d10', 'guidelines'; txt_ ' to increase the chances of getting your trait accepted.';
+ }
+ }
+ } if !auth->permTagmod;
+ elm_ TraitEdit => $FORM_OUT, $e;
+ };
+};
+
+
+elm_api TraitEdit => $FORM_OUT, $FORM_IN, sub {
+ my($data) = @_;
+ my $new = !$data->{id};
+ my $e = $new ? {} : db_entry $data->{id} or return tuwf->resNotFound;
+ return tuwf->resNotFound if !$new && !$e->{id};
+ return elm_Unauth if !can_edit i => $e;
+
+ if(!auth->permTagmod) {
+ $data->{hidden} = $e->{hidden}//1;
+ $data->{locked} = $e->{locked}//0;
+ }
+ $data->{gorder} = 0 if $data->{parents}->@*;
+
+ # Make sure parent IDs exists and are not a child trait of the current trait (i.e. don't allow cycles)
+ my @parents = map $_->{parent}, $data->{parents}->@*;
+ validate_dbid sub {
+ 'SELECT id FROM traits WHERE', sql_and
+ $new ? () : sql('id NOT IN(WITH RECURSIVE t(id) AS (SELECT', \$e->{id}, '::vndbid UNION SELECT tp.id FROM traits_parents tp JOIN t ON t.id = tp.parent) SELECT id FROM t)'),
+ sql 'id IN', $_[0]
+ }, @parents;
+ die "No or multiple primary parents" if $data->{parents}->@* && 1 != grep $_->{main}, $data->{parents}->@*;
+
+ my $group = tuwf->dbVali('SELECT coalesce(gid,id) FROM traits WHERE id =', \[grep $_->{main}, $data->{parents}->@*]->[0]{parent});
+
+ $data->{description} = bb_subst_links($data->{description});
+
+ # (Ideally this checks all groups that this trait applies in, but that's more annoying to implement)
+ my $re = '[\t\s]*\n[\t\s]*';
+ my $dups = tuwf->dbAlli('
+ SELECT n.id, n.name
+ FROM (SELECT id, name FROM traits UNION ALL SELECT id, s FROM traits, regexp_split_to_table(alias, ', \$re, ') a(s) WHERE s <> \'\') n(id,name)
+ JOIN traits t ON n.id = t.id
+ WHERE ', sql_and(
+ $new ? () : sql('n.id <>', \$e->{id}),
+ sql('t.gid IS NOT DISTINCT FROM', \$group),
+ sql 'lower(n.name) IN', [ map lc($_), $data->{name}, grep length($_), split /$re/, $data->{alias} ]
+ )
+ );
+ return elm_DupNames $dups if @$dups;
+
+ return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e;
+ my $ch = db_edit i => $e->{id}, $data;
+ tuwf->dbExeci('UPDATE traits SET gid = null WHERE id =', \$ch->{nitemid}) if !$group;
+ tuwf->dbExeci('
+ WITH RECURSIVE childs (id) AS (
+ SELECT ', \$ch->{nitemid}, '::vndbid UNION ALL SELECT tp.id FROM childs JOIN traits_parents tp ON tp.parent = childs.id AND tp.main
+ ) UPDATE traits SET gid =', \$group, 'WHERE id IN(SELECT id FROM childs) AND gid IS DISTINCT FROM', \$group
+ ) if $group;
+ elm_Redirect "/$ch->{nitemid}.$ch->{nrev}";
+};
+
+1;
diff --git a/lib/VNWeb/TT/TraitPage.pm b/lib/VNWeb/TT/TraitPage.pm
new file mode 100644
index 00000000..c120d645
--- /dev/null
+++ b/lib/VNWeb/TT/TraitPage.pm
@@ -0,0 +1,149 @@
+package VNWeb::TT::TraitPage;
+
+use VNWeb::Prelude;
+use VNWeb::Filters;
+use VNWeb::AdvSearch;
+use VNWeb::Images::Lib;
+use VNWeb::TT::Lib 'tree_', 'parents_';
+
+
+sub rev_ {
+ my($t) = @_;
+ sub enrich_item {
+ enrich_merge parent => 'SELECT id AS parent, name FROM traits WHERE id IN', $_[0]{parents};
+ $_[0]{parents} = [ sort { $a->{name} cmp $b->{name} || $a->{parent} <=> $b->{parent} } $_[0]{parents}->@* ];
+ }
+ enrich_item $t;
+ revision_ $t, \&enrich_item,
+ [ name => 'Name' ],
+ [ alias => 'Aliases' ],
+ [ description => 'Description' ],
+ [ sexual => 'Sexual content',fmt => 'bool' ],
+ [ searchable => 'Searchable', fmt => 'bool' ],
+ [ applicable => 'Applicable', fmt => 'bool' ],
+ [ defaultspoil => 'Default spoiler level' ],
+ [ gorder => 'Sort order' ],
+ [ parents => 'Parent traits', fmt => sub { a_ href => "/$_->{parent}", $_->{name}; txt_ ' (primary)' if $_->{main} } ];
+}
+
+
+sub infobox_ {
+ my($t) = @_;
+
+ p_ class => 'mainopts', sub {
+ a_ href => "/$t->{id}/add", 'Create child trait';
+ } if !$t->{hidden} && can_edit i => {};
+ h1_ "Trait: $t->{name}";
+ debug_ $t;
+
+ parents_ i => $t;
+
+ div_ class => 'description', sub {
+ lit_ bb_format $t->{description};
+ } if $t->{description};
+
+ my @prop = (
+ !$t->{sexual} ? () : 'Indicates sexual content.',
+ $t->{searchable} ? () : 'Not searchable.',
+ $t->{applicable} ? () : 'Can not be directly applied to characters.',
+ );
+ p_ class => 'center', sub {
+ strong_ 'Properties';
+ br_;
+ join_ \&br_, sub { txt_ $_ }, @prop;
+ } if @prop;
+
+ p_ class => 'center', sub {
+ strong_ 'Aliases';
+ br_;
+ join_ \&br_, sub { txt_ $_ }, split /\n/, $t->{alias};
+ } if $t->{alias};
+}
+
+
+sub chars_ {
+ my($t) = @_;
+
+ my $opt = tuwf->validate(get =>
+ p => { upage => 1 },
+ f => { advsearch_err => 'c' },
+ m => { onerror => [auth->pref('spoilers')||0], type => 'array', scalar => 1, minlength => 1, values => { enum => [0..2] } },
+ l => { onerror => [''], type => 'array', scalar => 1, minlength => 1, values => { anybool => 1 } },
+ fil => { onerror => '' },
+ s => { tableopts => $VNWeb::Chars::List::TABLEOPTS },
+ )->data;
+ $opt->{m} = $opt->{m}[0];
+ $opt->{l} = $opt->{l}[0];
+
+ # URL compatibility with old filters
+ if(!$opt->{f}->{query} && $opt->{fil}) {
+ my $q = eval {
+ my $f = filter_parse c => $opt->{fil};
+ # Old URLs often had the trait ID as part of the filter, let's remove that.
+ $f->{trait_inc} = [ grep "i$_" ne $t->{id}, $f->{trait_inc}->@* ] if $f->{trait_inc};
+ delete $f->{trait_inc} if $f->{trait_inc} && !$f->{trait_inc}->@*;
+ $f = filter_char_adv $f;
+ tuwf->compile({ advsearch => 'c' })->validate(@$f > 1 ? $f : undef)->data;
+ };
+ return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, f => $q), 'perm') if $q;
+ }
+
+ $opt->{f} = advsearch_default 'c' if !$opt->{f}{query} && !defined tuwf->reqGet('f');
+
+ my $where = sql_and
+ 'NOT c.hidden',
+ $opt->{l} ? 'NOT tc.lie' : (),
+ sql('tc.tid =', \$t->{id}),
+ sql('tc.spoil <=', \$opt->{m}),
+ $opt->{f}->sql_where();
+
+ my $time = time;
+ my($count, $list);
+ db_maytimeout {
+ $count = tuwf->dbVali('SELECT count(*) FROM chars c JOIN traits_chars tc ON tc.cid = c.id WHERE', $where);
+ $list = $count ? tuwf->dbPagei({results => $opt->{s}->results(), page => $opt->{p}}, '
+ SELECT c.id, c.title, c.gender, c.image
+ FROM', charst, 'c
+ JOIN traits_chars tc ON tc.cid = c.id
+ WHERE', $where, '
+ ORDER BY c.sorttitle, c.id'
+ ) : [];
+ } || (($count, $list) = (undef, []));
+
+ VNWeb::Chars::List::enrich_listing $list;
+ enrich_image_obj image => $list if !$opt->{s}->rows;
+ $time = time - $time;
+
+ form_ action => "/$t->{id}", method => 'get', sub {
+ article_ sub {
+ h1_ 'Characters';
+ p_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'm', value => 0, $opt->{m} == 0 ? (class => 'optselected') : (), 'Hide spoilers';
+ button_ type => 'submit', name => 'm', value => 1, $opt->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers';
+ button_ type => 'submit', name => 'm', value => 2, $opt->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!';
+ };
+ p_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'l', value => 0, !$opt->{l} ? (class => 'optselected') : (), 'Include lies';
+ button_ type => 'submit', name => 'l', value => 1, $opt->{l} ? (class => 'optselected') : (), 'Exclude lies';
+ };
+ input_ type => 'hidden', name => 'm', value => $opt->{m};
+ $opt->{f}->elm_($count, $time);
+ };
+ VNWeb::Chars::List::listing_ $opt, $list, $count, 1 if $count;
+ };
+}
+
+
+TUWF::get qr{/$RE{irev}}, sub {
+ my $t = db_entry tuwf->captures('id', 'rev');
+ return tuwf->resNotFound if !$t->{id};
+
+ framework_ index => !$t->{hidden}, title => "Trait: $t->{name}", dbobj => $t, hiddenmsg => 1, sub {
+ rev_ $t if tuwf->capture('rev');
+ article_ sub { infobox_ $t; };
+ tree_ i => $t->{id};
+ chars_ $t if $t->{searchable} && !$t->{hidden};
+ };
+};
+
+1;
diff --git a/lib/VNWeb/TableOpts.pm b/lib/VNWeb/TableOpts.pm
new file mode 100644
index 00000000..42885fa1
--- /dev/null
+++ b/lib/VNWeb/TableOpts.pm
@@ -0,0 +1,297 @@
+package VNWeb::TableOpts;
+
+# This is a helper module to handle passing around various table display
+# options in a single compact query parameter.
+#
+# Supported options:
+#
+# Sort column & order
+# Number of results per page
+# View: rows, cards or grid
+# Which columns are visible
+#
+# Out of scope: pagination & filtering.
+#
+# Usage:
+#
+# my $config = tableopts
+# # Which views are supported (default: all)
+# _views => [ 'rows', 'cards', 'grid' ],
+#
+# # SQL column in the users table to store the saved default
+# _pref => 'tableopts_something',
+#
+# # Column config.
+# # The key names are only used internally.
+# title => {
+# name => 'Title', # Column name, used in the configuration box.
+# compat => 'title', # Name of this column for compatibility with old URLs that referred to the column by name.
+# sort_id => 0, # This column can be sorted on, option indicates numeric identifier (must be stable)
+# sort_sql => 'v.title', # SQL to generate when sorting on this column,
+# # may include '?o' placeholder that will be replaced with selected ASC/DESC,
+# # or '!o' as placeholder for the opposite.
+# # If no placeholders are present, the ASC/DESC will be added automatically.
+# sort_num => 0/1, # Whether this is a numeric field, used in the UI to display "1→9" instead of "A→Z".
+# sort_default => 'asc', # Set to 'asc' or 'desc' if this column should be sorted on by default.
+# },
+# popularity => {
+# name => 'Popularity',
+# sort_id => 1,
+# sort_sql => 'v.c_popularity ?o, v.title',
+# vis_id => 0, # This column can be hidden/visible, option indicates numeric identifier
+# vis_default => 1, # If this column should be visible by default
+# };
+#
+# my $opts = tuwf->validate(get => s => { tableopts => $config })->data;
+#
+# my $sql = sql('.... ORDER BY', $opts->sql_order);
+#
+# $opts->view; # Current view, 'rows', 'cards' or 'grid'
+# $opts->results; # How many results to display
+# $opts->vis('popularity'); # is the column visible?
+#
+#
+#
+# Table options are encoded in a base64-encoded 31 bits integer (can be
+# extended, but bitwise operations in JS are quirky beyond 31 bits).
+# The bit layout is as follows, 0 being the least significant bit:
+#
+# 0 - 1: view 0: rows, 1: cards, 2: grid (3: unused)
+# 2 - 4: results 0: 50, 1: 10, 2: 25, 3: 100, 4: 200 (5-7: unused)
+# 5: order 0: ascending, 1: descending
+# 6 - 11: sort column, identifier used in the configuration
+# 12 - 31: column visibility, identifier in the configuration is used as bit index (12+$vis_id)
+#
+# This supports 64 column identifiers for sorting, 19 identifiers for visibility.
+
+use v5.26;
+use Carp 'croak';
+use Exporter 'import';
+use TUWF ':html5_';
+use VNWeb::Auth;
+use VNWeb::HTML ();
+use VNWeb::Validation;
+use VNWeb::JS;
+
+our @EXPORT = ('tableopts');
+
+my @alpha = (0..9, 'a'..'z', 'A'..'Z', '_', '-');
+my %alpha = map +($alpha[$_],$_), 0..$#alpha;
+sub _enc { ($_[0] >= @alpha ? _enc(int $_[0]/@alpha) : '').$alpha[$_[0]%@alpha] }
+sub _dec { return if length $_[0] > 6; my $n = 0; $n = $n*@alpha + ($alpha{$_}//return) for split //, $_[0]; $n }
+
+my @views = qw|rows cards grid|;
+my %views = map +($views[$_], $_), 0..$#views;
+
+my @results = (50, 10, 25, 100, 200);
+my %results = map +($results[$_], $_), 0..$#results;
+
+
+# Turn config options into something more efficient to work with
+sub tableopts {
+ my %o = (
+ sort_ids => [], # identifier => column config hash
+ col_order => [], # column config hashes in the order listed in the config
+ columns => {}, # column name => config hash
+ views => [], # supported views, as numbers
+ default => 0, # default settings, integer form
+ );
+ my @vis;
+ while(@_) {
+ my($k,$v) = (shift,shift);
+ if($k eq '_views') {
+ $o{views} = [ map $views{$_}//croak("unknown view: $_"), ref $v ? @$v : $v ];
+ next;
+ }
+ if($k eq '_pref') {
+ $o{pref} = $v;
+ next;
+ }
+ $o{columns}{$k} = $v;
+ $v->{id} = $k;
+ push $o{col_order}->@*, $v;
+ if(defined $v->{sort_id}) {
+ die "Duplicate sort_id $v->{sort_id}\n" if $o{sort_ids}[$v->{sort_id}];
+ $o{sort_ids}[$v->{sort_id}] = $v;
+ }
+ die "Duplicate vis_id $v->{vis_id}\n" if defined $v->{vis_id} && $vis[$v->{vis_id}]++;
+ $o{default} |= ($v->{sort_id} << 6) | ({qw|asc 0 desc 32|}->{$v->{sort_default}}//croak("unknown sort_default: $v->{sort_default}")) if $v->{sort_default};
+ $o{default} |= 1 << ($v->{vis_id} + 12) if $v->{vis_default};
+ }
+ $o{views} ||= [0];
+ $o{default} |= $o{views}[0];
+ #warn "=== ".($o{pref}||'undef')."\n"; dump_ids(\%o);
+ \%o
+}
+
+
+# COMPAT: For old URLs, we assume that this validation is used on the 's'
+# parameter, so we can accept two formats:
+# - "s=$compat_sort_column/$order"
+# - "s=$compat_sort_column&o=$order"
+# In the latter case, the validation will use reqGet() to get the 'o'
+# parameter.
+TUWF::set('custom_validations')->{tableopts} = sub {
+ my($t) = @_;
+ +{ onerror => sub {
+ my $d = $t->{pref} && auth->pref($t->{pref});
+ my $o = bless([$d // $t->{default},$t], __PACKAGE__);
+ $o->fixup;
+ }, func => sub {
+ my $obj = bless [undef, $t], __PACKAGE__;
+ my($val,$ord) = $_[0] =~ m{^([^/]+)/([ad])$} ? ($1,$2) : ($_[0],undef);
+ my $col = [grep $_->{compat} && $_->{compat} eq $val, values $t->{columns}->%*]->[0];
+ if($col && defined $col->{sort_id}) {
+ $obj->[0] = $t->{default};
+ $obj->set_sort_col_id($col->{sort_id});
+ $ord //= tuwf->reqGet('o');
+ $obj->set_order($ord && $ord eq 'd' ? 1 : 0);
+ } else {
+ $obj->[0] = _dec($_[0]) // return 0;
+ }
+ $_[0] = $obj->fixup;
+ # We could do strict validation on the individual fields, but the methods below can handle incorrect data.
+ 1;
+ } }
+};
+
+sub fixup {
+ my($obj) = @_;
+ # Reset sort_col and order to their default if the current sort_col id does not exist.
+ if(!$obj->[1]{sort_ids}[ $obj->sort_col_id ]) {
+ $obj->set_sort_col_id(sort_col_id([$obj->[1]{default}]));
+ $obj->set_order(order([$obj->[1]{default}]));
+ }
+ $obj
+}
+
+sub query_encode { _enc $_[0][0] }
+
+sub view { $views[$_[0][0] & 3] || $views[$_[0][1]{views}[0]] }
+sub rows { shift->view eq 'rows' }
+sub cards { shift->view eq 'cards' }
+sub grid { shift->view eq 'grid' }
+
+sub results { $results[($_[0][0] >> 2) & 7] || $results[0] }
+
+sub order { $_[0][0] & 32 }
+sub set_order { if($_[1]) { $_[0][0] |= 32 } else { $_[0][0] &= ~32 } }
+
+sub sort_col_id { ($_[0][0] >> 6) & 63 }
+sub set_sort_col_id { $_[0][0] = ($_[0][0] & (~0 - 0b111111000000)) | ($_[1] << 6) }
+
+# Given a view id, return a new object with that view selected.
+sub view_param {
+ my($self, $view) = @_;
+ my $n = bless [@$self], __PACKAGE__;
+ $n->[0] = ($n->[0] & ~3) | $view;
+ $n
+}
+
+
+# Given the key of a column, returns whether it is currently sorted on ('' / 'a' / 'd')
+sub sorted {
+ my($self, $key) = @_;
+ $self->[1]{columns}{$key}{sort_id} != $self->sort_col_id ? '' : $self->order ? 'd' : 'a';
+}
+
+# Given the key of a column and the desired order ('a'/'d'), returns a new object with that sorting applied.
+sub sort_param {
+ my($self, $key, $o) = @_;
+ my $n = bless [@$self], __PACKAGE__;
+ $n->set_order($o eq 'a' ? 0 : 1);
+ $n->set_sort_col_id($self->[1]{columns}{$key}{sort_id});
+ $n
+}
+
+# Returns an SQL expression suitable for use in an ORDER BY clause.
+sub sql_order {
+ my($self) = @_;
+ my($v,$o) = $self->@*;
+ my $col = $o->{sort_ids}[ $self->sort_col_id ];
+ die "No column to sort on" if !$col;
+ my $order = $self->order ? 'DESC' : 'ASC';
+ my $opposite_order = $self->order ? 'ASC' : 'DESC';
+ my $sql = $col->{sort_sql};
+ $sql =~ /[?!]o/ ? ($sql =~ s/\?o/$order/rg =~ s/!o/$opposite_order/rg) : "$sql $order";
+}
+
+
+# Returns whether the given column key is visible.
+sub vis { my $c = $_[0][1]{columns}{$_[1]}; $c && defined $c->{vis_id} && ($_[0][0] & (1 << (12+$c->{vis_id}))) }
+
+# Given a list of column names, return a new object with only these columns visible
+sub vis_param {
+ my($self, @cols) = @_;
+ my $n = bless [@$self], __PACKAGE__;
+ $n->[0] = $n->[0] & 0b1111_1111_1111;
+ $n->[0] |= 1 << (12+$self->[1]{columns}{$_}{vis_id}) for @cols;
+ $n;
+}
+
+
+my $FORM_OUT = form_compile any => {
+ save => { default => undef },
+ views => { type => 'array', values => { uint => 1 } },
+ value => { uint => 1 },
+ default => { uint => 1 },
+ usaved => { uint => 1, default => undef },
+ sorts => { aoh => { id => { uint => 1 }, name => {}, num => { anybool => 1 } } },
+ vis => { aoh => { id => { uint => 1 }, name => {} } },
+};
+
+js_api TableOptsSave => {
+ save => { enum => ['tableopts_c', 'tableopts_v', 'tableopts_vt'] },
+ value => { default => undef, uint => 1 }
+}, sub {
+ my($f) = @_;
+ return tuwf->resDenied if !auth;
+ tuwf->dbExeci('UPDATE users_prefs SET', { $f->{save} => $f->{value} }, 'WHERE id =', \auth->uid);
+ {}
+};
+
+
+sub widget_ {
+ my($self,$url) = @_;
+ my($v,$o) = $self->@*;
+ menu_ class => 'tableopts', VNWeb::HTML::widget(TableOpts => $FORM_OUT, {
+ save => auth ? $o->{pref} : undef,
+ views => $o->{views},
+ value => $v,
+ default => $o->{default},
+ usaved => $o->{pref} && auth->pref($o->{pref}),
+ sorts => [ map +{ id => $_->{sort_id}, name => $_->{name}, num => $_->{sort_num}||0 }, grep defined $_->{sort_id}, values $o->{col_order}->@* ],
+ vis => [ map +{ id => $_->{vis_id}, name => $_->{name} }, grep defined $_->{vis_id}, values $o->{col_order}->@* ],
+ }), sub {
+ li_ class => 'hidden', sub {
+ input_ type => 'hidden', name => 's', value => $self->query_encode;
+ };
+ li_ sub {
+ a_ href => $url->(s => $self->view_param($_)),
+ class => $_ == ($self->[0] & 3) ? 'highlightselected' : undef,
+ title => ['List view', 'Card view', 'Grid view']->[$_], sub {
+ # SVG icons from https://lucide.dev/, MIT
+ lit_ '<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 24 24"><g fill="none" stroke="currentColor" stroke-width="2" stroke-linecap="round" stroke-linejoin="round">'.
+ [ '<line x1="8" x2="21" y1="6" y2="6"/><line x1="8" x2="21" y1="12" y2="12"/><line x1="8" x2="21" y1="18" y2="18"/><line x1="3" x2="3.01" y1="6" y2="6"/><line x1="3" x2="3.01" y1="12" y2="12"/><line x1="3" x2="3.01" y1="18" y2="18"/>'
+ , '<rect width="18" height="18" x="3" y="3" rx="2" ry="2"/><line x1="3" x2="21" y1="12" y2="12"/>'
+ , '<rect width="7" height="7" x="3" y="3" rx="1"/><rect width="7" height="7" x="14" y="3" rx="1"/><rect width="7" height="7" x="14" y="14" rx="1"/><rect width="7" height="7" x="3" y="14" rx="1"/>'
+ ]->[$_].'</g></svg>';
+ };
+ } for $o->{views}->@*;
+ };
+}
+
+
+# Helpful debugging function, dumps a quick overview of assigned numeric
+# identifiers for the given opts.
+sub dump_ids {
+ my($o) = @_;
+ warn sprintf "sort %2d %s %s\n", $_->{sort_id}, $_->{id}, $_->{name}
+ for sort { $a->{sort_id} <=> $b->{sort_id} }
+ grep defined $_->{sort_id}, values $o->{col_order}->@*;
+ warn sprintf "vis %2d %s %s\n", $_->{vis_id}, $_->{id}, $_->{name}
+ for sort { $a->{vis_id} <=> $b->{vis_id} }
+ grep defined $_->{vis_id}, values $o->{col_order}->@*;
+}
+
+1;
diff --git a/lib/VNWeb/Tags/Elm.pm b/lib/VNWeb/Tags/Elm.pm
deleted file mode 100644
index 0f816bad..00000000
--- a/lib/VNWeb/Tags/Elm.pm
+++ /dev/null
@@ -1,24 +0,0 @@
-package VNWeb::Tags::Elm;
-
-use VNWeb::Prelude;
-
-elm_api Tags => undef, { search => {} }, sub {
- my $q = shift->{search};
- my $qs = $q =~ s/[%_]//gr;
-
- elm_TagResult tuwf->dbPagei({ results => 15, page => 1 },
- 'SELECT t.id, t.name, t.searchable, t.applicable, t.state
- FROM (',
- sql_join('UNION ALL',
- $q =~ /^$RE{gid}$/ ? sql('SELECT 1, id FROM tags WHERE id =', \"$+{id}") : (),
- sql('SELECT 1+substr_score(lower(name),', \$qs, '), id FROM tags WHERE name ILIKE', \"%$qs%"),
- sql('SELECT 10+substr_score(lower(alias),', \$qs, '), tag FROM tags_aliases WHERE alias ILIKE', \"%$qs%"),
- ), ') x (prio, id)
- JOIN tags t ON t.id = x.id
- WHERE t.state <> 1
- GROUP BY t.id, t.name, t.searchable, t.applicable, t.state
- ORDER BY MIN(x.prio), t.name
- ')
-};
-
-1;
diff --git a/lib/VNWeb/Tags/Lib.pm b/lib/VNWeb/Tags/Lib.pm
deleted file mode 100644
index 61220186..00000000
--- a/lib/VNWeb/Tags/Lib.pm
+++ /dev/null
@@ -1,16 +0,0 @@
-package VNWeb::Tags::Lib;
-
-use VNWeb::Prelude;
-use Exporter 'import';
-
-our @EXPORT = qw/ tagscore_ /;
-
-sub tagscore_ {
- my($s, $ign) = @_;
- div_ mkclass(tagscore => 1, negative => $s < 0, ignored => $ign), sub {
- span_ sprintf '%.1f', $s;
- div_ style => sprintf('width: %.0fpx', abs $s/3*30), '';
- };
-}
-
-1;
diff --git a/lib/VNWeb/TimeZone.pm b/lib/VNWeb/TimeZone.pm
new file mode 100644
index 00000000..6b14f4f0
--- /dev/null
+++ b/lib/VNWeb/TimeZone.pm
@@ -0,0 +1,512 @@
+package VNWeb::TimeZone;
+
+use v5.28;
+use warnings;
+use TUWF;
+use VNWeb::Auth;
+use VNWeb::Validation 'is_api';
+use Exporter 'import';
+
+
+our @EXPORT = ('@ZONES', '%ZONES');
+
+# All cities, including aliases for other timezones but excluding "country"
+# aliases to keep the list sane.
+# find /usr/share/zoneinfo -type f -printf '%P\n' | grep '/' | grep -vE '^(Etc|Brazil|Chile|Mexico|US|Canada)' | sort
+our @ZONES = qw{
+ UTC
+ Africa/Abidjan
+ Africa/Accra
+ Africa/Addis_Ababa
+ Africa/Algiers
+ Africa/Asmara
+ Africa/Asmera
+ Africa/Bamako
+ Africa/Bangui
+ Africa/Banjul
+ Africa/Bissau
+ Africa/Blantyre
+ Africa/Brazzaville
+ Africa/Bujumbura
+ Africa/Cairo
+ Africa/Casablanca
+ Africa/Ceuta
+ Africa/Conakry
+ Africa/Dakar
+ Africa/Dar_es_Salaam
+ Africa/Djibouti
+ Africa/Douala
+ Africa/El_Aaiun
+ Africa/Freetown
+ Africa/Gaborone
+ Africa/Harare
+ Africa/Johannesburg
+ Africa/Juba
+ Africa/Kampala
+ Africa/Khartoum
+ Africa/Kigali
+ Africa/Kinshasa
+ Africa/Lagos
+ Africa/Libreville
+ Africa/Lome
+ Africa/Luanda
+ Africa/Lubumbashi
+ Africa/Lusaka
+ Africa/Malabo
+ Africa/Maputo
+ Africa/Maseru
+ Africa/Mbabane
+ Africa/Mogadishu
+ Africa/Monrovia
+ Africa/Nairobi
+ Africa/Ndjamena
+ Africa/Niamey
+ Africa/Nouakchott
+ Africa/Ouagadougou
+ Africa/Porto-Novo
+ Africa/Sao_Tome
+ Africa/Timbuktu
+ Africa/Tripoli
+ Africa/Tunis
+ Africa/Windhoek
+ America/Adak
+ America/Anchorage
+ America/Anguilla
+ America/Antigua
+ America/Araguaina
+ America/Argentina/Buenos_Aires
+ America/Argentina/Catamarca
+ America/Argentina/ComodRivadavia
+ America/Argentina/Cordoba
+ America/Argentina/Jujuy
+ America/Argentina/La_Rioja
+ America/Argentina/Mendoza
+ America/Argentina/Rio_Gallegos
+ America/Argentina/Salta
+ America/Argentina/San_Juan
+ America/Argentina/San_Luis
+ America/Argentina/Tucuman
+ America/Argentina/Ushuaia
+ America/Aruba
+ America/Asuncion
+ America/Atikokan
+ America/Atka
+ America/Bahia
+ America/Bahia_Banderas
+ America/Barbados
+ America/Belem
+ America/Belize
+ America/Blanc-Sablon
+ America/Boa_Vista
+ America/Bogota
+ America/Boise
+ America/Buenos_Aires
+ America/Cambridge_Bay
+ America/Campo_Grande
+ America/Cancun
+ America/Caracas
+ America/Catamarca
+ America/Cayenne
+ America/Cayman
+ America/Chicago
+ America/Chihuahua
+ America/Coral_Harbour
+ America/Cordoba
+ America/Costa_Rica
+ America/Creston
+ America/Cuiaba
+ America/Curacao
+ America/Danmarkshavn
+ America/Dawson
+ America/Dawson_Creek
+ America/Denver
+ America/Detroit
+ America/Dominica
+ America/Edmonton
+ America/Eirunepe
+ America/El_Salvador
+ America/Ensenada
+ America/Fort_Nelson
+ America/Fort_Wayne
+ America/Fortaleza
+ America/Glace_Bay
+ America/Godthab
+ America/Goose_Bay
+ America/Grand_Turk
+ America/Grenada
+ America/Guadeloupe
+ America/Guatemala
+ America/Guayaquil
+ America/Guyana
+ America/Halifax
+ America/Havana
+ America/Hermosillo
+ America/Indiana/Indianapolis
+ America/Indiana/Knox
+ America/Indiana/Marengo
+ America/Indiana/Petersburg
+ America/Indiana/Tell_City
+ America/Indiana/Vevay
+ America/Indiana/Vincennes
+ America/Indiana/Winamac
+ America/Indianapolis
+ America/Inuvik
+ America/Iqaluit
+ America/Jamaica
+ America/Jujuy
+ America/Juneau
+ America/Kentucky/Louisville
+ America/Kentucky/Monticello
+ America/Knox_IN
+ America/Kralendijk
+ America/La_Paz
+ America/Lima
+ America/Los_Angeles
+ America/Louisville
+ America/Lower_Princes
+ America/Maceio
+ America/Managua
+ America/Manaus
+ America/Marigot
+ America/Martinique
+ America/Matamoros
+ America/Mazatlan
+ America/Mendoza
+ America/Menominee
+ America/Merida
+ America/Metlakatla
+ America/Mexico_City
+ America/Miquelon
+ America/Moncton
+ America/Monterrey
+ America/Montevideo
+ America/Montreal
+ America/Montserrat
+ America/Nassau
+ America/New_York
+ America/Nipigon
+ America/Nome
+ America/Noronha
+ America/North_Dakota/Beulah
+ America/North_Dakota/Center
+ America/North_Dakota/New_Salem
+ America/Nuuk
+ America/Ojinaga
+ America/Panama
+ America/Pangnirtung
+ America/Paramaribo
+ America/Phoenix
+ America/Port-au-Prince
+ America/Port_of_Spain
+ America/Porto_Acre
+ America/Porto_Velho
+ America/Puerto_Rico
+ America/Punta_Arenas
+ America/Rainy_River
+ America/Rankin_Inlet
+ America/Recife
+ America/Regina
+ America/Resolute
+ America/Rio_Branco
+ America/Rosario
+ America/Santa_Isabel
+ America/Santarem
+ America/Santiago
+ America/Santo_Domingo
+ America/Sao_Paulo
+ America/Scoresbysund
+ America/Shiprock
+ America/Sitka
+ America/St_Barthelemy
+ America/St_Johns
+ America/St_Kitts
+ America/St_Lucia
+ America/St_Thomas
+ America/St_Vincent
+ America/Swift_Current
+ America/Tegucigalpa
+ America/Thule
+ America/Thunder_Bay
+ America/Tijuana
+ America/Toronto
+ America/Tortola
+ America/Vancouver
+ America/Virgin
+ America/Whitehorse
+ America/Winnipeg
+ America/Yakutat
+ America/Yellowknife
+ Antarctica/Casey
+ Antarctica/Davis
+ Antarctica/DumontDUrville
+ Antarctica/Macquarie
+ Antarctica/Mawson
+ Antarctica/McMurdo
+ Antarctica/Palmer
+ Antarctica/Rothera
+ Antarctica/South_Pole
+ Antarctica/Syowa
+ Antarctica/Troll
+ Antarctica/Vostok
+ Arctic/Longyearbyen
+ Asia/Aden
+ Asia/Almaty
+ Asia/Amman
+ Asia/Anadyr
+ Asia/Aqtau
+ Asia/Aqtobe
+ Asia/Ashgabat
+ Asia/Ashkhabad
+ Asia/Atyrau
+ Asia/Baghdad
+ Asia/Bahrain
+ Asia/Baku
+ Asia/Bangkok
+ Asia/Barnaul
+ Asia/Beirut
+ Asia/Bishkek
+ Asia/Brunei
+ Asia/Calcutta
+ Asia/Chita
+ Asia/Choibalsan
+ Asia/Chongqing
+ Asia/Chungking
+ Asia/Colombo
+ Asia/Dacca
+ Asia/Damascus
+ Asia/Dhaka
+ Asia/Dili
+ Asia/Dubai
+ Asia/Dushanbe
+ Asia/Famagusta
+ Asia/Gaza
+ Asia/Harbin
+ Asia/Hebron
+ Asia/Ho_Chi_Minh
+ Asia/Hong_Kong
+ Asia/Hovd
+ Asia/Irkutsk
+ Asia/Istanbul
+ Asia/Jakarta
+ Asia/Jayapura
+ Asia/Jerusalem
+ Asia/Kabul
+ Asia/Kamchatka
+ Asia/Karachi
+ Asia/Kashgar
+ Asia/Kathmandu
+ Asia/Katmandu
+ Asia/Khandyga
+ Asia/Kolkata
+ Asia/Krasnoyarsk
+ Asia/Kuala_Lumpur
+ Asia/Kuching
+ Asia/Kuwait
+ Asia/Macao
+ Asia/Macau
+ Asia/Magadan
+ Asia/Makassar
+ Asia/Manila
+ Asia/Muscat
+ Asia/Nicosia
+ Asia/Novokuznetsk
+ Asia/Novosibirsk
+ Asia/Omsk
+ Asia/Oral
+ Asia/Phnom_Penh
+ Asia/Pontianak
+ Asia/Pyongyang
+ Asia/Qatar
+ Asia/Qostanay
+ Asia/Qyzylorda
+ Asia/Rangoon
+ Asia/Riyadh
+ Asia/Saigon
+ Asia/Sakhalin
+ Asia/Samarkand
+ Asia/Seoul
+ Asia/Shanghai
+ Asia/Singapore
+ Asia/Srednekolymsk
+ Asia/Taipei
+ Asia/Tashkent
+ Asia/Tbilisi
+ Asia/Tehran
+ Asia/Tel_Aviv
+ Asia/Thimbu
+ Asia/Thimphu
+ Asia/Tokyo
+ Asia/Tomsk
+ Asia/Ujung_Pandang
+ Asia/Ulaanbaatar
+ Asia/Ulan_Bator
+ Asia/Urumqi
+ Asia/Ust-Nera
+ Asia/Vientiane
+ Asia/Vladivostok
+ Asia/Yakutsk
+ Asia/Yangon
+ Asia/Yekaterinburg
+ Asia/Yerevan
+ Atlantic/Azores
+ Atlantic/Bermuda
+ Atlantic/Canary
+ Atlantic/Cape_Verde
+ Atlantic/Faeroe
+ Atlantic/Faroe
+ Atlantic/Jan_Mayen
+ Atlantic/Madeira
+ Atlantic/Reykjavik
+ Atlantic/South_Georgia
+ Atlantic/St_Helena
+ Atlantic/Stanley
+ Australia/ACT
+ Australia/Adelaide
+ Australia/Brisbane
+ Australia/Broken_Hill
+ Australia/Canberra
+ Australia/Currie
+ Australia/Darwin
+ Australia/Eucla
+ Australia/Hobart
+ Australia/LHI
+ Australia/Lindeman
+ Australia/Lord_Howe
+ Australia/Melbourne
+ Australia/NSW
+ Australia/North
+ Australia/Perth
+ Australia/Queensland
+ Australia/South
+ Australia/Sydney
+ Australia/Tasmania
+ Australia/Victoria
+ Australia/West
+ Australia/Yancowinna
+ Europe/Amsterdam
+ Europe/Andorra
+ Europe/Astrakhan
+ Europe/Athens
+ Europe/Belfast
+ Europe/Belgrade
+ Europe/Berlin
+ Europe/Bratislava
+ Europe/Brussels
+ Europe/Bucharest
+ Europe/Budapest
+ Europe/Busingen
+ Europe/Chisinau
+ Europe/Copenhagen
+ Europe/Dublin
+ Europe/Gibraltar
+ Europe/Guernsey
+ Europe/Helsinki
+ Europe/Isle_of_Man
+ Europe/Istanbul
+ Europe/Jersey
+ Europe/Kaliningrad
+ Europe/Kiev
+ Europe/Kirov
+ Europe/Kyiv
+ Europe/Lisbon
+ Europe/Ljubljana
+ Europe/London
+ Europe/Luxembourg
+ Europe/Madrid
+ Europe/Malta
+ Europe/Mariehamn
+ Europe/Minsk
+ Europe/Monaco
+ Europe/Moscow
+ Europe/Nicosia
+ Europe/Oslo
+ Europe/Paris
+ Europe/Podgorica
+ Europe/Prague
+ Europe/Riga
+ Europe/Rome
+ Europe/Samara
+ Europe/San_Marino
+ Europe/Sarajevo
+ Europe/Saratov
+ Europe/Simferopol
+ Europe/Skopje
+ Europe/Sofia
+ Europe/Stockholm
+ Europe/Tallinn
+ Europe/Tirane
+ Europe/Tiraspol
+ Europe/Ulyanovsk
+ Europe/Uzhgorod
+ Europe/Vaduz
+ Europe/Vatican
+ Europe/Vienna
+ Europe/Vilnius
+ Europe/Volgograd
+ Europe/Warsaw
+ Europe/Zagreb
+ Europe/Zaporozhye
+ Europe/Zurich
+ Indian/Antananarivo
+ Indian/Chagos
+ Indian/Christmas
+ Indian/Cocos
+ Indian/Comoro
+ Indian/Kerguelen
+ Indian/Mahe
+ Indian/Maldives
+ Indian/Mauritius
+ Indian/Mayotte
+ Indian/Reunion
+ Pacific/Apia
+ Pacific/Auckland
+ Pacific/Bougainville
+ Pacific/Chatham
+ Pacific/Chuuk
+ Pacific/Easter
+ Pacific/Efate
+ Pacific/Enderbury
+ Pacific/Fakaofo
+ Pacific/Fiji
+ Pacific/Funafuti
+ Pacific/Galapagos
+ Pacific/Gambier
+ Pacific/Guadalcanal
+ Pacific/Guam
+ Pacific/Honolulu
+ Pacific/Johnston
+ Pacific/Kanton
+ Pacific/Kiritimati
+ Pacific/Kosrae
+ Pacific/Kwajalein
+ Pacific/Majuro
+ Pacific/Marquesas
+ Pacific/Midway
+ Pacific/Nauru
+ Pacific/Niue
+ Pacific/Norfolk
+ Pacific/Noumea
+ Pacific/Pago_Pago
+ Pacific/Palau
+ Pacific/Pitcairn
+ Pacific/Pohnpei
+ Pacific/Ponape
+ Pacific/Port_Moresby
+ Pacific/Rarotonga
+ Pacific/Saipan
+ Pacific/Samoa
+ Pacific/Tahiti
+ Pacific/Tarawa
+ Pacific/Tongatapu
+ Pacific/Truk
+ Pacific/Wake
+ Pacific/Wallis
+ Pacific/Yap
+};
+our %ZONES = map +($_,1), @ZONES;
+
+TUWF::hook before => sub {
+ $ENV{TZ} = !is_api() && auth->pref('timezone') || 'UTC';
+} if !$main::ONLYAPI;
+
+1;
diff --git a/lib/VNWeb/TitlePrefs.pm b/lib/VNWeb/TitlePrefs.pm
new file mode 100644
index 00000000..4405d176
--- /dev/null
+++ b/lib/VNWeb/TitlePrefs.pm
@@ -0,0 +1,217 @@
+package VNWeb::TitlePrefs;
+
+use v5.26;
+use TUWF;
+use VNDB::Types;
+use VNWeb::Auth;
+use VNWeb::DB;
+use VNWeb::Validation;
+use Exporter 'import';
+
+our @EXPORT = qw/
+ titleprefs_obj
+ titleprefs_swap
+ vnt
+ releasest
+ producerst
+ charst
+ staff_aliast
+ item_info
+/;
+
+our @EXPORT_OK = qw/
+ titleprefs_parse
+ titleprefs_fmt
+ $DEFAULT_TITLE_PREFS
+/;
+
+
+# Parse a string representation of the 'titleprefs' SQL type for use in Perl & Elm.
+# (Could also use Postgres row_to_json() to simplify this a bit, but it wouldn't save much)
+sub titleprefs_parse {
+ return undef if !defined $_[0];
+ state $L = qr/([^,]*)/;
+ state $B = qr/([tf])/;
+ state $O = qr/([tf]?)/;
+ state $RE = qr/^\(
+ $L,$L,$L,$L, # 1.. 4 -> t1_lang .. t4_lang
+ $L,$L,$L,$L, # 5.. 8 -> a1_lang .. a4_lang
+ $B,$B,$B,$B,$B, # 9..13 -> t1_latin .. to_latin
+ $B,$B,$B,$B,$B, # 14..18 -> a1_latin .. ao_latin
+ $O,$O,$O,$O, # 19..22 -> t1_official .. t4_official
+ $O,$O,$O,$O # 23..26 -> a1_official .. a4_official
+ \)$/x;
+ die $_[0] if $_[0] !~ $RE;
+ sub b($) { !$_[0] ? undef : $_[0] eq 't' }
+ sub l($) { !$_[0] ? undef : $_[0] }
+ [
+ [ $1 ? { lang => l $1, latin => b $9, official => b $19 } : ()
+ , $2 ? { lang => l $2, latin => b $10, official => b $20 } : ()
+ , $3 ? { lang => l $3, latin => b $11, official => b $21 } : ()
+ , $4 ? { lang => l $4, latin => b $12, official => b $22 } : ()
+ , { lang => undef,latin => b $13, official => undef } ],
+ [ $5 ? { lang => l $5, latin => b $14, official => b $23 } : ()
+ , $6 ? { lang => l $6, latin => b $15, official => b $24 } : ()
+ , $7 ? { lang => l $7, latin => b $16, official => b $25 } : ()
+ , $8 ? { lang => l $8, latin => b $17, official => b $26 } : ()
+ , { lang => undef,latin => b $18, official => undef } ],
+ ]
+}
+
+
+sub titleprefs_fmt {
+ my($p) = @_;
+ return undef if !defined $p;
+ my sub val { my $v = $p->[$_[0]][$_[1]]; $v && $v->{lang} ? $v->{$_[2]} : undef }
+ my sub l($$) { val @_, 'lang' }
+ my sub b($$) { my $v = val @_, 'latin'; $v ? 't' : 'f' }
+ my sub o($$) { my $v = val @_, 'official'; !defined $v ? '' : $v ? 't' : 'f' }
+ '('.join(',',
+ l(0,0), l(0,1), l(0,2), l(0,3),
+ l(1,0), l(1,1), l(1,2), l(1,3),
+ b(0,0), b(0,1), b(0,2), b(0,3), $p->[0][$#{$p->[0]}]{latin} ? 't' : 'f',
+ b(1,0), b(1,1), b(1,2), b(1,3), $p->[1][$#{$p->[1]}]{latin} ? 't' : 'f',
+ o(0,0), o(0,1), o(0,2), o(0,3),
+ o(1,0), o(1,1), o(1,2), o(1,3)
+ ).')'
+}
+
+
+# This validation only covers half of the titleprefs, i.e. just the main or alternative title.
+TUWF::set('custom_validations')->{titleprefs} = {
+ type => 'array',
+ maxlength => 5,
+ values => { type => 'hash', keys => {
+ lang => { default => undef, enum => \%LANGUAGE }, # undef referring to the original title language
+ latin => { anybool => 1 },
+ official => { undefbool => 1 },
+ }},
+ func => sub {
+ # Last one must be olang if n==5.
+ return 0 if $_[0]->@* == 5 && $_[0][4]{lang};
+ # undef lang is only allowed as sentinel
+ return 0 if $_[0]->@* >= 2 && grep !$_[0][$_]{lang}, 0..($_[0]->@*-2);
+ # ensure we have an undef lang
+ push $_[0]->@*, { lang => undef, latin => '', official => undef } if !grep !$_->{lang}, $_[0]->@*;
+
+ # Remove duplicate languages that will never be matched.
+ my %l;
+ $_[0] = [ grep {
+ my $prio = !defined $_->{official} ? 3 : $_->{official} ? 2 : 1;
+ my $dupe = $l{$_->{lang}} && $l{$_->{lang}} <= $prio;
+ $l{$_->{lang}} = $prio if !$dupe;
+ !$dupe
+ } $_[0]->@* ];
+
+ # (XXX: we can also merge adjacent duplicates at this stage)
+
+ # Expand 'Chinese' to the scripts if we have enough free slots.
+ # (this is a hack and should ideally be handled in the title selection
+ # algorithm, but that selection code has multiple implementations and
+ # is already subject to potential performance issues, so I'd rather
+ # keep it simple)
+ $_[0] = [ map $_->{lang} eq 'zh' ? ($_, {%$_,lang=>'zh-Hant'}, {%$_,lang=>'zh-Hans'}) : ($_), $_[0]->@* ]
+ if $_[0]->@* <= 3 && !grep $_->{lang} && $_->{lang} =~ /^zh-/, $_[0]->@*;
+ 1;
+ },
+};
+
+
+our $DEFAULT_TITLE_PREFS = [
+ [ { lang => undef, latin => 1, official => undef } ],
+ [ { lang => undef, latin => '', official => undef } ],
+];
+
+sub pref { tuwf->req->{titleprefs} //= !is_api() && titleprefs_parse(auth->pref('titles')) }
+
+
+# Returns the preferred title array given an array of (vn|releases)_titles-like
+# objects. Same functionality as the SQL view, except implemented in perl.
+sub titleprefs_obj {
+ my($olang, $titles) = @_;
+ my $p = pref || $DEFAULT_TITLE_PREFS;
+ my %l = map +($_->{lang},$_), $titles->@*;
+
+ my @title = ('','','','');
+ for my $t (0,1) {
+ for ($p->[$t]->@*) {
+ my $o = $l{$_->{lang} // $olang} or next;
+ next if !defined $_->{official} && $o->{lang} ne $olang;
+ next if $_->{official} && defined $o->{official} && !$o->{official};
+ next if !defined $o->{title};
+ $title[$t*2] = $o->{lang};
+ $title[$t*2+1] = $_->{latin} && length $o->{latin} ? $o->{latin} : $o->{title};
+ last;
+ }
+ }
+ \@title;
+}
+
+
+# Returns the preferred title array given a language, latin title and original title.
+# For DB entries that only have (title, latin) fields.
+sub titleprefs_swap {
+ my($olang, $title, $latin) = @_;
+ my $p = pref || $DEFAULT_TITLE_PREFS;
+
+ my @title = ($olang,'',$olang,'');
+ for my $t (0,1) {
+ for ($p->[$t]->@*) {
+ next if $_->{lang} && $_->{lang} ne $olang;
+ $title[$t*2+1] = $_->{latin} ? $latin//$title : $title;
+ last;
+ }
+ }
+ \@title;
+}
+
+
+sub gen_sql {
+ my($has_official, $tbl_main, $tbl_titles, $join_col) = @_;
+ my $p = pref || $DEFAULT_TITLE_PREFS;
+
+ sub id { (!defined $_[0]{official}?'r':$_[0]{official}?'o':'u').($_[0]{lang}//'') }
+
+ my %joins = map +(id($_),1), $p->[0]->@*, $p->[1]->@*;
+ my $var = 'a';
+ $joins{$_} = 'x_'.$var++ for sort keys %joins;
+ my @joins = map sql(
+ "LEFT JOIN $tbl_titles $joins{$_} ON", sql_and
+ "$joins{$_}.$join_col = x.$join_col",
+ $_ =~ /^r/ ? "$joins{$_}.lang = x.olang" : (),
+ length($_) > 1 ? sql("$joins{$_}.lang =", \(''.substr($_,1))) : (),
+ $has_official && $_ =~ /^o./ ? "$joins{$_}.official" : (),
+ ), sort keys %joins;
+
+ my sub titlearray {
+ my($o) = @_;
+ 'ARRAY['.($o->{lang}?"'$o->{lang}'":'null').', COALESCE('.($o->{latin} ? $joins{ id($o) }.'.latin, ' : '').$joins{ id($o) }.'.title)]';
+ }
+ my sub titlesel {
+ my $orig = pop;
+ return titlearray($orig) if !@_;
+ 'CASE '.join(' ', map 'WHEN '.$joins{ id($_) }.'.title IS NOT NULL THEN '.titlearray($_), @_).' ELSE '.titlearray($orig).' END';
+ }
+ my $title = titlesel($p->[0]->@*).'||'.titlesel($p->[1]->@*);
+ my $sorttitle = 'COALESCE('.join(',',
+ map +($joins{ id($_) }.'.latin', $joins{ id($_) }.'.title'), $p->[0]->@*
+ ).')';
+
+ sql "(SELECT x.*, $title AS title, $sorttitle AS sorttitle FROM $tbl_main x", @joins, ')';
+}
+
+
+sub vnt() { tuwf->req->{titleprefs_v} //= pref ? gen_sql 1, 'vn', 'vn_titles', 'id' : 'vnt' }
+sub releasest() { tuwf->req->{titleprefs_r} //= pref ? gen_sql 0, 'releases', 'releases_titles', 'id' : 'releasest' }
+sub producerst() { tuwf->req->{titleprefs_p} //= pref ? sql 'producerst(', \tuwf->req->{auth}{user}{titles}, ')' : 'producerst' }
+sub charst() { tuwf->req->{titleprefs_c} //= pref ? sql 'charst(', \tuwf->req->{auth}{user}{titles}, ')' : 'charst' }
+sub staff_aliast() { tuwf->req->{titleprefs_s} //= pref ? sql 'staff_aliast(', \tuwf->req->{auth}{user}{titles}, ')' : 'staff_aliast' }
+
+# (Not currently used)
+#sub vnt_hist { gen_sql 1, 'vn_hist', 'vn_titles_hist', 'chid' }
+#sub releasest_hist { gen_sql 0, 'releases_hist', 'releases_titles_hist', 'chid' }
+
+# Wrapper around SQL's item_info() with the user's preference applied.
+sub item_info($$) { sql 'item_info(', \((tuwf->req->{auth} && tuwf->req->{auth}{user}{titles}) || undef), ',', $_[0], ',', $_[1], ')' }
+
+1;
diff --git a/lib/VNWeb/ULists/Elm.pm b/lib/VNWeb/ULists/Elm.pm
new file mode 100644
index 00000000..bcc22de1
--- /dev/null
+++ b/lib/VNWeb/ULists/Elm.pm
@@ -0,0 +1,297 @@
+package VNWeb::ULists::Elm;
+
+use VNWeb::Prelude;
+use VNWeb::ULists::Lib;
+
+
+# Should be called after any label/vote/private change to the ulist_vns table.
+# (Normally I'd do this with triggers, but that seemed like a more complex and less efficient solution in this case)
+sub updcache {
+ my($uid,$vid) = @_;
+ tuwf->dbExeci(SELECT => sql_func update_users_ulist_private => \$uid, \$vid) if @_ == 2;
+ tuwf->dbExeci(SELECT => sql_func update_users_ulist_stats => \$uid);
+}
+
+
+sub sql_labelid {
+ my($uid) = @_;
+ sql '(SELECT min(x.n)
+ FROM generate_series(10,
+ greatest((SELECT max(id)+1 from ulist_labels ul WHERE ul.uid =', \$uid, '), 10)
+ ) x(n)
+ WHERE NOT EXISTS(SELECT 1 FROM ulist_labels ul WHERE ul.uid =', \$uid, 'AND ul.id = x.n))';
+}
+
+
+our $LABELS = form_compile any => {
+ uid => { vndbid => 'u' },
+ labels => { maxlength => 1500, aoh => {
+ id => { int => 1 },
+ label => { sl => 1, maxlength => 50 },
+ private => { anybool => 1 },
+ count => { uint => 1 },
+ delete => { default => undef, uint => 1, range => [1, 3] }, # 1=keep vns, 2=delete when no other label, 3=delete all
+ } }
+};
+
+elm_api UListManageLabels => undef, $LABELS, sub {
+ my($uid, $labels) = ($_[0]{uid}, $_[0]{labels});
+ return elm_Unauth if !ulists_own $uid;
+
+ # Insert new labels
+ my @new = grep $_->{id} < 0 && !$_->{delete}, @$labels;
+ tuwf->dbExeci('INSERT INTO ulist_labels', { id => sql_labelid($uid), uid => $uid, label => $_->{label}, private => $_->{private} }) for @new;
+
+ # Update private flag
+ my $changed = 0;
+ $changed += tuwf->dbExeci(
+ 'UPDATE ulist_labels SET private =', \$_->{private},
+ 'WHERE uid =', \$uid, 'AND id =', \$_->{id}, 'AND private <>', \$_->{private}
+ ) for grep $_->{id} > 0 && !$_->{delete}, @$labels;
+
+ # Update label
+ tuwf->dbExeci(
+ 'UPDATE ulist_labels SET label =', \$_->{label},
+ 'WHERE uid =', \$uid, 'AND id =', \$_->{id}, 'AND label <>', \$_->{label}
+ ) for grep $_->{id} >= 10 && !$_->{delete}, @$labels;
+
+ # Delete labels
+ my @delete = grep $_->{id} >= 10 && $_->{delete}, @$labels;
+ my @delete_lblonly = map $_->{id}, grep $_->{delete} == 1, @delete;
+ my @delete_empty = map $_->{id}, grep $_->{delete} == 2, @delete;
+ my @delete_all = map $_->{id}, grep $_->{delete} == 3, @delete;
+
+ # delete vns with: (a label in option 3) OR ((a label in option 2) AND (no labels other than in option 1 or 2))
+ my @where = (
+ @delete_all ? sql('labels &&', sql_array(@delete_all), '::smallint[]') : (),
+ @delete_empty ? sql(
+ 'labels &&', sql_array(@delete_empty), '::smallint[]
+ AND labels <@', sql_array(@delete_lblonly, @delete_empty), '::smallint[]'
+ ) : ()
+ );
+ tuwf->dbExeci('DELETE FROM ulist_vns uv WHERE uid =', \$uid, 'AND (', sql_or(@where), ')') if @where;
+
+ $changed += tuwf->dbExeci(
+ 'UPDATE ulist_vns
+ SET labels = array_remove(labels,', \$_->{id}, ')
+ WHERE uid =', \$uid, 'AND labels && ARRAY[', \$_->{id}, '::smallint]'
+ ) for @delete;
+
+ tuwf->dbExeci('DELETE FROM ulist_labels WHERE uid =', \$uid, 'AND id IN', [ map $_->{id}, @delete ]) if @delete;
+
+ updcache $uid, $changed ? undef : ();
+ elm_Success
+};
+
+
+# Create a new label and add it to a VN
+elm_api UListLabelAdd => undef, {
+ uid => { vndbid => 'u' },
+ vid => { vndbid => 'v' },
+ label => { sl => 1, maxlength => 50 },
+}, sub {
+ my($data) = @_;
+ return elm_Unauth if !ulists_own $data->{uid};
+
+ my $id = tuwf->dbVali('
+ WITH x(id) AS (SELECT id FROM ulist_labels WHERE', { uid => $data->{uid}, label => $data->{label} }, '),
+ y(id) AS (INSERT INTO ulist_labels (id, uid, label, private) SELECT', sql_join(',',
+ sql_labelid($data->{uid}), \$data->{uid}, \$data->{label},
+ # Let's copy the private flag from the Voted label, seems like a sane default
+ sql('(SELECT private FROM ulist_labels WHERE', {uid => $data->{uid}, id => 7}, ')')
+ ), 'WHERE NOT EXISTS(SELECT 1 FROM x) RETURNING id)
+ SELECT id FROM x UNION SELECT id FROM y'
+ );
+ die "Attempt to set vote label" if $id == 7;
+
+ tuwf->dbExeci(
+ 'INSERT INTO ulist_vns', {uid => $data->{uid}, vid => $data->{vid}, labels => "{$id}"},
+ 'ON CONFLICT (uid, vid) DO UPDATE SET labels = array_set(ulist_vns.labels,', \$id, ')'
+ );
+ updcache $data->{uid}, $data->{vid};
+ elm_LabelId $id
+};
+
+
+
+our $VNVOTE = form_compile any => {
+ uid => { vndbid => 'u' },
+ vid => { vndbid => 'v' },
+ vote => { vnvote => 1 },
+};
+
+elm_api UListVoteEdit => undef, $VNVOTE, sub {
+ my($data) = @_;
+ return elm_Unauth if !ulists_own $data->{uid};
+ tuwf->dbExeci(
+ 'INSERT INTO ulist_vns', { %$data, vote_date => sql $data->{vote} ? 'NOW()' : 'NULL' },
+ 'ON CONFLICT (uid, vid) DO UPDATE
+ SET', { %$data,
+ lastmod => sql('NOW()'),
+ vote_date => sql $data->{vote} ? 'CASE WHEN ulist_vns.vote IS NULL THEN NOW() ELSE ulist_vns.vote_date END' : 'NULL'
+ }
+ );
+ updcache $data->{uid}, $data->{vid};
+ elm_Success
+};
+
+
+
+
+my $VNLABELS = {
+ uid => { vndbid => 'u' },
+ vid => { vndbid => 'v' },
+ label => { _when => 'in', id => 1 },
+ applied => { _when => 'in', anybool => 1 },
+ labels => { _when => 'out', aoh => { id => { int => 1 }, label => {}, private => { anybool => 1 } } },
+ selected => { _when => 'out', type => 'array', values => { id => 1 } },
+};
+
+our $VNLABELS_OUT = form_compile out => $VNLABELS;
+my $VNLABELS_IN = form_compile in => $VNLABELS;
+
+elm_api UListLabelEdit => $VNLABELS_OUT, $VNLABELS_IN, sub {
+ my($data) = @_;
+ return elm_Unauth if !ulists_own $data->{uid};
+ die "Attempt to set vote label" if $data->{label} == 7;
+ die "Attempt to set invalid label" if $data->{applied}
+ && !tuwf->dbVali('SELECT 1 FROM ulist_labels WHERE uid =', \$data->{uid}, 'AND id =', \$data->{label});
+
+ tuwf->dbExeci(
+ 'INSERT INTO ulist_vns', {
+ uid => $data->{uid},
+ vid => $data->{vid},
+ labels => $data->{applied}?"{$data->{label}}":'{}'
+ }, 'ON CONFLICT (uid, vid) DO UPDATE SET lastmod = NOW(),
+ labels =', sql_func $data->{applied} ? 'array_set' : 'array_remove', 'ulist_vns.labels', \$data->{label}
+ );
+ updcache $data->{uid}, $data->{vid};
+ elm_Success
+};
+
+
+
+
+our $VNDATE = form_compile any => {
+ uid => { vndbid => 'u' },
+ vid => { vndbid => 'v' },
+ date => { default => '', caldate => 1 },
+ start => { anybool => 1 }, # Field selection, started/finished
+};
+
+elm_api UListDateEdit => undef, $VNDATE, sub {
+ my($data) = @_;
+ return elm_Unauth if !ulists_own $data->{uid};
+ tuwf->dbExeci(
+ 'UPDATE ulist_vns SET lastmod = NOW(), ', $data->{start} ? 'started' : 'finished', '=', \($data->{date}||undef),
+ 'WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid}
+ );
+ # Doesn't need `updcache()`
+ elm_Success
+};
+
+
+
+
+our $VNOPT = form_compile any => {
+ own => { anybool => 1 },
+ uid => { vndbid => 'u' },
+ vid => { vndbid => 'v' },
+ notes => {},
+ rels => $VNWeb::Elm::apis{Releases}[0],
+ relstatus => { type => 'array', values => { uint => 1 } }, # List of release statuses, same order as rels
+};
+
+
+# UListVNNotes module is abused for the UList.Opts flag definition
+elm_api UListVNNotes => $VNOPT, {
+ uid => { vndbid => 'u' },
+ vid => { vndbid => 'v' },
+ notes => { default => '', maxlength => 2000 },
+}, sub {
+ my($data) = @_;
+ return elm_Unauth if !ulists_own $data->{uid};
+ tuwf->dbExeci(
+ 'INSERT INTO ulist_vns', \%$data, 'ON CONFLICT (uid, vid) DO UPDATE SET', { %$data, lastmod => sql('NOW()') }
+ );
+ # Doesn't need `updcache()`
+ elm_Success
+};
+
+
+
+
+elm_api UListDel => undef, {
+ uid => { vndbid => 'u' },
+ vid => { vndbid => 'v' },
+}, sub {
+ my($data) = @_;
+ return elm_Unauth if !ulists_own $data->{uid};
+ tuwf->dbExeci('DELETE FROM ulist_vns WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid});
+ updcache $data->{uid};
+ elm_Success
+};
+
+
+
+
+# Adds the release when not in the list.
+# $RLIST_STATUS is also referenced from VNWeb::Releases::Page.
+our $RLIST_STATUS = form_compile any => {
+ uid => { vndbid => 'u' },
+ rid => { vndbid => 'r' },
+ status => { default => undef, uint => 1, enum => \%RLIST_STATUS }, # undef meaning delete
+ empty => { default => '' }, # An 'out' field
+};
+elm_api UListRStatus => undef, $RLIST_STATUS, sub {
+ my($data) = @_;
+ delete $data->{empty};
+ return elm_Unauth if !ulists_own $data->{uid};
+ if(!defined $data->{status}) {
+ tuwf->dbExeci('DELETE FROM rlists WHERE uid =', \$data->{uid}, 'AND rid =', \$data->{rid})
+ } else {
+ tuwf->dbExeci('INSERT INTO rlists', $data, 'ON CONFLICT (uid, rid) DO UPDATE SET status =', \$data->{status})
+ }
+ # Doesn't need `updcache()`
+ elm_Success
+};
+
+
+
+our $WIDGET = form_compile out => $VNWeb::Elm::apis{UListWidget}[0]{keys};
+
+elm_api UListWidget => $WIDGET, { uid => { vndbid => 'u' }, vid => { vndbid => 'v' } }, sub {
+ my($data) = @_;
+ return elm_Unauth if !ulists_own $data->{uid};
+ my $v = tuwf->dbRowi('SELECT id, title, c_released FROM', vnt, 'v WHERE id =', \$data->{vid});
+ return elm_Invalid if !defined $v->{title};
+ elm_UListWidget ulists_widget_full_data $v, $data->{uid};
+};
+
+
+
+
+our %SAVED_OPTS = (
+ l => { onerror => [], type => 'array', scalar => 1, values => { int => 1, range => [-1,1600] } },
+ mul => { anybool => 1 },
+ s => { onerror => '' }, # TableOpts query string
+ f => { onerror => '' }, # AdvSearch
+);
+
+my $SAVED_OPTS = {
+ uid => { vndbid => 'u' },
+ opts => { type => 'hash', keys => \%SAVED_OPTS },
+ field => { _when => 'in', enum => [qw/ vnlist votes wish /] },
+};
+
+my $SAVED_OPTS_IN = form_compile in => $SAVED_OPTS;
+our $SAVED_OPTS_OUT = form_compile out => $SAVED_OPTS;
+
+elm_api UListSaveDefault => $SAVED_OPTS_OUT, $SAVED_OPTS_IN, sub {
+ my($data) = @_;
+ return elm_Unauth if !ulists_own $data->{uid};
+ tuwf->dbExeci('UPDATE users_prefs SET ulist_'.$data->{field}, '=', \JSON::XS->new->encode($data->{opts}), 'WHERE id =', \$data->{uid});
+ elm_Success
+};
+
+1;
diff --git a/lib/VNWeb/ULists/Export.pm b/lib/VNWeb/ULists/Export.pm
new file mode 100644
index 00000000..c9dc6875
--- /dev/null
+++ b/lib/VNWeb/ULists/Export.pm
@@ -0,0 +1,127 @@
+package VNWeb::ULists::Export;
+
+use TUWF::XML ':xml';
+use VNWeb::Prelude;
+use VNWeb::ULists::Lib;
+
+# XXX: Reading someone's entire list into memory (multiple times even) is not
+# the most efficient way to implement an export function. Might want to switch
+# to an async background process for this to reduce the footprint of web
+# workers.
+
+sub data {
+ my($uid) = @_;
+
+ # We'd like ISO7601/RFC3339 timestamps in UTC with accuracy to the second.
+ my sub tz { sql 'to_char(', $_[0], ' at time zone \'utc\',', \'YYYY-MM-DD"T"HH24:MM:SS"Z"', ') as', $_[1] }
+
+ # XXX: This keeps the old "title"/"original" fields for compatibility, but
+ # should the export take user title preferences into account instead? Or
+ # export all known titles?
+ my $d = {
+ 'export-date' => tuwf->dbVali(select => tz('NOW()', 'now')),
+ user => tuwf->dbRowi('SELECT id, username as name FROM users WHERE id =', \$uid),
+ labels => tuwf->dbAlli('SELECT id, label, private FROM ulist_labels WHERE uid =', \$uid, 'ORDER BY id'),
+ vns => tuwf->dbAlli('
+ SELECT v.id, v.title, uv.vote, uv.started, uv.finished, uv.notes, uv.c_private, uv.labels,',
+ sql_comma(tz('uv.added', 'added'), tz('uv.lastmod', 'lastmod'), tz('uv.vote_date', 'vote_date')), '
+ FROM ulist_vns uv
+ JOIN vnt v ON v.id = uv.vid
+ WHERE uv.uid =', \$uid, '
+ ORDER BY v.sorttitle'),
+ 'length-votes' => tuwf->dbAlli('
+ SELECT v.id, v.title, l.length, l.speed, l.private, l.notes, l.rid::text[] AS releases, ', tz('l.date', 'date'), '
+ FROM vn_length_votes l
+ JOIN vnt v ON v.id = l.vid
+ WHERE l.uid =', \$uid, '
+ ORDER BY v.sorttitle'),
+ };
+ enrich releases => id => vid => sub { sql '
+ SELECT rv.vid, r.id, r.title, r.released, rl.status, ', tz('rl.added', 'added'), '
+ FROM rlists rl
+ JOIN releasest r ON r.id = rl.rid
+ JOIN releases_vn rv ON rv.id = rl.rid
+ WHERE rl.uid =', \$uid, '
+ ORDER BY r.released, r.id'
+ }, $d->{vns};
+ enrich_merge id => sub { sql '
+ SELECT id, title, released FROM releasest WHERE id IN', $_, 'ORDER BY released, id'
+ }, map +($_->{releases} = [map +{id=>$_}, $_->{releases}->@*]), $d->{'length-votes'}->@*;
+ $d
+}
+
+
+sub filename {
+ my($d, $ext) = @_;
+ my $date = $d->{'export-date'} =~ s/[-TZ:]//rg;
+ "vndb-list-export-$d->{user}{name}-$date.$ext"
+}
+
+
+sub title {
+ my(@t) = $_[0]->@*;
+ return (length($t[3]) && $t[3] ne $t[1] ? (original => $t[3]) : (), $t[1]);
+}
+
+
+TUWF::get qr{/$RE{uid}/list-export/xml}, sub {
+ my $uid = tuwf->capture('id');
+ return tuwf->resDenied if !ulists_own $uid;
+ my $d = data $uid;
+ return tuwf->resNotFound if !$d->{user}{id};
+
+ tuwf->resHeader('Content-Disposition', sprintf 'attachment; filename="%s"', filename $d, 'xml');
+ tuwf->resHeader('Content-Type', 'application/xml; charset=UTF-8');
+
+ my %labels = map +($_->{id}, $_), $d->{labels}->@*;
+
+ my $fd = tuwf->resFd;
+ TUWF::XML->new(
+ write => sub { print $fd $_ for @_ },
+ pretty => 2,
+ default => 1,
+ );
+ xml;
+ tag 'vndb-export' => version => '1.0', date => $d->{'export-date'}, sub {
+ tag user => sub {
+ tag name => $d->{user}{name};
+ tag url => config->{url}.'/'.$d->{user}{id};
+ };
+ tag labels => sub {
+ tag label => id => $_->{id}, label => $_->{label}, private => $_->{private}?'true':'false', undef for $d->{labels}->@*;
+ };
+ tag vns => sub {
+ tag vn => id => $_->{id}, private => $_->{c_private}?'true':'false', sub {
+ tag title => title($_->{title});
+ tag label => id => $_, label => $labels{$_}{label}, undef for sort { $a <=> $b } $_->{labels}->@*;
+ tag added => $_->{added};
+ tag modified => $_->{lastmod} if $_->{added} ne $_->{lastmod};
+ tag vote => timestamp => $_->{vote_date}, fmtvote $_->{vote} if $_->{vote};
+ tag started => $_->{started} if $_->{started};
+ tag finished => $_->{finished} if $_->{finished};
+ tag notes => $_->{notes} if length $_->{notes};
+ tag release => id => $_->{id}, sub {
+ tag title => title($_->{title});
+ tag 'release-date' => rdate $_->{released};
+ tag status => $RLIST_STATUS{$_->{status}};
+ tag added => $_->{added};
+ } for $_->{releases}->@*;
+ } for $d->{vns}->@*;
+ };
+ tag 'length-votes', sub {
+ tag vn => id => $_->{id}, private => $_->{private}?'true':'false', sub {
+ tag title => title($_->{title});
+ tag date => $_->{date};
+ tag minutes => $_->{length};
+ tag speed => [qw/slow normal fast/]->[$_->{speed}] if defined $_->{speed};
+ tag notes => $_->{notes} if length $_->{notes};
+ tag release => id => $_->{id}, sub {
+ tag title => title($_->{title});
+ tag 'release-date' => rdate $_->{released};
+ } for $_->{releases}->@*;
+ } for $d->{'length-votes'}->@*;
+ };
+ };
+};
+
+1;
diff --git a/lib/VNWeb/ULists/Lib.pm b/lib/VNWeb/ULists/Lib.pm
new file mode 100644
index 00000000..0e264b3b
--- /dev/null
+++ b/lib/VNWeb/ULists/Lib.pm
@@ -0,0 +1,96 @@
+package VNWeb::ULists::Lib;
+
+use VNWeb::Prelude;
+use VNWeb::Releases::Lib 'releases_by_vn';
+use Exporter 'import';
+
+our @EXPORT = qw/ulists_own ulist_filtlabels enrich_ulists_widget ulists_widget_ ulists_widget_full_data/;
+
+# Do we have "ownership" access to this users' list (i.e. can we edit and see private stuff)?
+sub ulists_own {
+ auth->permUsermod || auth->api2Listread(shift)
+}
+
+
+sub ulist_filtlabels {
+ my($uid, $count) = @_;
+ my $own = ulists_own $uid;
+
+ my $l = tuwf->dbAlli(
+ 'SELECT l.id, l.label, l.private', $count ? ', coalesce(x.count, 0) as count' : (),
+ 'FROM ulist_labels l',
+ $count ? ('LEFT JOIN (
+ SELECT x.id, COUNT(*)
+ FROM ulist_vns uv, unnest(uv.labels) x(id)
+ WHERE uid =', \$uid, $own ? () : 'AND NOT uv.c_private', '
+ GROUP BY x.id
+ ) x(id, count) ON x.id = l.id') : (), '
+ WHERE l.uid =', \$uid, $own ? () : 'AND (NOT l.private OR l.id = 10-1-1-1)', # XXX: 'Voted' (7) is always visibible
+ 'ORDER BY CASE WHEN l.id < 10 THEN l.id ELSE 10 END, l.label'
+ );
+
+ # Virtual 'No label' label, only ever has private VNs.
+ push @$l, {
+ id => 0, label => 'No label', private => 1,
+ $count ? (count => tuwf->dbVali("SELECT count(*) FROM ulist_vns WHERE labels IN('{}','{7}') AND uid =", \$uid)) : (),
+ } if $own;
+
+ $l
+}
+
+
+# Enrich a list of VNs with data necessary for ulist_widget_.
+sub enrich_ulists_widget {
+ enrich_merge id => sql('SELECT vid AS id, true AS on_vnlist FROM ulist_vns WHERE uid =', \auth->uid, 'AND vid IN'), @_ if auth;
+
+ enrich vnlist_labels => id => vid => sub { sql '
+ SELECT uv.vid, ul.id, ul.label
+ FROM ulist_vns uv, unnest(uv.labels) l(id), ulist_labels ul
+ WHERE ul.uid =', \auth->uid, 'AND uv.uid =', \auth->uid, 'AND ul.id = l.id AND uv.vid IN', $_[0], '
+ ORDER BY CASE WHEN ul.id < 10 THEN ul.id ELSE 10 END, ul.label'
+ }, @_ if auth;
+}
+
+sub ulists_widget_ {
+ my($v) = @_;
+ elm_ 'UList.Widget', $VNWeb::ULists::Elm::WIDGET, {
+ uid => auth->uid,
+ vid => $v->{id},
+ labels => $v->{on_vnlist} ? $v->{vnlist_labels} : undef,
+ full => undef,
+ }, sub {
+ my $img = !$v->{on_vnlist} ? 'add' :
+ (reverse sort map "l$_->{id}", grep $_->{id} >= 1 && $_->{id} <= 6, $v->{vnlist_labels}->@*)[0] || 'unknown';
+ abbr_ @_, class => "icon-list-$img ulist-widget-icon", '';
+ } if auth && exists $v->{vnlist_labels};
+}
+
+
+# Returns the data structure for the elm_UListWidget API response for the given VN.
+sub ulists_widget_full_data {
+ my($v, $uid, $vnpage, $canvote) = @_;
+ my $lst = tuwf->dbRowi('SELECT vid, vote, notes, started, finished, labels FROM ulist_vns WHERE uid =', \$uid, 'AND vid =', \$v->{id});
+ my $review = tuwf->dbVali('SELECT id FROM reviews WHERE uid =', \$uid, 'AND vid =', \$v->{id});
+ $canvote //= sprintf('%08d', $v->{c_released}||99999999) <= strftime '%Y%m%d', gmtime;
+ +{
+ uid => $uid,
+ vid => $v->{id},
+ labels => $lst->{vid} ? [ map +{ id => $_, label => '' }, $lst->{labels}->@* ] : undef,
+ full => {
+ title => $vnpage ? '' : $v->{title}[1],
+ labels => tuwf->dbAlli('SELECT id, label, private FROM ulist_labels WHERE uid =', \$uid, 'ORDER BY CASE WHEN id < 10 THEN id ELSE 10 END, label'),
+ canvote => $lst->{vote} || $canvote || 0,
+ canreview => $review || ($canvote && can_edit(w => {})) || 0,
+ vote => fmtvote($lst->{vote}),
+ review => $review,
+ notes => $lst->{notes}||'',
+ started => $lst->{started}||'',
+ finished => $lst->{finished}||'',
+ releases => $vnpage ? [] : releases_by_vn($v->{id}),
+ rlist => $vnpage ? [] : tuwf->dbAlli('SELECT rid AS id, status FROM rlists WHERE uid =', \$uid, 'AND rid IN(SELECT id FROM releases_vn WHERE vid =', \$v->{id}, ')'),
+ },
+ };
+
+}
+
+1;
diff --git a/lib/VNWeb/ULists/List.pm b/lib/VNWeb/ULists/List.pm
new file mode 100644
index 00000000..04ca3e16
--- /dev/null
+++ b/lib/VNWeb/ULists/List.pm
@@ -0,0 +1,348 @@
+package VNWeb::ULists::Main;
+
+use VNWeb::Prelude;
+use VNWeb::ULists::Lib;
+use VNWeb::Releases::Lib;
+
+
+my $TABLEOPTS = VNWeb::VN::List::TABLEOPTS('ulist');
+
+
+sub opt {
+ my($u, $labels) = @_;
+
+ # Note that saved defaults may still use the old query format, which is
+ # { s => $sort_column, o => $order, c => [$visible_columns] }
+ my sub load { my $o = $u->{"ulist_$_[0]"}; ($o && eval { JSON::XS->new->decode($o) } or {})->%* };
+
+ state $s_default = tuwf->compile({ tableopts => $TABLEOPTS })->validate(undef)->data;
+ state $s_vnlist = $s_default->sort_param(title => 'a')->vis_param(qw/label vote added started finished/)->query_encode;
+ state $s_votes = $s_default->sort_param(voted => 'd')->vis_param(qw/vote voted/)->query_encode;
+ state $s_wishlist = $s_default->sort_param(title => 'a')->vis_param(qw/label added/)->query_encode;
+ state @all = (mul => 0, p => 1, f => '', q => tuwf->compile({ searchquery => 1 })->validate(undef)->data);
+
+ my $opt =
+ # Presets
+ tuwf->reqGet('vnlist') ? { @all, l => [1,2,3,4,7,0], s => $s_vnlist, load 'vnlist' } :
+ tuwf->reqGet('votes') ? { @all, l => [7], s => $s_votes, load 'votes' } :
+ tuwf->reqGet('wishlist') ? { @all, l => [5], s => $s_wishlist, load 'wish' } :
+ # Full options
+ tuwf->validate(get =>
+ p => { upage => 1 },
+ ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } },
+ q => { searchquery => 1 },
+ %VNWeb::ULists::Elm::SAVED_OPTS,
+ # Compat for old URLs
+ o => { onerror => undef, enum => ['a', 'd'] },
+ c => { onerror => undef, type => 'array', scalar => 1, values => { enum => [qw[ label vote voted added modified started finished rel rating ]] } },
+ )->data;
+ $opt->{ch} = $opt->{ch}[0];
+
+ $opt->{s} .= "/$opt->{o}" if $opt->{o};
+ $opt->{s} = tuwf->compile({ tableopts => $TABLEOPTS })->validate($opt->{s})->data;
+ $opt->{s} = $opt->{s}->vis_param($opt->{c}->@*) if $opt->{c};
+ delete $opt->{o};
+ delete $opt->{c};
+
+ $opt->{f} = tuwf->compile({ advsearch_err => 'v' })->validate($opt->{f})->data;
+
+ # $labels only includes labels we are allowed to see, getting rid of any
+ # labels in 'l' that aren't in $labels ensures we only filter on visible
+ # labels.
+ # Also, '-1' used to refer to the virtual "No label" label, now it's '0' instead.
+ my %accessible_labels = map +($_->{id}, 1), @$labels;
+ my %opt_l = map +($_, 1), grep $accessible_labels{$_}, map $_ == -1 ? 0 : $_, $opt->{l}->@*;
+ %opt_l = %accessible_labels if !keys %opt_l;
+ $opt->{l} = keys %opt_l == keys %accessible_labels ? [] : [ sort keys %opt_l ];
+
+ ($opt, \%opt_l)
+}
+
+
+sub filters_ {
+ my($own, $labels, $opt, $opt_labels, $url) = @_;
+
+ my sub lblfilt_ {
+ input_ type => 'checkbox', name => 'l', value => $_->{id}, id => "form_l$_->{id}", tabindex => 10, $opt_labels->{$_->{id}} ? (checked => 'checked') : ();
+ label_ for => "form_l$_->{id}", "$_->{label} ";
+ txt_ " ($_->{count})";
+ }
+
+ div_ class => 'labelfilters', sub {
+ # Implicit behavior alert: pressing enter in this input will activate
+ # the *first* submit button in the form, which happens to be the "ALL"
+ # character selector. Let's just pretend that is intended behavior.
+ input_ type => 'text', class => 'text', name => 'q', value => $opt->{q}||'', style => 'width: 500px', placeholder => 'Search', tabindex => 10;
+ br_;
+ span_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'ch', value => ($_//''), ($_//'') eq ($opt->{ch}//'') ? (class => 'optselected') : (), !defined $_ ? 'ALL' : $_ ? uc $_ : '#'
+ for (undef, 'a'..'z', 0);
+ };
+ input_ type => 'hidden', name => 'ch', value => $opt->{ch}//'';
+ $opt->{f}->elm_;
+ p_ class => 'linkradio', sub {
+ join_ sub { em_ ' / ' }, \&lblfilt_, grep $_->{id} < 10, @$labels;
+ span_ class => 'hidden', sub {
+ em_ ' || ';
+ input_ type => 'checkbox', name => 'mul', value => 1, id => 'form_l_multi', tabindex => 10, $opt->{mul} ? (checked => 'checked') : ();
+ label_ for => 'form_l_multi', 'Multi-select';
+ };
+ debug_ $labels;
+ my @cust = grep $_->{id} >= 10, @$labels;
+ if(@cust) {
+ br_;
+ join_ sub { em_ ' / ' }, \&lblfilt_, @cust;
+ }
+ };
+ input_ type => 'submit', class => 'submit', tabindex => 10, value => 'Update filters';
+ input_ type => 'button', class => 'submit', tabindex => 10, id => 'managelabels', value => 'Manage labels' if $own;
+ input_ type => 'button', class => 'submit', tabindex => 10, id => 'savedefault', value => 'Save as default' if $own;
+ input_ type => 'button', class => 'submit', tabindex => 10, id => 'exportlist', value => 'Export' if $own;
+ };
+}
+
+
+sub vn_ {
+ my($uid, $own, $opt, $n, $v, $labels) = @_;
+ tr_ mkclass(odd => $n % 2 == 0), id => "ulist_tr_$v->{id}", sub {
+ my %labels = map +($_,1), $v->{labels}->@*;
+
+ td_ class => 'tc1', sub {
+ input_ type => 'checkbox', class => 'checkhidden', 'x-checkall' => 'collapse_vid', id => 'collapse_vid'.$v->{id}, value => 'collapsed_vid'.$v->{id};
+ label_ for => 'collapse_vid'.$v->{id}, sub {
+ my $obtained = grep $_->{status} == 2, $v->{rels}->@*;
+ my $total = $v->{rels}->@*;
+ span_ id => 'ulist_relsum_'.$v->{id},
+ mkclass(done => $total && $obtained == $total, todo => $obtained < $total),
+ sprintf '%d/%d', $obtained, $total;
+ if($own) {
+ my $public = List::Util::any { $labels{$_->{id}} && !$_->{private} } @$labels;
+ my $publicLabel = List::Util::any { $_->{id} != 7 && $labels{$_->{id}} && !$_->{private} } @$labels;
+ span_ mkclass(invisible => !$public),
+ id => 'ulist_public_'.$v->{id},
+ 'data-publabel' => !!$publicLabel,
+ 'data-voted' => !!$labels{7},
+ title => 'This item is public', ' 👁';
+ }
+ };
+ };
+
+ td_ class => 'tc_voted', $v->{vote_date} ? fmtdate $v->{vote_date}, 'compact' : '-' if $opt->{s}->vis('voted');
+
+ td_ mkclass(tc_vote => 1, compact => $own, stealth => $own), sub {
+ txt_ fmtvote $v->{vote} if !$own;
+ elm_ 'UList.VoteEdit' => $VNWeb::ULists::Elm::VNVOTE, { uid => $uid, vid => $v->{id}, vote => fmtvote($v->{vote}) }, sub {
+ div_ @_, fmtvote $v->{vote}
+ } if $own && ($v->{vote} || sprintf('%08d', $v->{c_released}||0) < strftime '%Y%m%d', gmtime);
+ } if $opt->{s}->vis('vote');
+
+ td_ class => 'tc_rating', sub {
+ txt_ sprintf '%.2f', ($v->{c_rating}||0)/100;
+ small_ sprintf ' (%d)', $v->{c_votecount};
+ } if $opt->{s}->vis('rating');
+ td_ class => 'tc_average',sub {
+ txt_ sprintf '%.2f', ($v->{c_average}||0)/100;
+ small_ sprintf ' (%d)', $v->{c_votecount} if !$opt->{s}->vis('rating');
+ } if $opt->{s}->vis('average');
+
+ td_ class => 'tc_labels', sub {
+ my @l = grep $labels{$_->{id}} && $_->{id} != 7, @$labels;
+ my $txt = @l ? join ', ', map $_->{label}, @l : '-';
+ if($own) {
+ elm_ 'UList.LabelEdit' => $VNWeb::ULists::Elm::VNLABELS_OUT, { vid => $v->{id}, selected => [ grep $_ != 7, $v->{labels}->@* ] }, sub {
+ div_ @_, $txt;
+ };
+ } else {
+ txt_ $txt;
+ }
+ } if $opt->{s}->vis('label');
+
+ td_ class => 'tc_title', sub {
+ a_ href => "/$v->{id}", tattr $v;
+ small_ id => 'ulist_notes_'.$v->{id}, $v->{notes} if $v->{notes} || $own;
+ };
+ td_ class => 'tc_dev', sub {
+ join_ ' & ', sub {
+ a_ href => "/$_->{id}", tattr $_;
+ }, $v->{developers}->@*;
+ } if $opt->{s}->vis('developer');
+
+ td_ class => 'tc_added', fmtdate $v->{added}, 'compact' if $opt->{s}->vis('added');
+ td_ class => 'tc_modified', fmtdate $v->{lastmod}, 'compact' if $opt->{s}->vis('modified');
+
+ td_ class => 'tc_started', sub {
+ txt_ $v->{started}||'' if !$own;
+ elm_ 'UList.DateEdit' => $VNWeb::ULists::Elm::VNDATE, { uid => $uid, vid => $v->{id}, date => $v->{started}||'', start => 1 }, sub {
+ div_ @_, $v->{started}||''
+ } if $own;
+ } if $opt->{s}->vis('started');
+
+ td_ class => 'tc_finished', sub {
+ txt_ $v->{finished}||'' if !$own;
+ elm_ 'UList.DateEdit' => $VNWeb::ULists::Elm::VNDATE, { uid => $uid, vid => $v->{id}, date => $v->{finished}||'', start => 0 }, sub {
+ div_ @_, $v->{finished}||''
+ } if $own;
+ } if $opt->{s}->vis('finished');
+
+ td_ class => 'tc_rel', sub { rdate_ $v->{c_released} } if $opt->{s}->vis('released');
+ td_ class => 'tc_length',sub { VNWeb::VN::List::len_($v) } if $opt->{s}->vis('length');
+ };
+
+ tr_ mkclass(hidden => 1, 'collapsed_vid'.$v->{id} => 1, odd => $n % 2 == 0), sub {
+ td_ colspan => 7, class => 'tc_opt', sub {
+ my $relstatus = [ map $_->{status}, $v->{rels}->@* ];
+ elm_ 'UList.Opt' => $VNWeb::ULists::Elm::VNOPT, { own => $own?1:0, uid => $uid, vid => $v->{id}, notes => $v->{notes}, rels => $v->{rels}, relstatus => $relstatus };
+ };
+ };
+}
+
+
+sub listing_ {
+ my($uid, $own, $opt, $labels, $url) = @_;
+
+ my @l = grep $_ > 0 && $_ != 7, $opt->{l}->@*;
+ my $unlabeled = grep $_ == 0, $opt->{l}->@*;
+ my $voted = grep $_ == 7, $opt->{l}->@*;
+
+ my @where_vns = (
+ @l ? sql('uv.labels &&', sql_array(@l), '::smallint[]') : (),
+ $unlabeled ? sql("uv.labels IN('{}','{7}')") : (),
+ $voted ? sql('uv.vote IS NOT NULL') : ()
+ );
+
+ my $where = sql_and
+ sql('uv.uid =', \$uid),
+ $opt->{f}->sql_where(),
+ $opt->{q}->sql_where('v', 'v.id'),
+ $own ? () : 'NOT uv.c_private AND NOT v.hidden',
+ @where_vns ? sql_or(@where_vns) : (),
+ defined($opt->{ch}) ? sql 'match_firstchar(v.sorttitle, ', \$opt->{ch}, ')' : ();
+
+ my $count = tuwf->dbVali('SELECT count(*) FROM ulist_vns uv JOIN', vnt, 'v ON v.id = uv.vid WHERE', $where);
+
+ my $lst = tuwf->dbPagei({ page => $opt->{p}, results => $opt->{s}->results },
+ 'SELECT v.id, v.title, uv.vote, uv.notes, uv.labels, uv.started, uv.finished
+ , v.c_released, v.c_average, v.c_rating, v.c_votecount, v.c_released
+ , v.image, v.c_platforms::text[] AS platforms, v.c_languages::text[] AS lang
+ ,', sql_totime('uv.added'), ' as added
+ ,', sql_totime('uv.lastmod'), ' as lastmod
+ ,', sql_totime('uv.vote_date'), ' as vote_date',
+ $opt->{s}->vis('length') ? ', v.length, v.c_length, v.c_lengthnum' : (), '
+ FROM ulist_vns uv
+ JOIN', vnt, 'v ON v.id = uv.vid
+ WHERE', $where, '
+ ORDER BY', $opt->{s}->sql_order(), 'NULLS LAST, v.sorttitle'
+ );
+
+ enrich rels => id => vid => sub { sql '
+ SELECT rv.vid, r.id, rl.status, rv.rtype
+ FROM rlists rl
+ JOIN', releasest, 'r ON rl.rid = r.id
+ JOIN releases_vn rv ON rv.id = r.id
+ WHERE rl.uid =', \$uid, '
+ AND rv.vid IN', $_, '
+ ORDER BY r.released, r.sorttitle, r.id'
+ }, $lst;
+ enrich_release_elm map $_->{rels}, @$lst;
+ VNWeb::VN::List::enrich_listing(auth && auth->uid eq $uid && !$opt->{s}->rows(), $opt, $lst);
+
+ return VNWeb::VN::List::listing_($opt, $lst, $count, 0, $labels) if !$opt->{s}->rows;
+
+ # TODO: Consolidate the 'rows' listing with VN::List as well
+ paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 't', $opt->{s};
+ article_ class => 'browse ulist', sub {
+ table_ sub {
+ thead_ sub { tr_ sub {
+ td_ class => 'tc1', sub {
+ input_ type => 'checkbox', class => 'checkall', 'x-checkall' => 'collapse_vid', id => 'collapse_vid';
+ label_ for => 'collapse_vid', sub { txt_ 'Opt' };
+ };
+ td_ class => 'tc_voted', sub { txt_ 'Vote date'; sortable_ 'voted', $opt, $url } if $opt->{s}->vis('voted');
+ td_ class => 'tc_vote', sub { txt_ 'Vote'; sortable_ 'vote', $opt, $url } if $opt->{s}->vis('vote');
+ td_ class => 'tc_pop', sub { txt_ 'Popularity'; sortable_ 'popularity', $opt, $url } if $opt->{s}->vis('popularity');
+ td_ class => 'tc_rating', sub { txt_ 'Rating'; sortable_ 'rating', $opt, $url } if $opt->{s}->vis('rating');
+ td_ class => 'tc_average', sub { txt_ 'Average'; sortable_ 'average', $opt, $url } if $opt->{s}->vis('average');
+ td_ class => 'tc_labels', sub { txt_ 'Labels'; sortable_ 'label', $opt, $url } if $opt->{s}->vis('label');
+ td_ class => 'tc_title', sub { txt_ 'Title'; sortable_ 'title', $opt, $url; debug_ $lst };
+ td_ class => 'tc_dev', 'Developer' if $opt->{s}->vis('developer');
+ td_ class => 'tc_added', sub { txt_ 'Added'; sortable_ 'added', $opt, $url } if $opt->{s}->vis('added');
+ td_ class => 'tc_modified', sub { txt_ 'Modified'; sortable_ 'modified', $opt, $url } if $opt->{s}->vis('modified');
+ td_ class => 'tc_started', sub { txt_ 'Start date'; sortable_ 'started', $opt, $url } if $opt->{s}->vis('started');
+ td_ class => 'tc_finished', sub { txt_ 'Finish date'; sortable_ 'finished', $opt, $url } if $opt->{s}->vis('finished');
+ td_ class => 'tc_rel', sub { txt_ 'Release date';sortable_ 'released', $opt, $url } if $opt->{s}->vis('released');
+ td_ class => 'tc_length', 'Length' if $opt->{s}->vis('length');
+ }};
+ vn_ $uid, $own, $opt, $_, $lst->[$_], $labels for (0..$#$lst);
+ };
+ };
+ paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 'b';
+}
+
+
+TUWF::get qr{/$RE{uid}/ulist}, sub {
+ my $u = tuwf->dbRowi('
+ SELECT u.id,', sql_user(), ', ulist_votes, ulist_vnlist, ulist_wish
+ FROM users u JOIN users_prefs up ON up.id = u.id
+ WHERE u.id =', \tuwf->capture('id'));
+ return tuwf->resNotFound if !$u->{id};
+
+ my $own = ulists_own $u->{id};
+ my $labels = ulist_filtlabels $u->{id}, 1;
+ $_->{delete} = undef for @$labels;
+
+ my($opt, $opt_labels) = opt $u, $labels;
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ # This page has 3 user tabs: list, wish and votes; Select the appropriate active tab based on label filters.
+ my $num_core_labels = grep $_ < 10, keys %$opt_labels;
+ my $tab = $num_core_labels == 1 && $opt_labels->{7} ? 'votes'
+ : $num_core_labels == 1 && $opt_labels->{5} ? 'wish' : 'list';
+
+ my $title = $own ? 'My list' : user_displayname($u)."'s list";
+ framework_ title => $title, dbobj => $u, tab => $tab, js => 1,
+ $own ? ( pagevars => {
+ uid => $u->{id},
+ labels => $VNWeb::ULists::Elm::LABELS->analyze->{keys}{labels}->coerce_for_json($labels),
+ voteprivate => (map \($_->{private}?1:0), grep $_->{id} == 7, @$labels),
+ } ) : (),
+ sub {
+ my $empty = !grep $_->{count}, @$labels;
+ form_ method => 'get', sub {
+ article_ sub {
+ h1_ $title;
+ if($empty) {
+ p_ $own
+ ? 'Your list is empty! You can add visual novels to your list from the visual novel pages.'
+ : user_displayname($u).' does not have any visible visual novels in their list.';
+ } else {
+ filters_ $own, $labels, $opt, $opt_labels, \&url;
+ elm_ 'UList.ManageLabels' if $own;
+ elm_ 'UList.SaveDefault', $VNWeb::ULists::Elm::SAVED_OPTS_OUT, {
+ uid => $u->{id},
+ opts => { l => $opt->{l}, mul => $opt->{mul}, s => $opt->{s}->query_encode(), f => $opt->{f}->query_encode() },
+ } if $own;
+ div_ class => 'hidden exportlist', sub {
+ strong_ 'Export your list';
+ br_;
+ txt_ 'This function will export all visual novels and releases in your list, even those marked as private ';
+ txt_ '(there is currently no import function, more export options may be added later).';
+ br_;
+ br_;
+ a_ href => "/$u->{id}/list-export/xml", "Download XML export.";
+ } if $own;
+ }
+ };
+ listing_ $u->{id}, $own, $opt, $labels, \&url if !$empty;
+ }
+ };
+};
+
+
+
+# Redirects for old URLs
+TUWF::get qr{/$RE{uid}/votes}, sub { tuwf->resRedirect("/".tuwf->capture('id').'/ulist?votes=1', 'perm') };
+TUWF::get qr{/$RE{uid}/list}, sub { tuwf->resRedirect("/".tuwf->capture('id').'/ulist?vnlist=1', 'perm') };
+TUWF::get qr{/$RE{uid}/wish}, sub { tuwf->resRedirect("/".tuwf->capture('id').'/ulist?wishlist=1', 'perm') };
+
+
+1;
diff --git a/lib/VNWeb/User/Admin.pm b/lib/VNWeb/User/Admin.pm
new file mode 100644
index 00000000..36dd4da2
--- /dev/null
+++ b/lib/VNWeb/User/Admin.pm
@@ -0,0 +1,74 @@
+package VNWeb::User::Admin;
+
+use VNWeb::Prelude;
+
+my $FORM = {
+ id => { vndbid => 'u' },
+ username => { default => '' },
+
+ # Permissions of the user editing this account
+ editor_dbmod => { _when => 'out', anybool => 1 },
+ editor_usermod => { _when => 'out', anybool => 1 },
+ editor_tagmod => { _when => 'out', anybool => 1 },
+ editor_boardmod => { _when => 'out', anybool => 1 },
+
+ ign_votes => { anybool => 1 },
+ map +("perm_$_" => { anybool => 1 }), VNWeb::Auth::listPerms
+};
+
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_OUT = form_compile out => $FORM;
+
+sub _userinfo {
+ if(!auth->isMod) { tuwf->resDenied; tuwf->done; }
+ my $u = tuwf->dbRowi('
+ SELECT u.id, username, ign_votes, ', sql_comma(map "perm_$_", auth->listPerms), '
+ FROM users u
+ LEFT JOIN users_shadow us ON us.id = u.id
+ WHERE u.id =', \$_[0]
+ );
+ if(!$u->{id}) { tuwf->resNotFound; tuwf->done; }
+ $u
+}
+
+
+TUWF::get qr{/$RE{uid}/admin}, sub {
+ my $u = _userinfo tuwf->capture('id');
+
+ $u->{editor_dbmod} = auth->permDbmod;
+ $u->{editor_usermod} = auth->permUsermod;
+ $u->{editor_tagmod} = auth->permTagmod;
+ $u->{editor_boardmod} = auth->permBoardmod;
+
+ framework_ title => "Admin settings for ".($u->{username}//$u->{id}), dbobj => $u, tab => 'admin',
+ sub {
+ div_ widget(UserAdmin => $FORM_OUT, $u), '';
+ };
+};
+
+
+js_api UserAdmin => $FORM_IN, sub {
+ my($data) = @_;
+ my $u = _userinfo $data->{id};
+
+ tuwf->dbExeci(select => sql_func user_setperm_usermod => \$u->{id}, \auth->uid, sql_fromhex(auth->token), \$data->{perm_usermod})
+ if auth->permUsermod;
+
+ my @set = (
+ auth->permUsermod
+ ? ('ign_votes', map "perm_$_", grep $_ ne 'usermod', auth->listPerms)
+ : (
+ auth->permBoardmod ? qw/perm_board perm_review/ : (),
+ auth->permDbmod ? qw/perm_edit perm_imgvote perm_lengthvote/ : (),
+ auth->permTagmod ? qw/perm_tag/ : (),
+ ),
+ );
+ tuwf->dbExeci('UPDATE users SET', { map +($_, $data->{$_}), @set }, 'WHERE id =', \$u->{id});
+
+ my $new = _userinfo $u->{id};
+ my @diff = grep $u->{$_} ne $new->{$_}, @set;
+ auth->audit($data->{id}, 'user admin', join '; ', map "$_: $u->{$_} -> $new->{$_}", @diff) if @diff;
+ +{ ok => 1 }
+};
+
+1;
diff --git a/lib/VNWeb/User/Css.pm b/lib/VNWeb/User/Css.pm
new file mode 100644
index 00000000..10d21097
--- /dev/null
+++ b/lib/VNWeb/User/Css.pm
@@ -0,0 +1,37 @@
+package VNWeb::User::Css;
+
+use VNWeb::Prelude;
+
+
+sub _sanitize_css {
+ # This function is attempting to do the impossible: Sanitize user provided
+ # CSS against various attacks. I'm not expecting this to be bullet-proof.
+ # Fortunately, we also have CSP in place to mitigate some problems if they
+ # arise, but I'd rather not rely on it. I'd *love* to disable support for
+ # external url()'s, but unfortunately many people use that to load images.
+ # I'm afraid the only way to work around that is to fetch and cache those
+ # URLs on the server.
+ local $_ = $_[0];
+ s/\\//g; # Get rid of backslashes, could be used to bypass the other regexes.
+ s/@(import|charset|font-face)[^\n\;]*.//ig;
+ s/javascript\s*://ig; # Not sure 'javascript:' URLs do anything, but just in case.
+ s/expression\s*\(//ig; # An old IE thing I guess.
+ s/binding\s*://ig; # Definitely don't want bindings.
+ $_;
+}
+
+
+TUWF::get qr{/$RE{uid}\.css}, sub {
+ my $u = tuwf->dbRowi('
+ SELECT u.id, pubskin_can, pubskin_enabled, customcss
+ FROM users u
+ JOIN users_prefs up ON up.id = u.id
+ WHERE u.id =', \tuwf->capture('id'));
+ return tuwf->resNotFound if !$u->{id};
+ return tuwf->resDenied if !($u->{pubskin_can} && $u->{pubskin_enabled}) && !(auth && auth->uid eq $u->{id});
+ tuwf->resHeader('Content-type', 'text/css; charset=UTF8');
+ tuwf->resHeader('Cache-Control', 'max-age=31536000'); # invalidation is done by adding a checksum to the URL.
+ lit_ _sanitize_css $u->{customcss};
+};
+
+1;
diff --git a/lib/VNWeb/User/Delete.pm b/lib/VNWeb/User/Delete.pm
new file mode 100644
index 00000000..6e7827d4
--- /dev/null
+++ b/lib/VNWeb/User/Delete.pm
@@ -0,0 +1,214 @@
+package VNWeb::User::Delete;
+
+use VNWeb::Prelude;
+
+
+sub _getmail {
+ tuwf->dbVali(select => sql_func user_getmail => \auth->uid, \auth->uid, sql_fromhex auth->token);
+}
+
+sub set_delete {
+ return 0 if tuwf->reqMethod ne 'POST';
+ my $pwd = tuwf->validate(post => password => { password => 1, onerror => undef })->data // return 1;
+ return 1 if !VNWeb::Auth->new->login(auth->uid, $pwd, 1);
+
+ tuwf->dbExeci(select => sql_func user_setdelete => \auth->uid, sql_fromhex(auth->token), \1);
+ auth->audit(auth->uid, 'mark for deletion');
+
+ my $path = '/'.auth->uid.'/del/'.auth->token;
+ my $body = sprintf
+ "Hello %s,"
+ ."\n"
+ ."\nAs per your request, your account is scheduled for deletion in approximately 7 days."
+ ."\nTo view the status of your request or to cancel the deletion, visit the link below before the timer expires:"
+ ."\n"
+ ."\n%s"
+ ."\n"
+ ."\nvndb.org",
+ auth->user->{user_name}, tuwf->reqBaseURI().$path;
+
+ tuwf->mail($body,
+ To => _getmail(),
+ From => 'VNDB <noreply@vndb.org>',
+ Subject => 'Account deletion for '.auth->user->{user_name},
+ );
+ tuwf->resRedirect($path, 'post');
+ tuwf->done;
+}
+
+
+TUWF::any ['get','post'], qr{/$RE{uid}/del}, sub {
+ my $uid = auth->uid;
+ return tuwf->resNotFound if !auth || tuwf->capture('id') ne auth->uid;
+
+ my $invalid = set_delete;
+
+ framework_ title => 'Account deletion', sub {
+ article_ sub {
+ h1_ 'Account deletion';
+ div_ class => 'warning', 'Account deletion is permanent and your data cannot be restored. Proceed with care!';
+
+ h2_ 'E-mail opt-out';
+ p_ sub {
+ txt_ 'You can NOT register a new account in the future with the email address associated with this account: ';
+ strong_ _getmail;
+ txt_ '.';
+ };
+
+ my $vns = tuwf->dbVali('SELECT COUNT(*) FROM ulist_vns WHERE uid =', \$uid);
+ if ($vns) {
+ h2_ 'Visual novel list';
+ p_ sub {
+ a_ href => "/$uid/ulist", 'Your visual novel list';
+ txt_ ' will be deleted with your account.';
+ };
+ p_ sub {
+ txt_ 'Your list currently holds ';
+ strong_ $vns;
+ txt_ ' visual novels, consider making a local backup through the "Export" button before proceeding with the deletion.';
+ };
+ }
+
+ my $posts = tuwf->dbVali('SELECT
+ (SELECT COUNT(*)
+ FROM threads_posts tp
+ WHERE hidden IS NULL AND uid =', \$uid, '
+ AND EXISTS(SELECT 1 FROM threads t WHERE t.id = tp.tid AND NOT t.hidden)
+ ) +
+ (SELECT COUNT(*) FROM reviews_posts WHERE hidden IS NULL AND uid =', \$uid, ')');
+ if ($posts) {
+ h2_ 'Forum posts';
+ p_ sub {
+ a_ href => "/$uid/posts", sub {
+ txt_ 'Your ';
+ strong_ $posts;
+ txt_ ' forum posts';
+ };
+ txt_ ' will remain after your account has been deleted.';
+ };
+ p_ 'Please send an email to '.config->{admin_email}.' if these contain sensitive information that you wish to have deleted.';
+ }
+
+ my $edits = tuwf->dbVali('SELECT COUNT(*) FROM changes WHERE requester =', \$uid);
+ if ($edits) {
+ h2_ 'Database edits';
+ p_ sub {
+ a_ href => "/$uid/hist", sub {
+ txt_ 'Your ';
+ strong_ $edits;
+ txt_ ' database edits';
+ };
+ txt_ ' will remain after your account has been deleted.';
+ };
+ p_ 'Please send an email to '.config->{admin_email}.' if these contain sensitive information that you wish to have deleted.';
+ }
+
+ my $reviews = tuwf->dbVali('SELECT COUNT(*) FROM reviews WHERE uid =', \$uid);
+ if ($reviews) {
+ h2_ 'Reviews';
+ p_ sub {
+ a_ href => "/w?u=$uid", sub {
+ txt_ 'Your ';
+ strong_ $reviews;
+ txt_ ' reviews';
+ };
+ txt_ ' will remain after your account has been deleted.';
+ };
+ p_ "If you don't want this, make sure to delete the reviews by going through the edit form.";
+ }
+
+ my $lengthvotes = tuwf->dbVali('SELECT COUNT(*) FROM vn_length_votes WHERE NOT private AND uid =', \$uid);
+ my $imgvotes = tuwf->dbVali('SELECT COUNT(*) FROM image_votes WHERE uid =', \$uid);
+ my $tags = tuwf->dbVali('SELECT COUNT(*) FROM tags_vn WHERE uid =', \$uid);
+ my $quotes => tuwf->dbVali('SELECT COUNT(*) FROM quotes WHERE addedby =', \$uid);
+ if ($lengthvotes || $imgvotes || $tags || $quotes) {
+ h2_ 'Misc. database contributions';
+ p_ 'Your database contributions will remain after your account has been deleted, these include:';
+ ul_ sub {
+ li_ sub { strong_ $lengthvotes; txt_ ' visual novel play times.'; } if $lengthvotes;
+ li_ sub { strong_ $imgvotes; txt_ ' image flagging votes.'; } if $imgvotes;
+ li_ sub { strong_ $tags; txt_ ' visual novel tags.'; } if $tags;
+ li_ sub { strong_ $quotes; txt_ ' visual novel quotes.'; } if $quotes;
+ };
+ }
+
+ br_;
+ h2_ 'Confirm account deletion';
+ form_ method => 'POST', class => 'invalid-form', sub {
+ fieldset_ class => 'form', sub {
+ fieldset_ sub {
+ label_ for => 'password', 'Password';
+ input_ type => 'password', id => 'password', name => 'password', required => 1, class => 'mw';
+ p_ class => 'invalid', 'Invalid password.' if $invalid;
+ };
+ fieldset_ sub {
+ input_ type => 'submit', value => 'Delete my account';
+ p_ 'Your account will be deleted approximately 7 days after confirmation. You can cancel the deletion before that time.';
+ };
+ };
+ };
+ };
+ };
+};
+
+
+TUWF::any ['post','get'], qr{/$RE{uid}/del/([a-fA-F0-9]{40})}, sub {
+ my($uid, $token) = tuwf->captures(1,2);
+ return tuwf->resRedirect('/', 'temp') if auth && auth->uid ne $uid;
+
+ my $u = tuwf->dbRowi('
+ SELECT ', sql_totime('us.delete_at'), 'delete_at, ', sql_user(), '
+ , ', sql_func(user_validate_session => 'u.id', sql_fromhex($token), \'web'), 'IS DISTINCT FROM NULL AS valid
+ FROM users u
+ JOIN users_shadow us ON us.id = u.id
+ WHERE u.id =', \$uid
+ );
+
+ my $cancelled;
+ if (tuwf->reqMethod eq 'POST' && $u->{valid} && $u->{delete_at}) {
+ # TODO: Ideally this should just auto-login and redirect, but doing so
+ # with the current session token is a bad idea and I'm too lazy to code
+ # a session token renewal thing.
+ # TODO: This should really invalidate all existing session tokens,
+ # given that we could also have reached this page with a fresh token on
+ # login.
+ tuwf->dbExeci(select => sql_func user_setdelete => \$uid, sql_fromhex($token), \0);
+ tuwf->dbExeci(select => sql_func user_logout => \$uid, sql_fromhex $token);
+ auth->audit($uid, 'cancel deletion');
+ $cancelled = 1;
+ }
+
+ framework_ title => 'Account deletion', sub {
+ article_ $cancelled ? sub {
+ h1_ 'Account deletion cancelled';
+ p_ sub {
+ txt_ 'Your account is no longer scheduled for deletion. You can now ';
+ a_ href => '/u/login', 'login to your account again';
+ txt_ '.';
+ };
+ } : !defined $u->{user_name} ? sub {
+ h1_ 'No such user';
+ p_ 'No user found with that ID, perhaps the account has been deleted already.';
+ } : !$u->{valid} ? sub {
+ h1_ 'Invalid token';
+ } : !$u->{delete_at} ? sub {
+ h1_ 'No account deletion pending';
+ p_ 'Your account is not scheduled to be deleted.';
+ } : sub {
+ h1_ 'Account deletion pending';
+ p_ sub {
+ my $days = sprintf '%.0f', ($u->{delete_at}-time())/(24*3600);
+ txt_ 'Your account is scheduled to be deleted ';
+ txt_ $days < 1 ? 'in less than 24 hours.' :
+ $days < 2 ? 'tomorrow.' : "in approximately $days days.";
+ };
+ form_ method => 'POST', sub {
+ p_ sub {
+ input_ type => 'submit', value => 'Cancel account deletion';
+ };
+ };
+ };
+ };
+};
+
+1;
diff --git a/lib/VNWeb/User/Edit.pm b/lib/VNWeb/User/Edit.pm
index bfd2e5f8..a4e42ad8 100644
--- a/lib/VNWeb/User/Edit.pm
+++ b/lib/VNWeb/User/Edit.pm
@@ -1,44 +1,94 @@
package VNWeb::User::Edit;
use VNWeb::Prelude;
+use VNDB::Skins;
+use VNWeb::TitlePrefs '/./';
+use VNWeb::TimeZone;
+use Digest::SHA 'sha1';
-my $FORM = form_compile in => {
- username => { username => 1 },
- email => { email => 1 },
- perm => { uint => 1, func => sub { ($_[0] & ~auth->allPerms) == 0 } },
- ign_votes => { anybool => 1 },
- show_nsfw => { anybool => 1 },
- traits_sexual => { anybool => 1 },
- tags_all => { anybool => 1 },
- tags_cont => { anybool => 1 },
- tags_ero => { anybool => 1 },
- tags_tech => { anybool => 1 },
- spoilers => { uint => 1, range => [ 0, 2 ] },
- skin => { enum => tuwf->{skins} },
- customcss => { required => 0, default => '', maxlength => 2000 },
-
- nodistract_can => { anybool => 1 },
+
+my $FORM = {
+ id => { vndbid => 'u' },
+ username => { username => 1 },
+ username_throttled => { _when => 'out', anybool => 1 },
+ email => { email => 1 },
+ password => { default => undef, type => 'hash', keys => {
+ old => { password => 1 },
+ new => { password => 1 }
+ } },
+
+ # Supporter options available to this user
+ editor_usermod => { anybool => 1 },
+ nodistract_can => { _when => 'out', anybool => 1 },
+ support_can => { _when => 'out', anybool => 1 },
+ uniname_can => { _when => 'out', anybool => 1 },
+ pubskin_can => { _when => 'out', anybool => 1 },
+ # Supporter options
nodistract_noads => { anybool => 1 },
nodistract_nofancy => { anybool => 1 },
- support_can => { anybool => 1 },
support_enabled => { anybool => 1 },
- uniname_can => { anybool => 1 },
- uniname => { required => 0, default => '', regex => qr/^.{2,15}$/ }, # Use regex to check length, HTML5 `maxlength` attribute counts UTF-16 code units...
- pubskin_can => { anybool => 1 },
+ uniname => { default => '', sl => 1, length => [2,15] },
pubskin_enabled => { anybool => 1 },
- password => { _when => 'in', required => 0, type => 'hash', keys => {
- old => { password => 1 },
- new => { password => 1 }
+ traits => { sort_keys => 'tid', maxlength => 100, aoh => {
+ tid => { vndbid => 'i' },
+ name => { _when => 'out' },
+ group => { _when => 'out', default => undef },
+ } },
+
+ timezone => { default => '', enum => \%ZONES },
+ max_sexual => { int => 1, range => [-1, 2 ] },
+ max_violence => { uint => 1, range => [ 0, 2 ] },
+ spoilers => { uint => 1, range => [ 0, 2 ] },
+ titles => { titleprefs => 1 },
+ alttitles => { titleprefs => 1 },
+ tags_all => { anybool => 1 },
+ tags_cont => { anybool => 1 },
+ tags_ero => { anybool => 1 },
+ tags_tech => { anybool => 1 },
+ vnrel_langs => { default => undef, type => 'array', values => { enum => \%LANGUAGE }, sort => 'str', unique => 1 },
+ vnrel_olang => { anybool => 1 },
+ vnrel_mtl => { anybool => 1 },
+ staffed_langs => { default => undef, type => 'array', values => { enum => \%LANGUAGE }, sort => 'str', unique => 1 },
+ staffed_olang => { anybool => 1 },
+ staffed_unoff => { anybool => 1 },
+ traits_sexual => { anybool => 1 },
+ prodrelexpand => { anybool => 1 },
+ skin => { enum => skins },
+ customcss => { default => '', maxlength => 256*1024 },
+ customcss_csum => { anybool => 1 },
+
+ tagprefs => { sort_keys => 'tid', maxlength => 500, aoh => {
+ tid => { vndbid => 'g' },
+ spoil => { default => undef, int => 1, range => [ 0, 3 ] },
+ color => { default => undef, regex => qr/^(standout|grayedout|#[a-fA-F0-9]{6})$/ },
+ childs => { anybool => 1 },
+ name => {},
+ } },
+
+ traitprefs => { sort_keys => 'tid', maxlength => 500, aoh => {
+ tid => { vndbid => 'i' },
+ spoil => { default => undef, int => 1, range => [ 0, 3 ] },
+ color => { default => undef, regex => qr/^(standout|grayedout|#[a-fA-F0-9]{6})$/ },
+ childs => { anybool => 1 },
+ name => {},
+ group => { default => undef },
} },
- id => { uint => 1 },
- # This is technically only used for Perl->Elm data, but also received from
- # Elm in order to make the Send and Recv types equivalent.
- authmod => { anybool => 1 },
+ api2 => { maxlength => 64, aoh => {
+ token => {},
+ added => {},
+ lastused => { default => '' },
+ notes => { default => '', sl => 1, maxlength => 200 },
+ listread => { anybool => 1 },
+ listwrite => { anybool => 1 },
+ delete => { anybool => 1 },
+ } },
};
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_OUT = form_compile out => $FORM;
sub _getmail {
@@ -46,74 +96,105 @@ sub _getmail {
tuwf->dbVali(select => sql_func user_getmail => \$uid, \auth->uid, sql_fromhex auth->token);
}
+sub _namethrottled {
+ my($uid) = @_;
+ !auth->permUsermod && tuwf->dbVali('SELECT 1 FROM users_username_hist WHERE id =', \$uid, 'AND date > NOW()-\'1 day\'::interval')
+}
+
TUWF::get qr{/$RE{uid}/edit}, sub {
- my $u = tuwf->dbRowi(q{
- SELECT id, username, perm, ign_votes, show_nsfw, traits_sexual
- , tags_all, tags_cont, tags_ero, tags_tech, spoilers, skin, customcss
- , nodistract_can, nodistract_noads, nodistract_nofancy, support_can, support_enabled, uniname_can, uniname, pubskin_can, pubskin_enabled
- FROM users WHERE id =}, \tuwf->capture('id')
+ my $u = tuwf->dbRowi(
+ 'SELECT u.id, username, max_sexual, max_violence, traits_sexual, tags_all, tags_cont, tags_ero, tags_tech, prodrelexpand
+ , vnrel_langs::text[], vnrel_olang, vnrel_mtl, staffed_langs::text[], staffed_olang, staffed_unoff
+ , spoilers, skin, customcss, customcss_csum, timezone, titles
+ , nodistract_can, support_can, uniname_can, pubskin_can
+ , nodistract_noads, nodistract_nofancy, support_enabled, uniname, pubskin_enabled
+ FROM users u JOIN users_prefs up ON up.id = u.id WHERE u.id =', \tuwf->capture('id')
);
-
return tuwf->resNotFound if !$u->{id} || !can_edit u => $u;
- $u->{email} = _getmail $u->{id};
- $u->{authmod} = auth->permUsermod;
- $u->{password} = undef;
+ $u->{editor_usermod} = auth->permUsermod;
+ $u->{username_throttled} = _namethrottled $u->{id};
+ $u->{email} = _getmail $u->{id};
+ $u->{password} = undef;
+
+ $u->{traits} = tuwf->dbAlli('SELECT u.tid, t.name, g.name AS "group" FROM users_traits u JOIN traits t ON t.id = u.tid LEFT JOIN traits g ON g.id = t.gid WHERE u.id =', \$u->{id}, 'ORDER BY g.gorder, t.name');
+ $u->{timezone} ||= 'UTC';
+ @{$u}{'titles','alttitles'} = @{ titleprefs_parse($u->{titles}) // $DEFAULT_TITLE_PREFS };
$u->{skin} ||= config->{skin_default};
- # Let's not disclose this (though it's not hard to find out through other means)
- if(!auth->permUsermod) {
- $u->{ign_votes} = 0;
- $u->{perm} = auth->defaultPerms;
- }
+ $u->{tagprefs} = tuwf->dbAlli('SELECT u.tid, u.spoil, u.color, u.childs, t.name FROM users_prefs_tags u JOIN tags t ON t.id = u.tid WHERE u.id =', \$u->{id}, 'ORDER BY t.name');
+ $u->{traitprefs} = tuwf->dbAlli('SELECT u.tid, u.spoil, u.color, u.childs, t.name, g.name as "group" FROM users_prefs_traits u JOIN traits t ON t.id = u.tid LEFT JOIN traits g ON g.id = t.gid WHERE u.id =', \$u->{id}, 'ORDER BY g.gorder, t.name');
+
+ $u->{api2} = auth->api2_tokens($u->{id});
- my $title = $u->{id} == auth->uid ? 'My Account' : "Edit $u->{username}";
- framework_ title => $title, type => 'u', dbobj => $u, tab => 'edit',
+ my $title = $u->{id} eq auth->uid ? 'My Account' : "Edit $u->{username}";
+ framework_ title => $title, dbobj => $u, tab => 'edit',
sub {
- elm_ 'User.Edit', $FORM, $u;
+ article_ sub {
+ h1_ $title;
+ };
+ div_ widget(UserEdit => $FORM_OUT, $u), '';
};
};
-elm_api UserEdit => undef, $FORM, sub {
+js_api UserEdit => $FORM_IN, sub {
my $data = shift;
- my $username = tuwf->dbVali('SELECT username FROM users WHERE id =', \$data->{id});
- return tuwf->resNotFound if !$username;
- return elm_Unauth if !can_edit u => $data;
+ my $u = tuwf->dbRowi('SELECT id, username FROM users WHERE id =', \$data->{id});
+ return tuwf->resNotFound if !$u->{id};
+ return tuwf->resDenied if !can_edit u => $u;
+
+ my(%set, %setp);
+
+ $data->{uniname} = '' if $data->{uniname} eq $u->{username};
+ return +{ code => 'uniname', _err => 'Display name already taken.' }
+ if $data->{uniname} && tuwf->dbVali('SELECT 1 FROM users WHERE id <>', \$data->{id}, 'AND lower(username) =', \lc($data->{uniname}));
+
+ $data->{skin} = '' if $data->{skin} eq config->{skin_default};
+ $data->{timezone} = '' if $data->{timezone} eq 'UTC';
+ $data->{titles} = titleprefs_fmt [ $data->{titles}, delete $data->{alttitles} ];
+ $data->{titles} = undef if $data->{titles} eq titleprefs_fmt $DEFAULT_TITLE_PREFS;
+
+ $data->{vnrel_langs} = !$data->{vnrel_langs} || $data->{vnrel_langs}->@* == keys %LANGUAGE ? undef : '{'.join(',',$data->{vnrel_langs}->@*).'}';
+ $data->{staffed_langs} = !$data->{staffed_langs} || $data->{staffed_langs}->@* == keys %LANGUAGE ? undef : '{'.join(',',$data->{staffed_langs}->@*).'}';
+
+ $set{$_} = $data->{$_} for qw/nodistract_noads nodistract_nofancy support_enabled uniname pubskin_enabled/;
+ $setp{$_} = $data->{$_} for qw/
+ tags_all tags_cont tags_ero tags_tech
+ vnrel_langs vnrel_olang vnrel_mtl staffed_langs staffed_olang staffed_unoff
+ skin customcss timezone max_sexual max_violence spoilers traits_sexual prodrelexpand titles
+ /;
+ $setp{customcss_csum} = $data->{customcss_csum} && length $data->{customcss} ? unpack 'q', sha1 do { utf8::encode(local $_=$data->{customcss}); $_ } : 0;
- return elm_Taken if $data->{uniname}
- && tuwf->dbVali('SELECT 1 FROM users WHERE id <>', \$data->{id}, 'AND username =', \lc($data->{uniname}));
+ $set{email_confirmed} = 1 if auth->permUsermod;
- if(auth->permUsermod) {
- tuwf->dbExeci(update => users => set => {
- username => $data->{username},
- ign_votes => $data->{ign_votes},
- email_confirmed => 1,
- }, where => { id => $data->{id} });
- tuwf->dbExeci(select => sql_func user_setperm => \$data->{id}, \auth->uid, sql_fromhex(auth->token), \$data->{perm});
+ if($data->{username} ne $u->{username}) {
+ return +{ _err => 'You can only change your username once a day.' } if _namethrottled $data->{id};
+ return +{ code => 'username_taken', _err => 'Username already taken.' } if !is_unique_username $data->{username}, $data->{id};
+ $set{username} = $data->{username};
+ auth->audit($data->{id}, 'username change', "old=$u->{username}; new=$data->{username}");
+ tuwf->dbExeci('INSERT INTO users_username_hist', { id => $data->{id}, old => $u->{username}, new => $data->{username} });
}
if($data->{password}) {
- return elm_InsecurePass if is_insecurepass $data->{password}{new};
-
- if(auth->uid == $data->{id}) {
- return elm_BadCurPass if !auth->setpass($data->{id}, undef, $data->{password}{old}, $data->{password}{new});
- } else {
- tuwf->dbExeci(select => sql_func user_admin_setpass => \$data->{id}, \auth->uid,
- sql_fromhex(auth->token), sql_fromhex auth->_preparepass($data->{password}{new})
- );
- }
+ return +{ code => 'npass', _err => 'Your new password is in a public database of leaked passwords, please choose a different password.' }
+ if is_insecurepass $data->{password}{new};
+ my $ok = auth->setpass($data->{id}, undef, $data->{password}{old}, $data->{password}{new});
+ auth->audit($data->{id}, $ok ? 'password change' : 'bad password', 'at user edit form');
+ return +{ code => 'opass', _err => 'Incorrect password' } if !$ok;
}
- my $ret = \&elm_Success;
+ my $ret = {ok=>1};
my $oldmail = _getmail $data->{id};
- if($data->{email} ne $oldmail) {
+ if ($oldmail ne $data->{email}) {
+ return +{ code => 'email_taken', _err => 'E-Mail address already in use by another account' }
+ if tuwf->dbVali('SELECT 1 FROM user_emailtoid(', \$data->{email}, ') x(id) WHERE id <>', \$data->{id});
+ auth->audit($data->{id}, 'email change', "old=$oldmail; new=$data->{email}");
if(auth->permUsermod) {
tuwf->dbExeci(select => sql_func user_admin_setmail => \$data->{id}, \auth->uid, sql_fromhex(auth->token), \$data->{email});
} else {
- return elm_DoubleEmail if tuwf->dbVali(select => sql_func user_emailexists => \$data->{email}, \$data->{id});
my $token = auth->setmail_token($data->{email});
my $body = sprintf
"Hello %s,"
@@ -123,27 +204,51 @@ elm_api UserEdit => undef, $FORM, sub {
."%s"
."\n\n"
."vndb.org",
- $username, $oldmail, $data->{email}, tuwf->reqBaseURI()."/u$data->{id}/setmail/$token";
+ $u->{username}, $oldmail, $data->{email}, tuwf->reqBaseURI()."/$data->{id}/setmail/$token";
tuwf->mail($body,
To => $data->{email},
From => 'VNDB <noreply@vndb.org>',
- Subject => "Confirm e-mail change for $username",
+ Subject => "Confirm e-mail change for $u->{username}",
);
- $ret = \&elm_MailChange;
+ $ret = {email=>1};
}
}
- $data->{skin} = '' if $data->{skin} eq config->{skin_default};
- $data->{uniname} = '' if $data->{uniname} eq $data->{username};
- tuwf->dbExeci('UPDATE users SET', { %{$data}{qw/
- show_nsfw traits_sexual tags_all tags_cont tags_ero tags_tech spoilers skin customcss
- nodistract_noads nodistract_nofancy support_enabled uniname pubskin_enabled
- /} },
- 'WHERE id =', \$data->{id}
- );
+ tuwf->dbExeci('DELETE FROM users_traits WHERE id =', \$data->{id});
+ tuwf->dbExeci('INSERT INTO users_traits', { id => $data->{id}, tid => $_->{tid} }) for $data->{traits}->@*;
+
+ tuwf->dbExeci('DELETE FROM users_prefs_tags WHERE id =', \$data->{id});
+ tuwf->dbExeci('INSERT INTO users_prefs_tags', { id => $data->{id}, %{$_}{qw|tid spoil color childs|} }) for $data->{tagprefs}->@*;
- $ret->();
+ tuwf->dbExeci('DELETE FROM users_prefs_traits WHERE id =', \$data->{id});
+ tuwf->dbExeci('INSERT INTO users_prefs_traits', { id => $data->{id}, %{$_}{qw|tid spoil color childs|} }) for $data->{traitprefs}->@*;
+
+ my %tokens = map +($_->{token},$_), $data->{api2}->@*;
+ for (auth->api2_tokens($data->{id})->@*) {
+ my $t = $tokens{$_->{token}} // next;
+ $t->{listwrite} = 0 if !$t->{listread};
+ if($t->{delete}) {
+ auth->api2_del_token($data->{id}, $t->{token});
+ } elsif($t->{notes} ne $_->{notes}
+ || !$t->{listread} ne !$_->{listread}
+ || !$t->{listwrite} ne !$_->{listwrite}) {
+ auth->api2_set_token($data->{id}, %$t);
+ }
+ }
+
+ my $old = tuwf->dbRowi('SELECT', sql_comma(keys %set, keys %setp), 'FROM users u JOIN users_prefs up ON up.id = u.id WHERE u.id =', \$data->{id});
+ tuwf->dbExeci('UPDATE users SET', \%set, 'WHERE id =', \$data->{id}) if keys %set;
+ tuwf->dbExeci('UPDATE users_prefs SET', \%setp, 'WHERE id =', \$data->{id}) if keys %setp;
+ my $new = tuwf->dbRowi('SELECT', sql_comma(keys %set, keys %setp), 'FROM users u JOIN users_prefs up ON up.id = u.id WHERE u.id =', \$data->{id});
+
+ if (auth->uid ne $data->{id}) {
+ $_ = JSON::XS->new->allow_nonref->encode($_) for values %$old, %$new;
+ my @diff = grep $old->{$_} ne $new->{$_}, keys %set, keys %setp;
+ auth->audit($data->{id}, 'user edit', join '; ', map "$_: $old->{$_} -> $new->{$_}", @diff) if @diff;
+ }
+
+ return $ret;
};
@@ -151,7 +256,7 @@ TUWF::get qr{/$RE{uid}/setmail/(?<token>[a-f0-9]{40})}, sub {
my $success = auth->setmail_confirm(tuwf->capture('id'), tuwf->capture('token'));
my $title = $success ? 'E-mail confirmed' : 'Error confirming email';
framework_ title => $title, sub {
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ $title;
div_ class => $success ? 'notice' : 'warning', sub {
p_ "Your e-mail address has been updated!" if $success;
@@ -161,4 +266,9 @@ TUWF::get qr{/$RE{uid}/setmail/(?<token>[a-f0-9]{40})}, sub {
};
};
+
+js_api UserApi2New => { id => { vndbid => 'u' }}, sub {
+ +{ token => auth->api2_set_token($_[0]{id}), added => strftime '%Y-%m-%d', localtime }
+};
+
1;
diff --git a/lib/VNWeb/User/List.pm b/lib/VNWeb/User/List.pm
index 7d5311a2..7fe5cb43 100644
--- a/lib/VNWeb/User/List.pm
+++ b/lib/VNWeb/User/List.pm
@@ -9,7 +9,7 @@ sub listing_ {
my sub url { '?'.query_encode %$opt, @_ }
paginate_ \&url, $opt->{p}, [$count, 50], 't';
- div_ class => 'mainbox browse', sub {
+ article_ class => 'browse userlist', sub {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
td_ class => 'tc1', sub { txt_ 'Username'; sortable_ 'username', $opt, \&url };
@@ -19,6 +19,7 @@ sub listing_ {
td_ class => 'tc5', sub { txt_ 'Wishlist'; sortable_ 'wish', $opt, \&url };
td_ class => 'tc6', sub { txt_ 'Edits'; sortable_ 'changes', $opt, \&url };
td_ class => 'tc7', sub { txt_ 'Tags'; sortable_ 'tags', $opt, \&url };
+ td_ class => 'tc8', sub { txt_ 'Images'; sortable_ 'images', $opt, \&url };
} };
tr_ sub {
my $l = $_;
@@ -26,24 +27,28 @@ sub listing_ {
td_ class => 'tc2', fmtdate $l->{registered};
td_ class => 'tc3', sub {
txt_ '0' if !$l->{c_vns};
- a_ href => "/u$l->{user_id}/ulist?vnlist=1", $l->{c_vns} if $l->{c_vns};
+ a_ href => "/$l->{user_id}/ulist?vnlist=1", $l->{c_vns} if $l->{c_vns};
};
td_ class => 'tc4', sub {
txt_ '0' if !$l->{c_votes};
- a_ href => "/u$l->{user_id}/ulist?votes=1", $l->{c_votes} if $l->{c_votes};
+ a_ href => "/$l->{user_id}/ulist?votes=1", $l->{c_votes} if $l->{c_votes};
};
td_ class => 'tc5', sub {
txt_ '0' if !$l->{c_wish};
- a_ href => "/u$l->{user_id}/ulist?wishlist=1", $l->{c_wish} if $l->{c_wish};
+ a_ href => "/$l->{user_id}/ulist?wishlist=1", $l->{c_wish} if $l->{c_wish};
};
td_ class => 'tc6', sub {
txt_ '-' if !$l->{c_changes};
- a_ href => "/u$l->{user_id}/hist", $l->{c_changes} if $l->{c_changes};
+ a_ href => "/$l->{user_id}/hist", $l->{c_changes} if $l->{c_changes};
};
td_ class => 'tc7', sub {
txt_ '-' if !$l->{c_tags};
a_ href => "/g/links?u=$l->{user_id}", $l->{c_tags} if $l->{c_tags};
};
+ td_ class => 'tc8', sub {
+ txt_ '-' if !$l->{c_imgvotes};
+ a_ href => "/img/list?u=$l->{user_id}", $l->{c_imgvotes} if $l->{c_imgvotes};
+ };
} for @$list;
};
};
@@ -56,45 +61,55 @@ TUWF::get qr{/u/(?<char>[0a-z]|all)}, sub {
my $opt = tuwf->validate(get =>
p => { upage => 1 },
- s => { onerror => 'registered', enum => [qw[username registered vns votes wish changes tags]] },
+ s => { onerror => 'registered', enum => [qw[username registered vns votes wish changes tags images]] },
o => { onerror => 'd', enum => [qw[a d]] },
q => { onerror => '' },
)->data;
my @where = (
- $char eq 'all' ? () : $char eq '0' ? "ascii(username) not between ascii('a') and ascii('z')" : "username like '$char%'",
+ 'username IS NOT NULL',
+ auth->permUsermod ? () : 'email_confirmed',
+ $char eq 'all' ? () : sql('match_firstchar(username, ', \$char, ')'),
$opt->{q} ? sql_or(
- $opt->{q} =~ /^u?([0-9]+)$/ ? sql 'id =', \"$1" : (),
- sql 'position(', \$opt->{q}, 'in username) > 0'
+ auth->permUsermod && $opt->{q} =~ /@/ ? sql('id IN(SELECT uid FROM user_emailtoid(', \$opt->{q}, '))') : (),
+ $opt->{q} =~ /^u?$RE{num}$/ ? sql 'id =', \"u$1" : (),
+ $opt->{q} =~ /@/ ? () : sql('username ILIKE', \('%'.sql_like($opt->{q}).'%')),
) : ()
);
my $list = tuwf->dbPagei({ results => 50, page => $opt->{p} },
- 'SELECT', sql_user(), ',', sql_totime('registered'), 'as registered, c_vns, c_votes, c_wish, c_changes, c_tags
+ 'SELECT', sql_user(), ',', sql_totime('registered'), 'as registered, c_vns, c_votes, c_wish, c_changes, c_tags, c_imgvotes
FROM users u
- WHERE', sql_and('id > 0', @where),
+ WHERE', sql_and(@where),
'ORDER BY', {
- username => 'username',
+ username => 'lower(username)',
registered => 'id',
vns => 'c_vns',
votes => 'c_votes',
wish => 'c_wish',
changes => 'c_changes',
- tags => 'c_tags'
+ tags => 'c_tags',
+ images => 'c_imgvotes',
}->{$opt->{s}}, $opt->{o} eq 'd' ? 'DESC' : 'ASC'
);
- my $count = @where ? tuwf->dbVali('SELECT count(*) FROM users WHERE', sql_and @where) : tuwf->{stats}{users};
+ state $totalusers = tuwf->dbVal('SELECT count(*) FROM users');
+ my $count = @where ? tuwf->dbVali('SELECT count(*) FROM users WHERE', sql_and @where) : $totalusers;
framework_ title => 'Browse users', sub {
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ 'Browse users';
form_ action => '/u/all', method => 'get', sub {
- searchbox_ u => $opt->{q};
+ fieldset_ class => 'search', sub {
+ input_ type => 'text', name => 'q', id => 'q', class => 'text', value => $opt->{q}//'';
+ input_ type => 'submit', class => 'submit', value => 'Search!';
+ }
};
p_ class => 'browseopts', sub {
a_ href => "/u/$_", $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#'
for ('all', 'a'..'z', 0);
};
+ b_ 'The given email address is on the opt-out list.'
+ if auth->permUsermod && $opt->{q} && $opt->{q} =~ /@/ && tuwf->dbVali('SELECT email_optout_check(', \$opt->{q}, ')');
};
listing_ $opt, $list, $count if $count;
};
diff --git a/lib/VNWeb/User/Lists.pm b/lib/VNWeb/User/Lists.pm
deleted file mode 100644
index 1d285618..00000000
--- a/lib/VNWeb/User/Lists.pm
+++ /dev/null
@@ -1,590 +0,0 @@
-package VNWeb::User::Lists;
-
-use VNWeb::Prelude;
-use POSIX 'strftime';
-
-
-# Do we have "ownership" access to this users' list (i.e. can we edit and see private stuff)?
-sub own {
- auth->permUsermod || (auth && auth->uid == shift)
-}
-
-
-# Should be called after any change to the ulist_* tables.
-# (Normally I'd do this with triggers, but that seemed like a more complex and less efficient solution in this case)
-sub updcache {
- tuwf->dbExeci(SELECT => sql_func update_users_ulist_stats => \shift);
-}
-
-
-my $LABELS = form_compile any => {
- uid => { id => 1 },
- labels => { aoh => {
- id => { int => 1 },
- label => { maxlength => 50 },
- private => { anybool => 1 },
- count => { uint => 1 },
- delete => { required => 0, default => undef, uint => 1, range => [1, 3] }, # 1=keep vns, 2=delete when no other label, 3=delete all
- } }
-};
-
-elm_api UListManageLabels => undef, $LABELS, sub {
- my($uid, $labels) = ($_[0]{uid}, $_[0]{labels});
- return elm_Unauth if !own $uid;
-
- # Insert new labels
- my @new = grep $_->{id} < 0 && !$_->{delete}, @$labels;
- # Subquery to get the lowest unused id
- my $newid = sql '(
- SELECT min(x.n)
- FROM generate_series(10,
- greatest((SELECT max(id)+1 from ulist_labels ul WHERE ul.uid =', \$uid, '), 10)
- ) x(n)
- WHERE NOT EXISTS(SELECT 1 FROM ulist_labels ul WHERE ul.uid =', \$uid, 'AND ul.id = x.n)
- )';
- tuwf->dbExeci('INSERT INTO ulist_labels', { id => $newid, uid => $uid, label => $_->{label}, private => $_->{private} }) for @new;
-
- # Update private flag
- tuwf->dbExeci(
- 'UPDATE ulist_labels SET private =', \$_->{private},
- 'WHERE uid =', \$uid, 'AND id =', \$_->{id}, 'AND private <>', \$_->{private}
- ) for grep $_->{id} > 0 && !$_->{delete}, @$labels;
-
- # Update label
- tuwf->dbExeci(
- 'UPDATE ulist_labels SET label =', \$_->{label},
- 'WHERE uid =', \$uid, 'AND id =', \$_->{id}, 'AND label <>', \$_->{label}
- ) for grep $_->{id} >= 10 && !$_->{delete}, @$labels;
-
- # Delete labels
- my @delete = grep $_->{id} >= 10 && $_->{delete}, @$labels;
- my @delete_lblonly = map $_->{id}, grep $_->{delete} == 1, @delete;
- my @delete_empty = map $_->{id}, grep $_->{delete} == 2, @delete;
- my @delete_all = map $_->{id}, grep $_->{delete} == 3, @delete;
-
- # delete vns with: (a label in option 3) OR ((a label in option 2) AND (no labels other than in option 1 or 2))
- my @where =
- @delete_all ? sql('vid IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN', \@delete_all, ')') : (),
- @delete_empty ? sql(
- 'vid IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN', \@delete_empty, ')',
- 'AND NOT EXISTS(SELECT 1 FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl NOT IN(', [ @delete_lblonly, @delete_empty ], '))'
- ) : ();
- tuwf->dbExeci('DELETE FROM ulist_vns WHERE uid =', \$uid, 'AND (', sql_or(@where), ')') if @where;
-
- # (This will also delete all relevant vn<->label rows from ulist_vns_labels)
- tuwf->dbExeci('DELETE FROM ulist_labels WHERE uid =', \$uid, 'AND id IN', [ map $_->{id}, @delete ]) if @delete;
-
- updcache $uid;
- elm_Success
-};
-
-
-
-
-my $VNVOTE = form_compile any => {
- uid => { id => 1 },
- vid => { id => 1 },
- vote => { vnvote => 1 },
-};
-
-elm_api UListVoteEdit => undef, $VNVOTE, sub {
- my($data) = @_;
- return elm_Unauth if !own $data->{uid};
- tuwf->dbExeci(
- 'INSERT INTO ulist_vns', { %$data, vote_date => sql $data->{vote} ? 'NOW()' : 'NULL' },
- 'ON CONFLICT (uid, vid) DO UPDATE
- SET', { %$data,
- lastmod => sql('NOW()'),
- vote_date => sql $data->{vote} ? 'CASE WHEN ulist_vns.vote IS NULL THEN NOW() ELSE ulist_vns.vote_date END' : 'NULL'
- }
- );
- updcache $data->{uid};
- elm_Success
-};
-
-
-
-
-my $VNLABELS = {
- uid => { id => 1 },
- vid => { id => 1 },
- label => { _when => 'in', id => 1 },
- applied => { _when => 'in', anybool => 1 },
- labels => { _when => 'out', aoh => { id => { int => 1 }, label => {}, private => { anybool => 1 } } },
- selected => { _when => 'out', type => 'array', values => { id => 1 } },
-};
-
-my $VNLABELS_OUT = form_compile out => $VNLABELS;
-my $VNLABELS_IN = form_compile in => $VNLABELS;
-
-elm_api UListLabelEdit => $VNLABELS_OUT, $VNLABELS_IN, sub {
- my($data) = @_;
- return elm_Unauth if !own $data->{uid};
- die "Attempt to set vote label" if $data->{label} == 7;
-
- tuwf->dbExeci('INSERT INTO ulist_vns', {uid => $data->{uid}, vid => $data->{vid}}, 'ON CONFLICT (uid, vid) DO NOTHING');
- tuwf->dbExeci(
- 'DELETE FROM ulist_vns_labels
- WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid}, 'AND lbl =', \$data->{label}
- ) if !$data->{applied};
- tuwf->dbExeci(
- 'INSERT INTO ulist_vns_labels', { uid => $data->{uid}, vid => $data->{vid}, lbl => $data->{label} },
- 'ON CONFLICT (uid, vid, lbl) DO NOTHING'
- ) if $data->{applied};
- tuwf->dbExeci('UPDATE ulist_vns SET lastmod = NOW() WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid});
-
- updcache $data->{uid};
- elm_Success
-};
-
-
-
-
-my $VNDATE = form_compile any => {
- uid => { id => 1 },
- vid => { id => 1 },
- date => { required => 0, default => '', regex => qr/^(?:19[7-9][0-9]|20[0-9][0-9])-(?:0[1-9]|1[0-2])-(?:0[1-9]|[12][0-9]|3[01])$/ }, # 1970 - 2099 for sanity
- start => { anybool => 1 }, # Field selection, started/finished
-};
-
-elm_api UListDateEdit => undef, $VNDATE, sub {
- my($data) = @_;
- return elm_Unauth if !own $data->{uid};
- tuwf->dbExeci(
- 'UPDATE ulist_vns SET lastmod = NOW(), ', $data->{start} ? 'started' : 'finished', '=', \($data->{date}||undef),
- 'WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid}
- );
- updcache $data->{uid};
- elm_Success
-};
-
-
-
-
-my $VNOPT = form_compile any => {
- own => { anybool => 1 },
- uid => { id => 1 },
- vid => { id => 1 },
- notes => {},
- rels => { aoh => { # Same structure as 'elm_Releases' response
- id => { id => 1 },
- title => {},
- original => {},
- released => { uint => 1 },
- rtype => {},
- lang => { type => 'array', values => {} },
- platforms=> { type => 'array', values => {} },
- } },
- relstatus => { type => 'array', values => { uint => 1 } }, # List of release statuses, same order as rels
-};
-
-
-
-# UListVNNotes module is abused for the UList.Opts flag definition
-elm_api UListVNNotes => $VNOPT, {
- uid => { id => 1 },
- vid => { id => 1 },
- notes => { required => 0, default => '', maxlength => 2000 },
-}, sub {
- my($data) = @_;
- return elm_Unauth if !own $data->{uid};
- tuwf->dbExeci(
- 'UPDATE ulist_vns SET lastmod = NOW(), notes = ', \$data->{notes},
- 'WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid}
- );
- # Doesn't need `updcache()`
- elm_Success
-};
-
-
-
-
-elm_api UListDel => undef, {
- uid => { id => 1 },
- vid => { id => 1 },
-}, sub {
- my($data) = @_;
- return elm_Unauth if !own $data->{uid};
- tuwf->dbExeci('DELETE FROM ulist_vns WHERE uid =', \$data->{uid}, 'AND vid =', \$data->{vid});
- updcache $data->{uid};
- elm_Success
-};
-
-
-
-
-# Adds the release when not in the list.
-# $RLIST_STATUS is also referenced from VNWeb::Releases::Page.
-our $RLIST_STATUS = form_compile any => {
- uid => { id => 1 },
- rid => { id => 1 },
- status => { required => 0, uint => 1, enum => \%RLIST_STATUS }, # undef meaning delete
-};
-elm_api UListRStatus => undef, $RLIST_STATUS, sub {
- my($data) = @_;
- return elm_Unauth if !own $data->{uid};
- if(!defined $data->{status}) {
- tuwf->dbExeci('DELETE FROM rlists WHERE uid =', \$data->{uid}, 'AND rid =', \$data->{rid})
- } else {
- tuwf->dbExeci('INSERT INTO rlists', $data, 'ON CONFLICT (uid, rid) DO UPDATE SET status =', \$data->{status})
- }
- # Doesn't need `updcache()`
- elm_Success
-};
-
-
-
-
-my %SAVED_OPTS = (
- # Labels
- l => { onerror => [], type => 'array', scalar => 1, values => { int => 1 } },
- mul => { anybool => 1 },
- # Sort column & order
- s => { onerror => 'title', enum => [qw[ title label vote voted added modified started finished rel rating ]] },
- o => { onerror => 'a', enum => ['a', 'd'] },
- # Visible columns
- c => { onerror => [], type => 'array', scalar => 1, values => { enum => [qw[ label vote voted added modified started finished rel rating ]] } },
-);
-
-my $SAVED_OPTS = {
- uid => { id => 1 },
- opts => { type => 'hash', keys => \%SAVED_OPTS },
- field => { _when => 'in', enum => [qw/ vnlist votes wish /] },
-};
-
-my $SAVED_OPTS_IN = form_compile in => $SAVED_OPTS;
-my $SAVED_OPTS_OUT = form_compile out => $SAVED_OPTS;
-
-elm_api UListSaveDefault => $SAVED_OPTS_OUT, $SAVED_OPTS_IN, sub {
- my($data) = @_;
- return elm_Unauth if !own $data->{uid};
- tuwf->dbExeci('UPDATE users SET ulist_'.$data->{field}, '=', \JSON::XS->new->encode($data->{opts}), 'WHERE id =', \$data->{uid});
- elm_Success
-};
-
-
-
-
-sub opt {
- my($u, $filtlabels) = @_;
-
- my sub load { my $o = $u->{"ulist_$_[0]"}; ($o && eval { JSON::XS->new->decode($o) } or {})->%* };
-
- my $opt =
- # Presets
- tuwf->reqGet('vnlist') ? { mul => 0, p => 1, l => [1,2,3,4,7,-1,0], s => 'title', o => 'a', c => [qw/label vote added started finished/], load 'vnlist' } :
- tuwf->reqGet('votes') ? { mul => 0, p => 1, l => [7], s => 'voted', o => 'd', c => [qw/vote voted/], load 'votes' } :
- tuwf->reqGet('wishlist') ? { mul => 0, p => 1, l => [5], s => 'title', o => 'a', c => [qw/label added/], load 'wish' } :
- # Full options
- tuwf->validate(get =>
- p => { upage => 1 },
- ch=> { onerror => undef, enum => [ 'a'..'z', 0 ] },
- q => { onerror => undef },
- %SAVED_OPTS
- )->data;
-
- # $labels only includes labels we are allowed to see, getting rid of any labels in 'l' that aren't in $labels ensures we only filter on visible labels
- my %accessible_labels = map +($_->{id}, 1), @$filtlabels;
- my %opt_l = map +($_, 1), grep $accessible_labels{$_}, $opt->{l}->@*;
- %opt_l = %accessible_labels if !keys %opt_l;
- $opt->{l} = keys %opt_l == keys %accessible_labels ? [] : [ sort keys %opt_l ];
-
- ($opt, \%opt_l)
-}
-
-
-sub filters_ {
- my($own, $filtlabels, $opt, $opt_labels, $url) = @_;
-
- my sub lblfilt_ {
- input_ type => 'checkbox', name => 'l', value => $_->{id}, id => "form_l$_->{id}", tabindex => 10, $opt_labels->{$_->{id}} ? (checked => 'checked') : ();
- label_ for => "form_l$_->{id}", "$_->{label} ";
- txt_ " ($_->{count})";
- }
-
- form_ method => 'get', sub {
- input_ type => 'hidden', name => 's', value => $opt->{s};
- input_ type => 'hidden', name => 'o', value => $opt->{o};
- input_ type => 'hidden', name => 'ch', value => $opt->{ch} if defined $opt->{ch};
- input_ type => 'hidden', name => 'c', value => $_ for $opt->{c}->@*;
- p_ class => 'labelfilters', sub {
- input_ type => 'text', class => 'text', name => 'q', value => $opt->{q}||'', style => 'width: 500px', placeholder => 'Search', tabindex => 10;
- br_;
- # XXX: Rather silly that everything in this form is a form element except for the alphabet filter. Meh, behavior seems intuitive enough.
- span_ class => 'browseopts', sub {
- a_ href => $url->(ch => $_, p => undef), ($_//'') eq ($opt->{ch}//'') ? (class => 'optselected') : (), !defined($_) ? 'ALL' : $_ ? uc $_ : '#'
- for (undef, 'a'..'z', 0);
- };
- br_;
- span_ class => 'linkradio', sub {
- join_ sub { em_ ' / ' }, \&lblfilt_, grep $_->{id} < 10, @$filtlabels;
-
- span_ class => 'hidden', sub {
- em_ ' || ';
- input_ type => 'checkbox', name => 'mul', value => 1, id => 'form_l_multi', tabindex => 10, $opt->{mul} ? (checked => 'checked') : ();
- label_ for => 'form_l_multi', 'Multi-select';
- };
- debug_ $filtlabels;
- };
- my @cust = grep $_->{id} >= 10, @$filtlabels;
- if(@cust) {
- br_;
- span_ class => 'linkradio', sub {
- join_ sub { em_ ' / ' }, \&lblfilt_, @cust;
- }
- }
- br_;
- input_ type => 'submit', class => 'submit', tabindex => 10, value => 'Update filters';
- input_ type => 'button', class => 'submit', tabindex => 10, id => 'managelabels', value => 'Manage labels' if $own;
- input_ type => 'button', class => 'submit', tabindex => 10, id => 'savedefault', value => 'Save as default' if $own;
- };
- };
-}
-
-
-sub vn_ {
- my($uid, $own, $opt, $n, $v, $labels) = @_;
- tr_ mkclass(odd => $n % 2 == 0), id => "ulist_tr_$v->{id}", sub {
- my %labels = map +($_,1), $v->{labels}->@*;
-
- td_ class => 'tc1', sub {
- input_ type => 'checkbox', class => 'checkhidden', name => 'collapse_vid', id => 'collapse_vid'.$v->{id}, value => 'collapsed_vid'.$v->{id};
- label_ for => 'collapse_vid'.$v->{id}, sub {
- my $obtained = grep $_->{status} == 2, $v->{rels}->@*;
- my $total = $v->{rels}->@*;
- b_ id => 'ulist_relsum_'.$v->{id},
- mkclass(done => $total && $obtained == $total, todo => $obtained < $total, neutral => 1),
- sprintf '%d/%d', $obtained, $total;
- if($own) {
- my $public = List::Util::any { $labels{$_->{id}} && !$_->{private} } @$labels;
- my $publicLabel = List::Util::any { $_->{id} != 7 && $labels{$_->{id}} && !$_->{private} } @$labels;
- span_ mkclass(invisible => !$public),
- id => 'ulist_public_'.$v->{id},
- 'data-publabel' => !!$publicLabel,
- 'data-voted' => !!$labels{7},
- title => 'This item is public', ' 👁';
- }
- };
- };
-
- td_ class => 'tc_voted', $v->{vote_date} ? fmtdate $v->{vote_date}, 'compact' : '-' if in voted => $opt->{c};
-
- td_ mkclass(tc_vote => 1, compact => $own, stealth => $own), sub {
- txt_ fmtvote $v->{vote} if !$own;
- elm_ 'UList.VoteEdit' => $VNVOTE, { uid => $uid, vid => $v->{id}, vote => fmtvote($v->{vote}) }, fmtvote $v->{vote}
- if $own && ($v->{vote} || sprintf('%08d', $v->{c_released}||0) < strftime '%Y%m%d', gmtime);
- } if in vote => $opt->{c};
-
- td_ class => 'tc_rating', sub {
- txt_ sprintf '%.2f', ($v->{c_rating}||0)/10;
- b_ class => 'grayedout', sprintf ' (%d)', $v->{c_votecount};
- } if in rating => $opt->{c};
-
- td_ class => 'tc_labels', sub {
- my @l = grep $labels{$_->{id}} && $_->{id} != 7, @$labels;
- my $txt = @l ? join ', ', map $_->{label}, @l : '-';
- if($own) {
- elm_ 'UList.LabelEdit' => $VNLABELS_OUT, { vid => $v->{id}, selected => [ grep $_ != 7, $v->{labels}->@* ] }, $txt;
- } else {
- txt_ $txt;
- }
- } if in label => $opt->{c};
-
- td_ class => 'tc_title', sub {
- a_ href => "/v$v->{id}", title => $v->{original}||$v->{title}, shorten $v->{title}, 70;
- b_ class => 'grayedout', id => 'ulist_notes_'.$v->{id}, $v->{notes} if $v->{notes} || $own;
- };
-
- td_ class => 'tc_added', fmtdate $v->{added}, 'compact' if in added => $opt->{c};
- td_ class => 'tc_modified', fmtdate $v->{lastmod}, 'compact' if in modified => $opt->{c};
-
- td_ class => 'tc_started', sub {
- txt_ $v->{started}||'' if !$own;
- elm_ 'UList.DateEdit' => $VNDATE, { uid => $uid, vid => $v->{id}, date => $v->{started}||'', start => 1 }, $v->{started}||'' if $own;
- } if in started => $opt->{c};
-
- td_ class => 'tc_finished', sub {
- txt_ $v->{finished}||'' if !$own;
- elm_ 'UList.DateEdit' => $VNDATE, { uid => $uid, vid => $v->{id}, date => $v->{finished}||'', start => 0 }, $v->{finished}||'' if $own;
- } if in finished => $opt->{c};
-
- td_ class => 'tc_rel', sub { rdate_ $v->{c_released} } if in rel => $opt->{c};
- };
-
- tr_ mkclass(hidden => 1, 'collapsed_vid'.$v->{id} => 1, odd => $n % 2 == 0), sub {
- td_ colspan => 7, class => 'tc_opt', sub {
- my $relstatus = [ map $_->{status}, $v->{rels}->@* ];
- elm_ 'UList.Opt' => $VNOPT, { own => $own, uid => $uid, vid => $v->{id}, notes => $v->{notes}, rels => $v->{rels}, relstatus => $relstatus };
- };
- };
-}
-
-
-sub listing_ {
- my($uid, $own, $opt, $labels, $url) = @_;
-
- my @l = grep $_ > 0, $opt->{l}->@*;
- my($unlabeled) = grep $_ == -1, $opt->{l}->@*;
-
- my @where_vns = (
- @l ? sql('uv.vid IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN', \@l, ')') :
- !$own ? sql('uv.vid IN(SELECT vid FROM ulist_vns_labels WHERE uid =', \$uid, 'AND lbl IN(SELECT id FROM ulist_labels WHERE uid =', \$uid, 'AND NOT private))') : (),
- $unlabeled ? sql('NOT EXISTS(SELECT 1 FROM ulist_vns_labels WHERE uid =', \$uid, 'AND vid = uv.vid AND lbl <> ', \7, ')') : ()
- );
-
- my $where = sql_and
- sql('uv.uid =', \$uid),
- @where_vns ? sql_or(@where_vns) : (),
- $opt->{q} ? map sql('v.c_search like', \"%$_%"), normalize_query $opt->{q} : (),
- defined($opt->{ch}) && $opt->{ch} ? sql('LOWER(SUBSTR(v.title, 1, 1)) =', \$opt->{ch}) : (),
- defined($opt->{ch}) && !$opt->{ch} ? sql('(ASCII(v.title) <', \97, 'OR ASCII(v.title) >', \122, ') AND (ASCII(v.title) <', \65, 'OR ASCII(v.title) >', \90, ')') : ();
-
- my $count = tuwf->dbVali('SELECT count(*) FROM ulist_vns uv JOIN vn v ON v.id = uv.vid WHERE', $where);
-
- my $lst = tuwf->dbPagei({ page => $opt->{p}, results => 50 },
- 'SELECT v.id, v.title, v.original, uv.vote, uv.notes, uv.started, uv.finished, v.c_rating, v.c_votecount, v.c_released
- ,', sql_totime('uv.added'), ' as added
- ,', sql_totime('uv.lastmod'), ' as lastmod
- ,', sql_totime('uv.vote_date'), ' as vote_date
- FROM ulist_vns uv
- JOIN vn v ON v.id = uv.vid
- WHERE', $where, '
- ORDER BY', {
- title => 'v.title',
- label => sql('ARRAY(SELECT ul.label FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl <> ', \7, ')'),
- vote => 'uv.vote',
- voted => 'uv.vote_date',
- added => 'uv.added',
- modified => 'uv.lastmod',
- started => 'uv.started',
- finished => 'uv.finished',
- rel => 'v.c_released',
- rating => 'v.c_rating',
- }->{$opt->{s}}, $opt->{o} eq 'd' ? 'DESC' : 'ASC', 'NULLS LAST, v.title'
- );
-
- enrich_flatten labels => id => vid => sql('SELECT vid, lbl FROM ulist_vns_labels WHERE uid =', \$uid, 'AND vid IN'), $lst;
-
- enrich rels => id => vid => sub { sql '
- SELECT rv.vid, r.id, r.title, r.original, r.released, r.type as rtype, rl.status
- FROM rlists rl
- JOIN releases r ON rl.rid = r.id
- JOIN releases_vn rv ON rv.id = r.id
- WHERE rl.uid =', \$uid, '
- AND rv.vid IN', $_, '
- ORDER BY r.released ASC'
- }, $lst;
-
- enrich_flatten lang => id => id => sub { sql('SELECT id, lang FROM releases_lang WHERE id IN', $_, 'ORDER BY lang') }, map $_->{rels}, @$lst;
- enrich_flatten platforms => id => id => sub { sql('SELECT id, platform FROM releases_platforms WHERE id IN', $_, 'ORDER BY platform') }, map $_->{rels}, @$lst;
-
- # TODO: Thumbnail view?
- paginate_ $url, $opt->{p}, [ $count, 50 ], 't', sub {
- elm_ ColSelect => undef, [ $url->(), [
- [ voted => 'Vote date' ],
- [ vote => 'Vote' ],
- [ rating => 'Rating' ],
- [ label => 'Labels' ],
- [ added => 'Added' ],
- [ modified => 'Modified' ],
- [ started => 'Start date' ],
- [ finished => 'Finish date' ],
- [ rel => 'Release date' ],
- ] ];
- };
- div_ class => 'mainbox browse ulist', sub {
- table_ sub {
- thead_ sub { tr_ sub {
- td_ class => 'tc1', sub {
- input_ type => 'checkbox', class => 'checkall', name => 'collapse_vid', id => 'collapse_vid';
- label_ for => 'collapse_vid', sub { txt_ 'Opt' };
- };
- td_ class => 'tc_voted', sub { txt_ 'Vote date'; sortable_ 'voted', $opt, $url } if in voted => $opt->{c};
- td_ class => 'tc_vote', sub { txt_ 'Vote'; sortable_ 'vote', $opt, $url } if in vote => $opt->{c};
- td_ class => 'tc_rating', sub { txt_ 'Rating'; sortable_ 'rating', $opt, $url } if in rating => $opt->{c};
- td_ class => 'tc_labels', sub { txt_ 'Labels'; sortable_ 'label', $opt, $url } if in label => $opt->{c};
- td_ class => 'tc_title', sub { txt_ 'Title'; sortable_ 'title', $opt, $url; debug_ $lst };
- td_ class => 'tc_added', sub { txt_ 'Added'; sortable_ 'added', $opt, $url } if in added => $opt->{c};
- td_ class => 'tc_modified', sub { txt_ 'Modified'; sortable_ 'modified', $opt, $url } if in modified => $opt->{c};
- td_ class => 'tc_started', sub { txt_ 'Start date'; sortable_ 'started', $opt, $url } if in started => $opt->{c};
- td_ class => 'tc_finished', sub { txt_ 'Finish date'; sortable_ 'finished', $opt, $url } if in finished => $opt->{c};
- td_ class => 'tc_rel', sub { txt_ 'Release date';sortable_ 'rel', $opt, $url } if in rel => $opt->{c};
- }};
- vn_ $uid, $own, $opt, $_, $lst->[$_], $labels for (0..$#$lst);
- };
- };
- paginate_ $url, $opt->{p}, [ $count, 50 ], 'b';
-}
-
-
-# TODO: Ability to add VNs from this page
-TUWF::get qr{/$RE{uid}/ulist}, sub {
- my $u = tuwf->dbRowi('SELECT id,', sql_user(), ', ulist_votes, ulist_vnlist, ulist_wish FROM users u WHERE id =', \tuwf->capture('id'));
- return tuwf->resNotFound if !$u->{id};
-
- my $own = own $u->{id};
-
- # Visible and selectable labels
- my $labels = tuwf->dbAlli(
- 'SELECT l.id, l.label, l.private, count(vl.vid) as count, null as delete
- FROM ulist_labels l LEFT JOIN ulist_vns_labels vl ON vl.uid = l.uid AND vl.lbl = l.id
- WHERE', { 'l.uid' => $u->{id}, $own ? () : ('l.private' => 0) },
- 'GROUP BY l.id, l.label, l.private
- ORDER BY CASE WHEN l.id < 10 THEN l.id ELSE 10 END, l.label'
- );
-
- # All visible labels that can be filtered on, including "virtual" labels like 'No label'
- my $filtlabels = [
- @$labels,
- $own ? {
- id => -1, label => 'No label', count => tuwf->dbVali(
- 'SELECT count(*)
- FROM ulist_vns uv
- WHERE NOT EXISTS(SELECT 1 FROM ulist_vns_labels uvl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND uvl.lbl <>', \7, ')
- AND uid =', \$u->{id}
- )
- } : (),
- ];
-
- my($opt, $opt_labels) = opt $u, $filtlabels;
- my sub url { '?'.query_encode %$opt, @_ }
-
- # This page has 3 user tabs: list, wish and votes; Select the appropriate active tab based on label filters.
- my $num_core_labels = grep $_ < 10, keys %$opt_labels;
- my $tab = $num_core_labels == 1 && $opt_labels->{7} ? 'votes'
- : $num_core_labels == 1 && $opt_labels->{5} ? 'wish' : 'list';
-
- my $title = $own ? 'My list' : user_displayname($u)."'s list";
- framework_ title => $title, type => 'u', dbobj => $u, tab => $tab,
- $own ? ( pagevars => {
- uid => $u->{id}*1,
- labels => $LABELS->analyze->{keys}{labels}->coerce_for_json($labels),
- voteprivate => (map \($_->{private}?1:0), grep $_->{id} == 7, @$labels),
- } ) : (),
- sub {
- my $empty = !grep $_->{count}, @$filtlabels;
- div_ class => 'mainbox', sub {
- h1_ $title;
- if($empty) {
- p_ $own
- ? 'Your list is empty! You can add visual novels to your list from the visual novel pages.'
- : user_displayname($u).' does not have any visible visual novels in their list.';
- } else {
- filters_ $own, $filtlabels, $opt, $opt_labels, \&url;
- elm_ 'UList.ManageLabels' if $own;
- elm_ 'UList.SaveDefault', $SAVED_OPTS_OUT, { uid => $u->{id}, opts => $opt } if $own;
- }
- };
- listing_ $u->{id}, $own, $opt, $labels, \&url if !$empty;
- };
-};
-
-
-
-# Redirects for old URLs
-TUWF::get qr{/$RE{uid}/votes}, sub { tuwf->resRedirect("/u".tuwf->capture('id').'/ulist?votes=1', 'perm') };
-TUWF::get qr{/$RE{uid}/list}, sub { tuwf->resRedirect("/u".tuwf->capture('id').'/ulist?vnlist=1', 'perm') };
-TUWF::get qr{/$RE{uid}/wish}, sub { tuwf->resRedirect("/u".tuwf->capture('id').'/ulist?wishlist=1', 'perm') };
-
-
-1;
diff --git a/lib/VNWeb/User/Login.pm b/lib/VNWeb/User/Login.pm
index 95295e05..b4ac76da 100644
--- a/lib/VNWeb/User/Login.pm
+++ b/lib/VNWeb/User/Login.pm
@@ -4,19 +4,19 @@ use VNWeb::Prelude;
TUWF::get '/u/login' => sub {
- return tuwf->resRedirect('/', 'temp') if auth;
+ return tuwf->resRedirect('/', 'temp') if auth || config->{read_only};
my $ref = tuwf->reqGet('ref');
$ref = '/' if !$ref || $ref !~ /^\//;
framework_ title => 'Login', sub {
- elm_ 'User.Login' => tuwf->compile({}), $ref;
+ div_ widget(UserLogin => {ref => $ref}), '';
};
};
-elm_api UserLogin => undef, {
- username => { username => 1 },
+js_api UserLogin => {
+ username => {},
password => { password => 1 }
}, sub {
my $data = shift;
@@ -25,38 +25,61 @@ elm_api UserLogin => undef, {
my $tm = tuwf->dbVali(
'SELECT', sql_totime('greatest(timeout, now())'), 'FROM login_throttle WHERE ip =', \$ip
) || time;
- return elm_LoginThrottle if $tm-time() > config->{login_throttle}[1];
+ return +{ _err => 'Too many failed login attempts, please use the password reset form or try again later.' }
+ if $tm-time() > config->{login_throttle}[1];
+
+ my $ismail = $data->{username} =~ /@/;
+ my $mailmsg = 'Invalid username or password.';
+
+ my $u = tuwf->dbRowi('SELECT id, user_getscryptargs(id) x FROM users WHERE',
+ $ismail ? sql('id IN(SELECT uid FROM user_emailtoid(', \$data->{username}, '))')
+ : sql('lower(username) = lower(', \$data->{username}, ')')
+ );
+ # When logging in with an email, make sure we don't disclose whether or not an account with that email exists.
+ if ($ismail && !$u->{id}) {
+ auth->wasteTime; # make timing attacks a bit harder (not 100% perfect, DB lookups & different scrypt args can still influence timing)
+ return +{ _err => $mailmsg };
+ }
+ return +{ _err => 'No user with that name.' } if !$u->{id};
+ return +{ _err => 'Account disabled, please use the password reset form to re-activate your account.' } if !$u->{x};
my $insecure = is_insecurepass $data->{password};
- return $insecure ? elm_InsecurePass : elm_Success
- if auth->login($data->{username}, $data->{password}, $insecure);
+ my $ret = auth->login($u->{id}, $data->{password}, $insecure);
+ if($ret && $insecure) {
+ return +{ insecurepass => 1, uid => $u->{id} };
+ } elsif (40 == length $ret) {
+ return +{ _redir => "/$u->{id}/del/$ret" };
+ } else {
+ auth->audit(auth->uid, 'login');
+ return +{ ok => 1 };
+ }
- # Failed login, update throttle.
+ # Failed login, log and update throttle.
+ auth->audit($u->{id}, 'bad password', 'failed login attempt');
my $upd = {
ip => \$ip,
timeout => sql_fromtime $tm + config->{login_throttle}[0]
};
tuwf->dbExeci('INSERT INTO login_throttle', $upd, 'ON CONFLICT (ip) DO UPDATE SET', $upd);
- elm_BadLogin
+ +{ _err => $ismail ? $mailmsg : 'Incorrect password.' }
};
-elm_api UserChangePass => undef, {
- username => { username => 1 },
+js_api UserChangePass => {
+ uid => { vndbid => 'u' },
oldpass => { password => 1 },
newpass => { password => 1 },
}, sub {
my $data = shift;
- my $uid = tuwf->dbVali('SELECT id FROM users WHERE username =', \$data->{username});
- die if !$uid;
- return elm_InsecurePass if is_insecurepass $data->{newpass};
- die if !auth->setpass($uid, undef, $data->{oldpass}, $data->{newpass}); # oldpass should already have been verified.
- elm_Success
+ return +{ _err => 'Your new password has also been leaked.' } if is_insecurepass $data->{newpass};
+ die if !auth->setpass($data->{uid}, undef, $data->{oldpass}, $data->{newpass}); # oldpass should already have been verified.
+ auth->audit($data->{uid}, 'password change', 'after login with an insecure password');
+ {}
};
TUWF::post qr{/$RE{uid}/logout}, sub {
- return tuwf->resNotFound if !auth || auth->uid != tuwf->capture('id') || (tuwf->reqPost('csrf')||'') ne auth->csrftoken;
+ return tuwf->resNotFound if !auth || auth->uid ne tuwf->capture('id') || (tuwf->reqPost('csrf')||'') ne auth->csrftoken;
auth->logout;
tuwf->resRedirect('/', 'post');
};
diff --git a/lib/VNWeb/User/Notifications.pm b/lib/VNWeb/User/Notifications.pm
index c74cc1a8..513cec23 100644
--- a/lib/VNWeb/User/Notifications.pm
+++ b/lib/VNWeb/User/Notifications.pm
@@ -3,28 +3,46 @@ package VNWeb::User::Notifications;
use VNWeb::Prelude;
my %ntypes = (
- pm => 'Private Message',
- dbdel => 'Entry you contributed to has been deleted',
- listdel => 'VN in your (wish)list has been deleted',
- dbedit => 'Entry you contributed to has been edited',
- announce => 'Site announcement',
+ pm => 'Message on your board',
+ dbdel => 'Entry you contributed to has been deleted',
+ listdel => 'VN in your list has been deleted',
+ dbedit => 'Entry you contributed to has been edited',
+ announce => 'Site announcement',
+ post => 'Reply to a thread you posted in',
+ comment => 'Comment on your review',
+ subpost => 'Reply to a thread you subscribed to',
+ subedit => 'Entry you subscribed to has been edited',
+ subreview => 'New review for a VN you subscribed to',
+ subapply => 'Trait you subscribed to has been (un)applied',
);
sub settings_ {
my $id = shift;
+ my $u = tuwf->dbRowi('SELECT notify_dbedit, notify_post, notify_comment, notify_announce FROM users WHERE id =', \$id);
+
h1_ 'Settings';
- form_ action => "/u$id/notify_options", method => 'POST', sub {
+ form_ action => "/$id/notify_options", method => 'POST', sub {
input_ type => 'hidden', class => 'hidden', name => 'csrf', value => auth->csrftoken;
p_ sub {
label_ sub {
- input_ type => 'checkbox', name => 'dbedit', auth->pref('notify_dbedit') ? (checked => 'checked') : ();
+ input_ type => 'checkbox', name => 'dbedit', $u->{notify_dbedit} ? (checked => 'checked') : ();
txt_ ' Notify me about edits of database entries I contributed to.';
};
br_;
label_ sub {
- input_ type => 'checkbox', name => 'announce', auth->pref('notify_announce') ? (checked => 'checked') : ();
+ input_ type => 'checkbox', name => 'post', $u->{notify_post} ? (checked => 'checked') : ();
+ txt_ ' Notify me about replies to threads I posted in.';
+ };
+ br_;
+ label_ sub {
+ input_ type => 'checkbox', name => 'comment', $u->{notify_comment} ? (checked => 'checked') : ();
+ txt_ ' Notify me about comments to my reviews.';
+ };
+ br_;
+ label_ sub {
+ input_ type => 'checkbox', name => 'announce', $u->{notify_announce} ? (checked => 'checked') : ();
txt_ ' Notify me about site announcements.';
};
br_;
@@ -37,7 +55,7 @@ sub settings_ {
sub listing_ {
my($id, $opt, $count, $list) = @_;
- my sub url { "/u$id/notifies?r=$opt->{r}&p=$_" }
+ my sub url { "/$id/notifies?r=$opt->{r}&p=$_" }
my sub tbl_ {
thead_ sub { tr_ sub {
@@ -53,32 +71,40 @@ sub listing_ {
txt_ ' ';
input_ type => 'submit', class => 'submit', name => 'markread', value => 'mark selected read';
input_ type => 'submit', class => 'submit', name => 'remove', value => 'remove selected';
- b_ class => 'grayedout', ' (Read notifications are automatically removed after one month)';
+ small_ ' (Read notifications are automatically removed after one month)';
}
}};
tr_ $_->{read} ? () : (class => 'unread'), sub {
my $l = $_;
- my $lid = $l->{ltype}.$l->{iid}.($l->{subid}?'.'.$l->{subid}:'');
- my $url = "/u$id/notify/$l->{id}/$lid";
+ my $lid = $l->{iid}.($l->{num}?'.'.$l->{num}:'');
td_ class => 'tc1', sub { input_ type => 'checkbox', name => 'notifysel', value => $l->{id}; };
- td_ class => 'tc2', $ntypes{$l->{ntype}};
+ td_ class => 'tc2', sub {
+ # Hide some not very interesting overlapping notification types
+ my %t = map +($_,1), $l->{ntype}->@*;
+ delete $t{subpost} if $t{post} || $t{comment} || $t{pm};
+ delete $t{post} if $t{pm};
+ delete $t{subedit} if $t{dbedit};
+ delete $t{dbedit} if $t{dbdel};
+ join_ \&br_, sub { txt_ $ntypes{$_} }, sort keys %t;
+ };
td_ class => 'tc3', fmtage $l->{date};
- td_ class => 'tc4', sub { a_ href => $url, $lid };
+ td_ class => 'tc4', sub { a_ href => "/$lid", $lid };
td_ class => 'tc5', sub {
- a_ href => $url, sub {
- txt_ $l->{ltype} eq 't' ? 'Edit of ' : $l->{subid} == 1 ? 'New thread ' : 'Reply to ';
- i_ $l->{c_title};
+ a_ href => "/$lid", sub {
+ txt_ $l->{iid} =~ /^w/ ? ($l->{num} ? 'Comment on ' : 'Review of ') :
+ $l->{iid} =~ /^t/ ? ($l->{num} == 1 ? 'New thread ' : 'Reply to ') : 'Edit of ';
+ span_ tattr $l;
txt_ ' by ';
- i_ user_displayname $l;
+ span_ user_displayname $l;
};
};
} for @$list;
}
- form_ action => "/u$id/notify_update", method => 'POST', sub {
+ form_ action => "/$id/notify_update", method => 'POST', sub {
input_ type => 'hidden', class => 'hidden', name => 'url', value => do { local $_ = $opt->{p}; url };
paginate_ \&url, $opt->{p}, [$count, 25], 't';
- div_ class => 'mainbox browse notifies', sub {
+ article_ class => 'browse notifies', sub {
table_ class => 'stripe', \&tbl_;
};
paginate_ \&url, $opt->{p}, [$count, 25], 'b';
@@ -86,9 +112,13 @@ sub listing_ {
}
+# Redirect so that elm/Subscribe.elm can link to this page without knowing our uid.
+TUWF::get qr{/u/notifies}, sub { auth ? tuwf->resRedirect('/'.auth->uid.'/notifies', 'temp') : tuwf->resNotFound };
+
+
TUWF::get qr{/$RE{uid}/notifies}, sub {
my $id = tuwf->capture('id');
- return tuwf->resNotFound if !auth || $id != auth->uid;
+ return tuwf->resNotFound if !auth || $id ne auth->uid;
my $opt = tuwf->validate(get =>
p => { page => 1 },
@@ -96,24 +126,23 @@ TUWF::get qr{/$RE{uid}/notifies}, sub {
)->data;
my $where = sql_and(
- sql('uid =', \$id),
- $opt->{r} ? () : 'read IS NULL'
+ sql('n.uid =', \$id),
+ $opt->{r} ? () : 'n.read IS NULL'
);
- my $count = tuwf->dbVali('SELECT count(*) FROM notifications WHERE', $where);
+ my $count = tuwf->dbVali('SELECT count(*) FROM notifications n WHERE', $where);
my $list = tuwf->dbPagei({ results => 25, page => $opt->{p} },
- 'SELECT n.id, n.ntype, n.ltype, n.iid, n.subid, n.c_title
+ 'SELECT n.id, n.ntype::text[] AS ntype, n.iid, n.num, t.title, ', sql_user(), '
, ', sql_totime('n.date'), ' as date
, ', sql_totime('n.read'), ' as read
- , ', sql_user(),
- 'FROM notifications n
- LEFT JOIN users u ON u.id = n.c_byuser
+ FROM notifications n,', item_info('n.iid', 'n.num'), 't
+ LEFT JOIN users u ON u.id = t.uid
WHERE ', $where,
'ORDER BY n.id', $opt->{r} ? 'DESC' : 'ASC'
);
- framework_ title => 'My notifications',
+ framework_ title => 'My notifications', js => 1,
sub {
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ 'My notifications';
p_ class => 'browseopts', sub {
a_ !$opt->{r} ? (class => 'optselected') : (), href => '?r=0', 'Unread notifications';
@@ -122,35 +151,41 @@ TUWF::get qr{/$RE{uid}/notifies}, sub {
p_ 'No notifications!' if !$count;
};
listing_ $id, $opt, $count, $list;
- div_ class => 'mainbox', sub { settings_ $id };
+ article_ sub { settings_ $id };
};
};
TUWF::post qr{/$RE{uid}/notify_options}, sub {
my $id = tuwf->capture('id');
- return tuwf->resNotFound if !auth || $id != auth->uid;
+ return tuwf->resNotFound if !auth || $id ne auth->uid;
my $frm = tuwf->validate(post =>
csrf => {},
dbedit => { anybool => 1 },
announce => { anybool => 1 },
+ post => { anybool => 1 },
+ comment => { anybool => 1 },
)->data;
return tuwf->resNotFound if !auth->csrfcheck($frm->{csrf});
- auth->prefSet(notify_dbedit => $frm->{dbedit});
- auth->prefSet(notify_announce => $frm->{announce});
- tuwf->resRedirect("/u$id/notifies", 'post');
+ tuwf->dbExeci('UPDATE users SET', {
+ notify_dbedit => $frm->{dbedit},
+ notify_announce => $frm->{announce},
+ notify_post => $frm->{post},
+ notify_comment => $frm->{comment},
+ }, 'WHERE id =', \$id);
+ tuwf->resRedirect("/$id/notifies", 'post');
};
TUWF::post qr{/$RE{uid}/notify_update}, sub {
my $id = tuwf->capture('id');
- return tuwf->resNotFound if !auth || $id != auth->uid;
+ return tuwf->resNotFound if !auth || $id ne auth->uid;
my $frm = tuwf->validate(post =>
- url => { regex => qr{^/u$id/notifies} },
- notifysel => { required => 0, default => [], type => 'array', scalar => 1, values => { id => 1 } },
+ url => { regex => qr{^/$id/notifies} },
+ notifysel => { default => [], type => 'array', scalar => 1, values => { id => 1 } },
markread => { anybool => 1 },
remove => { anybool => 1 },
)->data;
@@ -164,11 +199,45 @@ TUWF::post qr{/$RE{uid}/notify_update}, sub {
};
+# XXX: Not currently used anymore, just visiting the destination pages will mark the relevant notifications as read
+# (but that's subject to change in the future, so let's keep this around)
TUWF::get qr{/$RE{uid}/notify/$RE{num}/(?<lid>[a-z0-9\.]+)}, sub {
my $id = tuwf->capture('id');
- return tuwf->resNotFound if !auth || $id != auth->uid;
- tuwf->dbExeci('UPDATE notifications SET read = NOW() WHERE uid =', \$id, ' AND id =', \tuwf->capture('num'));
+ return tuwf->resNotFound if !auth || $id ne auth->uid;
+ tuwf->dbExeci('UPDATE notifications SET read = NOW() WHERE read IS NULL AND uid =', \$id, ' AND id =', \tuwf->capture('num'));
tuwf->resRedirect('/'.tuwf->capture('lid'), 'temp');
};
+
+
+# It's a bit annoying to add auth->notiRead() to each revision page, so do that in bulk with a simple hook.
+TUWF::hook before => sub {
+ auth->notiRead($+{vndbid}, $+{rev}) if auth && tuwf->reqPath() =~ qr{^/(?<vndbid>[vrpcsdgi]$RE{num})\.(?<rev>$RE{num})$};
+};
+
+
+
+
+our $SUB = form_compile any => {
+ id => { vndbid => [qw|t w v r p c s d i g|] },
+ subnum => { undefbool => 1 },
+ subreview => { anybool => 1 },
+ subapply => { anybool => 1 },
+ noti => { uint => 1, default => undef }, # used by the widget, ignored in the backend
+};
+
+js_api Subscribe => $SUB, sub {
+ my($data) = @_;
+ $data->{subreview} = 0 if $data->{id} !~ /^v/;
+ delete $data->{noti};
+
+ my %where = (iid => delete $data->{id}, uid => auth->uid);
+ if(!defined $data->{subnum} && !$data->{subreview} && !$data->{subapply}) {
+ tuwf->dbExeci('DELETE FROM notification_subs WHERE', \%where);
+ } else {
+ tuwf->dbExeci('INSERT INTO notification_subs', {%where, %$data}, 'ON CONFLICT (iid,uid) DO UPDATE SET', $data);
+ }
+ {};
+};
+
1;
diff --git a/lib/VNWeb/User/Page.pm b/lib/VNWeb/User/Page.pm
index a1d86c58..db4f7a36 100644
--- a/lib/VNWeb/User/Page.pm
+++ b/lib/VNWeb/User/Page.pm
@@ -8,7 +8,7 @@ sub _info_table_ {
my($u, $own) = @_;
my sub sup {
- b_ ' ⭐supporter⭐' if $u->{user_support_can} && $u->{user_support_enabled};
+ strong_ ' ⭐supporter⭐' if $u->{user_support_can} && $u->{user_support_enabled};
}
tr_ sub {
@@ -19,13 +19,22 @@ sub _info_table_ {
};
} if $u->{user_uniname_can} && $u->{user_uniname};
tr_ sub {
+ my $old = tuwf->dbAlli('SELECT date::date, old FROM users_username_hist WHERE id =', \$u->{id},
+ auth->permUsermod ? () : 'AND date > NOW()-\'1 month\'::interval', 'ORDER BY date DESC');
td_ class => 'key', 'Username';
td_ sub {
- txt_ ucfirst $u->{user_name};
- txt_ ' ('; a_ href => "/u$u->{id}", "u$u->{id}";
+ txt_ $u->{user_name} if defined $u->{user_name};
+ b_ 'Account deleted' if !defined $u->{user_name};
+ user_maybebanned_ $u;
+ txt_ ' ('; a_ href => "/$u->{id}", $u->{id};
txt_ ')';
+ b_ ' Scheduled for deletion' if auth->isMod && tuwf->dbVali('SELECT delete_at FROM users_shadow WHERE id =', \$u->{id});
debug_ $u;
sup if !($u->{user_uniname_can} && $u->{user_uniname});
+ for(@$old) {
+ br_;
+ small_ "Changed from '$_->{old}' on $_->{date}.";
+ }
};
};
tr_ sub {
@@ -35,7 +44,7 @@ sub _info_table_ {
tr_ sub {
td_ 'Edits';
td_ !$u->{c_changes} ? '-' : sub {
- a_ href => "/u$u->{id}/hist", $u->{c_changes}
+ a_ href => "/$u->{id}/hist", $u->{c_changes}
};
};
tr_ sub {
@@ -44,17 +53,25 @@ sub _info_table_ {
td_ 'Votes';
td_ !$num ? '-' : sub {
txt_ sprintf '%d vote%s, %.2f average. ', $num, $num == 1 ? '' : 's', $sum/$num/10;
- a_ href => "/u$u->{id}/ulist?votes=1", 'Browse votes »';
+ a_ href => "/$u->{id}/ulist?votes=1", 'Browse votes »';
}
};
+ my $lengthvotes = tuwf->dbRowi('SELECT count(*) AS count, sum(length) AS sum, bool_or(not private) as haspub FROM vn_length_votes WHERE uid =', \$u->{id});
+ tr_ sub {
+ td_ 'Play times';
+ td_ sub {
+ vnlength_ $lengthvotes->{sum};
+ txt_ sprintf ' from %d submitted play times. ', $lengthvotes->{count};
+ a_ href => "/$u->{id}/lengthvotes", 'Browse votes »' if $own || $lengthvotes->{haspub};
+ };
+ } if $lengthvotes->{count};
tr_ sub {
my $vns = tuwf->dbVali(
- 'SELECT COUNT(DISTINCT uvl.vid) FROM ulist_vns_labels uvl',
- $own ? () : ('JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl AND NOT ul.private'),
- 'WHERE uvl.lbl NOT IN(', \5, ',', \6, ') AND uvl.uid =', \$u->{id}
+ 'SELECT COUNT(vid) FROM ulist_vns
+ WHERE NOT (labels && ARRAY[', \5, ',', \6, ']::smallint[]) AND uid =', \$u->{id}, $own ? () : 'AND NOT c_private'
)||0;
my $privrel = $own ? '1=1' : 'EXISTS(
- SELECT 1 FROM releases_vn rv JOIN ulist_vns_labels uvl ON uvl.vid = rv.vid JOIN ulist_labels ul ON ul.id = uvl.lbl AND ul.uid = uvl.uid WHERE rv.id = r.rid AND uvl.uid = r.uid AND NOT ul.private
+ SELECT 1 FROM releases_vn rv JOIN ulist_vns uv ON uv.vid = rv.vid WHERE uv.uid = r.uid AND rv.id = r.rid AND NOT uv.c_private
)';
my $rel = tuwf->dbVali('SELECT COUNT(*) FROM rlists r WHERE', $privrel, 'AND r.uid =', \$u->{id})||0;
td_ 'List stats';
@@ -62,7 +79,15 @@ sub _info_table_ {
txt_ sprintf '%d release%s of %d visual novel%s. ',
$rel, $rel == 1 ? '' : 's',
$vns, $vns == 1 ? '' : 's';
- a_ href => "/u$u->{id}/ulist?vnlist=1", 'Browse list »';
+ a_ href => "/$u->{id}/ulist?vnlist=1", 'Browse list »';
+ };
+ };
+ tr_ sub {
+ my $cnt = tuwf->dbVali('SELECT COUNT(*) FROM reviews WHERE uid =', \$u->{id});
+ td_ 'Reviews';
+ td_ !$cnt ? '-' : sub {
+ txt_ sprintf '%d review%s. ', $cnt, $cnt == 1 ? '' : 's';
+ a_ href => "/w?u=$u->{id}", 'Browse reviews »';
};
};
tr_ sub {
@@ -77,15 +102,46 @@ sub _info_table_ {
};
};
tr_ sub {
- my $stats = tuwf->dbRowi('SELECT COUNT(*) AS posts, COUNT(*) FILTER (WHERE num = 1) AS threads FROM threads_posts WHERE uid =', \$u->{id});
+ td_ 'Images';
+ td_ sub {
+ txt_ sprintf '%d images flagged. ', $u->{c_imgvotes};
+ a_ href => "/img/list?u=$u->{id}", 'Browse image votes »';
+ };
+ } if $u->{c_imgvotes};
+ tr_ sub {
+ my $stats = tuwf->dbRowi('
+ SELECT COUNT(*) AS posts, COUNT(*) FILTER (WHERE num = 1) AS threads
+ FROM threads_posts tp
+ WHERE hidden IS NULL AND uid =', \$u->{id}, '
+ AND EXISTS(SELECT 1 FROM threads t WHERE t.id = tp.tid AND NOT t.hidden AND NOT t.private)');
+ $stats->{posts} += tuwf->dbVali('SELECT COUNT(*) FROM reviews_posts WHERE hidden IS NULL AND uid =', \$u->{id});
td_ 'Forum stats';
td_ !$stats->{posts} ? '-' : sub {
txt_ sprintf '%d post%s, %d new thread%s. ',
$stats->{posts}, $stats->{posts} == 1 ? '' : 's',
$stats->{threads}, $stats->{threads} == 1 ? '' : 's';
- a_ href => "/u$u->{id}/posts", 'Browse posts »';
+ a_ href => "/$u->{id}/posts", 'Browse posts »';
};
};
+ my $quotes = tuwf->dbVali('SELECT COUNT(*) FROM quotes WHERE addedby =', \$u->{id}, auth->permDbmod ? () : 'AND NOT hidden');
+ tr_ sub {
+ td_ 'Quotes';
+ td_ sub {
+ txt_ sprintf '%d quote%s submitted. ', $quotes, $quotes == 1 ? '' : 's';
+ a_ href => "/v/quotes?u=$u->{id}", 'Browse quotes »' if auth;
+ };
+ } if $quotes;
+
+ my $traits = tuwf->dbAlli('SELECT u.tid, t.name, g.id as "group", g.name AS groupname FROM users_traits u JOIN traits t ON t.id = u.tid LEFT JOIN traits g ON g.id = t.gid WHERE u.id =', \$u->{id}, 'ORDER BY g.gorder, t.name');
+ my @groups;
+ for (@$traits) {
+ push @groups, $_ if !@groups || $groups[$#groups]{group} ne $_->{group};
+ push $groups[$#groups]{traits}->@*, $_;
+ }
+ tr_ sub {
+ td_ class => 'key', sub { a_ href => "/$_->{group}", $_->{groupname} };
+ td_ sub { join_ ', ', sub { a_ href => "/$_->{tid}", $_->{name} }, $_->{traits}->@* };
+ } for @groups;
}
@@ -111,24 +167,21 @@ sub _votestats_ {
};
my $recent = tuwf->dbAlli('
- SELECT vn.id, vn.title, vn.original, uv.vote,', sql_totime('uv.vote_date'), 'AS date
+ SELECT v.id, v.title, uv.vote,', sql_totime('uv.vote_date'), 'AS date
FROM ulist_vns uv
- JOIN vn ON vn.id = uv.vid
- WHERE uv.vote IS NOT NULL AND uv.uid =', \$u->{id},
- $own ? () : (
- 'AND EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private)'
- ), '
+ JOIN', vnt, 'v ON v.id = uv.vid
+ WHERE uv.vote IS NOT NULL AND uv.uid =', \$u->{id}, $own ? () : ('AND NOT uv.c_private AND NOT v.hidden'), '
ORDER BY uv.vote_date DESC LIMIT', \8
);
table_ class => 'recentvotes stripe', sub {
thead_ sub { tr_ sub { td_ colspan => 3, sub {
txt_ 'Recent votes';
- b_ sub { txt_ ' ('; a_ href => "/u$u->{id}/ulist?votes=1", 'show all'; txt_ ')' };
+ span_ sub { txt_ '('; a_ href => "/$u->{id}/ulist?votes=1", 'show all'; txt_ ')' };
} } };
tr_ sub {
my $v = $_;
- td_ sub { a_ href => "/v$v->{id}", title => $v->{original}||$v->{title}, shorten $v->{title}, 30 };
+ td_ sub { a_ href => "/$v->{id}", tattr $v; };
td_ fmtvote $v->{vote};
td_ fmtdate $v->{date};
} for @$recent;
@@ -140,42 +193,41 @@ sub _votestats_ {
TUWF::get qr{/$RE{uid}}, sub {
my $u = tuwf->dbRowi(q{
- SELECT id, c_changes, c_votes, c_tags
+ SELECT id, c_changes, c_votes, c_tags, c_imgvotes
,}, sql_totime('registered'), q{ AS registered
,}, sql_user(), q{
FROM users u
WHERE id =}, \tuwf->capture('id')
);
- return tuwf->resNotFound if !$u->{id};
+ return tuwf->resNotFound if !$u->{id} || (!$u->{user_name} && !auth->isMod);
- my $own = (auth && auth->uid == $u->{id}) || auth->permUsermod;
+ my $own = (auth && auth->uid eq $u->{id}) || auth->permUsermod;
$u->{votes} = tuwf->dbAlli('
SELECT (uv.vote::numeric/10)::int AS idx, COUNT(uv.vote) as votes, SUM(uv.vote) AS total
FROM ulist_vns uv
- WHERE uv.vote IS NOT NULL AND uv.uid =', \$u->{id},
- $own ? () : (
- 'AND EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private)'
- ), '
+ WHERE uv.vote IS NOT NULL AND uv.uid =', \$u->{id}, $own ? () : 'AND NOT uv.c_private', '
GROUP BY (uv.vote::numeric/10)::int
');
my $title = user_displayname($u)."'s profile";
- framework_ title => $title, type => 'u', dbobj => $u,
- sub {
- div_ class => 'mainbox userpage', sub {
+ framework_ title => $title, dbobj => $u, sub {
+ article_ class => 'userpage', sub {
+ itemmsg_ $u;
h1_ $title;
table_ class => 'stripe', sub { _info_table_ $u, $own };
};
- div_ class => 'mainbox', sub {
+ article_ sub {
h1_ 'Vote statistics';
div_ class => 'votestats', sub { _votestats_ $u, $own };
} if grep $_->{votes} > 0, $u->{votes}->@*;
if($u->{c_changes}) {
- h1_ class => 'boxtitle', sub { a_ href => "/u$u->{id}/hist", 'Recent changes' };
- VNWeb::Misc::History::tablebox_ u => $u->{id}, {p=>1}, nopage => 1, results => 10;
+ nav_ sub {
+ h1_ sub { a_ href => "/$u->{id}/hist", 'Recent changes' };
+ };
+ VNWeb::Misc::History::tablebox_ $u->{id}, {p=>1}, nopage => 1, nouser => 1, results => 10;
}
};
};
diff --git a/lib/VNWeb/User/PassReset.pm b/lib/VNWeb/User/PassReset.pm
index 39f1d6ea..45109f80 100644
--- a/lib/VNWeb/User/PassReset.pm
+++ b/lib/VNWeb/User/PassReset.pm
@@ -3,40 +3,56 @@ package VNWeb::User::PassReset;
use VNWeb::Prelude;
TUWF::get '/u/newpass' => sub {
- return tuwf->resRedirect('/', 'temp') if auth;
+ return tuwf->resRedirect('/', 'temp') if auth || config->{read_only};
framework_ title => 'Password reset', sub {
- elm_ 'User.PassReset';
+ div_ widget(UserPassReset => {}), '';
};
};
-elm_api UserPassReset => undef, {
+js_api UserPassReset => {
email => { email => 1 },
}, sub {
my $data = shift;
- my($id, $token) = auth->resetpass($data->{email});
- return elm_BadEmail if !$id;
+ # Throttle exists to prevent email sending abuse
+ my $ip = norm_ip tuwf->reqIP;
+ my $tm = tuwf->dbVali(
+ 'SELECT', sql_totime('greatest(timeout, now())'), 'FROM reset_throttle WHERE ip =', \$ip
+ ) || time;
+ return 'Too many password reset attempts, try again later.' if $tm-time() > config->{reset_throttle}[1];
- my $name = tuwf->dbVali('SELECT username FROM users WHERE id =', \$id);
- my $body = sprintf
+ my $upd = {ip => $ip, timeout => sql_fromtime $tm + config->{reset_throttle}[0]};
+ tuwf->dbExeci('INSERT INTO reset_throttle', $upd, 'ON CONFLICT (ip) DO UPDATE SET', $upd);
+
+ my($id, $mail, $token) = auth->resetpass($data->{email});
+ my $name = $id ? tuwf->dbVali('SELECT username FROM users WHERE id =', \$id) : $data->{email};
+ my $body = $id ? sprintf
"Hello %s,"
- ."\n\n"
- ."Your VNDB.org login has been disabled, you can now set a new password by following the link below:"
- ."\n\n"
- ."%s"
- ."\n\n"
- ."Now don't forget your password again! :-)"
- ."\n\n"
- ."vndb.org",
- $name, tuwf->reqBaseURI()."/u$id/setpass/$token";
+ ."\n"
+ ."\nYou can set a new password for your VNDB.org account by following the link below:"
+ ."\n"
+ ."\n%s"
+ ."\n"
+ ."\nNow don't forget your password again! :-)"
+ ."\n"
+ ."\nvndb.org",
+ $name, tuwf->reqBaseURI()."/$id/setpass/$token"
+ : "Hello,"
+ ."\n"
+ ."\nSomeone has requested a password reset for the VNDB account associated with this email address."
+ ."\nIf this was not done by you, feel free to ignore this email."
+ ."\n"
+ ."\nThere is no VNDB account associated with this email address, perhaps you used another address to sign up?"
+ ."\n"
+ ."\nvndb.org";
tuwf->mail($body,
- To => $data->{email},
+ To => $mail // $data->{email},
From => 'VNDB <noreply@vndb.org>',
Subject => "Password reset for $name",
);
- elm_Success
+ +{}
};
1;
diff --git a/lib/VNWeb/User/PassSet.pm b/lib/VNWeb/User/PassSet.pm
index cbb6c31f..13d6ba2f 100644
--- a/lib/VNWeb/User/PassSet.pm
+++ b/lib/VNWeb/User/PassSet.pm
@@ -2,18 +2,8 @@ package VNWeb::User::PassSet;
use VNWeb::Prelude;
-my $FORM = {
- uid => { id => 1 },
- token => { regex => qr/[a-f0-9]{40}/ },
- password => { _when => 'in', password => 1 },
-};
-
-my $FORM_IN = form_compile in => $FORM;
-my $FORM_OUT = form_compile out => $FORM;
-
-
TUWF::get qr{/$RE{uid}/setpass/(?<token>[a-f0-9]{40})}, sub {
- return tuwf->resRedirect('/', 'temp') if auth;
+ return tuwf->resRedirect('/', 'temp') if auth || config->{read_only};
my $id = tuwf->capture('id');
my $token = tuwf->capture('token');
@@ -22,21 +12,25 @@ TUWF::get qr{/$RE{uid}/setpass/(?<token>[a-f0-9]{40})}, sub {
return tuwf->resNotFound if !$name || !auth->isvalidtoken($id, $token);
framework_ title => 'Set password', sub {
- elm_ 'User.PassSet', $FORM_OUT, { uid => $id, token => $token };
+ div_ widget(UserPassSet => { uid => $id, token => $token }), '';
};
};
-elm_api UserPassSet => $FORM_OUT, $FORM_IN, sub {
+js_api UserPassSet => {
+ uid => { vndbid => 'u' },
+ token => { regex => qr/^[a-f0-9]{40}$/ },
+ password => { password => 1 },
+}, sub {
my($data) = @_;
- return elm_InsecurePass if is_insecurepass($data->{password});
- # "CSRF" is kind of wrong here, but the message advices to reload the page,
- # which will give a 404, which should be a good enough indication that the
- # token has expired. This case won't happen often.
- return elm_CSRF if !auth->setpass($data->{uid}, $data->{token}, undef, $data->{password});
+ return +{ insecure => 1, _err => 'Your new password is in a public database of leaked passwords, please choose a different password.' }
+ if is_insecurepass($data->{password});
+ return +{ _err => 'Invalid token.' }
+ if !auth->setpass($data->{uid}, $data->{token}, undef, $data->{password});
tuwf->dbExeci('UPDATE users SET email_confirmed = true WHERE id =', \$data->{uid});
- elm_Success
+ auth->audit($data->{uid}, 'password change', 'with email token');
+ +{ _redir => '/' }
};
1;
diff --git a/lib/VNWeb/User/Register.pm b/lib/VNWeb/User/Register.pm
index 2dd41e4e..85de3599 100644
--- a/lib/VNWeb/User/Register.pm
+++ b/lib/VNWeb/User/Register.pm
@@ -6,35 +6,64 @@ use VNWeb::Prelude;
TUWF::get '/u/register', sub {
return tuwf->resRedirect('/', 'temp') if auth;
framework_ title => 'Register', sub {
- elm_ 'User.Register';
+ if(global_settings->{lockdown_registration} || config->{read_only}) {
+ article_ sub {
+ h1_ 'Create an account';
+ p_ 'Account registration is temporarily disabled. Try again later.';
+ }
+ } else {
+ div_ widget('UserRegister'), '';
+ }
};
};
-elm_api UserRegister => undef, {
+js_api UserRegister => {
username => { username => 1 },
email => { email => 1 },
- vns => { int => 1 },
}, sub {
my $data = shift;
+ return 'Registration disabled.' if global_settings->{lockdown_registration};
- my $num = tuwf->dbVali("SELECT count FROM stats_cache WHERE section = 'vn'");
- return elm_Bot if $data->{vns} < $num*0.995 || $data->{vns} > $num*1.005;
- return elm_Taken if tuwf->dbVali('SELECT 1 FROM users WHERE username =', \$data->{username});
- return elm_DoubleEmail if tuwf->dbVali(select => sql_func user_emailexists => \$data->{email}, \undef);
+ return +{ err => 'username' } if !is_unique_username $data->{username};
+ # Throttle before checking for duplicate email, wouldn't want to be sending too many emails.
my $ip = tuwf->reqIP;
- return elm_DoubleIP if tuwf->dbVali(
- q{SELECT 1 FROM users WHERE registered >= NOW()-'1 day'::interval AND ip <<},
- $ip =~ /:/ ? \"$ip/48" : \"$ip/30"
- );
+ return 'You can only register one account from the same IP within 24 hours.'
+ if tuwf->dbVali('SELECT 1 FROM registration_throttle WHERE timeout > NOW() AND ip =', \norm_ip($ip));
+ my %throttle = (timeout => sql("NOW()+'1 day'::interval"), ip => norm_ip($ip));
+ tuwf->dbExeci('INSERT INTO registration_throttle', \%throttle, 'ON CONFLICT (ip) DO UPDATE SET', \%throttle);
+
+ # Check for opt-out. Returning 'ok' here sucks balls, but otherwise we'd be vulnerable to email enumeration.
+ return +{ ok => 1 } if tuwf->dbVali('SELECT email_optout_check(', \$data->{email}, ')');
+
+ # Check for duplicate email
+ my $dupe = tuwf->dbVali('SELECT u.username FROM users u, user_emailtoid(', \$data->{email}, ') x(id) WHERE x.id = u.id');
+ if (defined $dupe) {
+ tuwf->mail(
+ "Hello $data->{username},"
+ ."\n"
+ ."\nSomeone has attempted to register an account on VNDB.org with your email address,"
+ ."\nbut you already have an account on VNDB with the username '$dupe'."
+ ."\n"
+ ."\nIf you forgot your password, you can recover access to your account through the following link:"
+ ."\n".tuwf->reqBaseURI()."/u/newpass"
+ ."\n"
+ ."\nIf you don't remember creating an account on VNDB.org recently, please ignore this e-mail."
+ ."\n"
+ ."\nvndb.org",
+ To => $data->{email},
+ From => 'VNDB <noreply@vndb.org>',
+ Subject => "Duplicate registration for $data->{username}",
+ );
+ return +{ ok => 1 };
+ }
+
+ my $id = tuwf->dbVali('INSERT INTO users', {username => $data->{username}}, 'RETURNING id');
+ tuwf->dbExeci('INSERT INTO users_prefs', {id => $id});
+ tuwf->dbExeci('INSERT INTO users_shadow', {id => $id, ip => ipinfo(), mail => $data->{email}});
- my $id = tuwf->dbVali('INSERT INTO users', {
- username => $data->{username},
- mail => $data->{email},
- ip => $ip,
- }, 'RETURNING id');
- my(undef, $token) = auth->resetpass($data->{email});
+ my(undef, undef, $token) = auth->resetpass($data->{email});
my $body = sprintf
"Hello %s,"
@@ -46,14 +75,14 @@ elm_api UserRegister => undef, {
."If you don't remember creating an account on VNDB.org recently, please ignore this e-mail."
."\n\n"
."vndb.org",
- $data->{username}, tuwf->reqBaseURI()."/u$id/setpass/$token";
+ $data->{username}, tuwf->reqBaseURI()."/$id/setpass/$token";
tuwf->mail($body,
To => $data->{email},
From => 'VNDB <noreply@vndb.org>',
Subject => "Confirm registration for $data->{username}",
);
- elm_Success
+ +{ ok => 1 }
};
1;
diff --git a/lib/VNWeb/VN/Edit.pm b/lib/VNWeb/VN/Edit.pm
new file mode 100644
index 00000000..6c8a5f16
--- /dev/null
+++ b/lib/VNWeb/VN/Edit.pm
@@ -0,0 +1,239 @@
+package VNWeb::VN::Edit;
+
+use VNWeb::Prelude;
+use VNWeb::Images::Lib 'enrich_image';
+use VNWeb::Releases::Lib;
+
+
+my $FORM = {
+ id => { default => undef, vndbid => 'v' },
+ titles => { minlength => 1, sort_keys => 'lang', aoh => {
+ lang => { enum => \%LANGUAGE },
+ title => { sl => 1, maxlength => 250 },
+ latin => { default => undef, sl => 1, maxlength => 250 },
+ official => { anybool => 1 },
+ } },
+ alias => { default => '', maxlength => 500 },
+ description=> { default => '', maxlength => 10240 },
+ devstatus => { uint => 1, enum => \%DEVSTATUS },
+ olang => { default => 'ja', enum => \%LANGUAGE },
+ length => { uint => 1, enum => \%VN_LENGTH },
+ l_wikidata => { default => undef, uint => 1, max => (1<<31)-1 },
+ l_renai => { default => '', sl => 1, maxlength => 100 },
+ relations => { sort_keys => 'vid', aoh => {
+ vid => { vndbid => 'v' },
+ relation => { enum => \%VN_RELATION },
+ official => { anybool => 1 },
+ title => { _when => 'out' },
+ } },
+ anime => { sort_keys => 'aid', aoh => {
+ aid => { id => 1 },
+ title => { _when => 'out' },
+ original => { _when => 'out', default => '' },
+ } },
+ image => { default => undef, vndbid => 'cv' },
+ image_info => { _when => 'out', default => undef, type => 'hash', keys => $VNWeb::Elm::apis{ImageResult}[0]{aoh} },
+ editions => { sort_keys => 'eid', aoh => {
+ eid => { uint => 1, max => 500 },
+ lang => { default => undef, language => 1 },
+ name => { sl => 1 },
+ official => { anybool => 1 },
+ } },
+ staff => { sort_keys => ['aid','eid','role'], aoh => {
+ aid => { id => 1 },
+ eid => { default => undef, uint => 1 },
+ role => { enum => \%CREDIT_TYPE },
+ note => { default => '', sl => 1, maxlength => 250 },
+ id => { _when => 'out', vndbid => 's' },
+ title => { _when => 'out' },
+ alttitle => { _when => 'out' },
+ } },
+ seiyuu => { sort_keys => ['aid','cid'], aoh => {
+ aid => { id => 1 },
+ cid => { vndbid => 'c' },
+ note => { default => '', sl => 1, maxlength => 250 },
+ # Staff info
+ id => { _when => 'out', vndbid => 's' },
+ title => { _when => 'out' },
+ alttitle => { _when => 'out' },
+ } },
+ screenshots=> { sort_keys => 'scr', aoh => {
+ scr => { vndbid => 'sf' },
+ rid => { default => undef, vndbid => 'r' },
+ info => { _when => 'out', type => 'hash', keys => $VNWeb::Elm::apis{ImageResult}[0]{aoh} },
+ } },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+
+ authmod => { _when => 'out', anybool => 1 },
+ editsum => { _when => 'in out', editsum => 1 },
+ releases => { _when => 'out', $VNWeb::Elm::apis{Releases}[0]->%* },
+ reltitles => { _when => 'out', aoh => { id => { vndbid => 'r' }, title => {} } },
+ chars => { _when => 'out', aoh => {
+ id => { vndbid => 'c' },
+ title => {},
+ alttitle => {},
+ } },
+};
+
+my $FORM_OUT = form_compile out => $FORM;
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_CMP = form_compile cmp => $FORM;
+
+
+TUWF::get qr{/$RE{vrev}/edit} => sub {
+ my $e = db_entry tuwf->captures('id', 'rev') or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit v => $e;
+
+ $e->{authmod} = auth->permDbmod;
+ $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision $e->{id}.$e->{chrev}";
+
+ $e->{titles} = [ sort { $a->{lang} cmp $b->{lang} } $e->{titles}->@* ];
+ if($e->{image}) {
+ $e->{image_info} = { id => $e->{image} };
+ enrich_image 0, [$e->{image_info}];
+ } else {
+ $e->{image_info} = undef;
+ }
+ $_->{info} = {id=>$_->{scr}} for $e->{screenshots}->@*;
+ enrich_image 0, [map $_->{info}, $e->{screenshots}->@*];
+
+ enrich_merge vid => sql('SELECT id AS vid, title[1+1] AS title FROM', vnt, 'v WHERE id IN'), $e->{relations};
+ enrich_merge aid => 'SELECT id AS aid, title_romaji AS title, COALESCE(title_kanji, \'\') AS original FROM anime WHERE id IN', $e->{anime};
+
+ enrich_merge aid => sql('SELECT id, aid, title[1+1], title[1+1+1+1] AS alttitle, sorttitle FROM', staff_aliast, 's WHERE aid IN'), $e->{staff}, $e->{seiyuu};
+
+ # It's possible for older revisions to link to aliases that have been removed.
+ # Let's exclude those to make sure the form will at least load.
+ $e->{staff} = [ grep $_->{id}, $e->{staff}->@* ];
+ $e->{seiyuu} = [ grep $_->{id}, $e->{seiyuu}->@* ];
+
+ my %CRED;
+ $CRED{$_} = keys %CRED for keys %CREDIT_TYPE;
+ $e->{staff} = [ sort { $CRED{$a->{role}} <=> $CRED{$b->{role}} || $a->{sorttitle} cmp $b->{sorttitle} || $a->{aid} <=> $b->{aid} } $e->{staff}->@* ];
+ $e->{editions} = [ sort { ($a->{lang}||'') cmp ($b->{lang}||'') || $b->{official} cmp $a->{official} || $a->{name} cmp $b->{name} } $e->{editions}->@* ];
+
+ $e->{releases} = releases_by_vn $e->{id};
+ $e->{reltitles} = tuwf->dbAlli('
+ SELECT DISTINCT r.id, i.title
+ FROM releases r
+ JOIN releases_vn rv ON rv.id = r.id
+ JOIN releases_titles rt ON rt.id = r.id
+ JOIN unnest(ARRAY[rt.title,rt.latin]) i(title) ON i.title IS NOT NULL
+ WHERE NOT r.hidden AND rv.vid =', \$e->{id}
+ );
+
+ $e->{chars} = tuwf->dbAlli('
+ SELECT id, title[1+1], title[1+1+1+1] AS alttitle FROM', charst, '
+ WHERE NOT hidden AND id IN(SELECT id FROM chars_vns WHERE vid =', \$e->{id},')
+ ORDER BY sorttitle, id'
+ );
+
+ my $title = titleprefs_obj $e->{olang}, $e->{titles};
+ framework_ title => "Edit $title->[1]", dbobj => $e, tab => 'edit',
+ sub {
+ editmsg_ v => $e, "Edit $title->[1]";
+ elm_ VNEdit => $FORM_OUT, $e;
+ };
+};
+
+
+TUWF::get qr{/v/add}, sub {
+ return tuwf->resDenied if !can_edit v => undef;
+
+ framework_ title => 'Add visual novel',
+ sub {
+ editmsg_ v => undef, 'Add visual novel';
+ elm_ VNEdit => $FORM_OUT, elm_empty($FORM_OUT);
+ };
+};
+
+
+elm_api VNEdit => $FORM_OUT, $FORM_IN, sub {
+ my $data = shift;
+ my $new = !$data->{id};
+ my $e = $new ? { id => 0 } : db_entry $data->{id} or return tuwf->resNotFound;
+ return elm_Unauth if !can_edit v => $e;
+
+ if(!auth->permDbmod) {
+ $data->{hidden} = $e->{hidden}||0;
+ $data->{locked} = $e->{locked}||0;
+ }
+ $data->{description} = bb_subst_links $data->{description};
+ $data->{alias} =~ s/\n\n+/\n/;
+ die "No title in original language" if !length [grep $_->{lang} eq $data->{olang}, $data->{titles}->@*]->[0]{title};
+
+ validate_dbid 'SELECT id FROM anime WHERE id IN', map $_->{aid}, $data->{anime}->@*;
+ validate_dbid 'SELECT id FROM images WHERE id IN', $data->{image} if $data->{image};
+ validate_dbid 'SELECT id FROM images WHERE id IN', map $_->{scr}, $data->{screenshots}->@*;
+ validate_dbid 'SELECT aid FROM staff_alias WHERE aid IN', map $_->{aid}, $data->{staff}->@*;
+ validate_dbid 'SELECT aid FROM staff_alias WHERE aid IN', map $_->{aid}, $data->{seiyuu}->@*;
+
+ # Drop unused staff editions
+ my %editions = map defined $_->{eid} ? +($_->{eid},1) : (), $data->{staff}->@*;
+ $data->{editions} = [ grep $editions{$_->{eid}}, $data->{editions}->@* ];
+
+ $data->{relations} = [] if $data->{hidden};
+ validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, $data->{relations}->@*;
+ die "Relation with self" if grep $_->{vid} eq $e->{id}, $data->{relations}->@*;
+
+ die "Screenshot without releases assigned" if grep !$_->{rid}, $data->{screenshots}->@*; # This is only the case for *very* old revisions, form disallows this now.
+ # Allow linking to deleted or moved releases only if the previous revision also had that.
+ # (The form really should encourage the user to fix that, but disallowing the edit seems a bit overkill)
+ validate_dbid sub { '
+ SELECT r.id FROM releases r JOIN releases_vn rv ON r.id = rv.id WHERE NOT r.hidden AND rv.vid =', \$e->{id}, ' AND r.id IN', $_, '
+ UNION
+ SELECT rid FROM vn_screenshots WHERE id =', \$e->{id}, 'AND rid IN', $_
+ }, map $_->{rid}, $data->{screenshots}->@*;
+
+ # Likewise, allow linking to deleted or moved characters.
+ validate_dbid sub { '
+ SELECT c.id FROM chars c JOIN chars_vns cv ON c.id = cv.id WHERE NOT c.hidden AND cv.vid =', \$e->{id}, ' AND c.id IN', $_, '
+ UNION
+ SELECT cid FROM vn_seiyuu WHERE id =', \$e->{id}, 'AND cid IN', $_
+ }, map $_->{cid}, $data->{seiyuu}->@*;
+
+ $data->{image_nsfw} = $e->{image_nsfw}||0;
+ my %oldscr = map +($_->{scr}, $_->{nsfw}), @{ $e->{screenshots}||[] };
+ $_->{nsfw} = $oldscr{$_->{scr}}||0 for $data->{screenshots}->@*;
+
+ return elm_Unchanged if !$new && !form_changed $FORM_CMP, $data, $e;
+ my $ch = db_edit v => $e->{id}, $data;
+ update_reverse($ch->{nitemid}, $ch->{nrev}, $e, $data);
+ elm_Redirect "/$ch->{nitemid}.$ch->{nrev}";
+};
+
+
+sub update_reverse {
+ my($id, $rev, $old, $new) = @_;
+
+ my %old = map +($_->{vid}, $_), $old->{relations} ? $old->{relations}->@* : ();
+ my %new = map +($_->{vid}, $_), $new->{relations}->@*;
+
+ # Updates to be performed, vid => { vid => x, relation => y, official => z } or undef if the relation should be removed.
+ my %upd;
+
+ for my $i (keys %old, keys %new) {
+ if($old{$i} && !$new{$i}) {
+ $upd{$i} = undef;
+ } elsif(!$old{$i} || $old{$i}{relation} ne $new{$i}{relation} || !$old{$i}{official} != !$new{$i}{official}) {
+ $upd{$i} = {
+ vid => $id,
+ relation => $VN_RELATION{ $new{$i}{relation} }{reverse},
+ official => $new{$i}{official}
+ };
+ }
+ }
+
+ for my $i (keys %upd) {
+ my $v = db_entry $i;
+ $v->{relations} = [
+ $upd{$i} ? $upd{$i} : (),
+ grep $_->{vid} ne $id, $v->{relations}->@*
+ ];
+ $v->{editsum} = "Reverse relation update caused by revision $id.$rev";
+ db_edit v => $i, $v, 'u1';
+ }
+}
+
+1;
diff --git a/lib/VNWeb/VN/Elm.pm b/lib/VNWeb/VN/Elm.pm
new file mode 100644
index 00000000..e3486049
--- /dev/null
+++ b/lib/VNWeb/VN/Elm.pm
@@ -0,0 +1,37 @@
+package VNWeb::VN::Elm;
+
+use VNWeb::Prelude;
+
+elm_api VN => undef, {
+ search => { type => 'array', values => { searchquery => 1 } },
+ hidden => { anybool => 1 },
+}, sub {
+ my($data) = @_;
+ my @q = grep $_, $data->{search}->@*;
+
+ elm_VNResult @q ? tuwf->dbPagei({ results => $data->{hidden}?50:15, page => 1 },
+ 'SELECT v.id, v.title[1+1] AS title, v.hidden
+ FROM', vnt, 'v', VNWeb::Validate::SearchQuery::sql_joina(\@q, 'v', 'v.id'),
+ $data->{hidden} ? () : 'WHERE NOT v.hidden', '
+ ORDER BY sc.score DESC, v.sorttitle
+ ') : [];
+};
+
+
+js_api VN => {
+ search => { type => 'array', values => { searchquery => 1 } },
+ hidden => { anybool => 1 },
+}, sub {
+ my($data) = @_;
+ my @q = grep $_, $data->{search}->@*;
+
+ +{ results => @q ? tuwf->dbAlli(
+ 'SELECT v.id, v.title[1+1] AS title, v.hidden
+ FROM', vnt, 'v', VNWeb::Validate::SearchQuery::sql_joina(\@q, 'v', 'v.id'),
+ $data->{hidden} ? () : 'WHERE NOT v.hidden', '
+ ORDER BY sc.score DESC, v.sorttitle
+ LIMIT', \50
+ ) : [] };
+};
+
+1;
diff --git a/lib/VNWeb/VN/Graph.pm b/lib/VNWeb/VN/Graph.pm
new file mode 100644
index 00000000..e1cabbe9
--- /dev/null
+++ b/lib/VNWeb/VN/Graph.pm
@@ -0,0 +1,143 @@
+package VNWeb::VN::Graph;
+
+use VNWeb::Prelude;
+use VNWeb::Graph;
+use VNWeb::Images::Lib 'enrich_image_obj';
+
+
+TUWF::get qr{/$RE{vid}/rg}, sub {
+ my $id = tuwf->capture(1);
+ my $num = tuwf->validate(get => num => { uint => 1, onerror => 15 })->data;
+ my $unoff = tuwf->validate(get => unoff => { default => 1, anybool => 1 })->data;
+ my $v = dbobj $id;
+
+ my $has = tuwf->dbRowi('SELECT bool_or(official) AS official, bool_or(not official) AS unofficial FROM vn_relations WHERE id =', \$id, 'GROUP BY id');
+ $unoff = 1 if !$has->{official};
+
+ # Big list of { id0, id1, relation } hashes.
+ # Each relation is included twice, with id0 and id1 reversed.
+ my $where = $unoff ? '1=1' : 'vr.official';
+ my $rel = tuwf->dbAlli(q{
+ WITH RECURSIVE rel(id0, id1, relation, official) AS (
+ SELECT id, vid, relation, official FROM vn_relations vr WHERE id =}, \$id, 'AND', $where, q{
+ UNION
+ SELECT id, vid, vr.relation, vr.official FROM vn_relations vr JOIN rel r ON vr.id = r.id1 WHERE}, $where, q{
+ ) SELECT * FROM rel ORDER BY id0
+ });
+ return tuwf->resNotFound if !@$rel;
+
+ # Fetch the nodes
+ my $nodes = gen_nodes $id, $rel, $num;
+ enrich_merge id => sql("SELECT id, title[1+1] AS title, c_released, array_to_string(c_languages, '/') AS lang FROM", vnt, "v WHERE id IN"), values %$nodes;
+
+ my $total_nodes = keys { map +($_->{id0},1), @$rel }->%*;
+ my $visible_nodes = keys %$nodes;
+
+ my @lines;
+ my $params = "?num=$num&unoff=$unoff";
+ for my $n (sort { idcmp $a->{id}, $b->{id} } values %$nodes) {
+ my $title = val_escape shorten $n->{title}, 27;
+ my $tooltip = val_escape $n->{title};
+ my $date = rdate $n->{c_released};
+ my $lang = $n->{lang}||'N/A';
+ my $nodeid = $n->{distance} == 0 ? 'id = "graph_current", ' : '';
+ push @lines,
+ qq|n$n->{id} [ $nodeid URL = "/$n->{id}", tooltip = "$tooltip", label=<|.
+ qq|<TABLE CELLSPACING="0" CELLPADDING="2" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|.
+ qq|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="3"><FONT POINT-SIZE="9"> $title </FONT></TD></TR>|.
+ qq|<TR><TD> $date </TD><TD> $lang </TD></TR>|.
+ qq|</TABLE>> ]|;
+
+ push @lines, node_more $n->{id}, "/$n->{id}/rg$params", scalar grep !$nodes->{$_}, $n->{rels}->@*;
+ }
+
+ $rel = [ grep $nodes->{$_->{id0}} && $nodes->{$_->{id1}}, @$rel ];
+ my $dot = gen_dot \@lines, $nodes, $rel, \%VN_RELATION;
+
+ framework_ title => "Relations for $v->{title}[1]", dbobj => $v, tab => 'rg',
+ sub {
+ article_ class => 'relgraph', sub {
+ h1_ "Relations for $v->{title}[1]";
+ a_ href => "/$v->{id}/rgi", 'Interactive graph »';
+ p_ sub {
+ txt_ sprintf "Displaying %d out of %d related visual novels.", $visible_nodes, $total_nodes;
+ debug_ +{ nodes => $nodes, rel => $rel };
+ br_;
+ if($has->{official}) {
+ if($unoff) {
+ txt_ 'Show / ';
+ a_ href => "?num=$num&unoff=0", 'Hide';
+ } else {
+ a_ href => "?num=$num&unoff=1", 'Show';
+ txt_ ' / Hide';
+ }
+ txt_ ' unofficial relations. ';
+ br_;
+ }
+ if($total_nodes > 10) {
+ txt_ 'Adjust graph size: ';
+ join_ ', ', sub {
+ if($_ == min $num, $total_nodes) {
+ txt_ $_ ;
+ } else {
+ a_ href => "/$id/rg?num=$_", $_;
+ }
+ }, grep($_ < $total_nodes, 10, 15, 25, 50, 75, 100, 150, 250, 500, 750, 1000), $total_nodes;
+ }
+ txt_ '.';
+ } if $total_nodes > 10 || $has->{unofficial};
+ p_ class => 'center', sub { lit_ dot2svg $dot };
+ };
+ clearfloat_;
+ };
+};
+
+
+TUWF::get qr{/$RE{vid}/rgi}, sub {
+ my $v = dbobj tuwf->capture(1);
+
+ # Big list of { id0, id1, relation, official } hashes.
+ # Each relation is included twice, with id0 and id1 reversed.
+ my $rel = tuwf->dbAlli(q{
+ WITH RECURSIVE rel(id0, id1, relation, official) AS (
+ SELECT id, vid, relation, official FROM vn_relations vr WHERE id =}, \$v->{id}, q{
+ UNION
+ SELECT id, vid, vr.relation, vr.official FROM vn_relations vr JOIN rel r ON vr.id = r.id1
+ ) SELECT * FROM rel ORDER BY id0
+ });
+ return tuwf->resNotFound if !@$rel;
+
+ # Get rid of duplicate relations and convert to a more efficient array-based format.
+ # For directional relations, keep the one that is preferred ("pref"), for unidirectional relations, keep the one with the lowest id0.
+ $rel = [
+ map [ @{$_}{qw/ id0 id1 relation official /} ],
+ grep $VN_RELATION{$_->{relation}}{pref} || ($VN_RELATION{$_->{relation}}{reverse} eq $_->{relation} && idcmp($_->{id0}, $_->{id1}) < 0), @$rel
+ ];
+
+ # Fetch the nodes
+ my %nodes = map +($_, {id => $_}), map @{$_}[0,1], @$rel;
+ enrich_merge id => sql("
+ SELECT id, title[1+1] AS title, title[1+1+1+1] AS alttitle, c_released AS released, image, c_languages::text[] AS languages
+ FROM", vnt, "v WHERE id IN"
+ ), values %nodes;
+ enrich_image_obj image => values %nodes;
+
+ # compress image info a bit
+ $_->{image} = $_->{image} && [imgurl($_->{image}{id}), $_->{image}{sexual}, $_->{image}{violence}] for values %nodes;
+
+ framework_ title => "Relations for $v->{title}[1]", dbobj => $v, tab => 'rg',
+ sub {
+ article_ sub {
+ h1_ "Relations for $v->{title}[1]";
+ div_ widget(VNGraph => {
+ sexual => 0+(auth->pref('max_sexual')||0),
+ violence => 0+(auth->pref('max_violence')||0),
+ main => $v->{id},
+ nodes => [values %nodes],
+ rels => $rel,
+ }), ''
+ }
+ };
+};
+
+1;
diff --git a/lib/VNWeb/VN/Length.pm b/lib/VNWeb/VN/Length.pm
new file mode 100644
index 00000000..eb291665
--- /dev/null
+++ b/lib/VNWeb/VN/Length.pm
@@ -0,0 +1,213 @@
+package VNWeb::VN::Length;
+
+use VNWeb::Prelude;
+
+# Also used from VN::Page
+sub can_vote { auth->permDbmod || (auth->permLengthvote && !global_settings->{lockdown_edit}) }
+
+sub opts {
+ my($mode) = @_;
+ tableopts
+ date => { name => 'Date', sort_id => 0, sort_sql => 'l.date', sort_default => 'desc' },
+ length => { name => 'Time', sort_id => 1, sort_sql => 'l.length' },
+ speed => { name => 'Speed', sort_id => 2, sort_sql => 'l.speed ?o NULLS LAST, l.length' },
+ $mode ne 'u' ? (
+ username => { name => 'User', sort_id => 3, sort_sql => 'u.username' } ) : (),
+ $mode ne 'v' ? (
+ title => { name => 'Title', sort_id => 4, sort_sql => 'v.sorttitle' } ) : ()
+}
+my %TABLEOPTS = map +($_, opts $_), '', 'v', 'u';
+
+
+sub listing_ {
+ my($opt, $url, $count, $list, $mode) = @_;
+
+ if(auth->permDbmod) {
+ form_ method => 'post', action => '/lengthvotes-edit';
+ input_ type => 'hidden', class => 'hidden', name => 'url', value => tuwf->reqPath.tuwf->reqQuery, undef;
+ }
+
+ paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 't';
+ article_ class => 'browse lengthlist', sub {
+ table_ class => 'stripe', sub {
+ thead_ sub { tr_ sub {
+ td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'date', $opt, $url };
+ td_ class => 'tc2', sub { txt_ 'User'; sortable_ 'username', $opt, $url } if $mode ne 'u';
+ td_ class => 'tc2', sub { txt_ 'Title'; sortable_ 'title', $opt, $url } if $mode ne 'v';
+ td_ class => 'tc3', sub { txt_ 'Time'; sortable_ 'length', $opt, $url };
+ td_ class => 'tc4', sub { txt_ 'Speed'; sortable_ 'speed', $opt, $url };
+ td_ class => 'tc5', 'Rel';
+ td_ class => 'tc6', 'Notes';
+ td_ class => 'tc7', sub {
+ input_ type => 'submit', class => 'submit', value => 'Update', undef;
+ } if auth->permDbmod;
+ } };
+ tr_ sub {
+ td_ class => 'tc1', fmtdate $_->{date};
+ td_ class => 'tc2', sub { user_ $_ } if $mode ne 'u';
+ td_ class => 'tc2', sub {
+ a_ href => "/$_->{vid}", tattr $_;
+ } if $mode ne 'v';
+ td_ class => 'tc3'.($_->{ignore}?' grayedout':''), sub { vnlength_ $_->{length} };
+ td_ class => 'tc4'.($_->{ignore}?' grayedout':''), ['Slow','Normal','Fast','-']->[$_->{speed}//3];
+ td_ class => 'tc5', sub {
+ my %l = map +($_,1), map $_->{lang}->@*, $_->{rel}->@*;
+ abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for sort keys %l;
+ join_ ',', sub { a_ href => "/$_->{id}", $_->{id} }, sort { idcmp $a->{id}, $b->{id} } $_->{rel}->@*;
+ };
+ td_ class => 'tc6'.($_->{ignore}?' grayedout':''), sub {
+ small_ '(private) ' if $_->{private};
+ lit_ bb_format $_->{notes}, inline => 1;
+ };
+ td_ class => 'tc7', sub {
+ select_ name => "lv$_->{id}", sub {
+ option_ value => '', '--';
+ option_ value => 's0', 'slow';
+ option_ value => 's1', 'normal';
+ option_ value => 's2', 'fast';
+ option_ value => 'sn', 'uncounted';
+ };
+ } if auth->permDbmod;
+ } for @$list;
+ };
+ };
+ paginate_ $url, $opt->{p}, [$count, $opt->{s}->results], 'b';
+
+ end_ 'form' if auth->permDbmod;
+}
+
+
+sub stats_ {
+ my($o) = @_;
+ my $stats = tuwf->dbAlli('
+ SELECT speed, count(*) as count, avg(l.length) as avg
+ , stddev_pop(l.length::real)::int as stddev
+ , percentile_cont(', \0.5, ') WITHIN GROUP (ORDER BY l.length) AS median
+ FROM vn_length_votes l
+ LEFT JOIN users u ON u.id = l.uid
+ WHERE u.perm_lengthvote IS DISTINCT FROM false AND l.speed IS NOT NULL AND NOT l.private AND l.vid =', \$o->{id}, '
+ GROUP BY GROUPING SETS ((speed),()) ORDER BY speed'
+ );
+ return if !$stats->[0]{count};
+
+ table_ style => 'margin: 0 auto', sub {
+ thead_ sub { tr_ sub {
+ td_ 'Speed';
+ td_ 'Median';
+ td_ 'Average';
+ td_ 'Stddev';
+ td_ '# Votes';
+ } };
+ tr_ sub {
+ td_ ['Slow', 'Normal', 'Fast', 'Total']->[$_->{speed}//3];
+ td_ sub { vnlength_ $_->{median} };
+ td_ sub { vnlength_ $_->{avg} };
+ td_ sub { vnlength_ $_->{stddev} if $_->{stddev} };
+ td_ $_->{count};
+ } for @$stats;
+ };
+}
+
+
+TUWF::get qr{/(?:(?<thing>$RE{vid}|$RE{uid})/)?lengthvotes}, sub {
+ my $thing = tuwf->capture('thing');
+ my $o = $thing && dbobj $thing;
+ return tuwf->resNotFound if $thing && (!$o->{id} || ($o->{entry_hidden} && !auth->isMod));
+ my $mode = !$thing ? '' : $o->{id} =~ /^v/ ? 'v' : 'u';
+
+ my $opt = tuwf->validate(get =>
+ ign => { default => undef, enum => [0,1] },
+ p => { page => 1 },
+ s => { tableopts => $TABLEOPTS{$mode} },
+ )->data;
+
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ my $where = sql_and
+ $mode ? sql($mode eq 'v' ? 'l.vid =' : 'l.uid =', \$o->{id}) : (),
+ $mode eq 'u' && auth && $o->{id} eq auth->uid ? () : 'NOT l.private',
+ defined $opt->{ign} ? sql('l.speed IS', $opt->{ign} ? 'NULL' : 'NOT NULL') : ();
+ my $count = tuwf->dbVali('SELECT COUNT(*) FROM vn_length_votes l WHERE', $where);
+
+ my $lst = tuwf->dbPagei({results => $opt->{s}->results, page => $opt->{p}},
+ 'SELECT l.id, l.uid, l.vid, l.length, l.speed, l.notes, l.private, l.rid::text[] AS rel, '
+ , sql_totime('l.date'), 'AS date, u.perm_lengthvote IS NOT DISTINCT FROM false AS ignore',
+ $mode ne 'u' ? (', ', sql_user()) : (),
+ $mode ne 'v' ? ', v.title' : (), '
+ FROM vn_length_votes l
+ LEFT JOIN users u ON u.id = l.uid',
+ $mode ne 'v' ? ('JOIN', vnt, 'v ON v.id = l.vid') : (),
+ 'WHERE', $where,
+ 'ORDER BY', $opt->{s}->sql_order(),
+ );
+ $_->{rel} = [ map +{ id => $_ }, $_->{rel}->@* ] for @$lst;
+ enrich_flatten lang => id => id => 'SELECT id, lang FROM releases_titles WHERE id IN', map $_->{rel}, @$lst;
+
+ my $title = 'Length votes'.($mode ? ($mode eq 'v' ? ' for ' : ' by ').$o->{title}[1] : '');
+ framework_ title => $title, dbobj => $o, sub {
+ article_ sub {
+ h1_ $title;
+ p_ 'Nothing to list. :(' if !@$lst;
+ stats_ $o if $mode eq 'v' && @$lst;
+ p_ class => 'browseopts', sub {
+ a_ href => url(p => undef, ign => undef), class => defined $opt->{ign} ? undef : 'optselected', 'All';
+ a_ href => url(p => undef, ign => 0), class => defined $opt->{ign} && !$opt->{ign} ? 'optselected' : undef, 'Active';
+ a_ href => url(p => undef, ign => 1), class => defined $opt->{ign} && $opt->{ign} ? 'optselected' : undef, 'Ignored';
+ } if auth->permDbmod;
+ };
+ listing_ $opt, \&url, $count, $lst, $mode if @$lst;
+ };
+};
+
+
+TUWF::post '/lengthvotes-edit', sub {
+ return tuwf->resDenied if !auth->permDbmod || !samesite;
+
+ my @actions;
+ for my $k (tuwf->reqPosts) {
+ next if $k !~ /^lv$RE{num}$/;
+ my $id = $+{num};
+ my $act = tuwf->reqPost($k);
+ next if !$act;
+ my $r = tuwf->dbRowi('
+ UPDATE vn_length_votes SET',
+ $act eq 'sn' ? 'speed = NULL' :
+ $act eq 's0' ? 'speed = 0' :
+ $act eq 's1' ? 'speed = 1' :
+ $act eq 's2' ? ('speed =', \2) : die,
+ 'WHERE id =', \$id, 'RETURNING vid, uid'
+ );
+ push @actions, "$r->{vid}-".($r->{uid}//'anon')."-$act";
+ }
+ auth->audit(undef, 'lengthvote edit', join ', ', sort @actions) if @actions;
+ tuwf->resRedirect(tuwf->reqPost('url'), 'post');
+};
+
+
+our $LENGTHVOTE = form_compile any => {
+ uid => { vndbid => 'u' },
+ vid => { vndbid => 'v' },
+ maycount => { anybool => 1 },
+ vote => { type => 'hash', default => undef, keys => {
+ rid => { type => 'array', minlength => 1, values => { vndbid => 'r' } },
+ length => { uint => 1, range => [1,26159] }, # 435h59m, largest round-ish number where the 'fast' speed adjustment doesn't overflow a smallint
+ speed => { default => undef, uint => 1, enum => [0,1,2] },
+ private => { anybool => 1 },
+ notes => { default => '' },
+ } },
+};
+
+elm_api VNLengthVote => undef, $LENGTHVOTE, sub {
+ my($data) = @_;
+ return elm_Unauth if !can_vote() || $data->{uid} ne auth->uid;
+ my %where = ( uid => $data->{uid}, vid => $data->{vid} );
+ tuwf->dbExeci('DELETE FROM vn_length_votes WHERE', \%where) if !$data->{vote};
+ $data->{vote}{rid} = sql sql_array($data->{vote}{rid}->@*), '::vndbid[]' if $data->{vote};
+ tuwf->dbExeci(
+ 'INSERT INTO vn_length_votes', { %where, $data->{vote}->%* },
+ 'ON CONFLICT (uid, vid) DO UPDATE SET', $data->{vote}
+ ) if $data->{vote};
+ return elm_Success;
+};
+
+1;
diff --git a/lib/VNWeb/VN/List.pm b/lib/VNWeb/VN/List.pm
new file mode 100644
index 00000000..42891f81
--- /dev/null
+++ b/lib/VNWeb/VN/List.pm
@@ -0,0 +1,450 @@
+package VNWeb::VN::List;
+
+use VNWeb::Prelude;
+use VNWeb::AdvSearch;
+use VNWeb::Filters;
+use VNWeb::Images::Lib;
+use VNWeb::ULists::Lib;
+use VNWeb::TT::Lib 'tagscore_';
+
+# Returns the tableopts config for:
+# - this VN list ('vn')
+# - this VN list with a search query ('vns')
+# - the VN listing on tags ('tags')
+# - a user's VN list ('ulist')
+# The latter has different numeric identifiers, a sad historical artifact. :(
+sub TABLEOPTS {
+ my $tags = $_[0] eq 'tags';
+ my $vns = $_[0] eq 'vns';
+ my $vn = $vns || $_[0] eq 'vn';
+ my $ulist = $_[0] eq 'ulist';
+ die if !$tags && !$vn && !$ulist;
+
+ # Old popularity column:
+ # sort_id => $ulist ? 14 : 3,
+ # vis_id => $ulist ? 11 : 0,
+ tableopts
+ _pref => $tags ? 'tableopts_vt' : $vn ? 'tableopts_v' : undef,
+ _views => ['rows', 'cards', 'grid'],
+ $tags ? (tagscore => {
+ name => 'Tag score',
+ compat => 'tagscore',
+ sort_id => 0,
+ sort_sql => 'tvi.rating ?o, v.sorttitle',
+ sort_default => 'desc',
+ sort_num => 1,
+ }) : (),
+ $vns ? (qscore => {
+ name => 'Relevance',
+ sort_id => 0,
+ sort_sql => 'sc.score !o, v.sorttitle',
+ sort_default => 'asc',
+ sort_num => 1,
+ }) : (),
+ title => {
+ name => 'Title',
+ compat => 'title',
+ sort_id => $ulist ? 0 : 1,
+ sort_sql => 'v.sorttitle',
+ },
+ $ulist ? (
+ voted => {
+ name => 'Vote date',
+ sort_sql => 'uv.vote_date',
+ sort_id => 1,
+ sort_num => 1,
+ vis_id => 0,
+ compat => 'voted'
+ },
+ vote => {
+ name => 'Vote',
+ sort_sql => 'uv.vote',
+ sort_id => 2,
+ sort_num => 1,
+ vis_id => 1,
+ compat => 'vote'
+ },
+ label => {
+ name => 'Labels',
+ sort_sql => sql('ARRAY(SELECT ul.label FROM unnest(uv.labels) l(id) JOIN ulist_labels ul ON ul.id = l.id WHERE ul.uid = uv.uid AND l.id <> ', \7, ')'),
+ sort_id => 4,
+ vis_id => 3,
+ compat => 'label'
+ },
+ added => {
+ name => 'Added',
+ sort_sql => 'uv.added',
+ sort_id => 5,
+ sort_num => 1,
+ vis_id => 4,
+ compat => 'added'
+ },
+ modified => {
+ name => 'Modified',
+ sort_sql => 'uv.lastmod',
+ sort_id => 6,
+ sort_num => 1,
+ vis_id => 5,
+ compat => 'modified'
+ },
+ started => {
+ name => 'Start date',
+ sort_sql => 'uv.started',
+ sort_id => 7,
+ sort_num => 1,
+ vis_id => 6,
+ compat => 'started'
+ },
+ finished => {
+ name => 'Finish date',
+ sort_sql => 'uv.finished',
+ sort_id => 8,
+ sort_num => 1,
+ vis_id => 7,
+ compat => 'finished'
+ },
+ ) : (),
+ released => {
+ name => 'Release date',
+ compat => 'rel',
+ sort_id => $ulist ? 9 : 2,
+ sort_sql => 'v.c_released ?o, v.title',
+ sort_num => 1,
+ vis_id => $ulist ? 8 : undef,
+ },
+ length => {
+ name => 'Length',
+ vis_id => $ulist ? 9 : 4,
+ },
+ developer => {
+ name => 'Developer',
+ vis_id => $ulist ? 10 : 2,
+ },
+ rating => {
+ name => 'Bayesian rating',
+ compat => 'rating',
+ sort_id => $ulist ? 11 : 4,
+ sort_sql => 'v.c_rat_rank !o NULLS LAST, v.c_votecount ?o, v.sorttitle',
+ sort_num => 1,
+ vis_id => $ulist ? 12 : 1,
+ vis_default => 1,
+ },
+ average => {
+ name => 'Vote average',
+ sort_id => $ulist ? 12 : 5,
+ sort_sql => 'v.c_average ?o NULLS LAST, v.c_votecount ?o, v.sorttitle',
+ sort_num => 1,
+ vis_id => $ulist ? 13 : 3,
+ },
+ votes => {
+ name => 'Number of votes',
+ sort_id => $ulist ? 13 : 6,
+ sort_sql => 'v.c_votecount ?o, v.sorttitle',
+ sort_num => 1,
+ sort_default => $tags || $vns ? undef : 'desc',
+ },
+ id => {
+ name => $ulist ? 'VN entry added' : 'Date added',
+ sort_id => 10,
+ sort_sql => 'v.id',
+ sort_num => 1,
+ };
+}
+
+my $TABLEOPTS = TABLEOPTS 'vn';
+my $TABLEOPTS_Q = TABLEOPTS 'vns';
+
+sub len_ {
+ my($v) = @_;
+ if ($v->{c_lengthnum}) {
+ vnlength_ $v->{c_length};
+ small_ " ($v->{c_lengthnum})";
+ } elsif($v->{length}) {
+ txt_ $VN_LENGTH{$v->{length}}{txt};
+ }
+}
+
+# Also used by VNWeb::TT::TagPage
+sub listing_ {
+ my($opt, $list, $count, $tagscore, $labels) = @_;
+
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 't', $opt->{s};
+
+ my sub votesort {
+ txt_ ' (';
+ sortable_ 'votes', $opt, \&url, 0;
+ txt_ ')'
+ }
+ article_ class => 'browse vnbrowse', sub {
+ table_ class => 'stripe', sub {
+ thead_ sub { tr_ sub {
+ td_ class => 'tc_score', sub { txt_ 'Score'; sortable_ 'tagscore', $opt, \&url } if $tagscore;
+ td_ class => 'tc_ulist', '' if auth;
+ td_ class => 'tc_title', sub { txt_ 'Title'; sortable_ 'title', $opt, \&url };
+ td_ class => 'tc_dev', 'Developer' if $opt->{s}->vis('developer');
+ td_ class => 'tc_plat', '';
+ td_ class => 'tc_lang', '';
+ td_ class => 'tc_rel', sub { txt_ 'Released'; sortable_ 'released', $opt, \&url };
+ td_ class => 'tc_length',sub { txt_ 'Length'; } if $opt->{s}->vis('length');
+ td_ class => 'tc_rating', sub {
+ txt_ 'Rating'; sortable_ 'rating', $opt, \&url;
+ votesort();
+ } if $opt->{s}->vis('rating');
+ td_ class => $opt->{s}->vis('rating') ? 'tc_average' : 'tc_rating', sub {
+ txt_ 'Average'; sortable_ 'average', $opt, \&url;
+ votesort() if !$opt->{s}->vis('rating');
+ } if $opt->{s}->vis('average');
+ } };
+ tr_ sub {
+ td_ class => 'tc_score', sub { tagscore_ $_->{tagscore} } if $tagscore;
+ td_ class => 'tc_ulist', sub { ulists_widget_ $_ } if auth;
+ td_ class => 'tc_title', sub { a_ href => "/$_->{id}", tattr $_ };
+ td_ class => 'tc_dev', sub {
+ join_ ' & ', sub {
+ a_ href => "/$_->{id}", tattr $_;
+ }, $_->{developers}->@*;
+ } if $opt->{s}->vis('developer');
+ td_ class => 'tc_plat', sub { join_ '', sub { platform_ $_ if $_ ne 'unk' }, sort $_->{platforms}->@* };
+ td_ class => 'tc_lang', sub { join_ '', sub { abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' }, reverse sort $_->{lang}->@* };
+ td_ class => 'tc_rel', sub { rdate_ $_->{c_released} };
+ td_ class => 'tc_length',sub { len_ $_ } if $opt->{s}->vis('length');
+ td_ class => 'tc_rating',sub {
+ txt_ $_->{c_rating} ? sprintf '%.2f', $_->{c_rating}/100 : '-';
+ small_ sprintf ' (%d)', $_->{c_votecount};
+ } if $opt->{s}->vis('rating');
+ td_ class => 'tc_average',sub {
+ txt_ $_->{c_average} ? sprintf '%.2f', $_->{c_average}/100 : '-';
+ small_ sprintf ' (%d)', $_->{c_votecount} if !$opt->{s}->vis('rating');
+ } if $opt->{s}->vis('average');
+ } for @$list;
+ }
+ } if $opt->{s}->rows;
+
+ # Contents of the grid & card modes are the same
+ my sub infoblock_ {
+ my($canlink) = @_; # grid contains an outer <a>, so may not contain links itself.
+ my sub lnk_ {
+ my($url, @attr) = @_;
+ a_ href => $url, @attr if $canlink;
+ span_ @attr if !$canlink;
+ }
+ lnk_ "/$_->{id}", tattr $_;
+ if(!$labels || $opt->{s}->vis('released')) {
+ br_;
+ join_ '', sub { platform_ $_ if $_ ne 'unk' }, sort $_->{platforms}->@*;
+ join_ '', sub { abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' }, reverse sort $_->{lang}->@*;
+ rdate_ $_->{c_released};
+ }
+ if($opt->{s}->vis('developer')) {
+ br_;
+ join_ ' & ', sub {
+ lnk_ "/$_->{id}", tattr $_;
+ }, $_->{developers}->@*;
+ }
+ table_ sub {
+ tr_ sub {
+ td_ 'Tag score:';
+ td_ sub { tagscore_ $_->{tagscore} };
+ } if $tagscore;
+ tr_ sub {
+ td_ 'Length';
+ td_ sub { len_ $_ };
+ } if $opt->{s}->vis('length');
+ tr_ sub {
+ td_ $opt->{s}->vis('vote') ? 'Vote:' : 'Voted:';
+ td_ sub {
+ txt_ fmtvote $_->{vote} if $opt->{s}->vis('vote');
+ txt_ ' on '.($_->{vote_date} ? fmtdate $_->{vote_date}, 'compact' : '-') if $opt->{s}->vis('voted');
+ }
+ } if $opt->{s}->vis('vote') || $opt->{s}->vis('voted');
+ tr_ sub {
+ td_ 'Labels:';
+ td_ sub {
+ my %labels = map +($_,1), $_->{labels}->@*;
+ my @l = grep $labels{$_->{id}} && $_->{id} != 7, @$labels;
+ txt_ @l ? join ', ', map $_->{label}, @l : '-';
+ };
+ } if $opt->{s}->vis('label');
+ tr_ sub {
+ td_ 'Added on:';
+ td_ fmtdate $_->{added}, 'compact';
+ } if $opt->{s}->vis('added');
+ tr_ sub {
+ td_ 'Modified on:';
+ td_ fmtdate $_->{lastmod}, 'compact';
+ } if $opt->{s}->vis('modified');
+ tr_ sub {
+ td_ 'Started:';
+ td_ $_->{started}||'-';
+ } if $opt->{s}->vis('started');
+ tr_ sub {
+ td_ 'Finished:';
+ td_ $_->{finished}||'-';
+ } if $opt->{s}->vis('finished');
+ tr_ sub {
+ td_ 'Rating:';
+ td_ sub {
+ txt_ $_->{c_rating} ? sprintf '%.2f', $_->{c_rating}/100 : '-';
+ small_ sprintf ' (%d)', $_->{c_votecount};
+ };
+ } if $opt->{s}->vis('rating');
+ tr_ sub {
+ td_ 'Average:';
+ td_ sub {
+ txt_ $_->{c_average} ? sprintf '%.2f', $_->{c_average}/100 : '';
+ small_ sprintf ' (%d)', $_->{c_votecount} if !$opt->{s}->vis('rating');
+ };
+ } if $opt->{s}->vis('average');
+ }
+ }
+
+ article_ class => 'vncards', sub {
+ my($w,$h) = (90,120);
+ div_ sub {
+ div_ sub {
+ if($_->{image}) {
+ my($iw,$ih) = imgsize $_->{image}{width}*100, $_->{image}{height}*100, $w, $h;
+ image_ $_->{image}, width => $iw, height => $ih, url => "/$_->{id}", overlay => undef;
+ } else {
+ txt_ 'no image';
+ }
+ };
+ div_ sub {
+ ulists_widget_ $_;
+ infoblock_ 1;
+ };
+ } for @$list;
+ } if $opt->{s}->cards;
+
+ article_ class => 'vngrid', sub {
+ div_ !$_->{image} || image_hidden($_->{image}) ? (class => 'noimage') : (style => 'background-image: url("'.imgurl($_->{image}{id}).'")'), sub {
+ ulists_widget_ $_;
+ a_ href => "/$_->{id}", title => $_->{title}[3], sub { infoblock_ 0 };
+ } for @$list;
+ } if $opt->{s}->grid;
+
+ paginate_ \&url, $opt->{p}, [$count, $opt->{s}->results], 'b';
+}
+
+
+# Enrich some extra fields fields needed for listing_()
+# Also used by TT::TagPage and UList::List
+sub enrich_listing {
+ my($widget, $opt, @lst) = @_;
+
+ enrich developers => id => vid => sub { sql
+ 'SELECT v.id AS vid, p.id, p.title
+ FROM vn v, unnest(v.c_developers) vp(id),', producerst, 'p
+ WHERE p.id = vp.id AND v.id IN', $_[0], 'ORDER BY p.sorttitle, p.id'
+ }, @lst if $opt->{s}->vis('developer');
+
+ enrich_image_obj image => @lst if !$opt->{s}->rows;
+ enrich_ulists_widget @lst if $widget;
+}
+
+
+TUWF::get qr{/v(?:/(?<char>all|[a-z0]))?}, sub {
+ my $opt = tuwf->validate(get =>
+ q => { searchquery => 1 },
+ sq=> { searchquery => 1 },
+ p => { upage => 1 },
+ f => { advsearch_err => 'v' },
+ ch=> { onerror => [], type => 'array', scalar => 1, values => { onerror => undef, enum => ['0', 'a'..'z'] } },
+ fil => { onerror => '' },
+ rfil => { onerror => '' },
+ cfil => { onerror => '' },
+ )->data;
+ $opt->{q} = $opt->{sq} if !$opt->{q};
+ $opt->{s} = tuwf->validate(get => s => { tableopts => $opt->{q} ? $TABLEOPTS_Q : $TABLEOPTS })->data;
+ $opt->{s} = $opt->{s}->sort_param(qscore => 'a') if $opt->{q} && tuwf->reqGet('sb');
+ $opt->{ch} = $opt->{ch}[0];
+
+ # compat with old URLs
+ my $oldch = tuwf->capture('char');
+ $opt->{ch} //= $oldch if defined $oldch && $oldch ne 'all';
+
+ # URL compatibility with old filters
+ if(!$opt->{f}->{query} && ($opt->{fil} || $opt->{rfil} || $opt->{cfil})) {
+ my $q = eval {
+ my $fil = filter_vn_adv filter_parse v => $opt->{fil};
+ my $rfil = filter_release_adv filter_parse r => $opt->{rfil};
+ my $cfil = filter_char_adv filter_parse c => $opt->{cfil};
+ my @q = (
+ $fil && @$fil > 1 ? $fil : (),
+ $rfil && @$rfil > 1 ? [ 'release', '=', $rfil ] : (),
+ $cfil && @$cfil > 1 ? [ 'character', '=', $cfil ] : (),
+ );
+ tuwf->compile({ advsearch => 'v' })->validate(@q > 1 ? ['and',@q] : @q)->data;
+ };
+ return tuwf->resRedirect(tuwf->reqPath().'?'.query_encode(%$opt, fil => undef, rfil => undef, cfil => undef, f => $q), 'perm') if $q;
+ }
+
+ $opt->{f} = advsearch_default 'v' if !$opt->{f}{query} && !defined tuwf->reqGet('f');
+
+ my $where = sql_and
+ 'NOT v.hidden', $opt->{f}->sql_where(),
+ defined($opt->{ch}) ? sql 'match_firstchar(v.sorttitle, ', \$opt->{ch}, ')' : ();
+
+ my $time = time;
+ my($count, $list);
+ db_maytimeout {
+ $count = tuwf->dbVali('SELECT count(*) FROM', vnt, 'v WHERE', sql_and $where, $opt->{q}->sql_where('v', 'v.id'));
+ $list = $count ? tuwf->dbPagei({results => $opt->{s}->results(), page => $opt->{p}}, '
+ SELECT v.id, v.title, v.c_released, v.c_votecount, v.c_rating, v.c_average
+ , v.image, v.c_platforms::text[] AS platforms, v.c_languages::text[] AS lang',
+ $opt->{s}->vis('length') ? ', v.length, v.c_length, v.c_lengthnum' : (), '
+ FROM', vnt, 'v', $opt->{q}->sql_join('v', 'v.id'), '
+ WHERE', $where, '
+ ORDER BY', $opt->{s}->sql_order(),
+ ) : [];
+ } || (($count, $list) = (undef, []));
+
+ my $fullq = join '', $opt->{q}->words->@*;
+ my $other = length $fullq && $opt->{s}->sorted('qscore') && $opt->{p} == 1 ? tuwf->dbAlli("
+ SELECT x.id, i.title
+ FROM (
+ SELECT DISTINCT id
+ FROM search_cache
+ WHERE NOT (id BETWEEN 'v1' AND vndbid_max('v'))
+ AND NOT (id BETWEEN 'r1' AND vndbid_max('r'))
+ AND label =", \$fullq, ') x,
+ ', item_info('id', 'null'), 'i
+ WHERE NOT i.hidden
+ ORDER BY vndbid_type(x.id) DESC, i.title[1+1]
+ ') : [];
+
+ return tuwf->resRedirect("/$list->[0]{id}", 'temp') if $count && $count == 1 && $opt->{p} == 1 && $opt->{q} && !defined $opt->{ch} && !@$other;
+
+ enrich_listing(1, $opt, $list);
+ $time = time - $time;
+
+ framework_ title => 'Browse visual novels', sub {
+ form_ action => '/v', method => 'get', sub {
+ article_ sub {
+ h1_ 'Browse visual novels';
+ searchbox_ v => $opt->{q};
+ p_ class => 'browseopts', sub {
+ button_ type => 'submit', name => 'ch', value => ($_//''), ($_//'') eq ($opt->{ch}//'') ? (class => 'optselected') : (), !defined $_ ? 'ALL' : $_ ? uc $_ : '#'
+ for (undef, 'a'..'z', 0);
+ };
+ input_ type => 'hidden', name => 'ch', value => $opt->{ch}//'';
+ $opt->{f}->elm_($count, $time);
+ };
+ article_ sub {
+ h1_ 'Did you mean to search for...';
+ ul_ style => 'column-width: 250px', sub {
+ li_ sub {
+ strong_ {qw/r Release p Producer c Character s Staff g Tag i Trait/}->{substr $_->{id}, 0, 1};
+ txt_ ': ';
+ a_ href => "/$_->{id}", tattr $_;
+ } for @$other;
+ };
+ } if @$other;
+ listing_ $opt, $list, $count if $count;
+ };
+ };
+};
+
+1;
diff --git a/lib/VNWeb/VN/Page.pm b/lib/VNWeb/VN/Page.pm
new file mode 100644
index 00000000..6262fcc1
--- /dev/null
+++ b/lib/VNWeb/VN/Page.pm
@@ -0,0 +1,1036 @@
+package VNWeb::VN::Page;
+
+use VNWeb::Prelude;
+use VNWeb::Releases::Lib;
+use VNWeb::Images::Lib qw/image_flagging_display image_ enrich_image_obj/;
+use VNWeb::ULists::Lib 'ulists_widget_full_data';
+use VNDB::Func 'fmtrating';
+
+
+# Enrich everything necessary to at least render infobox_() and tabs_().
+# Also used by Chars::VNTab, Reviews::VNTab and VN::Quotes
+sub enrich_vn {
+ my($v, $revonly) = @_;
+ $v->{title} = titleprefs_obj $v->{olang}, $v->{titles};
+ enrich_merge id => 'SELECT id, c_votecount, c_length, c_lengthnum FROM vn WHERE id IN', $v;
+ enrich_merge vid => sql('SELECT id AS vid, title, sorttitle, c_released FROM', vnt, 'v WHERE id IN'), $v->{relations};
+ enrich_merge aid => 'SELECT id AS aid, title_romaji, title_kanji, year, type, ann_id, lastfetch FROM anime WHERE id IN', $v->{anime};
+ enrich_extlinks v => 0, $v;
+ enrich_image_obj image => $v;
+ enrich_image_obj scr => $v->{screenshots};
+
+ # The queries below are not relevant for revisions
+ return if $revonly;
+
+ # This fetches rather more information than necessary for infobox_(), but it'll have to do.
+ # (And we'll need it for the releases tab anyway)
+ $v->{releases} = tuwf->dbAlli('
+ SELECT r.id, rv.rtype, r.patch, r.released, r.gtin,', sql_extlinks(r => 'r.'), '
+ , (SELECT COUNT(*) FROM releases_vn rv WHERE rv.id = r.id) AS num_vns
+ FROM releases r
+ JOIN releases_vn rv ON rv.id = r.id
+ WHERE NOT r.hidden AND rv.vid =', \$v->{id}
+ );
+ enrich_extlinks r => 0, $v->{releases};
+
+ $v->{reviews} = tuwf->dbRowi('
+ SELECT COUNT(*) FILTER(WHERE isfull) AS full, COUNT(*) FILTER(WHERE NOT isfull) AS mini, COUNT(*) AS total
+ FROM reviews
+ WHERE NOT c_flagged AND vid =', \$v->{id}
+ );
+ $v->{tags} = !prefs()->{has_tagprefs} ? tuwf->dbAlli('
+ SELECT t.id, t.name, t.cat, tv.rating, tv.count, tv.spoiler, tv.lie
+ FROM tags t
+ JOIN tags_vn_direct tv ON t.id = tv.tag
+ WHERE tv.vid =', \$v->{id}, '
+ ORDER BY rating DESC, t.name'
+ ) : tuwf->dbAlli(
+ # Monster of a query, but tag overrides are a bit complicated:
+ # - We need to find the shortest path from a tag applied to the VN to a
+ # parent in users_prefs_tags, and use those preferences. That's what
+ # tag_direct does.
+ # - If the user has a tag marked as "Always show" but hasn't checked
+ # "also apply to child tags", then we need to look for any child tags
+ # and inject their parent if said parent hasn't been directly applied.
+ # That's what tag_indirect does.
+ 'WITH RECURSIVE tag_overrides (tid, spoil, color, childs, lvl) AS (
+ SELECT tid, spoil, color, childs, 0 FROM users_prefs_tags WHERE id =', \auth->uid, '
+ UNION ALL
+ SELECT tp.id, x.spoil, x.color, true, lvl+1
+ FROM tag_overrides x
+ JOIN tags_parents tp ON tp.parent = x.tid
+ WHERE x.childs
+ ), tag_overrides_grouped (tid, spoil, color) AS (
+ SELECT DISTINCT ON(tid) tid, spoil, color FROM tag_overrides ORDER BY tid, lvl
+ ), tag_direct (tid, rating, count, spoiler, lie, override, color) AS (
+ SELECT t.tag, t.rating, t.count, t.spoiler, t.lie, x.spoil, x.color
+ FROM tags_vn_direct t
+ LEFT JOIN tag_overrides_grouped x ON x.tid = t.tag
+ WHERE t.vid =', \$v->{id}, 'AND x.spoil IS DISTINCT FROM 1+1+1
+ ), tag_indirect (tid, rating, count, spoiler, lie, override, color) AS (
+ SELECT t.tag, t.rating, 0::smallint, t.spoiler, t.lie, x.spoil, x.color
+ FROM tags_vn_inherit t
+ JOIN users_prefs_tags x ON x.tid = t.tag
+ WHERE t.vid =', \$v->{id}, 'AND x.id =', \auth->uid, 'AND NOT x.childs AND x.spoil = 0
+ AND NOT EXISTS(SELECT 1 FROM tag_direct d WHERE d.tid = t.tag)
+ ) SELECT t.id, t.name, t.cat, d.rating, d.count, d.spoiler, d.lie, d.override, d.color
+ FROM tags t
+ JOIN (SELECT * FROM tag_direct UNION ALL SELECT * FROM tag_indirect) d ON d.tid = t.id
+ ORDER BY d.rating DESC, t.name'
+ );
+}
+
+
+# Enrich everything necessary for rev_() (includes enrich_vn())
+sub enrich_item {
+ my($v, $full) = @_;
+ enrich_vn $v, !$full;
+ enrich_merge aid => sql('SELECT id AS sid, aid, title FROM', staff_aliast, 's WHERE aid IN'), $v->{staff}, $v->{seiyuu};
+ enrich_merge cid => sql('SELECT id AS cid, title AS char_title FROM', charst, 'c WHERE id IN'), $v->{seiyuu};
+
+ $v->{relations} = [ sort { idcmp($a->{vid}, $b->{vid}) } $v->{relations}->@* ];
+ $v->{anime} = [ sort { $a->{aid} <=> $b->{aid} } $v->{anime}->@* ];
+ $v->{editions} = [ sort { ($a->{lang}||'') cmp ($b->{lang}||'') || $b->{official} cmp $a->{official} || $a->{name} cmp $b->{name} } $v->{editions}->@* ];
+ $v->{staff} = [ sort { ($a->{eid}//-1) <=> ($b->{eid}//-1) || $a->{aid} <=> $b->{aid} || $a->{role} cmp $b->{role} } $v->{staff}->@* ];
+ $v->{seiyuu} = [ sort { $a->{aid} <=> $b->{aid} || idcmp($a->{cid}, $b->{cid}) || $a->{note} cmp $b->{note} } $v->{seiyuu}->@* ];
+ $v->{screenshots} = [ sort { idcmp($a->{scr}{id}, $b->{scr}{id}) } $v->{screenshots}->@* ];
+}
+
+
+sub og {
+ my($v) = @_;
+ +{
+ description => bb_format($v->{description}, text => 1),
+ image => $v->{image} && !$v->{image}{sexual} && !$v->{image}{violence} ? imgurl($v->{image}{id}) :
+ [map $_->{scr}{sexual}||$_->{scr}{violence}?():(imgurl($_->{scr}{id})), $v->{screenshots}->@*]->[0]
+ }
+}
+
+
+sub prefs {
+ state $default = {
+ vnrel_langs => \%LANGUAGE, vnrel_olang => 1, vnrel_mtl => 0,
+ staffed_langs => \%LANGUAGE, staffed_olang => 1, staffed_unoff => 0,
+ has_tagprefs => 0,
+ };
+ tuwf->req->{vnpage_prefs} //= auth ? do {
+ my $v = tuwf->dbRowi('
+ SELECT vnrel_langs::text[], vnrel_olang, vnrel_mtl
+ , staffed_langs::text[], staffed_olang, staffed_unoff
+ , EXISTS(SELECT 1 FROM users_prefs_tags WHERE id =', \auth->uid, ') AS has_tagprefs
+ FROM users_prefs
+ WHERE id =', \auth->uid
+ );
+ $v->{vnrel_langs} = $v->{vnrel_langs} ? { map +($_,1), $v->{vnrel_langs}->@* } : \%LANGUAGE;
+ $v->{staffed_langs} = $v->{staffed_langs} ? { map +($_,1), $v->{staffed_langs}->@* } : \%LANGUAGE;
+ $v
+ } : $default;
+}
+
+
+# The voting and review options are hidden if nothing has been released yet.
+sub canvote {
+ my($v) = @_;
+ $v->{_canvote} //= do {
+ my $minreleased = min grep $_, map $_->{released}, $v->{releases}->@*;
+ $minreleased && $minreleased <= strftime('%Y%m%d', gmtime)
+ };
+}
+
+
+sub rev_ {
+ my($v) = @_;
+ revision_ $v, \&enrich_item,
+ [ titles => 'Title(s)', txt => sub {
+ "[$_->{lang}] $_->{title}".($_->{latin} ? " / $_->{latin}" : '').($_->{official} ? '' : ' (unofficial)')
+ }],
+ [ alias => 'Alias' ],
+ [ olang => 'Original language', fmt => \%LANGUAGE ],
+ [ description => 'Description' ],
+ [ devstatus => 'Development status',fmt => \%DEVSTATUS ],
+ [ length => 'Length', fmt => \%VN_LENGTH ],
+ [ editions => 'Editions', fmt => sub {
+ abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, '' if $_->{lang};
+ txt_ $_->{name};
+ small_ ' (unofficial)' if !$_->{official};
+ }],
+ [ staff => 'Credits', fmt => sub {
+ my $eid = $_->{eid};
+ my $e = defined $eid && (grep $eid == $_->{eid}, $_[0]{editions}->@*)[0];
+ txt_ "[$e->{name}] " if $e;
+ a_ href => "/$_->{sid}", tattr $_ if $_->{sid};
+ small_ '[removed alias]' if !$_->{sid};
+ txt_ " [$CREDIT_TYPE{$_->{role}}]";
+ txt_ " [$_->{note}]" if $_->{note};
+ }],
+ [ seiyuu => 'Seiyuu', fmt => sub {
+ a_ href => "/$_->{sid}", tattr $_ if $_->{sid};
+ small_ '[removed alias]' if !$_->{sid};
+ txt_ ' as ';
+ a_ href => "/$_->{cid}", tattr $_->{char_title};
+ txt_ " [$_->{note}]" if $_->{note};
+ }],
+ [ relations => 'Relations', fmt => sub {
+ txt_ sprintf '[%s] %s: ', $_->{official} ? 'official' : 'unofficial', $VN_RELATION{$_->{relation}}{txt};
+ a_ href => "/$_->{vid}", tattr $_;
+ }],
+ [ anime => 'Anime', fmt => sub { a_ href => "https://anidb.net/anime/$_->{aid}", "a$_->{aid}" }],
+ [ screenshots => 'Screenshots', fmt => sub {
+ my $rev = $_[0]{chid} == $v->{chid} ? 'new' : 'old';
+ txt_ '[';
+ a_ href => "/$_->{rid}", $_->{rid} if $_->{rid};
+ txt_ 'no release' if !$_->{rid};
+ txt_ '] ';
+ a_ href => imgurl($_->{scr}{id}), 'data-iv' => "$_->{scr}{width}x$_->{scr}{height}:$rev:$_->{scr}{sexual}$_->{scr}{violence}$_->{scr}{votecount}", $_->{scr}{id};
+ txt_ " [$_->{scr}{width}x$_->{scr}{height}; ";
+ a_ href => "/$_->{scr}{id}", image_flagging_display $_->{scr} if auth;
+ span_ image_flagging_display $_->{scr} if !auth;
+ txt_ '] ';
+ # The old NSFW flag has been removed around 2020-07-14, so not relevant for edits made later on.
+ small_ sprintf 'old flag: %s', $_->{nsfw} ? 'NSFW' : 'Safe' if $_[0]{rev_added} < 1594684800;
+ }],
+ [ image => 'Image', fmt => sub { image_ $_ } ],
+ [ img_nsfw => 'Image NSFW (unused)', fmt => sub { txt_ $_ ? 'Not safe' : 'Safe' } ],
+ revision_extlinks 'v'
+}
+
+
+sub infobox_relations_ {
+ my($v) = @_;
+ return if !$v->{relations}->@*;
+
+ my %rel;
+ push $rel{$_->{relation}}->@*, $_ for sort { $b->{official} <=> $a->{official} || $a->{c_released} <=> $b->{c_released} || $a->{sorttitle} cmp $b->{sorttitle} } $v->{relations}->@*;
+ my $unoffcount = grep !$_->{official}, $v->{relations}->@*;
+
+ tr_ sub {
+ td_ 'Relations';
+ td_ class => 'relations linkradio', sub {
+ if($unoffcount >= 3) {
+ input_ type => 'checkbox', id => 'unoffrelations', class => 'hidden';
+ label_ for => 'unoffrelations', "unofficial ($unoffcount)";
+ }
+ dl_ sub {
+ for(sort keys %rel) {
+ my @allunoff = (!grep $_->{official}, $rel{$_}->@*) ? (class => 'unofficial') : ();
+ dt_ @allunoff, $VN_RELATION{$_}{txt};
+ dd_ @allunoff, sub {
+ p_ class => $_->{official} ? undef : 'unofficial', sub {
+ small_ '[unofficial] ' if !$_->{official};
+ a_ href => "/$_->{vid}", tattr $_;
+ } for $rel{$_}->@*;
+ }
+ }
+ }
+ }
+ }
+}
+
+
+sub infobox_length_ {
+ my($v) = @_;
+
+ tr_ sub {
+ td_ 'Play time';
+ td_ sub {
+ # Cached number, which means this VN has counted votes
+ if($v->{c_lengthnum}) {
+ my $m = $v->{c_length};
+ txt_ +(grep $m >= $_->{low} && $m < $_->{high}, values %VN_LENGTH)[0]{txt}.' (';
+ vnlength_ $m;
+ txt_ ' from ';
+ a_ href => "/$v->{id}/lengthvotes", sprintf '%d vote%s', $v->{c_lengthnum}, $v->{c_length}==1?'':'s';
+ txt_ ')';
+ # No cached number so no counted votes; fall back to old 'length' field and display number of uncounted votes
+ } else {
+ my $uncounted = tuwf->dbVali('SELECT count(*) FROM vn_length_votes WHERE vid =', \$v->{id}, 'AND NOT private');
+ txt_ $VN_LENGTH{$v->{length}}{txt};
+ if ($v->{length} || $uncounted) {
+ lit_ ' (';
+ txt_ $VN_LENGTH{$v->{length}}{time} if $v->{length};
+ lit_ ', ' if $v->{length} && $uncounted;
+ a_ href => "/$v->{id}/lengthvotes", sprintf '%d uncounted vote%s', $uncounted, $uncounted == 1 ? '' : 's' if $uncounted;
+ lit_ ')';
+ }
+ }
+ if (VNWeb::VN::Length::can_vote()) {
+ my $my = tuwf->dbRowi('SELECT rid::text[] AS rid, length, speed, private, notes FROM vn_length_votes WHERE vid =', \$v->{id}, 'AND uid =', \auth->uid);
+ elm_ VNLengthVote => $VNWeb::VN::Length::LENGTHVOTE, {
+ uid => auth->uid, vid => $v->{id},
+ vote => $my->{rid}?$my:undef,
+ maycount => $v->{devstatus} != 1,
+ }, sub { span_ @_, ''};
+ }
+ };
+ };
+}
+
+
+sub infobox_producers_ {
+ my($v) = @_;
+
+ my $p = tuwf->dbAlli('
+ SELECT p.id, p.title, p.sorttitle, rl.lang, bool_or(rp.developer) as developer, bool_or(rp.publisher) as publisher, min(rv.rtype) as rtype, bool_or(r.official) as official
+ FROM releases_vn rv
+ JOIN releases r ON r.id = rv.id
+ JOIN releases_titles rl ON rl.id = rv.id
+ JOIN releases_producers rp ON rp.id = rv.id
+ JOIN', producerst, 'p ON p.id = rp.pid
+ WHERE NOT r.hidden AND (r.official OR NOT rl.mtl) AND rv.vid =', \$v->{id}, '
+ GROUP BY p.id, p.title, p.sorttitle, rl.lang
+ ORDER BY NOT bool_or(r.official), MIN(r.released), p.sorttitle
+ ');
+ return if !@$p;
+
+ my $hasfull = grep $_->{rtype} eq 'complete', @$p;
+ my %dev;
+ my @dev = grep $_->{developer} && (!$hasfull || $_->{rtype} ne 'trial') && !$dev{$_->{id}}++, @$p;
+
+ tr_ sub {
+ td_ 'Developer';
+ td_ sub {
+ join_ ' & ', sub { a_ href => "/$_->{id}", tattr $_ }, @dev;
+ };
+ } if @dev;
+
+ my(%lang, @lang, $lang);
+ for(grep $_->{publisher} && (!$hasfull || $_->{rtype} ne 'trial'), @$p) {
+ push @lang, $_->{lang} if !$lang{$_->{lang}};
+ push $lang{$_->{lang}}->@*, $_;
+ }
+ return if !keys %lang;
+
+ use sort 'stable';
+ @lang = sort { ($b eq $v->{olang}) cmp ($a eq $v->{olang}) } @lang;
+
+ # Merge multiple languages into one group if the publishers are the same.
+ my @nlang = (shift @lang);
+ my $last = join ';', sort map $_->{id}, $lang{$nlang[0]}->@*;
+ for (@lang) {
+ my $cids = join ';', sort map $_->{id}, $lang{$_}->@*;
+ if($last eq $cids) {
+ $nlang[$#nlang] .= ";$_";
+ } else {
+ push @nlang, $_;
+ }
+ $last = $cids;
+ }
+
+ tr_ sub {
+ td_ 'Publishers';
+ td_ sub {
+ join_ \&br_, sub {
+ my @l = split /;/;
+ abbr_ class => "icon-lang-$_", title => $LANGUAGE{$_}{txt}, '' for @l;
+ join_ ' & ', sub { a_ href => "/$_->{id}", $_->{official} ? () : (class => 'grayedout'), tattr $_ }, $lang{$l[0]}->@*;
+ }, @nlang;
+ }
+ };
+}
+
+
+sub infobox_affiliates_ {
+ my($v) = @_;
+
+ # If the same shop link has been added to multiple releases, use the 'first' matching type in this list.
+ my @type = ('bundle', '', 'partial', 'trial', 'patch');
+
+ # url => [$title, $url, $price, $type]
+ my %links;
+ for my $rel ($v->{releases}->@*) {
+ my $type = $rel->{patch} ? 4 :
+ $rel->{rtype} eq 'trial' ? 3 :
+ $rel->{rtype} eq 'partial' ? 2 :
+ $rel->{num_vns} > 1 ? 0 : 1;
+
+ $links{$_->{url2}} = [ @{$_}{qw/label url2 price/}, min $type, $links{$_->{url2}}[3]||9 ] for grep $_->{price}, $rel->{extlinks}->@*;
+ }
+ return if !keys %links;
+
+ tr_ id => 'buynow', sub {
+ td_ 'Shops';
+ td_ sub {
+ small_ class => 'ad', 'sponsored links';
+ join_ \&br_, sub {
+ b_ '» ';
+ a_ href => $_->[1], sub {
+ txt_ $_->[2];
+ small_ ' @ ';
+ txt_ $_->[0];
+ small_ " ($type[$_->[3]])" if $_->[3] != 1;
+ };
+ }, sort { $a->[0] cmp $b->[0] || $a->[2] cmp $b->[2] } values %links;
+ }
+ }
+}
+
+
+sub infobox_anime_ {
+ my($v) = @_;
+ return if !$v->{anime}->@*;
+ tr_ sub {
+ td_ 'Related anime';
+ td_ class => 'anime', sub { join_ \&br_, sub {
+ if(!$_->{lastfetch} || !$_->{year} || !$_->{title_romaji}) {
+ span_ sub {
+ txt_ '[no information available at this time: ';
+ a_ href => 'https://anidb.net/anime/'.$_->{aid}, "a$_->{aid}";
+ txt_ ']';
+ };
+ } else {
+ span_ sub {
+ txt_ '[';
+ a_ href => "https://anidb.net/anime/$_->{aid}", title => 'AniDB', 'DB';
+ if($_->{ann_id}) {
+ txt_ '-';
+ a_ href => "http://www.animenewsnetwork.com/encyclopedia/anime.php?id=$_->{ann_id}", title => 'Anime News Network', 'ANN';
+ }
+ txt_ '] ';
+ };
+ abbr_ title => $_->{title_kanji}||$_->{title_romaji}, shorten $_->{title_romaji}, 50;
+ span_ ' ('.(defined $_->{type} ? $ANIME_TYPE{$_->{type}}{txt}.', ' : '').$_->{year}.')';
+ }
+ }, sort { ($a->{year}||9999) <=> ($b->{year}||9999) } $v->{anime}->@* }
+ }
+}
+
+
+sub infobox_tags_ {
+ my($v) = @_;
+ div_ id => 'tagops', sub {
+ debug_ $v->{tags};
+ my @ero = grep($_->{cat} eq 'ero', $v->{tags}->@*) ? ('ero') : ();
+ for ('cont', @ero, 'tech') {
+ input_ id => "cat_$_", type => 'checkbox', class => 'hidden',
+ (auth ? auth->pref("tags_$_") : $_ ne 'ero') ? (checked => 'checked') : ();
+ label_ for => "cat_$_", lc $TAG_CATEGORY{$_};
+ }
+ my $spoiler = auth->pref('spoilers') || 0;
+ input_ id => 'tag_spoil_none', type => 'radio', class => 'hidden', name => 'tag_spoiler', $spoiler == 0 ? (checked => 'checked') : ();
+ label_ for => 'tag_spoil_none', class => 'sec', 'hide spoilers';
+ input_ id => 'tag_spoil_some', type => 'radio', class => 'hidden', name => 'tag_spoiler', $spoiler == 1 ? (checked => 'checked') : ();
+ label_ for => 'tag_spoil_some', 'show minor spoilers';
+ input_ id => 'tag_spoil_all', type => 'radio', class => 'hidden', name => 'tag_spoiler', $spoiler == 2 ? (checked => 'checked') : ();
+ label_ for => 'tag_spoil_all', 'spoil me!';
+
+ input_ id => 'tag_toggle_summary', type => 'radio', class => 'hidden', name => 'tag_all', auth->pref('tags_all') ? () : (checked => 'checked');
+ label_ for => 'tag_toggle_summary', class => 'sec', 'summary';
+ input_ id => 'tag_toggle_all', type => 'radio', class => 'hidden', name => 'tag_all', auth->pref('tags_all') ? (checked => 'checked') : ();
+ label_ for => 'tag_toggle_all', class => 'lst', 'all';
+ div_ id => 'vntags', sub {
+ my %counts = map +($_,[0,0,0]), keys %TAG_CATEGORY;
+ join_ ' ', sub {
+ my $spoil = $_->{override}//$_->{spoiler};
+ my $cnt = $counts{$_->{cat}};
+ $cnt->[2]++;
+ $cnt->[1]++ if $spoil < 2;
+ $cnt->[0]++ if $spoil < 1;
+ my $cut = defined $_->{override} ? '' : $cnt->[0] > 15 ? ' cut cut2 cut1 cut0' : $cnt->[1] > 15 ? ' cut cut2 cut1' : $cnt->[2] > 15 ? ' cut cut2' : '';
+ span_ class => "tagspl$spoil cat_$_->{cat} $cut", sub {
+ a_ href => "/$_->{id}",
+ mkclass(defined $_->{override} ? 'lieo' : 'lie', $_->{lie},
+ $_->{color} ? ($_->{color}, $_->{color} =~ /standout|grayedout/ ? 1 : 0) : ()),
+ style => sprintf('font-size: %dpx', $_->{rating}*3.5+6)
+ .(($_->{color}//'') =~ /^#/ ? "; color: $_->{color}" : ''),
+ $_->{name};
+ spoil_ $_->{spoiler};
+ small_ sprintf ' %.1f', $_->{rating};
+ }
+ }, $v->{tags}->@*;
+ }
+ }
+}
+
+
+# Also used by Chars::VNTab & Reviews::VNTab
+sub infobox_ {
+ my($v, $notags) = @_;
+
+ sub tlang_ {
+ my($t) = @_;
+ tr_ mkclass(title => 1, grayedout => !$t->{official}), sub {
+ td_ sub {
+ abbr_ class => "icon-lang-$t->{lang}", title => $LANGUAGE{$t->{lang}}{txt}, '';
+ };
+ td_ sub {
+ span_ tlang($t->{lang}, $t->{title}), $t->{title};
+ if($t->{latin}) {
+ br_;
+ txt_ $t->{latin};
+ }
+ }
+ }
+ }
+
+ article_ sub {
+ itemmsg_ $v;
+ h1_ tlang($v->{title}[0], $v->{title}[1]), $v->{title}[1];
+ h2_ class => 'alttitle', tlang(@{$v->{title}}[2,3]), $v->{title}[3] if $v->{title}[3] && $v->{title}[3] ne $v->{title}[1];
+
+ div_ class => 'warning', sub {
+ h2_ 'No releases';
+ p_ sub {
+ txt_ 'This entry does not have any releases associated with it yet. Please ';
+ a_ href => "/$v->{id}/add", 'add a release entry';
+ txt_ ' if you have information about this visual novel.';
+ br_;
+ txt_ '(A release entry should be present even if nothing has been
+ released yet, in that case it can just be a placeholder for a
+ future release)';
+ };
+ } if !$v->{hidden} && auth->permEdit && !$v->{releases}->@*;
+
+ p_ class => 'center standout', sub { lit_ config->{special_games}{$v->{id}}; br_; br_ } if config->{special_games}{$v->{id}};
+
+ div_ class => 'vndetails', sub {
+ div_ class => 'vnimg', sub { image_ $v->{image}, alt => $v->{title}[1]; };
+
+ table_ class => 'stripe', sub {
+ tr_ sub {
+ td_ 'Title';
+ td_ sub {
+ table_ sub { tlang_ $v->{titles}[0] };
+ };
+ } if $v->{titles}->@* == 1;
+ tr_ sub {
+ td_ class => 'titles', colspan => 2, sub {
+ details_ sub {
+ summary_ sub {
+ div_ 'Titles';
+ table_ sub { tlang_ grep $_->{lang} eq $v->{olang}, $v->{titles}->@* };
+ };
+ table_ sub {
+ tlang_ $_ for grep $_->{lang} ne $v->{olang}, sort { $b->{official} cmp $a->{official} || $a->{lang} cmp $b->{lang} } $v->{titles}->@*;
+ };
+ };
+ };
+ } if $v->{titles}->@* > 1;
+
+ tr_ sub {
+ td_ 'Aliases';
+ td_ $v->{alias} =~ s/\n/, /gr;
+ } if $v->{alias};
+
+ tr_ sub {
+ td_ 'Status';
+ td_ sub {
+ txt_ 'In development' if $v->{devstatus} == 1;
+ txt_ 'Unfinished, no ongoing development' if $v->{devstatus} == 2;
+ };
+ } if $v->{devstatus};
+
+ infobox_length_ $v;
+ infobox_producers_ $v;
+ infobox_relations_ $v;
+
+ tr_ sub {
+ td_ 'Links';
+ td_ sub { join_ ', ', sub { a_ href => $_->{url2}, $_->{label} }, $v->{extlinks}->@* };
+ } if $v->{extlinks}->@*;
+
+ infobox_affiliates_ $v;
+ infobox_anime_ $v;
+
+ tr_ class => 'nostripe', sub {
+ td_ colspan => 2, sub {
+ elm_ 'UList.VNPage', $VNWeb::ULists::Elm::WIDGET,
+ ulists_widget_full_data $v, auth->uid, 1, canvote $v;
+ }
+ } if auth;
+
+ tr_ class => 'nostripe', sub {
+ td_ class => 'vndesc', colspan => 2, sub {
+ h2_ 'Description';
+ p_ sub { lit_ $v->{description} ? bb_format $v->{description} : '-' };
+ debug_ $v;
+ }
+ }
+ }
+ };
+ div_ class => 'clearfloat', style => 'height: 5px', ''; # otherwise the tabs below aren't positioned correctly
+ infobox_tags_ $v if $v->{tags}->@* && !$notags;
+ }
+}
+
+
+# Also used by Chars::VNTab, Reviews::VNTab and VN::Quotes
+sub tabs_ {
+ my($v, $tab) = @_;
+ my $chars = tuwf->dbVali('SELECT COUNT(DISTINCT c.id) FROM chars c JOIN chars_vns cv ON cv.id = c.id WHERE NOT c.hidden AND cv.vid =', \$v->{id});
+ my $quotes = tuwf->dbVali('SELECT COUNT(*) FROM quotes WHERE NOT hidden AND vid =', \$v->{id});
+
+ $tab ||= '';
+ nav_ sub {
+ menu_ sub {
+ li_ class => ($tab eq '' ? ' tabselected' : ''), sub { a_ href => "/$v->{id}#main", name => 'main', 'main' };
+ li_ class => ($tab eq 'tags' ? ' tabselected' : ''), sub { a_ href => "/$v->{id}/tags#tags", name => 'tags', 'tags' };
+ li_ class => ($tab eq 'chars' ? ' tabselected' : ''), sub { a_ href => "/$v->{id}/chars#chars", name => 'chars', "characters ($chars)" } if $chars;
+ if($v->{reviews}{mini} > 4 || $tab eq 'minireviews' || $tab eq 'fullreviews') {
+ li_ class => ($tab eq 'minireviews'?' tabselected' : ''), sub { a_ href => "/$v->{id}/minireviews#review", name => 'review', "mini reviews ($v->{reviews}{mini})" } if $v->{reviews}{mini};
+ li_ class => ($tab eq 'fullreviews'?' tabselected' : ''), sub { a_ href => "/$v->{id}/fullreviews#review", name => 'review', "full reviews ($v->{reviews}{full})" } if $v->{reviews}{full};
+ } elsif($v->{reviews}{mini} || $v->{reviews}{full}) {
+ li_ class => ($tab =~ /reviews/ ?' tabselected':''), sub { a_ href => "/$v->{id}/reviews#review", name => 'review', sprintf 'reviews (%d)', $v->{reviews}{total} };
+ }
+ li_ class => ($tab eq 'quotes' ? ' tabselected' : ''), sub { a_ href => "/$v->{id}/quotes#quotes", name => 'quotes', "quotes ($quotes)" };
+ };
+ menu_ sub {
+ if(auth && canvote $v) {
+ my $id = tuwf->dbVali('SELECT id FROM reviews WHERE vid =', \$v->{id}, 'AND uid =', \auth->uid);
+ li_ sub { a_ href => "/$v->{id}/addreview", 'add review' } if !$id && can_edit w => {};
+ li_ sub { a_ href => "/$id/edit", 'edit review' } if $id;
+ }
+ if(auth->permEdit) {
+ li_ sub { a_ href => "/$v->{id}/add", 'add release' };
+ li_ sub { a_ href => "/$v->{id}/addchar", 'add character' };
+ }
+ };
+ }
+}
+
+
+sub releases_ {
+ my($v) = @_;
+
+ enrich_release $v->{releases};
+ $v->{releases} = sort_releases $v->{releases};
+
+ my(%lang, %langrel, %langmtl);
+ for my $r ($v->{releases}->@*) {
+ for ($r->{titles}->@*) {
+ push $lang{$_->{lang}}->@*, $r;
+ $langmtl{$_->{lang}} = ($langmtl{$_->{lang}}//1) && $_->{mtl};
+ }
+ }
+ $langrel{$_} = min map $_->{released}, $lang{$_}->@* for keys %lang;
+ my @lang = sort { $langrel{$a} <=> $langrel{$b} || ($b eq $v->{olang}) cmp ($a eq $v->{olang}) || $a cmp $b } keys %lang;
+ my $pref = prefs;
+
+ my sub lang_ {
+ my($lang) = @_;
+ my $ropt = { id => $lang, lang => $lang };
+ my $mtl = $langmtl{$lang};
+ my $open = ($pref->{vnrel_olang} && $lang eq $v->{olang} && !$mtl) || ($pref->{vnrel_langs}{$lang} && (!$mtl || $pref->{vnrel_mtl}));
+ details_ open => $open?'open':undef, sub {
+ summary_ $mtl ? (class => 'mtl') : (), sub {
+ abbr_ class => "icon-lang-$lang".($mtl?' mtl':''), title => $LANGUAGE{$lang}{txt}, '';
+ txt_ $LANGUAGE{$lang}{txt};
+ small_ sprintf ' (%d)', scalar $lang{$lang}->@*;
+ };
+ table_ class => 'releases', sub {
+ release_row_ $_, $ropt for $lang{$lang}->@*;
+ };
+ };
+ }
+
+ article_ class => 'vnreleases', sub {
+ h1_ 'Releases';
+ if(!$v->{releases}->@*) {
+ p_ 'We don\'t have any information about releases of this visual novel yet...';
+ } else {
+ lang_ $_ for @lang;
+ }
+ }
+}
+
+
+sub staff_cols_ {
+ my($lst) = @_;
+
+ # XXX: The staff listing is included in the page 3 times, for 3 different
+ # layouts. A better approach to get the same layout is to add the boxes to
+ # the HTML once with classes indicating the box position (e.g.
+ # "4col-col1-row1 3col-col2-row1" etc) and then using CSS to position the
+ # box appropriately. My attempts to do this have failed, however. The
+ # layouting can also be done in JS, but that's not my preferred option.
+
+ # Step 1: Get a list of 'boxes'; Each 'box' represents a role with a list of staff entries.
+ # @boxes = [ $height, $roleimp, $html ]
+ my %roles;
+ push $roles{$_->{role}}->@*, $_ for grep $_->{sid}, @$lst;
+ my $i=0;
+ my @boxes =
+ sort { $b->[0] <=> $a->[0] || $a->[1] <=> $b->[1] }
+ map [ 2+$roles{$_}->@*, $i++,
+ xml_string sub {
+ li_ class => 'vnstaff_head', $CREDIT_TYPE{$_};
+ li_ sub {
+ a_ href => "/$_->{sid}", tattr $_;
+ small_ $_->{note} if $_->{note};
+ } for sort { $a->{title}[1] cmp $b->{title}[1] } $roles{$_}->@*;
+ }
+ ], grep $roles{$_}, keys %CREDIT_TYPE;
+
+ # Step 2. Assign boxes to columns for 2 to 4 column layouts,
+ # efficiently packing the boxes to use the least vertical space,
+ # sorting the columns and boxes within columns by role importance.
+ # (There is no 1-column layout, that's just the 2-column layout stacked with css)
+ my @cols = map [map [0,99,[]], 1..$_], 2..4; # [ $height, $min_roleimp, $boxes ] for each column in each layout
+ for my $c (@cols) {
+ for (@boxes) {
+ my $smallest = $c->[0];
+ $c->[$_][0] < $smallest->[0] && ($smallest = $c->[$_]) for 1..$#$c;
+ $smallest->[0] += $_->[0];
+ $smallest->[1] = $_->[1] if $_->[1] < $smallest->[1];
+ push $smallest->[2]->@*, $_;
+ }
+ $_->[2] = [ sort { $a->[1] <=> $b->[1] } $_->[2]->@* ] for @$c;
+ @$c = sort { $a->[1] <=> $b->[1] } @$c;
+ }
+
+ div_ class => sprintf('vnstaff-%d', scalar @$_), sub {
+ ul_ sub {
+ lit_ $_->[2] for $_->[2]->@*;
+ } for @$_
+ } for @cols;
+}
+
+
+sub staff_ {
+ my($v) = @_;
+ return if !$v->{staff}->@*;
+
+ my %staff;
+ push $staff{ $_->{eid} // '' }->@*, $_ for $v->{staff}->@*;
+ my $pref = prefs;
+
+ article_ class => 'vnstaff', id => 'staff', sub {
+ h1_ 'Staff';
+ if (!$v->{editions}->@*) {
+ staff_cols_ $v->{staff};
+ return;
+ }
+ for my $e (undef, $v->{editions}->@*) {
+ my $lst = $staff{ $e ? $e->{eid} : '' };
+ next if !$lst;
+ my $lang = ($e && $e->{lang}) || $v->{olang};
+ my $unoff = $e && !$e->{official};
+ my $open = ($pref->{staffed_olang} && !$e) || ($pref->{staffed_langs}{$lang} && (!$unoff || $pref->{staffed_unoff}));
+ details_ open => $open?'open':undef, sub {
+ summary_ sub {
+ abbr_ class => "icon-lang-$e->{lang}", title => $LANGUAGE{$e->{lang}}{txt}, '' if $e && $e->{lang};
+ txt_ 'Original edition' if !$e;
+ txt_ $e->{name} if $e;
+ small_ ' (unofficial)' if $unoff;
+ };
+ staff_cols_ $lst;
+ };
+ }
+ };
+}
+
+
+sub charsum_ {
+ my($v) = @_;
+
+ my $spoil = viewget->{spoilers};
+ my $c = tuwf->dbAlli('
+ SELECT c.id, c.title, c.gender, v.role
+ FROM', charst, 'c
+ JOIN (SELECT id, MIN(role) FROM chars_vns WHERE role <> \'appears\' AND spoil <=', \$spoil, 'AND vid =', \$v->{id}, 'GROUP BY id) v(id,role) ON c.id = v.id
+ WHERE NOT c.hidden
+ ORDER BY v.role, c.name, c.id'
+ );
+ return if !@$c;
+ enrich seiyuu => id => cid => sub { sql('
+ SELECT vs.cid, sa.id, sa.title, vs.note
+ FROM vn_seiyuu vs
+ JOIN', staff_aliast, 'sa ON sa.aid = vs.aid
+ WHERE vs.id =', \$v->{id}, 'AND vs.cid IN', $_, '
+ ORDER BY sa.sorttitle'
+ ) }, $c;
+
+ article_ 'data-mainbox-summarize' => 210, sub {
+ p_ class => 'mainopts', sub {
+ a_ href => "/$v->{id}/chars#chars", 'Full character list';
+ };
+ h1_ 'Character summary';
+ div_ class => 'charsum_list', sub {
+ div_ class => 'charsum_bubble', sub {
+ div_ class => 'name', sub {
+ span_ sub {
+ abbr_ class => "icon-gen-$_->{gender}", title => $GENDER{$_->{gender}}, '' if $_->{gender} ne 'unknown';
+ a_ href => "/$_->{id}", tattr $_;
+ };
+ em_ $CHAR_ROLE{$_->{role}}{txt};
+ };
+ div_ class => 'actor', sub {
+ txt_ 'Voiced by';
+ $_->{seiyuu}->@* > 1 ? br_ : txt_ ' ';
+ join_ \&br_, sub {
+ a_ href => "/$_->{id}", tattr $_;
+ small_ $_->{note} if $_->{note};
+ }, $_->{seiyuu}->@*;
+ } if $_->{seiyuu}->@*;
+ } for @$c;
+ };
+ };
+}
+
+
+sub stats_ {
+ my($v) = @_;
+
+ my $stats = tuwf->dbAlli('
+ SELECT (uv.vote::numeric/10)::int AS idx, COUNT(uv.vote) as votes, SUM(uv.vote) AS total
+ FROM ulist_vns uv
+ WHERE uv.vote IS NOT NULL
+ AND NOT EXISTS(SELECT 1 FROM users u WHERE u.id = uv.uid AND u.ign_votes)
+ AND uv.vid =', \$v->{id}, '
+ GROUP BY (uv.vote::numeric/10)::int'
+ );
+ my $sum = sum map $_->{total}, @$stats;
+ my $max = max map $_->{votes}, @$stats;
+ my $num = sum map $_->{votes}, @$stats;
+
+ my $recent = @$stats && tuwf->dbAlli('
+ SELECT uv.vote, uv.c_private,', sql_totime('uv.vote_date'), 'as date, ', sql_user(), '
+ FROM ulist_vns uv
+ JOIN users u ON u.id = uv.uid
+ WHERE uv.vid =', \$v->{id}, 'AND uv.vote IS NOT NULL
+ AND NOT EXISTS(SELECT 1 FROM users u WHERE u.id = uv.uid AND u.ign_votes)
+ ORDER BY uv.vote_date DESC
+ LIMIT', \($v->{reviews}{total} ? 7 : 8)
+ );
+
+ my $rank = $v->{c_votecount} && tuwf->dbRowi('SELECT c_average, c_rating, c_pop_rank, c_rat_rank FROM vn v WHERE id =', \$v->{id});
+
+ my sub votestats_ {
+ table_ class => 'votegraph', sub {
+ thead_ sub { tr_ sub { td_ colspan => 2, 'Vote stats' } };
+ tfoot_ sub { tr_ sub { td_ colspan => 2, sub {
+ txt_ sprintf '%d vote%s%s', $num, $num == 1 ? '' : 's', $rank && $rank->{c_pop_rank} ? sprintf ' (rank %d)', $rank->{c_pop_rank} : '';
+ br_;
+ txt_ sprintf '%.02f average (%s%s)', $sum/$num/10,
+ $rank && $rank->{c_rating} && $rank->{c_rating} != $rank->{c_average} ? sprintf '%.02f weighted, ', $rank->{c_rating}/100 : '',
+ $rank && $rank->{c_rat_rank} ? sprintf('rank %d', $rank->{c_rat_rank}) : 'unranked';
+ } } };
+ tr_ sub {
+ my $num = $_;
+ my $votes = [grep $num == $_->{idx}, @$stats]->[0]{votes} || 0;
+ td_ class => 'number', $num;
+ td_ class => 'graph', sub {
+ div_ style => sprintf('width: %dpx', ($votes||0)/$max*250), ' ';
+ txt_ $votes||0;
+ };
+ } for (reverse 1..10);
+ };
+
+ table_ class => 'recentvotes stripe', sub {
+ thead_ sub { tr_ sub { td_ colspan => 3, sub {
+ txt_ 'Recent votes';
+ span_ sub {
+ txt_ '(';
+ a_ href => "/$v->{id}/votes", 'show all';
+ txt_ ')';
+ }
+ } } };
+ tfoot_ sub { tr_ sub { td_ colspan => 3, sub {
+ a_ href => "/$v->{id}/reviews#review", sprintf'%d review%s »', $v->{reviews}{total}, $v->{reviews}{total}==1?'':'s';
+ } } } if $v->{reviews}{total};
+ tr_ sub {
+ td_ sub {
+ small_ 'hidden' if $_->{c_private};
+ user_ $_ if !$_->{c_private};
+ };
+ td_ fmtvote $_->{vote};
+ td_ fmtdate $_->{date};
+ } for @$recent;
+ } if $recent && @$recent;
+ clearfloat_;
+ }
+
+ article_ id => 'stats', sub {
+ h1_ 'User stats';
+ if(!@$stats) {
+ p_ 'Nobody has voted on this visual novel yet...';
+ } else {
+ div_ class => 'votestats', \&votestats_;
+ }
+ }
+}
+
+
+sub screenshots_ {
+ my($v) = @_;
+ my $s = $v->{screenshots};
+ return if !@$s;
+
+ my $sexp = auth->pref('max_sexual')||0;
+ my $viop = auth->pref('max_violence')||0;
+ $viop = 0 if $sexp < 0;
+ my $sexs = min($sexp, max map $_->{scr}{sexual}, @$s);
+ my $vios = min($viop, max map $_->{scr}{violence}, @$s);
+
+ my @sex = (0,0,0);
+ my @vio = (0,0,0);
+ for (@$s) { $sex[$_->{scr}{sexual}]++; $vio[$_->{scr}{violence}]++ }
+
+ my %rel;
+ push $rel{$_->{rid}}->@*, $_ for grep $_->{rid}, @$s;
+
+ input_ name => 'scrhide_s', id => "scrhide_s$_", type => 'radio', class => 'hidden', $sexs == $_ ? (checked => 'checked') : () for 0..2;
+ input_ name => 'scrhide_v', id => "scrhide_v$_", type => 'radio', class => 'hidden', $vios == $_ ? (checked => 'checked') : () for 0..2;
+ article_ id => 'screenshots', sub {
+
+ p_ class => 'mainopts', sub {
+ if($sexp < 0 || $sex[1] || $sex[2]) {
+ label_ for => 'scrhide_s0', class => 'fake_link', "Safe ($sex[0])";
+ label_ for => 'scrhide_s1', class => 'fake_link', "Suggestive ($sex[1])" if $sex[1];
+ label_ for => 'scrhide_s2', class => 'fake_link', "Explicit ($sex[2])" if $sex[2];
+ }
+ small_ ' | ' if ($sexp < 0 || $sex[1] || $sex[2]) && ($vio[1] || $vio[2]);
+ if($vio[1] || $vio[2]) {
+ label_ for => 'scrhide_v0', class => 'fake_link', "Tame ($vio[0])";
+ label_ for => 'scrhide_v1', class => 'fake_link', "Violent ($vio[1])" if $vio[1];
+ label_ for => 'scrhide_v2', class => 'fake_link', "Brutal ($vio[2])" if $vio[2];
+ }
+ } if $sexp < 0 || $sex[1] || $sex[2] || $vio[1] || $vio[2];
+
+ h1_ 'Screenshots';
+
+ for my $r (grep $rel{$_->{id}}, $v->{releases}->@*) {
+ p_ class => 'rel', sub {
+ abbr_ class => "icon-lang-$_->{lang}", title => $LANGUAGE{$_->{lang}}{txt}, '' for $r->{titles}->@*;
+ platform_ $_ for $r->{platforms}->@*;
+ a_ href => "/$r->{id}", tattr $r;
+ };
+ div_ class => 'scr', sub {
+ a_ href => imgurl($_->{scr}{id}),
+ 'data-iv' => "$_->{scr}{width}x$_->{scr}{height}:scr:$_->{scr}{sexual}$_->{scr}{violence}$_->{scr}{votecount}",
+ mkclass(
+ scrlnk => 1,
+ scrlnk_s0 => $_->{scr}{sexual} <= 0,
+ scrlnk_s1 => $_->{scr}{sexual} <= 1,
+ scrlnk_v0 => $_->{scr}{violence} >= 1,
+ scrlnk_v1 => $_->{scr}{violence} >= 2,
+ nsfw => $_->{scr}{sexual} || $_->{scr}{violence},
+ ),
+ sub {
+ my($w, $h) = imgsize $_->{scr}{width}, $_->{scr}{height}, config->{scr_size}->@*;
+ img_ src => imgurl($_->{scr}{id}, 't'), width => $w, height => $h, alt => "Screenshot $_->{scr}{id}";
+ } for $rel{$r->{id}}->@*;
+ }
+ }
+ }
+}
+
+
+sub tags_ {
+ my($v) = @_;
+ if(!$v->{tags}->@*) {
+ article_ sub {
+ h1_ 'Tags';
+ p_ 'This VN has no tags assigned to it (yet).';
+ };
+ return;
+ }
+
+ my %tags = map +($_->{id},$_), $v->{tags}->@*;
+ my $parents = tuwf->dbAlli("
+ WITH RECURSIVE parents (tag, child) AS (
+ SELECT tag::vndbid, NULL::vndbid FROM (VALUES", sql_join(',', map sql('(',\$_,')'), keys %tags), ") AS x(tag)
+ UNION
+ SELECT tp.parent, tp.id FROM tags_parents tp, parents a WHERE a.tag = tp.id AND tp.main
+ ) SELECT * FROM parents WHERE child IS NOT NULL"
+ );
+
+ for(@$parents) {
+ $tags{$_->{tag}} ||= { id => $_->{tag} };
+ push $tags{$_->{tag}}{childs}->@*, $_->{child};
+ $tags{$_->{child}}{notroot} = 1;
+ }
+ enrich_merge id => 'SELECT id, name, cat FROM tags WHERE id IN', grep !$_->{name}, values %tags;
+ my @roots = sort { $a->{name} cmp $b->{name} } grep !$_->{notroot}, values %tags;
+
+ # Calculate rating and spoiler for parent tags.
+ my sub scores {
+ my($t) = @_;
+ return if !$t->{childs};
+ __SUB__->($tags{$_}) for $t->{childs}->@*;
+ $t->{inherited} = 1 if !defined $t->{rating};
+ $t->{spoiler} //= min map $tags{$_}{spoiler}, $t->{childs}->@*;
+ $t->{override} //= min map $tags{$_}{override}//$tags{$_}{spoiler}, $t->{childs}->@* if grep defined($tags{$_}{override}), $t->{childs}->@*;
+ $t->{rating} //= sum(map $tags{$_}{rating}, $t->{childs}->@*) / $t->{childs}->@*;
+ }
+ scores $_ for @roots;
+
+ my $view = viewget;
+ my sub rec {
+ my($lvl, $t) = @_;
+ return if ($t->{override}//$t->{spoiler}) > $view->{spoilers};
+ li_ class => "tagvnlist-top", sub {
+ h3_ sub { a_ href => "/$t->{id}", $t->{name} }
+ } if !$lvl;
+
+ li_ $lvl == 1 ? (class => 'tagvnlist-parent') : $t->{inherited} ? (class => 'tagvnlist-inherited') : (), sub {
+ VNWeb::TT::Lib::tagscore_($t->{rating}, $t->{inherited});
+ small_ '━━'x($lvl-1).' ' if $lvl > 1;
+ a_ href => "/$t->{id}", mkclass(
+ $t->{color} ? ($t->{color}, $t->{color} =~ /standout|grayedout/ ? 1 : 0) : (),
+ lie => $t->{lie} && ($view->{spoilers} > 1 || defined $t->{override}),
+ parent => !$t->{rating}
+ ), ($t->{color}//'') =~ /^#/ ? (style => "color: $t->{color}") : (),
+ $t->{name};
+ spoil_ $t->{spoiler};
+ a_ href => "/g/links?v=$v->{id}&t=$t->{id}", class => 'grayedout', " ($t->{count})" if $t->{count};
+ } if $lvl;
+
+ if($t->{childs}) {
+ __SUB__->($lvl+1, $_) for sort { $a->{name} cmp $b->{name} } map $tags{$_}, $t->{childs}->@*;
+ }
+ }
+
+ article_ sub {
+ my $max_spoil = max map $_->{lie}?2:$_->{spoiler}, values %tags;
+ p_ class => 'mainopts', sub {
+ if($max_spoil) {
+ a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0).'#tags', 'Hide spoilers';
+ a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1).'#tags', 'Show minor spoilers';
+ a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2).'#tags', 'Spoil me!' if $max_spoil == 2;
+ }
+ } if $max_spoil;
+
+ h1_ 'Tags';
+ ul_ class => 'vntaglist', sub {
+ rec 0, $_ for @roots;
+ };
+ debug_ \%tags;
+ };
+}
+
+
+TUWF::get qr{/$RE{vrev}}, sub {
+ my $v = db_entry tuwf->captures('id', 'rev');
+ return tuwf->resNotFound if !$v;
+
+ enrich_item $v, 1;
+
+ framework_ title => $v->{title}[1], index => !tuwf->capture('rev'), dbobj => $v, hiddenmsg => 1, js => 1, og => og($v),
+ sub {
+ rev_ $v if tuwf->capture('rev');
+ infobox_ $v;
+ tabs_ $v, 0;
+ releases_ $v;
+ staff_ $v;
+ charsum_ $v;
+ stats_ $v;
+ screenshots_ $v;
+ };
+};
+
+
+TUWF::get qr{/$RE{vid}/tags}, sub {
+ my $v = db_entry tuwf->capture('id');
+ return tuwf->resNotFound if !$v;
+
+ enrich_vn $v;
+
+ framework_ title => $v->{title}[1], index => 1, dbobj => $v, hiddenmsg => 1,
+ sub {
+ infobox_ $v, 1;
+ tabs_ $v, 'tags';
+ tags_ $v;
+ };
+};
+
+1;
diff --git a/lib/VNWeb/VN/Quotes.pm b/lib/VNWeb/VN/Quotes.pm
new file mode 100644
index 00000000..4edd1aaa
--- /dev/null
+++ b/lib/VNWeb/VN/Quotes.pm
@@ -0,0 +1,399 @@
+package VNWeb::VN::Quotes;
+
+use VNWeb::Prelude;
+
+sub deletable {
+ my($q) = @_;
+ !$q->{hidden} && $q->{addedby} && auth && $q->{addedby} eq auth->uid && auth->permEdit && $q->{added} > time()-5*24*3600;
+}
+
+sub editable {
+ auth->permDbmod || deletable @_;
+}
+
+sub submittable {
+ my($vid) = @_;
+ auth->permDbmod || (auth->permEdit && tuwf->dbVali(q{SELECT COUNT(*) FROM quotes WHERE added > NOW() - '1 day'::interval AND addedby =}, \auth->uid) < 5);
+}
+
+# Also used by Chars::Page
+sub votething_ {
+ my($q) = @_;
+ if (auth) {
+ $q->{id} *= 1;
+ span_ class => 'quote-score', widget(QuoteVote => [@{$q}{qw/id score vote/}, $_->{hidden} ? \1 : \0, editable($q) ? \1 : \0]), '';
+ } else {
+ span_ $q->{score};
+ }
+}
+
+TUWF::get qr{/$RE{vid}/quotes}, sub {
+ my $v = db_entry tuwf->capture('id');
+ return tuwf->resNotFound if !$v->{id} || $v->{entry_hidden};
+ VNWeb::VN::Page::enrich_vn($v);
+
+ my $lst = tuwf->dbAlli('
+ SELECT q.id, q.score, q.quote,', sql_totime('q.added'), 'AS added, q.addedby, q.cid, c.title, v.spoil
+ FROM quotes q
+ LEFT JOIN', charst, 'c ON c.id = q.cid
+ LEFT JOIN (SELECT id, MIN(spoil) FROM chars_vns WHERE vid =', \$v->{id}, 'GROUP BY id) v(id,spoil) ON c.id = v.id
+ WHERE NOT q.hidden
+ AND vid =', \$v->{id}, '
+ ORDER BY q.score DESC, q.quote
+ ');
+ enrich_merge id => sql('SELECT id, vote FROM quotes_votes WHERE uid =', \auth->uid, 'AND id IN'), $lst if auth;
+
+ my $view = viewget;
+ my $max_spoil = max 0, grep $_, map $_->{spoil}, @$lst;
+
+ framework_ title => "Quotes for $v->{title}[1]", dbobj => $v, hiddenmsg => 1, sub {
+ VNWeb::VN::Page::infobox_($v);
+ VNWeb::VN::Page::tabs_($v, 'quotes');
+ article_ sub {
+ h1_ "Quotes";
+ p_ submittable($v->{id}) ? sub {
+ txt_ 'No quotes yet, maybe ';
+ a_ href => "/$v->{id}/addquote", 'submit a quote yourself';
+ txt_ '?';
+ } : sub {
+ txt_ 'No quotes yet.';
+ };
+ } if !@$lst;
+ article_ sub {
+ p_ class => 'mainopts', sub {
+ if ($max_spoil) {
+ a_ mkclass(checked => $view->{spoilers} == 0), href => '?view='.viewset(spoilers=>0).'#quotes', 'Hide spoilers';
+ a_ mkclass(checked => $view->{spoilers} == 1), href => '?view='.viewset(spoilers=>1).'#quotes', 'Show minor spoilers';
+ a_ mkclass(standout =>$view->{spoilers} == 2), href => '?view='.viewset(spoilers=>2).'#quotes', 'Spoil me!' if $max_spoil == 2;
+ small_ ' | ';
+ }
+ if (auth->permDbmod) {
+ a_ href => "/v/quotes?v=$v->{id}", 'details';
+ small_ ' | ';
+ }
+ a_ href => "/$v->{id}/addquote", 'submit a quote';
+ } if submittable($v->{id});
+ h1_ "Quotes";
+ table_ sub {
+ tr_ sub {
+ td_ sub { votething_ $_ };
+ td_ sub {
+ if ($_->{cid} && ($_->{spoil}||0) <= $view->{spoilers}) {
+ small_ '[';
+ a_ href => "/$_->{cid}", tattr $_;
+ small_ '] ';
+ }
+ txt_ $_->{quote};
+ };
+ } for @$lst;
+ };
+ p_ sub {
+ small_ 'Vote to like/dislike a quote, typos and other errors should be reported on the forums.';
+ } if auth;
+ } if @$lst;
+ };
+};
+
+
+sub listing_ {
+ my($lst, $count, $opt, $url) = @_;
+ paginate_ $url, $opt->{p}, [$count, 50], 't';
+ article_ class => 'browse quotes', sub {
+ table_ class => 'stripe', sub {
+ tr_ sub {
+ td_ class => 'tc1', sub { votething_ $_ };
+ td_ class => 'tc2', sub { txt_ fmtdate $_->{added}, 'full' };
+ td_ class => 'tc3', sub {
+ a_ href => $url->(u => $_->{addedby}, p=>undef), class => 'setfil', '> ' if $_->{addedby} && !defined $opt->{u};
+ user_ $_;
+ };
+ td_ sub {
+ a_ href => $url->(v => $_->{vid}, p=>undef), class => 'setfil', '> ' if !defined $opt->{v};
+ a_ href => "/$_->{vid}/quotes#quotes", tattr $_;
+ br_;
+ if ($_->{cid}) {
+ small_ '[';
+ a_ href => "/$_->{cid}", tattr $_->{char};
+ small_ '] ';
+ }
+ txt_ $_->{quote};
+ };
+ } for @$lst;
+ };
+ };
+ paginate_ $url, $opt->{p}, [$count, 50], 'b';
+}
+
+sub opts_ {
+ my($opt) = @_;
+
+ my sub obj_ {
+ my($key, $label) = @_;
+ my $v = $opt->{$key} // return;
+ my $o = dbobj $v;
+ tr_ sub {
+ td_ "$label:";
+ td_ sub {
+ input_ type => 'checkbox', name => $key, value => $v, checked => 'checked';
+ lit_ ' ';
+ a_ href => "/$v", $o && $o->{id} && $o->{title}[1] ? tattr $o : $v;
+ };
+ };
+ }
+
+ my sub opt_ {
+ my($key, $val, $label) = @_;
+ label_ sub {
+ lit_ ' ';
+ input_ type => 'radio', name => $key, value => $val//'',
+ checked => ($opt->{$key}//'undef') eq ($val//'undef') ? 'checked' : undef;
+ lit_ ' ';
+ txt_ $label;
+ };
+ };
+
+ form_ sub {
+ table_ style => 'margin: auto', sub {
+ obj_ v => 'VN';
+ obj_ u => 'User';
+ tr_ sub {
+ td_ 'State:';
+ td_ sub {
+ opt_ h => undef, 'any';
+ opt_ h => 0 => 'Visible';
+ opt_ h => 1 => 'Deleted';
+ };
+ } if auth->permDbmod;
+ tr_ sub {
+ td_ 'Has char:';
+ td_ sub {
+ opt_ c => undef, 'any';
+ opt_ c => 0, 'no';
+ opt_ c => 1, 'yes';
+ };
+ };
+ tr_ sub {
+ td_ 'Order by:';
+ td_ sub {
+ opt_ s => added => 'date added';
+ opt_ s => lastmod => 'last modified';
+ opt_ s => top => 'highest score';
+ opt_ s => bottom => 'lowest score';
+ };
+ };
+ tr_ sub {
+ td_ '';
+ td_ sub { input_ type => 'submit', class => 'submit', value => 'Update' };
+ }
+ };
+ };
+}
+
+TUWF::get '/v/quotes', sub {
+ return tuwf->resDenied if !auth;
+ my $opt = tuwf->validate(get =>
+ v => { default => undef, vndbid => 'v' },
+ u => { default => undef, vndbid => 'u' },
+ h => { undefbool => 1 },
+ c => { undefbool => 1 },
+ s => { default => 'added', enum => [qw/added lastmod top bottom/] },
+ p => { upage => 1 },
+ )->data;
+ $opt->{h} = 0 if !auth->permDbmod;
+
+ my $u = $opt->{u} && tuwf->dbRowi('SELECT id,', sql_user(), 'FROM users u WHERE id =', \$opt->{u});
+ return tuwf->resNotFound if $opt->{u} && (!$u->{id} || (!defined $u->{user_name} && !auth->isMod));
+
+ my $where = sql_and
+ $opt->{v} ? sql('q.vid =', \$opt->{v}) : (),
+ $opt->{u} ? sql('q.addedby =', \$opt->{u}) : (),
+ defined $opt->{h} ? sql($opt->{h} ? '' : 'NOT', 'q.hidden') : (),
+ defined $opt->{c} ? sql('q.cid', $opt->{c} ? 'IS NOT NULL' : 'IS NULL') : ();
+
+ my $count = tuwf->dbVali('SELECT COUNT(*) FROM quotes q WHERE', $where);
+ my $lst = !$count ? [] : tuwf->dbPagei({ results => 50, page => $opt->{p} }, '
+ SELECT q.id, q.hidden, q.score, q.quote, q.addedby, q.vid, q.cid
+ , v.title, c.title AS char,', sql_user(), '
+ , ', sql_totime('q.added'), 'added
+ FROM quotes q
+ JOIN', vnt, 'v ON v.id = q.vid
+ LEFT JOIN', charst, 'c ON c.id = q.cid
+ LEFT JOIN users u ON u.id = q.addedby
+ ', $opt->{s} eq 'lastmod' ? 'LEFT JOIN (
+ SELECT id, MAX(date) FROM quotes_log GROUP BY id
+ ) l (id, latest) ON l.id = q.id' : (), '
+ WHERE', $where, '
+ ORDER BY ', {
+ added => 'q.id DESC',
+ lastmod => 'l.latest DESC, q.id DESC',
+ top => 'q.score DESC, q.id',
+ bottom => 'q.score, q.id',
+ }->{$opt->{s}}
+ );
+ enrich_merge id => sql('SELECT id, vote FROM quotes_votes WHERE uid =', \auth->uid, 'AND id IN'), $lst if auth;
+
+ my sub url { '?'.query_encode %$opt, @_ }
+
+ framework_ title => 'Quotes browser', sub {
+ article_ sub {
+ h1_ 'Quotes browser';
+ opts_ $opt;
+ };
+ listing_ $lst, $count, $opt, \&url if @$lst;
+ };
+};
+
+
+my $FORM = {
+ id => { uint => 1, default => undef },
+ vid => { vndbid => 'v' },
+ hidden => { anybool => 1 },
+ quote => { sl => 1, maxlength => 170 },
+ cid => { vndbid => 'c', default => undef },
+ title => { _when => 'out' },
+ alttitle => { _when => 'out' },
+ chars => { _when => 'out', aoh => {
+ id => { vndbid => 'c' },
+ title => {},
+ alttitle => {},
+ } },
+ delete => { anybool => 1 },
+};
+
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_OUT = form_compile out => $FORM;
+
+TUWF::get qr{/(?:$RE{vid}/addquote|editquote/$RE{num})}, sub {
+ my($vid, $qid) = tuwf->captures('id', 'num');
+
+ my $q = $qid && tuwf->dbRowi('
+ SELECT q.id, q.vid, q.hidden, q.quote,', sql_totime('q.added'), 'added, q.addedby, q.cid, c.title
+ FROM quotes q
+ LEFT JOIN', charst, 'c ON c.id = q.cid
+ WHERE q.id = ', \$qid
+ );
+ return tuwf->resNotFound if $qid && !$q->{id};
+ $vid ||= $q->{vid};
+
+ my $v = $vid && dbobj $vid;
+ return tuwf->resNotFound if $vid && (!$v->{id} || $v->{entry_hidden});
+ return tuwf->resDenied if $qid ? !editable $q : !submittable $vid;
+
+ my $log = $qid && tuwf->dbAlli('
+ SELECT ', sql_totime('q.date'), 'date, q.action,', sql_user(), '
+ FROM quotes_log q
+ LEFT JOIN users u ON u.id = q.uid
+ WHERE q.id = ', \$qid, '
+ ORDER BY q.date DESC
+ ');
+
+ my $chars = tuwf->dbAlli('
+ SELECT id, title[1+1] AS title, title[1+1+1+1] AS alttitle
+ FROM ', charst, '
+ WHERE NOT hidden AND id IN(SELECT id FROM chars_vns WHERE vid =', \$v->{id}, ')
+ ORDER BY sorttitle, id
+ ');
+
+ my $title = ($qid ? 'Edit' : 'Add')." quote for $v->{title}[1]";
+ framework_ title => $title, dbobj => $v, sub {
+ article_ sub {
+ h1_ $title;
+ h2_ 'Some rules:';
+ ul_ sub {
+ li_ 'Quotes must be in English. You may use your own translation.';
+ li_ 'Quotes should be interesting, funny and/or insightful out of context.';
+ li_ 'Quotes must come from an actual release of the visual novel.';
+ li_ 'Quotes may not contain spoilers.';
+ li_ 'At most 170 characters per quote, but shorter quotes are preferred.';
+ li_ 'You may submit at most 5 quotes per day.';
+ li_ "This quotes feature is more of a silly gimmick than a proper database feature, keep your expectations low.";
+ };
+ br_;
+ div_ widget(QuoteEdit => $FORM_OUT, { $qid ? (
+ id => $q->{id}, hidden => $q->{hidden}, quote => $q->{quote},
+ cid => $q->{cid}, title => $q->{title}[1], alttitle => $q->{title}[3],
+ ) : elm_empty($FORM_OUT)->%*, chars => $chars, vid => $vid, delete => deletable($q) }), '';
+ };
+ if ($log && @$log) {
+ nav_ sub {
+ h1_ 'Log';
+ };
+ article_ class => 'browse', sub {
+ table_ class => 'stripe', sub {
+ thead_ sub { tr_ sub {
+ td_ class => 'tc1', 'Date';
+ td_ 'User';
+ td_ 'Action';
+ } };
+ tr_ sub {
+ td_ class => 'tc1', fmtdate $_->{date}, 'full';
+ td_ sub { user_ $_; };
+ td_ sub {
+ lit_ bb_format $_->{action}, inline => 1;
+ };
+ } for @$log;
+ };
+ };
+ }
+ };
+};
+
+js_api QuoteEdit => $FORM_IN, sub {
+ my($data) = @_;
+
+ my $v = dbobj $data->{vid};
+ return tuwf->resNotFound if !$v->{id} || $v->{entry_hidden};
+
+ my $q = $data->{id} && tuwf->dbRowi('SELECT id, hidden, quote,', sql_totime('added'), 'added, addedby, cid FROM quotes WHERE id = ', \$data->{id});
+ return tuwf->resDenied if $data->{id} && (!$q->{id} || !editable $q);
+
+ if ($data->{id}) {
+ my %set = (
+ !$data->{hidden} ne !$q->{hidden} ? (hidden => $data->{hidden}) : (),
+ $data->{quote} ne $q->{quote} ? (quote => $data->{quote}) : (),
+ ($data->{cid}//'') ne ($q->{cid}//'') ? (cid => $data->{cid}) : (),
+ );
+ tuwf->dbExeci('UPDATE quotes SET', \%set, 'WHERE id =', \$data->{id}) if keys %set;
+ tuwf->dbExeci('INSERT INTO quotes_log', {
+ id => $data->{id}, uid => auth->uid,
+ action => join '; ',
+ exists $set{hidden} ? "State: ".($q->{hidden}?"Deleted":"New")." -> ".($data->{hidden}?"Deleted":"New") : (),
+ exists $set{cid} ? "Character: ".($q->{cid}||'empty')." -> ".($data->{cid}||'empty') : (),
+ exists $set{quote} ? "Quote: \"[i][raw]$q->{quote} [/raw][/i]\" -> \"[i][raw]$data->{quote} [/raw][/i]\"" : (),
+ }) if keys %set;
+
+ } else {
+ return 'You have already submitted 5 quotes today, try again tomorrow.' if !submittable($data->{vid});
+ my sub norm { sql 'lower(regexp_replace(', $_[0], q{, '[\s",.]+', '', 'g'))} }
+ return 'This quote has already been submitted.'
+ if tuwf->dbVali('SELECT 1 FROM quotes WHERE vid =', \$data->{vid}, 'AND', norm(\$data->{quote}), '=', norm('quote'));
+
+ my $id = tuwf->dbVali('INSERT INTO quotes', {
+ vid => $v->{id},
+ cid => $data->{cid},
+ addedby => auth->uid,
+ quote => $data->{quote},
+ auth->permDbmod ? (hidden => $data->{hidden}) : (),
+ }, 'RETURNING id');
+ tuwf->dbExeci('INSERT INTO quotes_votes', {id => $id, uid => auth->uid, vote => 1});
+ tuwf->dbExeci('INSERT INTO quotes_log', {id => $id, uid => auth->uid, action => 'Submitted'});
+ }
+ +{}
+};
+
+js_api QuoteDel => { id => { uint => 1 } }, sub {
+ my $q = tuwf->dbRowi('SELECT id, hidden,', sql_totime('added'), 'added, addedby FROM quotes WHERE id = ', \$_[0]{id});
+ return tuwf->resDenied if !$q->{id} || !deletable $q;
+ tuwf->dbExeci('DELETE FROM quotes WHERE id =', \$q->{id});
+ +{}
+};
+
+js_api QuoteVote => { id => { uint => 1 }, vote => { default => undef, enum => [-1,1] } }, sub {
+ my($data) = @_;
+ tuwf->dbExeci('DELETE FROM quotes_votes WHERE', { uid => auth->uid, id => $data->{id} }) if !$data->{vote};
+ $data->{uid} = auth->uid;
+ tuwf->dbExeci('INSERT INTO quotes_votes', $data, 'ON CONFLICT (id, uid) DO UPDATE SET vote =', \$data->{vote}) if $data->{vote};
+ +{}
+};
+
+1;
diff --git a/lib/VNWeb/VN/Tagmod.pm b/lib/VNWeb/VN/Tagmod.pm
index c5453ef1..367d95f0 100644
--- a/lib/VNWeb/VN/Tagmod.pm
+++ b/lib/VNWeb/VN/Tagmod.pm
@@ -1,25 +1,29 @@
package VNWeb::VN::Tagmod;
use VNWeb::Prelude;
-use VNWeb::Tags::Lib;
my $FORM = {
- id => { id => 1 },
+ id => { vndbid => 'v' },
title => { _when => 'out' },
tags => { sort_keys => 'id', aoh => {
- id => { id => 1 },
+ id => { vndbid => 'g' },
vote => { int => 1, enum => [ -3..3 ] },
- spoil => { required => 0, uint => 1, enum => [ 0..2 ] },
+ spoil => { default => undef, uint => 1, enum => [ 0..2 ] },
+ lie => { undefbool => 1 },
overrule => { anybool => 1 },
- notes => { required => 0, default => '', maxlength => 1000 },
+ notes => { default => '', sl => 1, maxlength => 1000 },
cat => { _when => 'out' },
name => { _when => 'out' },
rating => { _when => 'out', num => 1 },
count => { _when => 'out', uint => 1 },
spoiler => { _when => 'out', num => 1 },
+ islie => { _when => 'out', anybool => 1 },
overruled => { _when => 'out', anybool => 1 },
othnotes => { _when => 'out' },
+ hidden => { _when => 'out', anybool => 1 },
+ locked => { _when => 'out', anybool => 1 },
+ applicable => { _when => 'out', anybool => 1 },
} },
mod => { _when => 'out', anybool => 1 },
};
@@ -27,15 +31,24 @@ my $FORM = {
my $FORM_IN = form_compile in => $FORM;
my $FORM_OUT = form_compile out => $FORM;
+
+sub can_tag { auth->permTagmod || (auth->permTag && !global_settings->{lockdown_edit}) }
+
+
elm_api Tagmod => $FORM_OUT, $FORM_IN, sub {
my($id, $tags) = $_[0]->@{'id', 'tags'};
- return elm_Unauth if !auth->permTag;
+ return elm_Unauth if !can_tag;
$tags = [ grep $_->{vote}, @$tags ];
$_->{overrule} = 0 for auth->permTagmod ? () : @$tags;
- # Weed out invalid/deleted/non-applicable tags
- enrich_merge id => 'SELECT id, 1 as exists FROM tags WHERE state <> 1 AND applicable AND id IN', $tags;
+ # Weed out invalid/deleted/non-applicable tags.
+ # Voting on non-applicable tags is still allowed if there are existing votes for this tag on this VN.
+ enrich_merge id => sql('
+ SELECT tag AS id, 1 as exists FROM tags_vn WHERE vid =', \$id, '
+ UNION
+ SELECT id, 1 as exists FROM tags WHERE NOT (hidden AND locked) AND applicable AND id IN'
+ ), $tags;
$tags = [ grep $_->{exists}, @$tags ];
# Find out if any of these tags are being overruled
@@ -46,9 +59,11 @@ elm_api Tagmod => $FORM_OUT, $FORM_IN, sub {
# Add & update tags
for(@$tags) {
- my $row = { uid => auth->uid, vid => $id, tag => $_->{id}, vote => $_->{vote}, spoiler => $_->{spoil}, ignore => ($_->{overruled} && !$_->{overrule})?1:0, notes => $_->{notes} };
- tuwf->dbExeci('INSERT INTO tags_vn', $row, 'ON CONFLICT (uid, vid, tag) DO UPDATE SET', $row);
- tuwf->dbExeci('UPDATE tags_vn SET ignore = TRUE WHERE uid <>', \auth->uid, 'AND vid =', \$id, 'AND tag =', \$_->{id}) if $_->{overrule};
+ my $row = { uid => auth->uid, vid => $id, tag => $_->{id}, vote => $_->{vote}, notes => $_->{notes}
+ , spoiler => $_->{spoil}, lie => $_->{lie}, ignore => ($_->{overruled} && !$_->{overrule})?1:0
+ };
+ tuwf->dbExeci('INSERT INTO tags_vn', $row, 'ON CONFLICT (uid, tag, vid) DO UPDATE SET', $row);
+ tuwf->dbExeci('UPDATE tags_vn SET ignore = TRUE WHERE uid IS DISTINCT FROM (', \auth->uid, ') AND vid =', \$id, 'AND tag =', \$_->{id}) if $_->{overrule};
}
# Make sure to reset the ignore flag when a moderator removes an overruled vote.
@@ -61,36 +76,45 @@ elm_api Tagmod => $FORM_OUT, $FORM_IN, sub {
TUWF::get qr{/$RE{vid}/tagmod}, sub {
- my $v = tuwf->dbRowi('SELECT id, title, hidden AS entry_hidden, locked AS entry_locked FROM vn WHERE id =', \tuwf->capture('id'));
+ my $v = dbobj tuwf->capture('id');
return tuwf->resNotFound if !$v->{id} || (!auth->permDbmod && $v->{entry_hidden});
- return tuwf->resDenied if !auth->permTag;
+ return tuwf->resDenied if !can_tag;
my $tags = tuwf->dbAlli('
- SELECT t.id, t.name, t.cat, count(*) as count
- , avg(CASE WHEN tv.ignore THEN NULL ELSE tv.vote END) as rating
- , coalesce(avg(CASE WHEN tv.ignore THEN NULL ELSE tv.spoiler END), t.defaultspoil) as spoiler
- , bool_or(tv.ignore) as overruled
- FROM tags t
- JOIN tags_vn tv ON tv.tag = t.id
- WHERE tv.vid =', \$v->{id}, '
- GROUP BY t.id, t.name, t.cat
+ SELECT t.id, t.name, t.cat, t.hidden, t.locked, t.applicable
+ , tv.count, tv.overruled
+ , coalesce(td.rating, 0) AS rating, coalesce(td.spoiler, t.defaultspoil) AS spoiler, coalesce(td.islie, false) AS islie
+ FROM (SELECT tag, count(*) AS count, bool_or(ignore) as overruled FROM tags_vn WHERE vid =', \$v->{id}, ' GROUP BY tag) tv
+ JOIN tags t ON t.id = tv.tag
+ LEFT JOIN (
+ SELECT tv.tag
+ , COALESCE(AVG(tv.vote) filter (where tv.vote > 0), 1+1+1) * SUM(sign(tv.vote)) / COUNT(tv.vote) AS rating
+ , AVG(tv.spoiler) AS spoiler
+ , count(lie) filter(where lie) > 0 AND count(lie) filter (where lie) >= count(lie) filter(where not lie) AS islie
+ FROM tags_vn tv
+ JOIN tags t ON t.id = tv.tag
+ LEFT JOIN users u ON u.id = tv.uid
+ WHERE NOT tv.ignore AND (u.id IS NULL OR u.perm_tag) AND tv.vid =', \$v->{id}, '
+ GROUP BY tv.tag
+ ) td ON td.tag = tv.tag
ORDER BY t.name'
);
- enrich_merge id => sub { sql 'SELECT tag AS id, vote, spoiler AS spoil, ignore, notes FROM tags_vn WHERE', { uid => auth->uid, vid => $v->{id} } }, $tags;
+ enrich_merge id => sub { sql 'SELECT tag AS id, vote, spoiler AS spoil, lie, ignore, notes FROM tags_vn WHERE', { uid => auth->uid, vid => $v->{id} } }, $tags;
enrich othnotes => id => tag => sub {
- sql('SELECT tv.tag, ', sql_user(), ', tv.notes FROM tags_vn tv JOIN users u ON u.id = tv.uid WHERE tv.notes <> \'\' AND uid <>', \auth->uid, 'AND vid=', \$v->{id})
+ sql('SELECT tv.tag, ', sql_user(), ', tv.notes FROM tags_vn tv JOIN users u ON u.id = tv.uid WHERE tv.notes <> \'\' AND uid IS DISTINCT FROM (', \auth->uid, ') AND vid=', \$v->{id})
}, $tags;
for(@$tags) {
$_->{vote} //= 0;
$_->{spoil} //= undef;
+ $_->{lie} //= undef;
$_->{notes} //= '';
$_->{overrule} = $_->{vote} && !$_->{ignore} && $_->{overruled};
$_->{othnotes} = join "\n", map user_displayname($_).': '.$_->{notes}, $_->{othnotes}->@*;
}
- framework_ title => "Edit tags for $v->{title}", type => 'v', dbobj => $v, tab => 'tagmod', sub {
- elm_ 'Tagmod' => $FORM_OUT, { id => $v->{id}, title => $v->{title}, tags => $tags, mod => auth->permTagmod };
+ framework_ title => "Edit tags for $v->{title}[1]", dbobj => $v, tab => 'tagmod', sub {
+ elm_ 'Tagmod' => $FORM_OUT, { id => $v->{id}, title => $v->{title}[1], tags => $tags, mod => auth->permTagmod };
};
};
diff --git a/lib/VNWeb/VN/Votes.pm b/lib/VNWeb/VN/Votes.pm
index 00ea04b6..08813671 100644
--- a/lib/VNWeb/VN/Votes.pm
+++ b/lib/VNWeb/VN/Votes.pm
@@ -8,7 +8,7 @@ sub listing_ {
my sub url { '?'.query_encode %$opt, @_ }
paginate_ \&url, $opt->{p}, [ $count, 50 ], 't';
- div_ class => 'mainbox browse votelist', sub {
+ article_ class => 'browse votelist', sub {
table_ class => 'stripe', sub {
thead_ sub { tr_ sub {
td_ class => 'tc1', sub { txt_ 'Date'; sortable_ 'date', $opt, \&url; debug_ $lst };
@@ -19,8 +19,8 @@ sub listing_ {
td_ class => 'tc1', fmtdate $_->{date};
td_ class => 'tc2', fmtvote $_->{vote};
td_ class => 'tc3', sub {
- b_ class => 'grayedout', 'hidden' if $_->{hide_list};
- user_ $_ if !$_->{hide_list};
+ small_ 'hidden' if $_->{c_private};
+ user_ $_ if !$_->{c_private};
};
} for @$lst;
};
@@ -30,9 +30,8 @@ sub listing_ {
TUWF::get qr{/$RE{vid}/votes}, sub {
- my $id = tuwf->capture('id');
- my $v = tuwf->dbRowi('SELECT id, title, hidden AS entry_hidden, locked AS entry_locked FROM vn WHERE id =', \$id);
- return tuwf->resNotFound if !$v->{id} || $v->{hidden};
+ my $v = dbobj tuwf->capture('id');
+ return tuwf->resNotFound if !$v->{id} || $v->{entry_hidden};
my $opt = tuwf->validate(get =>
p => { page => 1 },
@@ -49,16 +48,15 @@ TUWF::get qr{/$RE{vid}/votes}, sub {
my $count = tuwf->dbVali('SELECT COUNT(*)', $fromwhere);
my $lst = tuwf->dbPagei({results => 50, page => $opt->{p}},
- 'SELECT uv.vote,', sql_totime('uv.vote_date'), 'as date, ', sql_user(), '
- , NOT EXISTS(SELECT 1 FROM ulist_vns_labels uvl JOIN ulist_labels ul ON ul.uid = uvl.uid AND ul.id = uvl.lbl WHERE uvl.uid = uv.uid AND uvl.vid = uv.vid AND NOT ul.private) AS hide_list
- ', $fromwhere, 'ORDER BY', sprintf
- { date => 'uv.vote_date %s', vote => 'uv.vote %s', title => '(CASE WHEN hide_list THEN NULL ELSE u.username END) %s, uv.vote_date' }->{$opt->{s}},
+ 'SELECT uv.vote, uv.c_private, ', sql_totime('uv.vote_date'), 'as date, ', sql_user(),
+ $fromwhere, 'ORDER BY', sprintf
+ { date => 'uv.vote_date %s, uv.vote', vote => 'uv.vote %s, uv.vote_date', title => "(CASE WHEN uv.c_private THEN NULL ELSE u.username END) %s, uv.vote_date" }->{$opt->{s}},
{ a => 'ASC', d => 'DESC' }->{$opt->{o}}
);
- framework_ title => "Votes for $v->{title}", type => 'v', dbobj => $v, sub {
- div_ class => 'mainbox', sub {
- h1_ "Votes for $v->{title}";
+ framework_ title => "Votes for $v->{title}[1]", dbobj => $v, sub {
+ article_ sub {
+ h1_ "Votes for $v->{title}[1]";
p_ 'No votes to list. :(' if !@$lst;
};
listing_ $opt, $count, $lst if @$lst;
diff --git a/lib/VNWeb/Validation.pm b/lib/VNWeb/Validation.pm
index d77fc54a..87c5e171 100644
--- a/lib/VNWeb/Validation.pm
+++ b/lib/VNWeb/Validation.pm
@@ -1,17 +1,22 @@
package VNWeb::Validation;
use v5.26;
-use TUWF;
-use PWLookup;
+use TUWF 'uri_escape';
use VNDB::Types;
use VNDB::Config;
use VNWeb::Auth;
use VNWeb::DB;
+use VNDB::Func 'gtintype';
+use Time::Local 'timegm';
use Carp 'croak';
use Exporter 'import';
our @EXPORT = qw/
- is_insecurepass
+ %RE
+ samesite
+ is_api
+ is_unique_username
+ ipinfo
form_compile
form_changed
validate_dbid
@@ -20,16 +25,63 @@ our @EXPORT = qw/
/;
+# Regular expressions for use in path registration
+my $num = qr{[1-9][0-9]{0,6}}; # Allow up to 10 mil, SQL vndbid type can't handle more than 2^26-1 (~ 67 mil).
+my $rev = qr{(?:\.(?<rev>$num))};
+our %RE = (
+ num => qr{(?<num>$num)},
+ uid => qr{(?<id>u$num)},
+ vid => qr{(?<id>v$num)},
+ rid => qr{(?<id>r$num)},
+ sid => qr{(?<id>s$num)},
+ cid => qr{(?<id>c$num)},
+ pid => qr{(?<id>p$num)},
+ iid => qr{(?<id>i$num)},
+ did => qr{(?<id>d$num)},
+ tid => qr{(?<id>t$num)},
+ gid => qr{(?<id>g$num)},
+ wid => qr{(?<id>w$num)},
+ imgid=> qr{(?<id>(?:ch|cv|sf)$num)},
+ vrev => qr{(?<id>v$num)$rev?},
+ rrev => qr{(?<id>r$num)$rev?},
+ prev => qr{(?<id>p$num)$rev?},
+ srev => qr{(?<id>s$num)$rev?},
+ crev => qr{(?<id>c$num)$rev?},
+ drev => qr{(?<id>d$num)$rev?},
+ grev => qr{(?<id>g$num)$rev?},
+ irev => qr{(?<id>i$num)$rev?},
+ postid => qr{(?<id>t$num)\.(?<num>$num)},
+);
+
+
TUWF::set custom_validations => {
- id => { uint => 1, max => 1<<40 },
- editsum => { required => 1, length => [ 2, 5000 ] },
- page => { uint => 1, min => 1, max => 1000, required => 0, default => 1, onerror => 1 },
- upage => { uint => 1, min => 1, required => 0, default => 1, onerror => 1 }, # pagination without a maximum
- username => { regex => qr/^(?!-*[a-z][0-9]+-*$)[a-z0-9-]*$/, minlength => 2, maxlength => 15 },
+ id => { uint => 1, max => (1<<26)-1 },
+ # 'vndbid' SQL type, accepts an arrayref with accepted prefixes.
+ # If only one prefix is supported, it will also take integers and normalizes them into the formatted form.
+ vndbid => sub {
+ my $multi = ref $_[0];
+ my $types = $multi ? join '|', $_[0]->@* : $_[0];
+ my $re = qr/^(?:$types)[1-9][0-9]{0,6}$/;
+ +{ _analyze_regex => $re, func => sub { $_[0] = "${types}$_[0]" if !$multi && $_[0] =~ /^[1-9][0-9]{0,6}$/; return $_[0] =~ $re } }
+ },
+ sl => { regex => qr/^[^\t\r\n]+$/ }, # "Single line", also excludes tabs because they're weird.
+ editsum => { length => [ 2, 5000 ] },
+ page => { uint => 1, min => 1, max => 1000, default => 1, onerror => 1 },
+ upage => { uint => 1, min => 1, default => 1, onerror => 1 }, # pagination without a maximum
+ username => { regex => qr/^(?!-*[a-zA-Z][0-9]+-*$)[a-zA-Z0-9-]*$/, minlength => 2, maxlength => 15 },
password => { length => [ 4, 500 ] },
language => { enum => \%LANGUAGE },
+ gtin => { default => 0, func => sub { $_[0] = 0 if !length $_[0]; $_[0] eq 0 || gtintype($_[0]) } },
+ rdate => { uint => 1, func => \&_validate_rdate },
+ fuzzyrdate => { default => 0, func => \&_validate_fuzzyrdate },
+ searchquery => { onerror => bless([],'VNWeb::Validate::SearchQuery'), func => sub { $_[0] = bless([$_[0]], 'VNWeb::Validate::SearchQuery'); 1 } },
+ # Calendar date, limited to 1970 - 2099 for sanity.
+ # TODO: Should also validate whether the day exists, currently "2022-11-31" is accepted, but that's a bug.
+ caldate => { regex => qr/^(?:19[7-9][0-9]|20[0-9][0-9])-(?:0[1-9]|1[0-2])-(?:0[1-9]|[12][0-9]|3[01])$/ },
+ # An array that may be either missing (returns undef), a single scalar (returns single-element array) or a proper array
+ undefarray => sub { +{ default => undef, type => 'array', scalar => 1, values => $_[0] } },
# Accepts a user-entered vote string (or '-' or empty) and converts that into a DB vote number (or undef) - opposite of fmtvote()
- vnvote => { required => 0, default => undef, regex => qr/^(?:|-|[1-9]|10|[1-9]\.[0-9]|10\.0)$/, func => sub { $_[0] = $_[0] eq '-' ? undef : 10*$_[0]; 1 } },
+ vnvote => { default => undef, regex => qr/^(?:|-|[1-9]|10|[1-9]\.[0-9]|10\.0)$/, func => sub { $_[0] = $_[0] eq '-' ? undef : 10*$_[0]; 1 } },
# Sort an array by the listed hash keys, using string comparison on each key
sort_keys => sub {
my @keys = ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0];
@@ -43,11 +95,85 @@ TUWF::set custom_validations => {
},
# Sorted and unique array-of-hashes (default order is sort_keys on the sorted keys...)
aoh => sub { +{ type => 'array', unique => 1, sort_keys => [sort keys %{$_[0]}], values => { type => 'hash', keys => $_[0] } } },
+ # Fields query parameter for the API, supports multiple values or comma-delimited list, returns a hash.
+ fields => sub {
+ my %keys = map +($_,1), ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0];
+ +{ default => {}, type => 'array', values => {}, scalar => 1, func => sub {
+ my @l = map split(/\s*,\s*/,$_), @{$_[0]};
+ return 0 if grep !$keys{$_}, @l;
+ $_[0] = { map +($_,1), @l };
+ 1;
+ } }
+ },
};
+sub _validate_rdate {
+ return 0 if $_[0] ne 0 && $_[0] !~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/;
+ my($y, $m, $d) = $_[0] eq 0 ? (0,0,0) : ($1, $2, $3);
+
+ # Re-normalize
+ ($m, $d) = (0, 0) if $y == 0;
+ $m = 99 if $y == 9999;
+ $d = 99 if $m == 99;
+ $_[0] = $y*10000 + $m*100 + $d;
+
+ return 0 if $y && $y != 9999 && ($y < 1980 || $y > 2100);
+ return 0 if $y && $m != 99 && (!$m || $m > 12);
+ return 0 if $y && $d != 99 && !eval { timegm(0, 0, 0, $d, $m-1, $y) };
+ return 1;
+}
+
+
+sub _validate_fuzzyrdate {
+ $_[0] = 0 if $_[0] =~ /^unknown$/i;
+ $_[0] = 1 if $_[0] =~ /^today$/i;
+ $_[0] = 99999999 if $_[0] =~ /^tba$/i;
+ $_[0] = "${1}9999" if $_[0] =~ /^([0-9]{4})$/;
+ $_[0] = "${1}${2}99" if $_[0] =~ /^([0-9]{4})-([0-9]{2})$/;
+ $_[0] = "${1}${2}$3" if $_[0] =~ /^([0-9]{4})-([0-9]{2})-([0-9]{2})$/;
+ return 1 if $_[0] eq 1;
+ VNWeb::Validation::_validate_rdate($_[0]);
+}
+
+
+# returns true if this request originated from the same site, i.e. not an external referer.
+sub samesite { !!tuwf->reqCookie('samesite') }
+
+# returns true if this request is for an /api/ URL.
+sub is_api { !$main::NOAPI && ($main::ONLYAPI || tuwf->reqPath =~ /^\/api\//) }
-sub is_insecurepass {
- config->{password_db} && PWLookup::lookup(config->{password_db}, shift)
+# Test uniqueness of a username in the database. Usernames with similar
+# homographs are considered duplicate.
+# (Would be much faster and safer to do this normalization in the DB and put a
+# unique constraint on the normalized name, but we have a bunch of existing
+# username clashes that I can't just change)
+sub is_unique_username {
+ my($name, $excludeid) = @_;
+ my sub norm {
+ # lowercase, normalize 'i1l' and '0o'
+ sql "regexp_replace(regexp_replace(lower(", $_[0], "), '[1l]', 'i', 'g'), '0', 'o', 'g')";
+ };
+ !tuwf->dbVali('SELECT 1 FROM users WHERE', norm('username'), '=', norm(\$name),
+ $excludeid ? ('AND id <>', \$excludeid) : ());
+}
+
+
+# Lookup IP and return an 'ipinfo' DB string.
+sub ipinfo {
+ my $ip = shift || tuwf->reqIP;
+ state $db = config->{location_db} && do {
+ require Location;
+ Location::init(config->{location_db});
+ };
+ sub esc { ($_[0]//'') =~ s/([,()\\'"])/\\$1/rg }
+ return sprintf "(%s,,,,,,,)", esc $ip if !$db;
+
+ my sub f { Location::lookup_network_has_flag($db, $ip, "LOC_NETWORK_FLAG_$_[0]") ? 't' : 'f' }
+ my $asn = Location::lookup_asn($db, $ip);
+ sprintf "(%s,%s,%d,%s,%s,%s,%s,%s)", esc($ip),
+ esc(Location::lookup_country_code($db,$ip)),
+ $asn, esc(Location::get_as_name($db,$asn)),
+ f('ANONYMOUS_PROXY'), f('SATELLITE_PROVIDER'), f('ANYCAST'), f('DROP');
}
@@ -100,12 +226,17 @@ sub _eq_deep {
# ($b), using the normalization defined in $schema. The $schema must validate.
sub form_changed {
my($schema, $a, $b) = @_;
- my $na = $schema->validate($a)->data;
- my $nb = $schema->validate($b)->data;
-
- #warn "a=".JSON::XS->new->pretty->canonical->encode($na);
- #warn "b=".JSON::XS->new->pretty->canonical->encode($nb);
- !_eq_deep $na, $nb;
+ my sub norm {
+ my $v = $schema->validate($_[0]);
+ if($v->err) {
+ require Data::Dumper;
+ my $e = Data::Dumper->new([$v->err])->Terse(1)->Pair(':')->Indent(0)->Sortkeys(1)->Dump;
+ my $j = JSON::XS->new->pretty->encode($_[0]);
+ warn "form_changed() input did not validate according to the schema.\nError: $e\nInput: $j";
+ }
+ $v->unsafe_data;
+ }
+ !_eq_deep norm($a), norm($b);
}
@@ -143,6 +274,15 @@ sub validate_dbid {
# Otherwise, checks if the user can edit the post.
# Requires the 'user_id', 'date' and 'hidden' fields.
#
+# w:
+# If no 'id' field, checks if the user can submit a new review.
+# Otherwise, checks if the user can edit the review.
+# Requires the 'uid' field.
+#
+# g/i:
+# If no 'id' field, checks if the user can create a new tag/trait.
+# Otherwise, checks if the user can edit the entry.
+#
# 'dbentry_type's:
# If no 'id' field, checks whether the user can create a new entry.
# Otherwise, requires 'entry_hidden' and 'entry_locked' fields.
@@ -150,12 +290,12 @@ sub validate_dbid {
sub can_edit {
my($type, $entry) = @_;
- return auth->permUsermod || (auth && $entry->{id} == auth->uid) if $type eq 'u';
+ return auth->permUsermod || (auth && $entry->{id} eq auth->uid) if $type eq 'u';
return auth->permDbmod if $type eq 'd';
if($type eq 't') {
- return 0 if !auth->permBoard;
return 1 if auth->permBoardmod;
+ return 0 if !auth->permBoard || (global_settings->{lockdown_board} && !auth->isMod);
if(!$entry->{id}) {
# Allow at most 5 new threads per day per user.
return auth && tuwf->dbVali('SELECT count(*) < ', \5, 'FROM threads_posts WHERE num = 1 AND date > NOW()-\'1 day\'::interval AND uid =', \auth->uid);
@@ -165,19 +305,33 @@ sub can_edit {
} else {
die "Can't do authorization test when hidden/date/user_id fields aren't present"
if !exists $entry->{hidden} || !exists $entry->{date} || !exists $entry->{user_id};
- return auth && $entry->{user_id} == auth->uid && !$entry->{hidden} && $entry->{date} > time-config->{board_edit_time};
+ # beware: for threads the 'hidden' field is a non-undef boolean flag, for posts it is a possibly-undef text field.
+ my $hidden = $entry->{id} =~ /^t/ && $entry->{num} == 1 ? $entry->{hidden} : defined $entry->{hidden};
+ return auth && $entry->{user_id} eq auth->uid && !$hidden && $entry->{date} > time-config->{board_edit_time};
}
}
+ if($type eq 'w') {
+ return 1 if auth->permBoardmod;
+ return auth->permReview && (!global_settings->{lockdown_board} || auth->isMod) if !$entry->{id};
+ return auth && auth->uid eq $entry->{user_id};
+ }
+
+ if($type eq 'g' || $type eq 'i') {
+ return auth->permEdit && (auth->permTagmod || !$entry->{id});
+ }
+
die "Can't do authorization test when entry_hidden/entry_locked fields aren't present"
if $entry->{id} && (!exists $entry->{entry_hidden} || !exists $entry->{entry_locked});
- auth->permDbmod || (auth->permEdit && !($entry->{entry_hidden} || $entry->{entry_locked}));
+ auth->permDbmod || (auth->permEdit && !global_settings->{lockdown_edit} && !($entry->{entry_hidden} || $entry->{entry_locked}));
}
-# Returns { spoilers => 0-2, traits_sexual => 0/1 }
-# Based on the view= query parameter or the user's preferences.
+# Some user preferences can be overruled with a ?view= query parameter,
+# viewget() can be used to fetch these parameters, viewset() to generate a
+# query parameter with certain preferences overruled.
+#
# The query parameter has the following format:
# view=1 -> spoilers=1, traits_sexual=<default>
# view=2s -> spoilers=2, traits_sexual=1
@@ -186,20 +340,121 @@ sub can_edit {
# i.e. a list of single-character flags:
# 0-2 -> spoilers
# s/S -> 1/0 traits_sexual
+# n/N -> 1/0 show_nsfw
# Missing flags will use default.
+#
+# The parameter also contains a CSRF token to prevent direct links to pages
+# with sensitive content. The token is domain-separated from the form CSRF
+# tokens, but is otherwise generic for all pages and options, so if someone's
+# token leaks, it's possible to generate links to any sensitive page for that
+# particular user for several hours.
sub viewget {
- (tuwf->reqGet('view')) =~ /^([0-2])?([sS]?)$/;
- {
- spoilers => $1 // auth->pref('spoilers') || 0,
- traits_sexual => !$2 ? auth->pref('traits_sexual') : $2 eq 's',
- }
+ tuwf->req->{view} ||= do {
+ my($view, $token) = tuwf->reqGet('view') =~ /^([^-]*)-(.+)$/;
+
+ # Abort this request and redirect if the token is invalid.
+ if(length($view) && (!samesite || !length($token) || !auth->csrfcheck($token, 'view'))) {
+ my $qs = join '&', map { my $k=$_; my @l=tuwf->reqGets($k); map uri_escape($k).'='.uri_escape($_), @l } grep $_ ne 'view', tuwf->reqGets();
+ tuwf->resInit;
+ tuwf->resRedirect(tuwf->reqPath().($qs?"?$qs":''), 'temp');
+ tuwf->done;
+ }
+
+ my($sp, $ts, $ns) = $view =~ /^([0-2])?([sS]?)([nN]?)$/;
+ {
+ spoilers => $sp // auth->pref('spoilers') || 0,
+ traits_sexual => !$ts ? auth->pref('traits_sexual') : $ts eq 's',
+ show_nsfw => !$ns ? (auth->pref('max_sexual')||0)==2 && (auth->pref('max_violence')||0)>0 : $ns eq 'n',
+ }
+ };
+ tuwf->req->{view}
}
-# Modifies the current view settings and serializes that into a view= value.
-# XXX: This may include more flags than the current page will use.
+
+# Creates a new 'view=' string with the given parameters. All other fields remain at their default.
sub viewset {
- my %s = (viewget->%*, @_);
- $s{spoilers}.($s{traits_sexual}?'s':'S')
+ my %s = @_;
+ join '',
+ $s{spoilers}//'',
+ !defined $s{traits_sexual} ? '' : $s{traits_sexual} ? 's' : 'S',
+ !defined $s{show_nsfw} ? '' : $s{show_nsfw} ? 'n' : 'N',
+ '-'.auth->csrftoken(0, 'view');
}
+
+# Object returned by the 'searchquery' validation, has some handy methods for generating SQL.
+package VNWeb::Validate::SearchQuery {
+ use TUWF;
+ use VNWeb::DB;
+
+ sub query_encode { $_[0][0] }
+ sub TO_JSON { $_[0][0] }
+
+ sub words {
+ $_[0][1] //= length $_[0][0]
+ ? [ map s/%//rg, tuwf->dbVali('SELECT search_query(', \$_[0][0], ')')->@* ]
+ : []
+ }
+
+ use overload bool => sub { $_[0]->words->@* > 0 };
+ use overload '""' => sub { $_[0][0]//'' };
+
+ sub _isvndbid { my $l = $_[0]->words; @$l == 1 && $l->[0] =~ /^[vrpcsgi]$num$/ }
+
+ sub where {
+ my($self, $type) = @_;
+ my $lst = $self->words;
+ my @keywords = map sql('sc.label LIKE', \('%'.sql_like($_).'%')), @$lst;
+ +(
+ $type ? "sc.id BETWEEN '${type}1' AND vndbid_max('$type')" : (),
+ $self->_isvndbid()
+ ? (sql 'sc.id =', \$lst->[0], 'OR', sql_and(@keywords))
+ : @keywords
+ )
+ }
+
+ sub sql_where {
+ my($self, $type, $id, $subid) = @_;
+ return '1=1' if !$self;
+ sql 'EXISTS(SELECT 1 FROM search_cache sc WHERE', sql_and(
+ sql('sc.id =', $id), $subid ? sql('sc.subid =', $subid) : (),
+ $self->where($type),
+ ), ')';
+ }
+
+ # Returns a subquery that can be joined to get the search score.
+ # Columns (id, subid, score)
+ sub sql_score {
+ my($self, $type) = @_;
+ my $lst = $self->words;
+ my $q = join '', @$lst;
+ sql '(SELECT id, subid, max(sc.prio * (', VNWeb::DB::sql_join('+',
+ $self->_isvndbid() ? sql('CASE WHEN sc.id =', \$q, 'THEN 1+1 ELSE 0 END') : (),
+ sql('CASE WHEN sc.label LIKE', \(sql_like($q).'%'), 'THEN 1::float/(1+1) ELSE 0 END'),
+ sql('similarity(sc.label,', \$q, ')'),
+ ), ')) AS score
+ FROM search_cache sc
+ WHERE', sql_and($self->where($type)), '
+ GROUP BY id, subid
+ )';
+ }
+
+ # Optionally returns a JOIN clause for sql_score, aliassed 'sc'
+ sub sql_join {
+ my($self, $type, $id, $subid) = @_;
+ return '' if !$self;
+ sql 'JOIN', $self->sql_score($type), 'sc ON sc.id =', $id, $subid ? ('AND sc.subid =', $subid) : ();
+ }
+
+ # Same as sql_join(), but accepts an array of SearchQuery objects that are OR'ed together.
+ sub sql_joina {
+ my($lst, $type, $id, $subid) = @_;
+ sql 'JOIN (
+ SELECT id, subid, max(score) AS score
+ FROM (', VNWeb::DB::sql_join('UNION ALL', map sql('SELECT * FROM', $_->sql_score($type), 'x'), @$lst), ') x
+ GROUP BY id, subid
+ ) sc ON sc.id =', $id, $subid ? ('AND sc.subid =', $subid) : ();
+ }
+};
+
1;