我们正在慢慢地将我们的大型Perl应用程序重构为面向对象的接口,特别是对于数据模型.令人讨厌的部分是堆栈跟踪变得不那么有用.举一个捏造的例子:之前.
- sub send_message {
- my ($user_id,$message) = @_;
- ...
- Carp::confess('test');
- }
- # output:
- test at example.pm line 23
- foo('42','Hello World') called at example.pl line 5
后.
- sub send_message {
- my ($user,$message) = @_;
- ...
- Carp::confess('test');
- }
- # output:
- test at example.pm line 23
- foo('MyApp::Model::User=HASH(0x2c94f68)','Hello World') called at example.pl line 5
所以现在我看不到哪个用户传递给foo(),我只看到类名(已经记录)和一个对象的内存地址.
我尝试使用overload.pm在模型类上安装stringification运算符:
- use overload ( '""' => \&stringify );
- sub stringify {
- my ($self) = @_;
- return sprintf '%s[id=%d]',ref($self),$self->id;
- }
但这并不影响长篇大论.我想要的是这样的:
- test at example.pm line 23
- foo('MyApp::Model::User[id=42]','Hello World') called at example.pl line 5
解决方法
问题出现在
Carp.pm
的这一部分:
- sub format_arg {
- my $arg = shift;
- if ( ref($arg) ) {
- $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
- }
- ...
- }
也就是说,当一个参数可能是一个重载对象时,任何字符串化重载都会被StrVal
helper规避,这会强制默认字符串化.
不幸的是,没有直截了当的方法.我们所能做的只是修补Carp :: format_arg sub,例如,
- BEGIN {
- use overload ();
- use Carp ();
- no warnings 'redefine';
- my $orig = \&Carp::format_arg;
- *Carp::format_arg = sub {
- my ($arg) = @_;
- if (ref $arg and my $stringify = overload::Method($arg,'""')) {
- $_[0] = $stringify->($arg);
- }
- goto &$orig;
- };
- }
事实上,这是不优雅的,应该被用于实用主义:
File Carp / string_overloading.pm:
- package Carp::string_overloading;
- use strict; use warnings;
- use overload ();
- use Carp ();
- # remember the original format_arg method
- my $orig = \&Carp::format_arg;
- # This package is internal to Perl's warning system.
- $Carp::CarpInternal{ __PACKAGE__() }++;
- {
- no warnings 'redefine';
- *Carp::format_arg = sub {
- my ($arg) = @_;
- if ( ref($arg)
- and in_effect(1 + Carp::long_error_loc)
- and my $stringify = overload::Method($arg,'""')
- ) {
- $_[0] = $stringify->($arg);
- }
- goto &$orig;
- };
- }
- sub import { $^H{__PACKAGE__ . "/in_effect"} = 1 }
- sub unimport { $^H{__PACKAGE__ . "/in_effect"} = 0 }
- sub in_effect {
- my $level = shift // 1;
- return (caller $level)[10]{__PACKAGE__ . "/in_effect"};
- }
- 1;
然后是代码
- use strict; use warnings;
- package Foo {
- use Carp ();
- use overload '""' => sub {
- my $self = shift;
- return sprintf '%s[%s]',ref $self,join ",",@$self;
- };
- use Carp::string_overloading;
- sub foo { Carp::confess "as requested" }
- no Carp::string_overloading;
- sub bar { Carp::confess "as requested" }
- }
- my $foo = bless [1..3] => 'Foo';
- eval { $foo->foo("foo") };
- print $@;
- eval { $foo->bar("bar") };
- print $@;
输出:
- as requested at test.pl line 12.
- Foo::foo('Foo[1,2,3]','foo') called at test.pl line 20
- eval {...} called at test.pl line 20
- as requested at test.pl line 15.
- Foo::bar('Foo=ARRAY(0x85468ec)','bar') called at test.pl line 22
- eval {...} called at test.pl line 22