summaryrefslogtreecommitdiff
path: root/lib/Multi/RG.pm
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2014-10-22 16:36:22 +0200
committerYorhel <git@yorhel.nl>2014-10-22 16:36:22 +0200
commit46ce00029e3c6f00f801ec0dc9be84db864df6df (patch)
tree240dd37f59326be49ccc2641b51ecefdbd174f4b /lib/Multi/RG.pm
parenta93452019f0a3bf84b13bcc637765c56f6dd18a4 (diff)
Multi::RG: Converted to use AnyEvent
AnyEvent::Util::run_cmd() is a godsent. POE was such a hassle in that area.
Diffstat (limited to 'lib/Multi/RG.pm')
-rw-r--r--lib/Multi/RG.pm380
1 files changed, 189 insertions, 191 deletions
diff --git a/lib/Multi/RG.pm b/lib/Multi/RG.pm
index e8ef52ee..30101c53 100644
--- a/lib/Multi/RG.pm
+++ b/lib/Multi/RG.pm
@@ -7,223 +7,134 @@ package Multi::RG;
use strict;
use warnings;
-use POE 'Wheel::Run', 'Filter::Stream';
+use Multi::Core;
+use AnyEvent::Util;
use Encode 'encode_utf8';
use XML::Parser;
use TUWF::XML;
-use Time::HiRes 'time';
-
-
-sub spawn {
- my $p = shift;
- POE::Session->create(
- package_states => [
- $p => [qw|
- _start shutdown check_rg creategraph getrel builddot savegraph finish
- proc_stdin proc_stdout proc_stderr proc_closed proc_child
- |],
- ],
- heap => {
- font => 'Arial',
- fsize => [ 9, 7, 10 ], # nodes, edges, node_title
- dot => '/usr/bin/dot',
- check_delay => 3600,
- @_,
- }
- );
-}
-sub _start {
- $_[KERNEL]->alias_set('rg');
- $_[KERNEL]->sig(CHLD => 'proc_child');
- $_[KERNEL]->sig(shutdown => 'shutdown');
- $_[KERNEL]->post(pg => listen => relgraph => 'check_rg');
- $_[KERNEL]->yield('check_rg');
-}
+my %O = (
+ font => 'Arial',
+ fsize => [ 9, 7, 10 ], # nodes, edges, node_title
+ dot => '/usr/bin/dot',
+ check_delay => 3600,
+);
+
+my %C;
-sub shutdown {
- $_[KERNEL]->delay('check_rg');
- $_[KERNEL]->post(pg => unlisten => 'relgraph');
- $_[KERNEL]->alias_remove('rg');
+
+sub run {
+ shift;
+ %O = (%O, @_);
+ push_watcher schedule 0, $O{check_delay}, \&check_rg;
+ push_watcher pg->listen(relgraph => on_notify => \&check_rg);
}
sub check_rg {
- 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
+ # Only process one at a time, we don't know how many other entries the
+ # current graph will affect.
+ return if $C{id};
+
+ AE::log debug => 'Checking for new graphs to create.';
+ pg_cmd q|
+ SELECT 'v', v.id FROM vn v JOIN vn_relations vr ON vr.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');
+ LIMIT 1|, undef, \&creategraph;
}
-sub creategraph { # num, res
- return $_[KERNEL]->delay('check_rg', $_[HEAP]{check_delay}) if $_[ARG0] == 0;
+sub creategraph {
+ my($res, $time) = @_;
+ return if pg_expect $res, 1 or !$res->rows;
- $_[HEAP]{start} = time;
- $_[HEAP]{id} = $_[ARG1][0]{id};
- $_[HEAP]{type} = $_[ARG1][0]{type};
- $_[HEAP]{rels} = {}; # relations (key=id1-id2, value=[relation,official])
- $_[HEAP]{nodes} = {}; # nodes (key=id, value= 0:found, 1:processed)
+ %C = (
+ start => scalar AE::time(),
+ type => scalar $res->value(0, 0),
+ id => scalar $res->value(0, 1),
+ sqlt => $time,
+ rels => {}, # relations (key=id1-id2, value=[relation,official])
+ nodes => {}, # nodes (key=id, value= 0:found, 1:processed)
+ );
- $_[KERNEL]->post(pg => query => $_[HEAP]{type} eq 'v'
- ? 'SELECT vid2 AS id, relation, official 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});
+ AE::log debug => "Generating graph for $C{type}$C{id}";
+ getrelid($C{id});
}
-sub getrel { # num, res, id
- my $id = $_[ARG2];
- $_[HEAP]{nodes}{$id} = 1;
+sub getrelid {
+ my $id = shift;
+ AE::log debug => "Fetching relations for $C{type}$id";
+ pg_cmd $C{type} eq 'v'
+ ? 'SELECT vid2, relation, official FROM vn v JOIN vn_relations vr ON vr.vid1 = v.latest WHERE v.id = $1'
+ : 'SELECT pid2, relation FROM producers p JOIN producers_relations pr ON pr.pid1 = p.latest WHERE p.id = $1',
+ [ $id ], sub { getrel($id, @_) };
+}
- for($_[ARG0] > 0 ? @{$_[ARG1]} : ()) {
- $_[HEAP]{rels}{$id.'-'.$_->{id}} = [ $VNDB::S{ $_[HEAP]{type} eq 'v' ? 'vn_relations' : 'prod_relations' }{$_->{relation}}[1], $_->{official} ] if $id < $_->{id};
- $_[HEAP]{rels}{$_->{id}.'-'.$id} = [ $_->{relation}, $_->{official} ] if $id > $_->{id};
- if(!exists $_[HEAP]{nodes}{$_->{id}}) {
- $_[HEAP]{nodes}{$_->{id}} = 0;
- $_[KERNEL]->post(pg => query => $_[HEAP]{type} eq 'v'
- ? 'SELECT vid2 AS id, relation, official 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});
+sub getrel { # id, res, time
+ my($id, $res, $time) = @_;
+ return if pg_expect $res, 1, $id;
+
+ $C{sqlt} += $time;
+ $C{nodes}{$id} = 1;
+
+ for($res->rows) {
+ my($xid, $xrel, $xoff) = @$_;
+ $xoff = 0 if $xoff && $xoff =~ /^f/;
+
+ $C{rels}{$id.'-'.$xid} = [ $VNDB::S{ $C{type} eq 'v' ? 'vn_relations' : 'prod_relations' }{$xrel}[1], $xoff ] if $id < $xid;
+ $C{rels}{$xid.'-'.$id} = [ $xrel, $xoff ] if $id > $xid;
+
+ # New node? Get its relations too.
+ if(!exists $C{nodes}{$xid}) {
+ $C{nodes}{$xid} = 0;
+ getrelid $xid;
}
}
+ # Wait for other node relations to come in.
+ return if grep !$_, values %{$C{nodes}};
+
# do we have all relations now? get node info
- if(!grep !$_, values %{$_[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::text[] 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');
- }
+ my @ids = keys %{$C{nodes}};
+ my $ids = join(', ', map '$'.$_, 1..@ids);
+ AE::log debug => "Fetching node information for $C{type}:".join ', ', @ids;
+ pg_cmd $C{type} eq 'v'
+ ? "SELECT v.id, vr.title, v.c_released AS date, array_to_string(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",
+ [ @ids ], \&builddot;
}
-sub builddot { # num, res
- my $nodes = $_[ARG1];
+sub builddot {
+ my($res, $time) = @_;
+ return if pg_expect $res, 1, $C{id};
+ $C{sqlt} += $time;
my $gv =
qq|graph rgraph {\n|.
- qq|\tnode [ fontname = "$_[HEAP]{font}", shape = "plaintext",|.
- qq| fontsize = $_[HEAP]{fsize}[0], fontcolor = "#333333", color = "#111111" ]\n|.
+ qq|\tnode [ fontname = "$O{font}", shape = "plaintext",|.
+ qq| fontsize = $O{fsize}[0], fontcolor = "#333333", color = "#111111" ]\n|.
qq|\tedge [ labeldistance = 2.5, labelangle = -20, labeljust = 1, minlen = 2, dir = "both",|.
- qq| fontname = $_[HEAP]{font}, fontsize = $_[HEAP]{fsize}[1], arrowsize = 0.7, color = "#111111", fontcolor = "#333333" ]\n|;
+ qq| fontname = $O{font}, fontsize = $O{fsize}[1], arrowsize = 0.7, color = "#111111", fontcolor = "#333333" ]\n|;
- # insert all nodes
- $gv .= $_[HEAP]{type} eq 'v' ? _vnnode($_, $_[HEAP]) : _prodnode($_, $_[HEAP]) for @$nodes;
-
- # ...and relations
- $gv .= $_[HEAP]{type} eq 'v' ? _vnrels($_[HEAP]{rels}, $nodes) : _prodrels($_[HEAP]{rels}, $nodes);
+ # insert all nodes and relations
+ my %nodes = map +($_->{id}, $_), $res->rowsAsHashes;
+ $gv .= $C{type} eq 'v' ? gv_vnnode($nodes{$_}) : gv_prodnode($nodes{$_}) for keys %nodes;
+ $gv .= $C{type} eq 'v' ? gv_vnrels($C{rels}, \%nodes) : gv_prodrels($C{rels}, \%nodes);
$gv .= "}\n";
- # Pass our dot file to graphviz
- $_[HEAP]{svg} = '';
- $_[HEAP]{proc} = POE::Wheel::Run->new(
- Program => $_[HEAP]{dot},
- ProgramArgs => [ '-Tsvg' ],
- StdioFilter => POE::Filter::Stream->new(),
- StdinEvent => 'proc_stdin',
- StdoutEvent => 'proc_stdout',
- StderrEvent => 'proc_stderr',
- CloseEvent => 'proc_closed',
- );
- $_[HEAP]{proc}->put($gv);
-}
-
-
-sub savegraph {
- # Before saving the SVG output, we'll modify it a little:
- # - Remove comments
- # - Add svg: prefix to all tags
- # - Remove xmlns declarations (this is set in the html)
- # - Remove <title> elements (unused)
- # - Remove id attributes (unused)
- # - Remove first <polygon> element (emulates the background color)
- # - Replace stroke and fill attributes with classes (so that coloring is done in CSS)
- my $svg = '';
- my $w = TUWF::XML->new(write => sub { $svg .= shift });
- my $p = XML::Parser->new;
- $p->setHandlers(
- Start => sub {
- my($expat, $el, %attr) = @_;
- return if $el eq 'title' || $expat->in_element('title');
- return if $el eq 'polygon' && $expat->depth == 2;
-
- $attr{class} = 'border' if $attr{stroke} && $attr{stroke} eq '#111111';
- $attr{class} = 'nodebg' if $attr{fill} && $attr{fill} eq '#222222';
-
- delete @attr{qw|stroke fill xmlns xmlns:xlink|};
- delete $attr{id} if $attr{id} && $attr{id} !~ /^node_[vp]\d+$/;
- $w->tag("svg:$el", %attr, $el eq 'path' || $el eq 'polygon' ? undef : ());
- },
- End => sub {
- my($expat, $el) = @_;
- return if $el eq 'title' || $expat->in_element('title');
- return if $el eq 'polygon' && $expat->depth == 2;
- $w->end("svg:$el") if $el ne 'path' && $el ne 'polygon';
- },
- Char => sub {
- my($expat, $str) = @_;
- return if $expat->in_element('title');
- $w->txt($str) if $str !~ /^[\s\t\r\n]*$/s;
- }
- );
- $p->parsestring($_[HEAP]{svg});
-
- # save the processed SVG in the database and fetch graph ID
- $_[KERNEL]->post(pg => query => 'INSERT INTO relgraphs (svg) VALUES (?) RETURNING id', [ $svg ], 'finish');
-}
-
-
-sub finish { # num, res
- my $id = $_[ARG1][0]{id};
- my $ids = join ',', sort map int, keys %{$_[HEAP]{nodes}};
- my $table = $_[HEAP]{type} eq 'v' ? 'vn' : 'producers';
-
- # update the table
- $_[KERNEL]->post(pg => do => "UPDATE $table SET rgraph = ? WHERE id IN($ids)", [ $id ]);
-
- # log
- $_[KERNEL]->call(core => log => 'Generated relation graph #%d in %.2fs, %s: %s', $id, time-$_[HEAP]{start}, uc $_[HEAP]{type}, $ids);
-
- # clean up
- delete @{$_[HEAP]}{qw| start id type nodes rels svg proc |};
-
- # check for more things to do
- $_[KERNEL]->yield('check_rg');
+ rundot($gv);
}
-
-# POE handlers for communication with GraphViz
-sub proc_stdin {
- $_[HEAP]{proc}->shutdown_stdin;
-}
-sub proc_stdout {
- $_[HEAP]{svg} .= $_[ARG0];
-}
-sub proc_stderr {
- $_[KERNEL]->call(core => log => 'GraphViz STDERR: %s', $_[ARG0]);
-}
-sub proc_closed {
- $_[KERNEL]->yield('savegraph');
-}
-sub proc_child {
- 1; # do nothing, just make sure SIGCHLD is handled to reap the process
-}
-
-
-
-# non-POE helper functions
-
-sub _vnnode {
- my($n, $heap) = @_;
+sub gv_vnnode {
+ my $n = shift;
my $date = sprintf '%08d', $n->{date};
$date =~ s{^([0-9]{4})([0-9]{2})([0-9]{2})$}{
@@ -249,23 +160,21 @@ sub _vnnode {
q|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="2"><FONT POINT-SIZE="%d"> %s </FONT></TD></TR>|.
q|<TR><TD> %s </TD><TD> %s </TD></TR>|.
qq|</TABLE>> ]\n|,
- $_->{id}, encode_utf8($tooltip), $heap->{fsize}[2], encode_utf8($title), $date, join('/', @{$n->{lang}})||'N/A';
+ $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($title), $date, $n->{lang}||'N/A';
}
-sub _vnrels {
+sub gv_vnrels {
my($rels, $vns) = @_;
my $r = '';
# @rels = ([ vid1, vid2, relation, official, date1, date2 ], ..), for easier processing
my @rels = map {
/^([0-9]+)-([0-9]+)$/;
- my $vn1 = (grep $1 == $_->{id}, @$vns)[0];
- my $vn2 = (grep $2 == $_->{id}, @$vns)[0];
- [ $1, $2, @{$rels->{$_}}, $vn1->{date}, $vn2->{date} ]
+ [ $1, $2, @{$rels->{$_}}, $vns->{$1}{date}, $vns->{$2}{date} ]
} keys %$rels;
- # insert all edges, ordered by release date again
+ # insert all edges, ordered by release date
for (sort { ($a->[4]>$a->[5]?$a->[5]:$a->[4]) <=> ($b->[4]>$b->[5]?$b->[5]:$b->[4]) } @rels) {
# [older game] -> [newer game]
if($_->[5] > $_->[4]) {
@@ -279,12 +188,12 @@ sub _vnrels {
: qq|label = "\$____vnrel_$_->[2]____\$" $style|;
$r .= qq|\tv$$_[1] -- v$$_[0] [ $label ]\n|;
}
- return $r;
+ $r;
}
-sub _prodnode {
- my($n, $heap) = @_;
+sub gv_prodnode {
+ my $n = shift;
my $name = $n->{name};
$name = substr($name, 0, 27).'...' if length($name) > 30;
@@ -302,18 +211,18 @@ sub _prodnode {
q|<TR><TD COLSPAN="2" ALIGN="CENTER" CELLPADDING="2"><FONT POINT-SIZE="%d"> %s </FONT></TD></TR>|.
q|<TR><TD ALIGN="CENTER"> $_lang_%s_$ </TD><TD ALIGN="CENTER"> $_ptype_%s_$ </TD></TR>|.
qq|</TABLE>> ]\n|,
- $_->{id}, encode_utf8($tooltip), $heap->{fsize}[2], encode_utf8($name), $n->{lang}, $n->{type};
+ $n->{id}, encode_utf8($tooltip), $O{fsize}[2], encode_utf8($name), $n->{lang}, $n->{type};
}
-sub _prodrels {
+sub gv_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 $p1 = $prods->{$1};
+ my $p2 = $prods->{$2};
my $rev = $VNDB::S{prod_relations}{$rels->{$_}[0]}[1];
my $label = $rev ne $rels->{$_}[0]
@@ -321,9 +230,98 @@ sub _prodrels {
: qq|label = "\$____prodrel_$rels->{$_}[0]____\$"|;
$r .= qq|\tp$p1->{id} -- p$p2->{id} [ $label ]\n|;
}
- return $r;
+ $r;
}
-1;
+sub rundot {
+ my $gv = shift;
+ AE::log trace => "Running graphviz, dot:\n$gv";
+
+ my $svg;
+ my $cv = run_cmd [ $O{dot}, '-Tsvg' ],
+ '<', \$gv,
+ '>', \$svg,
+ '2>', sub { AE::log warn => "STDERR from graphviz: $_[0]" if $_[0]; };
+
+ $cv->cb(sub {
+ return AE::log warn => 'graphviz failed' if shift->recv;
+ processgraph($svg);
+ });
+}
+
+
+sub processgraph {
+ my $data = shift;
+
+ # Before saving the SVG output, we'll modify it a little:
+ # - Remove comments
+ # - Add svg: prefix to all tags
+ # - Remove xmlns declarations (this is set in the html)
+ # - Remove <title> elements (unused)
+ # - Remove id attributes (unused)
+ # - Remove first <polygon> element (emulates the background color)
+ # - Replace stroke and fill attributes with classes (so that coloring is done in CSS)
+ my $svg = '';
+ my $w = TUWF::XML->new(write => sub { $svg .= shift });
+ my $p = XML::Parser->new;
+ $p->setHandlers(
+ Start => sub {
+ my($expat, $el, %attr) = @_;
+ return if $el eq 'title' || $expat->in_element('title');
+ return if $el eq 'polygon' && $expat->depth == 2;
+ $attr{class} = 'border' if $attr{stroke} && $attr{stroke} eq '#111111';
+ $attr{class} = 'nodebg' if $attr{fill} && $attr{fill} eq '#222222';
+
+ delete @attr{qw|stroke fill xmlns xmlns:xlink|};
+ delete $attr{id} if $attr{id} && $attr{id} !~ /^node_[vp]\d+$/;
+ $w->tag("svg:$el", %attr, $el eq 'path' || $el eq 'polygon' ? undef : ());
+ },
+ End => sub {
+ my($expat, $el) = @_;
+ return if $el eq 'title' || $expat->in_element('title');
+ return if $el eq 'polygon' && $expat->depth == 2;
+ $w->end("svg:$el") if $el ne 'path' && $el ne 'polygon';
+ },
+ Char => sub {
+ my($expat, $str) = @_;
+ return if $expat->in_element('title');
+ $w->txt($str) if $str !~ /^[\s\t\r\n]*$/s;
+ }
+ );
+ $p->parsestring($data);
+
+ # save the processed SVG in the database and fetch graph ID
+ AE::log trace => "Processed SVG:\n$svg";
+ pg_cmd 'INSERT INTO relgraphs (svg) VALUES ($1) RETURNING id', [ $svg ], \&save_rgraph;
+}
+
+
+sub save_rgraph {
+ my($res, $time) = @_;
+ return if pg_expect $res, 1;
+ $C{sqlt} += $time;
+
+ my $graphid = $res->value(0,0);
+ my @ids = sort keys %{$C{nodes}};
+ my $ids = join ',', map '$'.$_, 2..@ids+1;
+ my $table = $C{type} eq 'v' ? 'vn' : 'producers';
+
+ pg_cmd "UPDATE $table SET rgraph = \$1 WHERE id IN($ids)",
+ [ $graphid, @ids ],
+ sub {
+ my($res, $time) = @_;
+ return if pg_expect $res, 0;
+ $C{sqlt} += $time;
+
+ AE::log info => sprintf 'Generated relation graph #%d in %.2fs (%.2fs SQL), %s: %s',
+ $graphid, AE::time-$C{start}, $C{sqlt}, $C{type}, join ',', @ids;
+
+ %C = ();
+ check_rg;
+ };
+}
+
+
+1;