[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 qw/
    DBIx::Class::Schema::Loader::DBI::ODBC
/;
use mro 'c3';
use Try::Tiny;
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();

our $VERSION = '0.07012';

__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 AUTHOR

See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.

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