[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / ODBC / ACCESS.pm

package DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS;

use strict;
use warnings;
use base 'DBIx::Class::Schema::Loader::DBI::ODBC';
use mro 'c3';
use Try::Tiny;
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();

our $VERSION = '0.07047';

__PACKAGE__->mk_group_accessors('simple', qw/
    __ado_connection
    __adox_catalog
/);

=head1 NAME

DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS - Microsoft Access driver for
DBIx::Class::Schema::Loader

=head1 DESCRIPTION

See L<DBIx::Class::Schema::Loader::Base> for usage information.

=cut

sub _supports_db_schema { 0 }

sub _db_path {
    my $self = shift;

    $self->schema->storage->dbh->get_info(16);
}

sub _open_ado_connection {
    my ($self, $conn, $user, $pass) = @_;

    my @info = ({
        provider => 'Microsoft.ACE.OLEDB.12.0',
        dsn_extra => 'Persist Security Info=False',
    }, {
        provider => 'Microsoft.Jet.OLEDB.4.0',
    });

    my $opened = 0;
    my $exception;

    for my $info (@info) {
        $conn->{Provider} = $info->{provider};

        my $dsn = 'Data Source='.($self->_db_path);
        $dsn .= ";$info->{dsn_extra}" if exists $info->{dsn_extra};

        try {
            $conn->Open($dsn, $user, $pass);
            undef $exception;
        }
        catch {
            $exception = $_;
        };

        next if $exception;

        $opened = 1;
        last;
    }

    return ($opened, $exception);
}


sub _ado_connection {
    my $self = shift;

    return $self->__ado_connection if $self->__ado_connection;

    my ($dsn, $user, $pass) = @{ $self->schema->storage->_dbi_connect_info };

    my $have_pass = 1;

    if (ref $dsn eq 'CODE') {
        ($dsn, $user, $pass) = $self->_try_infer_connect_info_from_coderef($dsn);

        if (not $dsn) {
            my $dbh = $self->schema->storage->dbh;
            $dsn  = $dbh->{Name};
            $user = $dbh->{Username};
            $have_pass = 0;
        }
    }

    require Win32::OLE;
    my $conn = Win32::OLE->new('ADODB.Connection');

    $user = '' unless defined $user;
    if ((not $have_pass) && exists $self->_passwords->{$dsn}{$user}) {
        $pass = $self->_passwords->{$dsn}{$user};
        $have_pass = 1;
    }
    $pass = '' unless defined $pass;

    my ($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);

    if ((not $opened) && (not $have_pass)) {
        if (exists $ENV{DBI_PASS}) {
            $pass = $ENV{DBI_PASS};

            ($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);

            if ($opened) {
                $self->_passwords->{$dsn}{$user} = $pass;
            }
            else {
                print "Enter database password for $user ($dsn): ";
                chomp($pass = <STDIN>);

                ($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);

                if ($opened) {
                    $self->_passwords->{$dsn}{$user} = $pass;
                }
            }
        }
        else {
            print "Enter database password for $user ($dsn): ";
            chomp($pass = <STDIN>);

            ($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);

            if ($opened) {
                $self->_passwords->{$dsn}{$user} = $pass;
            }
        }
    }

    if (not $opened) {
        die "Failed to open ADO connection: $exception";
    }

    $self->__ado_connection($conn);

    return $conn;
}

sub _adox_catalog {
    my $self = shift;

    return $self->__adox_catalog if $self->__adox_catalog;

    require Win32::OLE;
    my $cat = Win32::OLE->new('ADOX.Catalog');
    $cat->{ActiveConnection} = $self->_ado_connection;

    $self->__adox_catalog($cat);

    return $cat;
}

sub _adox_column {
    my ($self, $table, $col) = @_;

    my $col_obj;

    my $cols = $self->_adox_catalog->Tables->Item($table->name)->Columns;

    for my $col_idx (0..$cols->Count-1) {
        $col_obj = $cols->Item($col_idx);
        if ($self->preserve_case) {
            last if $col_obj->Name eq $col;
        }
        else {
            last if lc($col_obj->Name) eq lc($col);
        }
    }

    return $col_obj;
}

sub rescan {
    my $self = shift;

    if ($self->__adox_catalog) {
        $self->__ado_connection(undef);
        $self->__adox_catalog(undef);
    }

    return $self->next::method(@_);
}

sub _table_pk_info {
    my ($self, $table) = @_;

    return [] if $self->_disable_pk_detection;

    my @keydata;

    my $indexes = try {
        $self->_adox_catalog->Tables->Item($table->name)->Indexes
    }
    catch {
        warn "Could not retrieve indexes in table '$table', disabling primary key detection: $_\n";
        return undef;
    };

    if (not $indexes) {
        $self->_disable_pk_detection(1);
        return [];
    }

    for my $idx_num (0..($indexes->Count-1)) {
        my $idx = $indexes->Item($idx_num);
        if ($idx->PrimaryKey) {
            my $cols = $idx->Columns;
            for my $col_idx (0..$cols->Count-1) {
                push @keydata, $self->_lc($cols->Item($col_idx)->Name);
            }
        }
    }

    return \@keydata;
}

sub _table_fk_info {
    my ($self, $table) = @_;

    return [] if $self->_disable_fk_detection;

    my $keys = try {
        $self->_adox_catalog->Tables->Item($table->name)->Keys;
    }
    catch {
        warn "Could not retrieve keys in table '$table', disabling relationship detection: $_\n";
        return undef;
    };

    if (not $keys) {
        $self->_disable_fk_detection(1);
        return [];
    }

    my @rels;

    for my $key_idx (0..($keys->Count-1)) {
        my $key = $keys->Item($key_idx);

        next unless $key->Type == 2;

        my $local_cols   = $key->Columns;
        my $remote_table = $key->RelatedTable;
        my (@local_cols, @remote_cols);

        for my $col_idx (0..$local_cols->Count-1) {
            my $col = $local_cols->Item($col_idx);
            push @local_cols,  $self->_lc($col->Name);
            push @remote_cols, $self->_lc($col->RelatedColumn);
        }

        push @rels, {
            local_columns => \@local_cols,
            remote_columns => \@remote_cols,
            remote_table => DBIx::Class::Schema::Loader::Table->new(
                loader => $self,
                name   => $remote_table,
                ($self->db_schema ? (
                    schema        => $self->db_schema->[0],
                    ignore_schema => 1,
                ) : ()),
            ),
        };
    }

    return \@rels;
}

sub _columns_info_for {
    my $self    = shift;
    my ($table) = @_;

    my $result = $self->next::method(@_);

    while (my ($col, $info) = each %$result) {
        my $data_type = $info->{data_type};

        my $col_obj = $self->_adox_column($table, $col);

        $info->{is_nullable} = ($col_obj->Attributes & 2) == 2 ? 1 : 0;

        if ($data_type eq 'counter') {
            $info->{data_type} = 'integer';
            $info->{is_auto_increment} = 1;
            delete $info->{size};
        }
        elsif ($data_type eq 'longbinary') {
            $info->{data_type} = 'image';
            $info->{original}{data_type} = 'longbinary';
        }
        elsif ($data_type eq 'longchar') {
            $info->{data_type} = 'text';
            $info->{original}{data_type} = 'longchar';
        }
        elsif ($data_type eq 'double') {
            $info->{data_type} = 'double precision';
            $info->{original}{data_type} = 'double';
        }
        elsif ($data_type eq 'guid') {
            $info->{data_type} = 'uniqueidentifier';
            $info->{original}{data_type} = 'guid';
        }
        elsif ($data_type eq 'byte') {
            $info->{data_type} = 'tinyint';
            $info->{original}{data_type} = 'byte';
        }
        elsif ($data_type eq 'currency') {
            $info->{data_type} = 'money';
            $info->{original}{data_type} = 'currency';

            if (ref $info->{size} eq 'ARRAY' && $info->{size}[0] == 19 && $info->{size}[1] == 4) {
                # Actual money column via ODBC, otherwise we pass the sizes on to the ADO driver for
                # decimal columns (which masquerade as money columns...)
                delete $info->{size};
            }
        }
        elsif ($data_type eq 'decimal') {
            if (ref $info->{size} eq 'ARRAY' && $info->{size}[0] == 18 && $info->{size}[1] == 0) {
                delete $info->{size};
            }
        }

# Pass through currency (which can be decimal for ADO.)
        if ($data_type !~ /^(?:(?:var)?(?:char|binary)|decimal)\z/ && $data_type ne 'currency') {
            delete $info->{size};
        }
    }

    return $result;
}

=head1 SEE ALSO

L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>

=head1 AUTHORS

See L<DBIx::Class::Schema::Loader/AUTHORS>.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;
# vim:et sts=4 sw=4 tw=0:
Commit	Line	Data
3b17d988	1	package DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS;
	2
	3	use strict;
	4	use warnings;
383bd2a8	5	use base 'DBIx::Class::Schema::Loader::DBI::ODBC';
3b17d988	6	use mro 'c3';
3b17d988	7	use Try::Tiny;
3b17d988	8	use namespace::clean;
c4a69b87	9	use DBIx::Class::Schema::Loader::Table ();
3b17d988	10
306bf770	11	our $VERSION = '0.07047';
3b17d988	12
	13	__PACKAGE__->mk_group_accessors('simple', qw/
	14	__ado_connection
	15	__adox_catalog
	16	/);
	17
	18	=head1 NAME
	19
	20	DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS - Microsoft Access driver for
	21	DBIx::Class::Schema::Loader
	22
	23	=head1 DESCRIPTION
	24
	25	See L<DBIx::Class::Schema::Loader::Base> for usage information.
	26
	27	=cut
	28
c4a69b87	29	sub _supports_db_schema { 0 }
c4a69b87	30
3b17d988	31	sub _db_path {
	32	my $self = shift;
	33
	34	$self->schema->storage->dbh->get_info(16);
	35	}
	36
	37	sub _open_ado_connection {
	38	my ($self, $conn, $user, $pass) = @_;
	39
	40	my @info = ({
	41	provider => 'Microsoft.ACE.OLEDB.12.0',
	42	dsn_extra => 'Persist Security Info=False',
	43	}, {
	44	provider => 'Microsoft.Jet.OLEDB.4.0',
	45	});
	46
	47	my $opened = 0;
	48	my $exception;
	49
	50	for my $info (@info) {
	51	$conn->{Provider} = $info->{provider};
	52
	53	my $dsn = 'Data Source='.($self->_db_path);
	54	$dsn .= ";$info->{dsn_extra}" if exists $info->{dsn_extra};
	55
	56	try {
	57	$conn->Open($dsn, $user, $pass);
	58	undef $exception;
	59	}
	60	catch {
	61	$exception = $_;
	62	};
	63
	64	next if $exception;
	65
	66	$opened = 1;
	67	last;
	68	}
	69
	70	return ($opened, $exception);
	71	}
	72
	73
	74	sub _ado_connection {
	75	my $self = shift;
	76
	77	return $self->__ado_connection if $self->__ado_connection;
	78
	79	my ($dsn, $user, $pass) = @{ $self->schema->storage->_dbi_connect_info };
	80
	81	my $have_pass = 1;
	82
	83	if (ref $dsn eq 'CODE') {
	84	($dsn, $user, $pass) = $self->_try_infer_connect_info_from_coderef($dsn);
	85
	86	if (not $dsn) {
	87	my $dbh = $self->schema->storage->dbh;
	88	$dsn = $dbh->{Name};
	89	$user = $dbh->{Username};
	90	$have_pass = 0;
	91	}
	92	}
	93
	94	require Win32::OLE;
95	my $conn = Win32::OLE->new('ADODB.Connection');
96
97	$user = '' unless defined $user;
98	if ((not $have_pass) && exists $self->_passwords->{$dsn}{$user}) {
99	$pass = $self->_passwords->{$dsn}{$user};
100	$have_pass = 1;
101	}
102	$pass = '' unless defined $pass;
103
104	my ($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);
105
106	if ((not $opened) && (not $have_pass)) {
107	if (exists $ENV{DBI_PASS}) {
108	$pass = $ENV{DBI_PASS};
109
110	($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);
111
112	if ($opened) {
113	$self->_passwords->{$dsn}{$user} = $pass;
114	}
115	else {
116	print "Enter database password for $user ($dsn): ";
117	chomp($pass = <STDIN>);
118
119	($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);
120
121	if ($opened) {
122	$self->_passwords->{$dsn}{$user} = $pass;
123	}
124	}
125	}
126	else {
127	print "Enter database password for $user ($dsn): ";
128	chomp($pass = <STDIN>);
129
130	($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);
131
132	if ($opened) {
133	$self->_passwords->{$dsn}{$user} = $pass;
134	}
135	}
136	}
137
138	if (not $opened) {
139	die "Failed to open ADO connection: $exception";
140	}
141
142	$self->__ado_connection($conn);
143
144	return $conn;
145	}
146
147	sub _adox_catalog {
148	my $self = shift;
149
150	return $self->__adox_catalog if $self->__adox_catalog;
151
152	require Win32::OLE;
153	my $cat = Win32::OLE->new('ADOX.Catalog');
154	$cat->{ActiveConnection} = $self->_ado_connection;
155
156	$self->__adox_catalog($cat);
157
158	return $cat;
159	}
160
2ae19e70	161	sub _adox_column {
	162	my ($self, $table, $col) = @_;
	163
	164	my $col_obj;
	165
c4a69b87	166	my $cols = $self->_adox_catalog->Tables->Item($table->name)->Columns;
2ae19e70	167
	168	for my $col_idx (0..$cols->Count-1) {
	169	$col_obj = $cols->Item($col_idx);
	170	if ($self->preserve_case) {
	171	last if $col_obj->Name eq $col;
	172	}
	173	else {
	174	last if lc($col_obj->Name) eq lc($col);
	175	}
	176	}
	177
	178	return $col_obj;
	179	}
	180
3b17d988	181	sub rescan {
	182	my $self = shift;
	183
	184	if ($self->__adox_catalog) {
	185	$self->__ado_connection(undef);
	186	$self->__adox_catalog(undef);
	187	}
	188
	189	return $self->next::method(@_);
	190	}
	191
	192	sub _table_pk_info {
	193	my ($self, $table) = @_;
	194
	195	return [] if $self->_disable_pk_detection;
	196
	197	my @keydata;
	198
	199	my $indexes = try {
c4a69b87	200	$self->_adox_catalog->Tables->Item($table->name)->Indexes
3b17d988	201	}
	202	catch {
	203	warn "Could not retrieve indexes in table '$table', disabling primary key detection: $_\n";
	204	return undef;
	205	};
	206
	207	if (not $indexes) {
	208	$self->_disable_pk_detection(1);
	209	return [];
	210	}
	211
	212	for my $idx_num (0..($indexes->Count-1)) {
	213	my $idx = $indexes->Item($idx_num);
	214	if ($idx->PrimaryKey) {
	215	my $cols = $idx->Columns;
	216	for my $col_idx (0..$cols->Count-1) {
	217	push @keydata, $self->_lc($cols->Item($col_idx)->Name);
	218	}
	219	}
	220	}
	221
	222	return \@keydata;
	223	}
	224
	225	sub _table_fk_info {
	226	my ($self, $table) = @_;
	227
	228	return [] if $self->_disable_fk_detection;
	229
	230	my $keys = try {
c4a69b87	231	$self->_adox_catalog->Tables->Item($table->name)->Keys;
3b17d988	232	}
	233	catch {
	234	warn "Could not retrieve keys in table '$table', disabling relationship detection: $_\n";
	235	return undef;
	236	};
	237
	238	if (not $keys) {
	239	$self->_disable_fk_detection(1);
	240	return [];
	241	}
	242
	243	my @rels;
	244
	245	for my $key_idx (0..($keys->Count-1)) {
c4a69b87	246	my $key = $keys->Item($key_idx);
	247
	248	next unless $key->Type == 2;
	249
3b17d988	250	my $local_cols = $key->Columns;
	251	my $remote_table = $key->RelatedTable;
	252	my (@local_cols, @remote_cols);
	253
	254	for my $col_idx (0..$local_cols->Count-1) {
c4a69b87	255	my $col = $local_cols->Item($col_idx);
	256	push @local_cols, $self->_lc($col->Name);
	257	push @remote_cols, $self->_lc($col->RelatedColumn);
3b17d988	258	}
	259
	260	push @rels, {
	261	local_columns => \@local_cols,
	262	remote_columns => \@remote_cols,
c4a69b87	263	remote_table => DBIx::Class::Schema::Loader::Table->new(
	264	loader => $self,
	265	name => $remote_table,
	266	($self->db_schema ? (
	267	schema => $self->db_schema->[0],
	268	ignore_schema => 1,
	269	) : ()),
	270	),
3b17d988	271	};
3b17d988	272	}
	273
	274	return \@rels;
	275	}
	276
	277	sub _columns_info_for {
	278	my $self = shift;
	279	my ($table) = @_;
	280
	281	my $result = $self->next::method(@_);
	282
	283	while (my ($col, $info) = each %$result) {
	284	my $data_type = $info->{data_type};
	285
2ae19e70	286	my $col_obj = $self->_adox_column($table, $col);
	287
	288	$info->{is_nullable} = ($col_obj->Attributes & 2) == 2 ? 1 : 0;
	289
3b17d988	290	if ($data_type eq 'counter') {
	291	$info->{data_type} = 'integer';
	292	$info->{is_auto_increment} = 1;
	293	delete $info->{size};
	294	}
	295	elsif ($data_type eq 'longbinary') {
	296	$info->{data_type} = 'image';
	297	$info->{original}{data_type} = 'longbinary';
	298	}
	299	elsif ($data_type eq 'longchar') {
	300	$info->{data_type} = 'text';
	301	$info->{original}{data_type} = 'longchar';
	302	}
	303	elsif ($data_type eq 'double') {
	304	$info->{data_type} = 'double precision';
	305	$info->{original}{data_type} = 'double';
	306	}
	307	elsif ($data_type eq 'guid') {
	308	$info->{data_type} = 'uniqueidentifier';
	309	$info->{original}{data_type} = 'guid';
	310	}
	311	elsif ($data_type eq 'byte') {
	312	$info->{data_type} = 'tinyint';
	313	$info->{original}{data_type} = 'byte';
	314	}
	315	elsif ($data_type eq 'currency') {
	316	$info->{data_type} = 'money';
	317	$info->{original}{data_type} = 'currency';
	318
	319	if (ref $info->{size} eq 'ARRAY' && $info->{size}[0] == 19 && $info->{size}[1] == 4) {
3568bda9	320	# Actual money column via ODBC, otherwise we pass the sizes on to the ADO driver for
	321	# decimal columns (which masquerade as money columns...)
	322	delete $info->{size};
	323	}
	324	}
	325	elsif ($data_type eq 'decimal') {
	326	if (ref $info->{size} eq 'ARRAY' && $info->{size}[0] == 18 && $info->{size}[1] == 0) {
3b17d988	327	delete $info->{size};
	328	}
	329	}
	330
	331	# Pass through currency (which can be decimal for ADO.)
3568bda9	332	if ($data_type !~ /^(?:(?:var)?(?:char\|binary)\|decimal)\z/ && $data_type ne 'currency') {
3b17d988	333	delete $info->{size};
	334	}
	335	}
	336
	337	return $result;
	338	}
	339
	340	=head1 SEE ALSO
	341
	342	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	343	L<DBIx::Class::Schema::Loader::DBI>
	344
b87ab391	345	=head1 AUTHORS
3b17d988	346
b87ab391	347	See L<DBIx::Class::Schema::Loader/AUTHORS>.
3b17d988	348
	349	=head1 LICENSE
	350
	351	This library is free software; you can redistribute it and/or modify it under
	352	the same terms as Perl itself.
	353
	354	=cut
	355
	356	1;
	357	# vim:et sts=4 sw=4 tw=0: