diff options
Diffstat (limited to '')
| -rwxr-xr-x | gen-gdf.pl | 142 |
1 files changed, 99 insertions, 43 deletions
@@ -23,15 +23,16 @@ my $dbmap = CPAN::cpanmap->connect( "dbi:SQLite:dbname=" . $db_map, "", "" ); my $struct_graph; $struct_graph->{ gexf } = { version => "1.0" }; $struct_graph->{ gexf }->{ meta } = { creator => [ 'rtgi' ] }; -$struct_graph->{ gexf }->{ graph } = { type => 'dynamic' }; +$struct_graph->{ gexf }->{ graph } = { type => 'static' }; +# static si pas de dates $struct_graph->{ gexf }->{ graph }->{ attributes } = { class => 'node', - type => 'dynamic', + type => 'static', }; push @{ $struct_graph->{ gexf }->{ graph }->{ attributes }->{ attribute } }, { id => 0, - title => 'dist', + #title => 'dist', type => 'string', }; say "done"; @@ -39,70 +40,125 @@ say "done"; print "creating nodes ... "; $struct_graph->{ gexf }->{ graph }->{ nodes } = {}; -my $packages; -my $id_nodes; +my ($search, $packages, $id_nodes); if ( $type && $type eq 'author' ) { - my $author_list = LoadFile( $list ); - $packages = $dbmap->resultset( 'packages' )->search( - { -and => [ - author => { 'in', $author_list}, + if ( $list ) { + my $author < io $list; + my @author_list = split /\n/, $author; + $search = { + -and => [ + author => { 'in', \@author_list }, released => { '>', '1970-01-01' } ] - } - ); -} else { - $packages = $dbmap->resultset( 'packages' )->search( - { -and => [ + }; + } else { + $search = { + -and => [ author => { '!=', 'null' }, released => { '>', '1970-01-01' } ] - } - ); + }; + } +} else { + $search = { + -and => [ + author => { '!=', 'null' }, + released => { '>', '1970-01-01' } + ] + }; } +$packages = $dbmap->resultset( 'packages' )->search( $search ); +my $id_authors; +my $authors; +my $i=0; +my $id_edges = 1; while ( my $package = $packages->next ) { - my ( $year, $month, $day ) - = $package->released =~ /^(\d{4})-(\d{2})-(\d{2})/; - push @{ $struct_graph->{ gexf }->{ graph }->{ nodes }->{ node } }, { - id => $package->id, - label => $package->dist, - author => $package->author, - version => $package->version, - datefrom => join( '-', $year, $month, $day ), - }; - $id_nodes->{$package->id}++; + if ( $type eq 'author' ) { + if (!exists $id_authors->{$package->author}){ + $id_authors->{$package->author} = ++$i; + } + if ( !exists $authors->{ $package->author } ) { + push @{ $struct_graph->{ gexf }->{ graph }->{ nodes }->{ node } }, + { + id => $id_authors->{$package->author}, + label => $package->author, + }; + $authors->{ $package->author }++; + } + my @edges = $package->edges; + foreach my $edge ( @edges ) { + next if $edge->dist_to->author eq $package->author; + my $edges + = $struct_graph->{ gexf }->{ graph }->{ edges }->{ edge }; + my @check = grep { + $_->{ source } eq $package->author + && $_->{ target } eq $edge->dist_to->author + } @$edges; + if ( @check ) { + map { $_->{ cardinal }++ } @check; + } else { + if (!exists $id_authors->{$edge->dist_to->author}){ + $id_authors->{$edge->dist_to->author} = ++$i; + push @{ $struct_graph->{ gexf }->{ graph }->{ nodes }->{ node } }, + { + id => $id_authors->{$edge->dist_to->author}, + label => $edge->dist_to->author, + }; + $authors->{ $edge->dist_to->author }++; + } + push @{ $struct_graph->{ gexf }->{ graph }->{ edges } + ->{ edge } }, + { + id => $id_edges++, + cardinal => 1, + source => $id_authors->{$package->author}, + target => $id_authors->{$edge->dist_to->author}, + type => 'dir', + }; + } + } + } else { + my ( $year, $month, $day ) + = $package->released =~ /^(\d{4})-(\d{2})-(\d{2})/; + push @{ $struct_graph->{ gexf }->{ graph }->{ nodes }->{ node } }, + { + id => $package->id, + label => $package->dist, + author => $package->author, + version => $package->version, + datefrom => join( '-', $year, $month, $day ), + }; + $id_nodes->{ $package->id }++; + } } say "done"; print "creating edges ... "; my $id = 0; my $edges; -if ( $type && $type eq 'author' ) { - $edges = $dbmap->resultset( 'edges' ) - ->search( { dist_from => { 'in' => [ keys %$id_nodes ] }, } ); -} else { +if ( !$type ) { $edges = $dbmap->resultset( 'edges' )->search; + while ( my $edge = $edges->next ) { + next unless exists $id_nodes->{ $edge->dist_from }; + next unless exists $id_nodes->{ $edge->dist_to }; + push @{ $struct_graph->{ gexf }->{ graph }->{ edges }->{ edge } }, + { + cardinal => 1, + source => $edge->dist_from, + target => $edge->dist_to, + type => 'dir', + id => ++$id, + }; + } } -while ( my $edge = $edges->next ) { - next unless exists $id_nodes->{ $edge->dist_from }; - next unless exists $id_nodes->{ $edge->dist_to }; - push @{ $struct_graph->{ gexf }->{ graph }->{ edges }->{ edge } }, { - cardinal => 1, - source => $edge->dist_from, - target => $edge->dist_to, - type => 'dir', - id => ++$id, - }; -} say "done"; print "generating gdf ... "; my $xml = XMLout( $struct_graph, AttrIndent => 1, - - #GroupTags => { node => 'attvalue' }, KeepRoot => 1, ); $xml > io( $output_gdf ); |