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