File Coverage

blib/lib/Devel/NYTProf/Util.pm

Criterion	Covered	Total	%
statement	112	115	97.3
branch	55	68	80.8
condition	8	11	72.7
subroutine	18	18	100.0
pod	0	9	0.0
total	193	221	87.3

# vim: ts=8 sw=4 expandtab:
##########################################################
# This script is part of the Devel::NYTProf distribution
#
# Copyright, contact and other information can be found
# at the bottom of this file, or by going to:
# http://metacpan.org/release/Devel-NYTProf/
#
###########################################################
package Devel::NYTProf::Util;

=head1 NAME

Devel::NYTProf::Util - general utility functions for L

=head1 SYNOPSIS

  use Devel::NYTProf::Util qw(strip_prefix_from_paths);

=head1 DESCRIPTION

Contains general utility functions for L

B The documentation for this module is currently incomplete and out of date.

=head1 FUNCTIONS

=encoding ISO8859-1

=cut


use warnings;
use strict;

use base qw'Exporter';

use Carp;
use Cwd qw(getcwd);
use List::Util qw(sum);
use Devel::NYTProf::Core;

our $VERSION = '6.13_003';

our @EXPORT_OK = qw(
    fmt_float
    fmt_time
    fmt_incl_excl_time
    make_path_strip_editor
    strip_prefix_from_paths
    calculate_median_absolute_deviation
    get_alternation_regex
    get_abs_paths_alternation_regex
    html_safe_filename
    trace_level
    _dumper
);


sub get_alternation_regex {
    my ($strings, $suffix_regex) = @_;
    $suffix_regex = '' unless defined $suffix_regex;

    # sort longest string first
    my @strings = sort { length $b <=> length $a } @$strings;

    # build string regex for each string
    my $regex = join "|", map { quotemeta($_) . $suffix_regex } @strings;

    return qr/(?:$regex)/;
}


sub get_abs_paths_alternation_regex {
    my ($inc, $cwd) = @_;
    my @inc = @$inc or croak "No paths";

    # rewrite relative directories to be absolute
    # the logic here should match that in get_file_id()
    my $abs_path_regex = ($^O eq "MSWin32") ? qr,^\w:/, : qr,^/,;
    for (@inc) {
        next if $_ =~ $abs_path_regex;    # already absolute
        $_ =~ s/^\.\///;   # remove a leading './'
        $cwd ||= getcwd();
        $_ = ($_ eq '.') ? $cwd : "$cwd/$_";
    }

    return get_alternation_regex(\@inc, '/?');
}


sub make_path_strip_editor {
    my ($inc_ref, $anchor, $replacement) = @_;
    $anchor      = '^' if not defined $anchor;
    $replacement = ''  if not defined $replacement;

    my @inc = @$inc_ref;

    our %make_path_strip_editor_cache;
    my $key = join "\t", $anchor, $replacement, @inc;

    return $make_path_strip_editor_cache{$key} ||= do {

        my $inc_regex = get_abs_paths_alternation_regex(\@inc);

        # anchor at start, capture anchor
        $inc_regex = qr{($anchor)$inc_regex};

        sub { $_[0] =~ s{$inc_regex}{$1$replacement} };
    };
}


# edit @$paths in-place to remove specified absolute path prefixes
sub strip_prefix_from_paths {
    my ($inc_ref, $paths, $anchor, $replacement) = @_;

    croak "strip_prefix_from_paths() first argument must be array ref"
        unless ref($inc_ref) eq 'ARRAY';
    return unless @{$inc_ref};

    return if not defined $paths;
    croak "strip_prefix_from_paths() second argument must be array ref"
        unless ref($paths) eq 'ARRAY';

    my $editor = make_path_strip_editor($inc_ref, $anchor, $replacement)
        or return;

    # strip off prefix using regex, skip any empty/undef paths
    if (UNIVERSAL::isa($paths, 'ARRAY')) {
        for my $path (@$paths) {
            if (ref $path) {    # recurse to process deeper data
                strip_prefix_from_paths($inc_ref, $path, $anchor, $replacement);
            }
            elsif ($path) {
                $editor->($path);
            }
        }
    }
    # There are no instances in test suite where $paths is a hash ref
#    elsif (UNIVERSAL::isa($paths, 'HASH')) {
#        for my $orig (keys %$paths) {
#            $editor->(my $new = $orig)
#                or next;
#            my $value = delete $paths->{$orig};
#            warn "Stripping prefix from $orig overwrites existing $new"
#                if defined $paths->{$new};
#            $paths->{$new} = $value;
#        }
#    }
    else {
        croak "Can't strip_prefix_from_paths of $paths";
    }

    return;
}


# eg normalize the width/precision so that the tables look good.
sub fmt_float {
    my ($val, $precision) = @_;
    $precision ||= 5;
    if ($val < 10 ** -($precision - 1) and $val > 0) {
        # Give the same width as a larger value formatted with the %f below.
        # This gives us 2 digits of precision for $precision == 5
        $val = sprintf("%." . ($precision - 4) . "e", $val);
        # But our exponents will always be e-05 to e-09, never e-10 or smaller
        # so remove the leading zero to make these small numbers stand out less
        # on the table.
        $val =~ s/e-0+/e-/;
    }
    elsif ($val != int($val)) {
        $val = sprintf("%.${precision}f", $val);
    }
    return $val;
}


# XXX undocumented hack that may become to an option one day
# Useful for making the time data more easily parseable
my $fmt_time_opt = $ENV{NYTPROF_FMT_TIME}; # e.g., '%f' for 'raw' times

sub fmt_time {
    my ($sec, $width) = @_;
    $width = '' unless defined $width;
    return undef if not defined $sec;
    return '-'.fmt_time(-$sec, $width) if $sec < 0; # negative value, can happen
    return sprintf $fmt_time_opt, $sec if $fmt_time_opt;
    return sprintf "%$width.0fs", 0    unless $sec;
    return sprintf "%$width.0fns",                              $sec * 1e9 if $sec < 1e-6;
    return sprintf "%$width.0fµs",                              $sec * 1e6 if $sec < 1e-3;
    return sprintf "%$width.*fms", 3 - length(int($sec * 1e3)), $sec * 1e3 if $sec < 1;
    return sprintf "%$width.*fs",  3 - length(int($sec      )), $sec       if $sec < 100;
    return sprintf "%$width.0fs", $sec;
}


sub fmt_incl_excl_time {
    my ($incl, $excl) = @_;
    my $diff = $incl - $excl;
    return fmt_time($incl) unless $diff;
    $_ = fmt_time($_) for $incl, $excl, $diff;
    if ($incl =~ /(\D+)$/) {
	# no need to repeat the unit if it's the same for all time stamps
	my $unit = $1;
	my $offset = -length($unit);
	for ($excl, $diff) {
	    if (/(\D+)$/) {
		substr($_, $offset) = "" if $1 eq $unit
	    }
	}
    }
    return sprintf "%s (%s+%s)", $incl, $excl, $diff;
}


## Given a ref to an array of numeric values
## returns median distance from the median value, and the median value.
## See http://en.wikipedia.org/wiki/Median_absolute_deviation
sub calculate_median_absolute_deviation {
    my $values_ref = shift;
    my ($ignore_zeros) = @_;
    croak "No array ref given" unless ref $values_ref eq 'ARRAY';

    my @values = ($ignore_zeros) ? grep {$_} @$values_ref : @$values_ref;
    my $median_value = [sort { $a <=> $b } @values]->[@values / 2];

    return [0, 0] if not defined $median_value;    # no data

    my @devi = map { abs($_ - $median_value) } @values;
    my $median_devi = [sort { $a <=> $b } @devi]->[@devi / 2];

    return [$median_devi, $median_value];
}


sub html_safe_filename {
    my ($fname) = @_;
    # replace / and \ with html safe '-', we also do a bunch of other
    # chars, especially ':' for Windows, to make the namer simpler and safer
    # also remove dots to keep VMS happy
    $fname =~ s{  [-/\\:\*\?"'<>|.]+ }{-}xg;
    # remove any leading or trailing '-' chars
    $fname =~ s{^-}{};
    $fname =~ s{-$}{};
    if($^O eq 'VMS'){
        # ODS-2 is limited to 39.39 chars (39 filename, 39 extension)
	# Reader.pm appends -LEVEL onto html safe filename so must
	# subtract 1 + max length of (sub block line), so 6.
        $fname = substr($fname,-33);
    }
    return $fname;
}

sub _dumper {
    require Data::Dumper;
    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Indent = 1;
    return Data::Dumper::Dumper(@_);
}

1;

__END__