#line 1 "DBD/Firebird.pm"
#
#   Copyright (c) 2011  Marius Popa <mapopa@gmail.com>
#   Copyright (c) 2011  Damyan Ivanov <dmn@debian.org>
#   Copyright (c) 1999-2008 Edwin Pratomo
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file

require 5.008001;

package DBD::Firebird;
use strict;
use warnings;
use Carp;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
use DBI 1.41 ();
require Exporter;
require DynaLoader;

@ISA = qw(Exporter DynaLoader);
$VERSION = '1.22';

bootstrap DBD::Firebird $VERSION;

use vars qw($VERSION $err $errstr $drh);

$err = 0;
$errstr = "";
$drh = undef;


sub CLONE
{
    $drh = undef;
}


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

    $class .= "::dr";

    $drh = DBI::_new_drh($class, {'Name' => 'Firebird',
                                  'Version' => $VERSION,
                                  'Err'    => \$DBD::Firebird::err,
                                  'Errstr' => \$DBD::Firebird::errstr,
                                  'Attribution' => 'DBD::Firebird by Edwin Pratomo and Daniel Ritz'});
    $drh;
}

# taken from JWIED's DBD::mysql, with slight modification
sub _OdbcParse($$$) 
{
    my($class, $dsn, $hash, $args) = @_;
    my($var, $val);

    if (!defined($dsn))
       { return; }

    while (length($dsn)) 
    {
        if ($dsn =~ /([^;]*)[;]\r?\n?(.*)/s) 
        {
            $val = $1;
            $dsn = $2;
        } 
        else 
        {
            $val = $dsn;
            $dsn = '';
        }
        if ($val =~ /([^=]*)=(.*)/) 
        {
            $var = $1;
            $val = $2;
            if ($var eq 'hostname') 
                { $hash->{'host'} = $val; } 
            elsif ($var eq 'db'  ||  $var eq 'dbname') 
                { $hash->{'database'} = $val; } 
            else 
                { $hash->{$var} = $val; }
        } 
        else 
        {
            foreach $var (@$args) 
            {
                if (!defined($hash->{$var})) 
                {
                    $hash->{$var} = $val;
                    last;
                }
            }
        }
    }
    $hash->{host} = "$hash->{host}/$hash->{port}" if ($hash->{host} && $hash->{port});
    $hash->{database} = "$hash->{host}:$hash->{database}" if $hash->{host};
}

sub create_database {
    my ( $self, $params ) = ( shift, shift );
    $self and $params and ref($params) and ref($params) eq 'HASH' and not @_
        or croak 'Usage: '
        . __PACKAGE__
        . '->create_database( { params...} )';

    exists $params->{db_path} and defined( $params->{db_path} )
        or croak "Required parameter 'db_path' not supplied";

    for( qw(db_path user password character_set) ) {
        next unless exists $params->{$_};

        $params->{$_} =~ s/'/''/g if defined($params->{$_});
    }

    DBD::Firebird::db::_create_database($params);
}

sub gfix {
    my ( $self, $params ) = ( shift, shift );
    $self and $params and ref($params) and ref($params) eq 'HASH' and not @_
        or croak 'Usage: '
        . __PACKAGE__
        . '->gfix( { params...} )';

    DBD::Firebird::db::_gfix($params);
}

package DBD::Firebird::dr;

sub connect 
{
    my($drh, $dsn, $dbuser, $dbpasswd, $attr) = @_;

    $dbuser   ||= $ENV{ISC_USER};       #"SYSDBA";
    $dbpasswd ||= $ENV{ISC_PASSWORD};   #"masterkey";

    my ($this, $private_attr_hash);

    $private_attr_hash = {
        'Name' => $dsn,
        'user' => $dbuser,
        'password' => $dbpasswd
    };

    DBD::Firebird->_OdbcParse($dsn, $private_attr_hash,
                               ['database', 'host', 'port', 'ib_role', 'ib_dbkey_scope',
                                'ib_charset', 'ib_dialect', 'ib_cache', 'ib_lc_time']);
    $private_attr_hash->{database} ||= $ENV{ISC_DATABASE}; #"employee.fdb"

    my ($dbh_name) = ($dsn =~ /(db=[^;]+)/);
    $dbh_name ||= "db=$private_attr_hash->{database}";
    my $dbh = DBI::_new_dbh($drh,
                            { Name => $dbh_name },
                            $private_attr_hash);

    DBD::Firebird::db::_login($dbh, $dsn, $dbuser, $dbpasswd, $attr) 
        or return undef;

    $dbh;
}

package DBD::Firebird::db;
use strict;
use Carp;

sub do 
{
    my($dbh, $statement, $attr, @params) = @_;
    my $rows;
    if (@params) 
    {
        my $sth = $dbh->prepare($statement, $attr) or return undef;
        defined($sth->execute(@params)) or return undef;
        $rows = $sth->rows;
    } 
    else 
    {
        $rows = DBD::Firebird::db::_do($dbh, $statement, $attr);
        return undef unless defined($rows);
    }
    ($rows == 0) ? "0E0" : $rows;
}

sub prepare 
{
    my ($dbh, $statement, $attribs) = @_;
    
    my $sth = DBI::_new_sth($dbh, {'Statement' => $statement });
    DBD::Firebird::st::_prepare($sth, $statement, $attribs)
        or return undef;
    $sth;
}

sub primary_key_info
{
    my ($dbh, undef, undef, $tbl) = @_;

    my $sth = $dbh->prepare(<<'__eosql');
    SELECT CAST(NULL AS CHAR(1))       AS TABLE_CAT,
           CAST(NULL AS CHAR(1))       AS TABLE_SCHEM,
           rc.rdb$relation_name        AS TABLE_NAME,
           ix.rdb$field_name           AS COLUMN_NAME,
           ix.rdb$field_position + 1   AS KEY_SEQ,
           rc.rdb$index_name           AS PK_NAME
      FROM rdb$relation_constraints rc
           INNER JOIN
           rdb$index_segments ix
             ON rc.rdb$index_name = ix.rdb$index_name
     WHERE rc.rdb$relation_name = ?
           AND
           rc.rdb$constraint_type = 'PRIMARY KEY'
  ORDER BY 1, 2, 3, 5
__eosql

    if ($sth) {
        $sth->{ChopBlanks} = 1;
        return unless $sth->execute($tbl);
    }

    $sth;
}

sub table_info
{
    my ($self, $cat, $schem, $name, $type, $attr) = @_;

    require DBD::Firebird::TableInfo;

    my $ti = ($self->{private_table_info}
               ||=
              DBD::Firebird::TableInfo->factory($self));

    no warnings 'uninitialized';
    if ($cat eq '%' and $schem eq '' and $name eq '') {
        return $ti->list_catalogs($self);
    } elsif ($cat eq '' and $schem eq '%' and $name eq '') {
        return $ti->list_schema($self);
    } elsif ($cat eq '' and $schem eq '' and $name eq '' and $type eq '%') {
        return $ti->list_types($self);
    } else {
        my %seen;
        $type = '' if $type eq '%';

        # normalize $type specifiers:  upcase, strip quote and uniqify
        my @types = grep { length and not $seen{$_}++ }
                        map { s/'//g; s/^\s+//; s/\s+$//; uc }
                            split(',' => $type);
        return $ti->list_tables($self, $name, @types);
    }
}

sub ping
{
    my($dbh) = @_;

    local $SIG{__WARN__} = sub { } if $dbh->{PrintError};
    local $dbh->{RaiseError} = 0 if $dbh->{RaiseError};
    my $ret = DBD::Firebird::db::_ping($dbh);

    return $ret;
}

# The get_info function was automatically generated by
# DBI::DBD::Metadata::write_getinfo_pm v1.05.

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

# The type_info_all function was automatically generated by
# DBI::DBD::Metadata::write_typeinfo_pm v1.05.

sub type_info_all
{
    my ($dbh) = @_;
    require DBD::Firebird::TypeInfo;
    return [ @$DBD::Firebird::TypeInfo::type_info_all ];
}

1;

package DBD::Firebird::st;

# taken from DBI.pm, with this only change:
#  - remove the call to bind_param without value when $attr is set
#    * it fails when the column can't contain NULLs
#    * it is not necessary anyway, as we allocate param placeholder
#      structures according to Firebird's ananysis of the SQL, not
#      according to the datatype the supplied in $attr
sub bind_param_array {
    my $sth = shift;
    my ($p_id, $value_array, $attr) = @_;

    return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
        if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY';

    return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array")
        unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here

    return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range")
        if $p_id <= 0; # can't easily/reliably test for too big

    # get/create arrayref to hold params
    my $hash_of_arrays = $sth->{ParamArrays} ||= { };

    $$hash_of_arrays{$p_id} = $value_array;

    1;
}

1;

__END__

#line 1581
