diff options
author | Yorhel <git@yorhel.nl> | 2014-10-22 16:36:22 +0200 |
---|---|---|
committer | Yorhel <git@yorhel.nl> | 2014-10-22 16:36:22 +0200 |
commit | 46ce00029e3c6f00f801ec0dc9be84db864df6df (patch) | |
tree | 240dd37f59326be49ccc2641b51ecefdbd174f4b /lib/Multi/RG.pm | |
parent | a93452019f0a3bf84b13bcc637765c56f6dd18a4 (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.pm | 380 |
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; |