1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
#!env perl -w
#
# more tests for exception handling.
#
use strict;
use warnings;
use Test::More
tests => 33;
BEGIN { use_ok 'Glib'; }
package MyClass;
use Glib::Object::Subclass
Glib::Object::,
signals =>
{
first => {},
second => {},
},
;
sub first { $_[0]->signal_emit ('first'); }
sub second { $_[0]->signal_emit ('second'); }
############
package main;
# keep stderr quiet, redirect it to stdout...
$SIG{__WARN__} = sub { print $_[0]; };
my $tag = Glib->install_exception_handler (sub {
$_[0] =~ s/\n/\\n/g;
ok (1, "trapped exception '$_[0]'");
# this should be ignored, too, and should NOT create an
# infinite loop.
die "oh crap, another exception!\nthis one has multiple lines!\nappend something";
1 });
ok( $tag, 'installed exception handler' );
ok( Glib->install_exception_handler (sub {
if ($_[0] =~ /ouch/) {
ok (1, 'saw ouch, uninstalling');
return 0;
} else {
ok (0, 'additional handler still installed');
return 1;
}
}),
'installed an additional handler' );
{
my $my = new MyClass;
$my->signal_connect (first => sub {
ok (1, 'in first handler, calling second');
$_[0]->second;
ok (1, "handler may die, but we shouldn't");
});
$my->signal_connect (second => sub {
ok (!$@, "signal handlers are eval'd so \$@ should always be empty");
ok (1, "in second handler, dying with 'ouch\\n'");
die "ouch\n";
ok (0, "should NEVER get here");
});
$_ = $my;
ok (1, 'calling second');
$my->second;
ok (1, "handler may die, but we shouldn't be affected");
is ($_, $my, 'we should not clobber $_');
$_ = undef;
# expect identical behavior in eval context
eval {
ok (1, 'calling second in eval');
$my->second;
ok (1, "handler may die, but we shouldn't be affected");
};
is ($@, "", "exception should be cleared already");
# super double gonzo...
ok (1, "calling first");
$my->first;
ok (1, "after eval");
print " # calling first out of eval - should not result in crash\n";
$my->first;
# more exception trapping behavior tests
$@ = undef;
$my->second;
is ($@, undef, 'exception value should remain unchanged');
$@ = 'neener';
$my->first;
is ($@, 'neener', 'exception value should remain unchanged');
}
__END__
Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the
full list)
This library is free software; you can redistribute it and/or modify it under
the terms of the GNU Library General Public License as published by the Free
Software Foundation; either version 2.1 of the License, or (at your option) any
later version.
This library is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the GNU Library General Public License for more
details.
You should have received a copy of the GNU Library General Public License along
with this library; if not, write to the Free Software Foundation, Inc., 59
Temple Place - Suite 330, Boston, MA 02111-1307 USA.
|
