Codebase list libexception-class-dbi-perl / a832c37
Initial revision David Wheeler 21 years ago
9 changed file(s) with 286 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+5
-0
Changes less more
0 Revision history for Perl extension Exception::Class::DBI.
1
2 0.01 Sat Aug 17 18:08:22 2002
3 -
4
+9
-0
MANIFEST less more
0 Changes
1 MANIFEST This list of files
2 Makefile.PL
3 README
4 errstr
5 lib/Exception/Class/DBI.pm
6 t/dbh.t
7 t/drh.t
8 t/sth.t
+11
-0
Makefile.PL less more
0 use ExtUtils::MakeMaker;
1 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
2 # the contents of the Makefile that is written.
3 WriteMakefile(
4 'NAME' => 'Exception::Class::DBI',
5 'VERSION_FROM' => 'lib/Exception/Class/DBI.pm', # finds $VERSION
6 'PREREQ_PM' => { 'Exception::Class' => 1.02 }, # e.g., Module::Name => 1.1
7 ($] >= 5.005 ? ## Add these new keywords supported since 5.005
8 (ABSTRACT_FROM => 'lib/Exception/Class/DBI.pm', # retrieve abstract from module
9 AUTHOR => 'David Wheeler <david@wheeler.net>') : ()),
10 );
+35
-0
README less more
0 Exception/Class/DBI version 0.01
1 ================================
2
3 The README is used to introduce the module and provide instructions on
4 how to install the module, any machine dependencies it may have (for
5 example C compilers and installed libraries) and any other information
6 that should be provided before the module is installed.
7
8 A README file is required for CPAN modules since CPAN extracts the
9 README file from a module distribution so that people browsing the
10 archive can use it get an idea of the modules uses. It is usually a
11 good idea to provide version information here so that people can
12 decide whether fixes for the module are worth downloading.
13
14 INSTALLATION
15
16 To install this module type the following:
17
18 perl Makefile.PL
19 make
20 make test
21 make install
22
23 DEPENDENCIES
24
25 This module requires these other modules and libraries:
26
27 blah blah blah
28
29 COPYRIGHT AND LICENCE
30
31 Put the correct copyright and licence information here.
32
33 Copyright (C) 2002 A. U. Thor blah blah blah
34
+0
-0
errstr less more
(New empty file)
+140
-0
lib/Exception/Class/DBI.pm less more
0 package Exception::Class::DBI;
1
2 # $Id: DBI.pm,v 1.1 2002/08/18 20:19:58 david Exp $
3
4 use 5.00500;
5 use strict;
6 use Exception::Class;
7 use vars qw($VERSION);
8 $VERSION = '0.01';
9
10 use Exception::Class ( 'Exception::Class::DBI' =>
11 { description => 'DBI exception',
12 fields => [qw(err errstr state retval)]
13 },
14 'Exception::Class::DBI::Unknown' =>
15 { isa => 'Exception::Class::DBI',
16 description => 'DBI unknown exception'
17 },
18 'Exception::Class::DBI::H' =>
19 { isa => 'Exception::Class::DBI',
20 description => 'DBI handle exception',
21 fields => [qw(warn active kids active_kids compat_mode
22 inactive_destroy trace_level
23 fetch_hash_key_name chop_blanks
24 long_read_len long_trunc_ok taint)]
25 },
26 'Exception::Class::DBI::DRH' =>
27 { isa => 'Exception::Class::DBI::H',
28 description => 'DBI driver handle exception',
29 },
30 'Exception::Class::DBI::DBH' =>
31 { isa => 'Exception::Class::DBI::H',
32 description => 'DBI database handle exception',
33 fields => [qw(auto_commit db_name statement
34 row_cache_size)]
35 },
36 'Exception::Class::DBI::STH' =>
37 { isa => 'Exception::Class::DBI::H',
38 description => 'DBI statment handle exception',
39 fields => [qw(num_of_fields num_of_params field_names
40 type precision scale nullable
41 cursor_name param_values statement
42 rows_in_cache)]
43 }
44 );
45
46 sub error_handler {
47 sub {
48 my ($err, $dbh, $retval) = @_;
49 if ($dbh) {
50 # Assemble arguments for a handle exception.
51 my @params = ( error => $err,
52 errstr => $dbh->errstr,
53 err => $dbh->err,
54 state => $dbh->state,
55 retval => $retval,
56 warn => $dbh->{Warn},
57 active => $dbh->{Active},
58 kids => $dbh->{Kids},
59 active_kids => $dbh->{ActiveKids},
60 compat_mode => $dbh->{CompatMode},
61 inactive_destroy => $dbh->{InactiveDestroy},
62 trace_level => $dbh->{TraceLevel},
63 fetch_hash_key_name => $dbh->{FetchHashKeyName},
64 chop_blanks => $dbh->{ChopBlanks},
65 long_read_len => $dbh->{LongReadLen},
66 long_trunc_ok => $dbh->{LongTruncOk},
67 taint => $dbh->{Taint},
68 );
69
70 if (UNIVERSAL::isa($dbh, 'DBI::dr')) {
71 # Just throw a driver exception. It has no extra attributes.
72 die Exception::Class::DBI::DRH->new(@params);
73 } elsif (UNIVERSAL::isa($dbh, 'DBI::db')) {
74 # Throw a database handle exception.
75 die Exception::Class::DBI::DBH->new
76 ( @params,
77 auto_commit => $dbh->{AutoCommit},
78 db_name => $dbh->{Name},
79 statement => $dbh->{Statement},
80 row_cache_size => $dbh->{RowCacheSize}
81 );
82 } elsif (UNIVERSAL::isa($dbh, 'DBI::st')) {
83 # Throw a statement handle exception.
84 die Exception::Class::DBI::DBH->new
85 ( @params,
86 num_of_fields => $dbh->{NUM_OF_FIELDS},
87 num_of_params => $dbh->{NUM_OF_PARAMS},
88 field_names => $dbh->{NAME},
89 type => $dbh->{TYPE},
90 precision => $dbh->{PRECISION},
91 scale => $dbh->{SCALE},
92 nullable => $dbh->{NULLABLE},
93 cursor_name => $dbh->{CursorName},
94 param_values => $dbh->{ParamValues},
95 statement => $dbh->{Statement},
96 rows_in_cache => $dbh->{RowsInCache}
97 );
98 } else {
99 # Unknown exception. This shouldn't happen.
100 die Exception::Class::DBI::Unknown->new(@params);
101 }
102 } else {
103 # Unknown exception. This shouldn't happen.
104 die Exception::Class::DBI::Unknown->new
105 ( error => $err,
106 errstr => $DBI::errstr,
107 err => $DBI::err,
108 state => $DBI::state,
109 retval => $retval
110 );
111 }
112 };
113 }
114
115 1;
116 __END__
117
118 =head1 NAME
119
120 Exception::Class::DBI - DBI Exception objects
121
122 =head1 SYNOPSIS
123
124 use DBI;
125 use Exception::Class::DBI;
126
127 =head1 DESCRIPTION
128
129
130
131 =head1 AUTHOR
132
133 David Wheeler <david@wheeler.net>
134
135 =head1 SEE ALSO
136
137 L<perl|perl>, L<Exception::Class|Exception::Class>.
138
139 =cut
+55
-0
t/dbh.t less more
0 #!/usr/bin/perl -w
1
2 use strict;
3 use Test::More (tests => 27);
4 BEGIN { use_ok('Exception::Class::DBI') }
5 use DBI;
6
7 ok( my $dbh = DBI->connect('dbi:Pg:dbname=template1', '', '',
8 { PrintError => 0,
9 RaiseError => 0,
10 HandleError => Exception::Class::DBI->error_handler
11 }),
12 "Connect to database" );
13
14 END { $dbh->disconnect if $dbh };
15
16 # Check that the error_handler has been installed.
17 ok( UNIVERSAL::isa($dbh->{HandleError}, 'CODE'), "Check HandlError" );
18
19 # Trigger an exception.
20 eval {
21 $dbh->do('select foo from foo');
22 };
23
24 # Make sure we got the proper exception.
25 ok( my $err = $@, "Get exception" );
26 ok( UNIVERSAL::isa($err, 'Exception::Class::DBI'), "Check E::C::DBI" );
27 ok( UNIVERSAL::isa($err, 'Exception::Class::DBI::H'),
28 "Check E::C::DBI::H" );
29 ok( UNIVERSAL::isa($err, 'Exception::Class::DBI::DBH'),
30 "Check E::C::DBI::DBH" );
31
32 # Check the accessor values.
33 ok( $err->err == 7, "Check err" );
34 is( $err->errstr, 'ERROR: Relation "foo" does not exist',
35 "Check errstr" );
36 is( $err->error, 'DBD::Pg::db do failed: ERROR: Relation "foo" does not exist',
37 "Check errstr" );
38 is( $err->state, 'S1000', "Check state" );
39 ok( ! defined $err->retval, "Check retval" );
40 ok( $err->warn == 1, "Check warn" );
41 ok( $err->active == 1, "Check active" );
42 ok( $err->kids == 0, "Check kids" );
43 ok( $err->active_kids == 0, "Check acitive_kids" );
44 is( $err->inactive_destroy, '', "Check inactive_destroy" );
45 ok( $err->trace_level == 0, "Check trace_level" );
46 is( $err->fetch_hash_key_name, 'NAME', "Check fetch_hash_key_name" );
47 is( $err->chop_blanks, '', "Check chop_blanks" );
48 ok( $err->long_read_len == 80, "Check long_read_len" );
49 is( $err->long_trunc_ok, '', "Check long_trunc_ok" );
50 is( $err->taint, '', "Check taint" );
51 ok( $err->auto_commit == 1, "Check auto_commit" );
52 is( $err->db_name, 'template1', "Check db_name" );
53 is( $err->statement, 'select foo from foo', "Check db_name" );
54 ok( ! defined $err->row_cache_size, "Check row_cache_size" );
+25
-0
t/drh.t less more
0 #!/usr/bin/perl -w
1
2 use strict;
3 use Test::More (tests => 5);
4 BEGIN { use_ok('Exception::Class::DBI') }
5 use DBI;
6
7 eval {
8 DBI->connect('dbi:dummy', '', '',
9 { PrintError => 0,
10 RaiseError => 0,
11 HandleError => Exception::Class::DBI->error_handler
12 });
13 };
14
15 ok( my $err = $@, "Caught exception" );
16 TODO: {
17 local $TODO = 'HandleError not implemented in DBI';
18 ok( UNIVERSAL::isa($err, 'Exception::Class::DBI'), "Check E::C::DBI" );
19 ok( UNIVERSAL::isa($err, 'Exception::Class::DBI::H'),
20 "Check E::C::DBI::H" );
21 ok( UNIVERSAL::isa($err, 'Exception::Class::DBI::DRH'),
22 "Check E::C::DBI::DRH" );
23 # Add code here to check basic properties.
24 }
+6
-0
t/sth.t less more
0 #!/usr/bin/perl -w
1
2 use strict;
3 use Test::More (tests => 1);
4 BEGIN { use_ok('Exception::Class::DBI') }
5 use DBI;