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 Carp::Clan qw/^DBIx::Class/;
  10 use Try::Tiny;
  11 use namespace::clean;
  12
  13 our $VERSION = '0.07009';
  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 _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 rescan {
 162     my $self = shift;
 163
 164     if ($self->__adox_catalog) {
 165         $self->__ado_connection(undef);
 166         $self->__adox_catalog(undef);
 167     }
 168
 169     return $self->next::method(@_);
 170 }
 171
 172 sub _table_pk_info {
 173     my ($self, $table) = @_;
 174
 175     return [] if $self->_disable_pk_detection;
 176
 177     my @keydata;
 178
 179     my $indexes = try {
 180         $self->_adox_catalog->Tables->Item($table)->Indexes
 181     }
 182     catch {
 183         warn "Could not retrieve indexes in table '$table', disabling primary key detection: $_\n";
 184         return undef;
 185     };
 186
 187     if (not $indexes) {
 188         $self->_disable_pk_detection(1);
 189         return [];
 190     }
 191
 192     for my $idx_num (0..($indexes->Count-1)) {
 193         my $idx = $indexes->Item($idx_num);
 194         if ($idx->PrimaryKey) {
 195             my $cols = $idx->Columns;
 196             for my $col_idx (0..$cols->Count-1) {
 197                 push @keydata, $self->_lc($cols->Item($col_idx)->Name);
 198             }
 199         }
 200     }
 201
 202     return \@keydata;
 203 }
 204
 205 sub _table_fk_info {
 206     my ($self, $table) = @_;
 207
 208     return [] if $self->_disable_fk_detection;
 209
 210     my $keys = try {
 211         $self->_adox_catalog->Tables->Item($table)->Keys;
 212     }
 213     catch {
 214         warn "Could not retrieve keys in table '$table', disabling relationship detection: $_\n";
 215         return undef;
 216     };
 217
 218     if (not $keys) {
 219         $self->_disable_fk_detection(1);
 220         return [];
 221     }
 222
 223     my @rels;
 224
 225     for my $key_idx (0..($keys->Count-1)) {
 226       my $key = $keys->Item($key_idx);
 227       if ($key->Type == 2) {
 228         my $local_cols   = $key->Columns;
 229         my $remote_table = $key->RelatedTable;
 230         my (@local_cols, @remote_cols);
 231
 232         for my $col_idx (0..$local_cols->Count-1) {
 233           my $col = $local_cols->Item($col_idx);
 234           push @local_cols,  $self->_lc($col->Name);
 235           push @remote_cols, $self->_lc($col->RelatedColumn);
 236         }
 237
 238         push @rels, {
 239             local_columns => \@local_cols,
 240             remote_columns => \@remote_cols,
 241             remote_table => $remote_table,
 242         };
 243
 244       }
 245     }
 246
 247     return \@rels;
 248 }
 249
 250 sub _columns_info_for {
 251     my $self    = shift;
 252     my ($table) = @_;
 253
 254     my $result = $self->next::method(@_);
 255
 256     while (my ($col, $info) = each %$result) {
 257         my $data_type = $info->{data_type};
 258
 259         if ($data_type eq 'counter') {
 260             $info->{data_type} = 'integer';
 261             $info->{is_auto_increment} = 1;
 262             delete $info->{size};
 263         }
 264         elsif ($data_type eq 'longbinary') {
 265             $info->{data_type} = 'image';
 266             $info->{original}{data_type} = 'longbinary';
 267         }
 268         elsif ($data_type eq 'longchar') {
 269             $info->{data_type} = 'text';
 270             $info->{original}{data_type} = 'longchar';
 271         }
 272         elsif ($data_type eq 'double') {
 273             $info->{data_type} = 'double precision';
 274             $info->{original}{data_type} = 'double';
 275         }
 276         elsif ($data_type eq 'guid') {
 277             $info->{data_type} = 'uniqueidentifier';
 278             $info->{original}{data_type} = 'guid';
 279         }
 280         elsif ($data_type eq 'byte') {
 281             $info->{data_type} = 'tinyint';
 282             $info->{original}{data_type} = 'byte';
 283         }
 284         elsif ($data_type eq 'currency') {
 285             $info->{data_type} = 'money';
 286             $info->{original}{data_type} = 'currency';
 287
 288             if (ref $info->{size} eq 'ARRAY' && $info->{size}[0] == 19 && $info->{size}[1] == 4) {
 289                 # Actual money column via ODBC, otherwise we pass the sizes on to the ADO driver for decimal
 290                 # columns (which masquerade as money columns...)
 291                 delete $info->{size};
 292             }
 293         }
 294
 295 # Pass through currency (which can be decimal for ADO.)
 296         if ($data_type !~ /^(?:(?:var)?(?:char|binary))\z/ && $data_type ne 'currency') {
 297             delete $info->{size};
 298         }
 299     }
 300
 301     return $result;
 302 }
 303
 304 =head1 SEE ALSO
 305
 306 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 307 L<DBIx::Class::Schema::Loader::DBI>
 308
 309 =head1 AUTHOR
 310
 311 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 312
 313 =head1 LICENSE
 314
 315 This library is free software; you can redistribute it and/or modify it under
 316 the same terms as Perl itself.
 317
 318 =cut
 319
 320 1;
 321 # vim:et sts=4 sw=4 tw=0: