[Summary view] [Print] [Text view]

   1  package
   2    DBI;    # hide this non-DBI package from simple indexers
   3  
   4  # $Id: W32ODBC.pm 8696 2007-01-24 23:12:38Z timbo $
   5  #
   6  # Copyright (c) 1997,1999 Tim Bunce
   7  # With many thanks to Patrick Hollins for polishing.
   8  #
   9  # You may distribute under the terms of either the GNU General Public
  10  # License or the Artistic License, as specified in the Perl README file.
  11  
  12  =head1 NAME
  13  
  14  DBI::W32ODBC - An experimental DBI emulation layer for Win32::ODBC
  15  
  16  =head1 SYNOPSIS
  17  
  18    use DBI::W32ODBC;
  19  
  20    # apart from the line above everything is just the same as with
  21    # the real DBI when using a basic driver with few features.
  22  
  23  =head1 DESCRIPTION
  24  
  25  This is an experimental pure perl DBI emulation layer for Win32::ODBC
  26  
  27  If you can improve this code I'd be interested in hearing about it. If
  28  you are having trouble using it please respect the fact that it's very
  29  experimental. Ideally fix it yourself and send me the details.
  30  
  31  =head2 Some Things Not Yet Implemented
  32  
  33      Most attributes including PrintError & RaiseError.
  34      type_info and table_info
  35  
  36  Volunteers welcome!
  37  
  38  =cut
  39  
  40  ${'DBI::VERSION'}    # hide version from PAUSE indexer
  41     = "0.01";
  42  
  43  my $Revision = sprintf("12.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
  44  
  45  
  46  sub DBI::W32ODBC::import { }    # must trick here since we're called DBI/W32ODBC.pm
  47  
  48  
  49  use Carp;
  50  
  51  use Win32::ODBC;
  52  
  53  @ISA = qw(Win32::ODBC);
  54  
  55  use strict;
  56  
  57  $DBI::dbi_debug = $ENV{PERL_DBI_DEBUG} || 0;
  58  carp "Loaded (W32ODBC) DBI.pm ${'DBI::VERSION'} (debug $DBI::dbi_debug)"
  59      if $DBI::dbi_debug;
  60  
  61  
  62  
  63  sub connect {
  64      my ($class, $dbname, $dbuser, $dbpasswd, $module, $attr) = @_;
  65      $dbname .= ";UID=$dbuser"   if $dbuser;
  66      $dbname .= ";PWD=$dbpasswd" if $dbpasswd;
  67      my $h = new Win32::ODBC $dbname;
  68      warn "Error connecting to $dbname: ".Win32::ODBC::Error()."\n" unless $h;
  69      bless $h, $class if $h;    # rebless into our class
  70      $h;
  71  }
  72  
  73  
  74  sub quote {
  75      my ($h, $string) = @_;
  76      return "NULL" if !defined $string;
  77      $string =~ s/'/''/g;    # standard
  78      # This hack seems to be required for Access but probably breaks for
  79      # other databases when using \r and \n. It would be better if we could
  80      # use ODBC options to detect that we're actually using Access.
  81      $string =~ s/\r/' & chr\$(13) & '/g;
  82      $string =~ s/\n/' & chr\$(10) & '/g;
  83      "'$string'";
  84  }
  85  
  86  sub do {
  87      my($h, $statement, $attribs, @params) = @_;
  88      Carp::carp "\$h->do() attribs unused" if $attribs;
  89      my $new_h = $h->prepare($statement) or return undef;    ##
  90      pop @{ $h->{'___sths'} };                               ## certian death assured
  91      $new_h->execute(@params) or return undef;               ##
  92      my $rows = $new_h->rows;                                ##
  93      $new_h->finish;                                         ## bang bang
  94      ($rows == 0) ? "0E0" : $rows;
  95  }
  96  
  97  # ---
  98  
  99  sub prepare {
 100      my ($h, $sql) = @_;
 101      ## opens a new connection with every prepare to allow
 102      ## multiple, concurrent queries
 103      my $new_h = new Win32::ODBC $h->{DSN};    ##
 104      return undef if not $new_h;             ## bail if no connection
 105      bless $new_h;                            ## shouldn't be sub-classed...
 106      $new_h->{'__prepare'} = $sql;            ##
 107      $new_h->{NAME} = [];                    ##
 108      $new_h->{NUM_OF_FIELDS} = -1;            ##
 109      push @{ $h->{'___sths'} } ,$new_h;        ## save sth in parent for mass destruction
 110      return $new_h;                            ##
 111  }
 112  
 113  sub execute {
 114      my ($h) = @_;
 115      my $rc = $h->Sql($h->{'__prepare'});
 116      return undef if $rc;
 117      my @fields = $h->FieldNames;
 118      $h->{NAME} = \@fields;
 119      $h->{NUM_OF_FIELDS} = scalar @fields;
 120      $h;    # return dbh as pseudo sth
 121  }
 122  
 123  
 124  sub fetchrow_hashref {                    ## provide DBI compatibility
 125      my $h = shift;
 126      my $NAME = shift || "NAME";
 127      my $row = $h->fetchrow_arrayref or return undef;
 128      my %hash;
 129      @hash{ @{ $h->{$NAME} } } = @$row;
 130      return \%hash;
 131  }
 132  
 133  sub fetchrow {
 134      my $h = shift;
 135      return unless $h->FetchRow();
 136      my $fields_r = $h->{NAME};
 137      return $h->Data(@$fields_r);
 138  }
 139  sub fetch {
 140      my @row = shift->fetchrow;
 141      return undef unless @row;
 142      return \@row;
 143  }
 144  *fetchrow_arrayref = \&fetch;            ## provide DBI compatibility
 145  *fetchrow_array    = \&fetchrow;        ## provide DBI compatibility
 146  
 147  sub rows {
 148      shift->RowCount;
 149  }
 150  
 151  sub finish {
 152      shift->Close;                        ## uncommented this line
 153  }
 154  
 155  # ---
 156  
 157  sub commit {
 158      shift->Transact(ODBC::SQL_COMMIT);
 159  }
 160  sub rollback {
 161      shift->Transact(ODBC::SQL_ROLLBACK);
 162  }
 163  
 164  sub disconnect {
 165      my ($h) = shift;                     ## this will kill all the statement handles
 166      foreach (@{$h->{'___sths'}}) {        ## created for a specific connection
 167          $_->Close if $_->{DSN};            ##
 168      }                                    ##
 169      $h->Close;                          ##
 170  }
 171  
 172  sub err {
 173      (shift->Error)[0];
 174  }
 175  sub errstr {
 176      scalar( shift->Error );
 177  }
 178  
 179  # ---
 180  
 181  1;