File Coverage

blib/lib/DBD/Oracle.pm
Criterion Covered Total %
statement 42 301 14.0
branch 7 170 4.1
condition 3 103 2.9
subroutine 8 31 25.8
pod 0 1 0.0
total 60 606 9.9


line stmt bran cond sub pod time code
1             # Oracle.pm
2             #
3             # Copyright (c) 1994-2005 Tim Bunce, Ireland
4             #
5             # See COPYRIGHT section in the documentation below
6              
7             require 5.003;
8              
9             $DBD::Oracle::VERSION = '1.19';
10              
11             my $ORACLE_ENV = ($^O eq 'VMS') ? 'ORA_ROOT' : 'ORACLE_HOME';
12              
13             {
14                 package DBD::Oracle;
15              
16 20     20   575     use DBI ();
  20         491  
  20         207  
17 20     20   305     use DynaLoader ();
  20         182  
  20         223  
18 20     20   337     use Exporter ();
  20         186  
  20         366  
19                 @ISA = qw(DynaLoader Exporter);
20                 %EXPORT_TAGS = (
21             ora_types => [ qw(
22             ORA_VARCHAR2 ORA_STRING ORA_NUMBER ORA_LONG ORA_ROWID ORA_DATE
23             ORA_RAW ORA_LONGRAW ORA_CHAR ORA_CHARZ ORA_MLSLABEL ORA_NTY
24             ORA_CLOB ORA_BLOB ORA_RSET
25             ) ],
26                     ora_session_modes => [ qw( ORA_SYSDBA ORA_SYSOPER ) ],
27                 );
28                 @EXPORT_OK = qw(ORA_OCI SQLCS_IMPLICIT SQLCS_NCHAR ora_env_var ora_cygwin_set_env);
29             #unshift @EXPORT_OK, 'ora_cygwin_set_env' if $^O eq 'cygwin';
30                 Exporter::export_ok_tags(qw(ora_types ora_session_modes));
31              
32                 my $Revision = substr(q$Revision: 1.103 $, 10);
33              
34                 require_version DBI 1.28;
35              
36                 bootstrap DBD::Oracle $VERSION;
37              
38                 $drh = undef; # holds driver handle once initialised
39              
40                 sub CLONE {
41 0     0   0         $drh = undef ;
42                 }
43                           
44                 sub driver{
45 19 50   19 0 331 return $drh if $drh;
46 19         209 my($class, $attr) = @_;
47 19         1301 my $oci = DBD::Oracle::ORA_OCI();
48              
49 19         202 $class .= "::dr";
50              
51             # not a 'my' since we use it above to prevent multiple drivers
52              
53 19         649 $drh = DBI::_new_drh($class, {
54             'Name' => 'Oracle',
55             'Version' => $VERSION,
56             'Err'    => \my $err,
57             'Errstr' => \my $errstr,
58             'Attribution' => "DBD::Oracle $VERSION using OCI$oci by Tim Bunce",
59             });
60 19         3123 DBD::Oracle::dr::init_oci($drh) ;
61 19         2584 $drh->STORE('ShowErrorStatement', 1);
62              
63 19 50       617 if ($DBI::VERSION >= 1.37) {
64 19         461 DBD::Oracle::db->install_method("ora_lob_read");
65 19         1950 DBD::Oracle::db->install_method("ora_lob_write");
66 19         1448 DBD::Oracle::db->install_method("ora_lob_append");
67 19         1417 DBD::Oracle::db->install_method("ora_lob_trim");
68 19         1592 DBD::Oracle::db->install_method("ora_lob_length");
69 19         1493 DBD::Oracle::db->install_method("ora_nls_parameters");
70 19         1346 DBD::Oracle::db->install_method("ora_can_unicode");
71             }
72              
73 19         1184 $drh;
74                 }
75              
76              
77                 END {
78             # Used to silence 'Bad free() ...' warnings caused by bugs in Oracle's code
79             # being detected by Perl's malloc.
80             $ENV{PERL_BADFREE} = 0;
81             #undef $Win32::TieRegistry::Registry if $Win32::TieRegistry::Registry;
82                 }
83              
84                 sub AUTOLOAD {
85 0     0   0      (my $constname = $AUTOLOAD) =~ s/.*:://;
86 0         0      my $val = constant($constname);
87 0     0   0      *$AUTOLOAD = sub { $val };
  0         0  
88 0         0      goto &$AUTOLOAD;
89                 }
90              
91             }
92              
93              
94             {   package DBD::Oracle::dr; # ====== DRIVER ======
95 20     20   570     use strict;
  20         189  
  20         339  
96              
97                 my %dbnames = (); # holds list of known databases (oratab + tnsnames)
98              
99                 sub load_dbnames {
100 0     0   0 my ($drh) = @_;
101 0         0 my $debug = $drh->debug;
102 0         0 my $oracle_home = DBD::Oracle::ora_env_var($ORACLE_ENV);
103 0         0 local *FH;
104 0         0 my $d;
105              
106 0 0 0     0 if (($^O eq 'MSWin32') or ($^O =~ /cygwin/i)) {
107             # XXX experimental, will probably change
108 0 0       0 $drh->trace_msg("Trying to fetch ORACLE_HOME and ORACLE_SID from the registry.\n")
109             if $debug;
110 0         0 my $sid = DBD::Oracle::ora_env_var("ORACLE_SID");
111 0 0 0     0 $dbnames{$sid} = $oracle_home if $sid and $oracle_home;
112 0 0 0     0 $drh->trace_msg("Found $sid \@ $oracle_home.\n") if $debug && $sid;
113             }
114              
115             # get list of 'local' database SIDs from oratab
116 0         0 foreach $d (qw(/etc /var/opt/oracle), DBD::Oracle::ora_env_var("TNS_ADMIN")) {
117 0 0       0 next unless defined $d;
118 0 0       0 next unless open(FH, "<$d/oratab");
119 0 0       0 $drh->trace_msg("Loading $d/oratab\n") if $debug;
120 0         0 my $ot;
121 0         0 while (defined($ot = <FH>)) {
122 0 0       0 next unless $ot =~ m/^\s*(\w+)\s*:\s*(.*?)\s*:/;
123 0         0 $dbnames{$1} = $2; # store ORACLE_HOME value
124 0 0       0 $drh->trace_msg("Found $1 \@ $2.\n") if $debug;
125             }
126 0         0 close FH;
127 0         0 last;
128             }
129              
130             # get list of 'remote' database connection identifiers
131 0         0 my @tns_admin;
132 0 0       0 push @tns_admin, (
133             "$oracle_home/network/admin", # OCI 7 and 8.1
134             "$oracle_home/net80/admin", # OCI 8.0
135             ) if $oracle_home;
136 0         0 push @tns_admin, "/var/opt/oracle";
137 0         0 foreach $d ( DBD::Oracle::ora_env_var("TNS_ADMIN"), ".", @tns_admin ) {
138 0 0 0     0 next unless $d && open(FH, "<$d/tnsnames.ora");
139 0 0       0 $drh->trace_msg("Loading $d/tnsnames.ora\n") if $debug;
140 0         0 local *_;
141 0         0 while (<FH>) {
142 0 0       0 next unless m/^\s*([-\w\.]+)\s*=/;
143 0         0 my $name = $1;
144 0 0       0 $drh->trace_msg("Found $name. ".($dbnames{$name} ? "(oratab entry overridden)" : "")."\n")
    0          
145             if $debug;
146 0         0 $dbnames{$name} = 0; # exists but false (to distinguish from oratab)
147             }
148 0         0 close FH;
149 0         0 last;
150             }
151              
152 0         0 $dbnames{0} = 1; # mark as loaded (even if empty)
153                 }
154              
155                 sub data_sources {
156 0     0   0 my $drh = shift;
157 0 0       0 load_dbnames($drh) unless %dbnames;
158 0         0 my @names = sort keys %dbnames;
159 0 0       0 my @sources = map { $_ ? ("dbi:Oracle:$_") : () } @names;
  0         0  
160 0         0 return @sources;
161                 }
162              
163              
164                 sub connect {
165 18     18   474 my ($drh, $dbname, $user, $auth, $attr)= @_;
166              
167 18 50       299 if ($dbname =~ /;/) {
168 0         0 my ($n,$v);
169 0         0 $dbname =~ s/^\s+//;
170 0         0 $dbname =~ s/\s+$//;
171 0         0 my @dbname = map {
172 0         0 ($n,$v) = split /\s*=\s*/, $_, -1;
173 0 0 0     0 Carp::carp("DSN component '$_' is not in 'name=value' format")
174             unless defined $v && defined $n;
175 0         0                 (uc($n), $v)
176             } split /\s*;\s*/, $dbname;
177 0         0 my %dbname = ( PROTOCOL => 'tcp', @dbname );
178              
179             # extract main attributes for connect_data portion
180 0         0 my @connect_data_attr = qw(SID INSTANCE_NAME SERVER SERVICE_NAME);
181 0         0 my %connect_data = map { ($_ => delete $dbname{$_}) }
  0         0  
182 0         0 grep { exists $dbname{$_} } @connect_data_attr;
183 0         0 my $connect_data = join "", map { "($_=$connect_data{$_})" } keys %connect_data;
  0         0  
184              
185 0 0 0     0 return $drh->DBI::set_err(-1,
186             "Can't connect using this syntax without specifying a HOST and one of @connect_data_attr")
187             unless $dbname{HOST} and %connect_data;
188              
189 0         0 my @addrs = map { "($_=$dbname{$_})" } keys %dbname;
  0         0  
190 0         0 my $addrs = join "", @addrs;
191 0 0       0 if ($dbname{PORT}) {
192 0         0 $addrs = "(ADDRESS=$addrs)";
193             }
194             else {
195 0         0 $addrs = "(ADDRESS_LIST=(ADDRESS=$addrs(PORT=1526))"
196             . "(ADDRESS=$addrs(PORT=1521)))";
197             }
198 0         0 $dbname = "(DESCRIPTION=$addrs(CONNECT_DATA=$connect_data))";
199 0         0 $drh->trace_msg("connect using '$dbname'");
200             }
201              
202             # If the application is asking for specific database
203             # then we may have to mung the dbname
204              
205 18 50 33     966 $dbname = $1 if !$dbname && $user && $user =~ s/\@(.*)//s;
      33        
206              
207 18 50 33     402 $drh->trace_msg("$ORACLE_ENV environment variable not set\n")
208             if !$ENV{$ORACLE_ENV} and $^O ne "MSWin32";
209              
210             # create a 'blank' dbh
211              
212 18 50       351 $user = '' if not defined $user;
213 18         277         (my $user_only = $user) =~ s:/.*::;
214 18         399 my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, {
215             'Name' => $dbname,
216             # these two are just for backwards compatibility
217             'USER' => uc $user_only, 'CURRENT_USER' => uc $user_only,
218             });
219              
220             # Call Oracle OCI logon func in Oracle.xs file
221             # and populate internal handle data.
222 18 50       1332775 DBD::Oracle::db::_login($dbh, $dbname, $user, $auth, $attr)
223             or return undef;
224              
225 0 0 0       if ($attr && $attr->{ora_module_name}) {
226 0           eval {
227 0           $dbh->do(q{BEGIN DBMS_APPLICATION_INFO.SET_MODULE(:1,NULL); END;},
228             undef, $attr->{ora_module_name});
229             };
230             }
231 0 0         unless (length $user_only) {
232 0           $user_only = $dbh->selectrow_array(q{
233             SELECT SYS_CONTEXT('userenv','session_user') FROM DUAL
234             });
235 0           $dbh_inner->{Username} = $user_only;
236             # these two are just for backwards compatibility
237 0           $dbh_inner->{USER} = $dbh_inner->{CURRENT_USER} = uc $user_only;
238             }
239              
240 0           $dbh;
241                 }
242              
243             }
244              
245              
246             {   package DBD::Oracle::db; # ====== DATABASE ======
247 20     20   637     use strict;
  20         196  
  20         404  
248 20     20   15541     use DBI qw(:sql_types);
  20         242  
  20         2000  
249              
250                 sub prepare {
251 0     0     my($dbh, $statement, @attribs)= @_;
252              
253             # create a 'blank' sth
254              
255 0           my $sth = DBI::_new_sth($dbh, {
256             'Statement' => $statement,
257             });
258              
259             # Call Oracle OCI parse func in Oracle.xs file.
260             # and populate internal handle data.
261              
262 0 0         DBD::Oracle::st::_prepare($sth, $statement, @attribs)
263             or return undef;
264              
265 0           $sth;
266                 }
267              
268              
269                 sub ping {
270 0     0     my($dbh) = @_;
271 0           my $ok = 0;
272 0           eval {
273 0           local $SIG{__DIE__};
274 0           local $SIG{__WARN__};
275             # we know that Oracle 7 prepare does a describe so this will
276             # actually talk to the server and is this a valid and cheap test.
277 0           my $sth = $dbh->prepare("select SYSDATE from DUAL /* ping */");
278             # But Oracle 8+ doesn't talk to server unless we describe the query
279 0   0       $ok = $sth && $sth->FETCH('NUM_OF_FIELDS');
280             };
281 0 0         return ($@) ? 0 : $ok;
282                 }
283              
284              
285                 sub get_info {
286 0     0     my($dbh, $info_type) = @_;
287 0           require DBD::Oracle::GetInfo;
288 0           my $v = $DBD::Oracle::GetInfo::info{int($info_type)};
289 0 0         $v = $v->($dbh) if ref $v eq 'CODE';
290 0           return $v;
291                 }
292              
293              
294                 sub table_info {
295 0     0     my($dbh, $CatVal, $SchVal, $TblVal, $TypVal) = @_;
296             # XXX add knowledge of temp tables, etc
297             # SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables
298 0 0         if (ref $CatVal eq 'HASH') {
299 0           ($CatVal, $SchVal, $TblVal, $TypVal) =
300             @$CatVal{'TABLE_CAT','TABLE_SCHEM','TABLE_NAME','TABLE_TYPE'};
301             }
302 0           my @Where = ();
303 0           my $Sql;
304 0 0 0       if ( defined $CatVal && $CatVal eq '%' && (!defined $SchVal || $SchVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19a
    0 0        
    0 0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
305 0           $Sql = <<'SQL';
306             SELECT NULL TABLE_CAT
307             , NULL TABLE_SCHEM
308             , NULL TABLE_NAME
309             , NULL TABLE_TYPE
310             , NULL REMARKS
311             FROM DUAL
312             SQL
313             }
314             elsif ( defined $SchVal && $SchVal eq '%' && (!defined $CatVal || $CatVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19b
315 0           $Sql = <<'SQL';
316