lib/DBIx/Class/Schema/Loader/DBI/ODBC/ACCESS.pm

   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';
   9 use Try::Tiny;
  10 use namespace::clean;
  11 use DBIx::Class::Schema::Loader::Table ();
  12
  13 our $VERSION = '0.07010';
  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
  31 sub _supports_db_schema { 0 }
  32
  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
 163 sub _adox_column {
 164     my ($self, $table, $col) = @_;
 165
 166     my $col_obj;
 167
 168     my $cols = $self->_adox_catalog->Tables->Item($table->name)->Columns;
 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
 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 {
 202         $self->_adox_catalog->Tables->Item($table->name)->Indexes
 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 {
 233         $self->_adox_catalog->Tables->Item($table->name)->Keys;
 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)) {
 248         my $key = $keys->Item($key_idx);
 249
 250         next unless $key->Type == 2;
 251
 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) {
 257             my $col = $local_cols->Item($col_idx);
 258             push @local_cols,  $self->_lc($col->Name);
 259             push @remote_cols, $self->_lc($col->RelatedColumn);
 260         }
 261
 262         push @rels, {
 263             local_columns => \@local_cols,
 264             remote_columns => \@remote_cols,
 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             ),
 273         };
 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
 288         my $col_obj = $self->_adox_column($table, $col);
 289
 290         $info->{is_nullable} = ($col_obj->Attributes & 2) == 2 ? 1 : 0;
 291
 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) {
 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) {
 329                 delete $info->{size};
 330             }
 331         }
 332
 333 # Pass through currency (which can be decimal for ADO.)
 334         if ($data_type !~ /^(?:(?:var)?(?:char|binary)|decimal)\z/ && $data_type ne 'currency') {
 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: