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
|
#!/usr/bin/perl -w
#
# $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/t/d.t,v 1.3 2004/05/04 22:11:24 muppetman Exp $
#
#
# Glib::Error
#
use strict;
use Test::More tests => 36;
use Glib;
# this is obviously invalid and should result in an exception.
eval { Glib::filename_from_uri 'foo://bar'; };
ok ($@, "\$@ is defined");
isa_ok ($@, "Glib::Error", "it's a Glib exception object");
isa_ok ($@, "Glib::Convert::Error", "specifically, it's a conversion error");
is ($@->code, 4, "numeric code");
is ($@->value, 'bad-uri', "code's nickname");
is ($@->domain, 'g_convert_error', 'error domain (implies class)');
ok ($@->message, "should have an error message, may be translated");
ok ($@->location, "should have an error location, may be translated");
is ($@, $@->message.$@->location, "stringification operator is overloaded");
#
# create a new exception class...
#
Glib::Type->register_enum ('Test::ErrorCode',
qw(frobbed fragged fubar b0rked help-me-please));
Glib::Error::register ('Test::Error', 'Test::ErrorCode');
is_deeply (\@Test::Error::ISA, ['Glib::Error'], 'register sets up ISA');
#
# create a new instance, something we can pass to croak.
#
my $error = Test::Error->new ('fubar', "I'm fscked up beyond repair");
ok ($error, '$error should be defined');
isa_ok ($error, 'Glib::Error', "it's an exception object");
isa_ok ($error, 'Test::Error', "it's one our new exception objects");
is ($error->code, 3, 'numeric code');
is ($error->value, 'fubar', "code's nickname");
is ($error->domain, 'test-error', "domain should be mangled from package");
is ($error->message, "I'm fscked up beyond repair", "message should be unaltered");
ok ($error->location, 'should have error location');
is ($error, $error->message.$error->location, "stringification operator is overloaded");
#
# now try to throw one of those with the Glib::Error syntax.
#
eval { Test::Error->throw ('fragged', "Here is a message"); };
ok ($@, '$@ should be defined');
isa_ok ($@, 'Glib::Error', "it's an exception object");
isa_ok ($@, 'Test::Error', "it's one our new exception objects");
is ($@->code, 2, 'numeric code');
is ($@->value, 'fragged', "code's nickname");
is ($@->domain, 'test-error', "domain should be mangled from package");
is ($@->message, "Here is a message", "message should be unaltered");
ok ($@->location, 'should have error location');
is ($@, $@->message.$@->location, "stringification operator is overloaded");
# various good tests for the matches function
ok (Glib::Error::matches ($@, 'Test::Error', 'fragged'), "is");
ok (!Glib::Error::matches (undef, 'Test::Error', 'fragged'), "isn't");
ok (!Glib::Error::matches ($@, 'Test::Error', 'b0rked'), "isn't");
ok (!Glib::Error::matches ($@, 'Glib::File::Error', 'noent'), "isn't");
ok (Glib::Error::matches ($@, 'test-error', 2), "is");
my $raw = {
domain => 'test-error',
code => 2,
message => 'dummy',
};
ok (Glib::Error::matches ($raw, 'Test::Error', 'fragged'), "unblessed hash");
ok (Glib::Error::matches (bless ($raw, 'Glib::Error'),
'Test::Error', 'fragged'),
"from Glib::Error, but with domain");
ok (!Glib::Error::matches (bless ($raw, 'Glib::Error'),
'Glib::File::Error', 'isdir'),
"from Glib::Error, but with domain");
__END__
Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the
full list). See LICENSE for more information.
|
