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 'DBIx::Class::Schema::Loader::DBI::ODBC';
   6 use mro 'c3';
   7 use Try::Tiny;
   8 use namespace::clean;
   9 use DBIx::Class::Schema::Loader::Table ();
  10
  11 our $VERSION = '0.07047';
  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
  29 sub _supports_db_schema { 0 }
  30
  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
 161 sub _adox_column {
 162     my ($self, $table, $col) = @_;
 163
 164     my $col_obj;
 165
 166     my $cols = $self->_adox_catalog->Tables->Item($table->name)->Columns;
 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
 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 {
 200         $self->_adox_catalog->Tables->Item($table->name)->Indexes
 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 {
 231         $self->_adox_catalog->Tables->Item($table->name)->Keys;
 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)) {
 246         my $key = $keys->Item($key_idx);
 247
 248         next unless $key->Type == 2;
 249
 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) {
 255             my $col = $local_cols->Item($col_idx);
 256             push @local_cols,  $self->_lc($col->Name);
 257             push @remote_cols, $self->_lc($col->RelatedColumn);
 258         }
 259
 260         push @rels, {
 261             local_columns => \@local_cols,
 262             remote_columns => \@remote_cols,
 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             ),
 271         };
 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
 286         my $col_obj = $self->_adox_column($table, $col);
 287
 288         $info->{is_nullable} = ($col_obj->Attributes & 2) == 2 ? 1 : 0;
 289
 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) {
 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) {
 327                 delete $info->{size};
 328             }
 329         }
 330
 331 # Pass through currency (which can be decimal for ADO.)
 332         if ($data_type !~ /^(?:(?:var)?(?:char|binary)|decimal)\z/ && $data_type ne 'currency') {
 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
 345 =head1 AUTHORS
 346
 347 See L<DBIx::Class::Schema::Loader/AUTHORS>.
 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: