diff options
Diffstat (limited to 'lib/Multi')
-rw-r--r-- | lib/Multi/Anime.pm | 13 | ||||
-rw-r--r-- | lib/Multi/IRC.pm | 8 | ||||
-rw-r--r-- | lib/Multi/Maintenance.pm | 35 | ||||
-rw-r--r-- | lib/Multi/RG.pm | 296 |
4 files changed, 227 insertions, 125 deletions
diff --git a/lib/Multi/Anime.pm b/lib/Multi/Anime.pm index 03134925..df2f6424 100644 --- a/lib/Multi/Anime.pm +++ b/lib/Multi/Anime.pm @@ -70,6 +70,17 @@ sub spawn { lm => 0, # timestamp of last outgoing message, 0=no running msg aid => 0, # anime ID of the last sent ANIME command tag => int(rand()*50000), + # anime types as returned by AniDB (lowercased) + anime_types => { + 'unknown' => undef, # NULL + 'tv series' => 'tv', + 'ova' => 'ova', + 'movie' => 'mov', + 'other' => 'oth', + 'web' => 'web', + 'tv special' => 'spe', + 'music video' => 'mv', + }, }, ); } @@ -224,7 +235,7 @@ sub receivepacket { # input, wheelid $col[2] = undef if !$col[2] || $col[2] =~ /^0,/; $col[3] = $1 if $col[3] =~ /^([0-9]+)/; # remove multi-year stuff $col[3] = undef if !$col[3]; - $col[4] = (grep lc($VNDB::S{anime_types}[$_]) eq lc($col[4]), 0..$#{$VNDB::S{anime_types}})[0]; + $col[4] = $_[HEAP]{anime_types}{ lc($col[4]) }; $col[5] = undef if !$col[5]; $col[6] = undef if !$col[6]; $_[KERNEL]->post(pg => do => 'UPDATE anime diff --git a/lib/Multi/IRC.pm b/lib/Multi/IRC.pm index 5018d2aa..4225e6b8 100644 --- a/lib/Multi/IRC.pm +++ b/lib/Multi/IRC.pm @@ -266,12 +266,12 @@ sub notify { # name, pid, payload return if !$_[HEAP]{$k}; my $q = $_[ARG0] eq 'newrevision' ? q|SELECT - CASE WHEN c.type = 0 THEN 'v' WHEN c.type = 1 THEN 'r' ELSE 'p' END AS type, c.rev, c.comments, c.id AS lastrev, + CASE WHEN c.type, c.rev, c.comments, c.id AS lastrev, COALESCE(vr.vid, rr.rid, pr.pid) AS id, COALESCE(vr.title, rr.title, pr.name) AS title, u.username FROM changes c - LEFT JOIN vn_rev vr ON c.type = 0 AND c.id = vr.id - LEFT JOIN releases_rev rr ON c.type = 1 AND c.id = rr.id - LEFT JOIN producers_rev pr ON c.type = 2 AND c.id = pr.id + LEFT JOIN vn_rev vr ON c.type = 'v' AND c.id = vr.id + LEFT JOIN releases_rev rr ON c.type = 'r' AND c.id = rr.id + LEFT JOIN producers_rev pr ON c.type = 'p' AND c.id = pr.id JOIN users u ON u.id = c.requester WHERE c.id > ? AND c.requester <> 1 ORDER BY c.added| diff --git a/lib/Multi/Maintenance.pm b/lib/Multi/Maintenance.pm index e29c7b52..4f816e56 100644 --- a/lib/Multi/Maintenance.pm +++ b/lib/Multi/Maintenance.pm @@ -17,13 +17,13 @@ sub spawn { package_states => [ $p => [qw| _start shutdown set_daily daily set_monthly monthly log_stats - vncache tagcache vnpopularity - usercache statscache revcache logrotate + vncache tagcache vnpopularity cleangraphs + usercache statscache logrotate |], ], heap => { - daily => [qw|vncache tagcache vnpopularity|], - monthly => [qw|usercache statscache revcache logrotate|], + daily => [qw|vncache tagcache vnpopularity cleangraphs|], + monthly => [qw|usercache statscache logrotate|], @_, }, ); @@ -50,7 +50,7 @@ sub set_daily { # (GMT because we're calculating on the UNIX timestamp, I can easily add an # offset if necessary, but it doesn't really matter what time this cron # runs, as long as it's run on a daily basis) - $_[KERNEL]->alarm(daily => int(time/86400+1)*86400); + $_[KERNEL]->alarm(daily => int((time+3)/86400+1)*86400); } @@ -70,7 +70,7 @@ sub set_monthly { # We do this by simply incrementing the timestamp with one day and checking gmtime() # for a month change. This might not be very reliable, but should be enough for # our purposes. - my $nextday = int(time/86400+1)*86400; + my $nextday = int((time+3)/86400+1)*86400; my $thismonth = (gmtime)[5]*100+(gmtime)[4]; # year*100 + month, for easy comparing $nextday += 86400 while (gmtime $nextday)[5]*100+(gmtime $nextday)[4] <= $thismonth; $_[KERNEL]->alarm(monthly => $nextday); @@ -99,24 +99,33 @@ sub log_stats { # num, res, action, time sub vncache { - # this takes about 30s to complete. We really need to search for an alternative + # this takes about 40s to complete. We really need to search for an alternative # method of keeping the c_* columns in the vn table up-to-date. $_[KERNEL]->post(pg => do => 'SELECT update_vncache(0)', undef, 'log_stats', 'vncache'); } sub tagcache { - # this still takes "only" about 3 seconds max. Let's hope that doesn't increase too much. + # takes about 18 seconds max. ouch, but still kind-of acceptable $_[KERNEL]->post(pg => do => 'SELECT tag_vn_calc()', undef, 'log_stats', 'tagcache'); } sub vnpopularity { - # still takes at most 2 seconds. Againt, let's hope that doesn't increase... + # still takes at most 2 seconds. let's hope that doesn't increase... $_[KERNEL]->post(pg => do => 'SELECT update_vnpopularity()', undef, 'log_stats', 'vnpopularity'); } +sub cleangraphs { + # should be pretty fast + $_[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'); +} + # # M O N T H L Y J O B S @@ -164,14 +173,6 @@ sub statscache { } -sub revcache { - # This -really- shouldn't be necessary... - # Currently takes about 25 seconds to complete - $_[KERNEL]->post(pg => do => q|SELECT update_rev('vn', ''), update_rev('releases', ''), update_rev('producers', '')|, - undef, 'log_stats', 'revcache'); -} - - sub logrotate { my $dir = sprintf '%s/old', $VNDB::M{log_dir}; mkdir $dir if !-d $dir; diff --git a/lib/Multi/RG.pm b/lib/Multi/RG.pm index e427caf2..b3f9bb46 100644 --- a/lib/Multi/RG.pm +++ b/lib/Multi/RG.pm @@ -9,6 +9,8 @@ use strict; use warnings; use POE 'Wheel::Run', 'Filter::Stream'; use Encode 'encode_utf8'; +use XML::Parser; +use XML::Writer; use Time::HiRes 'time'; @@ -17,15 +19,13 @@ sub spawn { POE::Session->create( package_states => [ $p => [qw| - _start shutdown check_rg creategraph getrel builddot buildgraph savegraph + _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 - imgdir => '/www/vndb/static/rg', - moy => [qw| Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec |], dot => '/usr/bin/dot', check_delay => 3600, @_, @@ -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,148 +64,138 @@ 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}} = reverserel($_->{relation}) if $id < $_->{id}; - $_[HEAP]{rels}{$_->{id}.'-'.$id} = $_->{relation} 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|. - qq|\tratio = "compress"\n|. - qq|\tgraph [ bgcolor="#ffffff00" ]\n|. qq|\tnode [ fontname = "$_[HEAP]{font}", shape = "plaintext",|. - qq| fontsize = $_[HEAP]{fsize}[0], style = "setlinewidth(0.5)", fontcolor = "#cccccc", color = "#225588" ]\n|. + qq| fontsize = $_[HEAP]{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 = "#225588", fontcolor = "#cccccc" ]\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}).+#$1==0?'N/A':$1==9999?'TBA':(($2&&$2<13?($_[HEAP]{moy}[$2-1].' '):'').$1)#e; - - my $title = $_->{title}; - $title = substr($title, 0, 27).'...' if length($title) > 30; - $title =~ s/&/&/g; - $title =~ s/>/>/g; - $title =~ s/</</g; - - my $tooltip = $_->{title}; - $tooltip =~ s/\\/\\\\/g; - $tooltip =~ s/"/\\"/g; - - $gv .= sprintf - qq|\tv%d [ URL = "/v%d", tooltip = "%s" label=<|. - q|<TABLE CELLSPACING="0" CELLPADDING="1" BORDER="0" CELLBORDER="1" BGCOLOR="#00000033">|. - 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}, $_->{id}, encode_utf8($tooltip), $_[HEAP]{fsize}[2], encode_utf8($title), $date, $_->{lang}||'N/A'; - } + qq| fontname = $_[HEAP]{font}, fontsize = $_[HEAP]{fsize}[1], arrowsize = 0.7, color = "#111111", fontcolor = "#333333" ]\n|; - # @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 nodes + $gv .= $_[HEAP]{type} eq 'v' ? _vnnode($_, $_[HEAP]) : _prodnode($_, $_[HEAP]) for @$nodes; - # 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] = reverserel($_->[2]); - } - my $label = - $VNDB::S{vn_relations}[$_->[2]][1] - ? qq|headlabel = "$VNDB::S{vn_relations}[$_->[2]][0]", taillabel = "$VNDB::S{vn_relations}[$_->[2]-1][0]"| : - $VNDB::S{vn_relations}[$_->[2]+1][1] - ? qq|headlabel = "$VNDB::S{vn_relations}[$_->[2]][0]", taillabel = "$VNDB::S{vn_relations}[$_->[2]+1][0]"| - : qq|label = " $VNDB::S{vn_relations}[$_->[2]][0]"|; - $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"; - # get ID - $_[KERNEL]->post(pg => query => 'INSERT INTO relgraph (cmap) VALUES (\'\') RETURNING id', undef, 'buildgraph', \$gv); -} - - -sub buildgraph { # num, res, \$gv - $_[HEAP]{gid} = $_[ARG1][0]{id}; - $_[HEAP]{graph} = sprintf('%s/%02d/%d.png', $_[HEAP]{imgdir}, $_[ARG1][0]{id} % 100, $_[ARG1][0]{id}); - $_[HEAP]{cmap} = ''; - - # roughly equivalent to: - # cat layout.txt | dot -Tpng -o graph.png -Tcmapx + # Pass our dot file to graphviz + $_[HEAP]{svg} = ''; $_[HEAP]{proc} = POE::Wheel::Run->new( Program => $_[HEAP]{dot}, - ProgramArgs => [ '-Tpng', '-o', $_[HEAP]{graph}, '-Tcmapx' ], + ProgramArgs => [ '-Tsvg' ], StdioFilter => POE::Filter::Stream->new(), StdinEvent => 'proc_stdin', StdoutEvent => 'proc_stdout', StderrEvent => 'proc_stderr', CloseEvent => 'proc_closed', ); - $_[HEAP]{proc}->put(${$_[ARG2]}); + $_[HEAP]{proc}->put($gv); } sub savegraph { - my $vids = join ',', sort map int, keys %{$_[HEAP]{nodes}}; + # 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 = XML::Writer->new(OUTPUT => \$svg); + 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 id xmlns xmlns:xlink|}; + $el eq 'path' || $el eq 'polygon' + ? $w->emptyTag("svg:$el", %attr) + : $w->startTag("svg:$el", %attr); + }, + End => sub { + my($expat, $el) = @_; + return if $el eq 'title' || $expat->in_element('title'); + return if $el eq 'polygon' && $expat->depth == 2; + $w->endTag("svg:$el") if $el ne 'path' && $el ne 'polygon'; + }, + Char => sub { + my($expat, $str) = @_; + return if $expat->in_element('title'); + $w->characters($str) if $str !~ /^[\s\t\r\n]*$/s; + } + ); + $p->parsestring($_[HEAP]{svg}); + $w->end(); + + # save the processed SVG in the database and fetch graph ID + $_[KERNEL]->post(pg => query => 'INSERT INTO relgraphs (svg) VALUES (?) RETURNING id', [ $svg ], 'finish'); +} - # chmod graph - chmod 0666, $_[HEAP]{graph}; - # save the image map in the database - $_[KERNEL]->post(pg => do => 'UPDATE relgraph SET cmap = ? WHERE id = ?', - [ "<!-- V:$vids -->\n$_[HEAP]{cmap}", $_[HEAP]{gid} ]); +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 VN table - $_[KERNEL]->post(pg => do => "UPDATE vn SET rgraph = ? WHERE id IN($vids)", [ $_[HEAP]{gid} ]); + # update the table + $_[KERNEL]->post(pg => do => "UPDATE $table SET rgraph = ? WHERE id IN($ids)", [ $id ]); # log - $_[KERNEL]->call(core => log => 'Generated relation graph in %.2fs, V: %s', time-$_[HEAP]{start}, $vids); + $_[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 vid nodes rels gid graph cmap proc |}; + delete @{$_[HEAP]}{qw| start id type nodes rels svg proc |}; # check for more things to do $_[KERNEL]->yield('check_rg'); @@ -216,7 +208,7 @@ sub proc_stdin { $_[HEAP]{proc}->shutdown_stdin; } sub proc_stdout { - $_[HEAP]{cmap} .= $_[ARG0]; + $_[HEAP]{svg} .= $_[ARG0]; } sub proc_stderr { $_[KERNEL]->call(core => log => 'GraphViz STDERR: %s', $_[ARG0]); @@ -230,9 +222,107 @@ sub proc_child { -# non-POE helper function -sub reverserel { # relation - return $VNDB::S{vn_relations}[$_[0]][1] ? $_[0]-1 : $VNDB::S{vn_relations}[$_[0]+1][1] ? $_[0]+1 : $_[0]; +# 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/</</g; + + my $tooltip = $n->{title}; + $tooltip =~ s/\\/\\\\/g; + $tooltip =~ s/"/\\"/g; + + return sprintf + qq|\tv%d [ URL = "/v%d", tooltip = "%s", label=<|. + q|<TABLE CELLSPACING="0" CELLPADDING="1" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|. + 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}, $_->{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/</</g; + + my $tooltip = $n->{name}; + $tooltip =~ s/\\/\\\\/g; + $tooltip =~ s/"/\\"/g; + + return sprintf + qq|\tp%d [ URL = "/p%d", tooltip = "%s", label=<|. + q|<TABLE CELLSPACING="0" CELLPADDING="1" BORDER="0" CELLBORDER="1" BGCOLOR="#222222">|. + 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}, $_->{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; } |