File Coverage

blib/lib/Git/Deploy/Timing.pm

Criterion	Covered	Total	%
statement	15	42	35.7
branch	0	12	0.0
condition			n/a
subroutine	5	8	62.5
pod	0	3	0.0
total	20	65	30.7

package Git::Deploy::Timing;
use strict;
use warnings FATAL => "all";
use Exporter 'import';
use Time::HiRes;

our @EXPORT = qw(
    push_timings
    should_write_timings
    write_timings
);

our (@timings, $write_timings, @real_argv);
BEGIN {
    # @timings is a set of 4-tuples: [ $tag, $time_stamp, $time_since_last_step, $time_since_start_tag ]
    @timings= (
            [
                'gdt_start',  # tagname
                $^T,                  # process start time (set by Perl at perl startup)
                -1,                   # time since last step (-1 == Not Applicable)
                -1,                   # time since start tag - only relevant on _end tags (-1 == Not Applicable)
            ]
    );
    # if this is true then we will write a timings file at process conclusion
    $write_timings= 0;
    @real_argv= @ARGV;
}

sub should_write_timings {
    $write_timings= 1;
}

sub push_timings {
    my $tag= shift;
    $tag =~ s/[^a-zA-Z0-9_]+/_/g; # strip any bogosity from the tag
    my $time= Time::HiRes::time();
    my $elapsed= -1;
    if ($tag=~/_end\z/) {
        (my $start= $tag)=~s/_end\z/_start/;
        foreach my $timing (@timings) {
            next unless $timing->[0] eq $start;
            $elapsed= $time - $timing->[1];
            last;
        }
    }
    push @timings, [ $tag, $time, $time - $timings[-1][1], $elapsed ];
}

sub write_timings {
    return unless $write_timings;
    # Do we even have to write the timing data?
    require Git::Deploy;
    return unless Git::Deploy::get_config_bool("log-timing-data",'false');
    # Where do we write it?
    my $log_directory;
    unless ( $log_directory = Git::Deploy::log_directory() ) {
        warn "Not writing timing data: 'log_directory' has not been configured.";
        return;
    }

    my $timing_file= "$log_directory/timing_gdt-$timings[0][1].txt";
    open my $fh, '>', $timing_file
        or do {
            warn "Not writing timing data: failed to open timing file '$timing_file': $!";
            return;
        };
    print $fh "# ". join("\t",$0,@real_argv),"\n";
    for my $timing (@timings) {
        print $fh join("\t",@$timing),"\n";
    }
    close $fh;
}

1;