Author: tim.bunce
Date: Wed Nov 12 09:47:21 2008
New Revision: 595
Modified:
trunk/lib/Devel/NYTProf/Util.pm
Log:
Refactor part of strip_prefix_from_paths into new make_path_strip_editor
function.
Modified: trunk/lib/Devel/NYTProf/Util.pm
==============================================================================
--- trunk/lib/Devel/NYTProf/Util.pm (original)
+++ trunk/lib/Devel/NYTProf/Util.pm Wed Nov 12 09:47:21 2008
@@ -45,6 +45,7 @@
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
@@ -84,21 +85,33 @@
return get_alternation_regex([EMAIL PROTECTED], '/?');
}
-# edit @$paths in-place to remove specified absolute path prefixes
-sub strip_prefix_from_paths {
- my ($inc_ref, $paths, $anchor, $replacement) = @_;
+
+sub make_path_strip_editor {
+ my ($inc_ref, $anchor, $replacement) = @_;
$anchor = '^' if not defined $anchor;
$replacement = '' if not defined $replacement;
my @inc = @$inc_ref
or return;
- return if not defined $paths;
my $inc_regex = get_abs_paths_alternation_regex([EMAIL PROTECTED]);
- # anchor at start, capture anchor, soak up any /'s at end
+ # anchor at start, capture anchor
$inc_regex = qr{($anchor)$inc_regex};
+ return 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) = @_;
+
+ return if not defined $paths;
+
+ 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) {
@@ -106,13 +119,13 @@
strip_prefix_from_paths($inc_ref, $path, $anchor,
$replacement);
}
elsif ($path) {
- $path =~ s{$inc_regex}{$1$replacement};
+ $editor->($path);
}
}
}
elsif (UNIVERSAL::isa($paths, 'HASH')) {
for my $orig (keys %$paths) {
- (my $new = $orig) =~ s{$inc_regex}{$1}
+ $editor->(my $new = $orig)
or next;
my $value = delete $paths->{$orig};
warn "Stripping prefix from $orig overwrites existing $new"
--~--~---------~--~----~------------~-------~--~----~
You've received this message because you are subscribed to
the Devel::NYTProf Development User group.
Group hosted at: http://groups.google.com/group/develnytprof-dev
Project hosted at: http://perl-devel-nytprof.googlecode.com
CPAN distribution: http://search.cpan.org/dist/Devel-NYTProf
To post, email: [email protected]
To unsubscribe, email: [EMAIL PROTECTED]
-~----------~----~----~----~------~----~------~--~---
