path: root/gen-gdf.pl

#!/usr/bin/perl -w
use strict;
use feature ':5.10';
use Getopt::Long;
use XML::Simple;
use YAML::Syck;
use IO::All;
use DateTime;

use lib ( 'lib' );
use CPAN::mapcpan;

my $options = GetOptions(
    'out=s'   => \my $output_gdf,
    'dbmap=s' => \my $db_map,
    'type=s'  => \my $type,
    'list=s'  => \my $list,
);

print "preparing gexf ... ";
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    => 'static' }; 
# static si pas de dates
$struct_graph->{ gexf }->{ graph }->{ attributes } = {
    class => 'node',
    type  => 'static',
};
push @{ $struct_graph->{ gexf }->{ graph }->{ attributes }->{ attribute } },
    {
    id    => 0,
    #title => 'dist',
    type  => 'string',
    };
say "done";

print "creating nodes ... ";
$struct_graph->{ gexf }->{ graph }->{ nodes } = {};

my ($search, $packages, $id_nodes);
if ( $type && $type eq 'author' ) {
    if ( $list ) {
        my $author < io $list;
        my @author_list = split /\n/, $author;
        $search = {
            -and => [
                author   => { 'in', \@author_list },
                released => { '>',  '1970-01-01' }
            ]
        };
    } 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 ) {
    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 ) {
    $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,
            };
    }
}

say "done";

print "generating gdf ... ";
my $xml = XMLout(
    $struct_graph,
    AttrIndent => 1,
    KeepRoot => 1,
);
$xml > io( $output_gdf );
say "done";