diff options
author | Yorhel <git@yorhel.nl> | 2015-04-27 12:26:11 +0200 |
---|---|---|
committer | Yorhel <git@yorhel.nl> | 2015-04-27 12:26:11 +0200 |
commit | 2646abcec9ee274dd35acde7eb8de01577ce931b (patch) | |
tree | 2f0c0aa596f0b339686db4fe9dc5aa7ec115fda8 /lib | |
parent | 141fbfdb168168b478fc0f5265cc9ee572519434 (diff) |
Multi::API: Fully implement 'get' command with AnyEvent
Diffstat (limited to 'lib')
-rw-r--r-- | lib/Multi/API.pm | 825 | ||||
-rw-r--r-- | lib/Multi/Core.pm | 2 |
2 files changed, 317 insertions, 510 deletions
diff --git a/lib/Multi/API.pm b/lib/Multi/API.pm index 0e12389b..4481dc18 100644 --- a/lib/Multi/API.pm +++ b/lib/Multi/API.pm @@ -117,6 +117,7 @@ sub cres { sub cerr { my($c, $id, $msg, %o) = @_; cres $c, [ error => { id => $id, msg => $msg, %o } ], "Error: %s, %s", $id, $msg; + return undef; } @@ -332,7 +333,9 @@ sub splitarray { } -# sql => str: Main sql query, three placeholders: select, where part, order by and limit clauses +# sql => str: Main sql query, three printf args: select, where part, order by and limit clauses +# sqluser => str: Alternative to 'sql' if the user is logged in. One additional printf arg: user id. +# If sql is undef and sqluser isn't, the command is only available to logged in users. # select => str: string to add to the select part of the main query # proc => &sub->($row): called on each row of the main query # sorts => { sort_key => sql_string }, %s is replaced with 'ASC/DESC' in sql_string @@ -342,9 +345,11 @@ sub splitarray { # flag_name => { # select => str: string to add to the select part of the main query # proc => &sub->($row): same as parent proc -# fetchidx => str: name of the field from the main query to get the id list from -# fetchsql => str: SQL query to fetch more data. %s is replaced with the list of ID's based on fetchidx -# fatchproc => &sub->($rows, $fetchrows) +# fetch => [ [ +# idx: str: name of the field from the main query to get the id list from, +# sql: str: SQL query to fetch more data. %s is replaced with the list of ID's based on fetchidx +# proc: &sub->($rows, $fetchrows) +# ], .. ], # } # } # filters => filters args for get_filters() (TODO: Document) @@ -398,48 +403,50 @@ my %GET_VN = ( }, anime => { fetch => [[ 'latest', 'SELECT va.vid, a.id, a.year, a.ann_id, a.nfo_id, a.type, a.title_romaji, a.title_kanji - FROM anime a JOIN vn_anime va ON va.aid = a.id WHERE va.vid IN(%s)', sub { my($r, $n) = @_; - # link - for my $i (@$r) { - $i->{anime} = [ grep $i->{latest} == $_->{vid}, @$n ]; + FROM anime a JOIN vn_anime va ON va.aid = a.id WHERE va.vid IN(%s)', + sub { my($r, $n) = @_; + # link + for my $i (@$r) { + $i->{anime} = [ grep $i->{latest} == $_->{vid}, @$n ]; + } + # cleanup + for (@$n) { + $_->{id} *= 1; + $_->{year} *= 1 if defined $_->{year}; + $_->{ann_id} *= 1 if defined $_->{ann_id}; + delete $_->{vid}; + } } - # cleanup - for (@$n) { - $_->{id} *= 1; - $_->{year} *= 1 if defined $_->{year}; - $_->{ann_id} *= 1 if defined $_->{ann_id}; - delete $_->{vid}; - } - }]], + ]], }, relations => { - fetchidx => 'latest', - fetchsql => 'SELECT vl.vid1, v.id, vl.relation, vr.title, vr.original FROM vn_relations vl + fetch => [[ 'latest', 'SELECT vl.vid1, v.id, vl.relation, vr.title, vr.original FROM vn_relations vl JOIN vn v ON v.id = vl.vid2 JOIN vn_rev vr ON vr.id = v.latest WHERE vl.vid1 IN(%s) AND NOT v.hidden', - fetchproc => sub { my($r, $n) = @_; - for my $i (@$r) { - $i->{relations} = [ grep $i->{latest} == $_->{vid1}, @$n ]; - } - for (@$n) { - $_->{id} *= 1; - $_->{original} ||= undef; - delete $_->{vid1}; + sub { my($r, $n) = @_; + for my $i (@$r) { + $i->{relations} = [ grep $i->{latest} == $_->{vid1}, @$n ]; + } + for (@$n) { + $_->{id} *= 1; + $_->{original} ||= undef; + delete $_->{vid1}; + } } - }, + ]], }, tags => { - fetchidx => 'id', - fetchsql => 'SELECT vid, tag AS id, avg(CASE WHEN ignore THEN NULL ELSE vote END) as score, + fetch => [[ 'id', 'SELECT vid, tag AS id, avg(CASE WHEN ignore THEN NULL ELSE vote END) as score, COALESCE(avg(CASE WHEN ignore THEN NULL ELSE spoiler END), 0) as spoiler FROM tags_vn tv WHERE vid IN(%s) GROUP BY vid, id HAVING avg(CASE WHEN ignore THEN NULL ELSE vote END) > 0', - fetchproc => sub { my($r, $n) = @_; - for my $i (@$r) { - $i->{tags} = [ map - [ $_->{id}*1, 1*sprintf('%.2f', $_->{score}), 1*sprintf('%.0f', $_->{spoiler}) ], - grep $i->{id} == $_->{vid}, @$n ]; - } - }, + sub { my($r, $n) = @_; + for my $i (@$r) { + $i->{tags} = [ map + [ $_->{id}*1, 1*sprintf('%.2f', $_->{score}), 1*sprintf('%.0f', $_->{spoiler}) ], + grep $i->{id} == $_->{vid}, @$n ]; + } + }, + ]], }, }, filters => { @@ -508,13 +515,13 @@ my %GET_RELEASE = ( $_[0]{freeware} = $_[0]{freeware} =~ /^t/ ? TRUE : FALSE; $_[0]{doujin} = $_[0]{doujin} =~ /^t/ ? TRUE : FALSE; }, - fetchidx => 'latest', - fetchsql => 'SELECT rid, lang FROM releases_lang WHERE rid IN(%s)', - fetchproc => sub { my($n, $r) = @_; - for my $i (@$n) { - $i->{languages} = [ map $i->{latest} == $_->{rid} ? $_->{lang} : (), @$r ]; - } - }, + fetch => [[ 'latest', 'SELECT rid, lang FROM releases_lang WHERE rid IN(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{languages} = [ map $i->{latest} == $_->{rid} ? $_->{lang} : (), @$r ]; + } + }, + ]], }, details => { select => 'rr.website, rr.notes, rr.minage, rr.gtin, rr.catalog', @@ -525,25 +532,57 @@ my %GET_RELEASE = ( $_[0]{gtin} ||= undef; $_[0]{catalog} ||= undef; }, + fetch => [ + [ 'latest', 'SELECT rid, platform FROM releases_platforms WHERE rid IN(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{platforms} = [ map $i->{latest} == $_->{rid} ? $_->{platform} : (), @$r ]; + } + } ], + [ 'latest', 'SELECT rid, medium, qty FROM releases_media WHERE rid IN(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{media} = [ grep $i->{latest} == $_->{rid}, @$r ]; + } + for (@$r) { + delete $_->{rid}; + $_->{qty} = $VNDB::S{media}{$_->{medium}} ? $_->{qty}*1 : undef; + } + } ], + ] }, - - @ids && !$get->{platforms} && grep(/details/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => - qq|SELECT rid, platform FROM releases_platforms WHERE rid IN($ids)|, - \@ids, 'get_release_res', { %$get, type => 'platforms' }); - - @ids && !$get->{media} && grep(/details/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => - qq|SELECT rid, medium, qty FROM releases_media WHERE rid IN($ids)|, - \@ids, 'get_release_res', { %$get, type => 'media' }); - - @ids && !$get->{vn} && grep(/vn/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq| - SELECT rv.rid, v.id, vr.title, vr.original FROM releases_vn rv JOIN vn v ON v.id = rv.vid - JOIN vn_rev vr ON vr.id = v.latest WHERE NOT v.hidden AND rv.rid IN($ids)|, - \@ids, 'get_release_res', { %$get, type => 'vn' }); - - @ids && !$get->{producers} && grep(/producers/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq| - SELECT rp.rid, rp.developer, rp.publisher, p.id, pr.type, pr.name, pr.original FROM releases_producers rp - JOIN producers p ON p.id = rp.pid JOIN producers_rev pr ON pr.id = p.latest WHERE NOT p.hidden AND rp.rid IN($ids)|, - \@ids, 'get_release_res', { %$get, type => 'producers' }); + vn => { + fetch => [[ 'latest', 'SELECT rv.rid, v.id, vr.title, vr.original FROM releases_vn rv JOIN vn v ON v.id = rv.vid + JOIN vn_rev vr ON vr.id = v.latest WHERE NOT v.hidden AND rv.rid IN(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{vn} = [ grep $i->{latest} == $_->{rid}, @$r ]; + } + for (@$r) { + $_->{id}*=1; + $_->{original} ||= undef; + delete $_->{rid}; + } + } + ]], + }, + producers => { + fetch => [[ 'latest', 'SELECT rp.rid, rp.developer, rp.publisher, p.id, pr.type, pr.name, pr.original FROM releases_producers rp + JOIN producers p ON p.id = rp.pid JOIN producers_rev pr ON pr.id = p.latest WHERE NOT p.hidden AND rp.rid IN(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{producers} = [ grep $i->{latest} == $_->{rid}, @$r ]; + } + for (@$r) { + $_->{id}*=1; + $_->{original} ||= undef; + $_->{developer} = $_->{developer} ? TRUE : FALSE; + $_->{publisher} = $_->{publisher} ? TRUE : FALSE; + delete $_->{rid}; + } + } + ]], + } }, filters => { id => [ @@ -569,7 +608,7 @@ my %GET_RELEASE = ( [ undef, 'rr.released :op: 0', {qw|= = != <>|} ], [ str => 'rr.released :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, process => \&parsedate ], ], - patch => [ [ bool => 'rr.patch = :value:', {'=',1} ] ] + patch => [ [ bool => 'rr.patch = :value:', {'=',1} ] ], freeware => [ [ bool => 'rr.freeware = :value:', {'=',1} ] ], doujin => [ [ bool => 'rr.doujin = :value:', {'=',1} ] ], type => [ @@ -586,92 +625,213 @@ my %GET_RELEASE = ( [ str => 'rr.id :op:(SELECT rl.rid FROM releases_lang rl WHERE rl.lang = :value:)', {'=' => 'IN', '!=' => 'NOT IN'}, process => \'lang' ], [ stra => 'rr.id :op:(SELECT rl.rid FROM releases_lang rl WHERE rl.lang IN(:value:))', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], ], - ]; + }, ); -sub get_release_res { - elsif($get->{type} eq 'languages') { - for my $i (@{$get->{list}}) { - $i->{languages} = [ map $i->{latest} == $_->{rid} ? $_->{lang} : (), @$res ]; - } - $get->{languages} = 1; - } - elsif($get->{type} eq 'platforms') { - for my $i (@{$get->{list}}) { - $i->{platforms} = [ map $i->{latest} == $_->{rid} ? $_->{platform} : (), @$res ]; - } - $get->{platforms} = 1; - } - elsif($get->{type} eq 'media') { - for my $i (@{$get->{list}}) { - $i->{media} = [ grep $i->{latest} == $_->{rid}, @$res ]; - } - for (@$res) { - delete $_->{rid}; - $_->{qty} = $VNDB::S{media}{$_->{medium}} ? $_->{qty}*1 : undef; - } - $get->{media} = 1; - } - elsif($get->{type} eq 'vn') { - for my $i (@{$get->{list}}) { - $i->{vn} = [ grep $i->{latest} == $_->{rid}, @$res ]; - } - for (@$res) { - $_->{id}*=1; - $_->{original} ||= undef; - delete $_->{rid}; - } - $get->{vn} = 1; - } - elsif($get->{type} eq 'producers') { - for my $i (@{$get->{list}}) { - $i->{producers} = [ grep $i->{latest} == $_->{rid}, @$res ]; - } - for (@$res) { - $_->{id}*=1; - $_->{original} ||= undef; - $_->{developer} = $_->{developer} ? TRUE : FALSE; - $_->{publisher} = $_->{publisher} ? TRUE : FALSE; - delete $_->{rid}; - } - $get->{producers} = 1; - } - - # get more info - my @ids = map $_->{latest}, @{$get->{list}}; - my $ids = join ',', map '?', @ids; +my %GET_PRODUCER = ( + sql => 'SELECT %s FROM producers p JOIN producers_rev pr ON p.latest = pr.id WHERE NOT p.hidden AND (%s) %s', + select => 'p.id, p.latest', + proc => sub { + delete $_[0]{latest}; + $_[0]{id} *= 1 + }, + sortdef => 'id', + sorts => { + id => 'p.id %s', + name => 'pr.name %s', + }, + flags => { + basic => { + select => 'pr.type, pr.name, pr.original, pr.lang AS language', + proc => sub { + $_[0]{original} ||= undef; + }, + }, + details => { + select => 'pr.website, pr.l_wp, pr.desc AS description, pr.alias AS aliases', + proc => sub { + $_[0]{description} ||= undef; + $_[0]{aliases} ||= undef; + $_[0]{links} = { + homepage => delete($_[0]{website})||undef, + wikipedia => delete $_[0]{l_wp}, + }; + }, + }, + relations => { + fetch => [[ 'latest', 'SELECT pl.pid1, p.id, pl.relation, pr.name, pr.original FROM producers_relations pl + JOIN producers p ON p.id = pl.pid2 JOIN producers_rev pr ON pr.id = p.latest WHERE pl.pid1 IN(%s) AND NOT p.hidden', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{relations} = [ grep $i->{latest} == $_->{pid1}, @$r ]; + } + for (@$r) { + $_->{id}*=1; + $_->{original} ||= undef; + delete $_->{pid1}; + } + }, + ]], + }, + }, + filters => { + id => [ + [ 'int' => 'p.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], + [ inta => 'p.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, join => ',', range => [1,1e6] ], + ], + name => [ + [ str => 'pr.name :op: :value:', {qw|= = != <>|} ], + [ str => 'pr.name ILIKE :value:', {'~',1}, process => \'like' ], + ], + original => [ + [ undef, "pr.original :op: ''", {qw|= = != <>|} ], + [ str => 'pr.original :op: :value:', {qw|= = != <>|} ], + [ str => 'pr.original ILIKE :value:', {'~',1}, process => \'like' ] + ], + type => [ + [ str => 'pr.type :op: :value:', {qw|= = != <>|}, + process => sub { !grep($_ eq $_[0], @{$VNDB::S{producer_types}}) ? \'No such producer type' : $_[0] } ], + ], + language => [ + [ str => 'pr.lang :op: :value:', {qw|= = != <>|}, process => \'lang' ], + [ stra => 'pr.lang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], + ], + search => [ + [ str => '(pr.name ILIKE :value: OR pr.original ILIKE :value: OR pr.alias ILIKE :value:)', {'~',1}, process => \'like' ], + ], + }, +); - @ids && !$get->{languages} && grep(/basic/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => - qq|SELECT rid, lang FROM releases_lang WHERE rid IN($ids)|, - \@ids, 'get_release_res', { %$get, type => 'languages' }); +my %GET_CHARACTER = ( + sql => 'SELECT %s FROM chars c JOIN chars_rev cr ON c.latest = cr.id WHERE NOT c.hidden AND (%s) %s', + select => 'c.id, c.latest', + proc => sub { + delete $_[0]{latest}; + $_[0]{id} *= 1 + }, + sortdef => 'id', + sorts => { + id => 'c.id %s', + name => 'cr.name %s', + }, + flags => { + basic => { + select => 'cr.name, cr.original, cr.gender, cr.bloodt, cr.b_day, cr.b_month', + proc => sub { + $_[0]{original} ||= undef; + $_[0]{gender} = undef if $_[0]{gender} eq 'unknown'; + $_[0]{bloodt} = undef if $_[0]{bloodt} eq 'unknown'; + $_[0]{birthday} = [ delete($_[0]{b_day})||undef, delete($_[0]{b_month})||undef ]; + }, + }, + details => { + select => 'cr.alias AS aliases, cr.image, cr."desc" AS description', + proc => sub { + $_[0]{aliases} ||= undef; + $_[0]{image} = $_[0]{image} ? sprintf '%s/ch/%02d/%d.jpg', $VNDB::S{url_static}, $_[0]{image}%100, $_[0]{image} : undef; + $_[0]{description} ||= undef; + }, + }, + meas => { + select => 'cr.s_bust AS bust, cr.s_waist AS waist, cr.s_hip AS hip, cr.height, cr.weight', + proc => sub { + $_[0]{$_} = $_[0]{$_} ? $_[0]{$_}*1 : undef for(qw|bust waist hip height weight|); + }, + }, + traits => { + fetch => [[ 'latest', 'SELECT cid, tid, spoil FROM chars_traits WHERE cid IN(%s)', + sub { my($n, $r) = @_; + for my $i (@$n) { + $i->{traits} = [ map [ $_->{tid}*1, $_->{spoil}*1 ], grep $i->{latest} == $_->{cid}, @$r ]; + } + }, + ]], + }, + }, + filters => { + id => [ + [ 'int' => 'c.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], + [ inta => 'c.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, range => [1,1e6], join => ',' ], + ], + name => [ + [ str => 'cr.name :op: :value:', {qw|= = != <>|} ], + [ str => 'cr.name ILIKE :value:', {'~',1}, process => \'like' ], + ], + original => [ + [ undef, "cr.original :op: ''", {qw|= = != <>|} ], + [ str => 'cr.original :op: :value:', {qw|= = != <>|} ], + [ str => 'cr.original ILIKE :value:', {'~',1}, process => \'like' ] + ], + search => [ + [ str => '(cr.name ILIKE :value: OR cr.original ILIKE :value: OR cr.alias ILIKE :value:)', {'~',1}, process => \'like' ], + ], + vn => [ + [ 'int' => 'cr.id IN(SELECT cv.cid FROM chars_vns cv WHERE cv.vid = :value:)', {'=',1}, range => [1,1e6] ], + ], + }, +); - @ids && !$get->{platforms} && grep(/details/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => - qq|SELECT rid, platform FROM releases_platforms WHERE rid IN($ids)|, - \@ids, 'get_release_res', { %$get, type => 'platforms' }); - @ids && !$get->{media} && grep(/details/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => - qq|SELECT rid, medium, qty FROM releases_media WHERE rid IN($ids)|, - \@ids, 'get_release_res', { %$get, type => 'media' }); +# the uid filter for votelist/vnlist/wishlist. Needs special care to handle the 'uid=0' case. +my $UID_FILTER = + [ 'int' => 'uid :op: :value:', {qw|= =|}, range => [0,1e6], process => + sub { my($uid, $c) = @_; !$uid && !$c->{uid} ? \'Not logged in.' : $uid || $c->{uid} } ]; - @ids && !$get->{vn} && grep(/vn/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq| - SELECT rv.rid, v.id, vr.title, vr.original FROM releases_vn rv JOIN vn v ON v.id = rv.vid - JOIN vn_rev vr ON vr.id = v.latest WHERE NOT v.hidden AND rv.rid IN($ids)|, - \@ids, 'get_release_res', { %$get, type => 'vn' }); +my %GET_VOTELIST = ( + sql => "SELECT %s FROM votes v WHERE (%s) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list') %s", + sqluser => q{SELECT %1$s FROM votes v WHERE (%2$s) AND (uid = %4$d OR NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list')) %3$s}, + select => "vid as vn, vote, extract('epoch' from date) AS added", + proc => sub { + $_[0]{vn}*=1; + $_[0]{vote}*=1; + $_[0]{added} = int $_[0]{added}; + }, + sortdef => 'vn', + sorts => { vn => 'vid %s' }, + flags => { basic => {} }, + filters => { uid => [ $UID_FILTER ] } +); - @ids && !$get->{producers} && grep(/producers/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq| - SELECT rp.rid, rp.developer, rp.publisher, p.id, pr.type, pr.name, pr.original FROM releases_producers rp - JOIN producers p ON p.id = rp.pid JOIN producers_rev pr ON pr.id = p.latest WHERE NOT p.hidden AND rp.rid IN($ids)|, - \@ids, 'get_release_res', { %$get, type => 'producers' }); +my %GET_VNLIST = ( + sql => "SELECT %s FROM vnlists v WHERE (%s) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list') %s", + sqluser => q{SELECT %1$s FROM vnlists v WHERE (%2$s) AND (uid = %4$d OR NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list')) %3$s}, + select => "vid as vn, status, extract('epoch' from added) AS added, notes", + proc => sub { + $_[0]{vn}*=1; + $_[0]{status}*=1; + $_[0]{added} = int $_[0]{added}; + $_[0]{notes} ||= undef; + }, + sortdef => 'vn', + sorts => { vn => 'vid %s' }, + flags => { basic => {} }, + filters => { uid => [ $UID_FILTER ] } +); - # send results - delete $_->{latest} for @{$get->{list}}; - $_[KERNEL]->yield(get_results => { %$get, type => 'release' }); -} +my %GET_WISHLIST = ( + sql => "SELECT %s FROM wlists w WHERE (%s) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = w.uid AND key = 'hide_list') %s", + sqluser => q{SELECT %1$s FROM wlists w WHERE (%2$s) AND (uid = %4$d OR NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = w.uid AND key = 'hide_list')) %3$s}, + select => "vid AS vn, wstat AS priority, extract('epoch' from added) AS added", + proc => sub { + $_[0]{vn}*=1; + $_[0]{priority}*=1; + $_[0]{added} = int $_[0]{added}; + }, + sortdef => 'vn', + sorts => { vn => 'vid %s' }, + flags => { basic => {} }, + filters => { uid => [ $UID_FILTER ] } +); my %GET = ( - vn => \%GET_VN, - release => \%GET_RELEASE, + vn => \%GET_VN, + release => \%GET_RELEASE, + producer => \%GET_PRODUCER, + character => \%GET_CHARACTER, + votelist => \%GET_VOTELIST, + vnlist => \%GET_VNLIST, + wishlist => \%GET_WISHLIST, ); @@ -760,7 +920,7 @@ sub get_filters { if(!ref $o{process}) { $v = sprintf $o{process}, $v; } elsif(ref($o{process}) eq 'CODE') { - $v = $o{process}->($v); + $v = $o{process}->($v, $c); return cerr $c, filter => $$v, %e if ref($v) eq 'SCALAR'; } elsif(${$o{process}} eq 'like') { y/%//; @@ -815,14 +975,19 @@ sub get_mainsql { map $type->{flags}{$_}{select} ? $type->{flags}{$_}{select} : (), @{$get->{info}}; my @placeholders; - my $where = encode_filters $get->{filters}, \&get_filters, $get->{c}, \@placeholders, $type->{filters}; + my $where = encode_filters $get->{filters}, \&get_filters, $c, \@placeholders, $type->{filters}; + return if !$where; my $col = $type->{sorts}{ $get->{opt}{sort} }; my $last = sprintf 'ORDER BY %s LIMIT %d OFFSET %d', sprintf($col, $get->{opt}{reverse} ? 'DESC' : 'ASC'), $get->{opt}{results}+1, $get->{opt}{results}*($get->{opt}{page}-1); - cpg $c, sprintf($type->{sql}, $select, $where, $last), \@placeholders, sub { + my $sql = $type->{sql}; + return cerr $c, needlogin => 'Not logged in as a user' if !$sql && !$c->{uid}; + $sql = $type->{sqluser} if $c->{uid}; + + cpg $c, sprintf($sql, $select, $where, $last, $c->{uid}), \@placeholders, sub { my @res = $_[0]->rowsAsHashes; $get->{more} = pop(@res)&&1 if @res > $get->{opt}{results}; $get->{list} = \@res; @@ -835,14 +1000,17 @@ sub get_mainsql { sub get_fetch { my($c, $type, $get) = @_; - my %need = ( map $type->{flags}{$_}{fetchsql} ? ($_, $type->{flags}{$_}) : (), @{$get->{info}} ); - return get_final($c, $type, $get) if !keys %need || !@{$get->{list}}; + my @need = map { my $f = $type->{flags}{$_}{fetch}; $f ? @$f : () } @{$get->{info}}; + return get_final($c, $type, $get) if !@need || !@{$get->{list}}; + + # Turn into a hash for easy self-deletion + my %need = map +($_, $need[$_]), 0..$#need; for my $n (keys %need) { - my @ids = map $_->{ $need{$n}{fetchidx} }, @{$get->{list}}; + my @ids = map $_->{ $need{$n}[0] }, @{$get->{list}}; my $ids = join ',', map '$'.$_, 1..@ids; - cpg $c, sprintf($need{$n}{fetchsql}, $ids), \@ids, sub { - $get->{fetched}{$n} = [$_[0]->rowsAsHashes]; + cpg $c, sprintf($need{$n}[1], $ids), \@ids, sub { + $get->{fetched}{$n} = [ $need{$n}[2], [$_[0]->rowsAsHashes] ]; delete $need{$n}; get_final($c, $type, $get) if !keys %need; }; @@ -854,8 +1022,8 @@ sub get_final { my($c, $type, $get) = @_; # Run process callbacks (fetchprocs first, so that they have access to fields that may get deleted in later procs) - for my $n (grep $type->{flags}{$_}{fetchproc}, @{$get->{info}}) { - $type->{flags}{$n}{fetchproc}->($get->{list}, $get->{fetched}{$n}); + for my $n (values %{$get->{fetched}}) { + $n->[0]->($get->{list}, $n->[1]); } for my $p ( @@ -876,330 +1044,6 @@ sub get_final { __END__ -sub get_producer { - my $get = $_[ARG0]; - - return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ - for (grep !/^(basic|details|relations)$/, @{$get->{info}}); - - my $select = 'p.id, p.latest'; - $select .= ', pr.type, pr.name, pr.original, pr.lang AS language' if grep /basic/, @{$get->{info}}; - $select .= ', pr.website, pr.l_wp, pr.desc AS description, pr.alias AS aliases' if grep /details/, @{$get->{info}}; - - my @placeholders; - my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [ - [ 'id', - [ 'int' => 'p.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], - [ inta => 'p.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, join => ',', range => [1,1e6] ], - ], [ 'name', - [ str => 'pr.name :op: :value:', {qw|= = != <>|} ], - [ str => 'pr.name ILIKE :value:', {'~',1}, process => \'like' ], - ], [ 'original', - [ undef, "pr.original :op: ''", {qw|= = != <>|} ], - [ str => 'pr.original :op: :value:', {qw|= = != <>|} ], - [ str => 'pr.original ILIKE :value:', {'~',1}, process => \'like' ] - ], [ 'type', - [ str => 'pr.type :op: :value:', {qw|= = != <>|}, - process => sub { !grep($_ eq $_[0], @{$VNDB::S{producer_types}}) ? \'No such producer type' : $_[0] } ], - ], [ 'language', - [ str => 'pr.lang :op: :value:', {qw|= = != <>|}, process => \'lang' ], - [ stra => 'pr.lang :op:(:value:)', {'=' => 'IN', '!=' => 'NOT IN'}, join => ',', process => \'lang' ], - ], [ 'search', - [ str => '(pr.name ILIKE :value: OR pr.original ILIKE :value: OR pr.alias ILIKE :value:)', {'~',1}, process => \'like' ], - ], - ]; - my $last = sqllast $get, 'id', { - id => 'p.id %s', - name => 'pr.name %s', - }; - return if !$where || !$last; - - $_[KERNEL]->post(pg => query => - qq|SELECT $select FROM producers p JOIN producers_rev pr ON pr.id = p.latest WHERE $where AND NOT hidden $last|, - \@placeholders, 'get_producer_res', $get); -} - - -sub get_producer_res { - my($num, $res, $get, $time) = (@_[ARG0..$#_]); - - $get->{time} += $time; - $get->{queries}++; - - # process the results - if(!$get->{type}) { - for (@$res) { - $_->{id}*=1; - $_->{original} ||= undef if grep /basic/, @{$get->{info}}; - if(grep /details/, @{$get->{info}}) { - $_->{links} = { - homepage => delete($_->{website})||undef, - wikipedia => delete $_->{l_wp}, - }; - $_->{description} ||= undef; - $_->{aliases} ||= undef; - } - } - $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results}; - $get->{list} = $res; - } - elsif($get->{type} eq 'relations') { - for my $i (@{$get->{list}}) { - $i->{relations} = [ grep $i->{latest} == $_->{pid1}, @$res ]; - } - for (@$res) { - $_->{id}*=1; - $_->{original} ||= undef; - delete $_->{pid1}; - } - $get->{relations} = 1; - } - - # get more info - my @ids = map $_->{latest}, @{$get->{list}}; - my $ids = join ',', map '?', @ids; - - @ids && !$get->{relations} && grep(/relations/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq| - SELECT pl.pid1, p.id, pl.relation, pr.name, pr.original FROM producers_relations pl - JOIN producers p ON p.id = pl.pid2 JOIN producers_rev pr ON pr.id = p.latest WHERE pl.pid1 IN($ids) AND NOT p.hidden|, - \@ids, 'get_producer_res', { %$get, type => 'relations' }); - - # send results - delete $_->{latest} for @{$get->{list}}; - $_[KERNEL]->yield(get_results => { %$get, type => 'producer' }); -} - - -sub get_character { - my $get = $_[ARG0]; - - return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ - for (grep !/^(basic|details|meas|traits)$/, @{$get->{info}}); - - my $select = 'c.id, c.latest'; - $select .= ', cr.name, cr.original, cr.gender, cr.bloodt, cr.b_day, cr.b_month' if grep /basic/, @{$get->{info}}; - $select .= ', cr.alias AS aliases, cr.image, cr."desc" AS description' if grep /details/, @{$get->{info}}; - $select .= ', cr.s_bust AS bust, cr.s_waist AS waist, cr.s_hip AS hip, cr.height, cr.weight' if grep /meas/, @{$get->{info}}; - # TODO: VNs + Instances - - my @placeholders; - my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [ - [ 'id', - [ 'int' => 'c.id :op: :value:', {qw|= = != <> > > < < <= <= >= >=|}, range => [1,1e6] ], - [ inta => 'c.id :op:(:value:)', {'=' => 'IN', '!= ' => 'NOT IN'}, range => [1,1e6], join => ',' ], - ], [ 'name', - [ str => 'cr.name :op: :value:', {qw|= = != <>|} ], - [ str => 'cr.name ILIKE :value:', {'~',1}, process => \'like' ], - ], [ 'original', - [ undef, "cr.original :op: ''", {qw|= = != <>|} ], - [ str => 'cr.original :op: :value:', {qw|= = != <>|} ], - [ str => 'cr.original ILIKE :value:', {'~',1}, process => \'like' ] - ], [ 'search', - [ str => '(cr.name ILIKE :value: OR cr.original ILIKE :value: OR cr.alias ILIKE :value:)', {'~',1}, process => \'like' ], - ], [ 'vn', - [ 'int' => 'cr.id IN(SELECT cv.cid FROM chars_vns cv WHERE cv.vid = :value:)', {'=',1}, range => [1,1e6] ], - ] - # TODO: More filters? - ]; - my $last = sqllast $get, 'id', { - id => 'c.id %s', - name => 'cr.name %s', - }; - return if !$last || !$where; - - $_[KERNEL]->post(pg => query => - qq|SELECT $select FROM chars c JOIN chars_rev cr ON c.latest = cr.id WHERE NOT c.hidden AND $where $last|, - \@placeholders, 'get_character_res', $get); -} - - -sub get_character_res { - my($num, $res, $get, $time) = (@_[ARG0..$#_]); - - $get->{time} += $time; - $get->{queries}++; - - # process the results - if(!$get->{type}) { - for (@$res) { - $_->{id}*=1; - if(grep /basic/, @{$get->{info}}) { - $_->{original} ||= undef; - $_->{gender} = undef if $_->{gender} eq 'unknown'; - $_->{bloodt} = undef if $_->{bloodt} eq 'unknown'; - $_->{birthday} = [ delete($_->{b_day})||undef, delete($_->{b_month})||undef ]; - } - if(grep /details/, @{$get->{info}}) { - $_->{aliases} ||= undef; - $_->{image} = $_->{image} ? sprintf '%s/ch/%02d/%d.jpg', $VNDB::S{url_static}, $_->{image}%100, $_->{image} : undef; - $_->{description} ||= undef; - } - if(grep /meas/, @{$get->{info}}) { - my $e = $_; - $e->{$_} = $e->{$_} ? $e->{$_}*1 : undef for(qw|bust waist hip height weight|); - } - } - $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results}; - $get->{list} = $res; - } - - elsif($get->{type} eq 'traits') { - for my $i (@{$get->{list}}) { - $i->{traits} = [ map [ $_->{tid}*1, $_->{spoil}*1 ], grep $i->{latest} == $_->{cid}, @$res ]; - } - $get->{traits} = 1; - } - - # fetch more results - my @ids = map $_->{latest}, @{$get->{list}}; - my $ids = join ',', map '?', @ids; - - @ids && !$get->{traits} && grep(/traits/, @{$get->{info}}) && return $_[KERNEL]->post(pg => query => qq| - SELECT cid, tid, spoil FROM chars_traits WHERE cid IN($ids)|, - \@ids, 'get_character_res', { %$get, type => 'traits' }); - - # send results - delete $_->{latest} for @{$get->{list}}; - $_[KERNEL]->yield(get_results => { %$get, type => 'character' }); -} - - -sub get_votelist { - my $get = $_[ARG0]; - - return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ - for (grep !/^(basic)$/, @{$get->{info}}); - - my $select = "vid AS vn, vote, extract('epoch' from date) AS added"; - - my @placeholders; - my $uid; - my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [ - [ 'uid', - [ 'int' => 'uid :op: :value:', {qw|= =|}, range => [0,1e6], process => sub { $uid = $_[0]; $_[0] || $get->{c}{uid} || 0 } ], - ] - ]; - - my $last = sqllast $get, 'vn', { vn => 'vid %s' }; - return if !$where || !$last; - - return cerr $get->{c}, needlogin => 'Not logged in as a user' if !$uid && !$get->{c}{uid}; - $where = "($where) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list')" if $uid; - - $_[KERNEL]->post(pg => query => - qq|SELECT $select FROM votes v WHERE $where $last|, - \@placeholders, 'get_votelist_res', $get); -} - - -sub get_votelist_res { - my($num, $res, $get, $time) = (@_[ARG0..$#_]); - - $get->{time} += $time; - $get->{queries}++; - - for (@$res) { - $_->{vn}*=1; - $_->{vote}*=1; - $_->{added} = int $_->{added}; - } - $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results}; - $get->{list} = $res; - - $_[KERNEL]->yield(get_results => { %$get, type => 'votelist' }); -} - - -sub get_vnlist { - my $get = $_[ARG0]; - - return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ - for (grep !/^(basic)$/, @{$get->{info}}); - - my $select = "vid AS vn, status, extract('epoch' from added) AS added, notes"; - - my @placeholders; - my $uid; - my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [ - [ 'uid', - [ 'int' => 'uid :op: :value:', {qw|= =|}, range => [0,1e6], process => sub { $uid = $_[0]; $_[0] || $get->{c}{uid} || 0 } ], - ] - ]; - my $last = sqllast $get, 'vn', { vn => 'vid %s' }; - return if !$where || !$last; - - return cerr $get->{c}, needlogin => 'Not logged in as a user' if !$uid && !$get->{c}{uid}; - $where = "($where) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = v.uid AND key = 'hide_list')" if $uid; - - $_[KERNEL]->post(pg => query => - qq|SELECT $select FROM vnlists v WHERE $where $last|, - \@placeholders, 'get_vnlist_res', $get); -} - - -sub get_vnlist_res { - my($num, $res, $get, $time) = (@_[ARG0..$#_]); - - $get->{time} += $time; - $get->{queries}++; - - for (@$res) { - $_->{vn}*=1; - $_->{status}*=1; - $_->{added} = int $_->{added}; - $_->{notes} ||= undef; - } - $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results}; - $get->{list} = $res; - - $_[KERNEL]->yield(get_results => { %$get, type => 'vnlist' }); -} - - -sub get_wishlist { - my $get = $_[ARG0]; - - return cerr $get->{c}, getinfo => "Unknown info flag '$_'", flag => $_ - for (grep !/^(basic)$/, @{$get->{info}}); - - my $select = "vid AS vn, wstat AS priority, extract('epoch' from added) AS added"; - - my @placeholders; - my $uid; - my $where = encode_filters $get->{filters}, \&filtertosql, $get->{c}, \@placeholders, [ - [ 'uid', - [ 'int' => 'uid :op: :value:', {qw|= =|}, range => [0,1e6], process => sub { $uid = $_[0]; $_[0] || $get->{c}{uid} || 0 } ], - ] - ]; - my $last = sqllast $get, 'vn', { vn => 'vid %s' }; - return if !$where || !$last; - - return cerr $get->{c}, needlogin => 'Not logged in as a user' if !$uid && !$get->{c}{uid}; - $where = "($where) AND NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = w.uid AND key = 'hide_list')" if $uid; - - $_[KERNEL]->post(pg => query => - qq|SELECT $select FROM wlists w WHERE $where $last|, - \@placeholders, 'get_wishlist_res', $get); -} - - -sub get_wishlist_res { - my($num, $res, $get, $time) = (@_[ARG0..$#_]); - - $get->{time} += $time; - $get->{queries}++; - - for (@$res) { - $_->{vn}*=1; - $_->{priority}*=1; - $_->{added} = int $_->{added}; - } - $get->{more} = pop(@$res)&&1 if @$res > $get->{opt}{results}; - $get->{list} = $res; - - $_[KERNEL]->yield(get_results => { %$get, type => 'wishlist' }); -} - sub set_return { my($num, $res, $obj, $time) = (@_[ARG0..$#_]); @@ -1272,44 +1116,5 @@ sub set_wishlist { }, [ $vp, $obj->{c}{uid}, $obj->{id}, $obj->{c}{uid}, $obj->{id}, $vp, $obj->{id} ], 'set_return', $obj); } - -# can be call()'ed from other sessions (specifically written for IRC) -sub admin { - my($func, @arg) = @_[ARG0..$#_]; - - if($func eq 'stats') { - return { %{$_[HEAP]{s}}, online => scalar keys %{$_[HEAP]{c}} }; - } - if($func eq 'list') { - return [ map { - my $c = $_[HEAP]{c}{$_}; - my $r = { # make sure not to return our wheel - id => $_, - (map +($_, $c->{$_}), qw|username ip client clientver connected cmds cmd_err|) - }; - if($c->{client}) { - $r->{t_cmd} = ($c->{throttle}[0]-time())/$_[HEAP]{throttle_cmd}[0]; - $r->{t_sql} = ($c->{throttle}[1]-time())/$_[HEAP]{throttle_sql}[0]; - $r->{t_cmd} = 0 if $r->{t_cmd} < 0; - $r->{t_sql} = 0 if $r->{t_sql} < 0; - } - $r - } keys %{$_[HEAP]{c}} ]; - } - if($func eq 'bans') { - return $_[HEAP]{ipbans}; - } - if($func eq 'ban') { - my $ip = $_[HEAP]{c}{$arg[0]} ? $_[HEAP]{c}{$arg[0]}{ip} : $arg[0]; - return undef if !$ip || $ip !~ /^\d{1,3}(?:\.\d{1,3}){3}$/; - push @{$_[HEAP]{ipbans}}, $ip; - delete $_[HEAP]{c}{$_} for grep $_[HEAP]{c}{$_}{ip} eq $ip, keys %{$_[HEAP]{c}}; - } - if($func eq 'unban') { - $_[HEAP]{ipbans} = [ grep $_ ne $arg[0], @{$_[HEAP]{ipbans}} ]; - } -} - - 1; diff --git a/lib/Multi/Core.pm b/lib/Multi/Core.pm index 36f9aae6..3244927e 100644 --- a/lib/Multi/Core.pm +++ b/lib/Multi/Core.pm @@ -183,6 +183,8 @@ sub pg_cmd { my($q, $a, $s) = @_; my $r; + #AE::log debug => sprintf "%s:%d: %s | %s", (caller)[0,2], $q, $a ? join ', ', @$a : ''; + my $sub = !$s || !ref $s ? do { my $loc = sprintf '%s:%d%s', (caller)[0,2], $s ? ":$s" : ''; sub { pg_expect $_[0], undef, $loc } |