#====================================================
#
#      Copyright 2008-2010 iAnywhere Solutions, Inc.
#
#   Licensed under the Apache License, Version 2.0 (the "License");
#   you may not use this file except in compliance with the License.
#   You may obtain a copy of the License at
#
#   http://www.apache.org/licenses/LICENSE-2.0
#
#   Unless required by applicable law or agreed to in writing, software
#   distributed under the License is distributed on an "AS IS" BASIS,
#   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#
#   See the License for the specific language governing permissions and
#   limitations under the License.
#
#   While not a requirement of the license, if you do modify this file, we
#   would appreciate hearing about it. Please email
#   sqlany_interfaces@sybase.com
#
#====================================================
require 5.002;
use strict;
use warnings;
{
    package DBD::SQLAnywhere;

    use DBI ();
    use DynaLoader ();
    use Exporter ();

    our $VERSION = '2.07';
    our @ISA = qw(DynaLoader Exporter);
    our %EXPORT_TAGS = (
	asa_types => [ qw(
	    ASA_SMALLINT ASA_INT ASA_DECIMAL ASA_FLOAT ASA_DOUBLE ASA_DATE
	    ASA_STRING ASA_FIXCHAR ASA_VARCHAR ASA_LONGVARCHAR ASA_TIME
	    ASA_TIMESTAMP ASA_TIMESTAMP_STRUCT ASA_BINARY ASA_LONGBINARY
	    ASA_VARIABLE ASA_TINYINT ASA_BIGINT ASA_UNSINT ASA_UNSSMALLINT
	    ASA_UNSBIGINT ASA_BIT ) ],
    );
    Exporter::export_ok_tags( 'asa_types' );

    my $Revision = substr(q$Revision: 1.57 $, 10);

    require_version DBI 1.51;

    bootstrap DBD::SQLAnywhere $VERSION;

    our $err = 0;		# holds error code   for DBI::err    (XXX SHARED!)
    our $errstr = "";	# holds error string for DBI::errstr (XXX SHARED!)
    our $drh = undef;	# holds driver handle once initialised

    sub CLONE {
	$drh = undef;
    }

    sub driver {
	return $drh if $drh;
	my($class, $attr) = @_;

	$class .= "::dr";

	# not a 'my' since we use it above to prevent multiple drivers

	$drh = DBI::_new_drh($class, {
	    'Name' => 'SQLAnywhere',
	    'Version' => $VERSION,
	    'Err'    => \$DBD::SQLAnywhere::err,
	    'Errstr' => \$DBD::SQLAnywhere::errstr,
	    'Attribution' => 'SQLAnywhere DBD by John Smirnios',
	    });

	if( !DBD::SQLAnywhere::dr::driver_init( $drh ) ) {
	    undef( $drh );
	}

	$drh;
    }

    1;
}


{   package DBD::SQLAnywhere::dr; # ====== DRIVER ======
    use strict;

    sub connect {
	my($drh, $dbname, $user, $auth, $attr)= @_;

	# NOTE!
	# 
	# For SQLAnywhere, $dbname and $user are appended to form an
	# SQLAnywhere connection string. 'UID=' is prefixed onto $user
	# if necessary. If $auth is nonempty, 'PWD=' is prefixed.
	# If dbname starts with something that doesn't look like
	# a connect string parameter ('label=value;' format) then
	# 'ENG=' is prefixed.
	my $conn_str;
	my $sqlcap;

	if( defined( $dbname ) ) {
	    $conn_str = $dbname;
	    $conn_str =~ s/^[\s;]*//;
	    $conn_str =~ s/[\s;]*$//;
	    if( $conn_str =~ /^[^=;]+($|;)/ ) {
		$conn_str = 'ENG=' . $conn_str;
	    }
	    
	    # look for undocumented option indicating the sqlca to use for
	    # server-side perl
	    if( $conn_str =~ /^ENG=saperl;sa_perl_sqlca=(0x)?([0-9a-fA-F]*)$/ ) {
	    	$sqlcap = $2;
	    }
	} else {
	    $conn_str = '';
	}
	if( defined( $user ) && ($user ne '') ) {
	    if( $user =~ /=/ ) {
		$conn_str .= ';' . $user;
	    } else {
		$conn_str .= ';UID=' . $user;
	    }
	}
	if( defined( $auth ) && ($auth ne '') ) {
	    $conn_str .= ';PWD=' . $auth;
	}

	# create a 'blank' dbh
	my $dbh = DBI::_new_dbh($drh, {
	    'Name' => $conn_str,
	    'USER' => $user, 'CURRENT_USER' => $user,
	    });

	# Call SQLAnywhere connect func in SQLAnywhere.xs file
	# and populate internal handle data.

	if( !DBD::SQLAnywhere::db::_login($dbh, $conn_str, 
					  (defined $sqlcap) ? $sqlcap : '', '', $attr) ) {
	    return undef;
	}

	$dbh;
    }
}


{   package DBD::SQLAnywhere::db; # ====== DATABASE ======
    use strict;

    sub prepare {
	my($dbh, $statement, @attribs)= @_;

	# create a 'blank' sth

	my $sth = DBI::_new_sth($dbh, {
	    'Statement' => $statement,
	    });

	# Call SQLAnywhere OCI oparse func in SQLAnywhere.xs file.
	# (This will actually also call oopen for you.)
	# and populate internal handle data.

	DBD::SQLAnywhere::st::_prepare($sth, $statement, @attribs)
	    or return undef;

	$sth;
    }


    sub ping {
	my($dbh) = @_;
	# we know that DBD::SQLAnywhere prepare does a describe so this will
	# actually talk to the server and is a valid and cheap test.
	return 1 if $dbh->prepare("select 1");
	return 0;
    }


# Use the DBI-provided quote routine
#    sub quote {
#	my($dbh, $value) = @_;
#	return $value;
#    }


#    sub quote_identifier {
#	my($dbh, $name) = @_;
#	return "\"".$name."\"";
#    }


    sub table_info {
	my($dbh,$catalogue,$schema,$table,$type)       = @_;		# XXX add qualification

	if ( !defined($schema) || $schema eq "" ) {
	    $schema = '%';
	}

	if ( !defined($table) || $table eq "" ) {
	    $table = '%';
	}

	if ( !defined($type) || $type eq "" ) {
	    # $type = 'TABLE,VIEW,SYSTEM TABLE,GLOBAL TEMPORARY,LOCAL TEMPORARY,ALIAS,SYNONYM';
	    $type = '%';
	}

	my $sth = $dbh->prepare("
        select
	    NULL as TABLE_CAT,
	    u.user_name as TABLE_SCHEM,
	    t.table_name as TABLE_NAME,
	    (if t.table_type = 'BASE' then (if t.creator = 0 then 'SYSTEM ' else '' endif) ||'TABLE'
		else (if t.table_type = 'GBL TEMP' then 'GLOBAL TEMPORARY' 
		      else t.table_type
		      endif)
		endif) as TABLE_TYPE,
	    t.remarks as REMARKS
	from SYS.SYSTABLE t, SYS.SYSUSERPERM u
	where t.creator = u.user_id
	  and u.user_name  like ?
 	  and t.table_name like ?
	  and TABLE_TYPE   like ?
	order by u.user_name, t.table_name
	") or return undef;
# and TABLE_TYPE  IN (?)
	$sth->bind_param( 1, $schema );
	$sth->bind_param( 2, $table );
	$sth->bind_param( 3, $type );
	$sth->execute or return undef;
	$sth;
    }


    sub type_info_all {
	my ($dbh) = @_;
	my $names = {
	    TYPE_NAME		=> 0,
	    DATA_TYPE		=> 1,
	    COLUMN_SIZE		=> 2,
	    LITERAL_PREFIX	=> 3,
	    LITERAL_SUFFIX	=> 4,
	    CREATE_PARAMS	=> 5,
	    NULLABLE		=> 6,
	    CASE_SENSITIVE	=> 7,
	    SEARCHABLE		=> 8,

	    UNSIGNED_ATTRIBUTE	=> 9,
	    FIXED_PREC_SCALE	=>10,
	    AUTO_UNIQUE_VALUE	=>11,
	    LOCAL_TYPE_NAME	=>12,
	    MINIMUM_SCALE	=>13,
	    MAXIMUM_SCALE	=>14,
	    SQL_DATA_TYPE	=>15,
	    SQL_DATETIME_SUB	=>16,
	    NUM_PREC_RADIX	=>17,
	};
	my $ti = [
	  $names,
	    [ 'bit', -7, 1, undef, undef, undef, 1, 0, 3,
	      1, undef, 0, undef, undef, undef, -7, undef, undef
	    ],
	    [ 'tinyint', -6, 4, undef, undef, undef, 1, 0, 3,
	      0, undef, 0, undef, undef, undef, -6, undef, undef
	    ],
	    [ 'bigint', -5, 20, undef, undef, undef, 1, 0, 3,
	      0, undef, 0, undef, undef, undef, -5, undef, undef
	    ],
	    [ 'unsigned bigint', -5, 20, undef, undef, undef, 1, 0, 3,
	      1, undef, 0, undef, undef, undef, -5, undef, undef
	    ],
	    [ 'long binary', -4, 2147483647, '\'', '\'', undef, 1, 0, 3,
	      undef, undef, undef, undef, undef, undef, -4, undef, undef
	    ],
	    [ 'binary', -2, 65535, '\'', '\'', 'max length', 1, 0, 3,
	      undef, undef, undef, undef, undef, undef, -2, undef, undef
	    ],
	    [ 'varbinary', -2, 65535, '\'', '\'', 'max length', 1, 0, 3,
	      undef, undef, undef, undef, undef, undef, -2, undef, undef
	    ],
	    [ 'long varchar', -1, 2147483647, '\'', '\'', undef, 1, 0, 3,
	      undef, undef, undef, undef, undef, undef, -1, undef, undef
	    ],
	    [ 'char', 1, 65535, '\'', '\'', 'max length', 1, 0, 3,
	      undef, undef, undef, undef, undef, undef, 1, undef, undef
	    ],
	    [ 'decimal', 2, 127, undef, undef, 'precision, scale', 1, 0, 3,
	      0, 0, 0, undef, 0, 127, 2, undef, 10
	    ],
	    [ 'numeric', 2, 127, undef, undef, 'precision, scale', 1, 0, 3,
	      0, 0, 0, undef, 0, 127, 2, undef, 10
	    ],
	    [ 'money', 3, 4, undef, undef, undef, 1, 0, 3,
	      0, 1, 0, undef, 4, 4, 3, undef, 10
	    ],
	    [ 'smallmoney', 3, 4, undef, undef, undef, 1, 0, 3,
	      0, 1, 0, undef, 4, 4, 3, undef, 10
	    ],
	    [ 'integer', 4, 10, undef, undef, undef, 1, 0, 3,
	      0, undef, 0, undef, 0, 0, 4, undef, undef
	    ],
	    [ 'unsigned int', 4, 10, undef, undef, undef, 1, 0, 3,
	      1, undef, 0, undef, undef, undef, 4, undef, undef
	    ],
	    [ 'smallint', 5, 6, undef, undef, undef, 1, 0, 3,
	      0, undef, 0, undef, 0, 0, 5, undef, undef
	    ],
	    [ 'unsigned smallint', 5, 5, undef, undef, undef, 1, 0, 3,
	      1, undef, 0, undef, undef, undef, 5, undef, undef
	    ],
	    [ 'double', 6, 64, undef, undef, undef, 1, 0, 3,
	      0, undef, 0, undef, undef, undef, 6, undef, 2
	    ],
	    [ 'float', 7, undef, undef, undef, undef, 1, 0, 3,
	      0, undef, 0, undef, undef, undef, 7, undef, 32
	    ],
	    [ 'double', 8, 64, undef, undef, undef, 1, 0, 3,
	      0, undef, 0, undef, undef, undef, 8, undef, 2
	    ],
	    [ 'varchar', 12, 65535, '\'', '\'', 'max length', 1, 0, 3,
	      undef, undef, undef, undef, undef, undef, 12, undef, undef
	    ]
        ];
	return $ti;
    }


    sub column_info {
	my($dbh,$catalogue,$schema,$table,$column)       = @_;		# XXX add qualification

	if( !defined($schema) || $schema eq "" ) {
	    $schema = '%';
	}

	if( !defined($table) || $table eq "" ) {
	    $table = '%';
	}

	if( !defined($column) || $column eq "" ) {
	    $column = '%';
	}

	my $sth = $dbh->prepare("
        select
	    NULL as TABLE_CAT,
	    u.user_name as TABLE_SCHEM,
	    t.table_name as TABLE_NAME,
	    c.column_name as COLUMN_NAME,
	    d.domain_id as DATA_TYPE, 
            d.domain_name AS TYPE_NAME,
	    c.width AS COLUMN_SIZE,
	    c.width AS BUFFER_LENGTH,
            c.width AS DECIMAL_DIGITS, 
	    c.scale AS NUM_PREC_RADIX,
	    IF c.nulls = 'Y' THEN 1 ELSE 0 ENDIF AS NULLABLE,
	    c.remarks AS REMARKS,
            c.\"default\" AS COLUMN_DEF, 
            d.domain_name AS SQL_DATA_TYPE,
            NULL AS SQL_DATETIME_SUB,
	    c.width AS CHAR_OCTET_LENGTH,
	    c.column_id AS ORDINAL_POSITION,
	    c.nulls AS IS_NULLABLE,
            NULL AS CHAR_SET_CAT,
	    NULL AS CHAR_SET_SCHEM,
	    NULL AS CHAR_SET_NAME,
	    NULL AS COLLATION_CAT,
	    NULL AS COLLATION_SCHEM,
	    NULL AS COLLATION_NAME,
	    NULL AS UDT_CAT,
	    NULL AS UDT_SCHEM,
	    NULL AS UDT_NAME,
	    NULL AS DOMAIN_CAT,
	    NULL AS DOMAIN_SCHEM,
	    NULL AS DOMAIN_NAME,
	    NULL AS SCOPE_CAT,
	    NULL AS SCOPE_SCHEM,
	    NULL AS SCOPE_NAME,
	    NULL AS MAX_CARDINALITY,
	    NULL AS DTD_IDENTIFIER,
	    NULL AS IS_SELF_REF
	    from SYS.SYSTABLE t
	   , SYS.SYSUSERPERM u
	   , SYS.SYSCOLUMN c
	   , SYS.SYSDOMAIN d
	where t.creator     = u.user_id
	  and t.table_id    = c.table_id
	  and c.domain_id   = d.domain_id
	  and u.user_name   like ?
	  and t.table_name  like ?
	  and c.column_name like ?
	order by c.column_id
	") or return undef;
	$sth->bind_param(1, $schema); 
	$sth->bind_param(2, $table); 
	$sth->bind_param(3, $column); 
	$sth->execute or return undef;
	$sth;
    }


    sub primary_key_info {
	my($dbh,$catalogue,$schema,$table,$column)       = @_;		# XXX add qualification

	if ( !defined($schema) || $schema eq "" ) {
	    $schema = '%';
	}

	if ( !defined($table) || $table eq "" ) {
	    $table = '%';
	}

	if ( !defined($column) || $column eq "" ) {
	    $column = '%';
	}

	my $sth = $dbh->prepare("
        select
	    NULL as TABLE_CAT,
	    u.user_name as TABLE_SCHEM,
	    t.table_name as TABLE_NAME,
	    c.column_name as COLUMN_NAME,
	    c.column_id AS KEY_SEQ,
	    i.index_name as PK_NAME
	from SYS.SYSTABLE t
       , SYS.SYSUSERPERM u
       , SYS.SYSCOLUMN c
       , SYS.SYSIDX i
	where t.creator     = u.user_id
	  and t.table_id    = c.table_id
	  and t.table_id    = i.table_id
	  and i.index_id    = 0
      and c.pkey        = 'Y'
      and u.user_name   like ?
      and t.table_name  like ?
      and c.column_name like ?
    order by c.column_id
	") or return undef;
	$sth->bind_param(1, $schema); 
	$sth->bind_param(2, $table); 
	$sth->bind_param(3, $column); 
	$sth->execute or return undef;
	$sth;
    }

    sub get_info {
        my($dbh, $info_type) = @_;
        require DBD::SQLAnywhere::GetInfo;
        my $v = $DBD::SQLAnywhere::GetInfo::info{int($info_type)};
        $v = $v->($dbh) if ref $v eq 'CODE';
        return $v;
    }

    sub statistics_info {
	my($dbh,$catalogue,$schema,$table,$unique_only,$quick) = @_;	# XXX add qualification

	if ( !defined($schema) || $schema eq "" ) {
	    $schema = '%';
	}

	if ( !defined($table) || $table eq "" ) {
	    $table = '%';
	}

	if ( defined($unique_only) && $unique_only == 1 ) {
	    $unique_only = 2;
	}

        # quick ignored for now
	if ( !defined($quick) || $quick eq "" || $quick != 1 ) {
	    $quick = 0;
	}

	my $sth = $dbh->prepare("
        select
	    NULL as TABLE_CAT,
	    u.user_name as TABLE_SCHEM,
	    t.table_name as TABLE_NAME,
	    IF i.\"unique\" = '1' THEN 1 ELSE 0 ENDIF as NON_UNIQUE,
	    t.table_name ||'.'|| i.index_name as INDEX_QUALIFIER,
	    i.index_name as INDEX_NAME,
	    'table' as TYPE,
	    NULL as ORDINAL_POSITION,
	    NULL as COLUMN_NAME,
	    NULL as ASC_OR_DESC,
	    NULL as CARDINALITY,
	    NULL as PAGES,
	    NULL as FILTER_CONDITION
	from SYS.SYSTABLE t
	, SYS.SYSUSERPERM u
	, SYS.SYSIDX i
	where t.creator  = u.user_id
	  and t.table_id = i.table_id
	  and u.user_name  like ?
 	  and t.table_name like ?
 	  and i.\"unique\"     like ?
	order by u.user_name, t.table_name
	") or return undef;
	$sth->bind_param( 1, $schema );
	$sth->bind_param( 2, $table );
	$sth->bind_param( 3, $unique_only );
#	$sth->bind_param( 4, $quick );
	$sth->execute or return undef;
	$sth;
    }

    sub last_insert_rowid {
	my($dbh,$source,$col) = @_;

	my $sth = $dbh->prepare("
         select \@\@IDENTITY
	") or return undef;
	$sth->execute or return undef;
        my @ida = $sth->fetchrow_array();
        return @ida ? $ida[0] : undef;
    }


}   # end of package DBD::SQLAnywhere::db


{   package DBD::SQLAnywhere::st; # ====== STATEMENT ======

    # all done in XS
}

1;

__END__

