# $Id: JDBC.pm,v 1.41 2006/01/27 22:10:04 gemerson Exp $ # # Copyright 1999-2001,2005 Vizdom Software, Inc. All Rights Reserved. # # This program is free software; you can redistribute it and/or # modify it under the same terms as the Perl Kit, namely, under # the terms of either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 1 of the License, or # (at your option) any later version, or # # b) the "Artistic License" that comes with the Perl Kit. # # This program 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 # either the GNU General Public License or the Artistic License # for more details. require 5.8.0; { package DBD::JDBC; use DBI 1.48; require Exporter; @ISA = qw(Exporter); %EXPORT_TAGS = ( sql_types => [ qw( SQL_BIGINT ) ], ); @EXPORT_OK = qw(SQL_BIGINT); use vars qw($methods_installed); $DBD::JDBC::VERSION = 0.69; $DBD::JDBC::drh = undef; # Driver handle constructor. This is pretty much straight # from the DBD doc. sub driver { return $drh if $drh; my($class, $attr) = @_; DBI->setup_driver('DBD::JDBC'); $class .= "::dr"; ($drh) = DBI::_new_drh($class, { 'Name' => 'JDBC', 'Version' => $VERSION, 'Attribution' => "DBD::JDBC $VERSION by Gennis Emerson", }); if (!$methods_installed++) { DBD::JDBC::db->install_method('jdbc_func', {}); DBD::JDBC::st->install_method('jdbc_func', {}); } $drh; } # This will dump the BER buffer to STDERR in a rather verbose way. # # args: the BER buffer, as a string # returns: nothing sub _dump { my ($str) = shift; my ($b, $result); my ($pos) = 0; my ($upper) = shift || length($str); do { $b = CORE::unpack("C",substr($str,$pos++,1)); $result .= join('', unpack("B*", chr($b))) . " (" . chr($b) . ") | "; } while($pos < $upper); print STDERR "$result\n"; } # This is a utility which handles the tedious part of # sending a message to the server and decoding the # response. If an error occurs, this function will use # DBI::set_err and return undef. # # args: # $h: a DBI object handle; used for debugging and error reporting # $socket: the server socket # $ber: a BER object for encoding and decoding messages # $encode_list: an array reference containing the arguments # for the BER encode # $decode_list: an array reference containing the arguments for # the BER decode method # # returns: true on success, false (and calls $h->set_err) on failure sub _send_request { my ($h, $socket, $ber, $encode_list, $decode_list, $method, $avoid_set_err) = @_; my $debug = $h->trace(); $ber->buffer(""); $h->trace_msg("Encoding [" . join(" | ", @$encode_list) . "]\n", 3) if $debug; $ber->encode(@$encode_list); local($SIG{PIPE}) = "IGNORE"; $h->trace_msg("Sending request to server\n", 3) if $debug; $ber->write($socket); if ($@) { die $@ if $avoid_set_err; return $h->set_err(DBD::JDBC::ErrorMessages::send_error($@)); } $h->trace_msg("Listening for response\n", 3) if $debug; $ber->read($socket); if ($@) { die $@ if $avoid_set_err; return $h->set_err(DBD::JDBC::ErrorMessages::recv_error($@)); } $h->trace_msg("Received response from server\n", 3) if $debug; my $err; my $tag = $ber->tag(); if ($tag == $ber->ERROR_RESP()) { my (@errors); $ber->decode(ERROR_RESP => \@errors); $ber->buffer(""); if ($err = $ber->error()) { $h->trace_msg("Error decoding response from server: $err", 3) if $debug; $ber->[ Convert::BER::_ERROR() ] = ""; die $err if $avoid_set_err; return $h->set_err(DBD::JDBC::ErrorMessages::ber_error($err)); } $h->{jdbc_error} = []; # Reset the error list. push @{$h->{jdbc_error}}, @errors; $h->trace_msg("Error: ".$errors[0]->{errstr}."\n", 3) if $debug; die $errors[0]->{errstr} if $avoid_set_err; return $h->set_err($errors[0]->{err}, $errors[0]->{errstr}, substr($errors[0]->{state}, 0, 5), $method); } else { $h->trace_msg("Decoding [" . join(" | ", @$decode_list) . "]\n", 3) if $debug; $ber->decode(@$decode_list); $ber->buffer(""); if ($err = $ber->error()) { $h->trace_msg("Error decoding response from server: $err", 3) if $debug; $ber->[ Convert::BER::_ERROR() ] = ""; die $err if $avoid_set_err; return $h->set_err(DBD::JDBC::ErrorMessages::ber_error($err)); } return 1; } } # JDBC constants. Since these seem to be based on values # from the SQL standard, I don't feel too bad about # hard-coding them here. %DBD::JDBC::Types = (NULL => 0, CHAR => 1, NUMERIC => 2, DECIMAL => 3, INTEGER => 4, SMALLINT => 5, FLOAT => 6, REAL => 7, DOUBLE => 8, VARCHAR => 12, LONGVARCHAR => -1, BINARY => -2, VARBINARY => -3, LONGVARBINARY => -4, BIGINT => -5, TINYINT => -6, DATE => 91, TIME => 92, TIMESTAMP => 93, BIT => -7, OTHER => 1111, JAVA_OBJECT => 2000, DISTINCT => 2001, STRUCT => 2002, ARRAY => 2003, BLOB => 2004, CLOB => 2005, REF => 2006, ); # DBI no longer defines this value due to a lack of desire to # choose between SQL and ODBC. Since JDBC uses it, we need to # define it separately. sub SQL_BIGINT() { -5 }; } { package DBD::JDBC::dr; # imp_data_size, according to the DBD doc, is used by DBI and # should be set here. 0 is a default which means something # like 'no size limit imposed'. $imp_data_size = 0; $imp_data_size = 0; # Avoid -w warnings. use strict; use IO::Socket; *_send_request = \&DBD::JDBC::_send_request; # Opens a socket connection to the host/port specified in the # dsn, sends a connection request to the server-side JDBC # driver, and returns a new database handle. Parameters which # can be specified in the DSN: # hostname: the DBD::JDBC server host; may be in the form name:port # port: the DBD::JDBC server port # url: the JDBC URL to pass to the JDBC driver # jdbc_character_set: a Java character encoding name; should # be the client's (the Perl application's) character encoding # # Arbitrary JDBC connection properties can be specified by # passing a hash reference as the value of the # "jdbc_properties" key in the attributes hash in the # DBI->connect method. # # If the user and password values passed to this method in # the DBI->connect call are undefined, the server will use # the DriverManager.getConnection(String, Properties) # method. Otherwise, the server will use the # DriverManager.getConnection(String, String, String) method. # # args # $drh: driver handle # $dsn: dsn # $user: username; may be undef # $auth: password; may be undef # $attr: hash reference of connection properties # # JDBC: DriverManager.getConnection, Connection.setXXX sub connect { my ($drh, $dsn, $user, $auth, $attr) = @_; my $debug = DBI->trace(); # Any ; or = characters in the url must be escaped using # http url escape syntax (e.g., an url of foo=bar becomes # foo%3Dbar). The driver will unescape the url portion of # the dsn. dsn format: # hostname=[:port];[port=;]url=[;jdbc_character_set=] my %dsn = split /[;=]/, $dsn; my $hostname = $dsn{'hostname'}; my $port = $dsn{'port'}; my $url = $dsn{'url'}; my $encoding = $dsn{'jdbc_character_set'} || "ISO8859_1"; if ($hostname && !$port) { ($hostname, $port) = split /:/, $hostname; } $url =~ s/%(3[bBdD])/pack("c", hex($1))/ge; # (; is 0x3b, = is 0x3d) my %properties; if ($attr && $attr->{'jdbc_properties'}) { %properties = %{ $attr->{'jdbc_properties'} }; } else { %properties = (); } return $drh->set_err( DBD::JDBC::ErrorMessages::missing_dsn_component('hostname')) unless $hostname; return $drh->set_err( DBD::JDBC::ErrorMessages::missing_dsn_component('port')) unless $port; return $drh->set_err( DBD::JDBC::ErrorMessages::missing_dsn_component('url')) unless $url; # Connect to the server. my $socket = IO::Socket::INET->new(PeerAddr => $hostname, PeerPort => $port, Proto => 'tcp'); return $drh->set_err(DBD::JDBC::ErrorMessages::socket_error($@)) if !$socket; my ($ber) = new DBD::JDBC::BER; my $response; return undef unless _send_request($drh, $socket, $ber, [CONNECT_REQ => [STRING => $url, ($user?'STRING':'NULL') => $user, ($auth?'STRING':'NULL') => $auth, STRING => $encoding, HASH => [STRING => [%properties]]]], [CONNECT_RESP => \$response]); # Create $dbh after we know connect succeeded. If this # method fails while using $h->set_err after $dbh has been # created, and the calling script checks for errors using # $DBI::{err,errstr,state} in a separate statement from # the call to connect, the undefined $dbh will somehow be # the last-used handle and cause an error. That's my best # theory, anyway. my ($dbh) = DBI::_new_dbh($drh, { 'Name' => $dsn, }); $dbh->STORE('Active' => 1); $dbh->STORE('jdbc_socket' => $socket); $dbh->STORE('jdbc_ber' => $ber); $dbh->STORE('jdbc_character_set' => $encoding); $dbh->STORE('jdbc_url' => $url); # The connection list is used by disconnect_all. my ($conns) = $drh->FETCH('jdbc_connections') || []; push @$conns, $dbh; $drh->STORE('jdbc_connections' => $conns); $dbh; } # This method is required to return usable dsn's, and JDBC # doesn't provide any sort of 'getURL' method. Available # drivers is about the best we could do. We also currently # have no way of knowing the server's host and port. sub data_sources { (); } # Added in DBI 1.42. Not currently implemented here. sub parse_trace_flag { my ($flag) = shift; return DBI->parse_trace_flag($flag); } # All cached database handles will be disconnected. The # handles will be removed from the cache even if the # disconnect call fails so they can be garbage # collected. This may be called by the user, but is more # likely to be called by DBI's END block on shutdown. # # Args: none # Return value: none sub disconnect_all { my ($drh) = shift; my ($conns) = $drh->FETCH('jdbc_connections'); return unless $conns; $drh->trace_msg("Found ".scalar(@$conns)." connections to close\n", 3); my ($conn, $name); while ($conn = shift @$conns) { $name = $conn->{'Name'}; $drh->trace_msg("Disconnecting $name\n", 3); $conn->disconnect() || $drh->trace_msg("Failed to disconnect $name: " . ($drh->errstr ? $drh->errstr : "") . "\n", 3); } } sub STORE { my ($drh, $attr, $value) = @_; if ($attr =~ /^jdbc_/) { $drh->{$attr} = $value; return 1; } $drh->SUPER::STORE($attr, $value); } sub FETCH { my ($drh, $attr) = @_; if ($attr =~ /^jdbc_/) { return $drh->{$attr}; } $drh->SUPER::FETCH($attr); } } { package DBD::JDBC::db; $imp_data_size = 0; $imp_data_size = 0; # Avoid -w warnings. use strict; *_send_request = \&DBD::JDBC::_send_request; # Prepares a statement for execution. # # JDBC: Connection.prepareStatement sub prepare { my ($dbh, $statement) = @_; my ($debug) = $dbh->trace(); my ($statement_handle); return undef unless _send_request($dbh, $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'), [PREPARE_REQ => $statement], [PREPARE_RESP => \$statement_handle]); my $param_count = _count_params($statement); my $sth = DBI::_new_sth($dbh, { 'Statement' => $statement, 'NUM_OF_PARAMS' => $param_count, 'NUM_OF_FIELDS' => undef, }); $sth->STORE('jdbc_handle' => $statement_handle); $sth->STORE('jdbc_socket' => $dbh->FETCH('jdbc_socket')); $sth->STORE('jdbc_ber' => $dbh->FETCH('jdbc_ber')); $sth->STORE('jdbc_rowcount' => -1); ## Set up ParamValues (DBI 1.28). Initialize the keys to the ## parameter numbers (if any). $sth->STORE('jdbc_params', {}); $sth->STORE('jdbc_params_types', {}); for my $i (1..$param_count) { $sth->{'jdbc_params'}->{$i} = undef; $sth->{'jdbc_params_types'}->{$i} = undef; } # Copy the current value of inherited properties to the server. $sth->STORE('LongReadLen' => $dbh->FETCH('LongReadLen')); $sth->STORE('LongTruncOk' => $dbh->FETCH('LongTruncOk') ? 1 : 0); $sth->STORE('ChopBlanks' => $dbh->FETCH('ChopBlanks') ? 1 : 0); $sth; } # JDBC: Connection.commit sub commit { my ($dbh) = shift; my ($resp); return _send_request($dbh, $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'), [COMMIT_REQ => 0], [COMMIT_RESP => \$resp]); } # JDBC: Connection.rollback sub rollback { my ($dbh) = shift; my ($resp); return _send_request($dbh, $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'), [ROLLBACK_REQ => 0], [ROLLBACK_RESP => \$resp]); } # Confirms that the server is alive and that this particular # (JDBC) connection has not been closed. # # JDBC: Connection.isClosed sub ping { my ($dbh) = shift; # If the connection isn't active, no point in pinging it. return 0 unless $dbh->FETCH('Active'); my ($resp); return undef unless _send_request($dbh, $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'), [PING_REQ => 0], [PING_RESP => \$resp]); return $resp; } # Sends a disconnect message to the server. The server will # attempt to close any open ResultSets and Statements, then # close the JDBC Connection. This driver's end of the socket # will be closed. # # JDBC: ResultSet.close, Statement.close, Connection.close sub disconnect { my ($dbh) = shift; my ($debug) = $dbh->trace(); # Don't disconnect inactive connections. return 1 unless $dbh->FETCH('Active'); $dbh->STORE('Active' => 0); my $resp; my ($result) = _send_request($dbh, $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'), [DISCONNECT_REQ => 0], [DISCONNECT_RESP => \$resp]); $dbh->FETCH('jdbc_socket')->close(); return $result; } # This is the func implementation. It expects the method name # to be a valid java.sql.Connection method name. The # parameter list may be empty if the method takes no # arguments. Otherwise, parameters may be specified as # scalars, if they should be mapped to java.lang.String # objects, or as [value,type] pairs (array references) if the # parameter type is something other than String. For example, # $dbh->func([1 => SQL_BIT], "setAutoCommit") If the method # returned void or null, this method will return # undef. Otherwise, the return value of the Java method will # be returned as a string. sub jdbc_func { my ($dbh) = shift; my ($method) = pop @_; $method =~ s/.*://; # method name starts out fully-qualified $method =~ s/^jdbc_//; my (@parameters) = @_; # When we're done, parameters_with_types will be a list # of alternating parameter value/JDBC type codes. my @parameters_with_types = (); my $param; foreach $param (@parameters) { if (ref $param) { push @parameters_with_types, $param->[0], DBD::JDBC::st::_jdbc_type($param->[1]); } else { push @parameters_with_types, $param, $DBD::JDBC::Types{VARCHAR}; } } my (@value); return undef unless _send_request($dbh, $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'), [CONNECTION_FUNC_REQ => [$method, \@parameters_with_types]], [CONNECTION_FUNC_RESP => \@value]); return $value[0]; } # This method is partially implemented. It needs to get its # data from DatabaseMetaData on the server. sub get_info { my ($dbh, $type) = @_; return undef unless defined $type and length $type; ## For now, use the JDBC URL to retrieve a string to ## serve as the DBMS name. Whenever access to ## DatabaseMetaData is implemented, use ## getDatabaseProductName. my $name; my $url = $dbh->{jdbc_url}; if ($url =~ m`jdbc:(.+)://`) { # jdbc:xxx[:yyy]://conn_info $name = $1; } elsif ($url =~ m`jdbc:([^:]+):`) { # jdbc:xxx:conn_info $name = $1; } elsif ($url =~ m`jdbc:(.+)`) { # jdbc:xxx $name = $1; } else { $name = $url; } my %type = ( ## Basic information: 6 => ["SQL_DRIVER_NAME", 'DBD/JDBC.pm'], 17 => ["SQL_DBMS_NAME", $name ]); ## Put both numbers and names into a hash my %t; for (keys %type) { $t{$_} = $type{$_}->[1]; $t{$type{$_}->[0]} = $type{$_}->[1]; } return undef unless exists $t{$type}; my $ans = $t{$type}; return $ans; } # This method is not implemented. # Implementation notes: call # DatabaseMetaData.getTables(). Use JDBC's default values # (null, "", etc) for the catalog, schema, tablenamepattern, # and types arguments. Note that this returns a statement # handle, so the server will have to be able to deal with # that. sub table_info { undef; } # This method is not implemented. # These names match the column names in DatabaseMetaData.getTypeInfo # exactly, except for AUTO_UNIQUE_VALUE, which is # AUTO_INCREMENT in JDBC, and COLUMN_SIZE, which is PRECISION in JDBC. # JDBC DBI # TYPE_NAME String String # DATA_TYPE SQL type DBI type # COLUMN_SIZE int int # LITERAL_PREFIX String (nullable) String (nullable) # LITERAL_SUFFIX String (nullable) String (nullable) # CREATE_PARAMS String (nullable) String (nullable) # NULLABLE short (0,1,2) int (0,1,2) # CASE_SENSITIVE boolean boolean # SEARCHABLE short (...) int (need to match up constants) # UNSIGNED_ATTRIBUTE boolean boolean (nullable) # FIXED_PREC_SCALE boolean boolean (nullable) # AUTO_UNIQUE_VALUE boolean boolean (nullable) # LOCAL_TYPE_NAME String (nullable) string (localized TYPE_NAME) # MINIMUM_SCALE short int (nullable) # MAXIMUM_SCALE short int (nullable) # NUM_PREC_RADIX int int (assume JDBC values are ok) sub type_info_all { undef; } # Added in DBI 1.42. Not currently implemented here. sub parse_trace_flag { my ($flag) = shift; return DBI->parse_trace_flag($flag); } sub STORE { my ($dbh, $attr, $value) = @_; if ($attr =~ /^jdbc_/) { $dbh->{$attr} = $value; return 1; } if ($attr eq 'AutoCommit') { die DBD::JDBC::ErrorMessages::bad_autocommit_value($value) unless ($value == 0 or $value == 1); return _set_attr($dbh, $attr, $value); } if ($attr eq 'RowCacheSize') { # unimplemented return; } $dbh->SUPER::STORE($attr, $value); } sub FETCH { my ($dbh, $attr) = @_; if ($attr =~ /^jdbc_/) { return $dbh->{$attr}; } if ($attr eq 'AutoCommit') { return _get_attr($dbh, $attr)->[0]; } if ($attr eq 'RowCacheSize') { # unimplemented return undef; } $dbh->SUPER::FETCH($attr); } # According to the DBI spec, we need to call rollback and # disconnect here. sub DESTROY { my ($dbh) = shift; return unless $dbh->FETCH('Active'); return if $dbh->FETCH('InactiveDestroy'); my $name = $dbh->FETCH('Name'); # Log any existing error on the current handle. my ($err, $errstr, $state) = ($dbh->err, $dbh->errstr, $dbh->state); $dbh->trace_msg("Error on db handle being destroyed: " . "($err) $errstr [$state]\n", 3) if ($dbh->trace() and $err); # Override of DIE and $@ copied from DBD::Proxy. local $SIG{__DIE__} = 'DEFAULT'; local $@; eval { $dbh->rollback() or $dbh->trace_msg("Rollback '$name' failed: " . $dbh->errstr . "\n", 3); $dbh->disconnect() or $dbh->trace_msg("Disconnect '$name' failed: " . $dbh->errstr . "\n", 3); }; $dbh->trace_msg("Error in DBD::JDBC::db::DESTROY: $@\n", 3) if ($dbh->trace() and $@); 1; } # This private method retrieves an attribute value from the server. # # args: handle, attribute name # returns: an array reference to a list of attribute values sub _get_attr { my ($dbh, $attr) = @_; my (@data); return undef unless _send_request($dbh, $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'), [GET_CONNECTION_PROPERTY_REQ => $attr], [GET_CONNECTION_PROPERTY_RESP => \@data]); return \@data; } # This private method sets an attribute value on the # server. Attribute values are always passed as strings; the # server is responsible for decoding them # # args: handle, attribute name, attribute value sub _set_attr { my ($dbh, $attr, $value) = @_; my ($data); _send_request($dbh, $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'), [SET_CONNECTION_PROPERTY_REQ => [STRING => $attr, STRING => $value]], [SET_CONNECTION_PROPERTY_RESP => \$data]); } # Simple SQL parameter counting implementation. This handles # single- and double-quoted strings within SQL # statements. This is made available because DBI says it should # be. I'm reluctant to rely on it, since we don't necessarily # know anything about the database language being used. # # args: a SQL statement # returns: the number of substitutable parameters in the statement sub _count_params { my (@chars) = split //, shift; my ($params, $state, $i, $last); # states my ($outside_quote, $in_single_quote, $in_double_quote) = (0, 1, 2); $last = 0; # Avoid lookahead at end of string. $params = 0; $state = $outside_quote; for ($i=0; $i < @chars; $i++) { next unless $chars[$i] =~ /[?'"]/; #'] $last = 1 if $i == $#chars; if ($state == $outside_quote) { if ($chars[$i] eq '?') { $params++; } if ($chars[$i] eq "'") { $state = $in_single_quote; } if ($chars[$i] eq '"') { $state = $in_double_quote; } } elsif ($state == $in_single_quote) { if ($chars[$i] eq "'") { (!$last && $chars[$i+1] eq "'") ? $i++ : ($state = $outside_quote); } } elsif ($state == $in_double_quote) { if ($chars[$i] eq '"') { (!$last && $chars[$i+1] eq '"') ? $i++ : ($state = $outside_quote); } } } $params; } } { package DBD::JDBC::st; $imp_data_size = 0; $imp_data_size = 0; # Avoid -w warnings. ##use vars qw($AUTOLOAD); use strict; use DBI qw(:sql_types); *_send_request = \&DBD::JDBC::_send_request; # ??? Error checking on parameter? I'm not sure it's worth # trusting my naive parameter counting to rule out bad parameter # indexes here. I don't remember what else I had in mind when # I wrote that question. Ensure that it's a scalar? Don't # allow a parameter type to be changed after it's been set (DBI # spec requirement). # If a type hint is provided, it should be a DBI type # constant. This method will convert the DBI types to JDBC # types for transmission to the server. sub bind_param { my ($sth, $param, $value, $attr) = @_; my ($type) = (ref $attr) ? $attr->{'TYPE'} : $attr; # Don't pass $type to _jdbc_type if it's undef to avoid warnings. $type = ($type ? _jdbc_type($type) : undef); # Store the parameter. $sth->{'jdbc_params'}->{$param} = $value; # Store the type hint, unless it's previously been set or is # currently undef. $sth->{'jdbc_params_types'}->{$param} = $type unless ($sth->{'jdbc_params_types'}->{$param} or not $type); 1; } # This method sends the parameters, if any, to the server and # causes the server to execute the previously prepared # statement. # # JDBC: PreparedStatement.setXXX, PreparedStatement.execute sub execute { my ($sth, @values) = @_; my $debug = $sth->trace(); # Set parameter values, if provided. For now, I'm # assuming that it's ok for bind_param to have been # called for parameter indexes larger than the highest # index in @values. if (@values) { my $i; for ($i = 1; $i <= @values; $i++) { $sth->{'jdbc_params'}->{$i} = $values[$i - 1]; } } my ($i, @encodelist); my $paramcount = $sth->{'jdbc_params'} ? scalar( keys %{ $sth->{'jdbc_params'} }) : 0; $sth->trace_msg("Warning: number of parameters set ($paramcount) " . "does not match NUM_OF_PARAMS (" . $sth->FETCH('NUM_OF_PARAMS') . ")", 3) if $debug && ($paramcount != $sth->FETCH('NUM_OF_PARAMS')); # encodelist is a list of alternating parameter values/types for ($i = 1; $i <= $paramcount; $i++) { push @encodelist, $sth->{'jdbc_params'}->{$i}; push @encodelist, $sth->{'jdbc_params_types'}->{$i} || $DBD::JDBC::Types{VARCHAR}; } my ($rowcount, $columncount); return undef unless _send_request($sth, $sth->FETCH('jdbc_socket'), $sth->FETCH('jdbc_ber'), [EXECUTE_REQ => [$sth->FETCH('jdbc_handle'), $paramcount, \@encodelist]], [EXECUTE_RESP => [OPTIONAL => [EXECUTE_ROWS_RESP => \$rowcount], OPTIONAL => [EXECUTE_RESULTSET_RESP => \$columncount]]]); return $sth->set_err(DBD::JDBC::ErrorMessages::bad_execute()) unless ((defined $rowcount) xor (defined $columncount)); if (defined $rowcount) { $sth->STORE('Active' => 0); $sth->STORE('NUM_OF_FIELDS', 0); $sth->{'jdbc_rowcount'} = $rowcount; return $rowcount == 0 ? "0E0" : $rowcount; } else { # must be columncount $sth->STORE('NUM_OF_FIELDS', $columncount) unless $sth->FETCH('NUM_OF_FIELDS'); $sth->{'jdbc_rowcount'} = 0; $sth->STORE('Active' => 1); return 1; } } sub fetch { my ($sth) = @_; my $debug = $sth->trace(); my @row; return undef unless _send_request($sth, $sth->FETCH('jdbc_socket'), $sth->FETCH('jdbc_ber'), [FETCH_REQ => $sth->FETCH('jdbc_handle')], [FETCH_RESP => \@row]); if (shift @row) { # row contains data $sth->{'jdbc_rowcount'}++; return $sth->_set_fbav(\@row); } $sth->trace_msg("At end of result set\n", 3) if $debug; $sth->finish(); # no more data return undef; } # DBI requires this alias. *fetchrow_arrayref = \1; # avoid -w warnings *fetchrow_arrayref = \&fetch; # This will return the number of rows affected by a DML # statement, or the number of rows returned so far by a # select statement. sub rows { return shift->{'jdbc_rowcount'}; } # I want finish to clean up server resources, but doing so # would most likely mean closing a ResultSet, and that would # force a commit in AutoCommit mode. The DBI spec says that # finish should have no effect on the connection's # transaction state. sub finish { my ($sth) = @_; $sth->STORE('Active' => 0); 1; } # This is the func implementation. It expects the method name # to be prefixed with one of "ResultSet.", "Statement.", or # "ResultSetMetaData." to indicate on which object the method # should be called. The parameter list may be empty if the # method takes no arguments. Otherwise, parameters may be # specified as scalars, if they should be mapped to # java.lang.String objects, or as [value,type] pairs (array # references) if the parameter type is something other than # String. For example, # $sth->func("eno", [5003 => SQL_INTEGER], "ResultSet.updateInt"); # If the method returned void or null, this # method will return undef. Otherwise, the return value of # the Java method will be returned as a string. sub jdbc_func { my ($sth) = shift; my ($method) = pop @_; $method =~ s/.*://; # method name starts out fully-qualified $method =~ s/^jdbc_//; my (@parameters) = @_; # When we're done, parameters_with_types will be a list # of alternating parameter value/JDBC type codes. my @parameters_with_types = (); my $param; foreach $param (@parameters) { if (ref $param) { push @parameters_with_types, $param->[0], DBD::JDBC::st::_jdbc_type($param->[1]); } else { push @parameters_with_types, $param, $DBD::JDBC::Types{VARCHAR}; } } my (@return_value); return undef unless _send_request($sth, $sth->FETCH('jdbc_socket'), $sth->FETCH('jdbc_ber'), [STATEMENT_FUNC_REQ => [$sth->FETCH('jdbc_handle'), $method, \@parameters_with_types]], [STATEMENT_FUNC_RESP => \@return_value]); return $return_value[0]; } # Added in DBI 1.42. Not currently implemented here. sub parse_trace_flag { my ($flag) = shift; return DBI->parse_trace_flag($flag); } sub STORE { my ($sth, $attr, $value) = @_; if ($attr =~ /^jdbc_/) { $sth->{$attr} = $value; return 1; } if ($attr eq 'LongReadLen') { return _set_attr($sth, $attr, $value) && $sth->SUPER::STORE($attr, $value); } if ($attr eq 'LongTruncOk') { return _set_attr($sth, $attr, $value ? 1 : 0) && $sth->SUPER::STORE($attr, $value); } if ($attr eq 'ChopBlanks') { return _set_attr($sth, $attr, $value ? 1 : 0) && $sth->SUPER::STORE($attr, $value); } $sth->SUPER::STORE($attr, $value); } sub FETCH { my ($sth, $attr) = @_; if ($attr =~ /^jdbc_/) { return $sth->{$attr}; } if ($attr eq 'ParamValues') { return $sth->{'jdbc_params'}; } # These attributes shouldn't change value for a given # statement, so cache them after retrieval. if ($attr eq 'NAME') { return ($sth->{'jdbc_NAME'} or $sth->{'jdbc_NAME'} = _get_attr($sth, $attr, 'STRING')); } if ($attr eq 'TYPE') { return ($sth->{'jdbc_TYPE'} or eval { my $row; if ($row = _get_attr($sth, $attr, 'INTEGER')) { my $new_row = [ map { _dbi_type($_) } @$row ]; return $sth->{'jdbc_TYPE'} = $new_row; } else { return undef; } }); } if ($attr eq 'PRECISION') { return ($sth->{'jdbc_PRECISION'} or $sth->{'jdbc_PRECISION'} = _get_attr($sth, $attr, 'INTEGER')); } if ($attr eq 'SCALE') { return ($sth->{'jdbc_SCALE'} or $sth->{'jdbc_SCALE'} = _get_attr($sth, $attr, 'INTEGER')); } if ($attr eq 'NULLABLE') { return ($sth->{'jdbc_NULLABLE'} or $sth->{'jdbc_NULLABLE'} = _get_attr($sth, $attr, 'INTEGER')); } if ($attr eq 'CursorName') { return ($sth->{'jdbc_CursorName'} or eval { my $row = _get_attr($sth, $attr, 'STRING'); if ($row && scalar(@$row)) { # non-empty list return $sth->{'jdbc_CursorName'} = $row->[0]; } else { return undef; } }); } if ($attr eq 'RowsInCache') { return undef; # Not supported. } $sth->SUPER::FETCH($attr); } # Destroys the object on garbage collection. Give the server # a chance to remove any references to the Statement object. # IMPORTANT: Check Active to see if the connection has been # disconnected; it's no use talking to the server if the # connection's closed. This is intended to let the server get # rid of the Statement if this particular statement handle is # being destroyed while the connection is still open. sub DESTROY { my ($sth) = shift; return if $sth->FETCH('InactiveDestroy'); return unless $sth->FETCH('Database')->FETCH('Active'); my $handle = $sth->FETCH('jdbc_handle'); my $resp; # Log any existing error on the current handle. my ($err, $errstr, $state) = ($sth->err, $sth->errstr, $sth->state); $sth->trace_msg("Error on statement handle being destroyed: " . "($err) $errstr [$state]\n", 3) if ($sth->trace() and $err); # Don't let calling _send_request affect the current # value of $@. (Override of $SIG{__DIE__} and $@ copied from # DBD::Proxy.) local $SIG{__DIE__} = 'DEFAULT'; local $@; eval { _send_request($sth, $sth->FETCH('jdbc_socket'), $sth->FETCH('jdbc_ber'), [STATEMENT_DESTROY_REQ => $handle], [STATEMENT_DESTROY_RESP => \$resp], "sth::destroy", 1); }; $sth->trace_msg("Error in DBD::JDBC::st::DESTROY: $@\n", 3) if ($sth->trace() and $@); 1; } # This private method retrieves an attribute value from the server. # # args: handle, attribute name # returns: an array reference to a list of attribute values sub _get_attr { my ($sth, $attr) = @_; my ($debug) = DBI->trace(); my @data; return undef unless _send_request($sth, $sth->FETCH('jdbc_socket'), $sth->FETCH('jdbc_ber'), [GET_STATEMENT_PROPERTY_REQ => [INTEGER => $sth->FETCH('jdbc_handle'), STRING => $attr]], [GET_STATEMENT_PROPERTY_RESP => \@data]); return \@data; } # This private method sets an attribute value on the # server. Attribute values are always passed as strings; the # server is responsible for decoding them # # args: handle, attribute name, attribute value sub _set_attr { my ($sth, $attr, $value) = @_; my $data; return _send_request($sth, $sth->FETCH('jdbc_socket'), $sth->FETCH('jdbc_ber'), [SET_STATEMENT_PROPERTY_REQ => [INTEGER => $sth->FETCH('jdbc_handle'), STRING => $attr, STRING => $value]], [SET_STATEMENT_PROPERTY_RESP => \$data]); } # Returns the JDBC type code corresponding to a given DBI type code. sub _jdbc_type { my ($dbi_type) = @_; return $DBD::JDBC::Types{VARCHAR} if $dbi_type == SQL_VARCHAR; return $DBD::JDBC::Types{LONGVARCHAR} if $dbi_type == SQL_LONGVARCHAR; return $DBD::JDBC::Types{VARBINARY} if $dbi_type == SQL_VARBINARY; return $DBD::JDBC::Types{LONGVARBINARY} if $dbi_type == SQL_LONGVARBINARY; return $DBD::JDBC::Types{BIT} if $dbi_type == SQL_BIT; return $DBD::JDBC::Types{INTEGER} if $dbi_type == SQL_INTEGER; return $DBD::JDBC::Types{NUMERIC} if $dbi_type == SQL_NUMERIC; return $DBD::JDBC::Types{DECIMAL} if $dbi_type == SQL_DECIMAL; return $DBD::JDBC::Types{FLOAT} if $dbi_type == SQL_FLOAT; return $DBD::JDBC::Types{REAL} if $dbi_type == SQL_REAL; return $DBD::JDBC::Types{DOUBLE} if $dbi_type == SQL_DOUBLE; return $DBD::JDBC::Types{TINYINT} if $dbi_type == SQL_TINYINT; return $DBD::JDBC::Types{SMALLINT} if $dbi_type == SQL_SMALLINT; return $DBD::JDBC::Types{BIGINT} if $dbi_type == DBD::JDBC::SQL_BIGINT; return $DBD::JDBC::Types{BINARY} if $dbi_type == SQL_BINARY; return $DBD::JDBC::Types{CHAR} if $dbi_type == SQL_CHAR; return $DBD::JDBC::Types{DATE} if $dbi_type == SQL_DATE; return $DBD::JDBC::Types{TIME} if $dbi_type == SQL_TIME; return $DBD::JDBC::Types{TIMESTAMP} if $dbi_type == SQL_TIMESTAMP; return $DBD::JDBC::Types{ARRAY} if $dbi_type == SQL_ARRAY; return $DBD::JDBC::Types{BLOB} if $dbi_type == SQL_BLOB; return $DBD::JDBC::Types{CLOB} if $dbi_type == SQL_CLOB; return $DBD::JDBC::Types{REF} if $dbi_type == SQL_REF; # SQL_ALL_TYPES has no meaningful mapping. # There's no SQL_XXX type to map to null. undef; } # Returns the DBI type code correponding to the given JDBC # type. If there's no known mapping, the JDBC type is # returned. sub _dbi_type { my ($jdbc_type) = @_; return SQL_VARCHAR if $jdbc_type == $DBD::JDBC::Types{VARCHAR}; return SQL_LONGVARCHAR if $jdbc_type == $DBD::JDBC::Types{LONGVARCHAR}; return SQL_VARBINARY if $jdbc_type == $DBD::JDBC::Types{VARBINARY}; return SQL_LONGVARBINARY if $jdbc_type == $DBD::JDBC::Types{LONGVARBINARY}; return SQL_BIT if $jdbc_type == $DBD::JDBC::Types{BIT}; return SQL_INTEGER if $jdbc_type == $DBD::JDBC::Types{INTEGER}; return SQL_NUMERIC if $jdbc_type == $DBD::JDBC::Types{NUMERIC}; return SQL_DECIMAL if $jdbc_type == $DBD::JDBC::Types{DECIMAL}; return SQL_FLOAT if $jdbc_type == $DBD::JDBC::Types{FLOAT}; return SQL_REAL if $jdbc_type == $DBD::JDBC::Types{REAL}; return SQL_DOUBLE if $jdbc_type == $DBD::JDBC::Types{DOUBLE}; return SQL_TINYINT if $jdbc_type == $DBD::JDBC::Types{TINYINT}; return SQL_SMALLINT if $jdbc_type == $DBD::JDBC::Types{SMALLINT}; return DBD::JDBC::SQL_BIGINT if $jdbc_type == $DBD::JDBC::Types{BIGINT}; return SQL_BINARY if $jdbc_type == $DBD::JDBC::Types{BINARY}; return SQL_CHAR if $jdbc_type == $DBD::JDBC::Types{CHAR}; return SQL_DATE if $jdbc_type == $DBD::JDBC::Types{DATE}; return SQL_TIME if $jdbc_type == $DBD::JDBC::Types{TIME}; return SQL_TIMESTAMP if $jdbc_type == $DBD::JDBC::Types{TIMESTAMP}; return SQL_ARRAY if $jdbc_type == $DBD::JDBC::Types{ARRAY}; return SQL_BLOB if $jdbc_type == $DBD::JDBC::Types{BLOB}; return SQL_CLOB if $jdbc_type == $DBD::JDBC::Types{CLOB}; return SQL_REF if $jdbc_type == $DBD::JDBC::Types{REF}; return $jdbc_type; # May define exported jdbc_ constants for this. } } { # This package contains the Convert::BER subclass which # implements the application-specific BER packet types used # by this driver. I've overridden the pack/unpack behavior of # a few object types in a way consistent with Convert::BER # but not documented. # # To add a new message type # - add the request and response tag numbers # - add the type definitions to the call to define() # In the Java source, # - create classes for the objects # - add the tag numbers to BerDbdModule and register the # request's factory method # - add code to handle the request in Connection package DBD::JDBC::BER; use Convert::BER 1.31 qw(/^(\$|BER_|ber)/); use strict; use vars qw($VERSION @ISA); @ISA = qw(Convert::BER); $VERSION = $DBD::JDBC::VERSION; # Tag numbers. sub JDBC_MYSEQUENCE () { 0 } sub JDBC_ERROR_RESP () { 0xA + 1000 } sub JDBC_CONNECT_REQ () { 0xB } sub JDBC_CONNECT_RESP () { 0xB + 1000 } sub JDBC_DISCONNECT_REQ () { 0xC } sub JDBC_DISCONNECT_RESP () { 0xC + 1000 } sub JDBC_COMMIT_REQ () { 0xD } sub JDBC_COMMIT_RESP () { 0xD + 1000 } sub JDBC_ROLLBACK_REQ () { 0xE } sub JDBC_ROLLBACK_RESP () { 0xE + 1000 } sub JDBC_PREPARE_REQ () { 0xF } sub JDBC_PREPARE_RESP () { 0xF + 1000 } sub JDBC_EXECUTE_REQ () { 0x10 } sub JDBC_EXECUTE_RESP () { 0x10 + 1000 } sub JDBC_FETCH_REQ () { 0x11 } sub JDBC_FETCH_RESP () { 0x11 + 1000 } sub JDBC_EXECUTE_ROWS_RESP () { 0x12 + 1000 } sub JDBC_EXECUTE_RESULTSET_RESP () { 0x13 + 1000 } sub JDBC_GET_CONNECTION_PROPERTY_REQ () { 0x14 } sub JDBC_GET_CONNECTION_PROPERTY_RESP () { 0x14 + 1000 } sub JDBC_GET_STATEMENT_PROPERTY_REQ () { 0x15 } sub JDBC_GET_STATEMENT_PROPERTY_RESP () { 0x15 + 1000 } sub JDBC_SET_CONNECTION_PROPERTY_REQ () { 0x16 } sub JDBC_SET_CONNECTION_PROPERTY_RESP () { 0x16 + 1000 } sub JDBC_SET_STATEMENT_PROPERTY_REQ () { 0x17 } sub JDBC_SET_STATEMENT_PROPERTY_RESP () { 0x17 + 1000 } sub JDBC_STATEMENT_FINISH_REQ () { 0x18 } sub JDBC_STATEMENT_FINISH_RESP () { 0x18 + 1000 } sub JDBC_STATEMENT_DESTROY_REQ () { 0x19 } sub JDBC_STATEMENT_DESTROY_RESP () { 0x19 + 1000 } sub JDBC_PING_REQ () { 0x1A } sub JDBC_PING_RESP () { 0x1A + 1000 } sub JDBC_HASH() { 0x1B } sub JDBC_ERROR() { 0x1C } sub JDBC_CONNECTION_FUNC_REQ() { 0x1D } sub JDBC_CONNECTION_FUNC_RESP() { 0x1D + 1000 } # Either Convert::BER or the Java BER classes are failing # around 1E and 1F. Just skip those cases. sub JDBC_STATEMENT_FUNC_REQ() { 0x20 } sub JDBC_STATEMENT_FUNC_RESP() { 0x20 + 1000 } # Define name/type/tag triplets. DBD::JDBC::BER->define( [MYSEQUENCE => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_MYSEQUENCE())], [ERROR_RESP => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_ERROR_RESP())], [CONNECT_REQ => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_CONNECT_REQ())], [CONNECT_RESP => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_CONNECT_RESP())], [DISCONNECT_REQ => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_DISCONNECT_REQ())], [DISCONNECT_RESP => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_DISCONNECT_RESP())], [COMMIT_REQ=> $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_COMMIT_REQ())], [COMMIT_RESP => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_COMMIT_RESP())], [ROLLBACK_REQ => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_ROLLBACK_REQ())], [ROLLBACK_RESP => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_ROLLBACK_RESP())], [PREPARE_REQ => $STRING, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_PREPARE_REQ())], [PREPARE_RESP => $INTEGER, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_PREPARE_RESP())], [EXECUTE_REQ => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_EXECUTE_REQ())], [EXECUTE_RESP => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_EXECUTE_RESP())], [FETCH_REQ => $INTEGER, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_FETCH_REQ())], [FETCH_RESP => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_FETCH_RESP())], [EXECUTE_ROWS_RESP => $INTEGER, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_EXECUTE_ROWS_RESP())], [EXECUTE_RESULTSET_RESP => $INTEGER, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_EXECUTE_RESULTSET_RESP())], [GET_CONNECTION_PROPERTY_REQ => $STRING, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_GET_CONNECTION_PROPERTY_REQ())], [GET_CONNECTION_PROPERTY_RESP => 'MYSEQUENCE', ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_GET_CONNECTION_PROPERTY_RESP())], [SET_CONNECTION_PROPERTY_REQ => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_SET_CONNECTION_PROPERTY_REQ())], [SET_CONNECTION_PROPERTY_RESP => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_SET_CONNECTION_PROPERTY_RESP())], [GET_STATEMENT_PROPERTY_REQ => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_GET_STATEMENT_PROPERTY_REQ())], [GET_STATEMENT_PROPERTY_RESP => 'MYSEQUENCE', ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_GET_STATEMENT_PROPERTY_RESP())], [SET_STATEMENT_PROPERTY_REQ => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_SET_STATEMENT_PROPERTY_REQ())], [SET_STATEMENT_PROPERTY_RESP => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_SET_STATEMENT_PROPERTY_RESP())], [STATEMENT_FINISH_REQ => $INTEGER, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_STATEMENT_FINISH_REQ())], [STATEMENT_FINISH_RESP => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_STATEMENT_FINISH_RESP())], [STATEMENT_DESTROY_REQ => $INTEGER, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_STATEMENT_DESTROY_REQ())], [STATEMENT_DESTROY_RESP => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_STATEMENT_DESTROY_RESP())], [PING_REQ => $NULL, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_PING_REQ())], [PING_RESP => $INTEGER, ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_PING_RESP())], [HASH => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_HASH())], [ERROR => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_ERROR())], # I was going to have the func response objects just be # SEQUENCEs. However, when I tried to read the response data # with [XXX_FUNC_RESP => [ OPTIONAL => STRING, OPTIONAL => NULL] # (syntax approximate), I kept getting "buffer not empty" # errors, so I gave up and went to MYSEQUENCE. The dumps of the # buffers looked fine. [CONNECTION_FUNC_REQ => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_CONNECTION_FUNC_REQ())], [CONNECTION_FUNC_RESP => 'MYSEQUENCE', ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_CONNECTION_FUNC_RESP())], [STATEMENT_FUNC_REQ => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_STATEMENT_FUNC_REQ())], [STATEMENT_FUNC_RESP => 'MYSEQUENCE', ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_STATEMENT_FUNC_RESP())], ); } { package DBD::JDBC::BER::MYSEQUENCE; # I want to know the length of the contents, not the length of # the packet, so $ber->length doesn't suffice. sub _content_length { my ($self, $ber) = @_; my $pos = $ber->[ Convert::BER::_POS() ]; my $len = $ber->unpack_length(); $ber->[ Convert::BER::_POS() ] = $pos; $len; } sub unpack_array { my ($self, $ber, $arg) = @_; if ($self->_content_length($ber) == 0) { @$arg = (); return 1; } my ($ber2, $tag, $i, $field); # Unpack the buffer into a new BER object. $self->unpack($ber, \$ber2); # There should be a better way to do this. CHOICE, ANY, ... ??? # tag() will return undef when the end of the buffer is reached for ($i = 0; $tag = $ber2->tag(); $i++) { if ($tag == $ber2->NULL()) { $ber2->decode(NULL => \$field); push @$arg, undef; } elsif ($tag == $ber2->STRING()) { $ber2->decode(STRING => \$field); push @$arg, $field; } elsif ($tag == $ber2->INTEGER()) { $ber2->decode(INTEGER => \$field); push @$arg, $field; } } 1; } } { package DBD::JDBC::BER::EXECUTE_REQ; # Modified from Convert::BER::SEQUENCE; sub pack_array { my ($self, $ber, $arg) = @_; # $arg is an array ref my ($handle, $param_count, $param_list) = @$arg; # Convert::BER::_encode should have packed the tag value already. # Build up the message body using a new BER object. my $ber2 = $ber->new; $ber2->_encode([INTEGER => $handle]); # handle $ber2->_encode([INTEGER => $param_count]); # parameter count my $i = 0; while ($i < scalar(@$param_list)) { my ($value, $type) = ($param_list->[$i], $param_list->[$i+1]); $i += 2; # Parameters may be null, but a type will always be specified. defined $value ? $ber2->_encode([STRING => $value]) : $ber2->_encode([NULL => 0]); $ber2->_encode([INTEGER => $type]); } $ber->pack_length(CORE::length($ber2->[ Convert::BER::_BUFFER() ])); $ber->[ Convert::BER::_BUFFER() ] .= $ber2->[ Convert::BER::_BUFFER() ]; 1; } } { package DBD::JDBC::BER::FETCH_RESP; # Can this be another MYSEQUENCE? ??? sub unpack_array { my ($self, $ber, $arg) = @_; my ($ber2, $tag, $i, $field); $self->unpack($ber, \$ber2); # This value indicates whether or not there's a row to be decoded. $ber2->decode(INTEGER => \$i); push @$arg, $i; if ($i) { # tag() will return undef when the end of the buffer is reached while ($tag = $ber2->tag()) { if ($tag == $ber2->NULL()) { $ber2->decode(NULL => \$field); push @$arg, undef; } elsif ($tag == $ber2->STRING()) { $ber2->decode(STRING => \$field); push @$arg, $field; } $i++; # Used periodically in debugging. } } 1; } } { package DBD::JDBC::BER::ERROR_RESP; # This will push hash references containing the components of # ERROR packets onto the array argument. sub unpack_array { my ($self, $ber, $arg) = @_; my ($ber2); $self->unpack($ber, \$ber2); # tag() will return undef when the end of the buffer is reached; while ($ber2->tag()) { my %error; $ber2->decode(ERROR => [STRING => \$error{'errstr'}, STRING => \$error{'err'}, STRING => \$error{'state'}]); push @$arg, \%error; } 1; } } # A func request consists of a sequence in which the first # element is a method name and the remaining elements are # (alternating) values and typecodes. { package DBD::JDBC::BER::CONNECTION_FUNC_REQ; # Modified from Convert::BER::SEQUENCE; sub pack_array { my ($self, $ber, $arg) = @_; # $arg is an array ref my ($method, $param_list) = @$arg; # Convert::BER::_encode should have packed the tag value already. # Build up the message body using a new BER object. my $ber2 = $ber->new; $ber2->_encode([STRING => $method]); # method name my $i = 0; while ($i < scalar(@$param_list)) { my ($value, $type) = ($param_list->[$i], $param_list->[$i+1]); $i += 2; # Parameters may be null, but a type will always be specified. defined $value ? $ber2->_encode([STRING => $value]) : $ber2->_encode([NULL => 0]); $ber2->_encode([INTEGER => $type]); } $ber->pack_length(CORE::length($ber2->[ Convert::BER::_BUFFER() ])); $ber->[ Convert::BER::_BUFFER() ] .= $ber2->[ Convert::BER::_BUFFER() ]; 1; } } # A func request consists of a sequence in which the first # element is a method name, the second element is a statement # handle, and the remaining elements are (alternating) values and # typecodes. { package DBD::JDBC::BER::STATEMENT_FUNC_REQ; # Modified from Convert::BER::SEQUENCE; sub pack_array { my ($self, $ber, $arg) = @_; # $arg is an array ref my ($handle, $method, $param_list) = @$arg; # Convert::BER::_encode should have packed the tag value already. # Build up the message body using a new BER object. my $ber2 = $ber->new; $ber2->_encode([INTEGER => $handle]); # handle $ber2->_encode([STRING => $method]); # method name my $i = 0; while ($i < scalar(@$param_list)) { my ($value, $type) = ($param_list->[$i], $param_list->[$i+1]); $i += 2; # Parameters may be null, but a type will always be specified. defined $value ? $ber2->_encode([STRING => $value]) : $ber2->_encode([NULL => 0]); $ber2->_encode([INTEGER => $type]); } $ber->pack_length(CORE::length($ber2->[ Convert::BER::_BUFFER() ])); $ber->[ Convert::BER::_BUFFER() ] .= $ber2->[ Convert::BER::_BUFFER() ]; 1; } } ## ==================== package DBD::JDBC::ErrorMessages; # All error messages generated by DBD::JDBC, including the Java # server component, but not including messages generated by the # JDBC driver in use, are assigned a SQL state of 'IJDBC'. The # server uses error numbers in the range 0-99, and DBD::JDBC # proper uses error numbers in the range 100-199. Other error # number ranges may be assigned as needed. (Note that we can't # guarantee that the JDBC driver doesn't use the SQL state IJDBC; # if it does, the application will have to distinguish between # errors itself.) $DBD::JDBC::ErrorMessages::sql_state = "IJDBC"; # This one is used in die, not set_err. sub bad_autocommit_value($) { return "Unsupported AutoCommit value $_[0]"; } sub send_error($) { return (100, $_[0], $sql_state); } sub recv_error($) { return (101, $_[0], $sql_state); } sub ber_error($) { return (102, $_[0], $sql_state); } sub missing_dsn_component($) { return (103, "Missing $_[0] in dsn", $sql_state); } sub socket_error($) { return (104, "Failed to open socket to server: $_[0]", $sql_state); } sub bad_execute() { return (105, "Invalid execute response", $sql_state); } sub bad_func_method($) { return (106, "Invalid func method name: $_[0]", $sql_state); } 1;