diff options
38 files changed, 528 insertions, 12411 deletions
diff --git a/lib/VNDB/Auth.pm b/lib/VNDB/Auth.pm new file mode 100644 index 00000000..ca0e785e --- /dev/null +++ b/lib/VNDB/Auth.pm @@ -0,0 +1,181 @@ +# This package provides a 'tuwf->auth' method and a useful object for dealing +# with VNDB sessions. Usage: +# +# use VNDB::Auth; +# +# if(auth) { +# ..user is logged in +# } +# ..or: +# if(tuwf->auth) { .. } +# +# my $success = auth->login($user, $pass); +# auth->logout; +# +# my $uid = auth->uid; +# my $username = auth->username; +# ..etc +# +# die "You're not allowed to post!" if !tuwf->auth->permBoard; +# +package VNDB::Auth; + +use strict; +use warnings; +use Moo; +use TUWF; +use SQL::Yapp dbh => sub { tuwf->dbh }; +use Exporter 'import'; + +use Digest::SHA qw|sha1 sha1_hex|; +use Crypt::URandom 'urandom'; +use Crypt::ScryptKDF 'scrypt_raw'; +use Encode 'encode_utf8'; + +our @EXPORT = ('auth'); +sub auth { tuwf->{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, ''); + + tuwf->{auth} = __PACKAGE__->new(%{ tuwf->conf->{auth} || {} }); + tuwf->{auth}->_load_session($uid, $token_e); + 1; +}; + + +TUWF::hook after => sub { tuwf->{auth} = __PACKAGE__->new }; + + +# log user IDs (necessary for determining performance issues, user preferences +# have a lot of influence in this) +TUWF::set log_format => sub { + my($self, $uri, $msg) = @_; + sprintf "[%s] %s %s: %s\n", scalar localtime(), $uri, $self->auth ? $self->auth->uid : '-', $msg; +}; + + + +use overload bool => sub { defined shift->uid }; + +has uid => (is => 'ro'); +has token => (is => 'ro'); +has username => (is => 'ro'); +has perm => (is => 'ro', default => 0); + + + +# 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. +my %perms = qw{ + 1 board + 2 boardmod + 4 edit + 16 tag + 32 dbmod + 64 tagmod + 128 usermod + 256 affiliate +}; + + +# Create a read-only accessor to check if the current user is authorized to +# perform a particular action. +for my $perm (keys %perms) { + has 'perm'.ucfirst($perm), + is => 'ro', + lazy => 1, + builder => sub { (shift->perm() & $perms{$perm}) > 0 }; +} + + +sub _randomascii { + return join '', map chr($_%92+33), unpack 'C*', urandom shift; +} + + +# Prepares a plaintext password for database storage +# Arguments: pass, optionally: salt, N, r, p +# Returns: encrypted password (as a binary string) +sub _preparepass { + my($self, $pass, $salt, $N, $r, $p) = @_; + ($N, $r, $p) = @{$self->{scrypt_args}} if !$N; + $salt ||= urandom(8); + return pack 'NCCa8a*', $N, $r, $p, $salt, scrypt_raw($pass, $self->{scrypt_salt} . $salt, $N, $r, $p, 32); +} + + +# Arguments: self, uid, encpass +# Returns: 0 on error, 1 on success +sub _create_session { + my($self, $uid, $encpass) = @_; + + my $token = urandom 20; + my $token_db = sha1_hex $token; + return 0 if !sqlFetch{SELECT USER_LOGIN($uid, DECODE({unpack 'H*', $encpass}, 'hex'), DECODE($token_db, 'hex'))}; + + tuwf->resCookie(auth => unpack('H*', $token).'.'.$uid, httponly => 1, expires => time + 31536000); + $self->_load_session($uid, $token_db); + return 1; +} + + +sub _load_session { + my($self, $uid, $token_db) = @_; + + my $user = {}; + if($uid) { + my $loggedin = sqlExpr{USER_ISLOGGEDIN(id, DECODE($token_db, 'hex'))}; + $user = sqlFetch{ + SELECT id, username, perm, EXTRACT('epoch' FROM $loggedin) AS lastused + FROM users + WHERE (id = $uid) + AND ($loggedin IS NOT NULL) + LIMIT 1 + }; + + # update the sessions.lastused column if lastused < now()-'6 hours' + sqlDo{SELECT USER_UPDATE_LASTUSED($user->{id}, DECODE($token_db, 'hex'))} + if $user->{id} && $user->{lastused} < time()-6*3600; + } + + # Drop the cookie if it's not valid + tuwf->resCookie(auth => undef) if !$user->{id} && tuwf->reqCookie('auth'); + + $self->{uid} = $user->{id}; + $self->{username} = $user->{username}; + $self->{perm} = $user->{perm}||0; + $self->{token} = $token_db; +} + + +# Returns 1 on success, 0 on failure +sub login { + my($self, $user, $pass) = @_; + return 0 if $self->uid || !$user || !$pass; + + my $u = sqlFetch{SELECT id, USER_GETSCRYPTARGS(id) AS args FROM users WHERE username = $user}; + return 0 if !$u->{id} || !$u->{args} || length($u->{args}) != 14; + + my($N, $r, $p, $salt) = unpack 'NCCa8', $u->{args}; + my $encpass = $self->_preparepass($pass, $salt, $N, $r, $p); + $self->_create_session($u->{id}, $encpass); +} + + +sub logout { + my $self = shift; + return if !$self->uid; + sqlDo{SELECT USER_LOGOUT($self->uid, DECODE($self->token, 'hex'))}; + $self->_load_session(); +} + + +# TODO: Password reset API +# TODO: Preferences API +# TODO: XSRF token handling + +1; diff --git a/lib/VNDB/DB/Affiliates.pm b/lib/VNDB/DB/Affiliates.pm deleted file mode 100644 index 94dfd198..00000000 --- a/lib/VNDB/DB/Affiliates.pm +++ /dev/null @@ -1,73 +0,0 @@ - -package VNDB::DB::Affiliates; - -use strict; -use warnings; -use POSIX 'strftime'; -use Exporter 'import'; - -our @EXPORT = qw|dbAffiliateGet dbAffiliateEdit dbAffiliateDel dbAffiliateAdd|; - - -# options: id rids affiliate hidden sort reverse -# what: release -sub dbAffiliateGet { - my($self, %o) = @_; - $o{sort} ||= 'id'; - $o{reverse} //= 0; - - my %where = ( - $o{id} ? ('id = ?' => $o{id}) : (), - $o{rids} ? ('rid IN(!l)' => [$o{rids}]) : (), - defined($o{affiliate}) ? ('affiliate = ?' => $o{affiliate}) : (), - defined($o{hidden}) ? ('!s af.hidden' => $o{hidden} ? '' : 'NOT') : (), - ); - - my $join = $o{what} ? 'JOIN releases r ON r.id = af.rid' : ''; - my $select = $o{what} ? ', r.title' : ''; - - my $order = sprintf { - id => 'af.id %s', - rel => 'r.title %s', - prio => 'af.priority %s', - url => 'af.url %s', - lastfetch => 'af.lastfetch %s', - }->{$o{sort}}, $o{reverse} ? 'DESC' : 'ASC'; - - return $self->dbAll(qq| - SELECT af.id, af.rid, af.hidden, af.priority, af.affiliate, af.url, af.version, - extract('epoch' from af.lastfetch) as lastfetch, af.price, af.data$select - FROM affiliate_links af - $join - !W - ORDER BY !s|, \%where, $order); -} - - -sub dbAffiliateDel { - my($self, $id) = @_; - $self->dbExec('DELETE FROM affiliate_links WHERE id = ?', $id); -} - - -sub dbAffiliateEdit { - my($self, $id, %ops) = @_; - my %set; - exists($ops{$_}) && ($set{"$_ = ?"} = $ops{$_}) for(qw|rid priority hidden affiliate url version price data|); - $set{"lastfetch = TIMESTAMP WITH TIME ZONE 'epoch' + ? * INTERVAL '1 second'"} = $ops{lastfetch} || $ops{lastfetch} eq '0' ? $ops{lastfetch} : undef if exists $ops{lastfetch}; - return if !keys %set; - $self->dbExec('UPDATE affiliate_links !H WHERE id = ?', \%set, $id); -} - - -sub dbAffiliateAdd { - my($self, %ops) = @_; - $self->dbExec(q|INSERT INTO affiliate_links (rid, priority, hidden, affiliate, url, version, price, data, lastfetch) - VALUES(!l, TIMESTAMP WITH TIME ZONE 'epoch' + ? * INTERVAL '1 second')|, - [@ops{qw| rid priority hidden affiliate url version price data|}], - $ops{lastfetch} || $ops{lastfetch} eq '0' ? $ops{lastfetch} : undef); -} - - -1; - diff --git a/lib/VNDB/DB/Chars.pm b/lib/VNDB/DB/Chars.pm deleted file mode 100644 index db9ae93b..00000000 --- a/lib/VNDB/DB/Chars.pm +++ /dev/null @@ -1,188 +0,0 @@ - -package VNDB::DB::Chars; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbCharGet dbCharGetRev dbCharRevisionInsert dbCharImageId|; - - -# 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} ) : (), - 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 <= ? AND c.weight > 0' => $o{weight_max} ) : (), - $o{search} ? ( - '(c.name ILIKE ? OR c.original ILIKE ? 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 ) : (), - $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}] ] ) : (), - ); - - 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.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.requester, c.comments, u.username, c.rev, c.ihid, c.ilock'; - $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.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 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 b4771adc..00000000 --- a/lib/VNDB/DB/Discussions.pm +++ /dev/null @@ -1,351 +0,0 @@ - -package VNDB::DB::Discussions; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbThreadGet dbThreadEdit dbThreadAdd dbPostGet dbPostEdit dbPostAdd dbThreadCount dbPollStats dbPollVote|; - - -# Options: id, type, iid, results, page, what, 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} ) : (), - !$o{id} ? ( - 't.hidden = FALSE' => 0 ) : (), - $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.poll_question IS NOT NULL AS haspoll', - $o{what} =~ /lastpost/ ? ('tpl.uid AS luid', q|EXTRACT('epoch' from tpl.date) AS ldate|, 'ul.username AS lusername') : (), - $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 $x = $r->[$r{$_->{tid}}]; $x->{fuid} = $_->{uid}; $x->{fdate} = $_->{date}; $x->{fusername} = $_->{username} } for (@{$self->dbAll(q| - SELECT tpf.tid, tpf.uid, EXTRACT('epoch' from tpf.date) AS date, uf.username - FROM threads_posts tpf - JOIN users uf ON tpf.uid = uf.id - WHERE tpf.num = 1 AND tpf.tid IN(!l)|, - [ 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; -} - - -# id, %options->( title locked hidden boards poll_question poll_max_options poll_preview poll_recast poll_options } -# The poll_{question,options,max_options} fields should not be set when there -# are no changes to the poll info. Either all or none of these fields should be -# set. -sub dbThreadEdit { - my($self, $id, %o) = @_; - - my %set = ( - 'title = ?' => $o{title}, - 'locked = ?' => $o{locked}?1:0, - 'hidden = ?' => $o{hidden}?1:0, - 'poll_preview = ?' => $o{poll_preview}?1:0, - 'poll_recast = ?' => $o{poll_recast}?1:0, - exists $o{poll_question} ? ( - 'poll_question = ?' => $o{poll_question}||undef, - 'poll_max_options = ?' => $o{poll_max_options}||1, - ) : (), - ); - - $self->dbExec(q| - UPDATE threads - !H - WHERE id = ?|, - \%set, $id); - - if($o{boards}) { - $self->dbExec('DELETE FROM threads_boards WHERE tid = ?', $id); - $self->dbExec(q| - INSERT INTO threads_boards (tid, type, iid) - VALUES (?, ?, ?)|, - $id, $_->[0], $_->[1]||0 - ) for (@{$o{boards}}); - } - - if(exists $o{poll_question}) { - $self->dbExec('DELETE FROM threads_poll_options WHERE tid = ?', $id); - $self->dbExec(q| - INSERT INTO threads_poll_options (tid, option) - VALUES (?, ?)|, - $id, $_ - ) for (@{$o{poll_options}}); - } -} - - -# %options->{ title hidden locked boards poll_stuff } -sub dbThreadAdd { - my($self, %o) = @_; - - my $id = $self->dbRow(q| - INSERT INTO threads (title, hidden, locked, poll_question, poll_max_options, poll_preview, poll_recast) - VALUES (?, ?, ?, ?, ?, ?, ?) - RETURNING id|, - $o{title}, $o{hidden}?1:0, $o{locked}?1:0, $o{poll_question}||undef, $o{poll_max_options}||1, $o{poll_preview}?1:0, $o{poll_recast}?1:0 - )->{id}; - - $self->dbExec(q| - INSERT INTO threads_boards (tid, type, iid) - VALUES (?, ?, ?)|, - $id, $_->[0], $_->[1]||0 - ) for (@{$o{boards}}); - - $self->dbExec(q| - INSERT INTO threads_poll_options (tid, option) - VALUES (?, ?)|, - $id, $_ - ) for ($o{poll_question} ? @{$o{poll_options}} : ()); - - return $id; -} - - -# Returns thread count of a specific item board -# Arguments: type, iid -sub dbThreadCount { - my($self, $type, $iid) = @_; - return $self->dbRow(q| - SELECT COUNT(*) AS cnt - FROM threads_boards tb - JOIN threads t ON t.id = tb.tid - WHERE tb.type = ? AND tb.iid = ? - AND t.hidden = FALSE|, - $type, $iid)->{cnt}; -} - - -# 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' => 1 ) : (), - $o{search} ? ( - 'bb_tsvector(msg) @@ to_tsquery(?)' => $o{search}) : (), - $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/ ? qw|tp.uid u.username| : (), - $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 - ); - - # Get headlines in a separate query - if($o{search} && @$r) { - my %r = map { - ($r->[$_]{tid}.'.'.$r->[$_]{num}, $_) - } 0..$#$r; - my $where = join ' or ', ('(tid = ? and num = ?)')x@$r; - my @where = map +($_->{tid},$_->{num}), @$r; - my $h = join ',', map "$_=$o{headline}{$_}", $o{headline} ? keys %{$o{headline}} : (); - - $r->[$r{$_->{tid}.'.'.$_->{num}}]{headline} = $_->{headline} for (@{$self->dbAll(qq| - SELECT tid, num, ts_headline('english', strip_bb_tags(strip_spoilers(msg)), to_tsquery(?), ?) as headline - FROM threads_posts - WHERE $where|, - $o{search}, $h, @where - )}); - } - - return wantarray ? ($r, $np) : $r; -} - - -# tid, num, %options->{ num msg hidden lastmod } -sub dbPostEdit { - my($self, $tid, $num, %o) = @_; - - my %set = ( - 'msg = ?' => $o{msg}, - 'edited = to_timestamp(?)' => $o{lastmod}, - 'hidden = ?' => $o{hidden}?1:0, - ); - - $self->dbExec(q| - UPDATE threads_posts - !H - WHERE tid = ? - AND num = ?|, - \%set, $tid, $num - ); -} - - -# tid, %options->{ uid msg } -sub dbPostAdd { - my($self, $tid, %o) = @_; - - my $num = $self->dbRow('SELECT num FROM threads_posts WHERE tid = ? ORDER BY num DESC LIMIT 1', $tid)->{num}; - $num = $num ? $num+1 : 1; - $o{uid} ||= $self->authInfo->{id}; - - $self->dbExec(q| - INSERT INTO threads_posts (tid, num, uid, msg) - VALUES(?, ?, ?, ?)|, - $tid, $num, @o{qw| uid msg |} - ); - $self->dbExec(q| - UPDATE threads - SET count = count+1 - WHERE id = ?|, - $tid); - - return $num; -} - - -# Args: tid -# Returns: num_users, poll_stats, user_voted_options -sub dbPollStats { - my($self, $tid) = @_; - my $uid = $self->authInfo->{id}; - - my $num_users = $self->dbRow('SELECT COUNT(DISTINCT uid) AS votes FROM threads_poll_votes WHERE tid = ?', $tid)->{votes} || 0; - - my $stats = !$num_users ? {} : { map +($_->{optid}, $_->{votes}), @{$self->dbAll( - 'SELECT optid, COUNT(optid) AS votes FROM threads_poll_votes WHERE tid = ? GROUP BY optid', $tid - )} }; - - my $user = !$num_users || !$uid ? [] : [ - map $_->{optid}, @{$self->dbAll('SELECT optid FROM threads_poll_votes WHERE tid = ? AND uid = ?', $tid, $uid)} - ]; - - return $num_users, $stats, $user; -} - - -sub dbPollVote { - my($self, $tid, $uid, @opts) = @_; - - $self->dbExec('DELETE FROM threads_poll_votes WHERE tid = ? AND uid = ?', $tid, $uid); - $self->dbExec('INSERT INTO threads_poll_votes (tid, uid, optid) VALUES (?, ?, ?)', - $tid, $uid, $_) for @opts; -} - -1; diff --git a/lib/VNDB/DB/Misc.pm b/lib/VNDB/DB/Misc.pm deleted file mode 100644 index d6389376..00000000 --- a/lib/VNDB/DB/Misc.pm +++ /dev/null @@ -1,125 +0,0 @@ - -package VNDB::DB::Misc; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw| - dbStats dbItemEdit dbRevisionGet dbRandomQuote -|; - - -# 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 [vrp], 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'; - $self->dbStaffRevisionInsert( \%o) if $type eq 's'; - - 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.requester, c.comments, c.rev, extract('epoch' from c.added) as added, u.username - FROM changes c - JOIN users u ON c.requester = u.id - !W - ORDER BY c.id DESC|, \%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 '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 random quote (hashref with keys = vid, quote) -sub dbRandomQuote { - return $_[0]->dbRow(q| - SELECT vid, quote - FROM quotes - ORDER BY RANDOM() - LIMIT 1|); -} - - - - -1; - diff --git a/lib/VNDB/DB/Producers.pm b/lib/VNDB/DB/Producers.pm deleted file mode 100644 index a6a301e5..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.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.requester, c.comments, u.username, c.rev, c.ihid, c.ilock'; - $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, 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 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 c54ea1a3..00000000 --- a/lib/VNDB/DB/Releases.pm +++ /dev/null @@ -1,253 +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|; - - -# 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{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{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}}) ] ]) : (), - ); -} - - -# Options: id vid pid released page results what med sort reverse date_before date_after -# plat lang olang type minage search resolution freeware doujin voiced ani_story ani_ero hidden_only -# What: extended vn producers platforms media affiliates -# 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{vid} ? ( 'rv.vid IN(!l)' => [ ref $o{vid} ? $o{vid} : [$o{vid}] ] ) : (), - $o{pid} ? ( 'rp.pid = ?' => $o{pid} ) : (), - $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{vid} ? 'JOIN releases_vn rv ON rv.id = r.id' : (), - $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.ani_story r.ani_ero r.hidden r.locked| : (), - $o{pid} ? ('rp.developer', 'rp.publisher') : (), - ); - - 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 affiliates -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.ani_story, r.ani_ero, ro.hidden, ro.locked' if $o{what} =~ /extended/; - $select .= ', extract(\'epoch\' from c.added) as added, c.requester, c.comments, u.username, c.rev, c.ihid, c.ilock'; - $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'; - - 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 - patch resolution voiced freeware doujin ani_story ani_ero|; - $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; - } -} - - -1; - diff --git a/lib/VNDB/DB/Staff.pm b/lib/VNDB/DB/Staff.pm deleted file mode 100644 index bf2ae325..00000000 --- a/lib/VNDB/DB/Staff.pm +++ /dev/null @@ -1,196 +0,0 @@ - -package VNDB::DB::Staff; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbStaffGet dbStaffGetRev dbStaffRevisionInsert dbStaffAliasIds|; - -# options: results, page, id, aid, search, exact, truename, role, gender -# what: extended changes roles aliases -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'; - $select .= ', s.desc, s.l_wp, s.l_site, s.l_twitter, s.l_anidb, s.hidden, s.locked' if $o{what} =~ /extended/; - - 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 _enrich($self, $r, $np, 0, $o{what}); -} - - -sub dbStaffGetRev { - my $self = shift; - my %o = (what => '', @_); - - $o{rev} ||= $self->dbRow('SELECT MAX(rev) AS rev FROM changes WHERE type = \'s\' AND itemid = ?', $o{id})->{rev}; - - my $select = 'c.itemid AS id, sa.aid, sa.name, sa.original, s.gender, s.lang'; - $select .= ', extract(\'epoch\' from c.added) as added, c.requester, c.comments, u.username, c.rev, c.ihid, c.ilock'; - $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 .= ', s.desc, s.l_wp, s.l_site, s.l_twitter, s.l_anidb, so.hidden, so.locked' if $o{what} =~ /extended/; - - my $r = $self->dbAll(q| - SELECT !s - FROM changes c - JOIN staff so ON so.id = c.itemid - JOIN staff_hist s ON s.chid = c.id - JOIN staff_alias_hist sa ON sa.chid = c.id AND s.aid = sa.aid - JOIN users u ON u.id = c.requester - WHERE c.type = 's' 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) = @_; - - # Role info is linked to VN revisions, so is independent of the selected staff revision - if(@$r && $what =~ /roles/) { - my %r = map { - $_->{roles} = []; - $_->{cast} = []; - ($_->{id}, $_); - } @$r; - - push @{$r{ delete $_->{id} }{roles}}, $_ for (@{$self->dbAll(q| - SELECT sa.id, sa.aid, v.id AS vid, sa.name, sa.original, v.c_released, v.title, v.original AS t_original, vs.role, vs.note - FROM vn_staff vs - JOIN vn v ON v.id = vs.id - JOIN staff_alias sa ON vs.aid = sa.aid - WHERE sa.id IN(!l) AND NOT v.hidden - ORDER BY v.c_released ASC, v.title ASC, vs.role ASC|, [ keys %r ] - )}); - push @{$r{ delete $_->{id} }{cast}}, $_ for (@{$self->dbAll(q| - SELECT sa.id, sa.aid, v.id AS vid, sa.name, sa.original, v.c_released, v.title, v.original AS t_original, c.id AS cid, c.name AS c_name, c.original AS c_original, vs.note - FROM vn_seiyuu vs - JOIN vn v ON v.id = vs.id - JOIN chars c ON c.id = vs.cid - JOIN staff_alias sa ON vs.aid = sa.aid - WHERE sa.id IN(!l) AND NOT v.hidden - ORDER BY v.c_released ASC, v.title ASC|, [ keys %r ] - )}); - } - - if(@$r && $what =~ /aliases/) { - my ($col, $hist, $colname) = $rev ? ('cid', '_hist', 'chid') : ('id', '', 'id'); - my %r = map { - $_->{aliases} = []; - ($_->{$col}, $_); - } @$r; - - push @{$r{ delete $_->{xid} }{aliases}}, $_ for (@{$self->dbAll(" - SELECT s.$colname AS xid, sa.aid, sa.name, sa.original - FROM staff_alias$hist sa - JOIN staff$hist s ON s.$colname = sa.$colname - WHERE s.$colname IN(!l) AND s.aid <> sa.aid - ORDER BY sa.name ASC", [ keys %r ] - )}); - } - - return wantarray ? ($r, $np) : $r; -} - - -# Updates the edit_* tables, used from dbItemEdit() -# Arguments: { columns in staff_rev and staff_alias}, -sub dbStaffRevisionInsert { - my($self, $o) = @_; - - $self->dbExec('DELETE FROM edit_staff_alias'); - if($o->{aid}) { - $self->dbExec(q| - INSERT INTO edit_staff_alias (aid, name, original) VALUES (?, ?, ?)|, - $o->{aid}, $o->{name}, $o->{original}); - } else { - $o->{aid} = $self->dbRow(q| - INSERT INTO edit_staff_alias (name, original) VALUES (?, ?) RETURNING aid|, - $o->{name}, $o->{original})->{aid}; - } - - my %staff = map exists($o->{$_}) ? (qq|"$_" = ?|, $o->{$_}) : (), - qw|aid gender lang desc l_wp l_site l_twitter l_anidb|; - $self->dbExec('UPDATE edit_staff !H', \%staff) if %staff; - for my $a (@{$o->{aliases}}) { - if($a->{aid}) { - $self->dbExec('INSERT INTO edit_staff_alias (aid, name, original) VALUES (!l)', [ @{$a}{qw|aid name orig|} ]); - } else { - $self->dbExec('INSERT INTO edit_staff_alias (name, original) VALUES (?, ?)', $a->{name}, $a->{orig}); - } - } -} - - -# returns alias IDs that are and were related to the given staff ID -sub dbStaffAliasIds { - my($self, $sid) = @_; - return $self->dbAll(q| - SELECT DISTINCT sa.aid - FROM changes c - JOIN staff_alias_hist sa ON sa.chid = c.id - WHERE c.type = 's' AND c.itemid = ?|, $sid); -} - -1; diff --git a/lib/VNDB/DB/Tags.pm b/lib/VNDB/DB/Tags.pm deleted file mode 100644 index 8c27e55f..00000000 --- a/lib/VNDB/DB/Tags.pm +++ /dev/null @@ -1,275 +0,0 @@ - -package VNDB::DB::Tags; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw|dbTagGet dbTTTree dbTagEdit dbTagAdd dbTagMerge dbTagLinks dbTagLinkEdit dbTagStats|; - - -# %options->{ id noid name search state meta 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{meta} ? ( - 't.meta = ?' => $o{meta}?1:0 ) : (), - ); - my @select = ( - qw|t.id t.meta t.name t.description t.state t.cat t.c_items|, - q|extract('epoch' from t.added) as added|, - $o{what} =~ /addedby/ ? ('t.addedby', 'u.username') : (), - ); - 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 meta description state cat| - }, $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}}); - } - $self->dbExec('DELETE FROM tags_vn WHERE tag = ?', $id) if $o{meta} || ($o{state} && $o{state} == 1); -} - - -# 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, meta, description, state, cat, addedby) VALUES (!l, ?) RETURNING id', - [ map $o{$_}, qw|name meta description state cat| ], $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 u.username t.name|) : (), - ); - - 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; -} - - -# Change a user's tags for a VN entry -sub dbTagLinkEdit { - my($self, $uid, $vid, $insert, $update, $delete, $overrule) = @_; - - # overrule - # 1. set ignore flag for everyone except $uid - $self->dbExec('UPDATE tags_vn SET ignore = ? WHERE tag = ? AND vid = ? AND uid <> ?', - $overrule->{$_}?1:0, $_, $vid, $uid) for(keys %$overrule); - # 2. make sure $uid isn't ignored when others are set to ignore - # (this happens when a mod takes over an other mods' overrule) - $self->dbExec('UPDATE tags_vn SET ignore = false WHERE tag = ? AND vid = ? AND uid = ?', - $_, $vid, $uid) for(grep $overrule->{$_}, keys %$overrule); - - # delete - $self->dbExec('DELETE FROM tags_vn WHERE vid = ? AND uid = ? AND tag IN(!l)', - $vid, $uid, [ keys %$delete ]) if keys %$delete; - - # insert - my $val = join ',', map '(?,?,?,?,?,?)', keys %$insert; - $self->dbExec("INSERT INTO tags_vn (tag, vid, uid, vote, spoiler, ignore) VALUES $val", map - +($_, $vid, $uid, $insert->{$_}[0], $insert->{$_}[1]<0?undef:$insert->{$_}[1], $insert->{$_}[2]?1:0), - keys %$insert) if keys %$insert; - - # update - $self->dbExec('UPDATE tags_vn SET vote = ?, spoiler = ?, date = NOW() WHERE tag = ? AND vid = ? AND uid = ?', - $update->{$_}[0], $update->{$_}[1]<0?undef:$update->{$_}[1], $_, $vid, $uid) for (keys %$update); -} - - -# Fetch all tags related to a VN -# Argument: %options->{ vid minrating 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($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), 0) as spoiler, - bool_or(tv.ignore) AS overruled - FROM tags t - JOIN tags_vn tv ON tv.tag = t.id - WHERE tv.vid = ? - GROUP BY t.id, t.name, t.cat - !s - ORDER BY !s|, - $o{vid}, defined $o{minrating} ? "HAVING $rating > $o{minrating}" : '', $order - ); - - return wantarray ? ($r, $np) : $r; -} - -1; - diff --git a/lib/VNDB/DB/Traits.pm b/lib/VNDB/DB/Traits.pm deleted file mode 100644 index 728e4e85..00000000 --- a/lib/VNDB/DB/Traits.pm +++ /dev/null @@ -1,111 +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 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} ] ) : (), - ); - - my @select = ( - qw|t.id t.meta t.name t.description t.state t.alias t."group" t."order" t.sexual t.c_items|, - 'tg.name AS groupname', 'tg."order" AS grouporder', q|extract('epoch' from t.added) as added|, - $o{what} =~ /addedby/ ? ('t.addedby', 'u.username') : (), - ); - 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 meta description state alias group order sexual| - }, $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, meta, description, state, alias, "group", "order", sexual, addedby) VALUES (!l, ?) RETURNING id', - [ map $o{$_}, qw|name meta description state alias group order sexual| ], $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 e6a85ba0..00000000 --- a/lib/VNDB/DB/ULists.pm +++ /dev/null @@ -1,353 +0,0 @@ - -package VNDB::DB::ULists; - -use strict; -use warnings; -use Exporter 'import'; - - -our @EXPORT = qw| - dbRListGet dbVNListGet dbVNListList dbVNListAdd dbVNListDel dbRListAdd dbRListDel - dbVoteGet dbVoteStats dbVoteAdd dbVoteDel - dbWishListGet dbWishListAdd dbWishListDel -|; - - -# 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 - ); -} - -# Options: uid vid -sub dbVNListGet { - my($self, %o) = @_; - - my %where = ( - 'uid = ?' => $o{uid}, - $o{vid} ? ('vid IN(!l)' => [ ref $o{vid} ? $o{vid} : [$o{vid}] ]) : (), - ); - - return $self->dbAll(q| - SELECT uid, vid, status - FROM vnlists - !W|, - \%where - ); -} - - -# Options: uid char voted page results sort reverse -# sort: title vote -sub dbVNListList { - my($self, %o) = @_; - $o{results} ||= 50; - $o{page} ||= 1; - - my %where = ( - 'vl.uid = ?' => $o{uid}, - defined($o{voted}) ? ('vo.vote !s NULL' => $o{voted} ? 'IS NOT' : 'IS') : (), - defined($o{status})? ('vl.status = ?' => $o{status}) : (), - $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 ) : (), - ); - - my $order = sprintf { - title => 'v.title %s', - vote => 'vo.vote %s NULLS LAST, v.title ASC', - }->{ $o{sort}||'title' }, $o{reverse} ? 'DESC' : 'ASC'; - - # execute query - my($r, $np) = $self->dbPage(\%o, qq| - SELECT vl.vid, v.title, v.original, vl.status, vl.notes, COALESCE(vo.vote, 0) AS vote - FROM vnlists vl - JOIN vn v ON v.id = vl.vid - LEFT JOIN votes vo ON vo.vid = vl.vid AND vo.uid = vl.uid - !W - ORDER BY !s|, - \%where, $order - ); - - # fetch releases and link to VNs - if(@$r) { - my %vns = map { - $_->{rels}=[]; - $_->{vid}, $_->{rels} - } @$r; - - my $rel = $self->dbAll(q| - SELECT rv.vid, rl.rid, r.title, r.original, r.released, r.type, 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 = ? - AND rv.vid IN(!l) - ORDER BY r.released ASC|, - $o{uid}, [ keys %vns ] - ); - - if(@$rel) { - my %rel = map { $_->{rid} => [] } @$rel; - push(@{$rel{$_->{id}}}, $_->{lang}) for (@{$self->dbAll(q| - SELECT id, lang - FROM releases_lang - WHERE id IN(!l)|, - [ keys %rel ] - )}); - for(@$rel) { - $_->{languages} = $rel{$_->{rid}}; - push @{$vns{$_->{vid}}}, $_; - } - } - } - - return wantarray ? ($r, $np) : $r; -} - - -# Arguments: uid vid status notes -# vid can be an arrayref only when the rows are already present, in which case an update is done -# status and notes can be undef when an update is done, in which case these fields aren't updated -sub dbVNListAdd { - my($self, $uid, $vid, $stat, $notes) = @_; - $self->dbExec( - 'UPDATE vnlists !H WHERE uid = ? AND vid IN(!l)', - {defined($stat) ? ('status = ?' => $stat ):(), - defined($notes)? ('notes = ?' => $notes):()}, - $uid, ref($vid) ? $vid : [ $vid ] - ) - || - $self->dbExec( - 'INSERT INTO vnlists (uid, vid, status, notes) VALUES(?, ?, ?, ?)', - $uid, $vid, $stat||0, $notes||'' - ); -} - - -# Arguments: uid, vid -sub dbVNListDel { - my($self, $uid, $vid) = @_; - $self->dbExec( - 'DELETE FROM vnlists WHERE uid = ? AND vid IN(!l)', - $uid, ref($vid) ? $vid : [ $vid ] - ); -} - - -# 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 ] - ); -} - - -# Options: uid vid hide hide_ign results page what sort reverse -# what: user, vn -sub dbVoteGet { - my($self, %o) = @_; - $o{results} ||= 50; - $o{page} ||= 1; - $o{what} ||= ''; - $o{sort} ||= 'date'; - $o{reverse} //= 1; - - my %where = ( - $o{uid} ? ( 'n.uid = ?' => $o{uid} ) : (), - $o{vid} ? ( 'n.vid = ?' => $o{vid} ) : (), - $o{hide} ? ( 'NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = n.uid AND key = \'hide_list\')' => 1 ) : (), - $o{hide_ign} ? ( '(NOT u.ign_votes OR u.id = ?)' => $self->authInfo->{id}||0 ) : (), - $o{vn_char} ? ( 'LOWER(SUBSTR(v.title, 1, 1)) = ?' => $o{vn_char} ) : (), - defined $o{vn_char} && !$o{vn_char} ? ( - '(ASCII(v.title) < 97 OR ASCII(v.title) > 122) AND (ASCII(v.title) < 65 OR ASCII(v.title) > 90)' => 1 ) : (), - $o{user_char} ? ( 'LOWER(SUBSTR(u.username, 1, 1)) = ?' => $o{user_char} ) : (), - defined $o{user_char} && !$o{user_char} ? ( - '(ASCII(u.username) < 97 OR ASCII(u.username) > 122) AND (ASCII(u.username) < 65 OR ASCII(u.username) > 90)' => 1 ) : (), - ); - - my @select = ( - qw|n.vid n.vote n.uid|, q|extract('epoch' from n.date) as date|, - $o{what} =~ /user/ ? ('u.username') : (), - $o{what} =~ /vn/ ? (qw|v.title v.original|) : (), - ); - - my @join = ( - $o{what} =~ /vn/ ? ( - 'JOIN vn v ON v.id = n.vid', - ) : (), - $o{what} =~ /user/ || $o{hide} ? ( - 'JOIN users u ON u.id = n.uid' - ) : (), - ); - - my $order = sprintf { - date => 'n.date %s', - username => 'u.username %s', - title => 'v.title %s', - vote => 'n.vote %s'.($o{what} =~ /vn/ ? ', v.title ASC' : $o{what} =~ /user/ ? ', u.username ASC' : ''), - }->{$o{sort}}, $o{reverse} ? 'DESC' : 'ASC'; - - my($r, $np) = $self->dbPage(\%o, q| - SELECT !s - FROM votes n - !s - !W - ORDER BY !s|, - join(',', @select), join(' ', @join), \%where, $order - ); - - return wantarray ? ($r, $np) : $r; -} - - -# Arguments: (uid|vid), id, use_ignore_list -# 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 $u = $self->authInfo->{id}; - 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 votes - !s - !W - GROUP BY (vote::numeric/10)::int|, - $ign ? 'JOIN users ON id = uid AND (NOT ign_votes'.($u?sprintf(' OR id = %d',$u):'').')' : '', - $col ? { '!s = ?' => [ $col, $id ] } : {}, - )}); - return $r; -} - - -# Adds a new vote or updates an existing one -# Arguments: vid, uid, vote -# vid can be an arrayref only when the rows are already present, in which case an update is done -sub dbVoteAdd { - my($self, $vid, $uid, $vote) = @_; - $self->dbExec(q| - UPDATE votes - SET vote = ? - WHERE vid IN(!l) - AND uid = ?|, - $vote, ref($vid) ? $vid : [$vid], $uid - ) || $self->dbExec(q| - INSERT INTO votes - (vid, uid, vote) - VALUES (!l)|, - [ $vid, $uid, $vote ] - ); -} - - -# Arguments: uid, vid -# vid can be an arrayref -sub dbVoteDel { - my($self, $uid, $vid) = @_; - $self->dbExec('DELETE FROM votes !W', - { 'vid IN(!l)' => [ref($vid)?$vid:[$vid]], 'uid = ?' => $uid } - ); -} - - -# %options->{ uid vid wstat what page results sort reverse } -# what: vn -# sort: title added wstat -sub dbWishListGet { - my($self, %o) = @_; - - $o{page} ||= 1; - $o{results} ||= 50; - $o{what} ||= ''; - - my %where = ( - 'wl.uid = ?' => $o{uid}, - $o{vid} ? ( 'wl.vid = ?' => $o{vid} ) : (), - defined $o{wstat} ? ( 'wl.wstat = ?' => $o{wstat} ) : (), - ); - - my $select = q|wl.vid, wl.wstat, extract('epoch' from wl.added) AS added|; - my @join; - if($o{what} =~ /vn/) { - $select .= ', v.title, v.original'; - push @join, 'JOIN vn v ON v.id = wl.vid'; - } - - no if $] >= 5.022, warnings => 'redundant'; - my $order = sprintf { - title => 'v.title %s', - added => 'wl.added %s', - wstat => 'wl.wstat %2$s, v.title ASC', - }->{ $o{sort}||'added' }, $o{reverse} ? 'DESC' : 'ASC', $o{reverse} ? 'ASC' : 'DESC'; - - my($r, $np) = $self->dbPage(\%o, q| - SELECT !s - FROM wlists wl - !s - !W - ORDER BY !s|, - $select, join(' ', @join), \%where, $order, - ); - - return wantarray ? ($r, $np) : $r; -} - - -# Updates or adds a whishlist item -# Arguments: vid, uid, wstat -sub dbWishListAdd { - my($self, $vid, $uid, $wstat) = @_; - $self->dbExec( - 'UPDATE wlists SET wstat = ? WHERE uid = ? AND vid IN(!l)', - $wstat, $uid, ref($vid) eq 'ARRAY' ? $vid : [ $vid ] - ) - || - $self->dbExec( - 'INSERT INTO wlists (uid, vid, wstat) VALUES(!l)', - [ $uid, $vid, $wstat ] - ); -} - - -# Arguments: uid, vids -sub dbWishListDel { - my($self, $uid, $vid) = @_; - $self->dbExec( - 'DELETE FROM wlists WHERE uid = ? AND vid IN(!l)', - $uid, ref($vid) eq 'ARRAY' ? $vid : [ $vid ] - ); -} - - -1; - diff --git a/lib/VNDB/DB/Users.pm b/lib/VNDB/DB/Users.pm deleted file mode 100644 index 84ff10f2..00000000 --- a/lib/VNDB/DB/Users.pm +++ /dev/null @@ -1,283 +0,0 @@ - -package VNDB::DB::Users; - -use strict; -use warnings; -use Exporter 'import'; - -our @EXPORT = qw| - dbUserGet dbUserEdit dbUserAdd dbUserDel dbUserPrefSet dbUserLogin dbUserLogout - dbUserUpdateLastUsed dbUserEmailExists dbUserGetMail dbUserSetMail dbUserSetPerm dbUserAdminSetPass - dbUserResetPass dbUserIsValidToken dbUserSetPass - dbNotifyGet dbNotifyMarkRead dbNotifyRemove - dbThrottleGet dbThrottleSet -|; - - -# %options->{ username session uid ip registered search results page what sort reverse notperm } -# what: notifycount stats scryptargs extended prefs hide_list -# sort: username registered votes changes tags -sub dbUserGet { - my $s = shift; - my %o = ( - page => 1, - results => 10, - what => '', - sort => '', - @_ - ); - - my $token = unpack 'H*', $o{session}||''; - $o{search} =~ s/%// if $o{search}; - my %where = ( - $o{username} ? ( - 'username = ?' => $o{username} ) : (), - $o{firstchar} ? ( - 'SUBSTRING(username from 1 for 1) = ?' => $o{firstchar} ) : (), - !$o{firstchar} && defined $o{firstchar} ? ( - 'ASCII(username) < 97 OR ASCII(username) > 122' => 1 ) : (), - $o{uid} && !ref($o{uid}) ? ( - 'id = ?' => $o{uid} ) : (), - $o{uid} && ref($o{uid}) ? ( - 'id IN(!l)' => [ $o{uid} ]) : (), - !$o{uid} && !$o{username} ? ( - 'id > 0' => 1 ) : (), - $o{ip} ? ( - 'ip !s ?' => [ $o{ip} =~ /\// ? '<<' : '=', $o{ip} ] ) : (), - $o{registered} ? ( - 'registered > to_timestamp(?)' => $o{registered} ) : (), - $o{search} ? ( - 'username ILIKE ?' => "%$o{search}%") : (), - $token ? ( - q|user_isloggedin(id, decode(?, 'hex')) IS NOT NULL| => $token ) : (), - $o{notperm} ? ( - 'perm & ~(?::smallint) > 0' => $o{notperm} ) : (), - ); - - my @select = ( - qw|id username c_votes c_changes c_tags|, - q|extract('epoch' from registered) as registered|, - $o{what} =~ /extended/ ? qw|perm ign_votes| : (), # mail - $o{what} =~ /hide_list/ ? 'up.value AS hide_list' : (), - $o{what} =~ /scryptargs/ ? 'user_getscryptargs(id) AS scryptargs' : (), - $o{what} =~ /notifycount/ ? - '(SELECT COUNT(*) FROM notifications WHERE uid = u.id AND read IS NULL) AS notifycount' : (), - $o{what} =~ /stats/ ? ( - '(SELECT COUNT(*) FROM rlists WHERE uid = u.id) AS releasecount', - '(SELECT COUNT(*) FROM vnlists WHERE uid = u.id) AS vncount', - '(SELECT COUNT(*) FROM threads_posts WHERE uid = u.id) AS postcount', - '(SELECT COUNT(*) FROM threads_posts WHERE uid = u.id AND num = 1) AS threadcount', - '(SELECT COUNT(DISTINCT tag) FROM tags_vn WHERE uid = u.id) AS tagcount', - '(SELECT COUNT(DISTINCT vid) FROM tags_vn WHERE uid = u.id) AS tagvncount', - ) : (), - $token ? qq|extract('epoch' from user_isloggedin(id, decode('$token', 'hex'))) as session_lastused| : (), - ); - - my @join = ( - $o{what} =~ /hide_list/ || $o{sort} eq 'votes' ? - "LEFT JOIN users_prefs up ON up.uid = u.id AND up.key = 'hide_list'" : (), - ); - - my $order = sprintf { - id => 'u.id %s', - username => 'u.username %s', - registered => 'u.registered %s', - votes => 'up.value NULLS FIRST, u.c_votes %s', - changes => 'u.c_changes %s', - tags => 'u.c_tags %s', - }->{ $o{sort}||'username' }, $o{reverse} ? 'DESC' : 'ASC'; - - my($r, $np) = $s->dbPage(\%o, q| - SELECT !s - FROM users u - !s - !W - ORDER BY !s|, - join(', ', @select), join(' ', @join), \%where, $order - ); - - if(@$r && $o{what} =~ /prefs/) { - my %r = map { - $r->[$_]{prefs} = {}; - ($r->[$_]{id}, $r->[$_]) - } 0..$#$r; - - $r{$_->{uid}}{prefs}{$_->{key}} = $_->{value} for (@{$s->dbAll(q| - SELECT uid, key, value - FROM users_prefs - WHERE uid IN(!l)|, - [ keys %r ] - )}); - } - return wantarray ? ($r, $np) : $r; -} - - -# uid, %options->{ columns in users table } -sub dbUserEdit { - my($s, $uid, %o) = @_; - - my %h; - defined $o{$_} && ($h{$_.' = ?'} = $o{$_}) - for (qw| username ign_votes email_confirmed |); - - return if scalar keys %h <= 0; - return $s->dbExec(q| - UPDATE users - !H - WHERE id = ?|, - \%h, $uid); -} - - -# username, mail, [ip] -sub dbUserAdd { - $_[0]->dbRow(q|INSERT INTO users (username, mail, ip) VALUES(?, ?, ?) RETURNING id|, $_[1], $_[2], $_[3]||$_[0]->reqIP)->{id}; -} - - -# uid -sub dbUserDel { - $_[0]->dbExec(q|DELETE FROM users WHERE id = ?|, $_[1]); -} - - -# uid, key, val -sub dbUserPrefSet { - my($s, $uid, $key, $val) = @_; - !$val ? $s->dbExec('DELETE FROM users_prefs WHERE uid = ? AND key = ?', $uid, $key) - : $s->dbExec('UPDATE users_prefs SET value = ? WHERE uid = ? AND key = ?', $val, $uid, $key) - || $s->dbExec('INSERT INTO users_prefs (uid, key, value) VALUES (?, ?, ?)', $uid, $key, $val); -} - - -# uid, encpass, token -sub dbUserLogin { - $_[0]->dbRow( - q|SELECT user_login(?, decode(?, 'hex'), decode(?, 'hex')) AS r|, - $_[1], unpack('H*', $_[2]), unpack('H*', $_[3]) - )->{r}||0; -} - - -# uid, token -sub dbUserLogout { - $_[0]->dbExec(q|SELECT user_logout(?, decode(?, 'hex'))|, $_[1], unpack 'H*', $_[2]); -} - - -# uid, token -sub dbUserUpdateLastUsed { - $_[0]->dbExec(q|SELECT user_update_lastused(?, decode(?, 'hex'))|, $_[1], unpack 'H*', $_[2]); -} - - -sub dbUserEmailExists { - $_[0]->dbRow(q|SELECT user_emailexists(?) AS r|, $_[1])->{r}; -} - - -sub dbUserIsValidToken { - $_[0]->dbRow(q|SELECT user_isvalidtoken(?, decode(?, 'hex')) AS r|, $_[1], unpack 'H*', $_[2])->{r}; -} - - -sub dbUserResetPass { - $_[0]->dbRow(q|SELECT user_resetpass(?, decode(?, 'hex')) AS r|, $_[1], unpack 'H*', $_[2])->{r}; -} - - -sub dbUserSetPass { - $_[0]->dbRow(q|SELECT user_setpass(?, decode(?, 'hex'), decode(?, 'hex')) AS r|, $_[1], unpack('H*', $_[2]), unpack('H*', $_[3]))->{r}; -} - - -sub dbUserGetMail { - $_[0]->dbRow(q|SELECT user_getmail(?, ?, decode(?, 'hex')) AS r|, $_[1], $_[2], unpack 'H*', $_[3])->{r}; -} - - -sub dbUserSetMail { - $_[0]->dbExec(q|SELECT user_setmail(?, ?, decode(?, 'hex'), ?)|, $_[1], $_[2], unpack('H*', $_[3]), $_[4]); -} - - -sub dbUserSetPerm { - $_[0]->dbExec(q|SELECT user_setperm(?, ?, decode(?, 'hex'), ?)|, $_[1], $_[2], unpack('H*', $_[3]), $_[4]); -} - - -sub dbUserAdminSetPass { - $_[0]->dbExec(q|SELECT user_admin_setpass(?, ?, decode(?, 'hex'), decode(?, 'hex'))|, $_[1], $_[2], unpack('H*', $_[3]), unpack('H*', $_[4])); -} - - -# %options->{ uid id what results page reverse } -# what: titles -sub dbNotifyGet { - my($s, %o) = @_; - $o{what} ||= ''; - $o{results} ||= 10; - $o{page} ||= 1; - - my %where = ( - 'n.uid = ?' => $o{uid}, - $o{id} ? ( - 'n.id = ?' => $o{id} ) : (), - defined($o{read}) ? ( - 'n.read !s' => $o{read} ? 'IS NOT NULL' : 'IS NULL' ) : (), - ); - - my @join = ( - $o{what} =~ /titles/ ? 'LEFT JOIN users u ON n.c_byuser = u.id' : (), - ); - - my @select = ( - qw|n.id n.ntype n.ltype n.iid n.subid|, - q|extract('epoch' from n.date) as date|, - q|extract('epoch' from n.read) as read|, - $o{what} =~ /titles/ ? qw|u.username n.c_title| : (), - ); - - my($r, $np) = $s->dbPage(\%o, q| - SELECT !s - FROM notifications n - !s - !W - ORDER BY n.id !s - |, join(', ', @select), join(' ', @join), \%where, $o{reverse} ? 'DESC' : 'ASC'); - return wantarray ? ($r, $np) : $r; -} - - -# ids -sub dbNotifyMarkRead { - my $s = shift; - $s->dbExec('UPDATE notifications SET read = NOW() WHERE id IN(!l)', \@_); -} - - -# ids -sub dbNotifyRemove { - my $s = shift; - $s->dbExec('DELETE FROM notifications WHERE id IN(!l)', \@_); -} - - -# ip -sub dbThrottleGet { - my $s = shift; - my $t = $s->dbRow("SELECT extract('epoch' from timeout) as timeout FROM login_throttle WHERE ip = ?", shift)->{timeout}; - return $t && $t >= time ? $t : time; -} - -# ip, timeout -sub dbThrottleSet { - my($s, $ip, $timeout) = @_; - !$timeout ? $s->dbExec('DELETE FROM login_throttle WHERE ip = ?', $ip) - : $s->dbExec('UPDATE login_throttle SET timeout = to_timestamp(?) WHERE ip = ?', $timeout, $ip) - || $s->dbExec('INSERT INTO login_throttle (ip, timeout) VALUES (?, to_timestamp(?))', $ip, $timeout); -} - -1; - diff --git a/lib/VNDB/DB/VN.pm b/lib/VNDB/DB/VN.pm deleted file mode 100644 index 55464728..00000000 --- a/lib/VNDB/DB/VN.pm +++ /dev/null @@ -1,365 +0,0 @@ - -package VNDB::DB::VN; - -use strict; -use warnings; -use TUWF 'sqlprint'; -use POSIX 'strftime'; -use Exporter 'import'; -use VNDB::Func 'gtintype', 'normalize_query'; - -our @EXPORT = qw|dbVNGet dbVNGetRev dbVNRevisionInsert dbVNImageId dbScreenshotAdd dbScreenshotGet dbScreenshotRandom dbVNImportSeiyuu|; - - -# Options: id, char, search, 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 -# What: extended anime staff seiyuu relations screenshots relgraph rating ranking wishlist vnlist -# Note: wishlist and vnlist are 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}; - - 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})) : (), - $uid && $o{ul_notblack} ? ( - 'v.id NOT IN(SELECT vid FROM wlists WHERE uid = ? AND wstat = 3)' => $uid ) : (), - $uid && defined $o{ul_onwish} ? ( - 'v.id !s IN(SELECT vid FROM wlists WHERE uid = ?)' => [ $o{ul_onwish} ? '' : 'NOT', $uid ] ) : (), - $uid && defined $o{ul_voted} ? ( - 'v.id !s IN(SELECT vid FROM votes WHERE uid = ?)' => [ $o{ul_voted} ? '' : 'NOT', $uid ] ) : (), - $uid && defined $o{ul_onlist} ? ( - 'v.id !s IN(SELECT vid FROM vnlists 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; - } - - my @join = ( - $o{what} =~ /relgraph/ ? - 'JOIN relgraphs vg ON vg.id = v.rgraph' : (), - $uid && $o{what} =~ /wishlist/ ? - 'LEFT JOIN wlists wl ON wl.vid = v.id AND wl.uid = ' . $uid : (), - $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_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| ) : (), - $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} =~ /wishlist/ ? 'wl.wstat' : (), - $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_platforms::text[], v.title, v.original, vo.rgraph'; - $select .= ', extract(\'epoch\' from c.added) as added, c.requester, c.comments, u.username, c.rev, c.ihid, c.ilock'; - $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, 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 s.hidden = FALSE AND 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 s.hidden = FALSE AND 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 ] - )}); - } - } - - 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|; - $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); -} - - -# returns seiyuus that voice characters referenced by $cids in VNs other than $vid -sub dbVNImportSeiyuu { - my($self, $vid, $cids) = @_; - return $self->dbAll(q| - SELECT DISTINCT ON(c.id) c.id AS cid, c.name AS c_name, sa.id AS sid, sa.aid, sa.name - FROM vn_seiyuu vs - JOIN chars c ON c.id = vs.cid - JOIN staff_alias sa ON sa.aid = vs.aid - WHERE vs.cid IN(!l) AND vs.id <> ?|, $cids, $vid); -} - - -1; diff --git a/lib/VNDB/Func.pm b/lib/VNDB/Func.pm deleted file mode 100644 index 6af8f5bf..00000000 --- a/lib/VNDB/Func.pm +++ /dev/null @@ -1,342 +0,0 @@ - -package VNDB::Func; - -use strict; -use warnings; -use TUWF ':html', 'kv_validate', 'xml_escape'; -use Exporter 'import'; -use POSIX 'strftime', 'ceil', 'floor'; -use JSON::XS; -use VNDBUtil; -our @EXPORT = (@VNDBUtil::EXPORT, qw| - clearfloat cssicon tagscore mt minage fil_parse fil_serialize parenttags - childtags charspoil imgpath imgurl - fmtvote fmtmedia fmtvnlen fmtage fmtdatestr fmtdate fmtuser fmtrating fmtspoil - json_encode json_decode script_json - form_compare -|); - - -# 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', ''; -} - - -# Draws a CSS icon, arguments: class, title -sub cssicon { - abbr class => "icons $_[0]", title => $_[1]; - lit ' '; - end; -} - - -# Tag score in html tags, argument: score, users -sub tagscore { - my $s = shift; - div class => 'taglvl', style => sprintf('width: %.0fpx', ($s-floor($s))*10), ' ' if $s < 0 && $s-floor($s) > 0; - for(-3..3) { - div(class => "taglvl taglvl0", sprintf '%.1f', $s), next if !$_; - if($_ < 0) { - if($s > 0 || floor($s) > $_) { - div class => "taglvl taglvl$_", ' '; - } elsif(floor($s) != $_) { - div class => "taglvl taglvl$_ taglvlsel", ' '; - } else { - div class => "taglvl taglvl$_ taglvlsel", style => sprintf('width: %.0fpx', 10-($s-$_)*10), ' '; - } - } else { - if($s < 0 || ceil($s) < $_) { - div class => "taglvl taglvl$_", ' '; - } elsif(ceil($s) != $_) { - div class => "taglvl taglvl$_ taglvlsel", ' '; - } else { - div class => "taglvl taglvl$_ taglvlsel", style => sprintf('width: %.0fpx', 10-($_-$s)*10), ' '; - } - } - } - div class => 'taglvl', style => sprintf('width: %.0fpx', (ceil($s)-$s)*10), ' ' if $s > 0 && ceil($s)-$s > 0; -} - - -# short wrapper around maketext() -sub mt { - return $TUWF::OBJ->{l10n}->maketext(@_); -} - - -sub minage { - my($a, $ex) = @_; - my $str = $a == -1 ? 'Unknown' : !$a ? 'All ages' : sprintf '%d+', $a; - $ex = !defined($a) ? '' : { - 0 => 'CERO A', - 12 => 'CERO B', - 15 => 'CERO C', - 17 => 'CERO D', - 18 => 'CERO Z', - }->{$a} if $ex; - return $str if !$ex; - return "$str (e.g. $ex)"; -} - - -# 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_~]+)$/ || !$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 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; -} - - -# 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'}}; - } - return @r; -} - - -# 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'; - } - end 'ul'; - clearfloat; - br; - end 'div'; -} - - -# generates the class elements for character spoiler hiding -sub charspoil { - return "charspoil charspoil_$_[0]".($_[0] ? ' hidden' : ''); -} - - -# generates a local path to an image in static/ -sub imgpath { # <type>, <id> - return sprintf '%s/static/%s/%02d/%d.jpg', $VNDB::ROOT, $_[0], $_[1]%100, $_[1]; -} - - -# 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]; -} - - -# Formats a vote number. -sub fmtvote { - return !$_[0] ? '-' : $_[0] % 10 == 0 ? $_[0]/10 : sprintf '%.1f', $_[0]/10; -} - -# Formats a media string ("1 CD", "2 CDs", "Internet download", etc) -sub fmtmedia { - my($med, $qty) = @_; - $med = $TUWF::OBJ->{media}{$med}; - join ' ', - ($med->[0] ? ($qty) : ()), - $med->[ $med->[0] && $qty > 1 ? 2 : 1 ]; -} - -# Formats a VN length (xtra = 1 for time indication, 2 for examples) -sub fmtvnlen { - my($len, $xtra) = @_; - $len = $TUWF::OBJ->{vn_lengths}[$len]; - $len->[0]. - ($xtra && $xtra == 1 && $len->[1] ? " ($len->[1])" : ''). - ($xtra && $xtra == 2 && $len->[2] ? " ($len->[2])" : ''); -} - -# Formats a UNIX timestamp as a '<number> <unit> ago' string -sub fmtage { - my $a = time-shift; - my($t, $single, $plural) = - $a > 60*60*24*365*2 ? ( $a/60/60/24/365, 'year', 'years' ) : - $a > 60*60*24*(365/12)*2 ? ( $a/60/60/24/(365/12), 'month', 'months' ) : - $a > 60*60*24*7*2 ? ( $a/60/60/24/7, 'week', 'weeks' ) : - $a > 60*60*24*2 ? ( $a/60/60/24, 'day', 'days' ) : - $a > 60*60*2 ? ( $a/60/60, 'hour', 'hours' ) : - $a > 60*2 ? ( $a/60, 'min', 'min' ) : - ( $a, 'sec', 'sec' ); - $t = sprintf '%d', $t; - 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; -} - -# Arguments: (uid, username), or a hashref containing that info -sub fmtuser { - my($id,$n) = ref($_[0]) eq 'HASH' ? ($_[0]{uid}||$_[0]{requester}, $_[0]{username}) : @_; - return !$id ? '[deleted]' : sprintf '<a href="/u%d">%s</a>', $id, xml_escape $n; -} - -# Turn a (natural number) vote into a rating indication -sub fmtrating { - ['worst ever', - 'awful', - 'bad', - 'weak', - 'so-so', - 'decent', - 'good', - 'very good', - 'excellent', - 'masterpiece']->[shift()-1]; -} - -# Turn a spoiler level into a string -sub fmtspoil { - ['neutral', - 'no spoiler', - 'minor spoiler', - 'major spoiler']->[shift()+1]; -} - - - -# 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(@_); -} - -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; -} - - - -# 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 || ref $o ne ref $n; - if(!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; -} - -1; - diff --git a/lib/VNDB/Handler/Affiliates.pm b/lib/VNDB/Handler/Affiliates.pm deleted file mode 100644 index efba6b18..00000000 --- a/lib/VNDB/Handler/Affiliates.pm +++ /dev/null @@ -1,152 +0,0 @@ - -package VNDB::Handler::Affiliates; - -use strict; -use warnings; -use TUWF ':html'; -use VNDB::Func; - - -TUWF::register( - qr{affiliates} => \&list, - qr{affiliates/del/([1-9]\d*)} => \&linkdel, - qr{affiliates/edit/([1-9]\d*)} => \&edit, - qr{affiliates/new} => \&edit, -); - - -sub list { - my $self = shift; - - return $self->htmlDenied if !$self->authCan('affiliate'); - my $f = $self->formValidate( - { get => 'a', required => 0, enum => [ 0..$#{$self->{affiliates}} ] }, - { get => 'h', required => 0, default => 0, enum => [ -1..1 ] }, - { get => 'o', required => 0, default => 'a', enum => ['a', 'd'] }, - { get => 's', required => 0, default => 'rel', enum => [qw|rel prio url lastfetch|] }, - ); - return $self->resNotFound if $f->{_err}; - - $self->htmlHeader(title => 'Affiliate administration interface'); - div class => 'mainbox'; - h1 'Affiliate administration interface'; - p class => 'browseopts'; - a defined($f->{a}) && $f->{a} == $_ ? (class => 'optselected') : (), href => "/affiliates?a=$_", $self->{affiliates}[$_]{name} - for (grep $self->{affiliates}[$_], 0..$#{$self->{affiliates}}); - end; - if(defined $f->{a}) { - p class => 'browseopts'; - a $f->{h} == -1 ? (class => 'optselected') : (), href => "/affiliates?a=$f->{a};h=-1",'all'; - a $f->{h} == 1 ? (class => 'optselected') : (), href => "/affiliates?a=$f->{a};h=1", 'hidden'; - a $f->{h} == 0 ? (class => 'optselected') : (), href => "/affiliates?a=$f->{a};h=0", 'non-hidden'; - end; - } - end; - - if(defined $f->{a}) { - my $list = $self->dbAffiliateGet( - affiliate => $f->{a}, hidden => $f->{h}==-1?undef:$f->{h}, - what => 'release', - sort => $f->{s}, reverse => $f->{o} eq 'd' - ); - $self->htmlBrowse( - items => $list, - nextpage => 0, - options => {p=>0, %$f}, - pageurl => '', - sorturl => "/affiliates?a=$f->{a};h=$f->{h}", - header => [ - ['Release', 'rel'], - ['Version'], - ['Hid'], - ['Prio', 'prio'], - ['Price / Lastfetch', 'lastfetch'], - ['', 'url' ] - ], - row => sub { - my($s, $n, $l) = @_; - Tr; - td class => 'tc1'; a href => "/r$l->{rid}", shorten $l->{title}, 50; end; - td class => 'tc2', $l->{version} || '<default>'; - td class => 'tc3', $l->{hidden} ? 'YES' : 'no'; - td class => 'tc4', $l->{priority}; - td class => 'tc5', sprintf '%s / %s', $l->{price}, $l->{lastfetch} ? fmtage($l->{lastfetch}) : '-'; - td class => 'tc6'; - a href => $l->{url}, 'link'; - txt ' | '; - a href => "/affiliates/edit/$l->{id}", 'edit'; - txt ' | '; - a href => "/affiliates/del/$l->{id}?formcode=".$self->authGetCode("/affiliates/del/$l->{id}"), 'del'; - end; - end; - }, - ); - } - $self->htmlFooter; -} - - -sub linkdel { - my($self, $id) = @_; - return $self->htmlDenied if !$self->authCan('affiliate'); - return if !$self->authCheckCode; - my $l = $self->dbAffiliateGet(id => $id)->[0]; - return $self->resNotFound if !$l; - $self->dbAffiliateDel($id); - $self->resRedirect("/affiliates?a=$l->{affiliate}"); -} - - -sub edit { - my($self, $id) = @_; - return $self->htmlDenied if !$self->authCan('affiliate'); - - my $r = $id && $self->dbAffiliateGet(id => $id)->[0]; - return $self->resNotFound if $id && !$r; - - my $frm; - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'rid', required => 1, template => 'id' }, - { post => 'priority', required => 0, default => 0, template => 'int' }, - { post => 'hidden', required => 0, default => 0, enum => [0,1] }, - { post => 'affiliate',required => 1, enum => [0..$#{$self->{affiliates}}] }, - { post => 'url', required => 1 }, - { post => 'version', required => 0, default => '' }, - { post => 'price', required => 0, default => '' }, - { post => 'lastfetch',required => 0, template => 'uint' }, - { post => 'data', required => 0, default => '' }, - ); - if(!$frm->{_err}) { - $self->dbAffiliateEdit($id, %$frm) if $id; - $self->dbAffiliateAdd(%$frm) if !$id; - return $self->resRedirect("/affiliates?a=$frm->{affiliate}", 'post'); - } - } - - if($id) { - $frm->{$_} = $r->{$_} for(qw|rid priority hidden affiliate url version price lastfetch data|); - } else { - $frm->{rid} = $self->reqGet('rid'); - } - - $self->htmlHeader(title => 'Edit affiliate link'); - $self->htmlForm({ frm => $frm, action => $id ? "/affiliates/edit/$id" : '/affiliates/new' }, 'blah' => [ 'Edit affiliate link', - [ input => short => 'rid', name => 'Release ID', width => 100 ], - [ input => short => 'priority', name => 'Priority', width => 50 ], - [ check => short => 'hidden', name => 'Hidden' ], - [ select => short => 'affiliate', name => 'Affiliate', options => [ map - [ $_, $self->{affiliates}[$_]{name} ], grep $self->{affiliates}[$_], 0..$#{$self->{affiliates}} ] ], - [ input => short => 'url', name => 'URL', width => 400 ], - [ input => short => 'version', name => 'Version', width => 400 ], - [ input => short => 'price', name => 'Price' ], - [ input => short => 'lastfetch', name => 'Lastfetch', post => ' UNIX timestamp' ], - [ input => short => 'data', name => 'Data', width => 400 ], - ]); - $self->htmlFooter; -} - - -1; - diff --git a/lib/VNDB/Handler/Chars.pm b/lib/VNDB/Handler/Chars.pm deleted file mode 100644 index d412aae9..00000000 --- a/lib/VNDB/Handler/Chars.pm +++ /dev/null @@ -1,586 +0,0 @@ - -package VNDB::Handler::Chars; - -use strict; -use warnings; -use TUWF ':html', 'uri_escape'; -use Exporter 'import'; -use VNDB::Func; -use List::Util 'min'; - -our @EXPORT = ('charOps', 'charTable', 'charBrowseTable'); - -TUWF::register( - qr{c([1-9]\d*)(?:\.([1-9]\d*))?} => \&page, - qr{c(?:([1-9]\d*)(?:\.([1-9]\d*))?/(edit|copy)|/new)} - => \&edit, - qr{c/([a-z0]|all)} => \&list, -); - - -sub page { - my($self, $id, $rev) = @_; - - my $method = $rev ? 'dbCharGetRev' : 'dbCharGet'; - my $r = $self->$method( - id => $id, - what => 'extended traits vns seiyuu', - $rev ? ( rev => $rev ) : () - )->[0]; - return $self->resNotFound if !$r->{id}; - - my $metadata = { - 'og:title' => $r->{name}, - 'og:description' => $r->{desc}, - 'og:image' => $r->{image} && imgurl(ch => $r->{image}), - }; - - $self->htmlHeader(title => $r->{name}, noindex => $rev, metadata => $metadata); - $self->htmlMainTabs(c => $r); - return if $self->htmlHiddenMessage('c', $r); - - if($rev) { - my $prev = $rev && $rev > 1 && $self->dbCharGetRev(id => $id, rev => $rev-1, what => 'extended traits vns')->[0]; - $self->htmlRevision('c', $prev, $r, - [ name => 'Name', diff => 1 ], - [ original => 'Original name', diff => 1 ], - [ alias => 'Aliases', diff => qr/[ ,\n\.]/ ], - [ desc => 'Description', diff => qr/[ ,\n\.]/ ], - [ gender => 'Gender', serialize => sub { $self->{genders}{$_[0]} } ], - [ b_month => 'Birthday/month',serialize => sub { $_[0]||'[empty]' } ], - [ b_day => 'Birthday/day', serialize => sub { $_[0]||'[empty]' } ], - [ s_bust => 'Bust', serialize => sub { $_[0]||'[empty]' } ], - [ s_waist => 'Waist', serialize => sub { $_[0]||'[empty]' } ], - [ s_hip => 'Hip', serialize => sub { $_[0]||'[empty]' } ], - [ height => 'Height', serialize => sub { $_[0]||'[empty]' } ], - [ weight => 'Weight', serialize => sub { $_[0]||'[empty]' } ], - [ bloodt => 'Blood type', serialize => sub { $self->{blood_types}{$_[0]} } ], - [ main => 'Main character',htmlize => sub { $_[0] ? sprintf '<a href="/c%d">c%d</a>', $_[0], $_[0] : '[empty]' } ], - [ main_spoil=> 'Spoiler', serialize => \&fmtspoil ], - [ image => 'Image', htmlize => sub { - return $_[0] ? sprintf '<img src="%s" />', imgurl(ch => $_[0]) : 'No image'; - }], - [ traits => 'Traits', join => '<br />', split => sub { - map sprintf('%s<a href="/i%d">%s</a> (%s)', $_->{group}?qq|<b class="grayedout">$_->{groupname} / </b> |:'', - $_->{tid}, $_->{name}, fmtspoil $_->{spoil}), @{$_[0]} - }], - [ vns => 'Visual novels', join => '<br />', split => sub { - map sprintf('<a href="/v%d">v%d</a> %s %s (%s)', $_->{vid}, $_->{vid}, - $_->{rid}?sprintf('[<a href="/r%d">r%d</a>]', $_->{rid}, $_->{rid}):'', - $self->{char_roles}{$_->{role}}[0], fmtspoil $_->{spoil}), @{$_[0]}; - }], - ); - } - - div class => 'mainbox'; - $self->htmlItemMessage('c', $r); - $self->charOps(1); - h1 $r->{name}; - h2 class => 'alttitle', $r->{original} if $r->{original}; - $self->charTable($r); - end; - - # TODO: ordering of these instances? - my $inst = []; - if(!$r->{main}) { - $inst = $self->dbCharGet(instance => $r->{id}, what => 'extended traits vns seiyuu'); - } else { - $inst = $self->dbCharGet(instance => $r->{main}, notid => $r->{id}, what => 'extended traits vns seiyuu'); - push @$inst, $self->dbCharGet(id => $r->{main}, what => 'extended traits vns seiyuu')->[0]; - } - if(@$inst) { - my $spoil = sub { local $_=shift; !$r->{main} ? $_->{main_spoil} : $_->{main_spoil} > $r->{main_spoil} ? $_->{main_spoil} : $r->{main_spoil} }; - my $minspoil = min map $spoil->($_), @$inst; - div class => 'mainbox '.charspoil($minspoil); - h1 'Other instances'; - $self->charTable($_, 1, $_ != $inst->[0], 0, $spoil->($_)) for @$inst; - end; - } - - $self->htmlFooter; -} - - -sub charOps { - my($self, $sexual) = @_; - my $spoil = $self->authPref('spoilers')||0; - p id => 'charops'; - # Note: Order of these links is hardcoded in JS - a href => '#', $spoil == $_ ? (class => 'sel') : (), ['Hide spoilers', 'Show minor spoilers', 'Spoil me!']->[$_] for (0..2); - a href => '#', class => 'sec'.($self->authPref('traits_sexual') ? ' sel' : ''), 'Show sexual traits' if $sexual; - end; -} - - -# 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}", $self->{genders}{$r->{gender}} if $r->{gender} ne 'unknown'; - span $self->{blood_types}{$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($r->{weight} || $r->{height} || $r->{s_bust} || $r->{s_waist} || $r->{s_hip}) { - Tr; - td class => 'key', 'Measurements'; - td join ', ', - $r->{height} ? "Height: $r->{height}cm" : (), - $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}||'??' : (); - 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; - } - - # 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 hidden' : ''); - span ', '; - 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) { - br if $first++; - my @r = @{$vns{$g}}; - # special case: all releases, no exceptions - if(!$vn && @r == 1 && !$r[0]{rid}) { - span class => charspoil $r[0]{spoil}; - txt $self->{char_roles}{$r[0]{role}}[0].' - '; - a href => "/v$r[0]{vid}/chars", $r[0]{vntitle}; - 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 $self->{char_roles}{$_->{role}}[0].' - '; - if($_->{rid}) { - b class => 'grayedout', "r$_->{rid}:"; - a href => "/r$_->{rid}", $_->{rtitle}; - } else { - txt 'All other releases'; - } - end; - } - 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 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 %{$self->{genders}} ] }, - { 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 => 0, template => 'uint', max => 32767 }, - { post => 'bloodt', required => 0, default => 'unknown', enum => [ keys %{$self->{blood_types}} ] }, - { 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 }, - ); - - # 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 - @traits = sort { $a->[0] <=> $b->[0] } map /^(\d+)-(\d+)$/&&[$1,$2], split / /, $frm->{traits}; - @vns = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } map [split /-/], split / /, $frm->{vns}; - $frm->{traits} = join(' ', map sprintf('%d-%d', @$_), @traits); - $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}; - - my %traits = @traits ? map +($_->{id}, 1), @{$self->dbTraitGet(results => 500, state => 2, id => [ map $_->[0], @traits ])} : (); - @traits = grep $traits{$_->[0]}, @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 => 'Gender',short => 'gender', options => [ - map [ $_, $self->{genders}{$_} ], keys %{$self->{genders}} ] ], - [ input => name => 'Birthday', short => 'bday', width => 100,post => ' MM-DD (e.g. "01-26" for the 26th of January)' ], - [ 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' ], - [ select => name => 'Blood type',short => 'bloodt', options => [ - map [ $_, $self->{blood_types}{$_} ], keys %{$self->{blood_types}} ] ], - [ 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", $_ eq $fch ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#'; - } - end; - - p class => 'filselect'; - a id => 'filselect', href => '#c'; - lit '<i>▸</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}", $self->{genders}{$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/Discussions.pm b/lib/VNDB/Handler/Discussions.pm deleted file mode 100644 index f7f26a5e..00000000 --- a/lib/VNDB/Handler/Discussions.pm +++ /dev/null @@ -1,703 +0,0 @@ - -package VNDB::Handler::Discussions; - -use strict; -use warnings; -use TUWF ':html', 'xml_escape', 'uri_escape'; -use POSIX 'ceil'; -use VNDB::Func; -use List::Util qw(first max); - - -TUWF::register( - qr{t([1-9]\d*)(?:/([1-9]\d*))?} => \&thread, - qr{t([1-9]\d*)(/[1-9]\d*)?/vote} => \&vote, - qr{t([1-9]\d*)\.([1-9]\d*)} => \&redirect, - qr{t/(all|db|an|ge|[vpu])([1-9]\d*)?} => \&board, - qr{t([1-9]\d*)/reply} => \&edit, - qr{t([1-9]\d*)\.([1-9]\d*)/edit} => \&edit, - qr{t/(db|an|ge|[vpu])([1-9]\d*)?/new} => \&edit, - qr{t/search} => \&search, - qr{t} => \&index, -); - - -sub caneditpost { - my($self, $post) = @_; - return $self->authCan('boardmod') || - ($self->authInfo->{id} && $post->{uid} == $self->authInfo->{id} && !$post->{hidden} && time()-$post->{date} < $self->{board_edit_time}) -} - - -sub thread { - my($self, $tid, $page) = @_; - $page ||= 1; - - my $t = $self->dbThreadGet(id => $tid, what => 'boardtitles poll')->[0]; - return $self->resNotFound if !$t->{id} || $t->{hidden} && !$self->authCan('boardmod'); - - my $p = $self->dbPostGet(tid => $tid, results => 25, page => $page, what => 'user'); - return $self->resNotFound if !$p->[0]; - - $self->htmlHeader(title => $t->{title}, noindex => 1); - div class => 'mainbox'; - h1 $t->{title}; - h2 'Posted in'; - ul; - for (sort { $a->{type}.$a->{iid} cmp $b->{type}.$b->{iid} } @{$t->{boards}}) { - li; - a href => "/t/$_->{type}", $self->{discussion_boards}{$_->{type}}; - if($_->{iid}) { - txt ' > '; - a style => 'font-weight: bold', href => "/t/$_->{type}$_->{iid}", "$_->{type}$_->{iid}"; - txt ':'; - a href => "/$_->{type}$_->{iid}", title => $_->{original}, $_->{title}; - } - end; - } - end; - end 'div'; - - _poll($self, $t, "/t$tid".($page > 1 ? "/$page" : '')) if $t->{haspoll}; - - $self->htmlBrowseNavigate("/t$tid/", $page, [ $t->{count}, 25 ], 't', 1); - div class => 'mainbox thread'; - table class => 'stripe'; - for my $i (0..$#$p) { - local $_ = $p->[$i]; - Tr $_->{deleted} ? (class => 'deleted') : (); - td class => 'tc1'; - a href => "/t$tid.$_->{num}", name => $_->{num}, "#$_->{num}"; - if(!$_->{hidden}) { - lit ' by '.fmtuser($_); - br; - txt fmtdate $_->{date}, 'full'; - } - end; - td class => 'tc2'; - if(caneditpost($self, $_)) { - i class => 'edit'; - txt '< '; - a href => "/t$tid.$_->{num}/edit", 'edit'; - txt ' >'; - end; - } - if($_->{hidden}) { - i class => 'deleted', 'Post deleted.'; - } else { - lit bb2html $_->{msg}; - i class => 'lastmod', 'Last modified on '.fmtdate($_->{edited}, 'full') if $_->{edited}; - } - end; - end; - } - end; - end 'div'; - $self->htmlBrowseNavigate("/t$tid/", $page, [ $t->{count}, 25 ], 'b', 1); - - if($t->{locked}) { - div class => 'mainbox'; - h1 'Reply'; - p class => 'center', 'This thread has been locked, you can\'t reply to it anymore'; - end; - } elsif($t->{count} <= $page*25 && $self->authCan('board')) { - form action => "/t$tid/reply", method => 'post', 'accept-charset' => 'UTF-8'; - div class => 'mainbox'; - fieldset class => 'submit'; - input type => 'hidden', class => 'hidden', name => 'formcode', value => $self->authGetCode("/t$tid/reply"); - h2; - txt 'Quick reply'; - b class => 'standout', ' (English please!)'; - end; - textarea name => 'msg', id => 'msg', rows => 4, cols => 50, ''; - br; - input type => 'submit', value => 'Reply', class => 'submit'; - input type => 'submit', value => 'Go advanced...', class => 'submit', name => 'fullreply'; - end; - end; - end 'form'; - } elsif(!$self->authCan('board')) { - div class => 'mainbox'; - h1 'Reply'; - p class => 'center', 'You must be logged in to reply to this thread.'; - end; - } - - $self->htmlFooter; -} - - -sub redirect { - my($self, $tid, $num) = @_; - $self->resRedirect("/t$tid".($num > 25 ? '/'.ceil($num/25) : '').'#'.$num, 'perm'); -} - - -# Arguments, action -# tid reply -# tid, 1 edit thread -# tid, num edit post -# type, (iid) start new thread -sub edit { - my($self, $tid, $num) = @_; - $num ||= 0; - - # in case we start a new thread, parse boards - my $board = ''; - if($tid !~ /^\d+$/) { - return $self->resNotFound if $tid =~ /(db|an|ge)/ && $num || $tid =~ /[vpu]/ && !$num; - $board = $tid.($num||''); - $tid = 0; - $num = 0; - } - - # get thread and post, if any - my $t = $tid && $self->dbThreadGet(id => $tid, what => 'boards poll')->[0]; - return $self->resNotFound if $tid && !$t->{id}; - - my $p = $num && $self->dbPostGet(tid => $tid, num => $num, what => 'user')->[0]; - return $self->resNotFound if $num && !$p->{num}; - - # are we allowed to perform this action? - return $self->htmlDenied if !$self->authCan('board') - || ($tid && ($t->{locked} || $t->{hidden}) && !$self->authCan('boardmod')) - || ($num && !caneditpost($self, $p)); - - # check form etc... - my $frm; - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - my $haspoll = $self->reqPost('poll') && 1; - $frm = $self->formValidate( - !$tid || $num == 1 ? ( - { post => 'title', maxlength => 50 }, - { post => 'boards', maxlength => 100 }, - $haspoll ? ( - { post => 'poll', required => 0 }, - { post => 'poll_question', required => 1, maxlength => 100 }, - { post => 'poll_options', required => 1, maxlength => 100*$self->{poll_options} }, - { post => 'poll_max_options', required => 1, default => 1, template => 'uint', min => 1, max => $self->{poll_options} }, - { post => 'poll_preview', required => 0 }, - { post => 'poll_recast', required => 0 }, - ) : (), - ) : (), - $self->authCan('boardmod') ? ( - { post => 'locked', required => 0 }, - { post => 'hidden', required => 0 }, - { post => 'nolastmod', required => 0 }, - ) : (), - { post => 'msg', maxlength => 32768 }, - { post => 'fullreply', required => 0 }, - ); - - $frm->{_err} = 1 if $frm->{fullreply}; - - # check for double-posting - push @{$frm->{_err}}, 'Please wait 30 seconds before making another post' if !$num && !$frm->{_err} && $self->dbPostGet( - uid => $self->authInfo->{id}, tid => $tid, mindate => time - 30, results => 1, $tid ? () : (num => 1))->[0]{num}; - - # Don't allow regular users to create more than 10 threads a day - push @{$frm->{_err}}, 'You can only create 5 threads every 24 hours' if - !$tid && !$self->authCan('boardmod') && - @{$self->dbPostGet(uid => $self->authInfo->{id}, mindate => time - 24*3600, num => 1)} >= 5; - - # parse and validate the boards - my @boards; - if(!$frm->{_err} && $frm->{boards}) { - for (split /[ ,]/, $frm->{boards}) { - my($ty, $id) = ($1, $2) if /^([a-z]{1,2})([0-9]*)$/; - push @boards, [ $ty, $id ] if !grep $_->[0].$_->[1] eq $ty.$id, @boards; - push @{$frm->{_err}}, "Wrong board: $_" if - !$ty || !$self->{discussion_boards}{$ty} - || $ty eq 'an' && ($id || !$self->authCan('boardmod')) - || $ty eq 'db' && $id - || $ty eq 'ge' && $id - || $ty eq 'v' && (!$id || !$self->dbVNGet(id => $id)->[0]{id}) - || $ty eq 'p' && (!$id || !$self->dbProducerGet(id => $id)->[0]{id}) - || $ty eq 'u' && (!$id || !$self->dbUserGet(uid => $id)->[0]{id}); - } - } - - # validate poll options - my @poll_options; - if(!$frm->{_err} && $haspoll) { - @poll_options = split /\s*\n\s*/, $frm->{poll_options}; - push @{$frm->{_err}}, [ 'poll_options', 'mincount', 2 ] if @poll_options < 2; - push @{$frm->{_err}}, [ 'poll_options', 'maxcount', $frm->{poll_max_options} ] if @poll_options > $self->{poll_options}; - push @{$frm->{_err}}, [ 'poll_max_options', 'template', 'uint' ] if @poll_options > 1 && @poll_options < $frm->{poll_max_options}; - } - - if(!$frm->{_err}) { - my($ntid, $nnum) = ($tid, $num); - - # create/edit thread - if(!$tid || $num == 1) { - my $pollchange = $haspoll && (!$t - || ($t->{poll_question}||'') ne $frm->{poll_question} - || $t->{poll_max_options} != $frm->{poll_max_options} - || join("\n", map $_->[1], @{$t->{poll_options}}) ne join("\n", @poll_options) - ); - my %thread = ( - title => $frm->{title}, - boards => \@boards, - hidden => $frm->{hidden}, - locked => $frm->{locked}, - poll_preview => $frm->{poll_preview}||0, - poll_recast => $frm->{poll_recast}||0, - !$haspoll ? ( - poll_question => undef # Make sure any existing poll gets deleted - ) : $pollchange ? ( - poll_question => $frm->{poll_question}, - poll_max_options => $frm->{poll_max_options}, - poll_options => \@poll_options - ) : (), - ); - $self->dbThreadEdit($tid, %thread) if $tid; - $ntid = $self->dbThreadAdd(%thread) if !$tid; - } - - # create/edit post - my %post = ( - msg => $self->bbSubstLinks($frm->{msg}), - hidden => $num != 1 && $frm->{hidden}, - lastmod => !$num || $frm->{nolastmod} ? 0 : time, - ); - $self->dbPostEdit($tid, $num, %post) if $num; - $nnum = $self->dbPostAdd($ntid, %post) if !$num; - - return $self->resRedirect("/t$ntid".($nnum > 25 ? '/'.ceil($nnum/25) : '').'#'.$nnum, 'post'); - } - } - - # fill out form if we have some data - if($p) { - $frm->{msg} ||= $p->{msg}; - $frm->{hidden} = $p->{hidden} if $num != 1 && !exists $frm->{hidden}; - if($num == 1) { - $frm->{boards} ||= join ' ', sort map $_->[1]?$_->[0].$_->[1]:$_->[0], @{$t->{boards}}; - $frm->{title} ||= $t->{title}; - $frm->{locked} //= $t->{locked}; - $frm->{hidden} //= $t->{hidden}; - if($t->{haspoll}) { - $frm->{poll} //= 1; - $frm->{poll_question} ||= $t->{poll_question}; - $frm->{poll_max_options} ||= $t->{poll_max_options}; - $frm->{poll_preview} //= $t->{poll_preview}; - $frm->{poll_recast} //= $t->{poll_recast}; - $frm->{poll_options} ||= join "\n", map $_->[1], @{$t->{poll_options}}; - } - } - } - delete $frm->{_err} unless ref $frm->{_err}; - $frm->{boards} ||= $board; - $frm->{poll_preview} //= 1; - $frm->{poll_max_options} ||= 1; - - # generate html - my $url = !$tid ? "/t/$board/new" : !$num ? "/t$tid/reply" : "/t$tid.$num/edit"; - my $title = !$tid ? 'Start new thread' : - !$num ? "Reply to $t->{title}" : - 'Edit post'; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlForm({ frm => $frm, action => $url }, 'postedit' => [$title, - [ static => label => 'Username', content => fmtuser($p ? ($p->{uid}, $p->{username}) : ($self->authInfo->{id}, $self->authInfo->{username})) ], - !$tid || $num == 1 ? ( - [ input => short => 'title', name => 'Thread title' ], - [ input => short => 'boards', name => 'Board(s)' ], - [ static => content => 'Read <a href="/d9.2">d9.2</a> for information about how to specify boards.' ], - $self->authCan('boardmod') ? ( - [ check => name => 'Locked', short => 'locked' ], - ) : (), - ) : ( - [ static => label => 'Topic', content => qq|<a href="/t$tid">|.xml_escape($t->{title}).'</a>' ], - ), - $self->authCan('boardmod') ? ( - [ check => name => 'Hidden', short => 'hidden' ], - $num ? ( - [ check => name => 'Don\'t update last modified field', short => 'nolastmod' ], - ) : (), - ) : (), - [ text => name => 'Message<br /><b class="standout">English please!</b>', short => 'msg', rows => 25, cols => 75 ], - [ static => content => 'See <a href="/d9.3">d9.3</a> for the allowed formatting codes' ], - (!$tid || $num == 1) ? ( - [ static => content => '<br />' ], - [ check => short => 'poll', name => 'Add poll' ], - $num && $frm->{poll_question} ? ( - [ static => content => '<b class="standout">All votes will be reset if any changes to the poll fields are made!</b>' ] - ) : (), - [ input => short => 'poll_question', name => 'Poll question', width => 250 ], - [ text => short => 'poll_options', name => "Poll options<br /><i>one per line,<br />$self->{poll_options} max</i>", rows => 8, cols => 35 ], - [ input => short => 'poll_max_options',width => 16, post => ' Number of options voter is allowed to choose' ], - [ check => short => 'poll_preview', name => 'Allow users to view poll results before voting' ], - [ check => short => 'poll_recast', name => 'Allow users to change their vote' ], - ) : (), - ]); - $self->htmlFooter; -} - - -sub vote { - my($self, $tid, $page) = @_; - return $self->htmlDenied if !$self->authCan('board'); - return if !$self->authCheckCode; - - my $url = '/t'.$tid.($page ? "/$page" : ''); - my $t = $self->dbThreadGet(id => $tid, what => 'poll')->[0]; - return $self->resNotFound if !$t; - - # user has already voted and poll doesn't allow to change a vote. - my $voted = ($self->dbPollStats($tid))[2][0]; - return $self->resRedirect($url, 'post') if $voted && !$t->{poll_recast}; - - my $f = $self->formValidate( - { post => 'option', multi => 1, mincount => 1, maxcount => $t->{poll_max_options}, enum => [ map $_->[0], @{$t->{poll_options}} ] } - ); - if($f->{_err}) { - $self->htmlHeader(title => 'Poll error'); - $self->htmlFormError($f, 1); - $self->htmlFooter; - return; - } - - $self->dbPollVote($t->{id}, $self->authInfo->{id}, @{$f->{option}}); - $self->resRedirect($url, 'post'); -} - - -sub board { - my($self, $type, $iid) = @_; - $iid ||= ''; - return $self->resNotFound if $type =~ /(db|an|ge|all)/ && $iid; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - ); - return $self->resNotFound if $f->{_err}; - - my $obj = !$iid ? undef : - $type eq 'u' ? $self->dbUserGet(uid => $iid, what => 'hide_list')->[0] : - $type eq 'p' ? $self->dbProducerGet(id => $iid)->[0] : - $self->dbVNGet(id => $iid)->[0]; - return $self->resNotFound if $iid && !$obj; - my $ititle = $obj && ($obj->{title}||$obj->{name}||$obj->{username}); - my $title = !$obj ? $self->{discussion_boards}{$type} || 'All boards' : "Related discussions for $ititle"; - - my($list, $np) = $self->dbThreadGet( - $type ne 'all' ? (type => $type) : (), - $iid ? (iid => $iid) : (), - results => 50, - page => $f->{p}, - what => 'firstpost lastpost boardtitles', - sort => $type eq 'an' ? 'id' : 'lastpost', reverse => 1, - ); - - $self->htmlHeader(title => $title, noindex => 1, feeds => [ $type eq 'an' ? 'announcements' : 'posts' ]); - - $self->htmlMainTabs($type, $obj, 'disc') if $iid; - form action => '/t/search', method => 'get'; - div class => 'mainbox'; - h1 $title; - p; - a href => '/t', 'Discussion board'; - txt ' > '; - a href => "/t/$type", $self->{discussion_boards}{$type}||'All boards'; - if($iid) { - txt ' > '; - a style => 'font-weight: bold', href => "/t/$type$iid", "$type$iid"; - txt ':'; - a href => "/$type$iid", $ititle; - } - end; - if(!$iid) { - fieldset class => 'search'; - input type => 'text', name => 'bq', id => 'bq', class => 'text'; - input type => 'hidden', name => 'b', value => $type if $type ne 'all'; - input type => 'submit', class => 'submit', value => 'Search!'; - end 'fieldset'; - } - p class => 'center'; - if(!@$list) { - b 'No related threads found'; - br; br; - a href => "/t/$type$iid/new", 'Why not create one yourself?'; - } else { - a href => '/t/'.($iid ? $type.$iid : $type ne 'ge' ? 'db' : $type).'/new', 'Start a new thread' if $type ne 'all'; - } - end; - end 'div'; - end 'form'; - - _threadlist($self, $list, $f, $np, "/t/$type$iid", $type.$iid) if @$list; - - $self->htmlFooter; -} - - -sub index { - my $self = shift; - - $self->htmlHeader(title => 'Discussion board index', noindex => 1, feeds => [ 'posts', 'announcements' ]); - form action => '/t/search', method => 'get'; - div class => 'mainbox'; - h1 'Discussion board index'; - fieldset class => 'search'; - input type => 'text', name => 'bq', id => 'bq', class => 'text'; - input type => 'submit', class => 'submit', value => 'Search!'; - end 'fieldset'; - p class => 'browseopts'; - a href => '/t/all', 'All boards'; - a href => '/t/'.$_, $self->{discussion_boards}{$_} - for (keys %{$self->{discussion_boards}}); - end; - end; - end; - - for (keys %{$self->{discussion_boards}}) { - my $list = $self->dbThreadGet( - type => $_, - results => /^(db|v|ge)$/ ? 10 : 5, - page => 1, - what => 'firstpost lastpost boardtitles', - sort => 'lastpost', reverse => 1, - ); - h1 class => 'boxtitle'; - a href => "/t/$_", $self->{discussion_boards}{$_}; - end; - _threadlist($self, $list, {p=>1}, 0, "/t", $_); - } - - $self->htmlFooter; -} - - -sub search { - my $self = shift; - - my $frm = $self->formValidate( - { get => 'bq', required => 0, maxlength => 100 }, - { get => 'b', required => 0, multi => 1, enum => [ keys %{$self->{discussion_boards}} ] }, - { get => 't', required => 0 }, - { get => 'p', required => 0, default => 1, template => 'page' }, - ); - return $self->resNotFound if $frm->{_err}; - - $self->htmlHeader(title => 'Search the discussion board', noindex => 1); - $self->htmlForm({ frm => $frm, action => '/t/search', method => 'get', nosubmit => 1, noformcode => 1 }, 'boardsearch' => ['Search the discussion board', - [ input => short => 'bq', name => 'Query' ], - [ check => short => 't', name => 'Only search thread titles' ], - [ select => short => 'b', name => 'Boards', multi => 1, size => scalar keys %{$self->{discussion_boards}}, - options => [ map [$_,$self->{discussion_boards}{$_}], keys %{$self->{discussion_boards}} ] ], - [ static => content => sub { - input type => 'submit', class => 'submit', tabindex => 10, value => 'Search!'; - } ], - ]); - return $self->htmlFooter if !$frm->{bq}; - - my %boards = map +($_,1), @{$frm->{b}}; - %boards = () if keys %boards == keys %{$self->{discussion_boards}}; - - my($l, $np); - if($frm->{t}) { - ($l, $np) = $self->dbThreadGet( - keys %boards ? ( type => [keys %boards] ) : (), - search => $frm->{bq}, - results => 50, - page => $frm->{p}, - what => 'firstpost lastpost boardtitles', - sort => 'lastpost', reverse => 1, - ); - } else { - # TODO: Allow or-matching too. But what syntax? - (my $ts = $frm->{bq}) =~ y{+|&:*()="';!?$%^\\[]{}<>~` }{ }s; - $ts =~ s/ +/ /; - $ts =~ s/^ //; - $ts =~ s/ $//; - $ts =~ s/ / & /g; - $ts =~ s/(?:^| )-([^ ]+)/ !$1 /; - ($l, $np) = $self->dbPostGet( - keys %boards ? ( type => [keys %boards] ) : (), - search => $ts, - results => 20, - page => $frm->{p}, - hide => 1, - what => 'thread user', - sort => 'date', reverse => 1, - headline => { - # 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 means we can re-use them for highlighting without - # worrying that they conflict with the message contents. - MaxFragments => 2, MinWords => 15, MaxWords => 40, StartSel => '[raw]', StopSel => '[/raw]', FragmentDelimiter => '[code]', - }, - ); - } - - my $url = '/t/search?'.join ';', 'bq='.uri_escape($frm->{bq}), $frm->{t} ? 't=1' : (), map "b=$_", keys %boards; - if(!@$l) { - div class => 'mainbox'; - h1 'No results'; - p 'No threads or messages found matching your criteria.'; - end; - } elsif($frm->{t}) { - _threadlist($self, $l, $frm, $np, $url, 'all'); - } else { - $self->htmlBrowse( - items => $l, - options => $frm, - nextpage => $np, - pageurl => $url, - class => 'postsearch', - header => [ - sub { td class => 'tc1_1', ''; td class => 'tc1_2', ''; }, - [ 'Date' ], - [ 'User' ], - [ 'Message' ], - ], - row => sub { - my($s, $n, $l) = @_; - my $link = "/t$l->{tid}.$l->{num}"; - Tr; - td class => 'tc1_1'; a href => $link, 't'.$l->{tid}; end; - td class => 'tc1_2'; a href => $link, '.'.$l->{num}; end; - td class => 'tc2', fmtdate $l->{date}; - td class => 'tc3'; lit fmtuser $l->{uid}, $l->{username}; end; - td class => 'tc4'; - div class => 'title'; - a href => $link, $l->{title}; - end; - my $h = xml_escape $l->{headline}; - $h =~ s/\[raw\]/<b class="standout">/g; - $h =~ s/\[\/raw\]/<\/b>/g; - $h =~ s/\[code\]/<b class="grayedout">...<\/b><br \/>/g; - div class => 'thread'; - lit $h; - end; - end; - end; - } - ); - } - $self->htmlFooter; -} - - -sub _threadlist { - my($self, $list, $f, $np, $url, $board) = @_; - $self->htmlBrowse( - items => $list, - options => $f, - nextpage => $np, - pageurl => $url, - class => 'discussions', - header => [ - [ 'Topic' ], - [ 'Replies' ], - [ 'Starter' ], - [ 'Last post' ], - ], - row => sub { - my($self, $n, $o) = @_; - Tr; - td class => 'tc1'; - a $o->{locked} ? ( class => 'locked' ) : (), href => "/t$o->{id}"; - span class => 'pollflag', '[poll]' if $o->{haspoll}; - txt shorten $o->{title}, 50; - end; - b class => 'boards'; - my $i = 1; - my @boards = sort { $a->{type}.$a->{iid} cmp $b->{type}.$b->{iid} } grep $_->{type}.($_->{iid}||'') ne $board, @{$o->{boards}}; - for(@boards) { - last if $i++ > 4; - txt ', ' if $i > 2; - a href => "/t/$_->{type}".($_->{iid}||''), - title => $_->{original}||$self->{discussion_boards}{$_->{type}}, - shorten $_->{title}||$self->{discussion_boards}{$_->{type}}, 30; - } - txt ', ...' if @boards > 4; - end; - end; - td class => 'tc2', $o->{count}-1; - td class => 'tc3'; - lit fmtuser $o->{fuid}, $o->{fusername}; - end; - td class => 'tc4'; - lit fmtuser $o->{luid}, $o->{lusername}; - lit ' @ '; - a href => "/t$o->{id}.$o->{count}", fmtdate $o->{ldate}, 'full'; - end; - end 'tr'; - } - ); -} - - -sub _poll { - my($self, $t, $url) = @_; - my($num_votes, $stats, $own_votes) = $self->dbPollStats($t->{id}); - my %own_votes = map +($_ => 1), @$own_votes; - my $preview = !@$own_votes && $self->reqGet('pollview') && $t->{poll_preview}; - my $allow_vote = $self->authCan('board') && (!@$own_votes || $t->{poll_recast}); - - div class => 'mainbox poll'; - form action => $url.'/vote', method => 'post'; - h1 class => 'question', $t->{poll_question}; - input type => 'hidden', name => 'formcode', value => $self->authGetCode($url.'/vote') if $allow_vote; - table class => 'votebooth'; - if($allow_vote && $t->{poll_max_options} > 1) { - thead; Tr; td colspan => 3; - i "You may choose up to $t->{poll_max_options} options"; - end; end; end; - } - tfoot; Tr; - td class => 'tc1'; - input type => 'submit', class => 'submit', value => 'Vote' if $allow_vote; - if(!$self->authCan('board')) { - b class => 'standout', 'You must be logged in to be able to vote.'; - } - end; - td class => 'tc2', colspan => 2; - if($t->{poll_preview} || @$own_votes) { - if(!$num_votes) { - i 'Nobody voted yet.'; - } elsif(!$preview && !@$own_votes) { - a href => $url.'?pollview=1', id => 'pollpreview', 'View results'; - } else { - txt sprintf '%d vote%s total', $num_votes, $num_votes == 1 ? '' : 's'; - } - } - end; - end; end; - tbody; - my $max = max values %$stats; - my $show_graph = $max && (@$own_votes || $preview); - my $graph_width = 200; - for my $opt (@{$t->{poll_options}}) { - my $votes = $stats->{$opt->[0]}; - my $own = exists $own_votes{$opt->[0]} ? ' own' : ''; - Tr $own ? (class => 'odd') : (); - td class => 'tc1'; - label; - input type => $t->{poll_max_options} > 1 ? 'checkbox' : 'radio', name => 'option', class => 'option', value => $opt->[0], $own ? (checked => '') : () if $allow_vote; - span class => 'option'.$own, $opt->[1]; - end; - end; - if($show_graph) { - td class => 'tc2'; - div class => 'graph', style => sprintf('width: %dpx', ($votes||0)/$max*$graph_width), ' '; - div class => 'number', $votes; - end; - td class => 'tc3', sprintf('%.3g%%', $votes ? $votes/$num_votes*100 : 0); - } else { - td class => 'tc2', colspan => 2, ''; - } - end; - } - end; - end 'table'; - end 'form'; - end 'div'; -} - - -1; - diff --git a/lib/VNDB/Handler/Misc.pm b/lib/VNDB/Handler/Misc.pm deleted file mode 100644 index e3b67d52..00000000 --- a/lib/VNDB/Handler/Misc.pm +++ /dev/null @@ -1,414 +0,0 @@ - -package VNDB::Handler::Misc; - - -use strict; -use warnings; -use TUWF ':html', ':xml', 'xml_escape', 'uri_escape'; -use VNDB::Func; -use POSIX 'strftime'; - - -TUWF::register( - qr{}, \&homepage, - qr{(?:([upvrcs])([1-9]\d*)/)?hist},\&history, - qr{d([1-9]\d*)}, \&docpage, - 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') }, - qr{d([1-9]\d*)\.([1-9]\d*)}, - sub { $_[0]->resRedirect("/d$_[1]#$_[2]", '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 => [ keys %{$self->{atom_feeds}} ], 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 ".fmtuser($_); - 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 $self->{discussion_boards}{$_->{type}}.($_->{iid}?' > '.$_->{title}:''), @{$_->{boards}}; - li; - txt fmtage($_->{ldate}).' '; - a href => "/t$_->{id}.$_->{count}", title => "Posted in $boards", shorten $_->{title}, 25; - lit ' by '.fmtuser($_->{luid}, $_->{lusername}); - 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 $_, $self->{platforms}{$_} for (@{$_->{platforms}}); - cssicon "lang $_", $self->{languages}{$_} 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 $_, $self->{platforms}{$_} for (@{$_->{platforms}}); - cssicon "lang $_", $self->{languages}{$_} for (@{$_->{languages}}); - txt ' '; - a href => "/r$_->{id}", title => $_->{original}||$_->{title}, shorten $_->{title}, 30; - end; - } - end; - end 'td'; - - end 'tr'; - end 'table'; - - $self->htmlFooter; -} - - -sub history { - my($self, $type, $id) = @_; - $type ||= ''; - $id ||= 0; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'm', required => 0, default => !$type, enum => [ 0, 1 ] }, - { get => 'h', required => 0, default => 0, enum => [ -1..1 ] }, - { get => 't', required => 0, default => '', enum => [qw|v r p c s a|] }, - { get => 'e', required => 0, default => 0, enum => [ -1..1 ] }, - { get => 'r', required => 0, default => 0, enum => [ 0, 1 ] }, - ); - return $self->resNotFound if $f->{_err}; - - # get item object and title - my $obj = $type eq 'u' ? $self->dbUserGet(uid => $id, what => 'hide_list')->[0] : - $type eq 'p' ? $self->dbProducerGet(id => $id)->[0] : - $type eq 'r' ? $self->dbReleaseGet(id => $id)->[0] : - $type eq 'c' ? $self->dbCharGet(id => $id)->[0] : - $type eq 's' ? $self->dbStaffGet(id => $id)->[0] : - $type eq 'v' ? $self->dbVNGet(id => $id)->[0] : undef; - return $self->resNotFound if $type && !$obj->{id}; - my $title = $type ? 'Edit history of '.($obj->{title} || $obj->{name} || $obj->{username}) : 'Recent changes'; - - # get the edit history - my($list, $np) = $self->dbRevisionGet( - $type && $type ne 'u' ? ( type => $type, itemid => $id ) : (), - $type eq 'u' ? ( uid => $id ) : (), - $f->{t} ? ( type => $f->{t} eq 'a' ? [qw|v r p s|] : $f->{t} ) : (), - page => $f->{p}, - results => 50, - auto => $f->{m}, - hidden => $type && $type ne 'u' ? 0 : $f->{h}, - edit => $f->{e}, - releases => $f->{r}, - ); - - $self->htmlHeader(title => $title, noindex => 1, feeds => [ 'changes' ]); - $self->htmlMainTabs($type, $obj, 'hist') if $type; - - # url generator - my $u = sub { - my($n, $v) = @_; - $n ||= ''; - local $_ = ($type ? "/$type$id" : '').'/hist'; - $_ .= '?m='.($n eq 'm' ? $v : $f->{m}); - $_ .= ';h='.($n eq 'h' ? $v : $f->{h}); - $_ .= ';t='.($n eq 't' ? $v : $f->{t}); - $_ .= ';e='.($n eq 'e' ? $v : $f->{e}); - $_ .= ';r='.($n eq 'r' ? $v : $f->{r}); - }; - - # filters - div class => 'mainbox'; - h1 $title; - if($type ne 'u') { - p class => 'browseopts'; - a !$f->{m} ? (class => 'optselected') : (), href => $u->(m => 0), 'Show automated edits'; - a $f->{m} ? (class => 'optselected') : (), href => $u->(m => 1), 'Hide automated edits'; - end; - } - if(!$type || $type eq 'u') { - if($self->authCan('dbmod')) { - p class => 'browseopts'; - a $f->{h} == 1 ? (class => 'optselected') : (), href => $u->(h => 1), 'Hide deleted items'; - a $f->{h} == -1 ? (class => 'optselected') : (), href => $u->(h => -1), 'Show deleted items'; - end; - } - p class => 'browseopts'; - a !$f->{t} ? (class => 'optselected') : (), href => $u->(t => ''), 'Show all items'; - a $f->{t} eq 'v' ? (class => 'optselected') : (), href => $u->(t => 'v'), 'Only visual novels'; - a $f->{t} eq 'r' ? (class => 'optselected') : (), href => $u->(t => 'r'), 'Only releases'; - a $f->{t} eq 'p' ? (class => 'optselected') : (), href => $u->(t => 'p'), 'Only producers'; - a $f->{t} eq 's' ? (class => 'optselected') : (), href => $u->(t => 's'), 'Only staff'; - a $f->{t} eq 'c' ? (class => 'optselected') : (), href => $u->(t => 'c'), 'Only characters'; - a $f->{t} eq 'a' ? (class => 'optselected') : (), href => $u->(t => 'a'), 'All except characters'; - end; - p class => 'browseopts'; - a !$f->{e} ? (class => 'optselected') : (), href => $u->(e => 0), 'Show all changes'; - a $f->{e} == 1 ? (class => 'optselected') : (), href => $u->(e => 1), 'Only edits'; - a $f->{e} == -1 ? (class => 'optselected') : (), href => $u->(e => -1), 'Only newly created pages'; - end; - } - if($type eq 'v') { - p class => 'browseopts'; - a !$f->{r} ? (class => 'optselected') : (), href => $u->(r => 0), 'Exclude edits of releases'; - a $f->{r} ? (class => 'optselected') : (), href => $u->(r => 1), 'Include edits of releases'; - end; - } - end 'div'; - - $self->htmlBrowseHist($list, $f, $np, $u->()); - $self->htmlFooter; -} - - -sub docpage { - my($self, $did) = @_; - - my $f = sprintf('%s/data/docs/%d', $VNDB::ROOT, $did); - my $F; - open($F, '<:utf8', $f) or return $self->resNotFound; - my @c = <$F>; - close $F; - - (my $title = shift @c) =~ s/^:TITLE://; - chomp $title; - - my($sec, $subsec) = (0,0); - for (@c) { - s{^:SUB:(.+)\r?\n$}{ - $sec++; - $subsec = 0; - qq|<h3><a href="#$sec" name="$sec">$sec. $1</a></h3>\n| - }e; - s{^:SUBSUB:(.+)\r?\n$}{ - $subsec++; - qq|<h4><a href="#$sec.$subsec" name="$sec.$subsec">$sec.$subsec. $1</a></h4>\n| - }e; - s{^:INC:(.+)\r?\n$}{ - $f = sprintf('%s/data/docs/%s', $VNDB::ROOT, $1); - open($F, '<:utf8', $f) or die $!; - my $ii = join('', <$F>); - close $F; - $ii; - }e; - s{^:MODERATORS:$}{ - my $l = $self->dbUserGet(results => 100, sort => 'id', notperm => $self->{default_perm}, what => 'extended'); - my $admin = 0; - $admin |= $_ for values %{$self->{permissions}}; - '<dl>'.join('', map { - my $u = $_; - my $p = $u->{perm} >= $admin ? 'admin' : join ', ', sort map +($u->{perm} &~ $self->{default_perm}) & $self->{permissions}{$_} ? $_ : (), keys %{$self->{permissions}}; - $p ? sprintf('<dt><a href="/u%d">%s</a></dt><dd>%s</dd>', $_->{id}, $_->{username}, $p) : () - } @$l).'</dl>'; - }e; - s{^:SKINCONTRIB:$}{ - my %users; - push @{$users{ $self->{skins}{$_}[1] }}, [ $_, $self->{skins}{$_}[0] ] - for sort { $self->{skins}{$a}[0] cmp $self->{skins}{$b}[0] } keys %{$self->{skins}}; - my $u = $self->dbUserGet(uid => [ keys %users ]); - '<dl>'.join('', map sprintf('<dt><a href="/u%d">%s</a></dt><dd>%s</dd>', - $_->{id}, $_->{username}, join(', ', map sprintf('<a href="?skin=%s">%s</a>', $_->[0], $_->[1]), @{$users{$_->{id}}}) - ), @$u).'</dl>'; - }e; - } - - $self->htmlHeader(title => $title); - div class => 'mainbox'; - h1 $title; - div class => 'docs'; - lit join '', @c; - end; - end; - $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" - if -s "$VNDB::ROOT/www/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 42c4e7f0..00000000 --- a/lib/VNDB/Handler/Producers.pm +++ /dev/null @@ -1,494 +0,0 @@ - -package VNDB::Handler::Producers; - -use strict; -use warnings; -use TUWF ':html', ':xml', 'xml_escape', 'html_escape'; -use VNDB::Func; - - -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}; - - my $metadata = { - 'og:title' => $p->{name}, - 'og:description' => $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 { $self->{producer_types}{$_[0]} } ], - [ name => 'Name (romaji)', diff => 1 ], - [ original => 'Original name', diff => 1 ], - [ alias => 'Aliases', diff => qr/[ ,\n\.]/ ], - [ lang => 'Language', serialize => sub { "$_[0] ($self->{languages}{$_[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]' - }], - [ desc => 'Description', diff => qr/[ ,\n\.]/ ], - [ relations => 'Relations', join => '<br />', split => sub { - my @r = map sprintf('%s: <a href="/p%d" title="%s">%s</a>', - $self->{prod_relations}{$_->{relation}}[1], $_->{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', $p->{original} if $p->{original}; - p class => 'center'; - txt "$self->{languages}{$p->{lang}} $self->{producer_types}{$p->{type}}"; - lit '<br />a.k.a. '.html_escape $p->{alias} if $p->{alias}; - - my @links = ( - $p->{website} ? [ 'Homepage', $p->{website} ] : (), - $p->{l_wp} ? [ 'Wikipedia', "http://en.wikipedia.org/wiki/$p->{l_wp}" ] : (), - ); - br if @links; - for(@links) { - a href => $_->[1], $_->[0]; - txt ' - ' if $_ ne $links[$#links]; - } - 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 %{$self->{prod_relations}}) { - next if !$rel{$r}; - txt $self->{prod_relations}{$r}[1].': '; - 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'); - 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 $_, $self->{platforms}{$_}; - } - cssicon "lang $_", $self->{languages}{$_} 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'; - if($rel->{website}) { - a href => $rel->{website}, rel => 'nofollow'; - cssicon 'external', 'External link'; - end; - } else { - txt ' '; - } - 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 /\s*,\s*/, $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.' ], - [ input => name => 'Aliases', short => 'alias', width => 400 ], - [ static => content => '(Un)official aliases, separated by a comma.' ], - ]); - $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 desc alias ihid ilock|), - l_wp => $p->{l_wp} || '', - 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 %{$self->{producer_types}} ] }, - { post => 'name', maxlength => 200 }, - { post => 'original', required => 0, maxlength => 200, default => '' }, - { post => 'alias', required => 0, maxlength => 500, default => '' }, - { post => 'lang', required => !$nosubmit, enum => [ keys %{$self->{languages}} ] }, - { post => 'website', required => 0, maxlength => 250, default => '', template => 'weburl' }, - { post => 'l_wp', required => 0, maxlength => 150, default => '' }, - { 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 }, - ); - 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; - $frm->{l_wp} = undef if !$frm->{l_wp}; - 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 [ $_, $self->{producer_types}{$_} ], keys %{$self->{producer_types}} ] ], - [ 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.' ], - [ input => name => 'Aliases', short => 'alias', width => 400 ], - [ static => content => '(Un)official aliases, separated by a comma.' ], - [ select => name => 'Primary language', short => 'lang', - options => [ map [ $_, "$_ ($self->{languages}{$_})" ], keys %{$self->{languages}} ] ], - [ input => name => 'Website', short => 'website' ], - [ input => name => 'Wikipedia link', short => 'l_wp', pre => 'http://en.wikipedia.org/wiki/' ], - [ 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 => $_, $self->{prod_relations}{$_}[1] - for (keys %{$self->{prod_relations}}); - 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{$_} = $self->{prod_relations}{$$new{$_}}[0]; - } - } - 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}, $self->{languages}{$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 $q = $self->formValidate({ get => 'q', maxlength => 500 }); - return $self->resNotFound if $q->{_err}; - $q = $q->{q}; - - my($list, $np) = $self->dbProducerGet( - $q =~ /^p([1-9]\d*)/ ? (id => $1) : (search => $q, sort => 'search'), - results => 10, - page => 1, - ); - - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'producers', more => $np ? 'yes' : 'no', query => $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 19fa0678..00000000 --- a/lib/VNDB/Handler/Releases.pm +++ /dev/null @@ -1,655 +0,0 @@ - -package VNDB::Handler::Releases; - -use strict; -use warnings; -use TUWF ':html', ':xml', 'uri_escape'; -use VNDB::Func; - - -TUWF::register( - qr{r([1-9]\d*)(?:\.([1-9]\d*))?} => \&page, - qr{(v)([1-9]\d*)/add} => \&edit, - qr{r} => \&browse, - qr{r(?:([1-9]\d*)(?:\.([1-9]\d*))?/(edit|copy))} - => \&edit, - qr{xml/releases.xml} => \&relxml, -); - - -sub page { - my($self, $rid, $rev) = @_; - - my $method = $rev ? 'dbReleaseGetRev' : 'dbReleaseGet'; - my $r = $self->$method( - id => $rid, - what => 'vn extended producers platforms media', - $rev ? (rev => $rev) : (), - )->[0]; - return $self->resNotFound if !$r->{id}; - - my $metadata = { - 'og:title' => $r->{title}, - 'og:description' => $r->{notes}, - }; - - $self->htmlHeader(title => $r->{title}, noindex => $rev, metadata => $metadata); - $self->htmlMainTabs('r', $r); - return if $self->htmlHiddenMessage('r', $r); - - if($rev) { - my $prev = $rev && $rev > 1 && $self->dbReleaseGetRev( - id => $rid, rev => $rev-1, - what => 'vn extended producers platforms media changes' - )->[0]; - $self->htmlRevision('r', $prev, $r, - [ vn => 'Relations', join => '<br />', split => sub { - map sprintf('<a href="/v%d" title="%s">%s</a>', $_->{vid}, $_->{original}||$_->{title}, shorten $_->{title}, 50), @{$_[0]}; - } ], - [ type => 'Type' ], - [ patch => 'Patch', serialize => sub { $_[0] ? 'Yes' : 'No' } ], - [ freeware => 'Freeware', serialize => sub { $_[0] ? 'Yes' : 'No' } ], - [ doujin => 'Doujin', serialize => sub { $_[0] ? 'Yes' : 'No' } ], - [ title => 'Title (romaji)', diff => 1 ], - [ original => 'Original title', diff => 1 ], - [ gtin => 'JAN/UPC/EAN', serialize => sub { $_[0]||'[empty]' } ], - [ catalog => 'Catalog number', serialize => sub { $_[0]||'[empty]' } ], - [ languages => 'Language', join => ', ', split => sub { map $self->{languages}{$_}, @{$_[0]} } ], - [ website => 'Website' ], - [ released => 'Release date', htmlize => \&fmtdatestr ], - [ minage => 'Age rating', serialize => \&minage ], - [ notes => 'Notes', diff => qr/[ ,\n\.]/ ], - [ platforms => 'Platforms', join => ', ', split => sub { map $self->{platforms}{$_}, @{$_[0]} } ], - [ media => 'Media', join => ', ', split => sub { map fmtmedia($_->{medium}, $_->{qty}), @{$_[0]} } ], - [ resolution => 'Resolution', serialize => sub { $self->{resolutions}[$_[0]][0]; } ], - [ voiced => 'Voiced', serialize => sub { $self->{voiced}[$_[0]] } ], - [ ani_story => 'Story animation', serialize => sub { $self->{animated}[$_[0]] } ], - [ ani_ero => 'Ero animation', serialize => sub { $self->{animated}[$_[0]] } ], - [ producers => 'Producers', join => '<br />', split => sub { - map sprintf('<a href="/p%d" title="%s">%s</a> (%s)', $_->{id}, $_->{original}||$_->{name}, shorten($_->{name}, 50), - join(', ', $_->{developer} ? 'developer' :(), $_->{publisher} ? 'publisher' :()) - ), @{$_[0]}; - } ], - ); - } - - div class => 'mainbox release'; - $self->htmlItemMessage('r', $r); - h1 $r->{title}; - h2 class => 'alttitle', $r->{original} if $r->{original}; - - _infotable($self, $r); - - if($r->{notes}) { - p class => 'description'; - lit bb2html $r->{notes}; - end; - } - - end; - $self->htmlFooter; -} - - -sub _infotable { - my($self, $r) = @_; - table class => 'stripe'; - - Tr; - td class => 'key', 'Relation'; - td; - for (@{$r->{vn}}) { - a href => "/v$_->{vid}", title => $_->{original}||$_->{title}, shorten $_->{title}, 60; - br if $_ != $r->{vn}[$#{$r->{vn}}]; - } - end; - end; - - Tr; - td 'Title'; - td $r->{title}; - end; - - if($r->{original}) { - Tr; - td 'Original title'; - td $r->{original}; - end; - } - - Tr; - td 'Type'; - td; - cssicon "rt$r->{type}", $r->{type}; - txt sprintf ' %s%s', ucfirst($r->{type}), $r->{patch} ? ', patch' : ''; - end; - end; - - Tr; - td 'Language'; - td; - for (@{$r->{languages}}) { - cssicon "lang $_", $self->{languages}{$_}; - txt ' '.$self->{languages}{$_}; - br if $_ ne $r->{languages}[$#{$r->{languages}}]; - } - end; - end; - - Tr; - td 'Publication'; - td join ', ', - $r->{freeware} ? 'Freeware' : 'Non-free', - $r->{patch} ? () : ($r->{doujin} ? 'doujin' : 'commercial'); - end; - - if(@{$r->{platforms}}) { - Tr; - td 'Platform'.(@{$r->{platforms}} == 1 ? '' : 's'); - td; - for(@{$r->{platforms}}) { - cssicon $_, $self->{platforms}{$_}; - txt ' '.$self->{platforms}{$_}; - br if $_ ne $r->{platforms}[$#{$r->{platforms}}]; - } - end; - end; - } - - if(@{$r->{media}}) { - Tr; - td @{$r->{media}} == 1 ? 'Medium' : 'Media'; - td join ', ', map fmtmedia($_->{medium}, $_->{qty}), @{$r->{media}}; - end; - } - - if($r->{resolution}) { - Tr; - td 'Resolution'; - td $self->{resolutions}[$r->{resolution}][0]; - end; - } - - if($r->{voiced}) { - Tr; - td 'Voiced'; - td $self->{voiced}[$r->{voiced}]; - end; - } - - if($r->{ani_story} || $r->{ani_ero}) { - Tr; - td 'Animation'; - td join ', ', - $r->{ani_story} ? "Story: $self->{animated}[$r->{ani_story}]" : (), - $r->{ani_ero} ? "Ero scenes: $self->{animated}[$r->{ani_ero}]" : (); - end; - } - - Tr; - td 'Released'; - td; - lit fmtdatestr $r->{released}; - end; - end; - - if($r->{minage} >= 0) { - Tr; - td 'Age rating'; - td minage $r->{minage}; - end; - } - - for my $t (qw|developer publisher|) { - my @prod = grep $_->{$t}, @{$r->{producers}}; - if(@prod) { - Tr; - td ucfirst($t).(@prod == 1 ? '' : 's'); - td; - for (@prod) { - a href => "/p$_->{id}", title => $_->{original}||$_->{name}, shorten $_->{name}, 60; - br if $_ != $prod[$#prod]; - } - end; - end; - } - } - - if($r->{gtin}) { - Tr; - td gtintype $r->{gtin}; - td $r->{gtin}; - end; - } - - if($r->{catalog}) { - Tr; - td 'Catalog no.'; - td $r->{catalog}; - end; - } - - if($r->{website}) { - Tr; - td 'Links'; - td; - a href => $r->{website}, rel => 'nofollow', 'Official website'; - end; - end; - } - - if($self->authInfo->{id}) { - my $rl = $self->dbRListGet(uid => $self->authInfo->{id}, rid => $r->{id})->[0]; - Tr; - td 'User options'; - td; - Select id => 'listsel', name => $self->authGetCode("/r$r->{id}/list"); - option value => -2, !$rl ? 'not on your list' : "Status: $self->{rlist_status}[$rl->{status}]"; - optgroup label => 'Set status'; - option value => $_, $self->{rlist_status}[$_] - for (0..$#{$self->{rlist_status}}); - end; - option value => -1, 'remove from list' if $rl; - end; - end; - end 'tr'; - } - - end 'table'; -} - - -# 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 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 gtin catalog languages website released minage - notes platforms patch resolution voiced freeware doujin ani_story ani_ero ihid ilock|), - 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; - $frm = $self->formValidate( - { post => 'type', enum => $self->{release_types} }, - { post => 'patch', required => 0, default => 0 }, - { post => 'freeware', required => 0, default => 0 }, - { post => 'doujin', 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 %{$self->{languages}} ] }, - { post => 'website', required => 0, default => '', maxlength => 250, template => 'weburl' }, - { post => 'released', required => 0, default => 0, template => 'rdate' }, - { post => 'minage' , required => 0, default => -1, enum => $self->{age_ratings} }, - { post => 'notes', required => 0, default => '', maxlength => 10240 }, - { post => 'platforms', required => 0, default => '', multi => 1, enum => [ keys %{$self->{platforms}} ] }, - { post => 'media', required => 0, default => '' }, - { post => 'resolution',required => 0, default => 0, enum => [ 0..$#{$self->{resolutions}} ] }, - { post => 'voiced', required => 0, default => 0, enum => [ 0..$#{$self->{voiced}} ] }, - { post => 'ani_story', required => 0, default => 0, enum => [ 0..$#{$self->{animated}} ] }, - { post => 'ani_ero', required => 0, default => 0, enum => [ 0..$#{$self->{animated}} ] }, - { post => 'producers', required => 0, default => '' }, - { post => 'vn', maxlength => 50000 }, - { post => 'editsum', template => 'editsum' }, - { post => 'ihid', required => 0 }, - { post => 'ilock', required => 0 }, - ); - - 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 ihid ilock|); - - # reset some fields when the patch flag is set - $frm->{doujin} = $frm->{resolution} = $frm->{voiced} = $frm->{ani_story} = $frm->{ani_ero} = 0 if $frm->{patch}; - - 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 - notes platforms resolution editsum patch voiced freeware doujin ani_story ani_ero ihid ilock|), - 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 [ $_, ucfirst $_ ], @{$self->{release_types}} ] ], - [ 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, - options => [ map [ $_, "$_ ($self->{languages}{$_})" ], keys %{$self->{languages}} ] ], - [ 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 ], @{$self->{age_ratings}} ] ], - [ 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.: Censored/uncensored or for which releases this patch applies.' ], - ], - - rel_format => [ 'Format', - [ select => short => 'resolution', name => 'Resolution', options => [ - map [ $_, @{$self->{resolutions}[$_]} ], 0..$#{$self->{resolutions}} ] ], - [ select => short => 'voiced', name => 'Voiced', options => [ - map [ $_, $self->{voiced}[$_] ], 0..$#{$self->{voiced}} ] ], - [ select => short => 'ani_story', name => 'Story animation', options => [ - map [ $_, $self->{animated}[$_] ], 0..$#{$self->{animated}} ] ], - [ select => short => 'ani_ero', name => 'Ero animation', options => [ - map [ $_, $_ ? $self->{animated}[$_] : 'Unknown / no ero scenes' ], 0..$#{$self->{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 %{$self->{platforms}}) { - span; - input type => 'checkbox', name => 'platforms', value => $p, id => $p, - $frm->{platforms} && grep($_ eq $p, @{$frm->{platforms}}) ? (checked => 'checked') : (); - label for => $p; - cssicon $p, $self->{platforms}{$p}; - txt ' '.$self->{platforms}{$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>▸</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 $_, $self->{platforms}{$_} for (@{$l->{platforms}}); - cssicon "lang $_", $self->{languages}{$_} 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 %{$self->{languages}} ] }, - { get => 'pl', required => 0, multi => 1, default => '', enum => [ keys %{$self->{platforms}} ] }, - { get => 'me', required => 0, multi => 1, default => '', enum => [ keys %{$self->{media}} ] }, - { get => 'tp', required => 0, default => '', enum => [ '', @{$self->{release_types}} ] }, - { 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 => $self->{age_ratings} }, - { get => 'mi', required => 0, default => 0, template => 'uint' }, - { get => 'ma', required => 0, default => 99999999, template => 'uint' }, - { get => 're', required => 0, multi => 1, default => 0, enum => [ 1..$#{$self->{resolutions}} ] }, - ); - return () if $f->{_err}; - $c{minage} = [ grep $_ >= 0 && ($f->{ma_m} ? $f->{ma_a} >= $_ : $f->{ma_a} <= $_), @{$self->{age_ratings}} ] 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{resolution} = $f->{re} if $f->{re}[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 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 $list = $self->dbReleaseGet(vid => $f->{v}, results => 100, what => 'vn'); - my %vns = map +($_,0), @{$f->{v}}; - for my $r (@$list) { - for my $v (@{$r->{vn}}) { - next if !exists $vns{$v->{vid}}; - $vns{$v->{vid}} = [ $v ] if !$vns{$v->{vid}}; - push @{$vns{$v->{vid}}}, $r; - } - } - !$vns{$_} && delete $vns{$_} for(keys %vns); - $self->resHeader('Content-type' => 'text/xml; charset=UTF-8'); - xml; - tag 'vns'; - for (sort { $a->[0]{title} cmp $b->[0]{title} } values %vns) { - next if !$_; - my $v = shift @$_; - tag 'vn', id => $v->{vid}, title => $v->{title}; - tag 'release', id => $_->{id}, lang => join(',', @{$_->{languages}}), $_->{title} - for (@$_); - end; - } - end; -} - - -1; - diff --git a/lib/VNDB/Handler/Staff.pm b/lib/VNDB/Handler/Staff.pm deleted file mode 100644 index ca2f9842..00000000 --- a/lib/VNDB/Handler/Staff.pm +++ /dev/null @@ -1,392 +0,0 @@ - -package VNDB::Handler::Staff; - -use strict; -use warnings; -use TUWF qw(:html :xml uri_escape xml_escape); -use VNDB::Func; -use List::Util qw(first); - -TUWF::register( - qr{s([1-9]\d*)(?:\.([1-9]\d*))?} => \&page, - qr{s(?:([1-9]\d*)(?:\.([1-9]\d*))?/edit|/new)} - => \&edit, - qr{s/([a-z0]|all)} => \&list, - qr{xml/staff\.xml} => \&staffxml, -); - - -sub page { - my($self, $id, $rev) = @_; - - my $method = $rev ? 'dbStaffGetRev' : 'dbStaffGet'; - my $s = $self->$method( - id => $id, - what => 'extended aliases roles', - $rev ? ( rev => $rev ) : () - )->[0]; - return $self->resNotFound if !$s->{id}; - - my $metadata = { - 'og:title' => $s->{name}, - 'og:description' => $s->{desc}, - }; - - $self->htmlHeader(title => $s->{name}, noindex => $rev, metadata => $metadata); - $self->htmlMainTabs('s', $s) if $id; - return if $self->htmlHiddenMessage('s', $s); - - if($rev) { - my $prev = $rev && $rev > 1 && $self->dbStaffGetRev(id => $id, rev => $rev-1, what => 'extended aliases')->[0]; - $self->htmlRevision('s', $prev, $s, - [ name => 'Name (romaji)', diff => 1 ], - [ original => 'Original name', diff => 1 ], - [ gender => 'Gender', serialize => sub { $self->{genders}{$_[0]} } ], - [ lang => 'Language', serialize => sub { "$_[0] ($self->{languages}{$_[0]})" } ], - [ l_site => 'Official page', 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_twitter => 'Twitter account', diff => 1 ], - [ l_anidb => 'AniDB creator ID', serialize => sub { $_[0] // '' } ], - [ desc => 'Description', diff => qr/[ ,\n\.]/ ], - [ aliases => 'Aliases', join => '<br />', split => sub { - map xml_escape(sprintf('%s%s', $_->{name}, $_->{original} ? ' ('.$_->{original}.')' : '')), @{$_[0]}; - }], - ); - } - - div class => 'mainbox staffpage'; - $self->htmlItemMessage('s', $s); - h1 $s->{name}; - h2 class => 'alttitle', $s->{original} if $s->{original}; - - # info table - table class => 'stripe'; - thead; - Tr; - td colspan => 2; - b style => 'margin-right: 10px', $s->{name}; - b class => 'grayedout', style => 'margin-right: 10px', $s->{original} if $s->{original}; - cssicon "gen $s->{gender}", $self->{genders}{$s->{gender}} if $s->{gender} ne 'unknown'; - end; - end; - end; - Tr; - td class => 'key', 'Language'; - td $self->{languages}{$s->{lang}}; - end; - if(@{$s->{aliases}}) { - Tr; - td class => 'key', @{$s->{aliases}} == 1 ? 'Alias' : 'Aliases'; - td; - table class => 'aliases'; - for my $alias (@{$s->{aliases}}) { - Tr class => 'nostripe'; - td $alias->{original} ? () : (colspan => 2), class => 'key'; - txt $alias->{name}; - end; - td $alias->{original} if $alias->{original}; - end; - } - end; - end; - end; - } - my @links = ( - $s->{l_site} ? [ 'Official page', $s->{l_site} ] : (), - $s->{l_wp} ? [ 'Wikipedia', "http://en.wikipedia.org/wiki/$s->{l_wp}" ] : (), - $s->{l_twitter} ? [ 'Twitter', "https://twitter.com/$s->{l_twitter}" ] : (), - $s->{l_anidb} ? [ 'AniDB', "http://anidb.net/cr$s->{l_anidb}" ] : (), - ); - if(@links) { - Tr; - td class => 'key', 'Links'; - td; - for(@links) { - a href => $_->[1], $_->[0]; - br if $_ != $links[$#links]; - } - end; - end; - } - end 'table'; - - # description - p class => 'description'; - lit bb2html $s->{desc}, 0, 1; - end; - end; - - _roles($self, $s); - _cast($self, $s); - $self->htmlFooter; -} - - -sub _roles { - my($self, $s) = @_; - return if !@{$s->{roles}}; - - h1 class => 'boxtitle', 'Credits'; - $self->htmlBrowse( - items => $s->{roles}, - class => 'staffroles', - header => [ - [ 'Title' ], - [ 'Released' ], - [ 'Role' ], - [ 'As' ], - [ 'Note' ], - ], - row => sub { - my($r, $n, $l) = @_; - Tr; - td class => 'tc1'; a href => "/v$l->{vid}", title => $l->{t_original}||$l->{title}, shorten $l->{title}, 60; end; - td class => 'tc2'; lit fmtdatestr $l->{c_released}; end; - td class => 'tc3', $self->{staff_roles}{$l->{role}}; - td class => 'tc4', title => $l->{original}||$l->{name}, $l->{name}; - td class => 'tc5', $l->{note}; - end; - }, - ); -} - - -sub _cast { - my($self, $s) = @_; - return if !@{$s->{cast}}; - - h1 class => 'boxtitle', sprintf 'Voiced characters (%d)', scalar @{$s->{cast}}; - $self->htmlBrowse( - items => $s->{cast}, - class => 'staffroles', - header => [ - [ 'Title' ], - [ 'Released' ], - [ 'Cast' ], - [ 'As' ], - [ 'Note' ], - ], - row => sub { - my($r, $n, $l) = @_; - Tr; - td class => 'tc1'; a href => "/v$l->{vid}", title => $l->{t_original}||$l->{title}, shorten $l->{title}, 60; end; - td class => 'tc2'; lit fmtdatestr $l->{c_released}; end; - td class => 'tc3'; a href => "/c$l->{cid}", title => $l->{c_original}, $l->{c_name}; end; - td class => 'tc4', title => $l->{original}||$l->{name}, $l->{name}; - td class => 'tc5', $l->{note}; - end; - }, - ); -} - - -sub edit { - my($self, $sid, $rev) = @_; - - my $s = $sid && $self->dbStaffGetRev(id => $sid, what => 'extended aliases roles', $rev ? (rev => $rev) : ())->[0]; - return $self->resNotFound if $sid && !$s->{id}; - $rev = undef if !$s || $s->{lastrev}; - - return $self->htmlDenied if !$self->authCan('edit') - || $sid && (($s->{locked} || $s->{hidden}) && !$self->authCan('dbmod')); - - my %b4 = !$sid ? () : ( - (map { $_ => $s->{$_} } qw|name original gender lang desc l_wp l_site l_twitter l_anidb ihid ilock|), - primary => $s->{aid}, - aliases => [ - map +{ aid => $_->{aid}, name => $_->{name}, orig => $_->{original} }, - sort { $a->{name} cmp $b->{name} || $a->{original} cmp $b->{original} } @{$s->{aliases}} - ], - ); - 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 => 'primary', required => 0, template => 'id', default => 0 }, - { post => 'desc', required => 0, maxlength => 5000, default => '' }, - { post => 'gender', required => 0, default => 'unknown', enum => [qw|unknown m f|] }, - { post => 'lang', enum => [ keys %{$self->{languages}} ] }, - { post => 'l_wp', required => 0, maxlength => 150, default => '' }, - { post => 'l_site', required => 0, template => 'weburl', maxlength => 250, default => '' }, - { post => 'l_twitter', required => 0, maxlength => 16, default => '', regex => [ qr/^\S+$/, 'Invalid twitter username' ] }, - { post => 'l_anidb', required => 0, template => 'id', default => undef }, - { post => 'aliases', template => 'json', json_sort => ['name','orig'], json_fields => [ - { field => 'name', required => 1, maxlength => 200 }, - { field => 'orig', required => 0, maxlength => 200, default => '' }, - { field => 'aid', required => 0, template => 'id', default => 0 }, - ]}, - { post => 'editsum', template => 'editsum' }, - { post => 'ihid', required => 0 }, - { post => 'ilock', required => 0 }, - ); - - if(!$frm->{_err}) { - my %old_aliases = $sid ? ( map +($_->{aid} => 1), @{$self->dbStaffAliasIds($sid)} ) : (); - $frm->{primary} = 0 unless exists $old_aliases{$frm->{primary}}; - - # reset aid to zero for newly added aliases. - $_->{aid} *= $old_aliases{$_->{aid}} ? 1 : 0 for(@{$frm->{aliases}}); - - # Make sure no aliases that have been linked to a VN are removed. - my %new_aliases = map +($_, 1), grep $_, $frm->{primary}, map $_->{aid}, @{$frm->{aliases}}; - $frm->{_err} = [ "Can't remove an alias that is still linked to a VN." ] - if grep !$new_aliases{$_->{aid}}, @{$s->{roles}}, @{$self->{cast}}; - } - - if(!$frm->{_err}) { - $frm->{ihid} = $frm->{ihid} ?1:0; - $frm->{ilock} = $frm->{ilock}?1:0; - $frm->{aid} = $frm->{primary} if $sid; - $frm->{desc} = $self->bbSubstLinks($frm->{desc}); - return $self->resRedirect("/s$sid", 'post') if $sid && !form_compare(\%b4, $frm); - - my $nrev = $self->dbItemEdit(s => $sid ? ($s->{id}, $s->{rev}) : (undef, undef), %$frm); - return $self->resRedirect("/s$nrev->{itemid}.$nrev->{rev}", 'post'); - } - } - - $frm->{$_} //= $b4{$_} for keys %b4; - $frm->{editsum} //= sprintf 'Reverted to revision s%d.%d', $sid, $rev if $rev; - $frm->{lang} = 'ja' if !$sid && !defined $frm->{lang}; - - my $title = $s ? "Edit $s->{name}" : 'Add staff member'; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('s', $s, 'edit') if $s; - $self->htmlEditMessage('s', $s, $title); - $self->htmlForm({ frm => $frm, action => $s ? "/s$sid/edit" : '/s/new', editsum => 1 }, - staffe_geninfo => [ 'General info', - [ hidden => short => 'name' ], - [ hidden => short => 'original' ], - [ hidden => short => 'primary' ], - [ json => short => 'aliases' ], - $sid && @{$s->{aliases}} ? - [ static => content => 'You may choose a different primary name.' ] : (), - [ static => label => 'Names', content => sub { - table id => 'names'; - thead; Tr; - td class => 'tc_id'; end; - td class => 'tc_name', 'Name (romaji)'; - td class => 'tc_original', 'Original'; td; end; - end; end; - tbody id => 'alias_tbl'; - # filled with javascript - end; - end; - }], - [ static => content => '<br />' ], - [ text => name => 'Staff note<br /><b class="standout">English please!</b>', short => 'desc', rows => 4 ], - [ select => name => 'Gender',short => 'gender', options => [ - map [ $_, $self->{genders}{$_} ], qw(unknown m f) ] ], - [ select => name => 'Primary language', short => 'lang', - options => [ map [ $_, "$_ ($self->{languages}{$_})" ], keys %{$self->{languages}} ] ], - [ input => name => 'Official page', short => 'l_site' ], - [ input => name => 'Wikipedia link', short => 'l_wp', pre => 'http://en.wikipedia.org/wiki/' ], - [ input => name => 'Twitter username', short => 'l_twitter' ], - [ input => name => 'AniDB creator ID', short => 'l_anidb' ], - [ static => content => '<br />' ], - ]); - - $self->htmlFooter; -} - - -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>▸</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; - my $gender = $list->[$_]{gender}; - cssicon 'lang '.$list->[$_]{lang}, $self->{languages}{$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 $q = $self->formValidate({ get => 'q', required => 0, maxlength => 500 }); - return $self->resNotFound if $q->{_err} || !$q->{q}; - - my($list, $np) = $self->dbStaffGet( - $q->{q} =~ /^s([1-9]\d*)/ ? (id => $1) : $q->{q} =~ /^=(.+)/ ? (exact => $1) : (search => $q->{q}, sort => 'search'), - results => 10, 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 => $_->{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 43215fde..00000000 --- a/lib/VNDB/Handler/Tags.pm +++ /dev/null @@ -1,762 +0,0 @@ - -package VNDB::Handler::Tags; - - -use strict; -use warnings; -use TUWF ':html', ':xml', 'xml_escape'; -use VNDB::Func; - - -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{g/links}, \&taglinks, - qr{v([1-9]\d*)/tagmod}, \&vntagmod, - 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->{meta} || $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 = ($t->{meta} ? 'Meta tag: ' : '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; - } - p class => 'center'; - b 'Category'; - br; - txt $self->{tag_categories}{$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->{meta} && $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};m=0", $f->{m} == 0 ? (class => 'optselected') : (), 'Hide spoilers'; - a href => "/g$t->{id}?fil=$f->{fil};m=1", $f->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers'; - a href => "/g$t->{id}?fil=$f->{fil};m=2", $f->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!'; - end; - - p class => 'filselect'; - a id => 'filselect', href => '#v'; - lit '<i>▸</i> Filters<i></i>'; - end; - end; - input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil}; - - 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; - } - p; br; txt 'The list below also includes all visual novels linked to child tags. This list is cached, it can take up to 24 hours after a visual novel has been tagged for it to show up on this page.'; 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 %{$self->{tag_categories}} ] }, - { post => 'catrec', required => 0 }, - { post => 'meta', 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 => '' }, - { post => 'merge', required => 0, default => '' }, - ); - 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}) { - $frm->{state} = $frm->{meta} = 0 if !$self->authCan('tagmod'); - my %opts = ( - name => $frm->{name}, - state => $frm->{state}, - cat => $frm->{cat}, - description => $frm->{description}, - meta => $frm->{meta}?1:0, - 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->dbTagMerge($tag, @merge) if $self->authCan('tagmod') && @merge; - $self->resRedirect("/g$tag", 'post'); - return; - } - } - - if($tag) { - $frm->{$_} ||= $t->{$_} for (qw|name meta description state cat|); - $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 => fmtuser($t->{addedby}, $t->{username}) ] : (), - [ select => short => 'state', name => 'State', options => [ - [0, 'Awaiting moderation'], [1, 'Deleted/hidden'], [2, 'Approved'] ] ], - [ checkbox => short => 'meta', name => 'This is a meta-tag (only to be used as parent for other tags, not for linking to VN entries)' ], - $tag ? - [ static => content => 'WARNING: Checking this option or selecting "Deleted" as state will permanently delete all existing VN relations!' ] : (), - ) : (), - [ select => short => 'cat', name => 'Category', options => [ - map [$_, $self->{tag_categories}{$_}], keys %{$self->{tag_categories}} ] ], - $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.' ], - [ 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 => '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!' ], - ) : (), - ]); - $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 taglinks { - my $self = shift; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'o', required => 0, default => 'd', enum => ['a', 'd'] }, - { get => 's', required => 0, default => 'date', enum => [qw|date tag|] }, - { get => 'v', required => 0, default => 0, template => 'id' }, - { get => 'u', required => 0, default => 0, template => 'id' }, - { get => 't', required => 0, default => 0, template => 'id' }, - ); - return $self->resNotFound if $f->{_err} || $f->{p} > 100; - - my($list, $np) = $self->dbTagLinks( - what => 'details', - results => 50, - page => $f->{p}, - sort => $f->{s}, - reverse => $f->{o} eq 'd', - $f->{v} ? (vid => $f->{v}) : (), - $f->{u} ? (uid => $f->{u}) : (), - $f->{t} ? (tag => $f->{t}) : (), - ); - - my $url = sub { - my %f = ((map +($_,$f->{$_}), qw|s o v u t|), @_); - my $qs = join ';', map $f{$_}?"$_=$f{$_}":(), keys %f; - return '/g/links'.($qs?"?$qs":'') - }; - - $self->htmlHeader(noindex => 1, title => 'Tag link browser'); - div class => 'mainbox'; - h1 'Tag link browser'; - - div class => 'warning'; - h2 'Spoiler warning'; - p 'This list displays the tag votes of individual users. Spoilery tags are not hidden, and may not even be correctly flagged as such.'; - end; - br; - - if($f->{u} || $f->{t} || $f->{v}) { - p 'Active filters:'; - ul; - if($f->{u}) { - my $o = $self->dbUserGet(uid => $f->{u})->[0]; - li; - txt '['; a href => $url->(u=>0), 'remove'; txt '] '; - txt 'User:'; txt ' '; - a href => "/u$o->{id}", $o->{username}; - end; - } - if($f->{t}) { - my $o = $self->dbTagGet(id => $f->{t})->[0]; - li; - txt '['; a href => $url->(t=>0), 'remove'; txt '] '; - txt 'Tag:'; txt ' '; - a href => "/g$o->{id}", $o->{name}; - end; - } - if($f->{v}) { - my $o = $self->dbVNGet(id => $f->{v})->[0]; - li; - txt '['; a href => $url->(v=>0), 'remove'; txt '] '; - txt 'Visual novel:'; txt ' '; - a href => "/v$o->{id}", $o->{title}; - end; - } - end 'ul'; - } - p 'Click the arrow beside a user, tag or VN to add it as a filter.' unless $f->{v} && $f->{u} && $f->{t}; - end 'div'; - - $self->htmlBrowse( - class => 'taglinks', - options => $f, - nextpage => $np, - items => $list, - pageurl => $url->(), - sorturl => $url->(s=>0,o=>0), - header => [ - [ 'Date', 'date' ], - [ 'User' ], - [ 'Rating' ], - [ 'Tag', 'tag' ], - [ 'Spoiler' ], - [ 'Visual novel' ], - ], - row => sub { - my($s, $n, $l) = @_; - Tr; - td class => 'tc1', fmtdate $l->{date}; - td class => 'tc2'; - a href => $url->(u=>$l->{uid}), class => 'setfil', '> ' if !$f->{u}; - a href => "/u$l->{uid}", $l->{username}; - end; - td class => 'tc3'.($l->{ignore}?' ignored':''); - tagscore $l->{vote}; - end; - td class => 'tc4'; - a href => $url->(t=>$l->{tag}), class => 'setfil', '> ' if !$f->{t}; - a href => "/g$l->{tag}", $l->{name}; - end; - td class => 'tc5', !defined $l->{spoiler} ? ' ' : fmtspoil $l->{spoiler}; - td class => 'tc6'; - a href => $url->(v=>$l->{vid}), class => 'setfil', '> ' if !$f->{v}; - a href => "/v$l->{vid}", shorten $l->{title}, 50; - end; - end; - }, - ); - $self->htmlFooter; -} - - -sub vntagmod { - my($self, $vid) = @_; - - my $v = $self->dbVNGet(id => $vid)->[0]; - return $self->resNotFound if !$v || $v->{hidden}; - - return $self->htmlDenied if !$self->authCan('tag'); - - my $tags = $self->dbTagStats(vid => $vid, results => 9999); - my $my = $self->dbTagLinks(vid => $vid, uid => $self->authInfo->{id}); - - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - my $frm = $self->formValidate( - { post => 'taglinks', required => 0, default => '', maxlength => 10240, regex => [ qr/^[1-9][0-9]*,-?[1-3],-?[0-2]( [1-9][0-9]*,-?[1-3],-?[0-2])*$/, 'meh' ] }, - { post => 'overrule', required => 0, multi => 1, template => 'id' }, - ); - return $self->resNotFound if $frm->{_err}; - - # convert some data in a more convenient structure for faster lookup - my %tags = map +($_->{id} => $_), @$tags; - my %old = map +($_->{tag} => $_), @$my; - my %new = map { my($tag, $vote, $spoiler) = split /,/; ($tag => [ $vote, $spoiler ]) } split / /, $frm->{taglinks}; - my %over = !$self->authCan('tagmod') || !$frm->{overrule}[0] ? () : (map $new{$_} ? ($_ => 1) : (), @{$frm->{overrule}}); - - # hashes which need to be filled, indicating what should be changed to the DB - my %delete; # tag => 1 - my %update; # tag => [ vote, spoiler ] (ignore flag is untouched) - my %insert; # tag => [ vote, spoiler, ignore ] - my %overrule; # tag => 0/1 - - for my $t (keys %old, keys %new) { - my $prev_over = $old{$t} && !$old{$t}{ignore} && $tags{$t}{overruled}; - - # overrule checkbox has changed? make sure to (de-)overrule the tag votes - $overrule{$t} = $over{$t}?1:0 if (!$prev_over && $over{$t}) || ($prev_over && !$over{$t}); - - # tag deleted? - if($old{$t} && !$new{$t}) { - $delete{$t} = 1; - next; - } - - # and insert or update the vote - if(!$old{$t} && $new{$t}) { - # determine whether this vote is going to be ignored or not - my $ign = $tags{$t}{overruled} && !$prev_over && !$over{$t}; - $insert{$t} = [ $new{$t}[0], $new{$t}[1], $ign ]; - } elsif($old{$t}{vote} != $new{$t}[0] || (defined $old{$t}{spoiler} ? $old{$t}{spoiler} : -1) != $new{$t}[1]) { - $update{$t} = [ $new{$t}[0], $new{$t}[1] ]; - } - } - # remove tags in the deleted state. - delete $insert{$_->{id}} for(keys %insert ? @{$self->dbTagGet(id => [ keys %insert ], state => 1)} : ()); - - $self->dbTagLinkEdit($self->authInfo->{id}, $vid, \%insert, \%update, \%delete, \%overrule); - - # need to re-fetch the tags and tag links, as these have been modified - $tags = $self->dbTagStats(vid => $vid, results => 9999); - $my = $self->dbTagLinks(vid => $vid, uid => $self->authInfo->{id}); - } - - - my $title = "Add/remove tags for $v->{title}"; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('v', $v, 'tagmod'); - div class => 'mainbox'; - h1 $title; - div class => 'notice'; - h2 'Tagging'; - ul; - li; txt 'Make sure you have read the '; a href => '/d10', 'guidelines'; txt '!'; end; - li 'Don\'t forget to hit the submit button on the bottom of the page to make your changes permanent.'; - li 'Some tag information on the site is cached, it can take up to an hour for your changes to be visible everywhere.'; - end; - end; - end 'div'; - $self->htmlForm({ action => "/v$vid/tagmod", nosubmit => 1 }, tagmod => [ 'Tags', - [ hidden => short => 'taglinks', value => '' ], - [ static => nolabel => 1, content => sub { - table class => 'tgl stripe'; - thead; - Tr; - td ''; - td colspan => $self->authCan('tagmod') ? 3 : 2, class => 'tc_you', 'You'; - td colspan => 3, class => 'tc_others', 'Others'; - end; - Tr; - td class => 'tc_tagname', 'Tag'; - td class => 'tc_myvote', 'Rating'; - td class => 'tc_myover', 'O' if $self->authCan('tagmod'); - td class => 'tc_myspoil', 'Spoiler'; - td class => 'tc_allvote', 'Rating'; - td class => 'tc_allspoil', 'Spoiler'; - td class => 'tc_allwho', ''; - end; - end 'thead'; - tfoot; Tr; - td colspan => 6; - input type => 'submit', class => 'submit', value => 'Save changes', style => 'float: right'; - input id => 'tagmod_tag', type => 'text', class => 'text', value => ''; - input id => 'tagmod_add', type => 'button', class => 'submit', value => 'Add tag'; - br; - p; - txt 'Check the '; a href => '/g', 'tag list'; txt ' to browse all available tags.'; - br; - txt 'Can\'t find what you\'re looking for? '; a href => '/g/new', 'Request a new tag'; txt '.'; - end; - end; - end; end 'tfoot'; - tbody id => 'tagtable'; - _tagmod_list($self, $vid, $tags, $my); - end 'tbody'; - end 'table'; - } ], - ]); - $self->htmlFooter; -} - -sub _tagmod_list { - my($self, $vid, $tags, $my) = @_; - - my %my = map +($_->{tag} => $_), @$my; - - for my $cat (keys %{$self->{tag_categories}}) { - my @tags = grep $_->{cat} eq $cat, @$tags; - next if !@tags; - Tr class => 'tagmod_cat'; - td colspan => 7, $self->{tag_categories}{$cat}; - end; - for my $t (@tags) { - my $m = $my{$t->{id}}; - Tr id => "tgl_$t->{id}"; - td class => 'tc_tagname'; a href => "/g$t->{id}", $t->{name}; end; - td class => 'tc_myvote', $m->{vote}||0; - if($self->authCan('tagmod')) { - td class => 'tc_myover'; - input type => 'checkbox', name => 'overrule', value => $t->{id}, - $m->{vote} && !$m->{ignore} && $t->{overruled} ? (checked => 'checked') : () - if $t->{cnt} > 1; - end; - } - td class => 'tc_myspoil', defined $m->{spoiler} ? $m->{spoiler} : -1; - td class => 'tc_allvote'; - tagscore $t->{rating}; - i $t->{overruled} ? (class => 'grayedout') : (), " ($t->{cnt})"; - b class => 'standout', style => 'font-weight: bold', title => 'Tag overruled. All votes other than that of the moderator who overruled it will be ignored.', ' !' if $t->{overruled}; - end; - td class => 'tc_allspoil', sprintf '%.2f', $t->{spoiler}; - td class => 'tc_allwho'; - a href => "/g/links?v=$vid;t=$t->{id}", 'Who?'; - end; - end; - } - } -} - - -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, meta => 0, 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' }, - ); - 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 => 15, - page => 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}, meta => $_->{meta} ? '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 41057c44..00000000 --- a/lib/VNDB/Handler/Traits.pm +++ /dev/null @@ -1,432 +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 = sprintf '%s: %s', $t->{meta} ? 'Meta trait' : '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->{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->{meta} && $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?m=0", $f->{m} == 0 ? (class => 'optselected') : (), 'Hide spoilers'; - a href => "/i$trait?m=1", $f->{m} == 1 ? (class => 'optselected') : (), 'Show minor spoilers'; - a href => "/i$trait?m=2", $f->{m} == 2 ? (class => 'optselected') : (), 'Spoil me!'; - end; - - p class => 'filselect'; - a id => 'filselect', href => '#c'; - lit '<i>▸</i> Filters<i></i>'; - end; - end; - input type => 'hidden', class => 'hidden', name => 'fil', id => 'fil', value => $f->{fil}; - - 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; - } - p; br; txt 'The list below also includes all characters linked to child traits. This list is cached, it can take up to 24 hours after a character has been edited for it to show up on this page.'; 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 => 'meta', 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' }, - ); - 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="/c%d">%s</a> already exists within the same group.', $_->{id}, xml_escape $_->{name} for @dups; - } - - if(!$frm->{_err}) { - $frm->{state} = $frm->{meta} = 0 if !$self->authCan('tagmod'); - my %opts = ( - name => $frm->{name}, - state => $frm->{state}, - description => $frm->{description}, - meta => $frm->{meta}?1:0, - sexual => $frm->{sexual}?1:0, - alias => $frm->{alias}, - order => $frm->{order}, - 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 meta sexual description state alias order|); - $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 => fmtuser($t->{addedby}, $t->{username}) ] : (), - [ select => short => 'state', name => 'State', options => [ - [0,'Awaiting moderation'], [1,'Deleted/hidden'], [2,'Approved'] ] ], - [ checkbox => short => 'meta', name => 'This is a meta trait (only to be used as parent for other traits, not for direct use with 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' ], - [ 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 }, - ); - 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->{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}, meta => $_->{meta} ? 'yes' : 'no', group => $_->{group}||'', groupname => $_->{groupname}||'', state => $_->{state}, $_->{name}; - } - end; -} - - -1; - diff --git a/lib/VNDB/Handler/ULists.pm b/lib/VNDB/Handler/ULists.pm deleted file mode 100644 index f30397b7..00000000 --- a/lib/VNDB/Handler/ULists.pm +++ /dev/null @@ -1,522 +0,0 @@ - -package VNDB::Handler::ULists; - -use strict; -use warnings; -use TUWF ':html', ':xml'; -use VNDB::Func; - - -TUWF::register( - qr{v([1-9]\d*)/vote}, \&vnvote, - qr{v([1-9]\d*)/wish}, \&vnwish, - qr{v([1-9]\d*)/list}, \&vnlist_e, - qr{r([1-9]\d*)/list}, \&rlist_e, - qr{xml/rlist.xml}, \&rlist_e, - qr{([uv])([1-9]\d*)/votes}, \&votelist, - qr{u([1-9]\d*)/wish}, \&wishlist, - qr{u([1-9]\d*)/list}, \&vnlist, -); - - -sub vnvote { - my($self, $id) = @_; - - my $uid = $self->authInfo->{id}; - return $self->htmlDenied() if !$uid; - - return if !$self->authCheckCode; - my $f = $self->formValidate( - { get => 'v', regex => qr/^(-1|([1-9]|10)(\.[0-9])?)$/ }, - { get => 'ref', required => 0, default => "/v$id" } - ); - return $self->resNotFound if $f->{_err} || ($f->{v} != -1 && ($f->{v} > 10 || $f->{v} < 1)); - - $self->dbVoteDel($uid, $id) if $f->{v} == -1; - $self->dbVoteAdd($id, $uid, $f->{v}*10) if $f->{v} > 0; - - $self->resRedirect($f->{ref}, 'temp'); -} - - -sub vnwish { - my($self, $id) = @_; - - my $uid = $self->authInfo->{id}; - return $self->htmlDenied() if !$uid; - - return if !$self->authCheckCode; - my $f = $self->formValidate( - { get => 's', enum => [ -1..$#{$self->{wishlist_status}} ] }, - { get => 'ref', required => 0, default => "/v$id" } - ); - return $self->resNotFound if $f->{_err}; - - $self->dbWishListDel($uid, $id) if $f->{s} == -1; - $self->dbWishListAdd($id, $uid, $f->{s}) if $f->{s} != -1; - - $self->resRedirect($f->{ref}, 'temp'); -} - - -sub vnlist_e { - my($self, $id) = @_; - - my $uid = $self->authInfo->{id}; - return $self->htmlDenied() if !$uid; - - return if !$self->authCheckCode; - my $f = $self->formValidate( - { get => 'e', enum => [ -1..$#{$self->{vnlist_status}} ] }, - { get => 'ref', required => 0, default => "/v$id" } - ); - return $self->resNotFound if $f->{_err}; - - $self->dbVNListDel($uid, $id) if $f->{e} == -1; - $self->dbVNListAdd($uid, $id, $f->{e}) if $f->{e} != -1; - - $self->resRedirect($f->{ref}, 'temp'); -} - - -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..$#{$self->{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', ''; - } -} - - -sub votelist { - my($self, $type, $id) = @_; - - my $obj = $type eq 'v' ? $self->dbVNGet(id => $id)->[0] : $self->dbUserGet(uid => $id, what => 'hide_list')->[0]; - return $self->resNotFound if !$obj->{id}; - - my $own = $type eq 'u' && $self->authInfo->{id} && $self->authInfo->{id} == $id; - return $self->resNotFound if $type eq 'u' && !$own && !(!$obj->{hide_list} || $self->authCan('usermod')); - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'o', required => 0, default => 'd', enum => ['a', 'd'] }, - { get => 's', required => 0, default => 'date', enum => [qw|date title vote|] }, - { get => 'c', required => 0, default => 'all', enum => [ 'all', 'a'..'z', 0 ] }, - ); - return $self->resNotFound if $f->{_err}; - - if($own && $self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - my $frm = $self->formValidate( - { post => 'vid', required => 1, multi => 1, template => 'id' }, - { post => 'batchedit', required => 1, enum => [ -2, -1, 1..10 ] }, - ); - my @vid = grep $_ && $_ > 0, @{$frm->{vid}}; - if(!$frm->{_err} && @vid && $frm->{batchedit} > -2) { - $self->dbVoteDel($id, \@vid) if $frm->{batchedit} == -1; - $self->dbVoteAdd(\@vid, $id, $frm->{batchedit}*10) if $frm->{batchedit} > 0; - } - } - - my($list, $np) = $self->dbVoteGet( - $type.'id' => $id, - what => $type eq 'v' ? 'user' : 'vn', - hide => $type eq 'v', - hide_ign => $type eq 'v', - sort => $f->{s} eq 'title' && $type eq 'v' ? 'username' : $f->{s}, - reverse => $f->{o} eq 'd', - results => 50, - page => $f->{p}, - $f->{c} ne 'all' ? ($type eq 'u' ? 'vn_char' : 'user_char', $f->{c}) : (), - ); - - my $title = $type eq 'v' ? "Votes for $obj->{title}" : "Votes by $obj->{username}"; - $self->htmlHeader(noindex => 1, title => $title); - $self->htmlMainTabs($type => $obj, 'votes'); - div class => 'mainbox'; - h1 $title; - p class => 'browseopts'; - for ('all', 'a'..'z', 0) { - a href => "/$type$id/votes?c=$_", $_ eq $f->{c} ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#'; - } - end; - p 'No votes to list. :-(' if !@$list; - end; - - if($own) { - my $code = $self->authGetCode("/u$id/votes"); - form action => "/u$id/votes?formcode=$code;c=$f->{c};s=$f->{s};p=$f->{p}", method => 'post'; - } - - @$list && $self->htmlBrowse( - class => 'votelist', - items => $list, - options => $f, - nextpage => $np, - pageurl => "/$type$id/votes?c=$f->{c};o=$f->{o};s=$f->{s}", - sorturl => "/$type$id/votes?c=$f->{c}", - header => [ - [ 'Cast', 'date' ], - [ 'Vote', 'vote' ], - [ $type eq 'v' ? 'User' : 'Visual novel', 'title' ], - ], - row => sub { - my($s, $n, $l) = @_; - Tr; - td class => 'tc1'; - input type => 'checkbox', name => 'vid', value => $l->{vid} if $own; - txt ' '.fmtdate $l->{date}; - end; - td class => 'tc2', fmtvote $l->{vote}; - td class => 'tc3'; - a href => $type eq 'v' ? ("/u$l->{uid}", $l->{username}) : ("/v$l->{vid}", shorten $l->{title}, 100); - end; - end; - }, - $own ? (footer => sub { - Tr; - td colspan => 3, class => 'tc1'; - input type => 'checkbox', class => 'checkall', name => 'vid', value => 0; - txt ' '; - Select name => 'batchedit', id => 'batchedit'; - option value => -2, '-- with selected --'; - optgroup label => 'Change vote'; - option value => $_, sprintf '%d (%s)', $_, fmtrating $_ for (reverse 1..10); - end; - option value => -1, 'revoke'; - end; - end; - end 'tr'; - }) : (), - ); - end if $own; - $self->htmlFooter; -} - - -sub wishlist { - my($self, $uid) = @_; - - my $own = $self->authInfo->{id} && $self->authInfo->{id} == $uid; - my $u = $self->dbUserGet(uid => $uid, what => 'hide_list')->[0]; - return $self->resNotFound if !$u || !$own && !(!$u->{hide_list} || $self->authCan('usermod')); - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'o', required => 0, default => 'd', enum => [ 'a', 'd' ] }, - { get => 's', required => 0, default => 'wstat', enum => [qw|title added wstat|] }, - { get => 'f', required => 0, default => -1, enum => [ -1..$#{$self->{wishlist_status}} ] }, - ); - return $self->resNotFound if $f->{_err}; - - if($own && $self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - my $frm = $self->formValidate( - { post => 'sel', required => 0, default => 0, multi => 1, template => 'id' }, - { post => 'batchedit', required => 1, enum => [ -1..$#{$self->{wishlist_status}} ] }, - ); - $frm->{sel} = [ grep $_, @{$frm->{sel}} ]; # weed out "select all" checkbox - if(!$frm->{_err} && @{$frm->{sel}} && $frm->{sel}[0]) { - $self->dbWishListDel($uid, $frm->{sel}) if $frm->{batchedit} == -1; - $self->dbWishListAdd($frm->{sel}, $uid, $frm->{batchedit}) if $frm->{batchedit} >= 0; - } - } - - my($list, $np) = $self->dbWishListGet( - uid => $uid, - sort => $f->{s}, reverse => $f->{o} eq 'd', - $f->{f} != -1 ? (wstat => $f->{f}) : (), - what => 'vn', - results => 50, - page => $f->{p}, - ); - - my $title = $own ? 'My wishlist' : "$u->{username}'s wishlist"; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('u', $u, 'wish'); - div class => 'mainbox'; - h1 $title; - if(!@$list && $f->{f} == -1) { - p 'Wishlist empty...'; - end; - return $self->htmlFooter; - } - p class => 'browseopts'; - a $f->{f} == $_ ? (class => 'optselected') : (), href => "/u$uid/wish?f=$_", - $_ == -1 ? 'All priorities' : $self->{wishlist_status}[$_] - for (-1..$#{$self->{wishlist_status}}); - end; - end 'div'; - - if($own) { - my $code = $self->authGetCode("/u$uid/wish"); - form action => "/u$uid/wish?formcode=$code;f=$f->{f};o=$f->{o};s=$f->{s};p=$f->{p}", method => 'post'; - } - - $self->htmlBrowse( - class => 'wishlist', - items => $list, - nextpage => $np, - options => $f, - pageurl => "/u$uid/wish?f=$f->{f};o=$f->{o};s=$f->{s}", - sorturl => "/u$uid/wish?f=$f->{f}", - header => [ - [ 'Title' => 'title' ], - [ 'Priority' => 'wstat' ], - [ 'Added' => 'added' ], - ], - row => sub { - my($s, $n, $i) = @_; - Tr; - td class => 'tc1'; - input type => 'checkbox', name => 'sel', value => $i->{vid} - if $own; - a href => "/v$i->{vid}", title => $i->{original}||$i->{title}, ' '.shorten $i->{title}, 70; - end; - td class => 'tc2', $self->{wishlist_status}[$i->{wstat}]; - td class => 'tc3', fmtdate $i->{added}, 'compact'; - end; - }, - $own ? (footer => sub { - Tr; - td colspan => 3; - input type => 'checkbox', class => 'checkall', name => 'sel', value => 0; - txt ' '; - Select name => 'batchedit', id => 'batchedit'; - option '-- with selected --'; - optgroup label => 'Change priority'; - option value => $_, $self->{wishlist_status}[$_] - for (0..$#{$self->{wishlist_status}}); - end; - option value => -1, 'remove from wishlist'; - end; - end; - end; - }) : (), - ); - end 'form' if $own; - $self->htmlFooter; -} - - -sub vnlist { - my($self, $uid) = @_; - - my $own = $self->authInfo->{id} && $self->authInfo->{id} == $uid; - my $u = $self->dbUserGet(uid => $uid, what => 'hide_list')->[0]; - return $self->resNotFound if !$u || !$own && !(!$u->{hide_list} || $self->authCan('usermod')); - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'o', required => 0, default => 'a', enum => [ 'a', 'd' ] }, - { get => 's', required => 0, default => 'title', enum => [ 'title', 'vote' ] }, - { get => 'c', required => 0, default => 'all', enum => [ 'all', 'a'..'z', 0 ] }, - { get => 'v', required => 0, default => 0, enum => [ -1..1 ] }, - { get => 't', required => 0, default => -1, enum => [ -1..$#{$self->{vnlist_status}} ] }, - ); - return $self->resNotFound if $f->{_err}; - - if($own && $self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - my $frm = $self->formValidate( - { post => 'vid', required => 0, default => 0, multi => 1, template => 'id' }, - { post => 'rid', required => 0, default => 0, multi => 1, template => 'id' }, - { post => 'not', required => 0, default => '', maxlength => 2000 }, - { post => 'vns', required => 1, enum => [ -2..$#{$self->{vnlist_status}}, 999 ] }, - { post => 'rel', required => 1, enum => [ -2..$#{$self->{rlist_status}} ] }, - ); - my @vid = grep $_ > 0, @{$frm->{vid}}; - my @rid = grep $_ > 0, @{$frm->{rid}}; - if(!$frm->{_err} && @vid && $frm->{vns} > -2) { - $self->dbVNListDel($uid, \@vid) if $frm->{vns} == -1; - $self->dbVNListAdd($uid, \@vid, $frm->{vns}) if $frm->{vns} >= 0 && $frm->{vns} < 999; - $self->dbVNListAdd($uid, \@vid, undef, $frm->{not}) if $frm->{vns} == 999; - } - if(!$frm->{_err} && @rid && $frm->{rel} > -2) { - $self->dbRListDel($uid, \@rid) if $frm->{rel} == -1; - $self->dbRListAdd($uid, \@rid, $frm->{rel}) if $frm->{rel} >= 0; - } - } - - my($list, $np) = $self->dbVNListList( - uid => $uid, - results => 50, - page => $f->{p}, - sort => $f->{s}, reverse => $f->{o} eq 'd', - voted => $f->{v} == 0 ? undef : $f->{v} < 0 ? 0 : $f->{v}, - $f->{c} ne 'all' ? (char => $f->{c}) : (), - $f->{t} >= 0 ? (status => $f->{t}) : (), - ); - - my $title = $own ? 'My visual novel list' : "$u->{username}'s visual novel list"; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('u', $u, 'list'); - - # url generator - my $url = sub { - my($n, $v) = @_; - $n ||= ''; - local $_ = "/u$uid/list"; - $_ .= '?c='.($n eq 'c' ? $v : $f->{c}); - $_ .= ';v='.($n eq 'v' ? $v : $f->{v}); - $_ .= ';t='.($n eq 't' ? $v : $f->{t}); - if($n eq 'page') { - $_ .= ';o='.($n eq 'o' ? $v : $f->{o}); - $_ .= ';s='.($n eq 's' ? $v : $f->{s}); - } - return $_; - }; - - div class => 'mainbox'; - h1 $title; - p class => 'browseopts'; - for ('all', 'a'..'z', 0) { - a href => $url->(c => $_), $_ eq $f->{c} ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#'; - } - end; - p class => 'browseopts'; - a href => $url->(v => 0), 0 == $f->{v} ? (class => 'optselected') : (), 'All'; - a href => $url->(v => 1), 1 == $f->{v} ? (class => 'optselected') : (), 'Only voted'; - a href => $url->(v => -1), -1 == $f->{v} ? (class => 'optselected') : (), 'Hide voted'; - end; - p class => 'browseopts'; - a href => $url->(t => -1), -1 == $f->{t} ? (class => 'optselected') : (), 'All'; - a href => $url->(t => $_), $_ == $f->{t} ? (class => 'optselected') : (), $self->{vnlist_status}[$_] for 0..$#{$self->{vnlist_status}}; - end; - end 'div'; - - _vnlist_browse($self, $own, $list, $np, $f, $url, $uid); - $self->htmlFooter; -} - -sub _vnlist_browse { - my($self, $own, $list, $np, $f, $url, $uid) = @_; - - if($own) { - form action => $url->(), method => 'post'; - input type => 'hidden', class => 'hidden', name => 'not', id => 'not', value => ''; - input type => 'hidden', class => 'hidden', name => 'formcode', id => 'formcode', value => $self->authGetCode("/u$uid/list"); - } - - $self->htmlBrowse( - class => 'rlist', - items => $list, - nextpage => $np, - options => $f, - sorturl => $url->(), - pageurl => $url->('page'), - header => [ - [ '' ], - sub { td class => 'tc2', id => 'expandall'; lit '▸'; end; }, - [ 'Title' => 'title' ], - [ '' ], [ '' ], - [ 'Status' ], - [ 'Releases*' ], - [ 'Vote' => 'vote' ], - ], - row => sub { - my($s, $n, $i) = @_; - Tr class => 'nostripe'.($n%2 ? ' odd' : ''); - td class => 'tc1'; input type => 'checkbox', name => 'vid', value => $i->{vid} if $own; end; - if(@{$i->{rels}}) { - td class => 'tc2 collapse_but', id => "vid$i->{vid}"; lit '▸'; end; - } else { - td class => 'tc2', ''; - } - td class => 'tc3_5', colspan => 3; - a href => "/v$i->{vid}", title => $i->{original}||$i->{title}, shorten $i->{title}, 70; - b class => 'grayedout', $i->{notes} if $i->{notes}; - end; - td class => 'tc6', $i->{status} ? $self->{vnlist_status}[$i->{status}] : ''; - td class => 'tc7'; - my $obtained = grep $_->{status}==2, @{$i->{rels}}; - my $total = scalar @{$i->{rels}}; - my $txt = sprintf '%d/%d', $obtained, $total; - $txt = qq|<b class="done">$txt</b>| if $total && $obtained == $total; - $txt = qq|<b class="todo">$txt</b>| if $obtained < $total; - lit $txt; - end; - td class => 'tc8', fmtvote $i->{vote}; - end 'tr'; - - for (@{$i->{rels}}) { - Tr class => "nostripe collapse relhid collapse_vid$i->{vid}".($n%2 ? ' odd':''); - td class => 'tc1', ''; - td class => 'tc2'; - input type => 'checkbox', name => 'rid', value => $_->{rid} if $own; - end; - td class => 'tc3'; - lit fmtdatestr $_->{released}; - end; - td class => 'tc4'; - cssicon "lang $_", $self->{languages}{$_} for @{$_->{languages}}; - cssicon "rt$_->{type}", $_->{type}; - end; - td class => 'tc5'; - a href => "/r$_->{rid}", title => $_->{original}||$_->{title}, shorten $_->{title}, 50; - end; - td class => 'tc6', $_->{status} ? $self->{rlist_status}[$_->{status}] : ''; - td class => 'tc7_8', colspan => 2, ''; - end 'tr'; - } - }, - - $own ? (footer => sub { - Tr; - td class => 'tc1'; input type => 'checkbox', name => 'vid', value => 0, class => 'checkall'; end; - td class => 'tc2'; input type => 'checkbox', name => 'rid', value => 0, class => 'checkall'; end; - td class => 'tc3_6', colspan => 4; - Select id => 'vns', name => 'vns'; - option value => -2, '-- with selected VNs --'; - optgroup label => 'Change status'; - option value => $_, $self->{vnlist_status}[$_] - for (0..$#{$self->{vnlist_status}}); - end; - option value => 999, 'Set note'; - option value => -1, 'remove from list'; - end; - Select id => 'rel', name => 'rel'; - option value => -2, '-- with selected releases --'; - optgroup label => 'Change status'; - option value => $_, $self->{rlist_status}[$_] - for (0..$#{$self->{rlist_status}}); - end; - option value => -1, 'remove from list'; - end; - input type => 'submit', value => 'Update'; - end; - td class => 'tc7_8', colspan => 2, '* Obtained/total'; - end 'tr'; - }) : (), - ); - - end 'form' if $own; -} - -1; - diff --git a/lib/VNDB/Handler/Users.pm b/lib/VNDB/Handler/Users.pm deleted file mode 100644 index d1f0df93..00000000 --- a/lib/VNDB/Handler/Users.pm +++ /dev/null @@ -1,825 +0,0 @@ - -package VNDB::Handler::Users; - -use strict; -use warnings; -use TUWF ':html', 'xml_escape'; -use VNDB::Func; -use POSIX 'floor'; - - -TUWF::register( - qr{u([1-9]\d*)} => \&userpage, - qr{u/login} => \&login, - qr{u([1-9]\d*)/logout} => \&logout, - qr{u/newpass} => \&newpass, - qr{u/newpass/sent} => \&newpass_sent, - qr{u([1-9]\d*)/setpass} => \&setpass, - qr{u/register} => \®ister, - qr{u/register/done} => \®ister_done, - qr{u([1-9]\d*)/edit} => \&edit, - qr{u([1-9]\d*)/posts} => \&posts, - qr{u([1-9]\d*)/del(/[od])?} => \&delete, - qr{u/(all|[0a-z])} => \&list, - qr{u([1-9]\d*)/notifies} => \¬ifies, - qr{u([1-9]\d*)/notify/([1-9]\d*)} => \&readnotify, -); - - -sub userpage { - my($self, $uid) = @_; - - my $u = $self->dbUserGet(uid => $uid, what => 'stats hide_list')->[0]; - return $self->resNotFound if !$u->{id}; - - my $votes = $u->{c_votes} && $self->dbVoteStats(uid => $uid); - my $list_visible = !$u->{hide_list} || ($self->authInfo->{id}||0) == $u->{id} || $self->authCan('usermod'); - - my $title = "$u->{username}'s profile"; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs('u', $u); - div class => 'mainbox userpage'; - h1 $title; - - table class => 'stripe'; - - Tr; - td class => 'key', 'Username'; - td; - txt ucfirst($u->{username}).' ('; - a href => "/u$uid", "u$uid"; - txt ')'; - end; - end; - - Tr; - td 'Registered'; - td fmtdate $u->{registered}; - end; - - Tr; - td 'Edits'; - td; - if($u->{c_changes}) { - a href => "/u$uid/hist", $u->{c_changes}; - } else { - txt '-'; - } - end; - end; - - Tr; - td 'Votes'; - td; - if(!$list_visible) { - txt 'hidden'; - } elsif($votes) { - my($total, $count) = (0, 0); - for (1..@$votes) { - $count += $votes->[$_-1][0]; - $total += $votes->[$_-1][1]; - } - a href => "/u$uid/votes", $count; - txt sprintf ' (%.2f average)', $total/$count/10; - } else { - txt '-'; - } - end; - end; - - Tr; - td 'Tags'; - td; - if(!$u->{c_tags}) { - txt '-'; - } else { - txt sprintf '%d vote%s on %d distinct tag%s and %d visual novel%s. ', - $u->{c_tags}, $u->{c_tags} == 1 ? '' : 's', - $u->{tagcount}, $u->{tagcount} == 1 ? '' : 's', - $u->{tagvncount}, $u->{tagvncount} == 1 ? '' : 's'; - a href => "/g/links?u=$uid"; lit 'Browse tags »'; end; - } - end; - end; - - Tr; - td 'List stats'; - td !$list_visible ? 'hidden' : - sprintf '%d release%s of %d visual novel%s.', - $u->{releasecount}, $u->{releasecount} == 1 ? '' : 's', - $u->{vncount}, $u->{vncount} == 1 ? '' : 's'; - end; - - Tr; - td 'Forum stats'; - td; - txt sprintf '%d post%s, %d new thread%s. ', - $u->{postcount}, $u->{postcount} == 1 ? '' : 's', - $u->{threadcount}, $u->{threadcount} == 1 ? '' : 's'; - if($u->{postcount}) { - a href => "/u$uid/posts"; lit 'Browse posts »'; end; - } - end; - end; - end 'table'; - end 'div'; - - if($votes && $list_visible) { - div class => 'mainbox'; - h1 'Vote statistics'; - $self->htmlVoteStats(u => $u, $votes); - end; - } - - if($u->{c_changes}) { - my $list = $self->dbRevisionGet(uid => $uid, results => 5); - h1 class => 'boxtitle'; - a href => "/u$uid/hist", 'Recent changes'; - end; - $self->htmlBrowseHist($list, { p => 1 }, 0, "/u$uid/hist"); - } - $self->htmlFooter; -} - - -sub login { - my $self = shift; - - return $self->resRedirect('/', 'temp') if $self->authInfo->{id}; - - my $tm = $self->dbThrottleGet(norm_ip($self->reqIP)); - if($tm-time() > $self->{login_throttle}[1]) { - $self->htmlHeader(title => 'Login'); - div class => 'mainbox'; - h1 'Login'; - div class => 'warning'; - h2 'Maximum failed login attempts reached.'; - p; - txt 'Login has been temporarily disabled for your IP address. You can wait a few hours and try again,' - .' or you can try from a different IP address. If you forgot your password, you can still use the '; - a href => '/u/newpass', 'password reset'; - txt ' functionality. If you still have trouble logging in, send a mail to '; - a href => 'mailto:contact@vndb.org', 'contact@vndb.org'; - txt '.'; - end; - end; - end 'div'; - $self->htmlFooter; - return; - } - - my $ref = $self->formValidate({ param => 'ref', required => 0, default => '/'})->{ref}; - - my $frm; - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'usrname', required => 1, minlength => 2, maxlength => 15 }, - { post => 'usrpass', required => 1, minlength => 4, maxlength => 64, template => 'ascii' }, - ); - - if(!$frm->{_err}) { - $frm->{usrname} = lc $frm->{usrname}; - return if $self->authLogin($frm->{usrname}, $frm->{usrpass}, $ref); - $frm->{_err} = [ 'Invalid username or password' ]; - $self->dbThrottleSet(norm_ip($self->reqIP), $tm+$self->{login_throttle}[0]); - } - } - - $self->htmlHeader(noindex => 1, title => 'Login'); - $self->htmlForm({ frm => $frm, action => '/u/login' }, login => [ 'Login', - [ hidden => short => 'ref', value => $ref ], - [ input => short => 'usrname', name => 'Username' ], - [ static => content => '<a href="/u/register">No account yet?</a>' ], - [ passwd => short => 'usrpass', name => 'Password' ], - [ static => content => '<a href="/u/newpass">Forgot your password?</a>' ], - ]); - $self->htmlFooter; -} - - -sub logout { - my $self = shift; - my $uid = shift; - return $self->resNotFound if !$self->authInfo->{id} || $self->authInfo->{id} != $uid; - $self->authLogout; -} - - -sub newpass { - my $self = shift; - - return $self->resRedirect('/', 'temp') if $self->authInfo->{id}; - - my($frm, $uid, $token); - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate({ post => 'mail', template => 'email' }); - if(!$frm->{_err}) { - ($uid, $token) = $self->authResetPass($frm->{mail}); - $frm->{_err} = [ 'No user found with that email address' ] if !$uid; - } - if(!$frm->{_err}) { - my $u = $self->dbUserGet(uid => $uid)->[0]; - my $body = sprintf - "Hello %s,\n\nYour VNDB.org login has been disabled, you can now set a new password by following the link below:\n\n" - ."%s\n\nNow don't forget your password again! :-)\n\nvndb.org", - $u->{username}, $self->reqBaseURI()."/u$u->{id}/setpass?t=$token"; - $self->mail($body, - To => $frm->{mail}, - From => 'VNDB <noreply@vndb.org>', - Subject => "Password reset for $u->{username}", - ); - return $self->resRedirect('/u/newpass/sent', 'post'); - } - } - - $self->htmlHeader(title => 'Forgot password', noindex => 1); - div class => 'mainbox'; - h1 'Forgot password'; - p 'Forgot your password and can\'t login to VNDB anymore?' - .' Don\'t worry! Just give us the email address you used to register on VNDB,' - .' and we\'ll send you instructions to set a new password within a few minutes!'; - end; - $self->htmlForm({ frm => $frm, action => '/u/newpass' }, newpass => [ 'Reset password', - [ input => short => 'mail', name => 'Email' ], - ]); - $self->htmlFooter; -} - - -sub newpass_sent { - my $self = shift; - return $self->resRedirect('/', 'temp') if $self->authInfo->{id}; - $self->htmlHeader(title => 'New password', noindex => 1); - div class => 'mainbox'; - h1 'New password'; - div class => 'notice'; - p 'Your password has been reset and instructions to set a new one should reach your mailbox in a few minutes.'; - end; - end; - $self->htmlFooter; -} - - -sub setpass { - my($self, $uid) = @_; - return $self->resRedirect('/', 'temp') if $self->authInfo->{id}; - - my $t = $self->formValidate({get => 't', regex => qr/^[a-f0-9]{40}$/i }); - return $self->resNotFound if $t->{_err}; - $t = $t->{t}; - - my $u = $self->dbUserGet(uid => $uid)->[0]; - return $self->resNotFound if !$u || !$self->authIsValidToken($u->{id}, $t); - - my $frm; - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode("/u$u->{id}/setpass?t=$t"); - $frm = $self->formValidate( - { post => 'usrpass', minlength => 4, maxlength => 64, template => 'ascii' }, - { post => 'usrpass2', minlength => 4, maxlength => 64, template => 'ascii' }, - ); - push @{$frm->{_err}}, 'Passwords do not match' if $frm->{usrpass} ne $frm->{usrpass2}; - - if(!$frm->{_err}) { - $self->dbUserEdit($uid, email_confirmed => 1); - return $self->authSetPass($uid, $frm->{usrpass}, "/u$uid", token => $t) - } - } - - $self->htmlHeader(title => "Set password for $u->{username}", noindex => 1); - $self->htmlForm({ frm => $frm, action => "/u$u->{id}/setpass?t=$t" }, setpass => [ "Set password for $u->{username}", - [ static => nolabel => 1, content => 'Now you can set a password for your account.' - .' You will be logged in automatically after your password has been saved.' ], - [ passwd => short => 'usrpass', name => 'Password' ], - [ passwd => short => 'usrpass2', name => 'Confirm password' ], - ]); - $self->htmlFooter; -} - - -sub register { - my $self = shift; - return $self->resRedirect('/', 'temp') if $self->authInfo->{id}; - - my $frm; - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate( - { post => 'usrname', template => 'uname' }, - { post => 'mail', template => 'email' }, - { post => 'type', enum => [1..3] }, - { post => 'answer', template => 'uint' }, - ); - my $num = $self->{stats}{[qw|vn releases producers|]->[ $frm->{type} - 1 ]}; - push @{$frm->{_err}}, 'Question was not correctly answered. Are you sure you are a human?' - if !$frm->{_err} && ($frm->{answer} > $num*1.005 || $frm->{answer} < $num*0.995); - push @{$frm->{_err}}, 'Someone already has this username, please choose another name' - if $frm->{usrname} eq 'anonymous' || !$frm->{_err} && $self->dbUserGet(username => $frm->{usrname})->[0]{id}; - push @{$frm->{_err}}, 'Someone already registered with that email address' - if !$frm->{_err} && $self->dbUserEmailExists($frm->{mail}); - - # Use /32 match for IPv4 and /48 for IPv6. The /48 is fairly broad, so some - # users may have to wait a bit before they can register... - my $ip = $self->reqIP; - push @{$frm->{_err}}, 'You can only register one account from the same IP within 24 hours' - if !$frm->{_err} && $self->dbUserGet(ip => $ip =~ /:/ ? "$ip/48" : $ip, registered => time-24*3600)->[0]{id}; - - if(!$frm->{_err}) { - my $uid = $self->dbUserAdd($frm->{usrname}, $frm->{mail}); - my(undef, $token) = $self->authResetPass($frm->{mail}); - my $body = sprintf "Hello %s,\n\n" - ."Someone has registered an account on VNDB.org with your email address. To confirm your registration, follow the link below.\n\n" - ."%s\n\n" - ."If you don't remember creating an account on VNDB.org recently, please ignore this e-mail.\n\n" - ."vndb.org", - $frm->{usrname}, $self->reqBaseURI()."/u$uid/setpass?t=$token"; - $self->mail($body, - To => $frm->{mail}, - From => 'VNDB <noreply@vndb.org>', - Subject => "Confirm registration for $frm->{usrname}", - ); - return $self->resRedirect('/u/register/done', 'post'); - } - } - - $self->htmlHeader(title => 'Create an account', noindex => 1); - - my $type = $frm->{type} || floor(rand 3)+1; - $self->htmlForm({ frm => $frm, action => '/u/register' }, register => [ 'Create an account', - [ hidden => short => 'type', value => $type ], - [ input => short => 'usrname', name => 'Username' ], - [ static => content => 'Preferred username. Must be lowercase and can only consist of alphanumeric characters.' ], - [ input => short => 'mail', name => 'Email' ], - [ static => content => 'Your email address will only be used in case you lose your password.' - .' We will never send spam or newsletters unless you explicitly ask us for it or we get hacked.<br /><br />' ], - [ static => content => sprintf '<br /><br />How many %s do we have in the database? (Hint: look to your left)', - ['visual novels', 'releases', 'producers']->[$type-1] ], - [ input => short => 'answer', name => 'Answer' ], - ]); - $self->htmlFooter; -} - - -sub register_done { - my $self = shift; - return $self->resRedirect('/', 'temp') if $self->authInfo->{id}; - $self->htmlHeader(title => 'Account created', noindex => 1); - div class => 'mainbox'; - h1 'Account created'; - div class => 'notice'; - p 'Your account has been created! In a few minutes, you should receive an email with instructions to set your password.'; - end; - end; - $self->htmlFooter; -} - - -sub edit { - my($self, $uid) = @_; - - # are we allowed to edit this user? - return $self->htmlDenied if !$self->authInfo->{id} || $self->authInfo->{id} != $uid && !$self->authCan('usermod'); - - # fetch user info (cached if uid == loggedin uid) - my $u = $self->authInfo->{id} == $uid ? $self->authInfo : $self->dbUserGet(uid => $uid, what => 'extended prefs')->[0]; - return $self->resNotFound if !$u->{id}; - - # check POST data - my $frm; - if($self->reqMethod eq 'POST') { - return if !$self->authCheckCode; - $frm = $self->formValidate( - $self->authCan('usermod') ? ( - { post => 'usrname', template => 'uname' }, - { post => 'perms', required => 0, multi => 1, enum => [ keys %{$self->{permissions}} ] }, - { post => 'ign_votes', required => 0, default => 0 }, - ) : (), - { post => 'mail', template => 'email' }, - { post => 'curpass', required => 0, minlength => 4, maxlength => 64, template => 'ascii', default => '' }, - { post => 'usrpass', required => 0, minlength => 4, maxlength => 64, template => 'ascii' }, - { post => 'usrpass2', required => 0, minlength => 4, maxlength => 64, template => 'ascii' }, - { post => 'hide_list', required => 0, default => 0, enum => [0,1] }, - { post => 'show_nsfw', required => 0, default => 0, enum => [0,1] }, - { post => 'traits_sexual', required => 0, default => 0, enum => [0,1] }, - { post => 'tags_all', required => 0, default => 0, enum => [0,1] }, - { post => 'tags_cat', required => 0, multi => 1, enum => [qw|cont ero tech|] }, - { post => 'spoilers', required => 0, default => 0, enum => [0..2] }, - { post => 'skin', required => 0, default => $self->{skin_default}, enum => [ keys %{$self->{skins}} ] }, - { post => 'customcss', required => 0, maxlength => 2000, default => '' }, - ); - push @{$frm->{_err}}, 'Passwords do not match' - if ($frm->{usrpass} || $frm->{usrpass2}) && (!$frm->{usrpass} || !$frm->{usrpass2} || $frm->{usrpass} ne $frm->{usrpass2}); - - if(!$frm->{_err}) { - $frm->{skin} = '' if $frm->{skin} eq $self->{skin_default}; - $self->dbUserPrefSet($uid, $_ => $frm->{$_}) for (qw|skin customcss show_nsfw traits_sexual tags_all hide_list spoilers|); - - my $tags_cat = join(',', sort @{$frm->{tags_cat}}) || 'none'; - $self->dbUserPrefSet($uid, tags_cat => $tags_cat eq $self->{default_tags_cat} ? '' : $tags_cat); - - my %o; - if($self->authCan('usermod')) { - $o{username} = $frm->{usrname} if $frm->{usrname}; - $o{ign_votes} = $frm->{ign_votes} ? 1 : 0; - - my $perm = 0; - $perm |= $self->{permissions}{$_} for(@{ delete $frm->{perms} }); - $self->dbUserSetPerm($u->{id}, $self->authInfo->{id}, $self->authInfo->{token}, $perm); - } - $self->dbUserSetMail($u->{id}, $self->authInfo->{id}, $self->authInfo->{token}, $frm->{mail}); - $self->dbUserEdit($uid, %o); - $self->authAdminSetPass($u->{id}, $frm->{usrpass}) if $frm->{usrpass} && $self->authInfo->{id} != $u->{id}; - - if($frm->{usrpass} && $self->authInfo->{id} == $u->{id}) { - # Bit ugly: On incorrect password, all other changes are still saved. - my $ok = $self->authSetPass($u->{id}, $frm->{usrpass}, "/u$uid/edit?d=1", pass => $frm->{curpass}); - return if $ok; - push @{$frm->{_err}}, 'Invalid password'; - } else { - return $self->resRedirect("/u$uid/edit?d=1", 'post'); - } - } - } - - # fill out default values - $frm->{usrname} ||= $u->{username}; - $frm->{mail} ||= $self->dbUserGetMail($u->{id}, $self->authInfo->{id}, $self->authInfo->{token}); - $frm->{perms} ||= [ grep $u->{perm} & $self->{permissions}{$_}, keys %{$self->{permissions}} ]; - $frm->{$_} //= $u->{prefs}{$_} for(qw|skin customcss show_nsfw traits_sexual tags_all hide_list spoilers|); - $frm->{tags_cat} ||= [ split /,/, $u->{prefs}{tags_cat}||$self->{default_tags_cat} ]; - $frm->{ign_votes} = $u->{ign_votes} if !defined $frm->{ign_votes}; - $frm->{skin} ||= $self->{skin_default}; - $frm->{usrpass} = $frm->{usrpass2} = $frm->{curpass} = ''; - - # create the page - $self->htmlHeader(title => 'My account', noindex => 1); - $self->htmlMainTabs('u', $u, 'edit'); - if($self->reqGet('d')) { - div class => 'mainbox'; - h1 'Settings saved'; - div class => 'notice'; - p 'Settings successfully saved.'; - end; - end - } - $self->htmlForm({ frm => $frm, action => "/u$uid/edit" }, useredit => [ 'My account', - [ part => title => 'General info' ], - $self->authCan('usermod') ? ( - [ input => short => 'usrname', name => 'Username' ], - [ select => short => 'perms', name => 'Permissions', multi => 1, size => (scalar keys %{$self->{permissions}}), options => [ - map [ $_, $_ ], sort keys %{$self->{permissions}} ] ], - [ check => short => 'ign_votes', name => 'Ignore votes in VN statistics' ], - ) : ( - [ static => label => 'Username', content => $frm->{usrname} ], - ), - [ input => short => 'mail', name => 'Email' ], - - [ part => title => 'Change password' ], - [ static => content => 'Leave blank to keep your current password' ], - [ passwd => short => 'curpass', name => 'Current Password' ], - [ passwd => short => 'usrpass', name => 'New Password' ], - [ passwd => short => 'usrpass2', name => 'Confirm password' ], - - [ part => title => 'Options' ], - [ check => short => 'hide_list', name => - qq{Don't allow other people to see my visual novel list (<a href="/u$uid/list">/u$uid/list</a>), - votes (<a href="/u$uid/votes">/u$uid/votes</a>) and wishlist (<a href="/u$uid/wish">/u$uid/wish</a>).} ], - [ check => short => 'show_nsfw', name => 'Disable warnings for images that are not safe for work.' ], - [ check => short => 'traits_sexual', name => 'Show sexual traits by default on character pages.' ], - [ check => short => 'tags_all', name => 'Show all tags by default on visual novel pages.' ], - [ select => short => 'tags_cat', name => 'Tag categories', multi => 1, size => 3, - options => [ map [ $_, $self->{tag_categories}{$_} ], keys %{$self->{tag_categories}} ] ], - [ select => short => 'spoilers', name => 'Spoiler level', options => [ - [0, 'Hide spoilers'], [1, 'Show only minor spoilers'], [2, 'Show all spoilers'] ]], - [ select => short => 'skin', name => 'Preferred skin', width => 300, options => [ - map [ $_, $self->{skins}{$_}[0].($self->debug?" [$_]":'') ], sort { $self->{skins}{$a}[0] cmp $self->{skins}{$b}[0] } keys %{$self->{skins}} ] ], - [ textarea => short => 'customcss', name => 'Additional <a href="http://en.wikipedia.org/wiki/Cascading_Style_Sheets">CSS</a>' ], - ]); - $self->htmlFooter; -} - - -sub posts { - my($self, $uid) = @_; - - # fetch user info (cached if uid == loggedin uid) - my $u = $self->authInfo->{id} && $self->authInfo->{id} == $uid ? $self->authInfo : $self->dbUserGet(uid => $uid, what => 'hide_list')->[0]; - return $self->resNotFound if !$u->{id}; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' } - ); - return $self->resNotFound if $f->{_err}; - - my($posts, $np) = $self->dbPostGet(uid => $uid, hide => 1, what => 'thread', page => $f->{p}, sort => 'date', reverse => 1); - - my $title = "Posts made by $u->{username}"; - $self->htmlHeader(title => $title, noindex => 1); - $self->htmlMainTabs(u => $u, 'posts'); - div class => 'mainbox'; - h1 $title; - if(!@$posts) { - p "$u->{username} hasn't made any posts yet."; - } - end; - - $self->htmlBrowse( - items => $posts, - class => 'uposts', - options => $f, - nextpage => $np, - pageurl => "/u$uid/posts", - header => [ - [ '' ], - [ '' ], - [ 'Date' ], - [ 'Title' ], - ], - row => sub { - my($s, $n, $l) = @_; - Tr; - td class => 'tc1'; a href => "/t$l->{tid}.$l->{num}", 't'.$l->{tid}; end; - td class => 'tc2'; a href => "/t$l->{tid}.$l->{num}", '.'.$l->{num}; end; - td class => 'tc3', fmtdate $l->{date}; - td class => 'tc4'; - a href => "/t$l->{tid}.$l->{num}", $l->{title}; - b class => 'grayedout'; lit bb2html $l->{msg}, 150; end; - end; - end; - }, - ) if @$posts; - $self->htmlFooter; -} - - -sub delete { - my($self, $uid, $act) = @_; - return $self->htmlDenied if !$self->authCan('usermod'); - - # rarely used admin function, won't really need translating - - # confirm - if(!$act) { - my $code = $self->authGetCode("/u$uid/del/o"); - my $u = $self->dbUserGet(uid => $uid, what => 'hide_list')->[0]; - return $self->resNotFound if !$u->{id}; - $self->htmlHeader(title => 'Delete user', noindex => 1); - $self->htmlMainTabs('u', $u, 'del'); - div class => 'mainbox'; - div class => 'warning'; - h2 'Delete user'; - p; - lit qq|Are you sure you want to remove <a href="/u$uid">$u->{username}</a>'s account?<br /><br />| - .qq|<a href="/u$uid/del/o?formcode=$code">Yes, I'm not kidding!</a>|; - end; - end; - end; - $self->htmlFooter; - } - # delete - elsif($act eq '/o') { - return if !$self->authCheckCode; - $self->dbUserDel($uid); - $self->resRedirect("/u$uid/del/d", 'post'); - } - # done - elsif($act eq '/d') { - $self->htmlHeader(title => 'Delete user', noindex => 1); - div class => 'mainbox'; - div class => 'notice'; - p 'User deleted.'; - end; - end; - $self->htmlFooter; - } -} - - -sub list { - my($self, $char) = @_; - - my $f = $self->formValidate( - { get => 's', required => 0, default => 'username', enum => [ qw|username registered votes changes tags| ] }, - { get => 'o', required => 0, default => 'a', enum => [ 'a','d' ] }, - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'q', required => 0, default => '', maxlength => 50 }, - ); - return $self->resNotFound if $f->{_err}; - - $self->htmlHeader(noindex => 1, title => 'Browse users'); - - div class => 'mainbox'; - h1 'Browse users'; - form action => '/u/all', 'accept-charset' => 'UTF-8', method => 'get'; - $self->htmlSearchBox('u', $f->{q}); - end; - p class => 'browseopts'; - for ('all', 'a'..'z', 0) { - a href => "/u/$_", $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? 'ALL' : $_ ? uc $_ : '#'; - } - end; - end; - - my($list, $np) = $self->dbUserGet( - sort => $f->{s}, reverse => $f->{o} eq 'd', - what => 'hide_list', - $char ne 'all' ? ( - firstchar => $char ) : (), - results => 50, - page => $f->{p}, - search => $f->{q}, - ); - - $self->htmlBrowse( - items => $list, - options => $f, - nextpage => $np, - pageurl => "/u/$char?o=$f->{o};s=$f->{s};q=$f->{q}", - sorturl => "/u/$char?q=$f->{q}", - header => [ - [ 'Username', 'username' ], - [ 'Registered', 'registered' ], - [ 'Votes', 'votes' ], - [ 'Edits', 'changes' ], - [ 'Tags', 'tags' ], - ], - row => sub { - my($s, $n, $l) = @_; - Tr; - td class => 'tc1'; - a href => '/u'.$l->{id}, $l->{username}; - end; - td class => 'tc2', fmtdate $l->{registered}; - td class => 'tc3'.($l->{hide_list} && $self->authCan('usermod') ? ' linethrough' : ''); - lit $l->{hide_list} && !$self->authCan('usermod') ? '-' : !$l->{c_votes} ? 0 : - qq|<a href="/u$l->{id}/votes">$l->{c_votes}</a>|; - end; - td class => 'tc4'; - lit !$l->{c_changes} ? 0 : qq|<a href="/u$l->{id}/hist">$l->{c_changes}</a>|; - end; - td class => 'tc5'; - lit !$l->{c_tags} ? 0 : qq|<a href="/g/links?u=$l->{id}">$l->{c_tags}</a>|; - end; - end 'tr'; - }, - ); - $self->htmlFooter; -} - - -sub notifies { - my($self, $uid) = @_; - - my $u = $self->authInfo; - return $self->htmlDenied if !$u->{id} || $uid != $u->{id}; - - my $f = $self->formValidate( - { get => 'p', required => 0, default => 1, template => 'page' }, - { get => 'r', required => 0, default => 0, enum => [0,1] }, - ); - return $self->resNotFound if $f->{_err}; - - # changing the notification settings - my $saved; - if($self->reqMethod() eq 'POST' && $self->reqPost('set')) { - return if !$self->authCheckCode; - my $frm = $self->formValidate( - { post => 'notify_nodbedit', required => 0, default => 1, enum => [0,1] }, - { post => 'notify_announce', required => 0, default => 0, enum => [0,1] } - ); - return $self->resNotFound if $frm->{_err}; - $self->authPref($_, $frm->{$_}) for ('notify_nodbedit', 'notify_announce'); - $saved = 1; - - # updating notifications - } elsif($self->reqMethod() eq 'POST') { - return if !$self->authCheckCode; - my $frm = $self->formValidate( - { post => 'notifysel', multi => 1, required => 0, template => 'id' }, - { post => 'markread', required => 0 }, - { post => 'remove', required => 0 } - ); - return $self->resNotFound if $frm->{_err}; - my @ids = grep $_, @{$frm->{notifysel}}; - $self->dbNotifyMarkRead(@ids) if @ids && $frm->{markread}; - $self->dbNotifyRemove(@ids) if @ids && $frm->{remove}; - $self->authInfo->{notifycount} = $self->dbUserGet(uid => $uid, what => 'notifycount')->[0]{notifycount}; - } - - my($list, $np) = $self->dbNotifyGet( - uid => $uid, - page => $f->{p}, - results => 25, - what => 'titles', - read => $f->{r} == 1 ? undef : 0, - reverse => $f->{r} == 1, - ); - - $self->htmlHeader(title => 'My notifications', noindex => 1); - $self->htmlMainTabs(u => $u); - div class => 'mainbox'; - h1 'My notifications'; - p class => 'browseopts'; - a !$f->{r} ? (class => 'optselected') : (), href => "/u$uid/notifies?r=0", 'Unread notifications'; - a $f->{r} ? (class => 'optselected') : (), href => "/u$uid/notifies?r=1", 'All notifications'; - end; - p 'No notifications!' if !@$list; - end; - - my $code = $self->authGetCode("/u$uid/notifies"); - - 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', - ); - - if(@$list) { - form action => "/u$uid/notifies?r=$f->{r};formcode=$code", method => 'post', id => 'notifies'; - $self->htmlBrowse( - items => $list, - options => $f, - nextpage => $np, - class => 'notifies', - pageurl => "/u$uid/notifies?r=$f->{r}", - header => [ - [ '' ], - [ 'Type' ], - [ 'Age' ], - [ 'ID' ], - [ 'Action' ], - ], - row => sub { - my($s, $n, $l) = @_; - Tr $l->{read} ? () : (class => 'unread'); - td class => 'tc1'; - input type => 'checkbox', name => 'notifysel', value => "$l->{id}"; - end; - td class => 'tc2', $ntypes{$l->{ntype}}; - td class => 'tc3', fmtage $l->{date}; - td class => 'tc4'; - a href => "/u$uid/notify/$l->{id}", "$l->{ltype}$l->{iid}".($l->{subid}?".$l->{subid}":''); - end; - td class => 'tc5 clickable', id => "notify_$l->{id}"; - lit sprintf - $l->{ltype} ne 't' ? 'Edit of %s by %s' : - $l->{subid} == 1 ? 'New thread %s by %s' : 'Reply to %s by %s', - sprintf('<i>%s</i>', xml_escape $l->{c_title}), - sprintf('<i>%s</i>', xml_escape $l->{username}); - end; - end 'tr'; - }, - footer => sub { - Tr; - td colspan => 5; - input type => 'checkbox', class => 'checkall', name => 'notifysel', value => 0; - txt ' '; - input type => 'submit', name => 'markread', value => 'mark selected read'; - input type => 'submit', name => 'remove', value => 'remove selected'; - b class => 'grayedout', ' (Read notifications are automatically removed after one month)'; - end; - end; - } - ); - end; - } - - form method => 'post', action => "/u$uid/notifies?formcode=$code"; - div class => 'mainbox'; - h1 'Settings'; - div class => 'notice', 'Settings successfully saved.' if $saved; - p; - for('nodbedit', 'announce') { - my $def = $_ eq 'nodbedit' ? 0 : 1; - input type => 'checkbox', name => "notify_$_", id => "notify_$_", value => $def, - ($self->authPref("notify_$_")||0) == $def ? (checked => 'checked') : (); - label for => "notify_$_", $_ eq 'nodbedit' - ? ' Notify me about edits of database entries I contributed to.' - : ' Notify me about site announcements.'; - br; - } - input type => 'submit', name => 'set', value => 'Save'; - end; - end; - end 'form'; - $self->htmlFooter; -} - - -sub readnotify { - my($self, $uid, $nid) = @_; - return $self->htmlDenied if !$self->authInfo->{id} || $uid != $self->authInfo->{id}; - my $n = $self->dbNotifyGet(uid => $uid, id => $nid)->[0]; - return $self->resNotFound if !$n->{iid}; - $self->dbNotifyMarkRead($n->{id}) if !$n->{read}; - # NOTE: for t+.+ IDs, this will create a double redirect, which is rather awkward... - $self->resRedirect("/$n->{ltype}$n->{iid}".($n->{subid}?".$n->{subid}":''), 'perm'); -} - - -1; - diff --git a/lib/VNDB/Handler/VNBrowse.pm b/lib/VNDB/Handler/VNBrowse.pm deleted file mode 100644 index da3f3782..00000000 --- a/lib/VNDB/Handler/VNBrowse.pm +++ /dev/null @@ -1,138 +0,0 @@ - -package VNDB::Handler::VNBrowse; - -use strict; -use warnings; -use TUWF ':html', 'uri_escape'; -use VNDB::Func; - - -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 => 'vnlist', required => 0, default => 2, enum => [ '0', '1' ] }, # 2: use pref - { get => 'wish', 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'); - $f->{wish} = $read_write_pref->('wish', 'vn_list_wish'); - - 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}}; - $f->{rfil} = fil_serialize $rfil, @{$VNDB::Util::Misc::filfields{release}}; - - my($list, $np) = $self->filFetchDB(vn => $f->{fil}, { - %compat, - tagspoil => $self->authPref('spoilers')||0, - }, { - what => ' rating' . - ($f->{vnlist} ? ' vnlist' : ''). - ($f->{wish} ? ' wishlist' : ''), - $char ne 'all' ? ( char => $char ) : (), - $f->{q} ? ( search => $f->{q} ) : (), - keys %$rfil ? ( release => $rfil ) : (), - 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};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'; - a href => $url->($char, 'wish' ), $f->{wish} ? (class => 'optselected') : (), 'Wishlist'; - end 'p'; - } - - p class => 'filselect'; - a id => 'filselect', href => '#v'; - lit '<i>▸</i> Visual Novel Filters<i></i>'; - end; - a id => 'rfilselect', href => '#r'; - lit '<i>▸</i> Release filters<i></i>'; - end; - end; - input type => 'hidden', class => 'hidden', name => $_, id => $_, value => $f->{$_} - for (qw{fil rfil s o}); - end; - end 'form'; - - $self->htmlBrowseVN($list, $f, $np, "/v/$char?q=$quri;fil=$f->{fil};rfil=$f->{rfil}", $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 %{$self->{languages}} ], default => '' }, - { get => 'pl', required => 0, multi => 1, enum => [ keys %{$self->{platforms}} ], 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 ce10611d..00000000 --- a/lib/VNDB/Handler/VNEdit.pm +++ /dev/null @@ -1,545 +0,0 @@ - -package VNDB::Handler::VNEdit; - -use strict; -use warnings; -use TUWF ':html', ':xml'; -use Image::Magick; -use VNDB::Func; - - -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_wp l_encubed l_renai 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 => [ 0..$#{$self->{vn_lengths}} ] }, - { post => 'l_wp', required => 0, default => '', maxlength => 150 }, - { post => 'l_encubed', required => 0, default => '', maxlength => 100 }, - { post => 'l_renai', required => 0, default => '', maxlength => 100 }, - { 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 %{$self->{staff_roles}} ] }, - { 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 }, - ); - # 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_wp l_encubed l_renai 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) = @_; - my $import = @$chars ? $self->dbVNImportSeiyuu($v->{id}, [ map $_->{id}, @$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', width => 450, options => - [ map [ $_ => fmtvnlen $_, 2 ], 0..$#{$self->{vn_lengths}} ] ], - - [ input => short => 'l_wp', name => 'External links', pre => 'http://en.wikipedia.org/wiki/' ], - [ input => short => 'l_encubed', pre => 'http://novelnews.net/tag/', post => '/' ], - [ input => short => 'l_renai', 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 { - if (@$import) { - script_json castimpdata => [ - map { my $c = $_; +{ map { $_ => $c->{$_} } qw|cid sid aid name| } } @$import - ]; - div id => 'cast_import'; - a href => '#', title => 'Import character cast from related visual novels', 'Import cast'; - end; - } - 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 => $_, $self->{vn_relations}{$_}[1] - for (keys %{$self->{vn_relations}}); - 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{$_} = [ $self->{vn_relations}{ $$new{$_}[0] }[0], $$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 5f335019..00000000 --- a/lib/VNDB/Handler/VNPage.pm +++ /dev/null @@ -1,982 +0,0 @@ - -package VNDB::Handler::VNPage; - -use strict; -use warnings; -use TUWF ':html', 'xml_escape'; -use VNDB::Func; - - -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 $_", $TUWF::OBJ->{languages}{$_}; - 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 $_, $TUWF::OBJ->{platforms}{$_}; - 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} }, - draw => sub { - if($_[0]{resolution}) { - txt $TUWF::OBJ->{resolutions}[$_[0]{resolution}][0]; - } else { - txt 'Unknown'; - } - }, - }, { # 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 $TUWF::OBJ->{voiced}[$_[0]{voiced}] }, - }, { # 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: $TUWF::OBJ->{animated}[$_[0]{ani_story}]" :(), - $_[0]{ani_ero} ? "Ero scenes: $TUWF::OBJ->{animated}[$_[0]{ani_ero}]":(); - 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 %{$self->{platforms}} ] }, - { get => 'lang', required => 0, default => 'all', enum => [ 'all', keys %{$self->{languages}} ] }, - ); - 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', $self->{platforms}, '') if $f->{pla}; - $plat_lang_draw->('languages', 'lang',$self->{languages}, '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 => 'producers platforms', results => 200); - - my $metadata = { - 'og:title' => $v->{title}, - 'og:description' => $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', $v->{original} if $v->{original}; - - div class => 'vndetails'; - - # image - div class => 'vnimg'; - if(!$v->{image}) { - p 'No image uploaded yet'; - } else { - p $v->{img_nsfw} ? (id => 'nsfw_hid', $self->authPref('show_nsfw') ? () : (class => 'hidden')) : (); - img src => imgurl(cv => $v->{image}), alt => $v->{title}; - i 'Flagged as NSFW' if $v->{img_nsfw}; - end; - if($v->{img_nsfw}) { - p id => 'nsfw_show', $self->authPref('show_nsfw') ? (class => 'hidden') : (); - txt 'This image has been flagged as Not Safe For Work.'; - br; br; - a href => '#', 'Show me anyway'; - br; br; - txt '(This warning can be disabled in your account)'; - end; - } - } - 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 $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; - } - my @links = ( - $v->{l_wp} ? [ 'Wikipedia', 'http://en.wikipedia.org/wiki/%s', $v->{l_wp} ] : (), - $v->{l_encubed} ? [ 'Encubed', 'http://novelnews.net/tag/%s/', $v->{l_encubed} ] : (), - $v->{l_renai} ? [ 'Renai.us', 'http://renai.us/game/%s.shtml', $v->{l_renai} ] : (), - ); - if(@links) { - Tr; - td 'Links'; - td; - for(@links) { - a href => sprintf($_->[1], $_->[2]), $_->[0]; - txt ', ' if $_ ne $links[$#links]; - } - end; - end; - } - - _producers($self, $r); - _relations($self, $v) if @{$v->{relations}}; - _anime($self, $v) if @{$v->{anime}}; - _useroptions($self, $v) if $self->authInfo->{id}; - _affiliate_links($self, $r); - - 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); - if(@$t) { - div id => 'tagops'; - # NOTE: order of these links is hardcoded in JS - my $tags_cat = $self->authPref('tags_cat') || $self->{default_tags_cat}; - a href => "#$_", $tags_cat =~ /\Q$_/ ? (class => 'tsel') : (), lc $self->{tag_categories}{$_} for keys %{$self->{tag_categories}}; - my $spoiler = $self->authPref('spoilers') || 0; - a href => '#', class => 'sec'.($spoiler == 0 ? ' tsel' : ''), lc 'Hide spoilers'; - a href => '#', $spoiler == 1 ? (class => 'tsel') : (), lc 'Show minor spoilers'; - a href => '#', $spoiler == 2 ? (class => 'tsel') : (), lc 'Spoil me!'; - a href => '#', class => 'sec'.($self->authPref('tags_all') ? '': ' tsel'), 'summary'; - a href => '#', $self->authPref('tags_all') ? (class => 'tsel') : (), 'all'; - end; - div id => 'vntags'; - for (@$t) { - span class => sprintf 'tagspl%.0f cat_%s %s', $_->{spoiler}, $_->{cat}, $_->{spoiler} > 0 ? 'hidden' : ''; - a href => "/g$_->{id}", style => sprintf('font-size: %dpx', $_->{rating}*3.5+6), $_->{name}; - b class => 'grayedout', sprintf ' %.1f', $_->{rating}; - end; - txt ' '; - } - 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 - ul class => 'maintabs notfirst'; - if(@$chars) { - li class => 'left '.(!$char ? ' tabselected' : ''); a href => "/v$v->{id}#main", name => 'main', 'main'; end; - li class => 'left '.($char ? ' tabselected' : ''); a href => "/v$v->{id}/chars#chars", name => 'chars', 'characters'; end; - } - if($self->authCan('edit')) { - li; a href => "/c/new?vid=$v->{id}", 'add character'; end; - li; a href => "/v$v->{id}/add", 'add release'; 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; -} - - -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_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="http://renai.us/game/%s.shtml">%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($self->{staff_roles}{$_->{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 %s%s', - $_->{id}, xml_escape($_->{original}||$_->{name}), xml_escape($_->{name}), 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', $self->{vn_relations}{$_->{relation}}[1], - $_->{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 = 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 = values %p; - next if !@p; - cssicon "lang $l", $self->{languages}{$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 $self->{vn_relations}{$_}[1]; - 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} ? $self->{anime_types}{$_->{type}}.', ' : '').$_->{year}.')'; - br; - } - } - end; - end 'tr'; -} - - -sub _useroptions { - my($self, $v) = @_; - - my $vote = $self->dbVoteGet(uid => $self->authInfo->{id}, vid => $v->{id})->[0]; - my $list = $self->dbVNListGet(uid => $self->authInfo->{id}, vid => $v->{id})->[0]; - my $wish = $self->dbWishListGet(uid => $self->authInfo->{id}, vid => $v->{id})->[0]; - - Tr; - td 'User options'; - td; - if($vote || !$wish) { - Select id => 'votesel', name => $self->authGetCode("/v$v->{id}/vote"); - option value => -3, $vote ? 'your vote: '.fmtvote($vote->{vote}) : 'not voted yet'; - optgroup label => $vote ? 'Change vote' : 'Vote'; - option value => $_, "$_ (".fmtrating($_).')' for (reverse 1..10); - option value => -2, 'Other'; - end; - option value => -1, 'revoke' if $vote; - end; - br; - } - - Select id => 'listsel', name => $self->authGetCode("/v$v->{id}/list"); - option $list ? "VN list: $self->{vnlist_status}[$list->{status}]" : 'not on your VN list'; - optgroup label => $list ? 'Change status' : 'Add to VN list'; - option value => $_, $self->{vnlist_status}[$_] for (0..$#{$self->{vnlist_status}}); - end; - option value => -1, 'remove from VN list' if $list; - end; - br; - - if(!$vote || $wish) { - Select id => 'wishsel', name => $self->authGetCode("/v$v->{id}/wish"); - option $wish ? "wishlist: $self->{wishlist_status}[$wish->{wstat}]" : 'not on your wishlist'; - optgroup label => $wish ? 'Change status' : 'Add to wishlist'; - option value => $_, $self->{wishlist_status}[$_] for (0..$#{$self->{wishlist_status}}); - end; - option value => -1, 'remove from wishlist' if $wish; - end; - } - end; - end 'tr'; -} - - -sub _affiliate_links { - my($self, $r) = @_; - return if !keys @$r; - my %r = map +($_->{id}, $_), @$r; - my $links = $self->dbAffiliateGet(rids => [ keys %r ], hidden => 0); - return if !@$links; - - $links = [ sort { $b->{priority}||$self->{affiliates}[$b->{affiliate}]{default_prio} <=> $a->{priority}||$self->{affiliates}[$a->{affiliate}]{default_prio} } @$links ]; - - Tr id => 'buynow'; - td 'Available at'; - td; - for my $link (@$links) { - my $f = $self->{affiliates}[$link->{affiliate}]; - my $rel = $r{$link->{rid}}; - my $plat = join(' and ', map $self->{platforms}{$_}, @{$rel->{platforms}}); - my $version = join(' and ', map $self->{languages}{$_}, @{$rel->{languages}}).' '.$plat.' version'; - - a rel => 'nofollow', href => $f->{link_format} ? $f->{link_format}->($link->{url}) : $link->{url}; - use utf8; - txt $link->{version} - || ($f->{default_version} && $f->{default_version}->($self, $link, $rel)) - || $version; - txt " at $f->{name}"; - abbr class => 'pricenote', title => - $link->{lastfetch} ? sprintf('Last updated: %s.', fmtage($link->{lastfetch})) : '', " for $link->{price}" - if $link->{price}; - txt ' »'; - 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 => 6; - cssicon "lang $l", $self->{languages}{$l}; - txt $self->{languages}{$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 $_, $self->{platforms}{$_}; - } - 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'; - if($self->authInfo->{id}) { - a href => "/r$rel->{id}", id => "rlsel_$rel->{id}", class => 'vnrlsel', - $rel->{ulist} ? $self->{rlist_status}[ $rel->{ulist}{status} ] : '--'; - } else { - txt ' '; - } - end; - td class => 'tc6'; - a href => "/affiliates/new?rid=$rel->{id}", 'a' if $self->authCan('affiliate'); - if($rel->{website}) { - a href => $rel->{website}, rel => 'nofollow'; - cssicon 'external', 'External link'; - end; - } else { - txt ' '; - } - end; - end 'tr'; - } - } - end 'table'; - end 'div'; -} - - -sub _screenshots { - my($self, $v, $r) = @_; - div class => 'mainbox', id => 'screenshots'; - - if(grep $_->{nsfw}, @{$v->{screenshots}}) { - p class => 'nsfwtoggle'; - txt 'Showing '; - i id => 'nsfwshown', $self->authPref('show_nsfw') ? scalar @{$v->{screenshots}} : scalar grep(!$_->{nsfw}, @{$v->{screenshots}}); - txt sprintf ' out of %d screenshot%s. ', scalar @{$v->{screenshots}}, @{$v->{screenshots}} == 1 ? '' : 's'; - a href => '#', id => "nsfwhide", '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 $_", $self->{languages}{$_} for (@{$rel->{languages}}); - 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%s', $_->{nsfw} ? ' nsfw':'', $_->{nsfw}&&!$self->authPref('show_nsfw')?' hidden':''), - '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 %{$self->{char_roles}}) { - $rol{$r} = [ grep grep($_->{role} eq $r, @{$_->{vns}}) && !$done{$_->{id}}++, @$l ]; - } - my $first = 0; - for my $r (keys %{$self->{char_roles}}) { - next if !@{$rol{$r}}; - div class => 'mainbox'; - $self->charOps(1) if !$first++; - h1 $self->{char_roles}{$r}[ @{$rol{$r}} > 1 ? 1 : 0 ]; - $self->charTable($_, 1, $_ != $rol{$r}[0], 1, _charspoillvl $v->{id}, $_) for (@{$rol{$r}}); - end; - } -} - - -sub _charsum { - my($self, $l, $v) = @_; - return if !@$l; - - my(@l, %done, $has_spoilers); - for my $r (keys %{$self->{char_roles}}) { - 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'; - $self->charOps(0) 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 $self->{char_roles}{$c->{role}}[0]; - cssicon "gen $c->{gender}", $self->{genders}{$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' => 100, id => 'staff'; - h1 'Staff'; - for my $r (keys %{$self->{staff_roles}}) { - my @s = grep $_->{role} eq $r, @{$v->{credits}}; - next if !@s; - ul; - li; b $self->{staff_roles}{$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/Util/Auth.pm b/lib/VNDB/Util/Auth.pm deleted file mode 100644 index e3ee20eb..00000000 --- a/lib/VNDB/Util/Auth.pm +++ /dev/null @@ -1,227 +0,0 @@ - -package VNDB::Util::Auth; - - -use strict; -use warnings; -use Exporter 'import'; -use Digest::SHA qw|sha1 sha1_hex|; -use Crypt::URandom 'urandom'; -use Crypt::ScryptKDF 'scrypt_raw'; -use Encode 'encode_utf8'; -use TUWF ':html'; -use VNDB::Func; - - -our @EXPORT = qw| - authInit authLogin authLogout authInfo authCan authSetPass authAdminSetPass - authResetPass authIsValidToken authGetCode authCheckCode authPref -|; - - -sub randomascii { - return join '', map chr($_%92+33), unpack 'C*', urandom shift; -} - - -# Fetches and parses the auth cookie. -# Returns (uid, encrypted_token) on success, (0, '') on failure. -sub parsecookie { - # Earlier versions of the auth cookie didn't have the dot separator, so that's optional. - return ($_[0]->reqCookie('auth')||'') =~ /^([a-fA-F0-9]{40})\.?(\d+)$/ ? ($2, sha1 pack 'H*', $1) : (0, ''); -} - - -# initializes authentication information and checks the vndb_auth cookie -sub authInit { - my $self = shift; - - my($uid, $token_e) = parsecookie($self); - $self->{_auth} = $uid && $self->dbUserGet(uid => $uid, session => $token_e, what => 'extended notifycount prefs')->[0]; - $self->{_auth}{token} = $token_e if $self->{_auth}; - - # update the sessions.lastused column if lastused < now()-'6 hours' - $self->dbUserUpdateLastUsed($uid, $token_e) if $self->{_auth} && $self->{_auth}{session_lastused} < time()-6*3600; - - # Drop the cookie if it's not valid - $self->resCookie(auth => undef) if !$self->{_auth} && $self->reqCookie('auth'); -} - - -# login, arguments: user, password, url-to-redirect-to-on-success -# returns 1 on success (redirected), 0 otherwise (no reply sent) -sub authLogin { - my($self, $user, $pass, $to) = @_; - - return 0 if !$user || !$pass; - - my $d = $self->dbUserGet(username => $user, what => 'scryptargs extended prefs notifycount')->[0]; - return 0 if !$d->{id} || !$d->{scryptargs} || length($d->{scryptargs}) != 14; - - my($N, $r, $p, $salt) = unpack 'NCCa8', $d->{scryptargs}; - my $encpass = _preparepass($self, $pass, $salt, $N, $r, $p); - - return _createsession($self, $d->{id}, $encpass, $to); -} - - -# Prepares a plaintext password for database storage -# Arguments: pass, optionally: salt, N, r, p -# Returns: encrypted password (as a binary string) -sub _preparepass { - my($self, $pass, $salt, $N, $r, $p) = @_; - ($N, $r, $p) = @{$self->{scrypt_args}} if !$N; - $salt ||= urandom(8); - return pack 'NCCa8a*', $N, $r, $p, $salt, scrypt_raw($pass, $self->{scrypt_salt} . $salt, $N, $r, $p, 32); -} - - -# self, uid, encpass, url-to-redirect-to -sub _createsession { - my($self, $uid, $encpass, $url) = @_; - - my $token = urandom(20); - return 0 if !$self->dbUserLogin($uid, $encpass, sha1 $token); - - $self->resRedirect($url, 'post'); - $self->resCookie(auth => unpack('H*', $token).'.'.$uid, httponly => 1, expires => time + 31536000); # keep the cookie for 1 year - return 1; -} - - -# clears authentication cookie and redirects to / -sub authLogout { - my $self = shift; - - my($uid, $token_e) = parsecookie($self); - $self->dbUserLogout($uid, $token_e) if $uid; - - $self->resRedirect('/', 'temp'); - $self->resCookie(auth => undef); -} - - -# Replaces the user's password with a random token that can be used to reset the password. -sub authResetPass { - my $self = shift; - my $mail = shift; - my $token = unpack 'H*', urandom(20); - my $id = $self->dbUserResetPass($mail, sha1(lc($token))); - return $id ? ($id, $token) : (); -} - - -# uid, token -sub authIsValidToken { - $_[0]->dbUserIsValidToken($_[1], sha1(lc($_[2]))) -} - - -# 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($self, $uid, $pass, $redir, $oldtype, $oldpass) = @_; - - if($oldtype eq 'token') { - $oldpass = sha1(lc($oldpass)); - - } elsif($oldtype eq 'pass') { - my $u = $self->dbUserGet(uid => $uid, what => 'scryptargs')->[0]; - return 0 if !$u->{id} || !$u->{scryptargs} || length($u->{scryptargs}) != 14; - my($N, $r, $p, $salt) = unpack 'NCCa8', $u->{scryptargs}; - $oldpass = _preparepass($self, $oldpass, $salt, $N, $r, $p); - } - - $pass = _preparepass($self, $pass); - return 0 if !$self->dbUserSetPass($uid, $oldpass, $pass); - return _createsession($self, $uid, $pass, $redir); -} - - -sub authAdminSetPass { - my($self, $uid, $pass) = @_; - $pass = _preparepass($self, $pass); - $self->dbUserAdminSetPass($uid, $self->authInfo->{id}, $self->authInfo->{token}, $pass); -} - - -# returns a hashref with information about the current loggedin user -# the hash is identical to the hash returned by dbUserGet -# returns empty hash if no user is logged in. -sub authInfo { - return shift->{_auth} || {}; -} - - -# returns whether the currently loggedin or anonymous user can perform -# a certain action. Argument is the action name as defined in global.pl -sub authCan { - my($self, $act) = @_; - return $self->{_auth} ? $self->{_auth}{perm} & $self->{permissions}{$act} : 0; -} - - -# 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 (string, can be empty, but makes the validation stronger) -# time (optional, time() to encode in the code) -sub authGetCode { - my $self = shift; - my $id = shift; - my $time = (shift || time)/3600; # accuracy of an hour - my $uid = encode_utf8($self->{_auth} ? $self->{_auth}{id} : norm_ip($self->reqIP())); - return lc substr sha1_hex($self->{form_salt} . $uid . encode_utf8($id||'') . pack('N', int $time)), 0, 16; -} - - -# 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 || $self->reqPath(); - my $code = shift || $self->reqParam('formcode'); - return _incorrectcode($self) if !$code || $code !~ qr/^[0-9a-f]{16}$/; - my $time = time; - return 1 if $self->authGetCode($id, $time) eq $code; - return 1 if $self->authGetCode($id, $time-3600) eq $code; - return 1 if $self->authGetCode($id, $time-2*3600) eq $code; - return _incorrectcode($self); -} - - -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($self, $key, $val) = @_; - my $nfo = $self->authInfo; - return '' if !$nfo->{id}; - return $nfo->{prefs}{$key}||'' if @_ == 2; - $nfo->{prefs}{$key} = $val; - $self->dbUserPrefSet($nfo->{id}, $key, $val); -} - -1; - diff --git a/lib/VNDB/Util/BrowseHTML.pm b/lib/VNDB/Util/BrowseHTML.pm deleted file mode 100644 index c3115017..00000000 --- a/lib/VNDB/Util/BrowseHTML.pm +++ /dev/null @@ -1,223 +0,0 @@ - -package VNDB::Util::BrowseHTML; - -use strict; -use warnings; -use TUWF ':html', 'xml_escape'; -use Exporter 'import'; -use VNDB::Func; -use POSIX 'ceil'; - - -our @EXPORT = qw| htmlBrowse htmlBrowseNavigate htmlBrowseHist 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($left, $page, $label) = @_; - li $left ? (class => 'left') : (); - a href => $url.$page; lit $label; end; - end; - }; - my $ell = sub { - use utf8; - li class => 'ellipsis'.(shift() ? ' left' : ''); - b '⋯'; - end; - }; - my $nc = 5; # max. number of buttons on each side - - ul class => 'maintabs browsetabs ' . ($al eq 't' ? 'notfirst' : 'bottom'); - $p > 2 and ref $np and $tab->(1, 1, '« first'); - $p > $nc+1 and ref $np and $ell->(1); - $p > $_ and ref $np and $tab->(1, $p-$_, $p-$_) for (reverse 2..($nc>$p-2?$p-2:$nc-1)); - $p > 1 and $tab->(1, $p-1, '‹ previous'); - - my $l = ceil($cnt/$pp)-$p+1; - $l > 2 and $tab->(0, $l+$p-1, 'last »'); - $l > $nc+1 and $ell->(0); - $l > $_ and $tab->(0, $p+$_, $p+$_) for (reverse 2..($nc>$l-2?$l-2:$nc-1)); - $l > 1 and $tab->(0, $p+1, 'next ›'); - end 'ul'; -} - - -sub htmlBrowseHist { - my($self, $list, $f, $np, $url) = @_; - $self->htmlBrowse( - items => $list, - options => $f, - nextpage => $np, - pageurl => $url, - class => 'history', - header => [ - sub { td class => 'tc1_1', 'Rev.'; td class => 'tc1_2', ''; }, - [ 'Date' ], - [ 'User' ], - [ 'Page' ], - ], - row => sub { - my($s, $n, $i) = @_; - my $revurl = "/$i->{type}$i->{itemid}.$i->{rev}"; - - Tr; - td class => 'tc1_1'; - a href => $revurl, "$i->{type}$i->{itemid}"; - end; - td class => 'tc1_2'; - a href => $revurl, ".$i->{rev}"; - end; - td class => 'tc2', fmtdate $i->{added}, 'full'; - td class => 'tc3'; - lit fmtuser $i; - end; - td class => 'tc4'; - a href => $revurl, title => $i->{ioriginal}, shorten $i->{ititle}, 80; - b class => 'grayedout'; lit bb2html $i->{comments}, 150; end; - end; - end 'tr'; - }, - ); -} - - -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'; - tagscore $l->{tagscore}, 0; - 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}; - end 'td'; - } - td class => 'tc8', defined($l->{wstat}) ? $self->{wishlist_status}[$l->{wstat}] : '' if $f->{wish}; - td class => 'tc2'; - $_ ne 'oth' && cssicon $_, $self->{platforms}{$_} - for (sort @{$l->{c_platforms}}); - end; - td class => 'tc3'; - cssicon "lang $_", $self->{languages}{$_} - 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 e8561e3c..00000000 --- a/lib/VNDB/Util/CommonHTML.pm +++ /dev/null @@ -1,477 +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, object, currently selected item (empty=main) -sub htmlMainTabs { - my($self, $type, $obj, $sel) = @_; - $sel ||= ''; - my $id = $type.$obj->{id}; - - return if $type eq 'g' && !$self->authCan('tagmod'); - - ul class => 'maintabs'; - if($type =~ /[uvrpcs]/) { - li $sel eq 'hist' ? (class => 'tabselected') : (); - a href => "/$id/hist", 'history'; - end; - } - - if($type =~ /[uvp]/) { - my $cnt = $self->dbThreadCount($type, $obj->{id}); - li $sel eq 'disc' ? (class => 'tabselected') : (); - a href => "/t/$id", "discussions ($cnt)"; - end; - } - - if($type eq 'u') { - li $sel eq 'posts' ? (class => 'tabselected') : (); - a href => "/$id/posts", 'posts'; - end; - } - - if($type eq 'u' && (!($obj->{hide_list} || $obj->{prefs}{hide_list}) || ($self->authInfo->{id} && $self->authInfo->{id} == $obj->{id}) || $self->authCan('usermod'))) { - li $sel eq 'wish' ? (class => 'tabselected') : (); - a href => "/$id/wish", 'wishlist'; - end; - - li $sel eq 'votes' ? (class => 'tabselected') : (); - a href => "/$id/votes", 'votes'; - end; - - li $sel eq 'list' ? (class => 'tabselected') : (); - a href => "/$id/list", 'list'; - end; - } - - if($type eq 'v' && $self->authCan('tag') && !$obj->{hidden}) { - li $sel eq 'tagmod' ? (class => 'tabselected') : (); - a href => "/$id/tagmod", 'modify tags'; - end; - } - - if(($type =~ /[rc]/ && $self->authCan('edit')) && $self->authInfo->{c_changes} > 0) { - li $sel eq 'copy' ? (class => 'tabselected') : (); - a href => "/$id/copy", 'copy'; - end; - } - - if( $type eq 'u' && ($self->authInfo->{id} && $obj->{id} == $self->authInfo->{id} || $self->authCan('usermod')) - || $type =~ /[vrpcs]/ && $self->authCan('edit') && ((!$obj->{locked} && !$obj->{hidden}) || $self->authCan('dbmod')) - || $type =~ /[gi]/ && $self->authCan('tagmod') - ) { - li $sel eq 'edit' ? (class => 'tabselected') : (); - a href => "/$id/edit", 'edit'; - end; - } - - if($type eq 'u' && $self->authCan('usermod')) { - li $sel eq 'del' ? (class => 'tabselected') : (); - a href => "/$id/del", 'remove'; - end; - } - - if($type eq 'v') { - li $sel eq 'releases' ? (class => 'tabselected') : (); - a href => "/$id/releases", 'releases'; - end; - } - - if($type =~ /[vp]/ && $obj->{rgraph}) { - li $sel eq 'rg' ? (class => 'tabselected') : (); - a href => "/$id/rg", 'relations'; - end; - } - - li !$sel ? (class => 'tabselected') : (); - a href => "/$id", $id; - end; - end 'ul'; -} - - -# generates a full error page, including header and footer -sub htmlDenied { - my $self = shift; - $self->htmlHeader(title => 'Access Denied'); - div class => 'mainbox'; - h1 'Access Denied'; - div class => 'warning'; - if(!$self->authInfo->{id}) { - h2 'You need to be logged in to perform this action.'; - p; lit 'Please <a href="/u/login">login</a>, or <a href="/u/register">create an account</a> if you don\'t have one yet.'; end; - } else { - h2 'You are not allowed to perform this action.'; - p 'It seems you don\'t have the proper rights to perform the action you wanted to perform...'; - } - end; - end 'div'; - $self->htmlFooter; -} - - -# 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 =~ /[cs]/ ? '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} - : $type eq 's' ? $self->dbStaffGetRev(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, 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) -# 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}"; - - # character information may be rather spoilerous - if($type eq 'c') { - div class => 'warning'; - h2 'SPOILER WARNING!'; - lit 'This revision page may contain major spoilers. You may want to view the <a href="/c'.$new->{id}.'">final page</a> instead.'; - end; - br;br; - } - - # 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 ' '; end; - td; revheader($self, $type, $old); end; - td; revheader($self, $type, $new); end; - end; - Tr; - td; lit ' '; 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", 'edit'; - txt ')'; - br; - txt 'By '; - lit fmtuser $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); - for my $i (0..($#d-2)/2) { - # $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 ]); - $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 -sub htmlEditMessage { - my($self, $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}; - - div class => 'mainbox'; - h1 $title; - if($copy) { - div class => 'warning'; - h2 'You\'re not editing an entry!'; - p; - txt 'You\'re about to insert a new entry into the database with information based on '; - a href => "/$type$obj->{id}", $obj->{title}||$obj->{name}; - txt '.'; - br; - txt 'Hit the \'edit\' tab on the right-top if you intended to edit the entry instead of creating a new one.'; - end; - end; - } - div class => 'notice'; - h2 'Before editing:'; - ul; - li; - txt "Read the "; - a href=> "/d$guidelines", 'guidelines'; - txt '!'; - end; - if($obj) { - li; - txt 'Check for any existing discussions on the '; - a href => $type =~ /[cs]/ ? '/t/db' : $type eq 'r' ? "/t/v$obj->{vn}[0]{vid}" : "/t/$type$obj->{id}", 'discussion board'; - end; - li; - txt 'Browse the '; - a href => "/$type$obj->{id}/hist", 'edit history'; - txt ' for any recent changes related to what you want to change.'; - end; - } elsif($type ne 'r') { - li; - a href => "/$type/all", 'Search the database'; - txt " to see if we already have information about this $typename."; - end; - } - end; - end; - if($obj && !$obj->{lastrev}) { - div class => 'warning'; - 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!"; - end; - } - end 'div'; -} - - -# 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 -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->dbVoteGet( - $type.'id' => $obj->{id}, - results => 8, - what => $type eq 'v' ? 'user' : 'vn', - hide => $type eq 'v', - hide_ign => $type eq 'v', - ); - 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($type eq 'u') { - a href => "/v$_->{vid}", title => $_->{original}||$_->{title}, shorten $_->{title}, 40; - } else { - a href => "/u$_->{uid}", $_->{username}; - } - 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 { - my($self, $sel, $v) = @_; - - fieldset class => 'search'; - p id => 'searchtabs'; - 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'; - end; - input type => 'text', name => 'q', id => 'q', class => 'text', value => $v; - input type => 'submit', class => 'submit', value => 'Search!'; - end 'fieldset'; -} - - -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 a522599e..00000000 --- a/lib/VNDB/Util/FormHTML.pm +++ /dev/null @@ -1,277 +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'; - 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, (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 ' '; - 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 ' '; - } - 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 => $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 -# 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) { - ul class => 'maintabs notfirst', 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'; - } - - # 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; - } - 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 5cb266f4..00000000 --- a/lib/VNDB/Util/LayoutHTML.pm +++ /dev/null @@ -1,204 +0,0 @@ - -package VNDB::Util::LayoutHTML; - -use strict; -use warnings; -use TUWF ':html', 'uri_escape'; -use Exporter 'import'; -use Encode 'decode_utf8'; -use VNDB::Func; - -our @EXPORT = qw|htmlHeader htmlFooter|; - - -sub htmlHeader { # %options->{ title, noindex, search, feeds, svg, metadata } - my($self, %o) = @_; - my $skin = $self->reqGet('skin') || $self->authPref('skin') || $self->{skin_default}; - $skin = $self->{skin_default} if !$self->{skins}{$skin} || !-d "$VNDB::ROOT/static/s/$skin"; - - # heading - lit '<!DOCTYPE HTML>'; - tag 'html', lang => 'en'; - head prefix => 'og: http://ogp.me/ns#'; - title $o{title}; - Link rel => 'shortcut icon', href => '/favicon.ico', type => 'image/x-icon'; - Link rel => 'stylesheet', href => $self->{url_static}.'/s/'.$skin.'/style.css?'.$self->{version}, type => 'text/css', media => 'all'; - Link rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB VN Search', href => $self->reqBaseURI().'/opensearch.xml'; - if($self->authPref('customcss')) { - (my $css = $self->authPref('customcss')) =~ s/\n/ /g; - style type => 'text/css', $css; - } - Link rel => 'alternate', type => 'application/atom+xml', href => "/feeds/$_.atom", title => $self->{atom_feeds}{$_}[1] - for ($o{feeds} ? @{$o{feeds}} : ()); - - if(exists $o{metadata}) { - # Required fields as per http://op.me/#metadata: og:title, og:type, og:image, og:url - if(exists $o{metadata}{'og:title'}) { - $o{metadata}{'og:site_name'} = 'The Visual Novel Database'; - $o{metadata}{'og:type'} ||= 'object'; - $o{metadata}{'og:image'} ||= $self->{placeholder_img}; - $o{metadata}{'og:url'} ||= $self->reqURI(); - } - - for my $k (keys %{$o{metadata}}) { - next if !$o{metadata}{$k} and $o{metadata}{$k} ne '0'; - $o{metadata}{$k} =~ s/\R/ /g; - - meta property => "$k", content => $o{metadata}->{$k}, undef; - } - } - - meta name => 'robots', content => 'noindex, follow', undef if $o{noindex}; - end; - body; - div id => 'bgright', ' '; - div id => 'header'; - h1; - a href => '/', 'the visual novel database'; - end; - end; - - _menu($self, %o); - - div id => 'maincontent'; -} - - -sub _menu { - my($self, %o) = @_; - - div id => 'menulist'; - - div class => 'menubox'; - h2; - txt 'Menu'; - end; - div; - a href => '/', 'Home'; br; - a href => '/v/all', 'Visual novels'; br; - b class => 'grayedout', '> '; 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 => '/u/all', 'Users'; br; - a href => '/hist', 'Recent changes'; br; - a href => '/t', 'Discussion board'; br; - a href => '/d6', 'FAQ'; br; - a href => '/v/rand','Random visual novel'; - end; - form action => '/v/all', method => 'get', id => 'search'; - fieldset; - legend 'Search'; - input type => 'text', class => 'text', id => 'sq', name => 'sq', value => $o{search}||'', placeholder => 'search'; - input type => 'submit', class => 'submit', value => 'Search'; - end; - end; - end 'div'; # /menubox - - div class => 'menubox'; - if($self->authInfo->{id}) { - my $uid = sprintf '/u%d', $self->authInfo->{id}; - my $nc = $self->authInfo->{notifycount}; - h2; - a href => $uid, ucfirst $self->authInfo->{username}; - end; - div; - a href => "$uid/edit", 'My Profile'; br; - a href => "$uid/list", 'My Visual Novel List'; br; - a href => "$uid/votes",'My Votes'; br; - a href => "$uid/wish", 'My Wishlist'; br; - a href => "$uid/notifies", $nc ? (class => 'notifyget') : (), 'My Notifications'.($nc?" ($nc)":''); br; - a href => "$uid/hist", 'My Recent Changes'; br; - a href => '/g/links?u='.$self->authInfo->{id}, 'My Tags'; br; - br; - if($self->authCan('edit')) { - 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; - } - br; - a href => "$uid/logout", 'Logout'; - end; - } else { - h2 'User menu'; - div; - my $ref = uri_escape $self->reqPath().$self->reqQuery(); - a href => "/u/login?ref=$ref", 'Login'; br; - a href => '/u/newpass', 'Password reset'; br; - a href => '/u/register', 'Register'; br; - end; - } - end 'div'; # /menubox - - div class => 'menubox'; - h2 'Database Statistics'; - div; - dl; - dt 'Visual Novels'; dd $self->{stats}{vn}; - dt 'Releases'; dd $self->{stats}{releases}; - dt 'Producers'; dd $self->{stats}{producers}; - dt 'Characters'; dd $self->{stats}{chars}; - dt 'Staff'; dd $self->{stats}{staff}; - dt 'VN Tags'; dd $self->{stats}{tags}; - dt 'Character Traits';dd $self->{stats}{traits}; - dt 'Users'; dd $self->{stats}{users}; - dt 'Threads'; dd $self->{stats}{threads}; - dt 'Posts'; dd $self->{stats}{posts}; - end; - clearfloat; - end; - end; - end 'div'; # /menulist -} - - -sub htmlFooter { # %options => { pref_code => 1 } - my($self, %o) = @_; - div id => 'footer'; - - my $q = $self->dbRandomQuote; - if($q && $q->{vid}) { - lit '"'; - a href => "/v$q->{vid}", style => 'text-decoration: none', $q->{quote}; - txt '"'; - br; - } - - txt "vndb $self->{version} | "; - a href => '/d7', 'about us'; - txt ' | '; - a href => 'irc://irc.synirc.net/vndb', '#vndb'; - txt ' | '; - a href => "mailto:$self->{admin_email}", $self->{admin_email}; - txt ' | '; - a href => $self->{source_url}, 'source'; - end; - 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}, ''; - end 'body'; - end 'html'; - - # write the SQL queries as a HTML comment when debugging is enabled - if($self->debug) { - lit "\n<!--\n SQL Queries:\n"; - for (@{$self->{_TUWF}{DB}{queries}}) { - my($sql, $params, $time) = @$_; - lit sprintf " [%6.2fms] %s | %s\n", $time*1000, $sql, - join ', ', - map "$_:".DBI::neat($params->{$_}), - sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b } - keys %$params - } - lit "-->\n"; - } -} - - -1; diff --git a/lib/VNDB/Util/Misc.pm b/lib/VNDB/Util/Misc.pm deleted file mode 100644 index 6a6496b3..00000000 --- a/lib/VNDB/Util/Misc.pm +++ /dev/null @@ -1,175 +0,0 @@ - -package VNDB::Util::Misc; - -use strict; -use warnings; -use Exporter 'import'; -use TUWF ':html'; -use VNDB::Func; - -our @EXPORT = qw|filFetchDB bbSubstLinks|; - - -our %filfields = ( - vn => [qw|date_before date_after released length hasani hasshot tag_inc tag_exc taginc tagexc tagspoil lang olang plat ul_notblack ul_onwish ul_voted ul_onlist|], - release => [qw|type patch freeware doujin date_before date_after released minage lang olang resolution plat med voiced ani_story ani_ero|], - char => [qw|gender bloodt bust_min bust_max waist_min waist_max hip_min hip_max height_min height_max weight_min weight_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 - $self->authPref($prefname => fil_serialize $filters) - if $type eq 'vn' && _fil_vn_compat($self, $filters) && !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; -} - - -sub _fil_vn_compat { - my($self, $fil) = @_; - - # older tag specification (by name rather than ID) - if($fil->{taginc} || $fil->{tagexc}) { - my $tagfind = sub { - return map { - my $i = $self->dbTagGet(name => $_)->[0]; - $i && !$i->{meta} ? $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}; - return 1; - } - - return 0; -} - - -sub bbSubstLinks { - my ($self, $msg) = @_; - - # pre-parse vndb links within message body - my (%lookup, %links); - while ($msg =~ m/(?:^|\s)\K([vcpgis])([1-9][0-9]*)\b/g) { - $lookup{$1}{$2} = 1; - } - return $msg unless %lookup; - my @opt = (results => 50); - # lookup parsed links - if ($lookup{v}) { - $links{"v$_->{id}"} = $_->{title} for (@{$self->dbVNGet(id => [keys %{$lookup{v}}], @opt)}); - } - if ($lookup{c}) { - $links{"c$_->{id}"} = $_->{name} for (@{$self->dbCharGet(id => [keys %{$lookup{c}}], @opt)}); - } - if ($lookup{p}) { - $links{"p$_->{id}"} = $_->{name} for (@{$self->dbProducerGet(id => [keys %{$lookup{p}}], @opt)}); - } - if ($lookup{g}) { - $links{"g$_->{id}"} = $_->{name} for (@{$self->dbTagGet(id => [keys %{$lookup{g}}], @opt)}); - } - if ($lookup{i}) { - $links{"i$_->{id}"} = $_->{name} for (@{$self->dbTraitGet(id => [keys %{$lookup{i}}], @opt)}); - } - if ($lookup{s}) { - $links{"s$_->{id}"} = $_->{name} for (@{$self->dbStaffGet(id => [keys %{$lookup{s}}], @opt)}); - } - return $msg unless %links; - my($result, @open) = ('', 'first'); - - while($msg =~ m{ - (?:\b([tdvprcugis][1-9]\d*)(?:\.[1-9]\d*)?\b) | # 1. id - (\[[^\s\]]+\]) | # 2. tag - ((?:https?|ftp)://[^><"\n\s\]\[]+[\d\w=/-]) # 3. url - }x) { - my($match, $id, $tag) = ($&, $1, $2); - $result .= $`; - $msg = $'; - - if($open[$#open] ne 'raw' && $open[$#open] ne 'code') { - # handle tags - if($tag) { - $tag = lc $tag; - if($tag eq '[raw]') { - push @open, 'raw'; - } elsif($tag eq '[quote]') { - push @open, 'quote'; - } elsif($tag eq '[code]') { - push @open, 'code'; - } elsif($tag eq '[/quote]' && $open[$#open] eq 'quote') { - pop @open; - } elsif($match =~ m{\[url=((https?://|/)[^\]>]+)\]}i) { - push @open, 'url'; - } elsif($tag eq '[/url]' && $open[$#open] eq 'url') { - pop @open; - } - } elsif($id && !grep(/^(?:quote|url)/, @open) && $links{$id}) { - $match = sprintf '[url=/%s]%s[/url]', $match, $links{$id}; - } - } - pop @open if($tag && $open[$#open] eq 'raw' && lc$tag eq '[/raw]'); - pop @open if($tag && $open[$#open] eq 'code' && lc$tag eq '[/code]'); - - $result .= $match; - } - $result .= $msg; - - return $result; -} - -1; - diff --git a/lib/VNDB/Util/ValidateTemplates.pm b/lib/VNDB/Util/ValidateTemplates.pm deleted file mode 100644 index e7ff3102..00000000 --- a/lib/VNDB/Util/ValidateTemplates.pm +++ /dev/null @@ -1,103 +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-]*$/, minlength => 2, maxlength => 15 }, - gtin => { func => \>intype }, - 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 }, - } -); - - -# 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/VNDB/VN/Page.pm b/lib/VNDB/VN/Page.pm new file mode 100644 index 00000000..59ea0ddb --- /dev/null +++ b/lib/VNDB/VN/Page.pm @@ -0,0 +1,57 @@ +package VNDB::VN::Page; + +use strict; +use warnings; +use TUWF ':Html5'; +use VNDB::Auth; +use VNDB::VN::DB; + +my $VID_RE = qr{v(?<vid>[1-9][0-9]*)}; + +sub header { + Div class => 'header', sub { + Div class => 'header__nav', sub { + Div class => 'header__logo', 'vndb'; + Div class => 'header__menu', 'Games'; + }; + Div class => 'header__user', auth->username || 'not logged in'; + }; +} + +sub framework { + my $body = shift; + Html sub { + Head sub { + Meta name => 'viewport', content => 'width=device-width, initial-scale=1, shrink-to-fit=no'; + Title 'VNDBv3 test'; + Link rel => 'stylesheet', href => '/f/style.css'; + }; + Body sub { + Div class => 'container', sub { + header; + }; + $body->(); + }; + }; + Pre style => 'font-size: 8px', sub { + tuwf->dbCommit; # Hack to measure the commit time + Txt "SQL Queries:\n"; + for (@{ tuwf->{_TUWF}{DB}{queries} }) { + my($sql, undef, $time) = @$_; + Txt sprintf " [%6.2fms] %s\n", $time*1000, $sql; + } + } if tuwf->debug; +} + + + + + +TUWF::get qr{/$VID_RE}, sub { + framework sub { + Txt tuwf->capture('vid'); + use Data::Dumper 'Dumper'; + #Pre Dumper [ VNDB::VN::DB::get(undef, {hidden => 1}) ]; + Pre Dumper [ VNDB::DB::entry(v => 1) ]; + }; +}; diff --git a/static/f/style.css b/static/f/style.css new file mode 100644 index 00000000..07f85ae1 --- /dev/null +++ b/static/f/style.css @@ -0,0 +1,268 @@ +* { + box-sizing: border-box; +} + +html { + min-height: 100%; + background: #f3f3f3; + background-image: linear-gradient(#b5bec1, #f3f3f3); + background-size: 600px; + background-repeat: repeat-x; +} + +body { + margin: 0; + color: #171717; + /* font-family: "Helvetica Neue", sans-serif; */ + font-family: -apple-system,BlinkMacSystemFont,"Segoe UI",Roboto,"Helvetica Neue",Arial,sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol"; + font-size: 1rem; + line-height: 1.5; +} + +dt { + font-weight: 600; +} + +dd { + margin: 0 0 .7em 0; +} + +.img--fit { + width: 100%; + height: auto; +} + +.img--rounded { + border-radius: 4px; +} +.elevation-1 { + box-shadow: 0 15px 35px rgba(50,50,93,.2), 0 5px 15px rgba(0,0,0,.2); +} + +.container { + padding: 0 15px; + margin: 0 auto; +} + +.row { + margin: 0 -15px; + display: flex; + flex-wrap: wrap; +} + +.col, .col-lg, .col-xl { + padding-left: 15px; + padding-right: 15px; +} + +.col { + flex: 1; +} + +.d-none { display: none; } +.d-block { display: block; } + +@media (min-width: 576px) { + .container { + max-width: 540px; + } +} +@media (min-width: 768px) { + .container { + max-width: 720px; + } +} +@media (min-width: 992px) { + .container { + max-width: 960px; + } + .col-lg { + flex: 1; + padding-left: 15px; + padding-right: 15px; + } + .col-lg--2 { flex: 2; } + .col-lg--3 { flex: 3; } + .col-lg--4 { flex: 4; } + .d-lg-block { display: block; } + .d-lg-none { display: none; } +} +@media (min-width: 1200px) { + .container { + max-width: 1140px; + } + .col-xl { + flex: 1; + padding-left: 15px; + padding-right: 15px; + } + .col-xl--2 { flex: 2; } + .col-xl--3 { flex: 3; } + .col-xl--4 { flex: 4; } + .d-xl-block { display: block; } + .d-xl-none { display: none; } +} +@media (min-width: 1360px) { + .container { + max-width: 1300px; + } +} + + + +.header { + display: flex; + align-items: center; + height: 64px; +} + +.header__nav { + flex: 1; + display: flex; + align-items: center; +} + +.header__logo { + font-weight: 500; + font-size: 18px; +} + +.header__menu { + margin-left: 40px; + font-weight: 500; +} + +.vn-header { + padding: 60px 0 80px 0; +} + +.vn-header__title { + font-size: 40px; + font-weight: 500; +} + +.vn-header__details { + margin-top: 8px; + font-weight: 500; +} + +.sidebar__item { + position: relative; + display: flex; + align-items: center; + height: 30px; + font-size: 12px; + font-weight: 500; + color: #555; +} + +.sidebar__item--active::before { + display: block; + content: ''; + position: absolute; + left: -20px; + width: 6px; + height: 6px; + border-radius: 6px; + background: #555; +} + +.vn-page { + padding-bottom: 100px; /* tmp */ +} + +.vn-page__top { + display: flex; +} + +.vn-page__top-main { + flex: 1; +} + +.vn-page__top-details { + padding: 15px; + padding-top: 65px; +} + +@media (min-width: 992px) { + .vn-page__top-details { + width: 230px; + margin-left: 40px; + margin-right: 15px; + padding: 0; + padding-top: 65px; + } +} + +.vn-page__top-body { + display: flex; +} + +.vn-page__nav { + width: 230px; +} + +.vn-page__description { + font-family: serif; + line-height: 1.3; + font-size: 1.2em; +} + +.vn-page__sidebar { + width: 230px; + padding: 0 15px; +} + +.section__title { + font-weight: 500; +} + +.vn-page__top-details > * { + margin-bottom: 25px; +} + +.vn-page__dl { + font-size: 0.9em; + margin-top: 35px; +} + +.section { + margin-top: 4em; +} + +.section__title { + margin: 0 0 0.5em 0; +} + +.add-to-list { + background: white; + border-radius: 4px; + padding: 0.8em 1em; +} + +.spoiler { + background-color: #ccc; + color: #ccc; +} + +.spoiler:hover { + background-color: rgba(0, 0, 0, 0.05); + color: inherit; +} + +.gallery { + display: flex; + flex-wrap: wrap; + margin: -7px; +} + +.gallery__image { + margin: 7px; +} + +.fake-img { + width: 200px; + height: 120px; + background-color: #aaa; + border-radius: 4px; +} diff --git a/util/vndb.pl b/util/vndb.pl index c0af72e1..efdc5e25 100755 --- a/util/vndb.pl +++ b/util/vndb.pl @@ -1,97 +1,42 @@ #!/usr/bin/perl - -package VNDB; - use strict; use warnings; - +use TUWF; use Cwd 'abs_path'; -our $ROOT; +my $ROOT; BEGIN { ($ROOT = abs_path $0) =~ s{/util/vndb\.pl$}{}; } - -$|=1; # Disable buffering on STDOUT, otherwise vndb-dev-server.pl won't pick up our readyness notification. - use lib $ROOT.'/lib'; +$|=1; # Disable buffering on STDOUT, otherwise vndb-dev-server.pl won't pick up our readyness notification. -use TUWF ':html'; -use SkinFile; - - -our(%O, %S); - - -# load the skins -# NOTE: $S{skins} can be modified in data/config.pl, allowing deletion of skins or forcing only one skin -my $skin = SkinFile->new("$ROOT/static/s"); -$S{skins} = { map +($_ => [ $skin->get($_, 'name'), $skin->get($_, 'userid') ]), $skin->list }; - - -# load settings from global.pl -require $ROOT.'/data/global.pl'; - - -# automatically regenerate the skins and script.js and whatever else should be done -system "make -sC $ROOT" if $S{regen_static}; - - -$TUWF::OBJ->{$_} = $S{$_} for (keys %S); -TUWF::set( - %O, - pre_request_handler => \&reqinit, - error_404_handler => \&handle404, - log_format => \&logformat, -); -TUWF::load_recursive('VNDB::Util', 'VNDB::DB', 'VNDB::Handler'); -TUWF::run(); +my $conf = require $ROOT.'/data/config3.pl'; -sub reqinit { - my $self = shift; +# Make the configuration available as tuwf->conf +sub TUWF::Object::conf { $conf } - # If we're running standalone, serve www/ and static/ too. - if($TUWF::OBJ->{_TUWF}{http}) { - if($self->resFile("$ROOT/www", $self->reqPath) || $self->resFile("$ROOT/static", $self->reqPath)) { - $self->resHeader('Cache-Control' => 'max-age=31536000'); - return 0; - } - } - # check authentication cookies - $self->authInit; +# Make our root path available as tuwf->root +# Optionally accepts other path components to assemble a file path: +# tuwf->root('static/sf/01/1.jpg') +sub TUWF::Object::root { shift; join '/', $ROOT, @_ } - # load some stats (used for about all pageviews, anyway) - $self->{stats} = $self->dbStats; - return 1; -} +TUWF::set %{ $conf->{tuwf} || {} }; -sub handle404 { - my $self = shift; - $self->resStatus(404); - $self->htmlHeader(title => 'Page Not Found'); - div class => 'mainbox'; - h1 'Page not found'; - div class => 'warning'; - h2 'Oops!'; - p; - txt 'It seems the page you were looking for does not exist,'; - br; - txt 'you may want to try using the menu on your left to find what you are looking for.'; - end; - end; - end; - $self->htmlFooter; -} +# If we're running standalone, serve www/ and static/ too. +TUWF::hook before => sub { + my $static = tuwf->{_TUWF}{http} && + ( tuwf->resFile(tuwf->root('www'), tuwf->reqPath) + || tuwf->resFile(tuwf->root('static'), tuwf->reqPath) + ); + tuwf->resHeader('Cache-Control' => 'max-age=31536000') if $static; + !$static; +}; -# log user IDs (necessary for determining performance issues, user preferences -# have a lot of influence in this) -sub logformat { - my($self, $uri, $msg) = @_; - sprintf "[%s] %s %s: %s\n", scalar localtime(), $uri, - $self->authInfo->{id} ? 'u'.$self->authInfo->{id} : '-', $msg; -} +TUWF::load_recursive 'VNDB'; +TUWF::run; |