From 6900668e8dad97762e4a4c493c21dec1391998cb Mon Sep 17 00:00:00 2001 From: Yorhel Date: Wed, 21 Oct 2009 16:01:08 +0200 Subject: Added relation graphs for producers TODO: - document the relations - emit a relgraph notify when needed --- lib/Multi/Maintenance.pm | 7 +- lib/Multi/RG.pm | 217 +++++++++++++++++++++++++++--------------- lib/VNDB/DB/Producers.pm | 6 +- lib/VNDB/Handler/Producers.pm | 23 +++++ lib/VNDB/Handler/VNPage.pm | 32 +------ lib/VNDB/Util/CommonHTML.pm | 40 +++++++- 6 files changed, 212 insertions(+), 113 deletions(-) (limited to 'lib') diff --git a/lib/Multi/Maintenance.pm b/lib/Multi/Maintenance.pm index ecc80486..0bd5eb91 100644 --- a/lib/Multi/Maintenance.pm +++ b/lib/Multi/Maintenance.pm @@ -119,8 +119,11 @@ sub vnpopularity { sub cleangraphs { # should be pretty fast - $_[KERNEL]->post(pg => do => 'DELETE FROM relgraphs vg WHERE NOT EXISTS(SELECT 1 FROM vn WHERE rgraph = vg.id)', - undef, 'log_stats', 'cleangraphs'); + $_[KERNEL]->post(pg => do => q| + DELETE FROM relgraphs vg + WHERE NOT EXISTS(SELECT 1 FROM vn WHERE rgraph = vg.id) + AND NOT EXISTS(SELECT 1 FROM producers WHERE rgraph = vg.id) + |, undef, 'log_stats', 'cleangraphs'); } diff --git a/lib/Multi/RG.pm b/lib/Multi/RG.pm index 5cb03ed4..de3e89bf 100644 --- a/lib/Multi/RG.pm +++ b/lib/Multi/RG.pm @@ -51,10 +51,12 @@ sub shutdown { sub check_rg { - return if $_[HEAP]{vid}; - $_[KERNEL]->call(pg => query => - 'SELECT v.id FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE rgraph IS NULL AND hidden = FALSE LIMIT 1', - undef, 'creategraph'); + return if $_[HEAP]{id}; + $_[KERNEL]->call(pg => query => q| + SELECT 'v' AS type, v.id FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE rgraph IS NULL AND hidden = FALSE + UNION + SELECT 'p', p.id FROM producers p JOIN producers_relations pr ON pr.pid1 = p.latest WHERE rgraph IS NULL AND hidden = FALSE + LIMIT 1|, undef, 'creategraph'); } @@ -62,45 +64,48 @@ sub creategraph { # num, res return $_[KERNEL]->delay('check_rg', $_[HEAP]{check_delay}) if $_[ARG0] == 0; $_[HEAP]{start} = time; - $_[HEAP]{vid} = $_[ARG1][0]{id}; - $_[HEAP]{rels} = {}; # relations (key=vid1-vid2, value=relation) - $_[HEAP]{nodes} = {}; # nodes (key=vid, value= 0:found, 1:processed) - - $_[KERNEL]->post(pg => query => - 'SELECT vid2 AS id, relation FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE v.id = ?', - [ $_[HEAP]{vid} ], 'getrel', $_[HEAP]{vid}); + $_[HEAP]{id} = $_[ARG1][0]{id}; + $_[HEAP]{type} = $_[ARG1][0]{type}; + $_[HEAP]{rels} = {}; # relations (key=id1-id2, value=relation) + $_[HEAP]{nodes} = {}; # nodes (key=id, value= 0:found, 1:processed) + + $_[KERNEL]->post(pg => query => $_[HEAP]{type} eq 'v' + ? 'SELECT vid2 AS id, relation FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE v.id = ?' + : 'SELECT pid2 AS id, relation FROM producers p JOIN producers_relations pr ON pr.pid1 = p.latest WHERE p.id = ?', + [ $_[HEAP]{id} ], 'getrel', $_[HEAP]{id}); } -sub getrel { # num, res, vid +sub getrel { # num, res, id my $id = $_[ARG2]; $_[HEAP]{nodes}{$id} = 1; for($_[ARG0] > 0 ? @{$_[ARG1]} : ()) { - $_[HEAP]{rels}{$id.'-'.$_->{id}} = $VNDB::S{vn_relations}{$_->{relation}}[1] if $id < $_->{id}; + $_[HEAP]{rels}{$id.'-'.$_->{id}} = $VNDB::S{ $_[HEAP]{type} eq 'v' ? 'vn_relations' : 'prod_relations' }{$_->{relation}}[1] if $id < $_->{id}; $_[HEAP]{rels}{$_->{id}.'-'.$id} = $_->{relation} if $id > $_->{id}; if(!exists $_[HEAP]{nodes}{$_->{id}}) { $_[HEAP]{nodes}{$_->{id}} = 0; - $_[KERNEL]->post(pg => query => - 'SELECT vid2 AS id, relation FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE v.id = ?', + $_[KERNEL]->post(pg => query => $_[HEAP]{type} eq 'v' + ? 'SELECT vid2 AS id, relation FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE v.id = ?' + : 'SELECT pid2 AS id, relation FROM producers p JOIN producers_relations pr ON pr.pid1 = p.latest WHERE p.id = ?', [ $_->{id} ], 'getrel', $_->{id}); } } - # do we have all relations now? get VN info + # do we have all relations now? get node info if(!grep !$_, values %{$_[HEAP]{nodes}}) { - $_[KERNEL]->post(pg => query => - 'SELECT v.id, vr.title, v.c_released AS date, v.c_languages AS lang - FROM vn v JOIN vn_rev vr ON vr.id = v.latest - WHERE v.id IN('.join(', ', map '?', keys %{$_[HEAP]{nodes}}).')', + my $ids = join(', ', map '?', keys %{$_[HEAP]{nodes}}); + $_[KERNEL]->post(pg => query => $_[HEAP]{type} eq 'v' + ? "SELECT v.id, vr.title, v.c_released AS date, v.c_languages AS lang FROM vn v JOIN vn_rev vr ON vr.id = v.latest WHERE v.id IN($ids) ORDER BY v.c_released" + : "SELECT p.id, pr.name, pr.lang, pr.type FROM producers p JOIN producers_rev pr ON pr.id = p.latest WHERE p.id IN($ids) ORDER BY pr.name", [ keys %{$_[HEAP]{nodes}} ], 'builddot'); } } sub builddot { # num, res - my $vns = $_[ARG1]; + my $nodes = $_[ARG1]; my $gv = qq|graph rgraph {\n|. @@ -109,57 +114,11 @@ sub builddot { # num, res qq|\tedge [ labeldistance = 2.5, labelangle = -20, labeljust = 1, minlen = 2, dir = "both",|. qq| fontname = $_[HEAP]{font}, fontsize = $_[HEAP]{fsize}[1], arrowsize = 0.7, color = "#111111", fontcolor = "#333333" ]\n|; - # insert all nodes, ordered by release date - for (sort { $a->{date} <=> $b->{date} } @$vns) { - my $date = sprintf '%08d', $_->{date}; - $date =~ s{^([0-9]{4})([0-9]{2})([0-9]{2})$}{ - $1 == 0 ? 'unknown' - : $1 == 9999 ? 'TBA' - : $2 == 99 ? $1 - : $3 == 99 ? "$1-$2" : "$1-$2-$3" - }e; - - my $title = $_->{title}; - $title = substr($title, 0, 27).'...' if length($title) > 30; - $title =~ s/&/&/g; - $title =~ s/>/>/g; - $title =~ s/{title}; - $tooltip =~ s/\\/\\\\/g; - $tooltip =~ s/"/\\"/g; - - $gv .= sprintf - qq|\tv%d [ URL = "/v%d", tooltip = "%s" label=<|. - q||. - q||. - q||. - qq|
%s
%s %s
> ]\n|, - $_->{id}, $_->{id}, encode_utf8($tooltip), $_[HEAP]{fsize}[2], encode_utf8($title), $date, $_->{lang}||'N/A'; - } + # insert all nodes + $gv .= $_[HEAP]{type} eq 'v' ? _vnnode($_, $_[HEAP]) : _prodnode($_, $_[HEAP]) for @$nodes; - # @rels = ([ vid1, vid2, relation, date1, date2 ], ..), for easier processing - my @rels = map { - /^([0-9]+)-([0-9]+)$/; - my $vn1 = (grep $1 == $_->{id}, @$vns)[0]; - my $vn2 = (grep $2 == $_->{id}, @$vns)[0]; - [ $1, $2, $_[HEAP]{rels}{$_}, $vn1->{date}, $vn2->{date} ] - } keys %{$_[HEAP]{rels}}; - - # insert all edges, ordered by release date again - for (sort { ($a->[3]>$a->[4]?$a->[4]:$a->[3]) <=> ($b->[3]>$b->[4]?$b->[4]:$b->[3]) } @rels) { - # [older game] -> [newer game] - if($_->[4] > $_->[3]) { - ($_->[0], $_->[1]) = ($_->[1], $_->[0]); - $_->[2] = $VNDB::S{vn_relations}{$_->[2]}[1]; - } - my $rev = $VNDB::S{vn_relations}{$_->[2]}[1]; - my $label = - $rev ne $_->[2] - ? qq|headlabel = "\$____vnrel_$_->[2]____\$", taillabel = "\$____vnrel_${rev}____\$"| - : qq|label = "\$____vnrel_$_->[2]____\$"|; - $gv .= qq|\tv$$_[1] -- v$$_[0] [ $label ]\n|; - } + # ...and relations + $gv .= $_[HEAP]{type} eq 'v' ? _vnrels($_[HEAP]{rels}, $nodes) : _prodrels($_[HEAP]{rels}, $nodes); $gv .= "}\n"; @@ -226,16 +185,17 @@ sub savegraph { sub finish { # num, res my $id = $_[ARG1][0]{id}; - my $vids = join ',', sort map int, keys %{$_[HEAP]{nodes}}; + my $ids = join ',', sort map int, keys %{$_[HEAP]{nodes}}; + my $table = $_[HEAP]{type} eq 'v' ? 'vn' : 'producers'; - # update the VN table - $_[KERNEL]->post(pg => do => "UPDATE vn SET rgraph = ? WHERE id IN($vids)", [ $id ]); + # update the table + $_[KERNEL]->post(pg => do => "UPDATE $table SET rgraph = ? WHERE id IN($ids)", [ $id ]); # log - $_[KERNEL]->call(core => log => 'Generated VN relation graph #%d in %.2fs, V: %s', $id, time-$_[HEAP]{start}, $vids); + $_[KERNEL]->call(core => log => 'Generated %s relation graph #%d in %.2fs, V: %s', $table, $id, time-$_[HEAP]{start}, $ids); # clean up - delete @{$_[HEAP]}{qw| start vid nodes rels svg proc |}; + delete @{$_[HEAP]}{qw| start id type nodes rels svg proc |}; # check for more things to do $_[KERNEL]->yield('check_rg'); @@ -261,5 +221,110 @@ sub proc_child { } + +# non-POE helper functions + +sub _vnnode { + my($n, $heap) = @_; + + my $date = sprintf '%08d', $n->{date}; + $date =~ s{^([0-9]{4})([0-9]{2})([0-9]{2})$}{ + $1 == 0 ? 'unknown' + : $1 == 9999 ? 'TBA' + : $2 == 99 ? $1 + : $3 == 99 ? "$1-$2" : "$1-$2-$3" + }e; + + my $title = $n->{title}; + $title = substr($title, 0, 27).'...' if length($title) > 30; + $title =~ s/&/&/g; + $title =~ s/>/>/g; + $title =~ s/{title}; + $tooltip =~ s/\\/\\\\/g; + $tooltip =~ s/"/\\"/g; + + return sprintf + qq|\tv%d [ URL = "/v%d", tooltip = "%s", label=<|. + q||. + q||. + q||. + qq|
%s
%s %s
> ]\n|, + $_->{id}, $_->{id}, encode_utf8($tooltip), $heap->{fsize}[2], encode_utf8($title), $date, $n->{lang}||'N/A'; +} + + +sub _vnrels { + my($rels, $vns) = @_; + my $r = ''; + + # @rels = ([ vid1, vid2, relation, date1, date2 ], ..), for easier processing + my @rels = map { + /^([0-9]+)-([0-9]+)$/; + my $vn1 = (grep $1 == $_->{id}, @$vns)[0]; + my $vn2 = (grep $2 == $_->{id}, @$vns)[0]; + [ $1, $2, $rels->{$_}, $vn1->{date}, $vn2->{date} ] + } keys %$rels; + + # insert all edges, ordered by release date again + for (sort { ($a->[3]>$a->[4]?$a->[4]:$a->[3]) <=> ($b->[3]>$b->[4]?$b->[4]:$b->[3]) } @rels) { + # [older game] -> [newer game] + if($_->[4] > $_->[3]) { + ($_->[0], $_->[1]) = ($_->[1], $_->[0]); + $_->[2] = $VNDB::S{vn_relations}{$_->[2]}[1]; + } + my $rev = $VNDB::S{vn_relations}{$_->[2]}[1]; + my $label = $rev ne $_->[2] + ? qq|headlabel = "\$____vnrel_$_->[2]____\$", taillabel = "\$____vnrel_${rev}____\$"| + : qq|label = "\$____vnrel_$_->[2]____\$"|; + $r .= qq|\tv$$_[1] -- v$$_[0] [ $label ]\n|; + } + return $r; +} + + +sub _prodnode { + my($n, $heap) = @_; + + my $name = $n->{name}; + $name = substr($name, 0, 27).'...' if length($name) > 30; + $name =~ s/&/&/g; + $name =~ s/>/>/g; + $name =~ s/{name}; + $tooltip =~ s/\\/\\\\/g; + $tooltip =~ s/"/\\"/g; + + return sprintf + qq|\tp%d [ URL = "/p%d", tooltip = "%s", label=<|. + q||. + q||. + q||. + qq|
%s
$_lang_%s_$ $_ptype_%s_$
> ]\n|, + $_->{id}, $_->{id}, encode_utf8($tooltip), $heap->{fsize}[2], encode_utf8($name), $n->{lang}, $n->{type}; +} + + +sub _prodrels { + my($rels, $prods) = @_; + my $r = ''; + + for (keys %$rels) { + /^([0-9]+)-([0-9]+)$/; + my $p1 = (grep $1 == $_->{id}, @$prods)[0]; + my $p2 = (grep $2 == $_->{id}, @$prods)[0]; + + my $rev = $VNDB::S{prod_relations}{$rels->{$_}}[1]; + my $label = $rev ne $rels->{$_} + ? qq|headlabel = "\$____prodrel_${rev}____\$", taillabel = "\$____prodrel_$rels->{$_}____\$"| + : qq|label = "\$____prodrel_$rels->{$_}____\$"|; + $r .= qq|\tp$p1->{id} -- p$p2->{id} [ $label ]\n|; + } + return $r; +} + + 1; diff --git a/lib/VNDB/DB/Producers.pm b/lib/VNDB/DB/Producers.pm index c28d12d7..7c7da3ba 100644 --- a/lib/VNDB/DB/Producers.pm +++ b/lib/VNDB/DB/Producers.pm @@ -9,7 +9,7 @@ our @EXPORT = qw|dbProducerGet dbProducerEdit dbProducerAdd|; # options: results, page, id, search, char, rev -# what: extended, changes, vn, relations +# what: extended changes vn relations relgraph sub dbProducerGet { my $self = shift; my %o = ( @@ -40,10 +40,12 @@ sub dbProducerGet { push @join, $o{rev} ? 'JOIN producers p ON p.id = pr.pid' : 'JOIN producers p ON pr.id = p.latest'; push @join, 'JOIN changes c ON c.id = pr.id' if $o{what} =~ /changes/ || $o{rev}; push @join, 'JOIN users u ON u.id = c.requester' if $o{what} =~ /changes/; + push @join, 'JOIN relgraphs pg ON pg.id = p.rgraph' if $o{what} =~ /relgraph/; - my $select = 'p.id, pr.type, pr.name, pr.original, pr.lang, pr.id AS cid'; + my $select = 'p.id, pr.type, pr.name, pr.original, pr.lang, pr.id AS cid, p.rgraph'; $select .= ', pr.desc, pr.alias, pr.website, p.hidden, p.locked' if $o{what} =~ /extended/; $select .= q|, extract('epoch' from c.added) as added, c.requester, c.comments, p.latest, pr.id AS cid, u.username, c.rev| if $o{what} =~ /changes/; + $select .= ', pg.svg' if $o{what} =~ /relgraph/; my($r, $np) = $self->dbPage(\%o, q| SELECT !s diff --git a/lib/VNDB/Handler/Producers.pm b/lib/VNDB/Handler/Producers.pm index 41465b18..4e75962b 100644 --- a/lib/VNDB/Handler/Producers.pm +++ b/lib/VNDB/Handler/Producers.pm @@ -8,6 +8,7 @@ use VNDB::Func; YAWF::register( + qr{p([1-9]\d*)/rg} => \&rg, qr{p([1-9]\d*)(?:\.([1-9]\d*))?} => \&page, qr{p(?:([1-9]\d*)(?:\.([1-9]\d*))?/edit|/new)} => \&edit, @@ -16,6 +17,28 @@ YAWF::register( ); +sub rg { + my($self, $pid) = @_; + + my $p = $self->dbProducerGet(id => $pid, what => 'relgraph')->[0]; + return 404 if !$p->{id} || !$p->{rgraph}; + + my $title = mt '_prodrg_title', $p->{name}; + return if $self->htmlRGHeader($title, 'p', $p); + + $p->{svg} =~ s/\$___(_prodrel_[a-z]+)____\$/mt $1/eg; + $p->{svg} =~ s/\$(_lang_[a-z]+)_\$/mt $1/eg; + $p->{svg} =~ s/\$(_ptype_[a-z]+)_\$/mt $1/eg; + + div class => 'mainbox'; + h1 $title; + p class => 'center'; + lit $p->{svg}; + end; + end; + $self->htmlFooter; +} + sub page { my($self, $pid, $rev) = @_; diff --git a/lib/VNDB/Handler/VNPage.pm b/lib/VNDB/Handler/VNPage.pm index 0205e77d..ec5f4afc 100644 --- a/lib/VNDB/Handler/VNPage.pm +++ b/lib/VNDB/Handler/VNPage.pm @@ -27,40 +27,10 @@ sub rg { return 404 if !$v->{id} || !$v->{rgraph}; my $title = mt '_vnrg_title', $v->{title}; - - if(($self->reqHeader('Accept')||'') !~ /application\/xhtml\+xml/) { - $self->htmlHeader(title => $title); - $self->htmlMainTabs('v', $v, 'rg'); - div class => 'mainbox'; - h1 $title; - div class => 'warning'; - h2 mt '_vnrg_notsupp'; - p mt '_vnrg_notsupp_msg'; - end; - end; - $self->htmlFooter; - return; - } - $self->resHeader('Content-Type' => 'application/xhtml+xml; charset=UTF-8'); - - # This is a REALLY ugly hack, need find a proper solution in YAWF - no warnings 'redefine'; - my $sub = \&YAWF::XML::html; - *YAWF::XML::html = sub () { - lit q||; - tag 'html', - xmlns => "http://www.w3.org/1999/xhtml", - 'xmlns:svg' => 'http://www.w3.org/2000/svg', - 'xmlns:xlink' => 'http://www.w3.org/1999/xlink'; - }; - $self->htmlHeader(title => $title); - *YAWF::XML::html = $sub; + return if $self->htmlRGHeader($title, 'v', $v); $v->{svg} =~ s/\$___(_vnrel_[a-z]+)____\$/mt $1/eg; - $self->htmlMainTabs('v', $v, 'rg'); div class => 'mainbox'; h1 $title; p class => 'center'; diff --git a/lib/VNDB/Util/CommonHTML.pm b/lib/VNDB/Util/CommonHTML.pm index 3d032d37..ad99d32d 100644 --- a/lib/VNDB/Util/CommonHTML.pm +++ b/lib/VNDB/Util/CommonHTML.pm @@ -12,7 +12,7 @@ use POSIX 'ceil'; our @EXPORT = qw| htmlMainTabs htmlDenied htmlHiddenMessage htmlBrowse htmlBrowseNavigate - htmlRevision htmlEditMessage htmlItemMessage htmlVoteStats htmlHistory htmlSearchBox + htmlRevision htmlEditMessage htmlItemMessage htmlVoteStats htmlHistory htmlSearchBox htmlRGHeader |; @@ -101,7 +101,7 @@ sub htmlMainTabs { end; } - if($type eq 'v' && $obj->{rgraph}) { + if($type =~ /[vp]/ && $obj->{rgraph}) { li $sel eq 'rg' ? (class => 'tabselected') : (); a href => "/$id/rg", mt '_mtabs_relations'; end; @@ -558,5 +558,41 @@ sub htmlSearchBox { } +sub htmlRGHeader { + my($self, $title, $type, $obj) = @_; + + 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 mt '_rg_notsupp'; + p mt '_rg_notsupp_msg'; + end; + end; + $self->htmlFooter; + return 1; + } + $self->resHeader('Content-Type' => 'application/xhtml+xml; charset=UTF-8'); + + # This is a REALLY ugly hack, need find a proper solution in YAWF + no warnings 'redefine'; + my $sub = \&YAWF::XML::html; + *YAWF::XML::html = sub () { + lit q||; + tag 'html', + xmlns => "http://www.w3.org/1999/xhtml", + 'xmlns:svg' => 'http://www.w3.org/2000/svg', + 'xmlns:xlink' => 'http://www.w3.org/1999/xlink'; + }; + $self->htmlHeader(title => $title); + *YAWF::XML::html = $sub; + $self->htmlMainTabs($type, $obj, 'rg'); + return 0; +} + 1; -- cgit v1.2.3