remove debug warning from last commit
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / PK / Auto / Oracle.pm
CommitLineData
e565d25e 1package DBIx::Class::PK::Auto::Oracle;
2
3use strict;
4use warnings;
5
aa562407 6use Carp qw/croak/;
7
e565d25e 8use base qw/DBIx::Class/;
9
10__PACKAGE__->load_components(qw/PK::Auto/);
11
12sub last_insert_id {
13 my $self = shift;
14 $self->get_autoinc_seq unless $self->{_autoinc_seq};
c8f4b52b 15 my $sql = "SELECT " . $self->{_autoinc_seq} . ".currval FROM DUAL";
66d9ef6b 16 my ($id) = $self->result_source->storage->dbh->selectrow_array($sql);
e565d25e 17 return $id;
18}
19
20sub get_autoinc_seq {
21 my $self = shift;
22
23 # return the user-defined sequence if known
5b34b2f9 24 if ($self->sequence) {
25 return $self->{_autoinc_seq} = $self->sequence;
26 }
e565d25e 27
28 # look up the correct sequence automatically
66d9ef6b 29 my $dbh = $self->result_source->storage->dbh;
e565d25e 30 my $sql = qq{
31 SELECT trigger_body FROM ALL_TRIGGERS t
32 WHERE t.table_name = ?
33 AND t.triggering_event = 'INSERT'
34 AND t.status = 'ENABLED'
35 };
36 # trigger_body is a LONG
37 $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
38 my $sth = $dbh->prepare($sql);
b98e75f6 39 $sth->execute( uc($self->result_source->name) );
e565d25e 40 while (my ($insert_trigger) = $sth->fetchrow_array) {
41 if ($insert_trigger =~ m!(\w+)\.nextval!i ) {
42 $self->{_autoinc_seq} = uc($1);
43 }
44 }
45 unless ($self->{_autoinc_seq}) {
aa562407 46 croak "Unable to find a sequence INSERT trigger on table '" . $self->_table_name . "'.";
e565d25e 47 }
48}
49
501;
51
52=head1 NAME
53
eb49d4e3 54DBIx::Class::PK::Auto::Oracle - Automatic primary key class for Oracle
e565d25e 55
56=head1 SYNOPSIS
57
eb49d4e3 58 # In your table classes
59 __PACKAGE__->load_components(qw/PK::Auto::Oracle Core/);
60 __PACKAGE__->set_primary_key('id');
6718c5f0 61
e565d25e 62=head1 DESCRIPTION
63
64This class implements autoincrements for Oracle.
65
66=head1 AUTHORS
67
68Andy Grundman <andy@hybridized.org>
9f19b1d6 69
e565d25e 70Scott Connelly <scottsweep@yahoo.com>
71
72=head1 LICENSE
73
74You may distribute this code under the same terms as Perl itself.
75
76=cut