# $Id: JDBC.pm,v 1.49 2008/12/17 00:05:23 gemerson Exp $
#
#  Copyright 1999-2001,2005,2008 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.
# There's a warning in (some) later versions of Perl about the 
# string used here in require, so try to ignore that.
{ no warnings qw(portable); require 5.8.0; }
{
    package DBD::JDBC;
    use DBI 1.48;
    require Exporter; 
    @ISA = qw(Exporter); 
    # DBI 1.54 added SQL_BIGINT back.
    if ($DBI::VERSION > 1.54) {
        %EXPORT_TAGS = ( sql_types => [ ], ); 
        @EXPORT_OK = ();
    }
    else {
        %EXPORT_TAGS = ( sql_types => [ qw( SQL_BIGINT ) ], ); 
        @EXPORT_OK = qw(SQL_BIGINT);
    }
    use vars qw($methods_installed); 
    $DBD::JDBC::VERSION = '0.71';
     
    $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', {});
            DBD::JDBC::db->install_method('jdbc_disconnect', {});
        }
        $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=<host>[:port];[port=<port>;]url=<url>[;jdbc_character_set=<encoding>]
        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);
        my $lra = $drh->FETCH('jdbc_longreadall');
        $dbh->STORE('jdbc_longreadall' => ((defined $lra) ? $lra : 1));
        $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, $params) = @_;
        my ($debug) = $dbh->trace();
         
        my ($keyType, $keyTypeCode, $keyList) = (undef, 'STRING', []); 
        if ($params && $params->{'jdbc_columnnames'}) {
            $keyType = "name"; 
            $keyList = $params->{'jdbc_columnnames'}; 
        }
        elsif ($params && $params->{'jdbc_columnindexes'}) {
            $keyType = "index"; 
            $keyTypeCode = 'INTEGER';
            $keyList = $params->{'jdbc_columnindexes'}; 
        }
        my ($statement_handle);
        return undef unless
            _send_request($dbh,
                          $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'),
                          [PREPARE_REQ => [STRING => $statement, 
                                           ($keyType?'STRING':'NULL') => $keyType, 
                                           $keyTypeCode => [@$keyList] ] ],
                          [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->STORE('jdbc_longreadall' => 
            $dbh->FETCH('jdbc_longreadall') ? 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;
    }
    # A private disconnect method which can be called from user
    # code even in environments such as Apache::DBI which disable
    # the standard disconnect. It's possible for a JDBC exception
    # to be returned which indicates that the underlying database
    # connection is non-functional. The DBD::JDBC server doesn't
    # know anything about specific database error codes, so it
    # can't handle the exception, but user code may be able to
    # tell that the connection should be closed.
    sub jdbc_disconnect {
        my ($dbh) = shift;
        disconnect($dbh);
    }
    # 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);
    } 
    # Implementation of last_insert_id.
    sub last_insert_id {
        my ($dbh, $catalog, $schema, $table, $field) = @_; 
        my $key; 
        return undef unless
            _send_request($dbh, 
                          $dbh->FETCH('jdbc_socket'), $dbh->FETCH('jdbc_ber'),
                          [GET_GENERATED_KEYS_REQ => [($catalog?'STRING':'NULL') => $catalog, 
                                                      ($schema?'STRING':'NULL') => $schema,
                                                      ($table?'STRING':'NULL') => $table, 
                                                      ($field?'STRING':'NULL') => $field]],
                          [GET_GENERATED_KEYS_RESP => \$key]); 
        return $key; 
    }
    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;
    # TODO: 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;
            my $ok = 1; 
            if ($attr eq 'jdbc_longreadall') {
                $value = ($value ? 1 : 0);  # Canonicalize for server.
                $sth->{$attr} = $value;
                $ok = _set_attr($sth, $attr, $value);
            }
            ## TODO: how should we report an error in storing on the server?
            return; 
        }
         
        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 $@);
        ## Calling finish as $sth->finish interferes with
        ## $DBI::errstr after this DESTROY completes. Calling
        ## finish($sth) doesn't. All we're currently after is
        ## setting Active to false, so it's possible that we
        ## should just do that explicitly here, but if finish
        ## ever does something else, we might want that something
        ## also.
        finish($sth);
        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 }
    sub JDBC_GET_GENERATED_KEYS_REQ()          { 0x21 }
    sub JDBC_GET_GENERATED_KEYS_RESP()         { 0x21 + 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_REQ  => $SEQUENCE,  
  ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, 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())],
 [GET_GENERATED_KEYS_REQ => $SEQUENCE,  
  ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, JDBC_GET_GENERATED_KEYS_REQ())],
 [GET_GENERATED_KEYS_RESP => $STRING,
  ber_tag(BER_APPLICATION | BER_PRIMITIVE, JDBC_GET_GENERATED_KEYS_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);
         
        # TODO: 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;
    # TODO: 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;