view release on metacpan or  search on metacpan

lib/Module/Dependency/Grapher.pm  view on Meta::CPAN

    my ( $maxitems, $pushed ) =
        _makeCols( $kind, $seeds, $options->{IncludeRegex}, $options->{ExcludeRegex} );
    _imageDimsSet();

    LOG("Making SVG to $filename");

    if ( $maxitems < 8 ) {
        $rowHeight = 8 * $rowHeight * 1.5 / $maxitems;
    }
    elsif ( $maxitems < 16 ) {
        $rowHeight = 16 * $rowHeight / $maxitems;
    }

    my $imgWidth  = $colWidth * ( scalar(@TIERS) < 3 ? 3 : scalar(@TIERS) );
    my $imgHeight = $rowHeight * $maxitems;

    my $realImgWidth  = $imgWidth + $wOffset + $eOffset;
    my $realImgHeight = $imgHeight + $nOffset + $sOffset;
    LOG("Rows are $rowHeight px, maxitems is $maxitems, image is $realImgWidth * $realImgWidth");

    my $im = new SVG(
        'viewBox' => (
                  '0 0 '
                . ( $imgWidth + $wOffset + $eOffset ) . ' '
                . ( $imgHeight + $nOffset + $sOffset )
        ),
        'preserveAspectRatio' => 'xMidYMid',
        '-indent'             => "\t"
    );

    # set up image object
    my $colours;
    while ( my ( $k, $v ) = each %COLOURS ) {
        $colours->{$k} = sprintf( '#%2.2x%2.2x%2.2x', @$v );
    }

    $im->rectangle(
        'x'      => 0,
        'y'      => 0,
        'width'  => ( $imgWidth + $wOffset + $eOffset ),
        'height' => ( $imgHeight + $nOffset + $sOffset ),
        stroke   => $colours->{'black'},
        fill     => 'none'
    );
    _packObjects( $imgHeight, 5 );
    _linkObjects( $im, $colours );

    # are things clickable? Bit of a kludge, this
    $colours->{'_HREF_FORMAT'} = $options->{'HrefFormat'};
    _labelObjects( $im, $colours );
    delete $colours->{'_HREF_FORMAT'};

    # add legend and prettiness
    TRACE("Drawing legend etc");

    $im->text(
        'x'     => 5,
        'y'     => 12,
        'fill'  => $colours->{'title1'},
        'style' => { 'font-size' => '12px' }
    )->cdata($imgtitle);
    $im->text(
        'x'     => 5,
        'y'     => 23,
        'fill'  => $colours->{'title1'},
        'style' => { 'font-size' => '9px' }
        )->cdata( "Grapher.pm $VERSION - " . localtime() )
        unless $options->{'NoVersion'};
    _drawLegend( $im, $colours, $realImgWidth - 160 - $eOffset, 3 ) unless $options->{'NoLegend'};

    $im->title( id => 'document-title' )->cdata($imgtitle);
    $im->desc( id => 'document-desc' )
        ->cdata('This image shows dependency relationships between perl programs and modules');

    TRACE("Printing SVG");
    local *IMG;
    open( IMG, "> $filename" ) or die("Can't open $filename for image write: $!");
    print IMG $im->xmlify;
    close IMG;
}

sub makePs {
    require PostScript::Simple;

    my ( $kind, $seeds, $filename, $options ) = @_;
    my $imgtitle = $options->{'Title'} || 'Dependency Chart';
    my $eps = ( uc( $options->{'Format'} ) eq 'PS' ) ? 0 : 1;
    my $colour = exists( $options->{'Colour'} ) ? $options->{'Colour'} : 1;
    my $font = $options->{'Font'} || 'Helvetica';

    my ( $maxitems, $pushed ) =
        _makeCols( $kind, $seeds, $options->{IncludeRegex}, $options->{ExcludeRegex} );
    _psDimsSet();

    LOG("Making postscript to $filename");

    if ( $maxitems < 8 ) {
        $rowHeight = 8 * $rowHeight * 1.5 / $maxitems;
    }
    elsif ( $maxitems < 16 ) {
        $rowHeight = 16 * $rowHeight / $maxitems;
    }

    my $imgWidth  = $colWidth * ( scalar(@TIERS) < 3 ? 3 : scalar(@TIERS) );
    my $imgHeight = $rowHeight * $maxitems;

    my $realImgWidth  = $imgWidth + $wOffset + $eOffset;
    my $realImgHeight = $imgHeight + $nOffset + $sOffset;
    LOG("Rows are $rowHeight px, maxitems is $maxitems, image is $realImgWidth * $realImgWidth");

    my $p = new PostScript::Simple(
        eps       => $eps,
        colour    => $colour,
        clip      => 1,
        landscape => ( !$eps ),
        xsize     => $realImgWidth,
        ysize     => $realImgHeight,
        units     => 'bp'
        )    # we use points because they're close to pixels, as used in GD
        || die("Can't build Postscript object: $!");
    $p->setlinewidth(0.5);
    $p->setfont( $font, 9 );

    _packObjects( $imgHeight, 5.5 );
    _linkObjects($p);
    $p->setcolour( @{ $COLOURS{'type'} } );
    _labelObjects($p);

    # add legend and prettiness
    TRACE("Drawing legend etc");
    _drawPsLegend( $p, $realImgWidth - 160 - $eOffset, 16 ) unless $options->{'NoLegend'};

    $p->setfont( $font, 16 );

lib/Module/Dependency/Grapher.pm  view on Meta::CPAN

    $x += 4;
    $y += 3;

    _drawText( $im, $colours, $x, $y, 'Legend' );
    if ( $type =~ m/^GD/ ) {
        $im->line( $x, $y + 8, $x + 30, $y + 8, $colours->{'type'} );
    }
    elsif ( $type =~ m/SVG/ ) {
        $im->line(
            x1     => $x,
            y1     => $y + 8,
            x2     => $x + 30,
            y2     => $y + 8,
            stroke => $colours->{'type'}
        );
    }
    $y += 12;
    _drawLink( $im, $colours, $x + 31, $y, 100 + $x, $y );
    _drawText( $im, $colours, $x, $y, 'Foo.pl' );
    _drawText( $im, $colours, 100 + $x, $y, 'Bar' );
    $y += 12;
    _drawText( $im, $colours, $x, $y, 'Foo.pl depends upon Bar.pm' );
}

sub _drawPsLegend {
    my ( $p, $x, $y ) = @_;

    _drawText( $p, undef, $x + 2, $y + 26, 'Legend' );
    $p->setlinewidth(0.4);
    $p->line( $x + 2, $y + 25, $x + 32, $y + 25 );
    _drawText( $p, undef, $x + 2,   $y + 14, 'Foo.pl' );
    _drawText( $p, undef, $x + 102, $y + 14, 'Bar' );
    _drawText( $p, undef, $x + 2,   $y + 2,  'Foo.pl depends upon Bar.pm' );
    _drawLink( $p, undef, $x + 29, $y + 14, $x + 102, $y + 14 );

    $p->setlinewidth(0.25);
    $p->setcolour( @{ $COLOURS{'black'} } );
    $p->box( $x, $y - 1, $x + 120, $y + 34 );
}

# ! behaves differently for each image type
sub _drawText {
    my ( $im, $colours, $x, $y, $text ) = @_;
    my $type = ref($im);

    #	TRACE("_drawText for $type");

    if ( $type =~ m/^GD/ ) {
        $im->string( gdTinyFont(), $x, $y, $text, $colours->{'type'} );
    }
    elsif ( $type =~ m/^PostScript/ ) {
        $im->text( $x, $y, $text );
    }
    elsif ( $type =~ m/^SVG/ ) {
        if ( $colours->{'_HREF_FORMAT'} ) {
            $im->anchor( -href => sprintf( $colours->{'_HREF_FORMAT'}, $text ) )->text(
                'x'     => $x,
                'y'     => $y + 5.5,
                'fill'  => $colours->{'type'},
                'style' => { 'font-size' => '8px', 'font-family' => 'Courier, Monaco, monospaced' }
            )->cdata($text);
        }
        else {
            $im->text(
                'x'     => $x,
                'y'     => $y + 5.5,
                'fill'  => $colours->{'type'},
                'style' => { 'font-size' => '8px', 'font-family' => 'Courier, Monaco, monospaced' }
            )->cdata($text);
        }
    }
}

# ! behaves differently for each image type
sub _drawLink {
    my ( $im, $colours, $xa, $ya, $xb, $yb ) = @_;
    my $type = ref($im);

    #	TRACE("_drawLink for $type");

    if ( $type =~ m/^GD/ ) {
        $im->line( $xa, $ya + 3, $xb - 3, $yb + 3, $colours->{'links'} );
        $im->rectangle( $xa, $ya + 2, $xa + 1, $ya + 4, $colours->{'blob_from'} );
        $im->rectangle( $xb - 3, $yb + 2, $xb - 4, $yb + 4, $colours->{'blob_to'} );
    }
    elsif ( $type =~ m/^PostScript/ ) {
        $im->setlinewidth(0.22);
        $im->line( $xa, $ya + 3, $xb - 3, $yb + 3, @{ $COLOURS{'black'} } );
        $im->setcolour( @{ $COLOURS{'white'} } );
        $im->circle( $xb - 3, $yb + 3, 1, 1 );
        $im->setcolour( @{ $COLOURS{'black'} } );
        $im->circle( $xa, $ya + 3, 1, 1 );
        $im->circle( $xb - 3, $yb + 3, 1, 0 );
    }
    elsif ( $type =~ m/^SVG/ ) {
        $im->line(
            x1     => $xa,
            y1     => $ya + 3,
            x2     => $xb - 3,
            y2     => $yb + 3,
            stroke => $colours->{'links'}
        );
        $im->rectangle(
            'x'      => $xa,
            'y'      => $ya + 2,
            'width'  => 2,
            'height' => 2,
            stroke   => 'none',
            fill     => $colours->{'blob_from'}
        );
        $im->rectangle(
            'x'      => $xb - 4,
            'y'      => $yb + 2,
            'width'  => 2,
            'height' => 2,
            stroke   => 'none',
            fill     => $colours->{'blob_to'}
        );
    }
    else {
        die 'This indicates that the object model has changed somewhere. Should not happen.';
    }
}

sub _imageDimsSet {
    $colWidth  = 200;
    $rowHeight = 12;

    $nOffset = 40;