lib/DBIx/Class/Schema/Loader/DBI/ADO/MS_Jet.pm

   1 package DBIx::Class::Schema::Loader::DBI::ADO::MS_Jet;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/
   6     DBIx::Class::Schema::Loader::DBI::ADO
   7     DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS
   8 /;
   9 use mro 'c3';
  10 use Carp::Clan qw/^DBIx::Class/;
  11 use Try::Tiny;
  12 use namespace::clean;
  13
  14 our $VERSION = '0.07007';
  15
  16 =head1 NAME
  17
  18 DBIx::Class::Schema::Loader::DBI::ADO::MS_Jet - ADO wrapper for
  19 L<DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS>
  20
  21 =head1 DESCRIPTION
  22
  23 Proxy for L<DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS> when using
  24 L<DBD::ADO>.
  25
  26 See L<DBIx::Class::Schema::Loader::Base> for usage information.
  27
  28 =cut
  29
  30 sub _db_path {
  31     my $self = shift;
  32
  33     $self->schema->storage->dbh->get_info(2);
  34 }
  35
  36 sub _ado_connection {
  37     my $self = shift;
  38
  39     return $self->__ado_connection if $self->__ado_connection;
  40
  41     my ($dsn, $user, $pass) = @{ $self->schema->storage->_dbi_connect_info };
  42
  43     my $have_pass = 1;
  44
  45     if (ref $dsn eq 'CODE') {
  46         ($dsn, $user, $pass) = $self->_try_infer_connect_info_from_coderef($dsn);
  47
  48         if (not $dsn) {
  49             my $dbh = $self->schema->storage->dbh;
  50             $dsn  = $dbh->{Name};
  51             $user = $dbh->{Username};
  52             $have_pass = 0;
  53         }
  54     }
  55
  56     require Win32::OLE;
  57     my $conn = Win32::OLE->new('ADODB.Connection');
  58
  59     $dsn =~ s/^dbi:[^:]+://i;
  60
  61     local $Win32::OLE::Warn = 0;
  62
  63     my @dsn;
  64     for my $s (split /;/, $dsn) {
  65         my ($k, $v) = split /=/, $s, 2;
  66         if (defined $conn->{$k}) {
  67             $conn->{$k} = $v;
  68             next;
  69         }
  70         push @dsn, $s;
  71     }
  72
  73     $dsn = join ';', @dsn;
  74
  75     $user = '' unless defined $user;
  76
  77     if ((not $have_pass) && exists $self->_passwords->{$dsn}{$user}) {
  78         $pass = $self->_passwords->{$dsn}{$user};
  79         $have_pass = 1;
  80     }
  81     $pass = '' unless defined $pass;
  82
  83     try {
  84         $conn->Open($dsn, $user, $pass);
  85     }
  86     catch {
  87         if (not $have_pass) {
  88             if (exists $ENV{DBI_PASS}) {
  89                 $pass = $ENV{DBI_PASS};
  90                 try {
  91                     $conn->Open($dsn, $user, $pass);
  92                     $self->_passwords->{$dsn}{$user} = $pass;
  93                 }
  94                 catch {
  95                     print "Enter database password for $user ($dsn): ";
  96                     chomp($pass = <STDIN>);
  97                     $conn->Open($dsn, $user, $pass);
  98                     $self->_passwords->{$dsn}{$user} = $pass;
  99                 };
 100             }
 101             else {
 102                 print "Enter database password for $user ($dsn): ";
 103                 chomp($pass = <STDIN>);
 104                 $conn->Open($dsn, $user, $pass);
 105                 $self->_passwords->{$dsn}{$user} = $pass;
 106             }
 107         }
 108         else {
 109             die $_;
 110         }
 111     };
 112
 113     $self->__ado_connection($conn);
 114
 115     return $conn;
 116 }
 117
 118 sub _columns_info_for {
 119     my $self    = shift;
 120     my ($table) = @_;
 121
 122     my $result = $self->next::method(@_);
 123
 124     while (my ($col, $info) = each %$result) {
 125         my $data_type = $info->{data_type};
 126
 127         my $col_obj;
 128
 129         $self->_adox_catalog->Tables->Item($table)->Columns;
 130
 131         for my $col_idx (0..$cols->Count-1) {
 132             $col_obj = $cols->Item($col_idx);
 133             if ($self->preserve_case) {
 134                 last if $col_obj->Name eq $col;
 135             }
 136             else {
 137                 last if lc($col_obj->Name) eq lc($col);
 138             }
 139         }
 140
 141         if ($col_obj->Attributes | 2 == 2) {
 142             $info->{is_nullable} = 1;
 143         }
 144
 145         if ($data_type eq 'long') {
 146             $info->{data_type} = 'integer';
 147             delete $info->{size};
 148
 149             my $props = $col_obj->Properties;
 150             for my $prop_idx (0..$props->Count-1) {
 151                 my $prop = $props->Item($prop_idx);
 152                 if ($prop->Name eq 'Autoincrement' && $prop->Value == 1) {
 153                     $info->{is_auto_increment} = 1;
 154                     last;
 155                 }
 156             }
 157         }
 158         elsif ($data_type eq 'short') {
 159             $info->{data_type} = 'smallint';
 160             delete $info->{size};
 161         }
 162         elsif ($data_type eq 'single') {
 163             $info->{data_type} = 'real';
 164             delete $info->{size};
 165         }
 166         elsif ($data_type eq 'money') {
 167             if (ref $info->{size} eq 'ARRAY') {
 168                 if ($info->{size}[0] == 19 && $info->{size}[1] == 255) {
 169                     delete $info->{size};
 170                 }
 171                 else {
 172                     # it's really a decimal
 173                     $info->{data_type} = 'decimal';
 174
 175                     if ($info->{size}[0] == 18 && $info->{size}[1] == 0) {
 176                         # default size
 177                         delete $info->{size};
 178                     }
 179                     delete $info->{original};
 180                 }
 181             }
 182         }
 183         elsif ($data_type eq 'varchar') {
 184             $info->{data_type} = 'char' if $col_obj->Type == 130;
 185             $info->{size} = $col_obj->DefinedSize;
 186         }
 187         elsif ($data_type eq 'bigbinary') {
 188             $info->{data_type} = 'varbinary';
 189
 190             my $props = $col_obj->Properties;
 191             for my $prop_idx (0..$props->Count-1) {
 192                 my $prop = $props->Item($prop_idx);
 193                 if ($prop->Name eq 'Fixed Length' && $prop->Value == 1) {
 194                     $info->{data_type} = 'binary';
 195                     last;
 196                 }
 197
 198             }
 199
 200             $info->{size} = $col_obj->DefinedSize;
 201         }
 202         elsif ($data_type eq 'longtext') {
 203             $info->{data_type} = 'text';
 204             $info->{original}{data_type} = 'longchar';
 205             delete $info->{size};
 206         }
 207     }
 208
 209     return $result;
 210 }
 211
 212 =head1 SEE ALSO
 213
 214 L<DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS>,
 215 L<DBIx::Class::Schema::Loader::DBI::ADO>,
 216 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 217 L<DBIx::Class::Schema::Loader::DBI>
 218
 219 =head1 AUTHOR
 220
 221 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 222
 223 =head1 LICENSE
 224
 225 This library is free software; you can redistribute it and/or modify it under
 226 the same terms as Perl itself.
 227
 228 =cut
 229
 230 1;
 231 # vim:et sts=4 sw=4 tw=0: