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.07010';
  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 = $self->_adox_column($table, $col);
 128
 129         if ($data_type eq 'long') {
 130             $info->{data_type} = 'integer';
 131             delete $info->{size};
 132
 133             my $props = $col_obj->Properties;
 134             for my $prop_idx (0..$props->Count-1) {
 135                 my $prop = $props->Item($prop_idx);
 136                 if ($prop->Name eq 'Autoincrement' && $prop->Value == 1) {
 137                     $info->{is_auto_increment} = 1;
 138                     last;
 139                 }
 140             }
 141         }
 142         elsif ($data_type eq 'short') {
 143             $info->{data_type} = 'smallint';
 144             delete $info->{size};
 145         }
 146         elsif ($data_type eq 'single') {
 147             $info->{data_type} = 'real';
 148             delete $info->{size};
 149         }
 150         elsif ($data_type eq 'money') {
 151             if (ref $info->{size} eq 'ARRAY') {
 152                 if ($info->{size}[0] == 19 && $info->{size}[1] == 255) {
 153                     delete $info->{size};
 154                 }
 155                 else {
 156                     # it's really a decimal
 157                     $info->{data_type} = 'decimal';
 158
 159                     if ($info->{size}[0] == 18 && $info->{size}[1] == 0) {
 160                         # default size
 161                         delete $info->{size};
 162                     }
 163                     delete $info->{original};
 164                 }
 165             }
 166         }
 167         elsif ($data_type eq 'varchar') {
 168             $info->{data_type} = 'char' if $col_obj->Type == 130;
 169             $info->{size} = $col_obj->DefinedSize;
 170         }
 171         elsif ($data_type eq 'bigbinary') {
 172             $info->{data_type} = 'varbinary';
 173
 174             my $props = $col_obj->Properties;
 175             for my $prop_idx (0..$props->Count-1) {
 176                 my $prop = $props->Item($prop_idx);
 177                 if ($prop->Name eq 'Fixed Length' && $prop->Value == 1) {
 178                     $info->{data_type} = 'binary';
 179                     last;
 180                 }
 181             }
 182
 183             $info->{size} = $col_obj->DefinedSize;
 184         }
 185         elsif ($data_type eq 'longtext') {
 186             $info->{data_type} = 'text';
 187             $info->{original}{data_type} = 'longchar';
 188             delete $info->{size};
 189         }
 190     }
 191
 192     return $result;
 193 }
 194
 195 =head1 SEE ALSO
 196
 197 L<DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS>,
 198 L<DBIx::Class::Schema::Loader::DBI::ADO>,
 199 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 200 L<DBIx::Class::Schema::Loader::DBI>
 201
 202 =head1 AUTHOR
 203
 204 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 205
 206 =head1 LICENSE
 207
 208 This library is free software; you can redistribute it and/or modify it under
 209 the same terms as Perl itself.
 210
 211 =cut
 212
 213 1;
 214 # vim:et sts=4 sw=4 tw=0: