File Coverage

blib/lib/Devel/Memalyzer.pm

Criterion	Covered	Total	%
statement	82	83	98.8
branch	22	30	73.3
condition	7	8	87.5
subroutine	17	17	100.0
pod	7	10	70.0
total	135	148	91.2

package Devel::Memalyzer;
use strict;
use warnings;

use base 'Devel::Memalyzer::Base';
use Carp;
use IO qw/Handle File Pipe/;

our $VERSION = 0.001;
our $SINGLETON;

__PACKAGE__->gen_accessors(qw/ output columns headers /);

sub import {
    my $class = shift;
    return unless @_;
    $class->init( @_ );
}

sub singleton { $SINGLETON }

sub init {
    my $class = shift;
    carp( "re-initializing $class, this will destroy your old one and is probably not what you want" )
        if $SINGLETON;
    $SINGLETON = $class->new( @_ );
    return $class->singleton;
}

sub record {
    my $self = shift;
    my ( $pid ) = @_;
    my %data = (
        timestamp => time,
        (map { $_->collect( $pid ) } $self->plugins),
        $self->collect_columns( $pid ),
    );

    $self->sync_headers( \%data );

    my ( $raw ) = $self->output_handles;
    print $raw join( ',', @data{ @{ $self->headers }}) . "\n";
}

sub plugins {
    my $self = shift;
    return unless $self->{ _plugins } || $self->{ plugins };
    $self->{ _plugins } ||= [ map {
        eval "require $_; 1" || die( $@ );
        $_->new;
    } @{ $self->{ plugins }}];
    return @{ $self->{ _plugins }};
}

sub add_column {
    my $self = shift;
    my ( $name, $sub ) = @_;
    $self->columns({}) unless $self->columns();
    $self->columns->{ $name } = $sub;
}

sub del_column {
    my $self = shift;
    my ( $name ) = @_;
    my $columns = $self->columns;
    delete $columns->{ $name };
}

sub collect_columns {
    my $self = shift;
    my ( $pid ) = @_;

    my %data;
    for my $column ( keys %{ $self->columns || {}}) {
        my $sub = $self->columns->{ $column };
        $data{ $column } = $sub->( $pid );
    }
    return %data;
}

sub sync_headers {
    my $self = shift;
    my ( $data ) = @_;

    my $old = $self->headers;
    my $new = [ reverse sort keys %$data ];

    # return if headers are unchanged
    return if $old && join('', @$old) eq join('', @$new);

    $self->headers( $new );

    my ( $raw, $headers )= $self->output_handles;
    print $raw "\n" if $old;
    print $headers join(',', @$new ). "\n";
}

sub output_handles {
    my $self = shift;

    unless( $self->{ output_handles }) {
        my $file = $self->output;

        die( "Refusing to override exisiting output file: '$file'" )
            if -e $file;

        open( my $raw, '>', $self->output . ".raw" ) || die( "Error opening output file: $!" );
        open( my $headers, '>', $self->output . ".head" ) || die( "Error opening output file: $!" );
        $raw->autoflush( 1 );
        $headers->autoflush( 1 );
        $self->{ output_handles } = [ $raw, $headers ];
    }

    return @{ $self->{ output_handles }};
}

sub finish {
    my $self = shift;
    return unless $self->{ output_handles };
    my ($raw, $headers) = @{ $self->{ output_handles }};
    close( $raw ) if $raw;
    close( $headers ) if $headers;
}

sub DESTROY {
    my $self = shift;
    $self->finish;
}

1;

__END__