manakai/t/util-error.t

#!/usr/bin/perl
use strict;
use Message::Util::Error;
use Test;
plan tests => 25;

try {
  throw Message::Util::Error -type => 'SOMETHING_UNKNOWN';
} catch Message::Util::Error with {
  my $err = shift;
  warn $err->stringify if $^W;
  ok $err->text, qq("SOMETHING_UNKNOWN": Unknown error);
} except {
  ok 1, 0;
} otherwise {
  ok 1, 0;
} finally {
  ok 1, 1;
};
ok 1, 1;

try {
  throw test_error -type => 'ERR1', param1 => 'VAL1', param2 => 'VAL2';
} catch test_error with {
  my $err = shift;
  ok $err->text, qq(Param1 "VAL1"; Param2 "VAL2");
};

try {
  throw test_error -type => 'error_with_code';
} catch test_error with {
  my $err = shift;
  ok $err->code, 128, "error_with_code->code";
  ok $err->value, 128, "error_with_code->value";
  ok 0+$err->value, 128, "0+error_with_code";
  ok $err->text, "error", "error_with_code->text";
  ok $err->type, "error_with_code", "error_with_code->type";
  ok $err->subtype, undef, "error_with_code->subtype";
  ok $err->type_def->{-description}, "error", "error_with_code->type_def";
};

try {
  throw test_error -type => 'error_with_code', -subtype => 'suberror';
} catch test_error with {
  my $err = shift;
  ok $err->code, 128, "error_with_code->code";
  ok $err->value, 128, "error_with_code->value";
  ok 0+$err->value, 128, "0+error_with_code";
  ok $err->text, "suberror", "error_with_code->text";
  ok $err->type, "error_with_code", "error_with_code->type";
  ok $err->subtype, "suberror", "error_with_code->subtype";
  ok $err->type_def->{-description}, "error", "error_with_code->type_def";
};

package test_error;
BEGIN {
our @ISA = 'Message::Util::Error';
}
sub ___error_def () {+{
  ERR1 => {
    -description => q(Param1 "%t(name=>param1);"; Param2 "%t(name=>param2);"),
  },
  fatal => {
    -description => q(fatal error),
  },
  warn => {
    -description => q(warn msg),
  },
  error_with_code => {
    -code => 128,
    -description => q(error),
    -subtype => {
      suberror => {
        -description => q(suberror),
        -code => 100,
      },
    },
  },
}}

package test_report;
BEGIN {
our @ISA = 'test_error';
}

package test_pack1;
#line 1 "pack1"

sub t {
  throw test_error -type => 'ERR1', param1 => 1, param2 => 2;
}
sub r {
  report test_error -type => 'ERR1', param1 => 1, param2 => 2;
}

sub rw {
  report test_error -type => 'warn', -object => bless {};
}
sub rf {
  report test_error -type => 'fatal', -object => bless {};
}

sub ___report_error ($$;%) {
  my ($pack1, $err, %opt) = @_;
#  if ($err->{-type} eq 'fatal') {
    $err->throw;
#  } else {
#    
#  }
}

package test_pack2;
#line 1 "pack2"

sub t {
  local $Error::Depth = $Error::Depth + 1;
  throw test_error -type => 'ERR1', param1 => 1, param2 => 2;
}
sub r {
  local $Error::Depth = $Error::Depth + 1;
  report test_error -type => 'ERR1', param1 => 1, param2 => 2;
}

package test_pack3;
#line 1 "pack3"
push our @ISA, 'test_pack1';

sub t {
  local $Error::Depth = $Error::Depth + 1;
  shift->SUPER::t (@_);
}
sub r {
  local $Error::Depth = $Error::Depth + 1;
  shift->SUPER::r (@_);
}

sub rf {
  local $Error::Depth = $Error::Depth + 1;
  shift->SUPER::rf (@_);
}

package main;
#line 1 "main"

try {
  test_pack1->t;
} catch test_error with {
  my $err = shift;
  ok $err->file, "pack1";
};

try {
  test_pack1->r;
} catch test_error with {
  my $err = shift;
  ok $err->file, "main";
};

try {
  test_pack2->t;
} catch test_error with {
  my $err = shift;
  ok $err->file, "main";
};

try {
  test_pack3->t;
} catch test_error with {
  my $err = shift;
  ok $err->file, "pack3";
};

try {
  test_pack3->r;
} catch test_error with {
  my $err = shift;
  ok $err->file, "main";
};


try {
  test_pack1->rf;
} catch test_error with {
  my $err = shift;
  ok $err->file, "main";
};

try {
  test_pack3->rf;
} catch test_error with {
  my $err = shift;
  ok $err->file, "main";
};

=head1 LICENSE

Copyright 2003-2007 Wakaba <w@suika.fam.cx>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2003/12/26 07:09:42 $
1	wakaba	1.1	#!/usr/bin/perl
2	wakaba	1.3	use strict;
3	wakaba	1.1	use Message::Util::Error;
4	wakaba	1.4	use Test;
5	wakaba	1.5	plan tests => 25;
6	wakaba	1.1
7			try {
8	wakaba	1.2	throw Message::Util::Error -type => 'SOMETHING_UNKNOWN';
9	wakaba	1.1	} catch Message::Util::Error with {
10			my $err = shift;
11	wakaba	1.3	warn $err->stringify if $^W;
12	wakaba	1.4	ok $err->text, qq("SOMETHING_UNKNOWN": Unknown error);
13	wakaba	1.1	} except {
14	wakaba	1.4	ok 1, 0;
15	wakaba	1.1	} otherwise {
16	wakaba	1.4	ok 1, 0;
17	wakaba	1.1	} finally {
18	wakaba	1.4	ok 1, 1;
19	wakaba	1.1	};
20	wakaba	1.4	ok 1, 1;
21	wakaba	1.1
22			try {
23	wakaba	1.2	throw test_error -type => 'ERR1', param1 => 'VAL1', param2 => 'VAL2';
24	wakaba	1.1	} catch test_error with {
25			my $err = shift;
26	wakaba	1.4	ok $err->text, qq(Param1 "VAL1"; Param2 "VAL2");
27	wakaba	1.1	};
28
29	wakaba	1.5	try {
30			throw test_error -type => 'error_with_code';
31			} catch test_error with {
32			my $err = shift;
33			ok $err->code, 128, "error_with_code->code";
34			ok $err->value, 128, "error_with_code->value";
35			ok 0+$err->value, 128, "0+error_with_code";
36			ok $err->text, "error", "error_with_code->text";
37			ok $err->type, "error_with_code", "error_with_code->type";
38			ok $err->subtype, undef, "error_with_code->subtype";
39			ok $err->type_def->{-description}, "error", "error_with_code->type_def";
40			};
41
42			try {
43			throw test_error -type => 'error_with_code', -subtype => 'suberror';
44			} catch test_error with {
45			my $err = shift;
46			ok $err->code, 128, "error_with_code->code";
47			ok $err->value, 128, "error_with_code->value";
48			ok 0+$err->value, 128, "0+error_with_code";
49			ok $err->text, "suberror", "error_with_code->text";
50			ok $err->type, "error_with_code", "error_with_code->type";
51			ok $err->subtype, "suberror", "error_with_code->subtype";
52			ok $err->type_def->{-description}, "error", "error_with_code->type_def";
53			};
54
55	wakaba	1.1	package test_error;
56			BEGIN {
57			our @ISA = 'Message::Util::Error';
58			}
59	wakaba	1.2	sub ___error_def () {+{
60	wakaba	1.1	ERR1 => {
61	wakaba	1.5	-description => q(Param1 "%t(name=>param1);"; Param2 "%t(name=>param2);"),
62	wakaba	1.1	},
63	wakaba	1.4	fatal => {
64	wakaba	1.5	-description => q(fatal error),
65	wakaba	1.4	},
66			warn => {
67	wakaba	1.5	-description => q(warn msg),
68			},
69			error_with_code => {
70			-code => 128,
71			-description => q(error),
72			-subtype => {
73			suberror => {
74			-description => q(suberror),
75			-code => 100,
76			},
77			},
78	wakaba	1.4	},
79	wakaba	1.1	}}
80
81	wakaba	1.4	package test_report;
82			BEGIN {
83			our @ISA = 'test_error';
84			}
85
86			package test_pack1;
87			#line 1 "pack1"
88
89			sub t {
90			throw test_error -type => 'ERR1', param1 => 1, param2 => 2;
91			}
92			sub r {
93			report test_error -type => 'ERR1', param1 => 1, param2 => 2;
94			}
95
96			sub rw {
97			report test_error -type => 'warn', -object => bless {};
98			}
99			sub rf {
100			report test_error -type => 'fatal', -object => bless {};
101			}
102
103			sub ___report_error ($$;%) {
104			my ($pack1, $err, %opt) = @_;
105			# if ($err->{-type} eq 'fatal') {
106			$err->throw;
107			# } else {
108			#
109			# }
110			}
111
112			package test_pack2;
113			#line 1 "pack2"
114
115			sub t {
116			local $Error::Depth = $Error::Depth + 1;
117			throw test_error -type => 'ERR1', param1 => 1, param2 => 2;
118			}
119			sub r {
120			local $Error::Depth = $Error::Depth + 1;
121			report test_error -type => 'ERR1', param1 => 1, param2 => 2;
122			}
123
124			package test_pack3;
125			#line 1 "pack3"
126			push our @ISA, 'test_pack1';
127
128			sub t {
129			local $Error::Depth = $Error::Depth + 1;
130			shift->SUPER::t (@_);
131			}
132			sub r {
133			local $Error::Depth = $Error::Depth + 1;
134			shift->SUPER::r (@_);
135			}
136
137			sub rf {
138			local $Error::Depth = $Error::Depth + 1;
139			shift->SUPER::rf (@_);
140			}
141
142			package main;
143			#line 1 "main"
144
145			try {
146			test_pack1->t;
147			} catch test_error with {
148			my $err = shift;
149			ok $err->file, "pack1";
150			};
151
152			try {
153			test_pack1->r;
154			} catch test_error with {
155			my $err = shift;
156			ok $err->file, "main";
157			};
158
159			try {
160			test_pack2->t;
161			} catch test_error with {
162			my $err = shift;
163			ok $err->file, "main";
164			};
165
166			try {
167			test_pack3->t;
168			} catch test_error with {
169			my $err = shift;
170			ok $err->file, "pack3";
171			};
172
173			try {
174			test_pack3->r;
175			} catch test_error with {
176			my $err = shift;
177			ok $err->file, "main";
178			};
179
180	wakaba	1.1
181	wakaba	1.4	try {
182			test_pack1->rf;
183			} catch test_error with {
184			my $err = shift;
185			ok $err->file, "main";
186			};
187
188			try {
189			test_pack3->rf;
190			} catch test_error with {
191			my $err = shift;
192			ok $err->file, "main";
193			};
194	wakaba	1.5
195			=head1 LICENSE
196
197			Copyright 2003-2007 Wakaba <w@suika.fam.cx>
198
199			This program is free software; you can redistribute it and/or
200			modify it under the same terms as Perl itself.
201
202			=cut
203
204			1; # $Date: 2003/12/26 07:09:42 $