1package DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS; 2 3use strict; 4use warnings; 5use base 'DBIx::Class::Schema::Loader::DBI::ODBC'; 6use mro 'c3'; 7use Try::Tiny; 8use namespace::clean; 9use DBIx::Class::Schema::Loader::Table (); 10 11our $VERSION = '0.07033'; 12 13__PACKAGE__->mk_group_accessors('simple', qw/ 14 __ado_connection 15 __adox_catalog 16/); 17 18=head1 NAME 19 20DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS - Microsoft Access driver for 21DBIx::Class::Schema::Loader 22 23=head1 DESCRIPTION 24 25See L<DBIx::Class::Schema::Loader::Base> for usage information. 26 27=cut 28 29sub _supports_db_schema { 0 } 30 31sub _db_path { 32 my $self = shift; 33 34 $self->schema->storage->dbh->get_info(16); 35} 36 37sub _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 74sub _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 147sub _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 161sub _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 181sub 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 192sub _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 225sub _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 277sub _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 342L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, 343L<DBIx::Class::Schema::Loader::DBI> 344 345=head1 AUTHOR 346 347See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 348 349=head1 LICENSE 350 351This library is free software; you can redistribute it and/or modify it under 352the same terms as Perl itself. 353 354=cut 355 3561; 357# vim:et sts=4 sw=4 tw=0: 358