summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJesse Luehrs <doy@tozt.net>2010-04-30 20:06:11 -0500
committerJesse Luehrs <doy@tozt.net>2010-04-30 20:09:40 -0500
commitddd601047a76fb519d4acba4c59d77ebfde1fa6e (patch)
tree2a5840e61ce7a6868d522015ddc74c0f938d9be5
parentce489a3dcdcd8dcc1dec85b92698e0b94c85ca38 (diff)
downloadcarp-always-color-ddd601047a76fb519d4acba4c59d77ebfde1fa6e.tar.gz
carp-always-color-ddd601047a76fb519d4acba4c59d77ebfde1fa6e.zip
only color the actual warning/error
also clean up a couple more edge cases
-rw-r--r--lib/Carp/Always/Color/HTML.pm11
-rw-r--r--lib/Carp/Always/Color/Term.pm11
-rw-r--r--t/001-term.t8
-rw-r--r--t/002-html.t8
-rw-r--r--t/003-detect.t4
-rw-r--r--t/004-eval.t40
-rw-r--r--t/005-object.t10
7 files changed, 72 insertions, 20 deletions
diff --git a/lib/Carp/Always/Color/HTML.pm b/lib/Carp/Always/Color/HTML.pm
index 53b3f4e..e0cb599 100644
--- a/lib/Carp/Always/Color/HTML.pm
+++ b/lib/Carp/Always/Color/HTML.pm
@@ -23,20 +23,21 @@ STDERR is pointing to.
BEGIN { $Carp::Internal{(__PACKAGE__)}++ }
sub _die {
+ die @_ if ref($_[0]);
eval { Carp::Always::_die(@_) };
my $err = $@;
- $err =~ s/(.*)/<span style="color:#800">$1<\/span>/;
+ $err =~ s/(.*)( at .*? line .*?$)/<span style="color:#800">$1<\/span>$2/m;
die $err;
}
sub _warn {
- my $warning;
+ my @warning;
{
- local $SIG{__WARN__} = sub { $warning = $_[0] };
+ local $SIG{__WARN__} = sub { @warning = @_ };
Carp::Always::_warn(@_);
}
- $warning =~ s/(.*)/<span style="color:#880">$1<\/span>/;
- warn $warning;
+ $warning[0] =~ s/(.*)( at .*? line .*?$)/<span style="color:#880">$1<\/span>$2/m;
+ warn @warning;
}
my %OLD_SIG;
diff --git a/lib/Carp/Always/Color/Term.pm b/lib/Carp/Always/Color/Term.pm
index c4789f6..579eb5c 100644
--- a/lib/Carp/Always/Color/Term.pm
+++ b/lib/Carp/Always/Color/Term.pm
@@ -23,20 +23,21 @@ of where STDERR is pointing to.
BEGIN { $Carp::Internal{(__PACKAGE__)}++ }
sub _die {
+ die @_ if ref($_[0]);
eval { Carp::Always::_die(@_) };
my $err = $@;
- $err =~ s/(.*)/\e[31m$1\e[m/;
+ $err =~ s/(.*)( at .*? line .*?$)/\e[31m$1\e[m$2/m;
die $err;
}
sub _warn {
- my $warning;
+ my @warning;
{
- local $SIG{__WARN__} = sub { $warning = $_[0] };
+ local $SIG{__WARN__} = sub { @warning = @_ };
Carp::Always::_warn(@_);
}
- $warning =~ s/(.*)/\e[33m$1\e[m/;
- warn $warning;
+ $warning[0] =~ s/(.*)( at .*? line .*?$)/\e[33m$1\e[m$2/m;
+ warn @warning;
}
my %OLD_SIG;
diff --git a/t/001-term.t b/t/001-term.t
index 07c2751..7c1977d 100644
--- a/t/001-term.t
+++ b/t/001-term.t
@@ -20,7 +20,7 @@ output_is(<<EOF,
use Carp::Always::Color::Term;
warn "foo";
EOF
- "\e[33mfoo at -e line 2\e[m\n",
+ "\e[33mfoo\e[m at -e line 2\n",
"simple warns work");
output_is(<<EOF,
@@ -30,14 +30,14 @@ output_is(<<EOF,
}
foo();
EOF
- "\e[33mfoo at -e line 3\e[m\n\tmain::foo() called at -e line 5\n",
+ "\e[33mfoo\e[m at -e line 3\n\tmain::foo() called at -e line 5\n",
"warns with a stacktrace work");
output_is(<<EOF,
use Carp::Always::Color::Term;
die "foo";
EOF
- "\e[31mfoo at -e line 2\e[m\n",
+ "\e[31mfoo\e[m at -e line 2\n",
"simple dies work");
output_is(<<EOF,
@@ -47,5 +47,5 @@ output_is(<<EOF,
}
foo();
EOF
- "\e[31mfoo at -e line 3\e[m\n\tmain::foo() called at -e line 5\n",
+ "\e[31mfoo\e[m at -e line 3\n\tmain::foo() called at -e line 5\n",
"dies with a stacktrace work");
diff --git a/t/002-html.t b/t/002-html.t
index 86be6a9..f51914d 100644
--- a/t/002-html.t
+++ b/t/002-html.t
@@ -20,7 +20,7 @@ output_is(<<EOF,
use Carp::Always::Color::HTML;
warn "foo";
EOF
- "<span style=\"color:#880\">foo at -e line 2</span>\n",
+ "<span style=\"color:#880\">foo</span> at -e line 2\n",
"simple warns work");
output_is(<<EOF,
@@ -30,14 +30,14 @@ output_is(<<EOF,
}
foo();
EOF
- "<span style=\"color:#880\">foo at -e line 3</span>\n\tmain::foo() called at -e line 5\n",
+ "<span style=\"color:#880\">foo</span> at -e line 3\n\tmain::foo() called at -e line 5\n",
"warns with a stacktrace work");
output_is(<<EOF,
use Carp::Always::Color::HTML;
die "foo";
EOF
- "<span style=\"color:#800\">foo at -e line 2</span>\n",
+ "<span style=\"color:#800\">foo</span> at -e line 2\n",
"simple dies work");
output_is(<<EOF,
@@ -47,5 +47,5 @@ output_is(<<EOF,
}
foo();
EOF
- "<span style=\"color:#800\">foo at -e line 3</span>\n\tmain::foo() called at -e line 5\n",
+ "<span style=\"color:#800\">foo</span> at -e line 3\n\tmain::foo() called at -e line 5\n",
"dies with a stacktrace work");
diff --git a/t/003-detect.t b/t/003-detect.t
index aadcf88..6c4f7d3 100644
--- a/t/003-detect.t
+++ b/t/003-detect.t
@@ -20,7 +20,7 @@ output_is(<<EOF,
use Carp::Always::Color;
warn "foo";
EOF
- "\e[33mfoo at -e line 2\e[m\n",
+ "\e[33mfoo\e[m at -e line 2\n",
"detection works for terminal output");
output_is(<<EOF,
@@ -33,5 +33,5 @@ output_is(<<EOF,
warn "foo";
print \$stderr;
EOF
- "<span style=\"color:#880\">foo at -e line 7</span>\n",
+ "<span style=\"color:#880\">foo</span> at -e line 7\n",
"detection works for terminal output");
diff --git a/t/004-eval.t b/t/004-eval.t
new file mode 100644
index 0000000..3500dc0
--- /dev/null
+++ b/t/004-eval.t
@@ -0,0 +1,40 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+BEGIN {
+ eval "use IO::Pty::Easy;";
+ plan skip_all => "IO::Pty::Easy is required for this test" if $@;
+ plan tests => 2;
+}
+
+sub output_is {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($script, $expected, $desc) = @_;
+ my $pty = IO::Pty::Easy->new;
+ $pty->spawn("$^X", "-e", $script);
+ is($pty->read, $expected, $desc);
+}
+
+output_is(<<EOF,
+ use Carp::Always::Color;
+ eval { die "foo" };
+ if (\$@) {
+ die \$@;
+ }
+EOF
+ "\e[31m\e[31mfoo\e[m\e[m at -e line 4\n",
+ "rethrowing works");
+
+output_is(<<EOF,
+ use Carp::Always::Color;
+ sub foo {
+ eval { die "foo" };
+ if (\$@) {
+ die \$@;
+ }
+ }
+ foo();
+EOF
+ "\e[31m\e[31mfoo\e[m\e[m at -e line 5\n\tmain::foo() called at -e line 8\n",
+ "rethrowing works inside functions");
diff --git a/t/005-object.t b/t/005-object.t
new file mode 100644
index 0000000..3a88dd3
--- /dev/null
+++ b/t/005-object.t
@@ -0,0 +1,10 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+use Carp::Always::Color;
+
+my $err = bless({}, 'My::Error::Class');
+eval { die $err };
+is($@, $err, "exception objects aren't affected");