From c3f82a90ae106301701f68602ede12a6bdc7c2ae Mon Sep 17 00:00:00 2001 From: jurl Date: Sat, 21 Feb 2004 23:47:25 +0000 Subject: [PATCH] Import DBD-Oracle 1.06 git-svn-id: http://svn.perl.org/modules/dbd-oracle/trunk@104 50811bd7-b8ce-0310-adc1-d9db26280581 --- Changes | 605 ++++++++++++++ MANIFEST | 43 + Makefile.PL | 1117 +++++++++++++++++++++++++ Oracle.ex/Readme | 36 + Oracle.ex/bind.pl | 45 ++ Oracle.ex/commit.pl | 72 ++ Oracle.ex/ex.pl | 47 ++ Oracle.ex/japh | 52 ++ Oracle.ex/mktable.pl | 102 +++ Oracle.ex/oradump.pl | 42 + Oracle.ex/proc.pl | 148 ++++ Oracle.ex/sql | 235 ++++++ Oracle.ex/tabinfo.pl | 68 ++ Oracle.h | 59 ++ Oracle.pm | 1178 +++++++++++++++++++++++++++ Oracle.xs | 98 +++ Oraperl.pm | 866 ++++++++++++++++++++ README | 264 ++++++ README.clients | 275 +++++++ README.explain | 193 +++++ README.help | 335 ++++++++ README.java | 207 +++++ README.login | 2 + README.longs | 81 ++ README.sec | 142 ++++ README.win32 | 41 + README.wingcc | 22 + Todo | 48 ++ dbdimp.c | 1836 ++++++++++++++++++++++++++++++++++++++++++ dbdimp.h | 303 +++++++ hints/svr4.pl | 126 +++ oci.def | 368 +++++++++ oci7.c | 553 +++++++++++++ oci8.c | 1442 +++++++++++++++++++++++++++++++++ ocitrace.h | 249 ++++++ ora_explain.PL | 1814 +++++++++++++++++++++++++++++++++++++++++ oraperl.ph | 53 ++ t/base.t | 48 ++ t/general.t | 82 ++ t/long.t | 344 ++++++++ t/plsql.t | 290 +++++++ t/reauth.t | 46 ++ test.pl | 390 +++++++++ 43 files changed, 14367 insertions(+) create mode 100644 Changes create mode 100644 MANIFEST create mode 100755 Makefile.PL create mode 100644 Oracle.ex/Readme create mode 100755 Oracle.ex/bind.pl create mode 100755 Oracle.ex/commit.pl create mode 100755 Oracle.ex/ex.pl create mode 100755 Oracle.ex/japh create mode 100755 Oracle.ex/mktable.pl create mode 100755 Oracle.ex/oradump.pl create mode 100755 Oracle.ex/proc.pl create mode 100755 Oracle.ex/sql create mode 100755 Oracle.ex/tabinfo.pl create mode 100644 Oracle.h create mode 100644 Oracle.pm create mode 100644 Oracle.xs create mode 100644 Oraperl.pm create mode 100644 README create mode 100644 README.clients create mode 100644 README.explain create mode 100644 README.help create mode 100644 README.java create mode 100644 README.login create mode 100644 README.longs create mode 100644 README.sec create mode 100644 README.win32 create mode 100644 README.wingcc create mode 100644 Todo create mode 100644 dbdimp.c create mode 100644 dbdimp.h create mode 100644 hints/svr4.pl create mode 100644 oci.def create mode 100644 oci7.c create mode 100644 oci8.c create mode 100644 ocitrace.h create mode 100644 ora_explain.PL create mode 100644 oraperl.ph create mode 100755 t/base.t create mode 100644 t/general.t create mode 100644 t/long.t create mode 100644 t/plsql.t create mode 100644 t/reauth.t create mode 100755 test.pl diff --git a/Changes b/Changes new file mode 100644 index 00000000..e3e84200 --- /dev/null +++ b/Changes @@ -0,0 +1,605 @@ +Changes in DBD::Oracle 1.06 14th July 2000 + + Fixed ora_ph_type attribute to allow 96 or 97. + Fixed compile failure with Oracle 7. + +Changes in DBD::Oracle 1.05 13th July 2000 + + Added $dbh->{ora_ph_type} attribute to define default bind type: + 1=> VARCHAR2, does strip trailing spaces, embedded \0 bytes okay + 5=> STRING, doesn't strip trailing spaces, embedded \0 ends string + 96=> CHAR, doesn't strip trailing spaces, embedded \0 okay + 97=> CHARZ, doesn't strip trailing spaces, embedded \0 ends string? + The two CHAR types force 'blank-padded comparison semantics'. + Needs testing and documenting, volunteers most welcome! + Added (many) typecasts to avoid compiler warnings thanks to Denis Goddard. + Added ability to pass existing DBD::Oracle select statement handle + (cursor) back _into_ Oracle as a ref cursor type thanks to Mike Moretti. + Note that this enables a workaround for closing ref cursors: + $dbh->do("BEGIN CLOSE :cursor; END;", undef, $sth_ref_csr_to_close); + Improved Win32 support in Makefile.PL thanks to Michael A. Chase. + Workaround Win32::TieRegistry FETCH error during global destruction. + Re-enable row cache by default for OCI8 (can give big speed increase). + Fixed bug in OCI8 row cache calculation thanks to Greg Stark. + +Changes in DBD::Oracle 1.04 11th July 2000 + + Added info on workarounds for Java thread related linker errors + on Solaris with Oracle 8.1.6. Thanks to Andi Lamprecht. + Fixed memory leak on connect. Thanks to Jeffrey W. Baker. + Fixed memory and ref cursor leaks. Thanks to Mike Moretti and John Tobey. + Fixed SEGV on insert/update or many LOBS. Thanks to Honza Pazdziora. + Fixed treating SUCCESS_WITH_INFO from finish() as an error. + Fixed passing of attribs to connect thanks to K.Takaoka. + Fixed cursor binding example in docs thanks to Michael Chase. + Build using otrace/demo/atmoci.mk as last resort thanks to Chris Sylvain. + Improved reliability of "perl Makefile.PL -b" configure option. + Improved reliability of t/plsql.t cursor tests. Hopefully. + Improved reliability of ping method. + Fixed broken SQL type warning in bind_param. + +Changes in DBD::Oracle 1.03 12th July 1999 + + Added "perl Makefile.PL -b" configure option. Links DBD::Oracle + using same linker args as Oracle's own OCI demo applications. + Added connect("dbi:Oracle:host=foo;sid=bar", ...) syntax. + Added OCI8 function trace at level 6, useful for Oracle support. + Added ora_session_mode attribute to connect (eg SYSDBA/SYSOPER). + Added test for Oracle security problem. See README.sec. + Updated ora_explain tool to v1.1 thanks to Alan Burlison. + Contributions from Michael Chase (plus docs from Andy Duncan): + Documented plsql_errstr & dbms_output_enable/_put/_get. + Enhanced $dbh->func('plsql_errstr') output. + Replaced old Oraperl examples with DBI/DBD::Oracle ones. + +Changes in DBD::Oracle 1.02 14th June 1999 + + LongReadLen no longer limited to 64KB for OCI 7 & 8! + But beware of OCI 7 bug when fetching >64KB. + See t/long.t for more details. + Fixed OCI7 ref cursor missing data row. + Fixed OCI8 LOB statement handle leak & improved trace. + +Changes in DBD::Oracle 1.01 8th June 1999 + + Enhanced diagnostics in t/long.t test suite. + Removed byte with high-bit set from t/long.t test data. + Disable finish if database disconnected or perl is terminating. + Made t/general.t work with other NLS settings. + Added Cygwin support thanks to Alexander Smishlajev. + Fixed 'undeclared identifier' error building with old Oracle's. + +Changes in DBD::Oracle 1.00 4th June 1999 + + Increased default row cache size for improved performance. + Added OCI8 binding of cursors! Sponsored by cp.net. + Added OCI7 binding of cursors! (Was easier after OCI8 work :-) + Added OCI8 blob_read (only for LOBs not LONGs) thanks to Jim Lawson. + Added OCI8 re-authentication thanks to John Tobey. + Added t/long.t test script for LONG/LONG RAW/CLOB/BLOB handling. + Length of fetched LONG RAW string now 2 * LongReadLen for OCI7 & 8. + Fixed LONG fetches being one byte longer than LongReadLen. + Fixed OCI8 non-reporting of LobWrite error. + Fixed OCI8 "LongReadLen too small and/or LongTruncOk not set" hint. + Fixed OCI7 probable cursor leak. + Fixed ping method to be more robust. This should fix + the "morning bug" problem with Apache::DBI. + Fixed t/general.t core dump thanks to Donald Buczek. + Fixed ora_check_sql prepare attribute (for selects). + Fetch errors (non-row level) now turn off the Active attribute. + +Changes in DBD::Oracle 0.61, 9th April 1999 + + Fixed execute() always returning 0 rows! (with OCI 7). + Fixed $sth->bind_param(..., SQL_CHAR); + Assorted minor Makefile.PL improvements. + Added ora_check_sql attribute to prepare() for OCI8. + +Changes in DBD::Oracle 0.60, 10th March 1999 + + Fetching all records now resets Active flag as it should. + Finally fixed "Can't bind unknown placeholder" (hopefully :-). + Fixed placeholder parser to ignore comments, thanks to JD Laub. + Fixed placeholder parser to ignore double-quotes strings. + No longer changes ORACLE_HOME to match oratab, by default. + Fixes for OCI 8: + Fixed selection of very large numbers (132 digits). + Fixed small memory leak in parameter binding. + Fixed small memory leak in prepare of statements using LOBs. + Fixed binding empty strings. + Fixed OCILobRead error when fetching of zero length LOBs. + Fixed OCILobWrite of zero length to use OCILobTrim instead. + Treat SUCCESS_WITH_INFO from OCIStmtExecute as SUCCESS. + Enabled OCI_CRED_EXT login thanks to Alan Burlison & Jeremy Brinkley. + Modified hints/svr4.pl - SVR4 users please test. + Updated Alan Burlison's ora_explain Tk tool to version 1.0. + +Changes in DBD::Oracle 0.59 (Oraperl 1.37), 27th December 1998 + + Fixed detection of ambiguous LOB-param-to-table-field assignment + (previous fix had typo). Only affects multiple LOBs in same table. + Added support for Oracle 8's "... RETURNING foo,bar INTO :foo,:bar" + for simple scalar types (not LOBs or arrays) via bind_param_inout. + Cleaned up the code. + Improved Oracle 8 library selection code for Win32 (untested). + +Changes in DBD::Oracle 0.58 (Oraperl 1.37), 22nd December 1998 + + Fixed detection of ambiguous LOB-param-to-table-field assignment. + Added bind_param ora_field attribute to disambiguate if needed. + +Changes in DBD::Oracle 0.57 (Oraperl 1.37), 21st December 1998 + + Fixed bug preventing fetching LONGs when using OCI 8, better. + (Oracle bug #641812 not involved. Should work for all 8.0.x) + +Changes in DBD::Oracle 0.56 (Oraperl 1.37), 19th December 1998 + + Fixed bug preventing fetching LONGs when using OCI 8. + (Oracle bug #641812 may still cause failure prior to v8.0.5.) + Fixed LongTruncOk to work when using OCI 8. + Fixed bug in table name detection code for OCI8 LOB refetch. + SCALE & PRECISION work for OCI 7 & 8. + +Changes in DBD::Oracle 0.55 (Oraperl 1.37), 16th December 1998 + + Major internal work to support Oracle 8 OCI. + Oracle 8 LOBs are supported and treated as LONGs (DBD::Oracle works + hard to hide the complexities of handling Lob Locators for you). + See Oracle 8 section in the docs for more details. + Added $sth->{TYPE}. + SCALE & PRECISION are implemented but return 0 (Oracle bug?). + DBI 1.02 or later is required. + Assorted build time Makefile.PL improvements. + Builds with 5.004_04, 5.005_02 and 5.005_54 (not _53). + Added "use DBD::Oracle qw(:ora_types);" + +Changes in DBD::Oracle 0.54 (Oraperl 1.37), 14th August 1998 + + Added $dbh->type_info_all. + Fixed $dbh->tables (partly by renaming to new $dbh->table_info). + data_sources no longer adds abbreviated versions of tnsnames. + Alan Burlison's whizzo Tk based explain script now bundled. + Revised workaround for "Can't bind unknown placeholder '3'" errors. + Doubled default automatic row cache size (now approx 5KB). + The resetting of Oracle's SIGCHD handler to SA_RESTART can + now be disabled by setting the env var DBD_ORACLE_SIGCHLD=0. + Fixed Makefile.PL -c to better avoid shared Oracle lib. + +Changes in DBD::Oracle 0.53 (Oraperl 1.37), 3rd August 1998 + + Further build fixes (esp kpudc problem with Oracle 8). + Now prefers oracle.mk over proc.mk again. + Only $ENV{ORA_CLIENT_LIB} ||= 'shared' if shared lib exists. + Builds okay with 5.005-thread (not tested). + +Changes in DBD::Oracle 0.52 (Oraperl 1.37), 28th July 1998 + + Assorted build fixes (esp. Win32, HP-UX and AIX). + More hints on error messages, especially long truncation and + field-level errors when fetching. + Compiles okay now for systems without SQLT_CUR defined. + Only sets SA_RESTART on SIGCLD if connect was successful. + +Changes in DBD::Oracle 0.51 (Oraperl 1.37), 5rd July 1998 + + Makefile.PL no longer tries to link with just -lclntsh directly :-( + Improvements to some HP-UX builds (hopefully). + DBI->data_sources ' dummy ' value removed (and list now sorted). + connect failure now shows actual Oracle error message again. + Initial (incomplete) support for binding cursor vars (see t/plsql.t). + +Changes in DBD::Oracle 0.50 (Oraperl 1.36), 3rd June 1998 + + Makefile.PL changes: fixed -c option, now searches for .h files, + tries alternate location for sysliblist, checks for executable + orainst/inspdver before using it. + Fixed cursor leak. + Added first word of tnsnames.ora name as aliases if no clash. + +Changes in DBD::Oracle 0.49 (Oraperl 1.36), 1st June 1998 + + Further improvements to build process over 0.48. + Fixed broken truncation error in 0.48. + Fetch ORACLE_SID from Win32 registry (thanks to Preston Bannister) + Improved automatic row cache sizing (prompted by Jon Meek). + Added $sth->{ora_cache_rows} and $sth->{ora_est_row_width} + as read-only attributes to make cache size logic easier to test. + +Changes in DBD::Oracle 0.48 (Oraperl 1.36), 25th May 1998 + + THIS IS AN EXPERIMENTAL RELEASE - USE WITH CAUTION! + Now links to -lclntsh directly (Thanks to Bruce Nelson and others) + Workaround for broken backticks after login (Thanks to Warren Jones) + Now finds and reads tnsnames.ora to disambiguate dbnames in connect. + Added basic support for bind_param(..., SQL_TYPE). + Fixed bind_param_inout after execute. + Added dbms_output_(enable|put|get) functions. + Added $dbh->ping. + Added DBI->data_sources('Oracle'); + $sth->rows now warns if called for select before rows fetched. + Fixed RAW types to not truncate. + Improved quality and clarity of trace information. + Requires DBI 0.92 + +Changes in DBD::Oracle 0.47 (Oraperl 1.35), 8th Sept 1997 + + $h->{InactiveDestroy} = 1; now works reliably (with DBI 0.90). + Makefile.PL changed for Oracle8. Thanks to Philippe Vanhaesendonck. + Long params now work. Thanks to Michael Harvey. + (Long params don't yet work for inout params.) + AutoCommit flag now per-dbh. Thanks to Irving Reid. + Fixed panic: _dbd_rebind_ph when binding an undef. + Added $dbh->ping method (for Apache::DBI users). + Some field-level fetch errors didn't cause the fetch to fail + (the field was simply set undef). + LongReadLen now works (if $Oraperl::ora_trunc unset or <= 0) + LongTruncOk now works (for non oraperl mode handle). + +Changes in DBD::Oracle 0.46 (Oraperl 1.34), 20th June 1997 + + Fixed Makefile.PL to work with 5.004_01. + Some VMS support from Dan Sugalski + If ORACLE_HOME isn't set, Oracle.pm no longer tries to guess it. + bind_param_inout now checks for read-only variables. + Requires DBI 0.84. + +Changes in DBD::Oracle 0.45 (Oraperl 1.33), 16th June 1997 + + A $dbh DESTROY without an explicit disconnect does a rollback. + Note that this may 'break' existing 'lazy' code but is completely + essential for robust applications. See comments in Oracle.xs. + + Added Makefile.PL changes from Eric Bartley and others. + The changes should fix build problems for Oracle 7.3.x. + + Requires DBI 0.83. + + Oraperl now uses DBI->connect and thus works with DBI 0.81 to + automatically support Apache without requiring script changes. + + Reworked parameter binding in preparation for future changes. + - mutated placeholder values are now automatically rebound. + - in/out vars that become undef/null after binding now work. + - transparent support for longs should be easier to implement. + + Added Win32 support from Jeff Urlwin. + + Added some documentation to DBD::Oracle for 'perldoc DBD::Oracle'. + + Most tests now converted to standard t/*.t format. + Added $sth->{NULLABLE}->[$field]. + Added private plsql_errstr method: $txt=$dbh->func('plsql_errstr') + to fetch PL/SQL error messages. Thanks to Bob Menteer. + Added $sth->{ora_pad_empty} and ORAPERL_PAD_EMPTY env var + for better compatibility with old oraperl. + Added $sth->{AutoCommit} FETCH. + Added $sth->{ChopBlanks} (but not yet tested). + No longer asks Oracle for text of login failure message since + that can cause oracle's code to hang (sigh). We provide fake text + for the most common errors and a useful default for the rest. + You can set DBD_ORACLE_LOGIN_ERR env var to revert to old behaviour. + + The Copyright terms for DBD::Oracle have changed and now read as follows: + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file, + with the exception that it cannot be placed on a CD-ROM or similar media + for commercial distribution without the prior approval of the author. + +Changes in DBD::Oracle 0.44 (Oraperl 1.30), 14th Jan 1997 + + Fixed leak in read_blob (thanks to Jurgen Botz for the patch). + Improved automatic cache sizing (so better default caching). + Negative cache size specifies desired cache/transfer size in bytes. + Added $rowid = $csr->{ora_rowid} attribute (untested, please test). + (Use via $csr->bind_param(1, $rowid, { ora_type => 11 });) + Queries returning LONG's are no longer cached (so there's no + need to set the cache to 1 explicitly to get read_blob to work). + Added a test using string type with bind_param_inout in test.pl. + Worked around the rather sad VMS linker case insensitivity. + Worked around VMS linker length warning on XS...disconnect_all. + Makefile.PL deletes non-existant files from $(COMPOBJS) + (thanks to aburlison@cix.compulink.co.uk for the original patch) + +Changes in DBD::Oracle 0.43 (Oraperl 1.30), 29nd Oct 1996 + + Fixed serious 'false ora_errno 1 after short select' bug. + Worked around oracle bug that makes cda->ft unreliable. + Do not use DBD::Oracle 0.41 or 0.42. + Cursors are now 'describe'd at prepare time thus making + NUM_OF_FIELDS always available. Describe does nothing for + non-select operations. NUM_OF_FIELDS > 0 is now used to + select between oexec() and oexfet() in execute(). + Added more internal debugging. Improved test.pl. + +Changes in DBD::Oracle 0.42 (Oraperl 1.30), 28nd Oct 1996 + + Fixed serious 'cache empty after re-bind' bug. + Do not use DBD::Oracle 0.41. + Implemented oexfet (combined execute and cache fetch) for + select operations. This is a further significant speed up. + Many selects now make only one trip to Oracle (after prepare) + which combines the execute and fetching multiple rows. + +Changes in DBD::Oracle 0.41 (Oraperl 1.30), 22nd Oct 1996 + + Added the long overdue row cache to DBD::Oracle. + (Thanks to Reetnem@aol.com for providing a patch that prompted + me to complete the work.) + Oraperl $ora_cache and cache parameter to ora_open now work. + Default cache size is adjusted automatically for row width. + Major reworking of field buffer memory management. + Added a more internal debugging. + Further updates to the README files. + +Changes in DBD::Oracle 0.40 (Oraperl 1.29), 14th Oct 1996 + + WARNING - This release contains significant changes to the + placeholding binding code. You should test it carefully + before using in live systems. + + Implemented PL/SQL output values via $sth->bind_param_inout. + See the code at the end of test.pl for example usage. + + Binding is now implemented using obndra rather than obndrv. + This may have a subtle effect when matching char fields + against placeholders with trailing spaces. + + Fixed bind_param ora_type attribute. Thanks to Stephen Zander + for the patch. Updated README's. Added README.longs. + +Changes in DBD::Oracle 0.39 (Oraperl 1.29), 23rd Sep 1996 + + Fix for DEC "target := MACRO = string" Makefile syntax. + Added README notes from Dave Moellenhoff, Lou Henefeld and others. + Added README.login from James Taylor. + Added README.client with various notes about building DBD::Oracle + on minimaly configured client systems. + Extra parameters to ora_do are now passed to DBI's do(). + (This is an extension to the original oraperl ora_do.) + +Changes in DBD::Oracle 0.38 (Oraperl 1.28), 22th Aug 1996 + + Overhaul of Makefile variable parsing. Should now cope with + complex variables which expand to nested shell escapes. + Try perl Makefile.PL -v to watch the fun. + Updated README, Makefile.PL and test.pl messages for clarity. + Fixed possible memory corruption in dbd_bind_ph(). + +Changes in DBD::Oracle 0.37 (Oraperl 1.28), 25th July 1996 + + Fixed Makefile.PL for Oracle 7.3.2. + Fixed $num_fields = ora_fetch($csr) before first fetch for + queries with bind vars. + Fixed occasional core dump on global destruct. + +Changes in DBD::Oracle 0.36 (Oraperl 1.28), 10th July 1996 + + Fixed bind_param ora_type attribute. + Fixed preparse to allocate enough memory for worst case. + Fixed broken HP-UX 10 check in Makefile.PL. + Other assorted Makefile.PL improvements. + (Many thanks to those who sent in fixes.) + +Changes in DBD::Oracle 0.35 (Oraperl 1.28), 21st June 1996 + + Fixed broken Solaris 2.5 check in Makefile.PL. + Added ld path to the log. + +Changes in DBD::Oracle 0.34 (Oraperl 1.28), 21st June 1996 + + Workaround Solaris 2 bug #1224467 (_rmutex_unlock). + With many thanks to James Taylor. + + Added 'Bad free()' warning suppression to ora_logon and + ora_logoff(). Setting the DBD_DUMP environment variable + will trigger a (handy for me) core dump if a Bad free + warning is detected. + + Further additions to the README about Bad free()'s. + +Changes in DBD::Oracle 0.33 (Oraperl 1.27), 19th June 1996 + + Added Makefile.PL -g option to enable debugging. + Added Makefile.PL -s symbol_name option to search for symbols. + Reorganised the way Makefile.PL uses MakeMaker liblist code. + Oraperl defaults to the 'safe' (normal) mode of using the DBI. + Oraperl uses sigtrap on SEGV & BUS to give a perl stack trace. + Added README notes about -g option, core files and stack traces. + Small change to $dbname/$user/$passwd logic in connect. + +Changes in DBD::Oracle 0.32 (Oraperl 1.25), 30th May 1996 + + Fixed memory leak when FETCH'ing attributes. + Fixed Makefile.PL FileHandle problem (forgot 'use FileHandle;'). + Enhanced Makefile.PL support for Oracle 7.3. + +Changes in DBD::Oracle 0.31 (Oraperl 1.25), 20th May 1996 + + Makefile.PL for HP-UX now defaults to dynamic for hpux >= 10. + + execute (ora_bind/ora_do) now returns undef on error or the + number of rows affected (0 is returned as 0E0, hence true, for + okay but no rows affected or no row count available/applicable). + This matches the oraperl version 2.4 behaviour. + + Made an attempt at supporting Oracle 7.3 (e.g. include's in proc.mk) + Please let me know if it works (else supply patches to fix it :-) + + Fixed small memory leak in ora_titles etc functions. + +Changes in DBD::Oracle 0.30, 7th May 1996 + + THE ORAPERL EMULATION LAYER IS NOW FORMALLY RELEASED (NO LONGER ALPHA). + + Note that the underlying DBI and DBD::Oracle interfaces remain alpha + because they are still subject to (possibly significant) change. + + Oraperl v2 used to return the string 'OK' to indicate success + with a zero numeric value. The Oraperl emulation now uses the + string '0E0' to achieve the same effect since it does not cause + any -w warnings when used in a numeric context. + + Fixed typecast warning (s/safefree/Safefree). + Automatically sets/resets ORACLE_HOME from oratab value for sid. + + TO DO: Automatic configuration from Oracle 7.3 is not yet working + (Oracle have reorganised the makefiles yet again!). + +Changes in DBD::Oracle 0.29, 2 March 1996 + + Fixed Makefile.PL to get DBIXS.h from right spot. + Changes to suit perl5.002 and site_lib directories. + Detects old versions ahead of new in @INC. + Random tidy-ups. + +Changes in DBD::Oracle 0.28, 29 Jan 1996: + + Minor release for Perl5.002 (beta2 or later). + Requires Perl5.002 and DBI 0.66; + + Only functional change is to suppress (rare) 'handle not setup' + warnings unless debugging. + +Changes in DBD::Oracle 0.27, 16 Nov 1995: + + Improved oraperl compatibility in assorted ways. + Added the original oraperl manual to Oraperl.pm as pod. + (perldoc Oraperl will display the manual). + The manual highlights remaining differences in the emulation. + Added original oraperl examples into oraperl.ex directory. + + Improved error reporting in test.pl. + Removed some internal limits. + Renamed readblob to blob_read and fixed return value. + Implemented $sth = $dbh->tables method (see DBI changes file). + Uses $Config{archlibexp} not $Config{archlib} in makefile.PL + Requires DBI-0.65. + + I've still not got around to implementing a row cache (array + fetch) but it's next on my list. + + This should be the last alpha release of the oraperl emulation. + (The DBD::Oracle module itself will remain alpha for awhile yet.) + + +Changes in DBD::Oracle 0.26, 23 Oct 1995: + + Removed error message (sql) size limits in parse and ora_error. + Fixed FETCH NUM_OF_PARAMS so it doesn't trigger a describe. + The ora_lengths and ora_types attributes work in non-oraperl mode. + + +Changes in DBD::Oracle 0.25, 26 Aug 1995: + + User visible changes: + + Fixed bug in parsing '?' style placeholders. + $sth->bind_param now checks for a too long LONG type string. + $sth->prepare now takes attributes: + ora_parse_lang => 0 | 1 | 2 (v6, auto v6/v7, v7) + ora_parse_defer => 0 | 1 (control defered parsing) + + Other changes to be propogated to other drivers: + + Added usage of new DBD_ATTRIB_* macros to XS and C code. + dbd_bind_ph return value inverted to make it consistent. + Added braces around XSRETURN_UNDEF in execute. + Checked for describe failure in FETCH. + Removed NumParams since it's now called NUM_OF_PARAMS in DBI. + Updated NEED_DBIXS_VERSION in Oracle.h + + +Changes in DBD::Oracle 0.24, 22 Aug 1995: + + User visible changes: + + $sth->bind_param method implemented (needs testing :-) + and new DBI $sth->bind_col* methods work for DBD::Oracle. + + Other changes to be propogated to other drivers: + + - Slight change to STORE functions to allow them to return status + if called as $h->STORE(...). + + - Revised signature of dbd_bind_ph function and added a bind_param + method for it. Prototype moved from dbdimp.h to Oracle.h + + - Revised execute method to use modified dbd_bind_ph function and + remove remaining oracle specifics. + + - imp_xxh_t structures first element now called 'com' not 'dbihcom' + and new DBI macros used to access fields. + + +Changes in DBD::Oracle 0.23, 18 Aug 1995: + + Fixed Oraperl.pm debug which was left on by default by accident. + Added small patches from Davide.Migliavacca@inferentia.it for + longs (dbtype_is_long, dbd_describe and dbd_st_readblob). + Added svr4 hints from Alan Burlison + Changed dbd_describe to return true for success (to be consistent). + + +Changes in DBD::Oracle 0.22, 17 Aug 1995: + + Much more maturity, in line with the required DBI-0.60 release. + The .xs file is now very 'clean'. It's an excellent base for + developing other drivers. See notes in the DBI Changes file. + + The oraperl &ora_do should be working now (along with $sth->do()). + It does not leak (as far as I can tell). + + This release is stable enough for general use again (like 0.20). + Please test heavily. + + +Changes in DBD::Oracle 0.21, 15 Aug 1995: + + NOTE: THIS IS AN UNSTABLE RELEASE! + It requires the closely related DBI 0.59 release. + See Changes file in that release. + Major reworking of internal data management! + + Only execute and fetchrow have yet to move into dbdimp.c. + These were kept back since I plan other associated changes. + + Known problems: + Warning mode is on by default so certain oraperl coding + styles cause warnings such as: + Statement handle ... destroyed without finish() at ... + disconnect(...) invalidates 1 associated cursor(s) at ... + In future oraperl mode handles will have those warnings disabled. + ...other changes to numerous/minor to mention + +Changes in DBD::Oracle 0.20, 1 Aug 1995: + + Fixed core dump when binding an undef (treated as a NULL) + Binding a string longer that 2000 bytes will use LONG type. + Workaround OSF makefile and oratype.h problems + PL/SQL := construct will no longer confuse dbd_preparse() + +Changes in DBD::Oracle 0.19, 21 June 1995: + + Added $VERSION + disconnect_all now gives error 'not implemented'. + Reworked memory management, imp_dbh's are cached. + imp_dbh_t now has an in_use flag and generation counter. + st::DESTROY now checks its imp_dbh for validity. + &ora_do() now returns "OK" for 0 rows (as per oraperl). + Reworked logging to use DBILOGFP macro. + Now test code added to loop through logon/prep/fin/logoff. + + +Changes in DBD::Oracle 0.18: + + Makefile.PL: HPUX now builds with LINKTYPE=static automatically. + Fixed errors on logout/global destruction. + Added logout/global destruction test to test.pl. + Changed Oraperl.pm default mode from safe to fast (see func_ref()). + Added platform who's-who list to README. + Added $sth->readblob($field, $offset, $length [, \$dest) method. + (You need to add the following after line 80 in DBI/DBI.pm: + 'readblob' => {'U'=>[4,5,'$field, $offset, $len [, \\$buf]']}, + in order to access the new readblob method.) + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 00000000..55f43923 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,43 @@ +Changes +MANIFEST +Makefile.PL +Oracle.ex/Readme +Oracle.ex/bind.pl +Oracle.ex/commit.pl +Oracle.ex/ex.pl +Oracle.ex/japh +Oracle.ex/mktable.pl +Oracle.ex/oradump.pl +Oracle.ex/proc.pl +Oracle.ex/sql +Oracle.ex/tabinfo.pl +Oracle.h +Oracle.pm +Oracle.xs +Oraperl.pm +README +README.clients +README.explain +README.help +README.java +README.login +README.longs +README.sec +README.win32 +README.wingcc Notes about building with mingw32 and cygwin32 +Todo +dbdimp.c +dbdimp.h +hints/svr4.pl +oci.def OCI.DLL export declarations +oci7.c +oci8.c +ocitrace.h +ora_explain.PL +oraperl.ph Old oraperl file included for completeness of emulation +t/base.t +t/general.t +t/long.t +t/plsql.t +t/reauth.t +test.pl diff --git a/Makefile.PL b/Makefile.PL new file mode 100755 index 00000000..5fc8966b --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,1117 @@ +# $Id: Makefile.PL,v 1.84 2000/07/13 22:42:02 timbo Exp $ + +## +## You should not need to edit this file. +## + +BEGIN { $^W = 1 } +BEGIN { require 5.003 } # 5.003 fixes very important bugs + +use ExtUtils::MakeMaker 5.16, qw(&WriteMakefile $Verbose); +use Getopt::Long; +use Config; +use Cwd; +use File::Find; +use strict; + +# This DBI must be installed before we can build a DBD. +# For those not using Dynamic loading this means building a +# new static perl in the DBI directory by saying 'make perl' +# and then using _that_ perl to make this one. +use DBI 1.08; +use DBI::DBD; # DBD creation tools + + +# Some MakeMaker's forged some FileHandle methods +require FileHandle unless defined(&FileHandle::new); + +BEGIN { if ($^O eq 'VMS') { + require vmsish; + import vmsish; + require VMS::Filespec; + import VMS::Filespec; +}} + + +my $dbi_dir = dbd_dbi_dir(); +my $dbi_arch_dir = dbd_dbi_arch_dir(); +my $os = $^O; +my $osvers = $Config{osvers}; +$osvers =~ s/^\s*(\d+\.\d+).*/$1/; # drop sub-sub-version: 2.5.1 -> 2.5 +my $exe_ext = ($os eq 'VMS') ? '.pl' : ''; + +my %opts = ( + NAME => 'DBD::Oracle', + VERSION_FROM => 'Oracle.pm', + EXE_FILES => [ "ora_explain$exe_ext" ], + OBJECT => '$(O_FILES)', + DEFINE => '', + DIR => [], + clean => { FILES => 'Oracle.xsi dll.base dll.exp sqlnet.log libOracle.def ora_explain' }, + dist => { DIST_DEFAULT => 'clean distcheck disttest ci tardist', + PREOP => '$(MAKE) -f Makefile.old distdir', + COMPRESS => 'gzip -v9', SUFFIX => 'gz', + }, +); +if ($ExtUtils::MakeMaker::VERSION >= 5.43) { + $opts{AUTHOR} = 'Tim Bunce (dbi-users@isc.org)'; + $opts{ABSTRACT_FROM} = 'Oracle.pm'; + $opts{PREREQ_PM} = { DBI => 0 }; + $opts{CAPI} = 'TRUE' if $Config{archname} =~ /-object\b/i; +} + +$opts{LINKTYPE} = 'static' if $Config{dlsrc} =~ /dl_none/; + +my(@MK, %MK, $MK, %MK_expanding); # parsed macros from Oracle's makefiles +my %mk_target_deps; +my %mk_target_rules; + +# Options (rarely needed) +$::opt_b = 1; # try to use Oracle's own 'build' rule +$::opt_m = 0; # path to proc.mk or oracle.mk file to read +$::opt_p = ''; # alter preference for oracle.mk over proc +$::opt_n = ''; # Oracle .mk macro name to use for library list to link with +$::opt_c = 0; # don't encourage use of shared library +$::opt_l = 0; # try direct-link to libclntsh +$::opt_g = ''; # enable debugging (-g for compiler and linker) +$::opt_s = ''; # Find a symbol in oracle libs, Don't build a Makefile +$::opt_S = ''; # Find a symbol in oracle & system libs, Don't build a Makefile +$::opt_v = 0; # be more verbose +$::opt_d = 0; # much more verbose for debugging +$::opt_8 = 0; # disable use of OCI 8 (where available) + +GetOptions(qw(b! v! d! g! p! l! c! 8! m=s n=s s=s S=s)) + or die "Invalid arguments"; + +$::opt_g &&= '-g'; # convert to actual string +$::opt_v = 1 if $::opt_d; +$Verbose = 1 if $::opt_v; + + +# --- Introduction + +print "\n Configuring DBD::Oracle ...\n +>>>\tRemember to actually *READ* the README file! + \tEspecially if you have any problems.\n +" unless $::opt_s; + + +# --- Where is Oracle installed... + +my $ORACLE_ENV = ($os eq 'VMS') ? 'ORA_ROOT' : 'ORACLE_HOME'; + +my $OH = $ENV{$ORACLE_ENV} || ''; +$OH = win32_oracle_home($OH) if ($os eq 'MSWin32') or ($os =~ /cygwin/i); +($OH = unixify $OH) =~ s:/$:: if $os eq 'VMS'; + +die qq{ The $ORACLE_ENV environment variable must be set. + It must be set to hold the path to an Oracle installation directory + on this machine (or a machine with a compatible architecture). + See the README.clients file for more information. + ABORTED! +} unless $OH; + +die qq{ The $ORACLE_ENV environment variable value ($OH) is not valid. + It must be set to hold the path to an Oracle installation directory + on this machine (or a compatible archtecture). + See the README.clients file for more information. + ABORTED! +} unless -d $OH; + +print "Using Oracle in $OH\n"; + +# We'll try to dig up some Oracle version information. Not essential. +my (@inspdver, %inspdver); $inspdver{RDBMS} = 0; +if ($os ne 'VMS' and $os ne 'MSWin32' and -x "$OH/orainst/inspdver") { + open INST, "$OH/orainst/inspdver |"; + my @inspdver = ; + close INST; + foreach (@inspdver) { + chop; + $inspdver{$2} = $1 if m/^(\S+)\s+(.*)/; + $inspdver{RDBMS} = $1 if m/^(\d+\.\d+\.\d+)\S*\s+.*RDBMS/; + next unless $::opt_v + or m/RDBMS/i or m/PL.SQL/i + + or m/Precomp/i or m/Pro\*C/i; + print "$_\n"; + } + print "\n"; + if ($inspdver{RDBMS} =~ /^7.3.[12]/ and $os eq 'hpux') { + print "DBD::Oracle for Oracle $inspdver{RDBMS} on HP-UX may not build ok.\n"; + print "If your have problems read the README (in fact, read it anyway!)\n"; + print "An upgrade to Oracle 7.3.3 is probably a good idea.\n"; + sleep 5; + } +} + +symbol_search() if $::opt_s or $::opt_S; + + +# --- How shall we link with Oracle? Let me count the ways... + +my @mkfiles; +my $linkwith; +my $linkwith_msg; +my $need_ldlp_env; + +if ($os eq 'VMS') { + my $OCIINCLUDE = vmsify("$OH/rdbms/") ." ". vmsify("$OH/rdbms/demo/oci_demo/"); + $opts{INC} = "$OCIINCLUDE $dbi_arch_dir"; + $opts{OBJECT} = 'oracle.obj dbdimp.obj oci7.obj oci8.obj' if $] < 5.005; +} + +elsif (($os eq 'MSWin32') or ($os =~ /cygwin/i)) { + my $OCIDIR = ""; + find( sub { + print "Found $_ directory\n" if /^OCI\d*$/i; + $OCIDIR = $_ if /^OCI\d*$/i && $OCIDIR lt $_; + $File::Find::prune = 1 if -d $_ && $_ !~ /^\./; + }, $OH ); + die "OCI directory not found, please install OCI in $OH" if ! $OCIDIR; + print "Using OCI directory '$OCIDIR'\n"; + + if ($Config{cc} =~ /gcc/i) { + $opts{LIBS} = [ "-loci" ]; + print "Using liboci.a (did you build it?)\n"; + } else { + my %OCILIB; + my $oci_compiler_dir; + my @oci_compiler_dirs = + map { -d "$OH/$OCIDIR/lib/$_" ? "$OH/$OCIDIR/lib/$_": () } + $Config{cc} eq 'bcc32' ? qw(BORLAND BC) : qw(MSVC); + find( sub { + $File::Find::prune = 1 if -d $_ && $_ !~ /^\./; + return unless /^(OCI|ORA).*\.LIB$/i; + ($oci_compiler_dir = $File::Find::dir) =~ s:^.*/::; + print "Found $OCIDIR/lib/$oci_compiler_dir/$_ library\n"; + $OCILIB{uc($_)} = $_; + }, @oci_compiler_dirs ); + # sort the version numbered libs into assending order + my @OCILIB = sort grep { /(OCI|ORA)\d\d+\./i } keys %OCILIB; + # prefer the non-versioned library if present + push @OCILIB, "OCI.LIB" if $OCILIB{'OCI.LIB'}; + # opt_8 means DISABLE use of OCI 8 API + push @OCILIB, "OCIW32.LIB" if $OCILIB{'OCIW32.LIB'} && $::opt_8; + my $OCILIB = pop @OCILIB || ''; + $OCILIB =~ s/\.LIB$//i; + + die qq{ + Unable to find required Oracle OCI files for the build. Please check + that you have your OCI installed in your oracle home ($OH) + directory and that it has the following files (and probably more): + + $OH\\$OCIDIR\\include\\oratypes.h + $OH\\$OCIDIR\\lib\\$oci_compiler_dir\\$OCILIB.lib + + Please install OCI or send comments back to dbi-users\@fugue.com + if you have an OCI directory other than $OCIDIR. + + } unless (-e "$OH/$OCIDIR/include/oratypes.h" + && -e "$OH/$OCIDIR/lib/$oci_compiler_dir/$OCILIB.lib"); + + print "Using $OCIDIR/lib/$oci_compiler_dir/$OCILIB.lib\n"; + $opts{LIBS} = [ "-L$OH/$OCIDIR/LIB/$oci_compiler_dir $OCILIB" ]; + }; + + my $OCIINCLUDE = "-I$OH/$OCIDIR/include -I$OH/rdbms/demo"; + $opts{INC} = "$OCIINCLUDE -I$dbi_arch_dir"; +} + +# --- UNIX Variants --- + +elsif ($::opt_l and # use -l to enable this direct-link approach + @_=grep { m:/lib(cl(ie)?ntsh|oracle).\w+$:o } <$OH/lib/lib*> + ) { + # --- the simple modern way --- + foreach(@_) { s:\Q$OH/lib/::g } + print "Found direct-link candidates: @_\n"; + my $lib = ("@_" =~ m:lib(cl(ie)?ntsh)\.:) ? $1 : "oracle"; + $linkwith_msg = "-l$lib."; + my $syslibs = (-f "$OH/lib/sysliblist") + ? read_file("$OH/lib/sysliblist") + : read_file("$OH/rdbms/lib/sysliblist"); + $syslibs =~ s/-l:lib(\w+).(sl|a)\b/-l$1/g if $os eq 'hpux'; + print "Oracle sysliblist: $syslibs\n"; + $opts{LIBS} = [ "-L$OH/lib -l$lib $syslibs" ]; + $opts{dynamic_lib} = { OTHERLDFLAGS => "$::opt_g" }; + my $inc = join " ", map { "-I$OH/$_" } find_headers(); + $opts{INC} = "$inc -I$dbi_arch_dir"; +} +else { # --- trawl the guts of Oracle's make files looking the how it wants to link + + my @ora_libs = <$OH/lib/lib*>; + warn "\nYou don't seem to have many Oracle libraries installed. If the" + ."\nbuild fails you probably need to install more Oracle software.\n\n" + if @ora_libs < 6; # just a helpful hint + + # can we give the shared library a helping hand? + my @shared = grep { m:/lib(cl(ie)?ntsh|oracle).\w+$:o } @ora_libs; + # show original value of ORA_CLIENT_LIB if defined ... + print "\$ORA_CLIENT_LIB=$ENV{ORA_CLIENT_LIB}\n" + if defined $ENV{ORA_CLIENT_LIB}; + # ... before we then set it how it probably should be set + # XXX but we still need to write it into the generated Makefile. + $ENV{ORA_CLIENT_LIB} = 'shared' + if !defined $ENV{ORA_CLIENT_LIB} + && ($opts{LINKTYPE}||'') ne 'static' && @shared && !$::opt_c; + + my $mkfile = find_mkfile(); + my $linkvia = fetch_oci_macros($mkfile); + + my $libhome = expand_mkvars($MK{LIBHOME}, 0, 1) || "$OH/lib"; + $linkwith = expand_mkvars($linkvia, 0, 1); + + if ($mk_target_rules{build} && $::opt_b) { + print "\n"; + my $rules = join "\n", '', @{ $mk_target_rules{build} }; + my $DBD_ORA_OBJ = "DBD_ORA_OBJ.o"; + open DBD_ORA_OBJ, ">$DBD_ORA_OBJ" or die; + close DBD_ORA_OBJ; + my $make = "$Config{make} -f $mkfile build " + ."ECHODO=true ECHO=echo GENCLNTSH='echo genclntsh' " + ."EXE=DBD_ORA_EXE OBJS=$DBD_ORA_OBJ"; + print "Discovering Oracle OCI build rules...\n"; + print "by executing:\n$make\n" if $::opt_v; + my @cmds = map { chop; $_ } grep { !m/^\s*$/ } `$make 2>&1`; + warn "Warning: Oracle build rule discovery failed ($?)\n" if $?; + unlink $DBD_ORA_OBJ; + my $prev = ''; + @cmds = grep { my $skip = $prev eq "echo $_"; $prev=$_; !$skip } @cmds; + my @prolog; push @prolog, shift @cmds while @cmds && $cmds[0] !~ /DBD_ORA_EXE/; + print "Oracle oci build prolog:\n\t", join("\n\t", @prolog), "\n" if @prolog; + print "Oracle oci build command:\n\t", join("\n\t", @cmds), "\n"; + while ($cmds[0] =~ s/\\$/ /) { # join lines split with \'s + $cmds[0] .= splice(@cmds,1,1); + } + if (@cmds == 1) { + my $build = $cmds[0]; + $build =~ s/^\s*(true\s+)?(\S+)\s*//; # remove 'true' and compiler/linker + $build =~ s/$DBD_ORA_OBJ//; # remove dummy object file + $build =~ s/\S+\s+DBD_ORA_EXE//; # remove dummy exe file and preceding flag + $linkwith = $build; + # delete problematic crt?.o on solaris + $linkwith = del_crtobj($linkwith, 1) if $os eq 'solaris'; + } + else { + print "Unable to interpret Oracle oci build commands. Using fallback approach.\n"; + $::opt_b = 0; + } + print "\n"; + } + else { + print "Oracle $mkfile doesn't define a 'build' rule.\n" if $::opt_b; + $::opt_b = 0; + } + + $linkwith =~ s/-Y P,/-YP,/g if $Config{'cc'} =~ /gcc/; + $linkwith =~ s:-R /:-R/:g if $os eq 'solaris'; + + if ($::opt_b) { # The simple approach + $opts{dynamic_lib} = { OTHERLDFLAGS => "$::opt_g $linkwith" }; + $linkwith_msg = "OTHERLDFLAGS = $linkwith [from 'build' rule]"; + } + else { # the not-so-simple approach! + # get a cut down $linkwith to pass to MakeMaker liblist + my $linkwith_s = expand_mkvars($linkwith, 1, 1); + + # convert "/full/path/libFOO.a" into "-L/full/path -lFOO" + # to cater for lack of smarts in MakeMaker / Liblist + # which ignores /foo/bar.a entries! + my $lib_ext_re = "(a|$Config{dlext}|$Config{so})"; + $linkwith_s =~ s!(\S+)/lib(\w+)\.($lib_ext_re)\b!-L$1 -l$2!g; + + # Platform specific fix-ups: + # delete problematic crt?.o on solaris + $linkwith_s = del_crtobj($linkwith_s) if $os eq 'solaris'; + $linkwith_s =~ s/-l:lib(\w+)\.sl\b/-l$1/g; # for hp-ux + # this kind of stuff should be in a ./hints/* file: + $linkwith_s .= " -lc" if $Config{osname} eq 'dynixptx' + or $Config{archname} =~ /-pc-sco3\.2v5/; + if ($os eq 'solaris' and $linkwith_s =~ /-lthread/ + and $osvers >= 2.3 and $osvers <= 2.6 + ) { + print "Warning: Solaris 2.5 bug #1224467 may cause '_rmutex_unlock' error.\n"; + print "Deleting -lthread from link list as a possible workround ($osvers).\n"; + $linkwith_s =~ s/\s*-lthread\b/ /g; + } + + # extract object files, keep for use later + my @linkwith_o; + push @linkwith_o, $1 while $linkwith_s =~ s/(\S+\.[oa])\b//; + # also extract AIX .exp files since they confuse MakeMaker + push @linkwith_o, $1 while $linkwith_s =~ s/(-bI:\S+\.exp)\b//; + + $linkwith_msg = "@linkwith_o $linkwith_s [from $linkvia]"; + $opts{LIBS} = [ "-L$libhome $linkwith_s" ]; + $opts{dynamic_lib} = { OTHERLDFLAGS => "$::opt_g @linkwith_o \$(COMPOBJS)" }; + } + + my $OCIINCLUDE = $MK{INCLUDE} || ''; + $OCIINCLUDE .= " -I$OH/rdbms/demo"; + my $inc = join " ", map { "-I$OH/$_" } find_headers(); + $opts{INC} = "$OCIINCLUDE $inc -I$dbi_arch_dir"; +} + + +# --- Handle special cases --- + +# HP-UX 9 cannot link a non-PIC object file into a shared library. +# Since the # .a libs that Oracle supplies contain non-PIC object +# files, we sadly have to build static on HP-UX 9 :( +if ($os eq 'hpux') { + if ($osvers < 10) { + print "Warning: Forced to build static not dynamic on $os $osvers.\a\n"; + $opts{LINKTYPE} = 'static'; + } + else { + print "Warning: You may need to build using static linking. See the README file.\n"; + } + # see const_cccmd for -Aa to -Ae flag change +} + +if ($os eq 'aix' and $osvers >= 4 and $Config{cc} ne 'xlc_r') { + print "\n\n"; + print "Warning: You will probably need to rebuild perl using the xlc_r compiler.\a\n"; + print " You may also need do: ORACCENV='cc=xlc_r'; export ORACCENV\n"; + print " Also see the README about the -p option\n"; + sleep 6; +} + +$opts{DEFINE} .= ' -Wall -Wno-comment' if $Config{cc} eq 'gcc'; + +$opts{DEFINE} .= ' -Xa' if $Config{cc} eq 'clcc'; # CenterLine CC + +$opts{DEFINE} .= ' -DNO_OCI8' if $::opt_8; + +$opts{DEFINE} .= ' $(HP64DEFINES)' if ($os eq "hpux" and $Config{archname} =~ /-thread\b/i + and $Config{ccflags} =~ /\+DD64\b/); + +print "WARNING: Your GNU C compiler is very old. Please upgrade.\n" + if ($Config{gccversion} and $Config{gccversion} =~ m/^(1|2\.[1-5])/); + +# Set some private WriteMakefile options if this is 'me' :-) +if ($ENV{S_ARCH_SW} && $ENV{LOGNAME} eq 'timbo'){ # a reasonable guess + $opts{DEFINE} .= ' -Wcast-align -Wconversion -Wpointer-arith -Wtraditional' + . ' -Wbad-function-cast -Wcast-qual' if $Config{cc} eq 'gcc'; + $::opt_g = '-g'; + $opts{dynamic_lib}->{OTHERLDFLAGS} ||= ''; + $opts{dynamic_lib}->{OTHERLDFLAGS} .= " $::opt_g"; +} + +if ($opts{LINKTYPE} && $opts{LINKTYPE} eq 'static') { + print "** Note: DBD::Oracle will be built *into* a NEW perl binary. You MUST use that new perl.\n"; + print " See README and Makefile.PL for more information.\a\n"; +} + + +# --- final information dumps and generation of the Makefile + +# log key platform information to help others help you quickly if needed +print "\n"; +print "System: perl$] @Config{qw(myuname)}\n"; +print "Compiler: @Config{qw(cc optimize ccflags)}\n"; +print "Linker: ". (find_bin('ld')||"not found") ."\n" unless $os eq 'VMS'; +print "Oracle makefiles would have used these definitions but we override them:\n" + if $MK{CFLAGS} || $MK{LDFLAGS} || $MK{LDSTRING}; +print " CC: $MK{CC}\n\n" if $MK{CC}; +print " CFLAGS: $MK{CFLAGS}\n" if $MK{CFLAGS}; +print " [".mkvar('CFLAGS',0,1,0). "]\n\n" if $MK{CFLAGS}; +print " CLIBS: $MK{CLIBS}\n" if $MK{CLIBS}; +print " [".mkvar('CLIBS',0,1,0). "]\n\n" if $MK{CLIBS}; +if ($mk_target_rules{build} && !$::opt_b) { + my $rules = join "\n", '', @{ $mk_target_rules{build} }; + $rules = expand_mkvars($rules, 0, 0, 1, 1) if $rules =~ /^\s*\$\(\w+\)\s*$/; +print " build: $rules\n"; +print " [".expand_mkvars($rules,0,1,0). "]\n\n"; +} +print " LDFLAGS: $MK{LDFLAGS}\n" if $MK{LDFLAGS}; +print " [".mkvar('LDFLAGS',0,1,0). "]\n\n" if $MK{LDFLAGS}; +print " LDSTRING: $MK{LDSTRING}\n" if $MK{LDSTRING}; +print " [".mkvar('LDSTRING',0,1,0)."]\n\n" if $MK{LDSTRING}; +print "\nLinking with $linkwith_msg\n" if $linkwith_msg; +print "\n"; + +WriteMakefile(%opts); + +# deal with Test::Harness bug +eval { package WAIT; require 'wait.ph' }; +if (!$@ && !defined(&WAIT::WCOREDUMP)) { + print "\n"; + print "You have a wait.ph file generated by perl h2ph utility.\n"; + print "It does not define a WCOREDUMP function. That's probably an error.\n"; + print "If a DBD::Oracle test fails then you will probably see a message\n"; + print "from Test::Harness about WCOREDUMP being undefined. You can either ignore\n"; + print "it or try to fix your wait.ph file. The message does not reflect the\n"; + print "cause of the test failure, it's just a problem interpreting the failure.\n"; + print "\n"; +} + +print "\n*** If you have problems, read the README and README.help files ***\n"; +print " (Of course, you have read README by now anyway, haven't you?)\n\n"; + +check_security() unless $os eq 'VMS' or $os eq 'MSWin32' or $os =~ /cygwin/i; + +exit 0; + + +# ===================================================================== + + +sub win32_oracle_home { + my $oh = shift; + + my ($req_ok, $hkey, $Val, $Keys); + if ( ! $oh ) { + if ( $Config{osname} eq "MSWin32") { + # Win32::TieRegistry is prefered, but it requires Win32API::Registry + # which is not available in mingw or cygwin + eval { + require Win32::TieRegistry; + $Win32::TieRegistry::Registry->Delimiter("/"); + $req_ok = 1; + $hkey = $Win32::TieRegistry::Registry-> + {"LMachine/SOFTWARE/Oracle/"}; + }; + eval { # older name of Win32::TieRegistry + require Tie::Registry; + $Tie::Registry::Registry->Delimiter("/"); + $req_ok = 1; + $hkey = $Tie::Registry::Registry->{"LMachine/SOFTWARE/Oracle/"}; + } unless $req_ok; + eval { + $Val = sub { + # Return value + my ($hkey) = @_; + return $hkey->{ORACLE_HOME} || ''; + }; + $Keys = sub { + # Return list of sub-folder keys + my ($hkey) = @_; + # MAC: %$hkey and related method calls don't work under + # perl5db, so don't try single stepping through here + return map {m:/$: ? $hkey->{$_} : ()} keys %$hkey; + }; + } if $hkey; + } + + # Win32::Registry imports some symbols into main:: + # this is not commonly wanted, so try this as a last resort + # MAC: it is available under mingw and might be available under cygwin + # If cygwin doesn't have it, move the rest inside the other if block + eval { + require Win32::Registry; + $main::HKEY_LOCAL_MACHINE->Open('SOFTWARE\\ORACLE', $hkey); + my $dummy = $main::HKEY_LOCAL_MACHINE; # avoid single use complaint + $Val = sub { + # Return value + my ($hkey) = @_; + my $hval; + $hkey->GetValues($hval); + return $hval->{ORACLE_HOME}[2] || ''; + }; + $Keys = sub { + # Return list of sub-folder keys + my ($hkey) = @_; + my @hkey; + $hkey->GetKeys(\@hkey); + @hkey = map { $hkey->Open($_, $_); $_ } @hkey; + return @hkey; + }; + } unless $req_ok; + + # Look for ORACLE_HOME in all ORACLE sub-folders, use last one found + # before 8.1.5, there should be only one + eval { + my @hkey = ($hkey); + my ($oh1, %oh); + while (@hkey) { + $hkey = shift @hkey; + $oh = $oh1, $oh{$oh1} = 1 + if ($oh1 = &$Val($hkey)) && -d $oh1; + push @hkey, &$Keys($hkey); + } + print "\nMultiple Oracle homes: ", join(" ", sort keys %oh), "\n\n" + if 1 < keys %oh; + } if defined $Keys; + } + + $oh =~ s:\\:/:g if $oh; + return $oh +} + + +# ===================================================================== + + +sub MY::post_initialize { + my $self = shift; + + if (-f "$Config{installprivlib}/DBD/Oraperl.pm"){ # very old now + print " +Please note: the Oraperl.pm installation location has changed. +It was: $Config{installprivlib}/DBD/Oraperl.pm +Is now: $Config{installprivlib}/Oraperl.pm +You have an old copy which you should delete when installing this one.\n"; + } + + if ($Config{privlibexp} ne $Config{sitelibexp}) { + print " +Warning: By default new modules are installed into your 'site_lib' +directories. Since site_lib directories come after the normal library +directories you must delete any old DBD::Oracle files and directories from +your 'privlib' and 'archlib' directories and their auto subdirectories. +"; + if ( $os ne 'VMS' ) { + my ( $sl_exp, $sa_exp, $pl_exp, $al_exp, %old ); + ( $sl_exp = $Config{sitelibexp} ) =~ s:\\:/:g; + ( $sa_exp = $Config{sitearchexp} ) =~ s:\\:/:g; + ( $pl_exp = $Config{privlibexp} ) =~ s:\\:/:g; + ( $al_exp = $Config{archlibexp} ) =~ s:\\:/:g; + my $wanted = sub { + $File::Find::prune = ($File::Find::name eq $sl_exp || + $File::Find::name eq $sa_exp ) && -d $_; + $old{$File::Find::name} = 1 + if ! $File::Find::prune && /^Oracle/; + }; + find( $wanted, $pl_exp, $al_exp ); + print "Here's a list of probable old files and directories:\n ", + join( "\n ", sort keys %old ), "\n" if keys %old; + print "\n"; + } + } + + print "\nNote: \$ORACLE_HOME/lib must be added to your $need_ldlp_env environment variable\n", + "before running \"make test\" and whenever DBD::Oracle is used.\n\n" + if $need_ldlp_env && ($ENV{$need_ldlp_env}||'') !~ m:\Q$OH/lib\b:; + + # Ensure Oraperl.pm and oraperl.ph are installed into top lib dir + $self->{PM}->{'Oraperl.pm'} = '$(INST_LIB)/Oraperl.pm'; + $self->{PM}->{'oraperl.ph'} = '$(INST_LIB)/oraperl.ph'; + + # Add $linkwith to EXTRALIBS for those doing static linking + $self->{EXTRALIBS} .= " -L\$(LIBHOME) $linkwith"; + + ''; +} + + +sub MY::postamble { + return dbd_postamble(@_); +} + + +sub del_crtobj { + my $orig = shift; + my $verbose = shift || $::opt_v; + my $str = $orig; + # E.g. for changing the COMPOBJS line (and sometimes LDSTRING) + # old: COMPOBJS=$(COMPOBJ)/crti.o $(COMPOBJ)/crt1.o $(COMPOBJ)/__fstd.o + # new: COMPOBJS=$(COMPOBJ)/__fstd.o + my @del; + push @del, $1 while $str =~ s:([^\s=]*\bcrt[1in]\.o)\b::; + if ($orig ne $str) { + print "Deleted @del from link args.\n" if $verbose; + print "del_crtobj: $orig\n : $str\n@del\n" if $::opt_v; + } + return $str; +} + + +sub find_mkfile { + + my @mkfiles; + my @mk_proc = ( + 'precomp/demo/proc/proc.mk', + 'precomp/demo/proc/demo_proc.mk', + 'proc/lib/proc.mk', + 'proc16/lib/proc16.mk', + ); + my @mk_oci = ( + 'rdbms/lib/oracle.mk', + 'rdbms/demo/oracle.mk', + 'rdbms/demo/demo_rdbms.mk', + 'otrace/demo/atmoci.mk', + ); + my @mkplaces = ($::opt_p) ? (@mk_proc,@mk_oci) : (@mk_oci,@mk_proc); + if ($::opt_m) { + $::opt_m = cwd()."/$::opt_m" unless $::opt_m =~ m:^/:; + die "-m $::opt_m: not found" unless -f $::opt_m; + unshift @mkplaces, $::opt_m; + } + my ($mkfile, $place); + foreach $place (@mkplaces) { + $place = "$OH/$place" + unless $place =~ m:^[/\.]:; # abs or relative path + next unless -f $place; + push @mkfiles, $place; + print "Found $place\n"; + } + $mkfile = $mkfiles[0]; # use first one found + die qq{ + Unable to locate an oracle.mk, proc.mk or other suitable *.mk + file in your Oracle installation. (I looked in + @mkplaces) + + The oracle.mk (or demo_rdbms.mk) file is part of the Oracle + RDBMS product. The proc.mk (or demo_proc.mk) file is part of + the Oracle Pro*C product. You need to build DBD::Oracle on a + system which has one of these Oracle components installed. + (Other *.mk files such as the env_*.mk files will not work.) + + In the unlikely event that a suitable *.mk file is installed + somewhere non-standard you can specify where it is using the -m option: + perl Makefile.PL -m /path/to/your.mk + + See README.clients for more information and some alternatives. + + } unless ($os eq 'MSWin32') || ($os eq 'VMS') || ($mkfile && -f $mkfile); + + print "Using $mkfile\n"; + + warn "Note: Attempting to use makefile from otrace component. This may not work.\n" + if ($mkfile =~ /atmoci.mk/); + + return $mkfile; +} + + +sub fetch_oci_macros { + my $file = shift; + + # Read $file makefile, extract macro definitions from it + # and store them in $MK, @MK and %MK. + + # Don't include the following definitions in the generated + # makefile (note that %MK stills gets these values). + my @edit = qw( + SHELL CC CPP CFLAGS CCFLAGS OPTIMIZE ASFLAGS RCC LD LDFLAGS + AR AS CHMOD ECHO EXE OBJS PERL OBJ_EXT LIB_EXT VERSION + ); + my %edit; @edit{@edit} = ('$_ = ""') x @edit; + + $edit{ORA_NLS} = $edit{ORA_NLS33} = $edit{ORA_NLS32} = q{ + print "Deleting $_\n", + " because it is not already set in the environment\n", + " and it can cause ORA-01019 errors.\n"; + $_ = ''; + } unless $ENV{ORA_NLS} || $ENV{ORA_NLS33} || $ENV{ORA_NLS32}; + + $edit{COMPOBJS} = q{ + # Firstly a Solaris specific edit: + $_ = del_crtobj($_) if $os eq 'solaris'; + + # Delete any object files in COMPOBJS that don't actually exist + my $of; + foreach $of (split(/=|\s+/)) { + next if !$of or $of eq "COMPOBJS"; + my $obj = expand_mkvars($of,0,0); + next if -e $obj; + print "Deleting $of from COMPOBJS because $obj doesn't exist.\n"; + s:\Q$of::; + } + }; + + # deal with (some subversions) of Oracle8.0.3's incompatible use of OBJ_EXT + my $incompat_ext = ($MK{OBJ_EXT} && $MK{OBJ_EXT} !~ /^\./); + warn "OBJ_EXT correction enabled ($MK{OBJ_EXT})\n" if $incompat_ext; + + my $mkver = 0; + my $lastline = ''; + my @lines = read_inc_file($file); + for(1; $_ = shift(@lines); $lastline = $_){ + # Join split lines but retain backwack and newlines: + $_ .= shift @lines while(m/\\[\r\n]+$/); + chomp; + push @MK, '' if $_ eq '' and $lastline ne ''; # squeeze multiple blank lines + next unless $_; + + if ($incompat_ext) { + s/\.(\$\(OBJ_EXT\))/$1/g; + s/\.(\$\(LIB_EXT\))/$1/g; + } + + if (m!^([-\w/+.\$()]+)\s*:+\s*([^=]*)!) { # skip targets + my $tgt = $1; + $mk_target_deps{$tgt} = $2 || ''; + push @{ $mk_target_rules{$tgt} ||= [] }, shift @lines + while @lines && $lines[0] =~ m!^\t! && chomp $lines[0]; + #print "target $tgt => $mk_target_deps{$tgt} => @{$mk_target_rules{$tgt}}\n"; + next; + } + next if m!^\t!; # skip target build rules + next if m/^\s*\.SUFFIXES/; + + unless($MK{mkver}) { # still want to get version number + my $line = $_; $line =~ s/[\\\r\n]/ /g; + $MK{mkver} = $mkver = $1 + if $line =~ m/\$Header:.*?\.mk.+(\d+\.\d+)/; + } + + # We always store values into %MK before checking %edit + # %edit can edit this in addition to $_ if needed. + my $name; + if (m/^\s*(\w+)\s*=\s*/) { + $name = $1; + if ($MK{$name} && $MK{$name} ne $') { + print "$name macro redefined by Oracle\n from $MK{$name}\n to $'\n" + if $::opt_v; + } + $MK{$name} = $'; + $MK{$name} =~ s/^([^#]*)#.*/$1/; # remove comments + + if (exists $edit{$name}) { + my $pre = $_; + eval $edit{$name}; # execute code to edit $_ + print "Edit $name ($edit{$name}) failed: $@\n" if $@; + if ($_ ne $pre and $::opt_v) { + $_ ? print "Edited $name definition\n from: $pre\n to: $_\n" + : print "Deleted $name definition: $pre\n"; + } + } + } + + push(@MK, $_); + } + + # --- now decide what to link with --- + my $linkvia; + + if ($::opt_n) { + $linkvia = "\$($::opt_n)" if $MK{$::opt_n}; + warn "Can't use '$::opt_n': not defined by .mk files\n" + unless $linkvia; + } + + # modern Oracle .mk files define OCISTATICLIBS and OCISHAREDLIBS + if (!$linkvia && ($MK{OCISHAREDLIBS} || $MK{OCISTATICLIBS})) { + $linkvia = ''; + if ($MK{OCISTATICLIBS} && + ( ($opts{LINKTYPE}||'') eq 'static' + || "@ARGV" =~ m/\bLINKTYPE=static\b/ + || $::opt_c) + ) { + $linkvia .= '$(DEF_ON) ' if $MK{DEF_ON}; + $linkvia .= '$(SSCOREED) ' if $MK{SSCOREED}; + $linkvia .= '$(OCISTATICLIBS)'; + } + else { + $linkvia .= '$(SSDBED) ' if $MK{SSDBED}; + $linkvia .= '$(DEF_OPT) ' if $MK{DEF_OPT}; + if ($inspdver{RDBMS} =~ /^8\.0\./ and $os eq 'dec_osf' and $osvers >= 4.0) { + $linkvia .= '$(SCOREPT) $(NAETAB) $(NAEDHS) $(LLIBRDBMS_CLT) $(LLIBMM) '; + $linkvia .= '$(NETLIBS) $(CORELIBS) $(LLIBCOMMON) $(LLIBEPC) '; + $need_ldlp_env = "LD_LIBRARY_PATH"; + } + $linkvia .= '$(OCISHAREDLIBS)'; + } + } + + $linkvia = '$(LIBCLNTSH)' if !$linkvia && $MK{LIBCLNTSH}; + + # The oracle.mk file tends to define OCILDLIBS + $linkvia = '$(OCILDLIBS)' if !$linkvia && $MK{OCILDLIBS}; + + # Now we get into strange land of twisty turny macros + if (!$linkvia && $MK{PROLDLIBS}) { # Oracle 7.3.x + # XXX tweak for threaded perl? - use PROLLSsharedthread + if ($MK{PROLDLIBS} =~ /thread/i && $MK{PROLLSshared}) { + $linkvia = '$(PROLLSshared)'; + } + else { + $linkvia = '$(PROLDLIBS)'; + } + } + elsif (!$linkvia && int($mkver) == 1) { + if ($MK{LLIBOCIC}) { + $linkvia = '$(LLIBOCIC) $(TTLIBS)'; + } else { + print "Warning: Guessing what to link with.\n"; + $linkvia = '-locic $(TTLIBS)'; # XXX GUESS HACK + } + } + unless ($linkvia){ + die "ERROR parsing $file: Unable to determine what to link with.\n" + ."Please send me copies of these files (one per mail message):\n@mkfiles\n"; + } + $MK = join("\n", @MK); + return $linkvia; +} + + +sub read_inc_file { + my $file = shift; + my $fh; + unless ($fh = new FileHandle "<$file") { + # Workaround more oracle bungling (Oracle 7.3.2/Solaris x86) + my $alt; ($alt = $file) =~ s/\.dk\.mk$/\.mk/; + $fh = new FileHandle "<$alt"; + die "Unable to read $file: $!" unless $fh; + } + print "Reading $file.\n"; + my @lines; + push(@mkfiles, $file); + while(<$fh>) { + # soak up while looking for include directives + push(@lines, $_), next + unless /^\s*include\s+(.*?)\s*$/m; + my $inc_file = $1; + # deal with "include $(ORACLE_HOME)/..." + # (can't use expand_mkvars() here) + $inc_file =~ s/\$\((ORACLE_HOME|ORACLE_ROOT)\)/$ENV{$ORACLE_ENV}/og; + push(@lines, read_inc_file($inc_file)); + } + print "Read a total of ".@lines." lines from $file (including inclusions)\n" if $::opt_v; + return @lines; +} + + +my %expand_shellescape; +sub expand_shellescape { + my($orig, $level) = @_; + my $cmd = $orig; + my $debug = $::opt_d || 1; + print "Evaluating `$orig`\n" + if $debug && !$expand_shellescape{$orig}; + # ensure we have no $(...) vars left - strip out undefined ones: + $cmd =~ s/\$[({](\w+)[})]/mkvar("$1", 1, 0, $level+1)/ge; + print " expanded `$cmd`\n" if $debug and $cmd ne $orig; + my $result = `$cmd`; + chop $result; + print " returned '$result'\n" + if $debug && !$expand_shellescape{$orig}; + $expand_shellescape{$orig} = $result; + $result; +} + +sub expand_mkvars { + my ($string, $strip, $backtick, $level, $maxlevel) = @_; + $level ||= 1; + local($_) = $string; + print "$level Expanding $_\n" if $::opt_d; + # handle whizzo AIX make feature used by Oracle + s/\$[({] (\w+) \? ([^(]*?) : ([^(]*?) [})]/ + my ($vname, $vT, $vF) = ($1,$2,$3); + $MK{$vname} = (mkvar($vname, 1, $backtick, $level+1)) ? $vT : $vF + /xge; # can recurse + s/\$[({] (\w+) [})]/ + mkvar("$1", $strip, $backtick, $level+1, $maxlevel) + /xge; # can recurse + s/`(.*?[^\\])`/expand_shellescape("$1", $level+1)/esg if $backtick; # can recurse + s/\s*\\\n\s*/ /g; # merge continuations + s/\s+/ /g; # shrink whitespace + print "$level Expanded $string\n to $_\n\n" if $::opt_d and $_ ne $string; + $_; +} + + +sub mkvar { + my($var, $strip, $backtick, $level, $maxlevel) = @_; + my $default = $strip ? '' : "\$($var)"; + print "$level Variable: $var\n" if $::opt_d; + return '$(LIBHOME)' if $var eq 'LIBHOME' && !$strip; # gets noisy + return $ENV{$ORACLE_ENV} if $var eq 'ORACLE_HOME'; + my $val = $MK{$var}; + if (!defined $val and exists $ENV{$var}) { + $val = $ENV{$var}; + print "Using value of $var from environment: $val\n" + unless $var eq 'LD_LIBRARY_PATH'; + } + return $default unless defined $val; + if ($MK_expanding{$var}) { + print "Definition of \$($var) includes \$($var).\n"; + return "\$($var)"; + } + local($MK_expanding{$var}) = 1; + return $val if $maxlevel && $level >= $maxlevel; + return expand_mkvars($val, $strip, $backtick, $level+1, $maxlevel); # can recurse +} + + +sub read_file { + my $file = shift; + unless (open(ROL, "<$file")) { + warn "WARNING: Unable to open $file: $!\n"; + return ""; + } + my $text = join "", ; + $text =~ s/\n+/ /g; + close ROL; + return $text; +} + + +sub find_bin{ + my $bin = shift; + my $path_sep = $Config{path_sep}; + foreach (split(/$path_sep/, $ENV{PATH})){ + return "$_/$bin" if -x "$_/$bin"; + } + return "<$bin not found>"; +} + + +sub find_headers { + my (%h_dir, @h_dir); + find( sub { + return unless /^o(ci...|ratypes)\.h$/i; + my $dir = $File::Find::dir; + $dir =~ s:^\Q$OH/::; + $h_dir{$dir} = $_; + print "Found $dir/$_\n" if $::opt_v; + }, "$OH/rdbms" ); + @h_dir = keys %h_dir; + print "Found header files in @h_dir.\n" if @h_dir; + return @h_dir; +} + + +sub symbol_search { + $::opt_s ||= $::opt_S; + print "Searching for symbol '$::opt_s' in $OH ...\n"; + my $dlext = $Config{dlext}; + system(qq{ cd $OH; for i in lib/*.[ao] lib/*.$dlext */lib/*.[ao]; + do echo " searching oracle \$i ..."; PATH=/usr/ccs/bin:\$PATH nm \$i | grep $::opt_s; done + }); + if ($::opt_S) { + my @libpth = split ' ', $Config{libpth}; + print "Searching for symbol '$::opt_s' in @libpth ...\n"; + @libpth = map { ("$_/lib*.$dlext", "$_/lib*.a") } @libpth; + system(qq{ cd $OH; for i in @libpth; + do echo " searching \$i ..."; PATH=/usr/ccs/bin:\$PATH nm \$i | grep $::opt_s; done + }); + } + print "Search done.\n"; + print "(Please only include the 'interesting' parts when mailing.)\n"; + exit; +} + + +# ===================================================================== + + +{ + package MY; # SUPER needs package context, $self is not sufficient + + + sub post_constants { + my $self = shift; + # Oracle Definitions, based on $(ORACLE_HOME)/proc/lib/proc.mk + # Please let me know if this does, or does not, work for you. + ' +################################################################### +# +ORACLE_HOME = '.$OH.' + +# The following text has been extracted from '.join("\n#\t", '', @mkfiles).' + +'.$MK.' + +# End of extract from '."@mkfiles".' +# +################################################################### +'; + } + + + sub const_cccmd { + my ($self) = shift; + print "Using DBD::Oracle $self->{VERSION}.\n"; + + local($_) = $self->SUPER::const_cccmd(@_); + # If perl Makefile.PL *-g* then switch on debugging + if ($::opt_g) { + s/\s-O\d?\b//; # delete optimise option + s/\s-/ -g -/; # add -g option + } + # are we using the non-bundled hpux compiler? + if ($os eq "hpux" and $Config::Config{ccflags} =~ /-Aa\b/) { + print "Changing -Aa to -Ae for HP-UX in ccmd.\n" + if s/-Aa\b/-Ae/g; # allow "long long" in oratypes.h + } + $_; + } + + sub cflags { + my ($self) = shift; + local($_) = $self->SUPER::cflags(@_); + # If perl Makefile.PL *-g* then switch on debugging + if ($::opt_g) { + s/\s-O\d?\b//; # delete optimise option + s/\s-/ -g -/; # add -g option + } + # are we using the non-bundled hpux compiler? + if ($os eq "hpux" and $Config::Config{ccflags} =~ /-Aa\b/) { + print "Changing -Aa to -Ae for HP-UX in cflags.\n" + if s/-Aa\b/-Ae/g; # allow "long long" in oratypes.h + } + $_; + } + + sub dynamic_lib { + return shift->SUPER::dynamic_lib(@_) unless $os eq 'VMS'; + + # special code for VMS only + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + return '' unless $self->has_link_code(); + + my $OtherText; + my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; + my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my @m; + push @m, "OTHERLDFLAGS = $otherldflags\n"; + push @m, "INST_DYNAMIC_DEP = $inst_dynamic_dep\n"; + if ($] < 5.00450) { + push @m, ' +$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt rtls.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) + $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) + $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.',$Config::Config{'dlext'},' + Lnproc $(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,rtls.opt/Option,$(PERL_INC)perlshr_attr.opt/Option i +'; + } else { + push @m, ' +$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) + $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) + $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.',$Config::Config{'dlext'},' + Lnproc $(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option i +'; + + } + push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); + join('',@m); + } + +} + + +sub check_security { + # check for the SUID/SGID bits on ORACLE_HOME/bin/oratclsh + # if set, this allows a user to fork a root shell! + # Get the octal portion of perms that indicates + # SUID and SGID, and warn if either is set + + my @files = map { ($_,$_.'0') } qw( + oratclsh lsnrctl oemevent onrsd osslogin tnslsnr + tnsping trcasst trcroute cmctl cmadmin cmgw names namesctl otrccref + otrcfmt otrcrep otrccol + ); + + my @bad; + foreach (@files) { + my $file = "$ENV{ORACLE_HOME}/bin/$_"; + my ($mode) = (stat($file))[2]; + next unless defined $mode; + push @bad, $file if ($mode & 04000 and $mode & 00111) + or ($mode & 02000 and $mode & 00111); + } + return unless @bad; + + print "\n"; + warn "WARNING - YOUR ORACLE INSTALLATION HAS A SECURITY PROBLEM.\a\n"; + warn "Read the README.sec file for more information and patch details.\a\n"; + warn "This is just a warning. It does not affect DBD::Oracle in any way.\n"; + sleep 5; +} + +__END__ diff --git a/Oracle.ex/Readme b/Oracle.ex/Readme new file mode 100644 index 00000000..82af96c6 --- /dev/null +++ b/Oracle.ex/Readme @@ -0,0 +1,36 @@ +This directory contains a few sample DBI/DBD::Oracle scripts. Some are +genuinely useful while others are just demonstrations of different things. +They are adapted from the Oraperl example scripts in ../Oraperl.ex/ to +show how to do the same things in Perl 5 and DBI. + +$dbh->{RaiseError} is set to 1 in all scripts for automatic error checking. + +bind.pl Demonstrates how execute() and fetchrow_array() may be + combined to make a simple table lookup program with placeholders. + +commit.pl Demonstrates the use of commit() and rollback(). + +ex.pl Reads data from a table and prints it using a format. + Also illustrates how to recognise NULL fields and bind_columns + with known column names. + +japh Just another Perl hacker, written for DBI. + This is no one-liner, but it demonstrates a few things. + +mktable.pl Creates a table, puts some data into it, drops it. + Demonstrates do(), placeholders, inserting and reading NULL values, + and bind_columns() with known columns. + +oradump.pl Dumps an Oracle table as a set of INSERT statements. + Demonstrates the use of $sth->{TYPE}, $dbh->quote(), + and bind_columns() with unknown column names. + +proc.pl Demonstrates how to get values into and out of stored procedures + and how to receive result sets. + +sql Demonstrates the use of $sth->{NUM_OF_FIELDS}, $sth->{NAME}, + $sth->{PRECISION}, and bind_columns() with unknown column names. + +tabinfo.pl Displays the structure of the specified table. + Demonstrates the use of $sth->{NAME}, $sth->{PRECISION}, + $sth->{TYPE}, and type_info_all(). diff --git a/Oracle.ex/bind.pl b/Oracle.ex/bind.pl new file mode 100755 index 00000000..303d96be --- /dev/null +++ b/Oracle.ex/bind.pl @@ -0,0 +1,45 @@ +#!/usr/bin/perl -w +# +# bind.pl +# +# This shows how a placeholder may be used to implement a simple lookup. + +use DBI; + +use strict; + +# Set trace level if '-# trace_level' option is given +DBI->trace( shift ) if 1 < @ARGV && $ARGV[0] =~ /^-#/ && shift; + +die "syntax: $0 [-# trace] base user pass" if 3 > @ARGV; +my ( $inst, $user, $pass ) = @ARGV; + +# Connect to database +my $dbh = DBI->connect( "dbi:Oracle:$inst", $user, $pass, + { AutoCommit => 0, RaiseError => 1, PrintError => 0 } ) + or die $DBI::errstr; + +# Prepare the SELECT statement using a placeholder +my $sth = $dbh->prepare( 'SELECT created FROM all_users WHERE username = ?' ); + +my ( $created ); +$| = 1; +print "Enter an empty line to finish\n"; +print "Userid? "; +while ( ) { + chomp; + last if ! $_; + $sth->execute( uc( $_ ) ); + + # Note that the variable is in parenthesis to give an array context + if ( ( $created ) = $sth->fetchrow_array ) { + print "$created\n"; + } + else { + print "unknown\n"; + } + print "Userid? "; +} + +$sth->finish; +$dbh->disconnect; diff --git a/Oracle.ex/commit.pl b/Oracle.ex/commit.pl new file mode 100755 index 00000000..e6e0da3c --- /dev/null +++ b/Oracle.ex/commit.pl @@ -0,0 +1,72 @@ +#!/usr/bin/perl -w +# +# commit.pl +# +# Simple example of using commit and rollback. + +use DBI; + +use strict; + +# Set trace level if '-# trace_level' option is given +DBI->trace( shift ) if 1 < @ARGV && $ARGV[0] =~ /^-#/ && shift; + +die "syntax: $0 [-# trace] base user pass" if 3 > @ARGV; +my ( $inst, $user, $pass ) = @ARGV; + +# Connect to database +my $dbh = DBI->connect( "dbi:Oracle:$inst", $user, $pass, + { AutoCommit => 0, RaiseError => 1, PrintError => 0 } ) + or die $DBI::errstr; + +# Create the table to hold prime numbers +print "Creating table\n"; +eval { $dbh->do( 'CREATE TABLE primes ( prime NUMBER )' ); }; +warn $@ if $@; + +print "Loading table"; +my $sth = $dbh->prepare( 'INSERT INTO primes VALUES ( ? )' ); +while ( ) { + chomp; + print " $_"; + $sth->execute( $_ ); + print " commit (", $dbh->commit, ")" if 11 == $_; +} +print "\n"; + +my $prime; +print "Reading table for the first time\n"; +$sth = $dbh->prepare( 'SELECT prime FROM primes ORDER BY prime' ); +$sth->execute; +$sth->bind_columns( {}, \$prime ); +while ( $sth->fetch ) { + print " $prime"; +} +$sth->finish; +print "\n"; + +print "rollback (", $dbh->rollback, ")\n"; + +print "Reading table for the second time.\n"; +$sth->execute; +$sth->bind_columns( {}, \$prime ); +while ( $sth->fetch ) { + print " $prime"; +} +$sth->finish; +print "\n"; + +$dbh->do( 'DROP TABLE primes' ); +print "Table Dropped\n"; +$dbh->disconnect; +__END__ +2 +3 +5 +7 +11 +13 +17 +19 +23 +29 diff --git a/Oracle.ex/ex.pl b/Oracle.ex/ex.pl new file mode 100755 index 00000000..95ffa322 --- /dev/null +++ b/Oracle.ex/ex.pl @@ -0,0 +1,47 @@ +#!/usr/bin/perl -w +# Short example using bind_columns() to list a table's values + +use DBI; + +use strict; + +# Set trace level if '-# trace_level' option is given +DBI->trace( shift ) if 1 < @ARGV && $ARGV[0] =~ /^-#/ && shift; + +die "syntax: $0 [-# trace] base user pass [max]" if 3 > @ARGV; +my ( $inst, $user, $pass, $max ) = @ARGV; +$max = 20 if ! $max || 0 > $max; + +my ( $name, $id, $created ); +format STDOUT_TOP = + Name ID Created + ============================== ========= ========= +. + +format STDOUT = + @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>> @<<<<<<<< + $name, $id, $created +. + +# Connect to database +my $dbh = DBI->connect( "dbi:Oracle:$inst", $user, $pass, + { AutoCommit => 0, RaiseError => 1, PrintError => 0 } ) + or die $DBI::errstr; + +my $sth = $dbh->prepare( + "SELECT username, user_id, created FROM all_users ORDER BY username" ); +$sth->execute; + +my $nfields = $sth->{NUM_OF_FIELDS}; +print "Query will return $nfields fields\n\n"; + +$sth->bind_columns( {}, \( $name, $id, $created ) ); +while ( $sth->fetch ) { + last if ! --$max; + # mark any NULL fields found + foreach ( $name, $id, $created ) { $_ = 'NULL' if ! defined; } + write; +} + +$sth->finish; +$dbh->disconnect; diff --git a/Oracle.ex/japh b/Oracle.ex/japh new file mode 100755 index 00000000..1232e60f --- /dev/null +++ b/Oracle.ex/japh @@ -0,0 +1,52 @@ +#!/usr/bin/perl -w +# This is an example of how we could code a JAPH using DBI and DBD::Oracle. +# +# Original oraperl script by Kevin Stock +# Date: 1st December 1992 + +use DBI; + +use strict; + +# Set trace level if '-# trace_level' option is given +DBI->trace( shift ) if 1 < @ARGV && $ARGV[0] =~ /^-#/ && shift; + +die "syntax: $0 [-# trace] base user pass" if 3 > @ARGV; +my ( $inst, $user, $pass ) = @ARGV; + +# Connect to database +my $dbh = DBI->connect( "dbi:Oracle:$inst", $user, $pass, + { AutoCommit => 0, RaiseError => 1, PrintError => 0 } ) + or die $DBI::errstr; + +# Create the sample table +$dbh->do( "CREATE TABLE japh ( word CHAR(7), posn NUMBER(1) )" ); + +# Loop to insert data into the table +my $sth = $dbh->prepare( "INSERT INTO japh VALUES ( ?, ? )" ); +while ( ) { + chomp; + $sth->execute( split ':', $_ ); +} + +# Now retrieve the data, printing it word by word +$sth = $dbh->prepare( "SELECT word FROM japh ORDER BY posn" ); +$sth->execute; +my $word; +$sth->bind_columns( {}, \$word ); +$sth->{ChopBlanks} = 1; # Wouldn't you rather use VARCHAR2 instead of CHAR? +while ( $sth->fetch ) { + print " $word"; +} +$sth->finish; +print "\n"; + +# delete the table +$dbh->do( 'DROP TABLE japh' ); +$dbh->disconnect; + +__END__ +DBI:3 +another:2 +hacker:4 +just:1 diff --git a/Oracle.ex/mktable.pl b/Oracle.ex/mktable.pl new file mode 100755 index 00000000..28d01007 --- /dev/null +++ b/Oracle.ex/mktable.pl @@ -0,0 +1,102 @@ +#!/usr/bin/perl -w +# Sample DBI program to create a new table and load data into it. +# +# Author: Kevin Stock (original oraperl script) +# Date: 5th August 1991 +# Date: 25th September 1992 + +use DBI; + +use strict; + +# Set trace level if '-# trace_level' option is given +DBI->trace( shift ) if 1 < @ARGV && $ARGV[0] =~ /^-#/ && shift; + +die "syntax: $0 [-# trace] base user pass" if 3 > @ARGV; +my ( $inst, $user, $pass ) = @ARGV; + +# Connect to database +my $dbh = DBI->connect( "dbi:Oracle:$inst", $user, $pass, + { AutoCommit => 0, RaiseError => 1, PrintError => 0 } ) + or die $DBI::errstr; + +# set these as strings to make the code more readable +my $CREATE = "CREATE TABLE tryit ( name VARCHAR2(10), ext NUMBER(3) )"; +my $INSERT = "INSERT INTO tryit VALUES ( ?, ? )"; +my $LIST = "SELECT * FROM tryit ORDER BY name"; +my $DELETE = "DELETE FROM tryit WHERE name = ?"; +my $DELETE_NULL = "DELETE FROM tryit WHERE name IS NULL"; +my $DROP = "DROP TABLE tryit"; + +# Can use dynamic variables in write as long as they are visible at format time +my ( $msg, $name, $ext ); + +# Prepare formats for output +format STDOUT_TOP = + + @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $msg + + Name Ext + ==== === +. + +format STDOUT = + @<<<<<<<<< @>> + $name, $ext +. + +# function to list the table +sub list { + $msg = join "\n", @_; + $- = 0; + my $sth = $dbh->prepare( $LIST ); + $sth->execute; + $sth->bind_columns( {}, \( $name, $ext ) ); + while ( $sth->fetch ) { + $name = '' unless defined $name; + $ext = '' unless defined $ext; + write; + } + $sth->finish; +} + +# create the database +$dbh->do( $CREATE ); + +# put some data into it +my $sth = $dbh->prepare( $INSERT ); +while ( ) { + chomp; + $sth->execute( map { 'NULL' eq $_ ? undef : $_ } split /:/, $_, 2 ); +} +$dbh->commit; +list( 'Initial Data' ); + +# remove a few rows +$sth = $dbh->prepare( $DELETE ); +foreach $name ( 'catherine', 'angela', 'arnold', 'julia' ) { + $sth->execute( $name ); +} +$dbh->commit; +list( 'After removing selected people' ); + +# Remove some rows with NULLs +$dbh->do( $DELETE_NULL ); +list( 'After removing NULL names' ); + +# remove the table and disconnect +$dbh->do( $DROP ); +$dbh->disconnect; + +# This is the data which will go into the table +__END__ +julia:292 +angela:208 +NULL:999 +larry:424 +catherine:201 +nonumber:NULL +randal:306 +arnold:305 +NULL:NULL diff --git a/Oracle.ex/oradump.pl b/Oracle.ex/oradump.pl new file mode 100755 index 00000000..88a8bd01 --- /dev/null +++ b/Oracle.ex/oradump.pl @@ -0,0 +1,42 @@ +#!/usr/bin/perl -w +# +# Dump the contents of an Oracle table into a set of insert statements. +# Quoting is controlled by the datatypes of each column. (new with DBI) +# +# Usage: oradump +# +# Author: Kevin Stock (original oraperl script) +# Date: 28th February 1992 +# + +use DBI; + +use strict; + +# Set trace level if '-# trace_level' option is given +DBI->trace( shift ) if 1 < @ARGV && $ARGV[0] =~ /^-#/ && shift; + +die "syntax: $0 base user pass table\n" if 4 > @ARGV; +my ( $base, $user, $pass, $table ) = @ARGV; + +# Connect to database +my $dbh = DBI->connect( "dbi:Oracle:$base", $user, $pass, + { AutoCommit => 0, RaiseError => 1, PrintError => 0 } ) + or die $DBI::errstr; + +my $sth = $dbh->prepare( "SELECT * FROM $table"); +$sth->execute; +my @name = @{$sth->{NAME}}; +my @type = @{$sth->{TYPE}}; +my $lead = "INSERT INTO $table ( " . join( ', ', @name ) . " ) VALUES ( "; +my ( @data, $i ); +$sth->bind_columns( {}, \( @data[0 .. $#name] ) ); +while ( $sth->fetch ) { + $i = 0; + # print $lead . join( ", ", map { $dbh->quote( $_, $type[$i++] ) } @data ) . + print $lead . join( ", ", map { $dbh->quote( $_ ) } @data ) . + " );\n"; +} + +$sth->finish; +$dbh->disconnect; diff --git a/Oracle.ex/proc.pl b/Oracle.ex/proc.pl new file mode 100755 index 00000000..a8a65a14 --- /dev/null +++ b/Oracle.ex/proc.pl @@ -0,0 +1,148 @@ +#!/usr/bin/perl -w +# Short examples of procedure calls from Oracle.pm +# These PL/SQL examples come from: Eric Bartley . + +use DBI; + +use strict; + +# Set trace level if '-# trace_level' option is given +DBI->trace( shift ) if 1 < @ARGV && $ARGV[0] =~ /^-#/ && shift; + +die "syntax: $0 [-# trace] base user pass" if 3 > @ARGV; +my ( $inst, $user, $pass ) = @ARGV; + +# So we don't have to check every DBI call we set RaiseError. +# See the DBI docs if you're not familiar with RaiseError. +# AutoCommit is currently encouraged and may be required later. +my $dbh = DBI->connect( "dbi:Oracle:$inst", $user, $pass, + { AutoCommit => 0, RaiseError => 1, PrintError => 0 } ) + or die "Unable to connect: $DBI::errstr"; + +# Create the package for the examples +$dbh->do( <do( <prepare( q{ +BEGIN + plsql_example.proc_np; +END; +} ); +$sth->execute; + + +print "\nExample 2\n"; +# Now we call a procedure that has 1 IN parameter. Here we use bind_param +# to bind out parameter to the prepared statement just like you might +# do for an INSERT, UPDATE, DELETE, or SELECT statement. +# +# I could have used positional placeholders (e.g. :1, :2, etc.) or +# ODBC style placeholders (e.g. ?), but I prefer Oracle's named +# placeholders (but few DBI drivers support them so they're not portable). +# +# proc_in() will RAISE_APPLICATION_ERROR which will cause the execute to 'fail'. +# Because we set RaiseError, the DBI will die() so we catch that with eval {}. + +my $err_code = -20001; + +$sth = $dbh->prepare( q{ +BEGIN + plsql_example.proc_in( :err_code ); +END; +} ); +$sth->bind_param( ":err_code", $err_code ); +eval { $sth->execute; }; +print 'After proc_in: $@ = ', "'$@', errstr = '$DBI::errstr'\n"; + + +print "\nExample 3\n"; +# Building on the last example, I've added 1 IN OUT parameter. We still +# use a placeholders in the call to prepare, the difference is that +# we now call bind_param_inout to bind the value to the place holder. +# +# Note that the third parameter to bind_param_inout is the maximum size +# of the variable. You normally make this slightly larger than necessary. +# But note that the perl variable will have that much memory assigned to +# it even if the actual value returned is shorter. + +my $test_num = 5; +my $is_odd; + +$sth = $dbh->prepare( q{ +BEGIN + plsql_example.proc_in_inout( :test_num, :is_odd ); +END; +} ); + +# The value of $test_num is _copied_ here +$sth->bind_param( ":test_num", $test_num ); +$sth->bind_param_inout( ":is_odd", \$is_odd, 1 ); + +# The execute will automagically update the value of $is_odd +$sth->execute; +print "$test_num is ", $is_odd ? "odd - ok" : "even - error!", "\n"; + + +print "\nExample 4\n"; +# What about the return value of a PL/SQL function? Well treat it the same +# as you would a call to a function from SQL*Plus. We add a placeholder +# for the return value and bind it with a call to bind_param_inout so +# we can access it's value after execute. + +my $whoami = ""; + +$sth = $dbh->prepare( q{ +BEGIN + :whoami := plsql_example.func_np; +END; +} ); +$sth->bind_param_inout( ":whoami", \$whoami, 30 ); +$sth->execute; +print "Your database user name is $whoami\n"; + +# Get rid of the example package +$dbh->do( 'DROP PACKAGE plsql_example' ); +$dbh->disconnect; diff --git a/Oracle.ex/sql b/Oracle.ex/sql new file mode 100755 index 00000000..acdaa2d3 --- /dev/null +++ b/Oracle.ex/sql @@ -0,0 +1,235 @@ +#!/usr/bin/perl -w +'di'; +'ig00'; +# See usage() for syntax + +use Getopt::Long; + +use DBI; + +use strict; + +# Default values for options +my ( $trace, $inst, $cache, $delim, $format, $headers, $page_len, $null_str ) = + ( 0, $ENV{TWO_TASK} || $ENV{ORACLE_SID} || '', '', "\t", 0, 0, 60, '' ); + +# Syntax description +sub usage { + my ( $sOpt, $sVal, @sMsg ) = @_; + + my $sHelpText = < \&usage, + 'trace|t=i' => \$trace, + 'base|b=s' => \$inst, + 'cache|c=i' => \$cache, + 'delim|d=s' => \$delim, + 'Format!' => \$format, 'F!' => \$format, + 'Headers!' => \$headers, 'H!' => \$headers, + 'len|len=i' => \$page_len, + 'null|n=s' => \$null_str, + ) or usage( 'die', 1 ); +usage( 'die', 1, "Only one of -F and -H may be specified\n" ) + if $format && $headers; + +usage( 'die', 1, 'Username and password are required' ) if 2 > @ARGV; +my ( $user, $pass, @stmt ) = @ARGV; +if ( ! @stmt ) { + print "Enter the statement to execute (^D to end):\n"; + @stmt = ; +} +usage( 'die', 1, "A statement is required" ) if ! @stmt; + +$\ = "\n"; # each record terminated with newline +$, = $delim; # set column delimiter +$= = $page_len; # set page length + +# Set trace level +DBI->trace( $trace ); + +# Connect to database +my $dbh = DBI->connect( "dbi:Oracle:$inst", $user, $pass, + { AutoCommit => 0, RaiseError => 1, PrintError => 0 } ) + or die $DBI::errstr; +$dbh->{RowCacheSize} = $cache if $cache; # set fetch cache + +# Start statement +my $sth = $dbh->prepare( join "\n", @stmt ); +$sth->execute; +my $nfields = $sth->{NUM_OF_FIELDS}; + +# print out any information which comes back +if ( $nfields ) { + # the statement has output columns + my ( @col, $col ); + my @name = @{$sth->{NAME}}; + if ( $format ) { + # build format statements for the data + my @size = @{$sth->{PRECISION}}; + + # First, the header - a list of field names, formatted + # in columns of the appropriate width + my $fmt = join '|', map { "%-${_}.${_}s" } @size; + $fmt = sprintf $fmt, @name; + $format .= "format STDOUT_TOP =\n" . $fmt . "\n"; + + # Then underlines for the field names + $fmt =~ tr/|/-/c; + $fmt =~ tr/|/+/; + $format .= $fmt . "\n.\n"; + + # Then for the data format, a @<<... field per column + $fmt =~ tr/-+/<|/; + $fmt =~ s/(^|\|)bind_columns( {}, \( @col[0 .. $#name] ) ); + while ( $sth->fetch ) { + foreach $col ( @col ) { $col = $null_str if ! defined $col; } + $format ? write : print @col; + } +} + +# finish off neatly +$sth->finish; +$dbh->disconnect; + +__END__ # no need for perl even to scan the rest + +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +';<<'.ex'; ############## From here on it's a standard manual page ############ +.TH SQL L "5th July 1999" +.ad +.nh +.SH NAME +sql \- execute an Oracle SQL statement from the command line +.SH SYNOPSIS +\fBsql\fP +[\fB\-b\fP\fIbase\fP] +[\fB\-c\fP\fIcache\fP] +[\fB\-d\fP\fIdelim\fP] +[\fB\-F\fP|\fB\-H\fP] +[\fB\-l\fP\fIpage_len\fP] +[\fB\-n\fP\fIstring\fP] +\fIname\fP \fIpassword\fP +\fIstatement\fP +.SH DESCRIPTION +.I Sql +connects to an Oracle database +using the \fIname\fP and \fIpassword\fP supplied +and executes the given SQL \fIstatement\fP +displaying the result +on its standard output. + +The \fB\-b\fP\fIbase\fP flag may be supplied to specify the database to be used. +If it is not given, the database specified by the environment variable +\fBTWO_TASK\fP or \fBORACLE_SID\fP is used. + +The \fB\-c\fP\fIcache\fP flag may be supplied to set the size of fetch cache +to be used. If it is not given, the default is used. + +If the \fB\-n\fP\fIstring\fP flag is supplied, +\fBNULL\fP fields (in the \fIOracle\fP sense) +will replaced in the output by \fIstring\fP. +Normally, they are left blank. + +The \fB\-F\fP and \fB\-H\fP flags may be used to modify the form of the output. +Without either flag, no field headers are printed +and fields are not padded. +With the \fB\-H\fP flag, +field headers are added to the top of the output, +but the format is otherwise unchanged. +With the \fB\-F\fP flag, +the output is formatted in a tabular form similar to that used by \fIsqlplus\fP, +except that all fields are left\-justified, regardless of their data type. +Column headers are printed at the top of each page; +a page is assumed to be 60 lines long, +but this may be overridden with the \fB\-l\fP\fIpage_len\fP flag. + +Without the \fB\-F\fP flag, fields are separated with tabs; +this may be changed to any desired string (\fIdelim\fP) +using the \fB\-d\fP flag. +.SH ENVIRONMENT +The environment variable \fBTWO_TASK\fP or \fBORACLE_SID\fP +determines the Oracle database to be used +if the \fB\-b\fP\fIbase\fP flag is not supplied. +.SH DIAGNOSTICS +.in +5 +.ti -5 +\fBonly one of \-F and \-H may be specified\fP +.br +the \fB\-F\fP and \fB\-H\fP options are mutually exclusive, +but both were specified + +.in -5 +The only other diagnostics generated by \fIsql\fP are usage messages, +which should be self\-explanatory. +However, you may also encounter +error messages from DBI (unlikely) or from Oracle (more common). +See the \fIOracle Error Messages and Codes Manual\fP for details. +.SH NOTES +This program is only intended for use from the command line. +If you use it within a shell script +then you should consider rewriting your script in DBI +to use Perl's text manipulation and formatting commands. +.SH "SEE ALSO" +\fISQL Language Reference Manual\fP +.br +perl(1), +oraperl(1) +.SH AUTHOR +Kevin Stock, +.if t .ft C + +.if t .ft P +.ex diff --git a/Oracle.ex/tabinfo.pl b/Oracle.ex/tabinfo.pl new file mode 100755 index 00000000..307bd6b1 --- /dev/null +++ b/Oracle.ex/tabinfo.pl @@ -0,0 +1,68 @@ +#!/usr/bin/perl -w +# +# tabinfo +# +# Usage: tabinfo base user password table +# +# Displays the structure of the specified table. +# Note that the field names are restricted to the length of the field. +# This is mainly to show the use of &ora_lengths, &ora_titles and &ora_types. +# +use DBI; + +use strict; + +# Set trace level if '-# trace_level' option is given +DBI->trace( shift ) if 1 < @ARGV && $ARGV[0] =~ /^-#/ && shift; + +# read the compulsory arguments +die "syntax: $0 base user password table ...\n" if 4 > @ARGV; +my ( $base, $user, $pass, @table ) = @ARGV; + +my ( $table, @name, @length, @type, %type_name, $i ); +format STDOUT_TOP = +Structure of @<<<<<<<<<<<<<<<<<<<<<<< +$table + +Field name | Length | Type | Type Name +----------------------------------------------+--------+------+----------------- +. + +format STDOUT = +@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | @>>>>> | @>>> | @<<<<<<<<<<<<<<< +$name[$i], $length[$i], $type[$i], $type_name{$type[$i]} +. + +# Connect to database +my $dbh = DBI->connect( "dbi:Oracle:$base", $user, $pass, + { AutoCommit => 0, RaiseError => 1, PrintError => 0 } ) + or die $DBI::errstr; + +# Associate type names to types +{ + my $type_info_all = $dbh->type_info_all; + my $iname = $type_info_all->[0]{TYPE_NAME}; + my $itype = $type_info_all->[0]{DATA_TYPE}; + my $rtype; + shift @$type_info_all; + foreach $rtype ( @$type_info_all ) { + $type_name{$$rtype[$itype]} = $$rtype[$iname] + if ! exists $type_name{$$rtype[$itype]}; + } +} + +my $sth; +foreach $table ( @table ) { + $sth = $dbh->prepare( "SELECT * FROM $table WHERE 1 = 2"); + @name = @{$sth->{NAME}}; + @length = @{$sth->{PRECISION}}; + @type = @{$sth->{TYPE}}; + + foreach $i ( 0 .. $#name ) { + write; + } + $- = 0; + $sth->finish; +} + +$dbh->disconnect; diff --git a/Oracle.h b/Oracle.h new file mode 100644 index 00000000..e47b6a80 --- /dev/null +++ b/Oracle.h @@ -0,0 +1,59 @@ +/* + $Id: Oracle.h,v 1.17 1999/07/12 03:20:42 timbo Exp $ + + Copyright (c) 1994,1995 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file, + with the exception that it cannot be placed on a CD-ROM or similar media + for commercial distribution without the prior approval of the author. + +*/ + + +#define NEED_DBIXS_VERSION 93 + +#define PERL_POLLUTE + +#include /* installed by the DBI module */ + +#include "dbdimp.h" + +#include /* installed by the DBI module */ + +#ifdef yxyxyxyx +/* These prototypes are for dbdimp.c funcs used in the XS file */ +/* These names are #defined to driver specific names in dbdimp.h */ + +void dbd_init _((dbistate_t *dbistate)); + +int dbd_db_login _((SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *user, char *pwd)); +int dbd_db_do _((SV *sv, char *statement)); +int dbd_db_commit _((SV *dbh, imp_dbh_t *imp_dbh)); +int dbd_db_rollback _((SV *dbh, imp_dbh_t *imp_dbh)); +int dbd_db_disconnect _((SV *dbh, imp_dbh_t *imp_dbh)); +void dbd_db_destroy _((SV *dbh, imp_dbh_t *imp_dbh)); +int dbd_db_STORE_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv)); +SV *dbd_db_FETCH_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv)); + +int dbd_st_prepare _((SV *sth, imp_sth_t *imp_sth, + char *statement, SV *attribs)); +int dbd_st_rows _((SV *sth, imp_sth_t *imp_sth)); +int dbd_st_execute _((SV *sth, imp_sth_t *imp_sth)); +AV *dbd_st_fetch _((SV *sth, imp_sth_t *imp_sth)); +int dbd_st_finish _((SV *sth, imp_sth_t *imp_sth)); +void dbd_st_destroy _((SV *sth, imp_sth_t *imp_sth)); +int dbd_st_blob_read _((SV *sth, imp_sth_t *imp_sth, + int field, long offset, long len, SV *destrv, long destoffset)); +int dbd_st_STORE_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv)); +SV *dbd_st_FETCH_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv)); +int dbd_bind_ph _((SV *sth, imp_sth_t *imp_sth, + SV *param, SV *value, IV sql_type, SV *attribs, int is_inout, IV maxlen)); +#endif + +int dbd_db_login6 _((SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *user, char *pwd, SV *attr)); +int dbd_describe _((SV *sth, imp_sth_t *imp_sth)); +ub4 ora_blob_read_piece _((SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV *dest_sv, + long offset, long len, long destoffset)); + +/* end of Oracle.h */ diff --git a/Oracle.pm b/Oracle.pm new file mode 100644 index 00000000..f5102395 --- /dev/null +++ b/Oracle.pm @@ -0,0 +1,1178 @@ + +# $Id: Oracle.pm,v 1.80 2000/07/14 21:52:08 timbo Exp $ +# +# Copyright (c) 1994,1995,1996,1997,1998,1999 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file, +# with the exception that it cannot be placed on a CD-ROM or similar media +# for commercial distribution without the prior approval of the author. + +require 5.003; + +$DBD::Oracle::VERSION = '1.06'; + +my $ORACLE_ENV = ($^O eq 'VMS') ? 'ORA_ROOT' : 'ORACLE_HOME'; + +{ + package DBD::Oracle; + + use DBI (); + use DynaLoader (); + use Exporter (); + @ISA = qw(DynaLoader Exporter); + %EXPORT_TAGS = ( + ora_types => [ qw( + ORA_VARCHAR2 ORA_NUMBER ORA_LONG ORA_ROWID ORA_DATE + ORA_RAW ORA_LONGRAW ORA_CHAR ORA_MLSLABEL ORA_NTY + ORA_CLOB ORA_BLOB ORA_RSET + ) ], + ); + @EXPORT_OK = ('ORA_OCI'); + Exporter::export_ok_tags('ora_types'); + + + my $Revision = substr(q$Revision: 1.80 $, 10); + + require_version DBI 1.02; + + bootstrap DBD::Oracle $VERSION; + + $err = 0; # holds error code for DBI::err (XXX SHARED!) + $errstr = ""; # holds error string for DBI::errstr (XXX SHARED!) + $drh = undef; # holds driver handle once initialised + + sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + my $oci = DBD::Oracle::ORA_OCI(); + + $class .= "::dr"; + + # not a 'my' since we use it above to prevent multiple drivers + + $drh = DBI::_new_drh($class, { + 'Name' => 'Oracle', + 'Version' => $VERSION, + 'Err' => \$DBD::Oracle::err, + 'Errstr' => \$DBD::Oracle::errstr, + 'Attribution' => "DBD::Oracle $VERSION using OCI$oci by Tim Bunce", + }); + + $drh; + } + + + END { + # Used to silence 'Bad free() ...' warnings caused by bugs in Oracle's code + # being detected by Perl's malloc. + $ENV{PERL_BADFREE} = 0; + undef $Win32::TieRegistry::Registry if $Win32::TieRegistry::Registry; + } + + #sub AUTOLOAD { + # (my $constname = $AUTOLOAD) =~ s/.*:://; + # my $val = constant($constname); + # *$AUTOLOAD = sub { $val }; + # goto &$AUTOLOAD; + #} + +} + + +{ package DBD::Oracle::dr; # ====== DRIVER ====== + use strict; + + my %dbnames = (); # holds list of known databases (oratab + tnsnames) + + sub load_dbnames { + my ($drh) = @_; + my $debug = $drh->debug; + my $oracle_home = $ENV{$ORACLE_ENV} || ''; + local *FH; + my $d; + + if (($^O eq 'MSWin32') or ($^O =~ /cygwin/i)) { + # XXX experimental, will probably change + $drh->trace_msg("Trying to fetch ORACLE_HOME and ORACLE_SID from the registry.\n") + if $debug; + my($hkey, $sid, $home); + eval q{ + require Win32::TieRegistry; + $Win32::TieRegistry::Registry->Delimeter("/"); + $hkey= $Win32::TieRegistry::Registry->{"LMachine/Software/Oracle/"}; + }; + eval q{ + require Tie::Registry; + $Tie::Registry::Registry->Delimeter("/"); + $hkey= $Tie::Registry::Registry->{"LMachine/Software/Oracle/"}; + } unless $hkey; + if ($hkey) { + $sid = $hkey->{ORACLE_SID}; + $home= $hkey->{ORACLE_HOME}; + } else { + eval q{ + my $reg_key; + require Win32::Registry; + $main::HKEY_LOCAL_MACHINE->Open('SOFTWARE\ORACLE', $reg_key); + $reg_key->GetValues( $hkey ); + $sid = $hkey->{ORACLE_SID}[2]; + $home= $hkey->{ORACLE_HOME}[2]; + }; + }; + $home= $ENV{$ORACLE_ENV} unless $home; + $dbnames{$sid} = $home if $sid and $home; + $drh->trace_msg("Found $sid \@ $home.\n") if $debug; + $oracle_home =$home unless $oracle_home; + }; + + # get list of 'local' database SIDs from oratab + foreach $d (qw(/etc /var/opt/oracle), $ENV{TNS_ADMIN}) { + next unless defined $d; + next unless open(FH, "<$d/oratab"); + $drh->trace_msg("Loading $d/oratab\n") if $debug; + my $ot; + while (defined($ot = )) { + next unless $ot =~ m/^\s*(\w+)\s*:\s*(.*?)\s*:/; + $dbnames{$1} = $2; # store ORACLE_HOME value + $drh->trace_msg("Found $1 \@ $2.\n") if $debug; + } + close FH; + last; + } + + # get list of 'remote' database connection identifiers + foreach $d ( $ENV{TNS_ADMIN}, + ".", # current directory + "$oracle_home/network/admin", # OCI 7 and 8.1 + "$oracle_home/net80/admin", # OCI 8.0 + "/var/opt/oracle" + ) { + next unless $d && open(FH, "<$d/tnsnames.ora"); + $drh->trace_msg("Loading $d/tnsnames.ora\n") if $debug; + while () { + next unless m/^\s*([-\w\.]+)\s*=/; + my $name = $1; + $drh->trace_msg("Found $name. ".($dbnames{$name} ? "(oratab entry overridden)" : "")."\n") + if $debug; + $dbnames{$name} = 0; # exists but false (to distinguish from oratab) + } + close FH; + last; + } + + $dbnames{0} = 1; # mark as loaded (even if empty) + } + + sub data_sources { + my $drh = shift; + load_dbnames($drh) unless %dbnames; + my @names = sort keys %dbnames; + my @sources = map { $_ ? ("dbi:Oracle:$_") : () } @names; + return @sources; + } + + + sub connect { + my ($drh, $dbname, $user, $auth, $attr)= @_; + + if ($dbname =~ /;/) { + my ($n,$v); + $dbname =~ s/^\s+//; + $dbname =~ s/\s+$//; + my @dbname = map { + ($n,$v) = split /\s*=\s*/, $_; (uc($n), $v) + } split /\s*;\s*/, $dbname; + my %dbname = ( PROTOCOL => 'tcp', @dbname ); + my $sid = delete $dbname{SID}; + return $drh->DBI::set_err(-1, + "Can't connect using this syntax without specifying a HOST and a SID") + unless $sid and $dbname{HOST}; + my @addrs; + push @addrs, "$n=$v" while ( ($n,$v) = each %dbname ); + my $addrs = "(" . join(")(", @addrs) . ")"; + if ($dbname{PORT}) { + $addrs = "(ADDRESS=$addrs)"; + } + else { + $addrs = "(ADDRESS_LIST=(ADDRESS=$addrs(PORT=1526))" # Oracle8 + . "(ADDRESS=$addrs(PORT=1521)))"; # Oracle7 + } + $dbname = "(DESCRIPTION=$addrs(CONNECT_DATA=(SID=$sid)))"; + $drh->trace_msg("connect using '$dbname'"); + } + + # If the application is asking for specific database + # then we may have to mung the dbname + + if (DBD::Oracle::ORA_OCI() >= 8) { + $dbname = $1 if !$dbname && $user =~ s/\@(.*)//s; + } + elsif ($dbname) { # OCI 7 handling below + + # We can use the 'user/passwd@machine' form of user. + # $TWO_TASK and $ORACLE_SID will be ignored in that case. + if ($dbname =~ /^@/){ # Implies an Sql*NET connection + $user = "$user/$auth$dbname"; + $auth = ""; + } + elsif ($dbname =~ /^\w?:/){ # Implies an Sql*NET connection + $user = "$user/$auth".'@'.$dbname; + $auth = ""; + } + else { + # Is this a NON-Sql*NET connection (ORACLE_SID)? + # Or is it an alias for an Sql*NET connection (TWO_TASK)? + # Sadly the 'user/passwd@machine' form only works + # for Sql*NET connections. + load_dbnames($drh) unless %dbnames; + if (exists $dbnames{$dbname}) { # known name + my $dbhome = $dbnames{$dbname}; # local=>ORACLE_HOME, remote=>0 + if ($dbhome) { + $ENV{ORACLE_SID} = $dbname; + delete $ENV{TWO_TASK}; + if ($attr && $attr->{ora_oratab_orahome}) { + warn "Changing $ORACLE_ENV for $dbname to $dbhome (to match oratab entry)" + if ($ENV{$ORACLE_ENV} and $dbhome ne $ENV{$ORACLE_ENV}); + $ENV{$ORACLE_ENV} = $dbhome; + } + } + else { + $user .= '@'.$dbname; # it's a known TNS alias + } + } + else { + $user .= '@'.$dbname; # assume it's a TNS alias + } + } + } + + warn "$ORACLE_ENV environment variable not set!\n" + if !$ENV{$ORACLE_ENV} and $^O ne "MSWin32"; + + # create a 'blank' dbh + + my $dbh = DBI::_new_dbh($drh, { + 'Name' => $dbname, + 'USER' => $user, 'CURRENT_USER' => $user, + }); + + # Call Oracle OCI logon func in Oracle.xs file + # and populate internal handle data. + DBD::Oracle::db::_login($dbh, $dbname, $user, $auth, $attr) + or return undef; + + if ($attr && $attr->{ora_module_name}) { + eval { + $dbh->do(q{BEGIN DBMS_APPLICATION_NAME.SET_MODULE(:1,NULL); END;}, + undef, $attr->{ora_module_name}); + }; + } + + $dbh; + } + +} + + +{ package DBD::Oracle::db; # ====== DATABASE ====== + use strict; + + sub prepare { + my($dbh, $statement, @attribs)= @_; + + # create a 'blank' sth + + my $sth = DBI::_new_sth($dbh, { + 'Statement' => $statement, + }); + + # Call Oracle OCI parse func in Oracle.xs file. + # and populate internal handle data. + + DBD::Oracle::st::_prepare($sth, $statement, @attribs) + or return undef; + + $sth; + } + + + sub ping { + my($dbh) = @_; + my $ok = 0; + eval { + local $SIG{__DIE__}; + local $SIG{__WARN__}; + # we know that Oracle 7 prepare does a describe so this will + # actually talk to the server and is this a valid and cheap test. + my $sth = $dbh->prepare("select SYSDATE from DUAL /* ping */"); + # But Oracle 8 doesn't talk to server unless we describe the query + $ok = $sth && $sth->FETCH('NUM_OF_FIELDS'); + }; + return ($@) ? 0 : $ok; + } + + + sub table_info { + my($dbh) = @_; # XXX add qualification + # XXX add knowledge of public synonmys views etc + # The SYS/SYSTEM should probably be a decode that + # prepends 'SYSTEM ' to TABLE_TYPE. + my $sth = $dbh->prepare("select + NULL TABLE_CAT, + at.OWNER TABLE_SCHEM, + at.TABLE_NAME, + tc.TABLE_TYPE, + tc.COMMENTS REMARKS + from ALL_TABLES at, ALL_TAB_COMMENTS tc + where at.OWNER = tc.OWNER + and at.TABLE_NAME = tc.TABLE_NAME + and at.OWNER <> 'SYS' and at.OWNER <> 'SYSTEM' + order by tc.TABLE_TYPE, at.OWNER, at.TABLE_NAME + ") or return undef; + $sth->execute or return undef; + $sth; + } + + sub type_info_all { + my ($dbh) = @_; + my $names = { + TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE => 9, + FIXED_PREC_SCALE =>10, + AUTO_UNIQUE_VALUE =>11, + LOCAL_TYPE_NAME =>12, + MINIMUM_SCALE =>13, + MAXIMUM_SCALE =>14, + SQL_DATA_TYPE =>15, + SQL_DATETIME_SUB =>16, + NUM_PREC_RADIX =>17, + }; + # Based on the values from Oracle 8.0.4 ODBC driver + my $ti = [ + $names, + [ 'LONG RAW', -4, '2147483647', '\'', '\'', undef, 1, '0', '0', + undef, '0', undef, undef, undef, undef, -4, undef, undef + ], + [ 'RAW', -3, 255, '\'', '\'', 'max length', 1, '0', 3, + undef, '0', undef, undef, undef, undef, -3, undef, undef + ], + [ 'LONG', -1, '2147483647', '\'', '\'', undef, 1, 1, '0', + undef, '0', undef, undef, undef, undef, -1, undef, undef + ], + [ 'CHAR', 1, 255, '\'', '\'', 'max length', 1, 1, 3, + undef, '0', '0', undef, undef, undef, 1, undef, undef + ], + [ 'NUMBER', 3, 38, undef, undef, 'precision,scale', 1, '0', 3, + '0', '0', '0', undef, '0', 38, 3, undef, 10 + ], + [ 'DOUBLE', 8, 15, undef, undef, undef, 1, '0', 3, + '0', '0', '0', undef, undef, undef, 8, undef, 10 + ], + [ 'DATE', 11, 19, '\'', '\'', undef, 1, '0', 3, + undef, '0', '0', undef, '0', '0', 11, undef, undef + ], + [ 'VARCHAR2', 12, 2000, '\'', '\'', 'max length', 1, 1, 3, + undef, '0', '0', undef, undef, undef, 12, undef, undef + ] + ]; + return $ti; + } + + sub plsql_errstr { + # original version thanks to Bob Menteer + my $sth = shift->prepare_cached(q{ + SELECT name, type, line, position, text + FROM user_errors ORDER BY name, type, sequence + }) or return undef; + $sth->execute or return undef; + my ( @msg, $oname, $otype, $name, $type, $line, $pos, $text ); + $oname = $otype = 0; + while ( ( $name, $type, $line, $pos, $text ) = $sth->fetchrow_array ) { + if ( $oname ne $name || $otype ne $type ) { + push @msg, "Errors for $type $name:"; + $oname = $name; + $otype = $type; + } + push @msg, "$line.$pos: $text"; + } + return join( "\n", @msg ); + } + + # + # note, dbms_output must be enabled prior to usage + # + sub dbms_output_enable { + my ($dbh, $buffersize) = @_; + $buffersize ||= 20000; # use oracle 7.x default + $dbh->do("begin dbms_output.enable(:1); end;", undef, $buffersize); + } + + sub dbms_output_get { + my $dbh = shift; + my $sth = $dbh->prepare_cached("begin dbms_output.get_line(:l, :s); end;") + or return; + my ($line, $status, @lines); + # line can be greater that 255 (e.g. 7 byte date is expanded on output) + $sth->bind_param_inout(':l', \$line, 400); + $sth->bind_param_inout(':s', \$status, 20); + if (!wantarray) { + $sth->execute or return undef; + return $line if $status eq '0'; + return undef; + } + push @lines, $line while($sth->execute && $status eq '0'); + return @lines; + } + + sub dbms_output_put { + my $dbh = shift; + my $sth = $dbh->prepare_cached("begin dbms_output.put_line(:1); end;") + or return; + my $line; + foreach $line (@_) { + $sth->execute($line) or return; + } + return 1; + } + + + sub dbms_msgpipe_get { + my $dbh = shift; + my $sth = $dbh->prepare_cached(q{ + begin dbms_msgpipe.get_request(:returnpipe, :proc, :param); end; + }) or return; + my $msg = ['','','']; + $sth->bind_param_inout(":returnpipe", \$msg->[0], 30); + $sth->bind_param_inout(":proc", \$msg->[1], 30); + $sth->bind_param_inout(":param", \$msg->[2], 4000); + $sth->execute or return undef; + return $msg; + } + + sub dbms_msgpipe_ack { + my $dbh = shift; + my $msg = shift; + my $sth = $dbh->prepare_cached(q{ + begin dbms_msgpipe.acknowledge(:returnpipe, :errormsg, :param); end; + }) or return; + $sth->bind_param_inout(":returnpipe", \$msg->[0], 30); + $sth->bind_param_inout(":proc", \$msg->[1], 30); + $sth->bind_param_inout(":param", \$msg->[2], 4000); + $sth->execute or return undef; + return 1; + } + +} # end of package DBD::Oracle::db + + +{ package DBD::Oracle::st; # ====== STATEMENT ====== + + # all done in XS +} + +1; + +__END__ + +=head1 NAME + +DBD::Oracle - Oracle database driver for the DBI module + +=head1 SYNOPSIS + + use DBI; + + $dbh = DBI->connect("dbi:Oracle:$dbname", $user, $passwd); + + $dbh = DBI->connect("dbi:Oracle:host=$host;sid=$sid", $user, $passwd); + + # See the DBI module documentation for full details + + # for some advanced uses you may need Oracle type values: + use DBD::Oracle qw(:ora_types); + + +=head1 DESCRIPTION + +DBD::Oracle is a Perl module which works with the DBI module to provide +access to Oracle databases (both version 7 and 8). + +=head1 CONNECTING TO ORACLE + +This is a topic which often causes problems. Mainly due to Oracle's many +and sometimes complex ways of specifying and connecting to databases. +(James Taylor and Lane Sharman have contributed much of the text in +this section.) + +=head2 Connecting without environment variables or tnsname.ora file + +If you use the C style syntax, for example: + + $dbh = DBI->connect("dbi:Oracle:host=myhost.com;sid=ORCL", $user, $passwd); + +then DBD::Oracle will construct a full connection descriptor string +for you and Oracle will not need to consult the tnsname.ora file. + +If a C number is not specified then the descriptor will try both +1526 and 1521 in that order (e.g., new then old). You can check which +port(s) are in use by typing "$ORACLE_HOME/bin/lsnrctl stat" on the server. + + +=head2 Oracle environment variables + +Oracle typically uses two environment variables to specify default +connections: ORACLE_SID and TWO_TASK. + +ORACLE_SID is really unnecessary to set since TWO_TASK provides the +same functionality in addition to allowing remote connections. + + % setenv TWO_TASK T:hostname:ORACLE_SID # for csh shell + $ TWO_TASK=T:hostname:ORACLE_SID export TWO_TASK # for sh shell + + % sqlplus username/password + +Note that if you have *both* local and remote databases, and you +have ORACLE_SID *and* TWO_TASK set, and you don't specify a fully +qualified connect string on the command line, TWO_TASK takes precedence +over ORACLE_SID (i.e. you get connected to remote system). + + TWO_TASK=P:sid + +will use the pipe driver for local connections using SQL*Net v1. + + TWO_TASK=T:machine:sid + +will use TCP/IP (or D for DECNET, etc.) for remote SQL*Net v1 connection. + + TWO_TASK=dbname + +will use the info stored in the SQL*Net v2 F +configuration file for local or remote connections. + +The ORACLE_HOME environment variable should be set correctly. It can be +left unset if you aren't using any of Oracle's executables, but it is +not recommended and error messages may not display. + +Discouraging the use of ORACLE_SID makes it easier on the users to see +what is going on. (It's unfortunate that TWO_TASK couldn't be renamed, +since it makes no sense to the end user, and doesn't have the ORACLE +prefix). + +=head2 Connection Examples Using DBD::Oracle + +Below are various ways of connecting to an oracle database using +SQL*Net 1.x and SQL*Net 2.x. "Machine" is the computer the database is +running on, "SID" is the SID of the database, "DB" is the SQL*Net 2.x +connection descriptor for the database. + +B Some of these formats may not work with Oracle 8. + + BEGIN { + $ENV{ORACLE_HOME} = '/home/oracle/product/7.x.x'; + $ENV{TWO_TASK} = 'DB'; + } + $dbh = DBI->connect('dbi:Oracle:','scott', 'tiger'); + # - or - + $dbh = DBI->connect('dbi:Oracle:','scott/tiger'); + +works for SQL*Net 2.x, so does + + $ENV{TWO_TASK} = 'T:Machine:SID'; + +for SQL*Net 1.x connections. For local connections you can use the +pipe driver: + + $ENV{TWO_TASK} = 'P:SID'; + +Here are some variations (not setting TWO_TASK) + + $dbh = DBI->connect('dbi:Oracle:T:Machine:SID','username','password') + + $dbh = DBI->connect('dbi:Oracle:','username@T:Machine:SID','password') + + $dbh = DBI->connect('dbi:Oracle:','username@DB','password') + + $dbh = DBI->connect('dbi:Oracle:DB','username','password') + + $dbh = DBI->connect('dbi:Oracle:DB','username/password','') + + $dbh = DBI->connect('dbi:Oracle:host=foobar;sid=ORCL;port=1521', 'scott/tiger', '') + + $dbh = DBI->connect('dbi:Oracle:', q{scott/tiger@(DESCRIPTION= + (ADDRESS=(PROTOCOL=TCP)(HOST= foobar)(PORT=1521)) + (CONNECT_DATA=(SID=ORCL)))}, "") + +If you are having problems with login taking a long time (>10 secs say) +then you might have tripped up on an Oracle bug. You can try using one +of the ...@DB variants as a workaround. E.g., + + $dbh = DBI->connect('','username/password@DB',''); + +On the other hand, that may cause you to trip up on another Oracle bug +that causes alternating connection attempts to fail! (In reality only +a small proportion of people experience these problems.) + + +=head2 Optimizing Oracle's listner + +[By Lane Sharman ] I spent a LOT of time optimizing +listener.ora and I am including it here for anyone to benefit from. My +connections over tnslistener on the same humble Netra 1 take an average +of 10-20 milli seconds according to tnsping. If anyone knows how to +make it better, please let me know! + + LISTENER = + (ADDRESS_LIST = + (ADDRESS = + (PROTOCOL = TCP) + (Host = aa.bbb.cc.d) + (Port = 1521) + (QUEUESIZE=10) + ) + ) + + STARTUP_WAIT_TIME_LISTENER = 0 + CONNECT_TIMEOUT_LISTENER = 10 + TRACE_LEVEL_LISTENER = OFF + SID_LIST_LISTENER = + (SID_LIST = + (SID_DESC = + (SID_NAME = xxxx) + (ORACLE_HOME = /xxx/local/oracle7-3) + (PRESPAWN_MAX = 40) + (PRESPAWN_LIST= + (PRESPAWN_DESC=(PROTOCOL=tcp) (POOL_SIZE=40) (TIMEOUT=120)) + ) + ) + ) + +1) When the application is co-located on the host AND there is no need for +outside SQLNet connectivity, stop the listener. You do not need it. Get +your application/cgi/whatever working using pipes and shared memory. I am +convinced that this is one of the connection bugs (sockets over the same +machine). Note the $ENV{ORAPIPES} env var. The essential code to do +this at the end of this section. + +2) Be careful in how you implement the multi-threaded server. Currently I +am not using it in the initxxxx.ora file but will be doing some more testing. + +3) Be sure to create user rollback segments and use them; do not use the +system rollback segments; however, you must also create a small rollback +space for the system as well. + +5) Use large tuning settings and get lots of RAM. Check out all the +parameters you can set in v$parameters because there are quite a few not +documented you may to set in your initxxx.ora file. + +6) Use svrmgrl to control oracle from the command line. Write lots of small +SQL scripts to get at V$ info. + + use DBI; + # Environmental variables used by Oracle + $ENV{ORACLE_SID} = "xxx"; + $ENV{ORACLE_HOME} = "/opt/oracle7"; + $ENV{EPC_DISABLED} = "TRUE"; + $ENV{ORAPIPES} = "V2"; + my $dbname = "xxx"; + my $dbuser = "xxx"; + my $dbpass = "xxx"; + my $dbh = DBI->connect("dbi:Oracle:$dbname", $dbuser, $dbpass) + || die "Unale to connect to $dbname: $DBI::errstr\n"; + +=head2 Oracle utilities + +If you are still having problems connecting then the Oracle adapters +utility may offer some help. Run these two commands: + + $ORACLE_HOME/bin/adapters + $ORACLE_HOME/bin/adapters $ORACLE_HOME/bin/sqlplus + +and check the output. The "Protocol Adapters" section should be the +same. It should include at least "IPC Protocol Adapter" and "TCP/IP +Protocol Adapter". + +If it generates any errors which look relevant then please talk to yor +Oracle technical support (and not the dbi-users mailing list). Thanks. +Thanks to Mark Dedlow for this information. + + +=head2 Connect Attributes + +The ora_session_mode attribute can be used to connect with SYSDBA +authorization and SYSOPER authorization. + + $mode = 2; # SYSDBA + $mode = 4; # SYSOPER + DBI->connect($dsn, $user, $passwd, { ora_session_mode => $mode }); + + +=head1 International NLS / 8-bit text issues + +If 8-bit text is returned as '?' characters or can't be inserted +make sure the following environment vaiables are set correctly: + NLS_LANG, ORA_NLS, ORA_NLS32, ORA_NLS33 +Thanks to Robin Langdon for this information. +Example: + $ENV{NLS_LANG} = "american_america.we8iso8859p1"; + $ENV{ORA_NLS} = "$ENV{ORACLE_HOME}/ocommon/nls/admin/data"; + +Also From: Yngvi Thor Sigurjonsson +If you are using 8-bit characters and "export" for backups make sure +that you have NLS_LANG set when export is run. Otherwise you might get +unusable backups with ? replacing all your beloved characters. We were +lucky once when we noticed that our exports were damaged before +disaster struck. + +Remember that the database has to be created with an 8-bit character set. + +Also note that the NLS files $ORACLE_HOME/ocommon/nls/admin/data +changed extension (from .d to .nlb) between 7.2.3 and 7.3.2. + + +=head1 PL/SQL Examples + +These PL/SQL examples come from: Eric Bartley . + + # we assume this package already exists + my $plsql = q{ + + CREATE OR REPLACE PACKAGE plsql_example + IS + PROCEDURE proc_np; + + PROCEDURE proc_in ( + err_code IN NUMBER + ); + + PROCEDURE proc_in_inout ( + test_num IN NUMBER, + is_odd IN OUT NUMBER + ); + + FUNCTION func_np + RETURN VARCHAR2; + + END plsql_example; + + CREATE OR REPLACE PACKAGE BODY plsql_example + IS + PROCEDURE proc_np + IS + whoami VARCHAR2(20) := NULL; + BEGIN + SELECT USER INTO whoami FROM DUAL; + END; + + PROCEDURE proc_in ( + err_code IN NUMBER + ) + IS + BEGIN + RAISE_APPLICATION_ERROR(err_code, 'This is a test.'); + END; + + PROCEDURE proc_in_inout ( + test_num IN NUMBER, + is_odd IN OUT NUMBER + ) + IS + BEGIN + is_odd := MOD(test_num, 2); + END; + + FUNCTION func_np + RETURN VARCHAR2 + IS + ret_val VARCHAR2(20); + BEGIN + SELECT USER INTO ret_val FROM DUAL; + RETURN ret_val; + END; + + END plsql_example; + }; + + use DBI; + + my($db, $csr, $ret_val); + + $db = DBI->connect('dbi:Oracle:database','user','password') + or die "Unable to connect: $DBI::errstr"; + + # So we don't have to check every DBI call we set RaiseError. + # See the DBI docs now if you're not familiar with RaiseError. + $db->{RaiseError} = 1; + + # Example 1 + # + # Calling a PLSQL procedure that takes no parameters. This shows you the + # basic's of what you need to execute a PLSQL procedure. Just wrap your + # procedure call in a BEGIN END; block just like you'd do in SQL*Plus. + # + # p.s. If you've used SQL*Plus's exec command all it does is wrap the + # command in a BEGIN END; block for you. + + $csr = $db->prepare(q{ + BEGIN + PLSQL_EXAMPLE.PROC_NP; + END; + }); + $csr->execute; + + + # Example 2 + # + # Now we call a procedure that has 1 IN parameter. Here we use bind_param + # to bind out parameter to the prepared statement just like you might + # do for an INSERT, UPDATE, DELETE, or SELECT statement. + # + # I could have used positional placeholders (e.g. :1, :2, etc.) or + # ODBC style placeholders (e.g. ?), but I prefer Oracle's named + # placeholders (but few DBI drivers support them so they're not portable). + + my $err_code = -20001; + + $csr = $db->prepare(q{ + BEGIN + PLSQL_EXAMPLE.PROC_IN(:err_code); + END; + }); + + $csr->bind_param(":err_code", $err_code); + + # PROC_IN will RAISE_APPLICATION_ERROR which will cause the execute to 'fail'. + # Because we set RaiseError, the DBI will croak (die) so we catch that with eval. + eval { + $csr->execute; + }; + print 'After proc_in: $@=',"'$@', errstr=$DBI::errstr, ret_val=$ret_val\n"; + + + # Example 3 + # + # Building on the last example, I've added 1 IN OUT parameter. We still + # use a placeholders in the call to prepare, the difference is that + # we now call bind_param_inout to bind the value to the place holder. + # + # Note that the third parameter to bind_param_inout is the maximum size + # of the variable. You normally make this slightly larger than necessary. + # But note that the perl variable will have that much memory assigned to + # it even if the actual value returned is shorter. + + my $test_num = 5; + my $is_odd; + + $csr = $db->prepare(q{ + BEGIN + PLSQL_EXAMPLE.PROC_IN_INOUT(:test_num, :is_odd); + END; + }); + + # The value of $test_num is _copied_ here + $csr->bind_param(":test_num", $test_num); + + $csr->bind_param_inout(":is_odd", \$is_odd, 1); + + # The execute will automagically update the value of $is_odd + $csr->execute; + + print "$test_num is ", ($is_odd) ? "odd - ok" : "even - error!", "\n"; + + + # Example 4 + # + # What about the return value of a PLSQL function? Well treat it the same + # as you would a call to a function from SQL*Plus. We add a placeholder + # for the return value and bind it with a call to bind_param_inout so + # we can access it's value after execute. + + my $whoami = ""; + + $csr = $db->prepare(q{ + BEGIN + :whoami := PLSQL_EXAMPLE.FUNC_NP; + END; + }); + + $csr->bind_param_inout(":whoami", \$whoami, 20); + $csr->execute; + print "Your database user name is $whoami\n"; + + $db->disconnect; + +You can find more examples in the t/plsql.t file in the DBD::Oracle +source directory. + + +=head1 Private database handle functions + +These functions are called through the method func() +which is described in the DBI documentation. + +=head2 plsql_errstr + +This function returns a string which describes the errors +from the most recent PL/SQL function, procedure, package, +or package body compile in a format similar to the output +of the SQL*Plus command 'show errors'. + +The function returns undef if the error string could not +be retrieved due to a database error. +Look in $dbh->errstr for the cause of the failure. + +If there are no compile errors, an empty string is returned. + +Example: + + # Show the errors if CREATE PROCEDURE fails + $dbh->{RaiseError} = 0; + if ( $dbh->do( q{ + CREATE OR REPLACE PROCEDURE perl_dbd_oracle_test as + BEGIN + PROCEDURE filltab( stuff OUT TAB ); asdf + END; } ) ) {} # Statement succeeded + } + elsif ( 6550 != $dbh->err ) { die $dbh->errstr; } # Utter failure + my $msg = $dbh->func( 'plsql_errstr' ); + die $dbh->errstr if ! defined $msg; + die $msg if $msg; + + +=head2 dbms_output_enable / dbms_output_put / dbms_output_get + +These functions use the PL/SQL DBMS_OUTPUT package to store and +retrieve text using the DBMS_OUTPUT buffer. Text stored in this buffer +by dbms_output_put or any PL/SQL block can be retrieved by +dbms_output_get or any PL/SQL block connected to the same database +session. + +Stored text is not available until after dbms_output_put or the PL/SQL +block that saved it completes its execution. This means you B +use these functions to monitor long running PL/SQL procedures. + +Example 1: + + # Enable DBMS_OUTPUT and set the buffer size + $dbh->{RaiseError} = 1; + $dbh->func( 1000000, 'dbms_output_enable' ); + + # Put text in the buffer . . . + $dbh->func( @text, 'dbms_output_put' ); + + # . . . and retreive it later + @text = $dbh->func( 'dbms_output_get' ); + +Example 2: + + $dbh->{RaiseError} = 1; + $sth = $dbh->prepare(q{ + DECLARE tmp VARCHAR2(50); + BEGIN + SELECT SYSDATE INTO tmp FROM DUAL; + dbms_output.put_line('The date is '||tmp); + END; + }); + $sth->execute; + + # retreive the string + $date_string = $dbh->func( 'dbms_output_get' ); + + +=over 4 + +=item dbms_output_enable ( [ buffer_size ] ) + +This function calls DBMS_OUTPUT.ENABLE to enable calls to package +DBMS_OUTPUT procedures GET, GET_LINE, PUT, and PUT_LINE. Calls to +these procedures are ignored unless DBMS_OUTPUT.ENABLE is called +first. + +The buffer_size is the maximum amount of text that can be saved in the +buffer and must be between 2000 and 1,000,000. If buffer_size is not +given, the default is 20,000 bytes. + +=item dbms_output_put ( [ @lines ] ) + +This function calls DBMS_OUTPUT.PUT_LINE to add lines to the buffer. + +If all lines were saved successfully the function returns 1. Depending +on the context, an empty list or undef is returned for failure. + +If any line causes buffer_size to be exceeded, a buffer overflow error +is raised and the function call fails. Some of the text might be in +the buffer. + +=item dbms_output_get + +This function calls DBMS_OUTPUT.GET_LINE to retrieve lines of text from +the buffer. + +In an array context, all complete lines are removed from the buffer and +returned as a list. If there are no complete lines, an empty list is +returned. + +In a scalar context, the first complete line is removed from the buffer +and returned. If there are no complete lines, undef is returned. + +Any text in the buffer after a call to DBMS_OUTPUT.GET_LINE or +DBMS_OUTPUT.GET is discarded by the next call to DBMS_OUTPUT.PUT_LINE, +DBMS_OUTPUT.PUT, or DBMS_OUTPUT.NEW_LINE. + +=back + + +=head1 Using DBD::Oracle with Oracle 8 - Features and Issues + +DBD::Oracle version 0.55 onwards can be built to use either the Oracle 7 +or Oracle 8 OCI (Oracle Call Interface) API functions. The new Oracle 8 +API is used by default and offers several advantages, including support +for LOB types and cursor binding. Here's a quote from the Oracle OCI +documentation: + + The Oracle8 OCI has several enhancements to improve application + performance and scalability. Application performance has been improved + by reducing the number of client to server round trips required and + scalability improvements have been facilitated by reducing the amount + of state information that needs to be retained on the server side. + +=head2 Prepare postponed till execute + +The DBD::Oracle module will avoid an explicit 'describe' operation +prior to the execution of the statement unless the application requests +information about the results (such as $sth->{NAME}). This reduces +communication with the server and increases performance. However, it also +means that SQL errors are not detected until C is called +(instead of C as now). + +=head2 Handling LOBs + +When fetching LOBs, they are treated just like LONGs and are subject to +$sth->{LongReadLen} and $sth->{LongTruncOk}. Note that with OCI 7 +DBD::Oracle pre-allocates the whole buffer (LongReadLen) before +constructing the returned column. With OCI 8 it grows the buffer to +the amount needed for the largest LOB to be fetched so far. + +When inserting or updating LOBs some I magic has to be performed +behind the scenes to make it transparent. Basically the driver has to +refetch the newly inserted 'LOB Locators' before being able to write to +them. However, it works, and I've made it as fast as possible, just +one extra server-round-trip per insert or update after the first. +For the time being, only single-row LOB updates are supported. Also +passing LOBS to PL/SQL blocks doesn't work. + +To insert or update a large LOB, DBD::Oracle has to know in advance +that it is a LOB type. So you need to say: + + $sth->bind_param($field_num, $lob_value, { ora_type => ORA_CLOB }); + +The ORA_CLOB and ORA_BLOB constants can be imported using + + use DBD::Oracle qw(:ora_types); + +or just use the corresponding integer values (112 and 113). + +To make scripts work with both Oracle7 and Oracle8, the Oracle7 +DBD::Oracle will treat the LOB ora_types as LONGs without error. +So in any code you may have now that looks like + + $sth->bind_param($idx, $value, { ora_type => 8 }); + +you could change the 8 (LONG type) to ORA_CLOB or ORA_BLOB +(112 or 113). + +One further wrinkle: for inserts and updates of LOBs, DBD::Oracle has +to be able to tell which parameters relate to which table fields. +In all cases where it can possibly work it out for itself, it does, +however, if there are multiple LOB fields of the same type in the table +then you need to tell it which field each LOB param relates to: + + $sth->bind_param($idx, $value, { ora_type=>ORA_CLOB, ora_field=>'foo' }); + +=head2 Binding Cursors + +Cursors can now be returned from PL/SQL blocks. Either from stored +procedure OUT parameters or from direct C statements, as show below: + + use DBI; + use DBD::Oracle qw(:ora_types); + $dbh = DBI->connect(...); + $sth1 = $dbh->prepare(q{ + BEGIN OPEN :cursor FOR + SELECT table_name, tablespace_name + FROM user_tables WHERE tablespace_name = :space + END; + }); + $sth1->bind_param(":space", "USERS"); + my $sth2; + $sth1->bind_param_inout(":cursor", \$sth2, 0, { ora_type => ORA_RSET } ); + # $sth2 is now a valid DBI statement handle for the cursor + while ( @row = $sth2->fetchrow_array ) { ... } + +The only special requirement is the use of C with an +attribute hash parameter that specifies C as C. +If you don't do that you'll get an error from the C like: +"ORA-06550: line X, column Y: PLS-00306: wrong number or types of +arguments in call to ...". + +=head1 Oracle Related Links + +=head2 Oracle on Linux + + http://www.datamgmt.com/maillist.html + http://www.eGroups.com/list/oracle-on-linux + http://www.wmd.de/wmd/staff/pauck/misc/oracle_on_linux.html + ftp://oracle-ftp.oracle.com/server/patch_sets/LINUX + +=head2 Free Oracle Tools and Links + + ora_explain supplied and installed with DBD::Oracle. + + http://vonnieda.org/oracletool/ + +=head2 Commercial Oracle Tools and Links + +Assorted tools and references for general information. +No recommendation implied. + + http://www.platinum.com/products/oracle.htm + http://www.SoftTreeTech.com + http://www.databasegroup.com + +Also PL/Vision from RevealNet and Steven Feuerstein, and +"Q" from Savant Corporation. + + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +DBD::Oracle by Tim Bunce. DBI by Tim Bunce. + +=head1 COPYRIGHT + +The DBD::Oracle module is Copyright (c) 1995,1996,1997,1998,1999 Tim Bunce. England. +The DBD::Oracle module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself with the exception that it +cannot be placed on a CD-ROM or similar media for commercial distribution +without the prior approval of the author unless the CD-ROM is primarily a +copy of the majority of the CPAN archive. + +=head1 ACKNOWLEDGEMENTS + +A great many people have helped me over the years. Far too many to +name, but I thank them all. + +See also L. + +=cut diff --git a/Oracle.xs b/Oracle.xs new file mode 100644 index 00000000..096adfbf --- /dev/null +++ b/Oracle.xs @@ -0,0 +1,98 @@ +#include "Oracle.h" + +DBISTATE_DECLARE; + +MODULE = DBD::Oracle PACKAGE = DBD::Oracle + +I32 +constant() + PROTOTYPE: + ALIAS: + ORA_VARCHAR2 = 1 + ORA_NUMBER = 2 + ORA_LONG = 8 + ORA_ROWID = 11 + ORA_DATE = 12 + ORA_RAW = 23 + ORA_LONGRAW = 24 + ORA_CHAR = 96 + ORA_MLSLABEL = 105 + ORA_NTY = 108 + ORA_CLOB = 112 + ORA_BLOB = 113 + ORA_RSET = 116 + ORA_OCI = 0 + CODE: + if (!ix) { + char *what = GvNAME(CvGV(cv)); + if (strEQ(what,"ORA_OCI")) +#ifdef OCI_V8_SYNTAX + RETVAL = 8; +#else + RETVAL = 7; +#endif + else croak("Unknown DBD::Oracle constant '%s'", what); + } + else RETVAL = ix; + OUTPUT: + RETVAL + +MODULE = DBD::Oracle PACKAGE = DBD::Oracle + +INCLUDE: Oracle.xsi + +MODULE = DBD::Oracle PACKAGE = DBD::Oracle::st + +void +ora_fetch(sth) + SV * sth + PPCODE: + /* fetchrow: but with scalar fetch returning NUM_FIELDS for Oraperl */ + /* This code is called _directly_ by Oraperl.pm bypassing the DBI. */ + /* as a result we have to do some things ourselves (like calling */ + /* CLEAR_ERROR) and we loose the tracing that the DBI offers :-( */ + D_imp_sth(sth); + AV *av; + int debug = DBIc_DEBUGIV(imp_sth); + if (DBIS->debug > debug) + debug = DBIS->debug; + DBIh_CLEAR_ERROR(imp_sth); + if (GIMME == G_SCALAR) { /* XXX Oraperl */ + /* This non-standard behaviour added only to increase the */ + /* performance of the oraperl emulation layer (Oraperl.pm) */ + if (!imp_sth->done_desc && !dbd_describe(sth, imp_sth)) + XSRETURN_UNDEF; + XSRETURN_IV(DBIc_NUM_FIELDS(imp_sth)); + } + if (debug >= 2) + fprintf(DBILOGFP, " -> ora_fetch\n"); + av = dbd_st_fetch(sth, imp_sth); + if (av) { + int num_fields = AvFILL(av)+1; + int i; + EXTEND(sp, num_fields); + for(i=0; i < num_fields; ++i) { + PUSHs(AvARRAY(av)[i]); + } + if (debug >= 2) + fprintf(DBILOGFP, " <- (...) [%d items]\n", num_fields); + } + else { + if (debug >= 2) + fprintf(DBILOGFP, " <- () [0 items]\n"); + } + if (debug >= 2 && SvTRUE(DBIc_ERR(imp_sth))) + fprintf(DBILOGFP, " !! ERROR: %s %s", + neatsvpv(DBIc_ERR(imp_sth),0), neatsvpv(DBIc_ERRSTR(imp_sth),0)); + + +MODULE = DBD::Oracle PACKAGE = DBD::Oracle::db + +void +reauthenticate(dbh, uid, pwd) + SV * dbh + char * uid + char * pwd + CODE: + D_imp_dbh(dbh); + ST(0) = ora_db_reauthenticate(dbh, imp_dbh, uid, pwd) ? &sv_yes : &sv_no; diff --git a/Oraperl.pm b/Oraperl.pm new file mode 100644 index 00000000..91c71b63 --- /dev/null +++ b/Oraperl.pm @@ -0,0 +1,866 @@ +# Oraperl Emulation Interface for Perl 5 DBD::Oracle DBI +# +# $Id: Oraperl.pm,v 1.39 1999/06/05 03:23:07 timbo Exp $ +# +# Copyright (c) 1994,1995 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file, +# with the exception that it cannot be placed on a CD-ROM or similar media +# for commercial distribution without the prior approval of the author. +# +# To use this interface use one of the following invocations: +# +# use Oraperl; +# or +# eval 'use Oraperl; 1' || die $@ if $] >= 5; +# +# The second form allows oraperl scripts to be used with +# both oraperl and perl 5. + +package Oraperl; + +require 5.002; + +use DBI 0.84; +use Exporter; + +$VERSION = substr(q$Revision: 1.39 $, 10); + +@ISA = qw(Exporter); + +@EXPORT = qw( + &ora_login &ora_open &ora_bind &ora_fetch &ora_close + &ora_logoff &ora_do &ora_titles &ora_lengths &ora_types + &ora_commit &ora_rollback &ora_autocommit &ora_version + &ora_readblob + $ora_cache $ora_long $ora_trunc $ora_errno $ora_errstr + $ora_verno $ora_debug +); + +$debug = 0 unless defined $debug; +$debugdbi = 0; +# $safe # set true/false before 'use Oraperl' if needed. +$safe = 1 unless defined $safe; + +# Help those who get core dumps from non-'safe' Oraperl (bad cursors) +use sigtrap qw(ILL); +if (!$safe) { + $SIG{BUS} = $SIG{SEGV} = sub { + print STDERR "Add BEGIN { \$Oraperl::safe=1 } above 'use Oraperl'.\n" + unless $safe; + goto &sigtrap::trap; + }; +} + + +# Install Driver (use of install_driver is a special case here) +$drh = DBI->install_driver('Oracle'); +if ($drh) { + print "DBD::Oracle driver installed as $drh\n" if $debug; + $drh->trace($debug); + $drh->{CompatMode} = 1; + $drh->{Warn} = 0; +} + + +use strict; + +sub _func_ref { + my $name = shift; + my $pkg = ($Oraperl::safe) ? "DBI" : "DBD::Oracle"; + \&{"${pkg}::$name"}; +} + +sub _warn { + my $prev_warn = shift; + if ($_[0] =~ /^(Bad|Duplicate) free/) { + return unless $ENV{PERL_DBD_DUMP} eq 'dump'; + print STDERR "Aborting with a core dump for diagnostics (PERL_DBD_DUMP)\n"; + dump; + } + $prev_warn ? &$prev_warn(@_) : warn @_; +} + + +# ----------------------------------------------------------------- +# +# $lda = &ora_login($system_id, $name, $password) +# &ora_logoff($lda) + +sub ora_login { + my($system_id, $name, $password) = @_; + local($Oraperl::prev_warn) = $SIG{'__WARN__'} || 0; # must be local + local($SIG{'__WARN__'}) = sub { _warn($Oraperl::prev_warn, @_) }; + # we still use the old style connect call with an explicit driver + my $dbh = DBI->connect($system_id, $name, $password, 'Oracle'); + return $dbh; +} +sub ora_logoff { + my($dbh) = @_; + return if !$dbh; + local($Oraperl::prev_warn) = $SIG{'__WARN__'} || 0; # must be local + local($SIG{'__WARN__'}) = sub { _warn($Oraperl::prev_warn, @_) }; + $dbh->disconnect(); +} + + + +# ----------------------------------------------------------------- +# +# $csr = &ora_open($lda, $stmt [, $cache]) +# &ora_bind($csr, $var, ...) +# &ora_fetch($csr [, $trunc]) +# &ora_do($lda, $stmt) +# &ora_close($csr) + +sub ora_open { + my($lda, $stmt) = @_; + $Oraperl::ora_cache_o = $_[2]; # temp hack to pass cache through + + my $csr = $lda->prepare($stmt) or return undef; + + # only execute here if no bind vars specified + $csr->execute or return undef unless $csr->{NUM_OF_PARAMS}; + + $csr; +} + +*ora_bind = _func_ref('st::execute'); +*ora_fetch = \&{"DBD::Oracle::st::ora_fetch"}; +*ora_close = _func_ref('st::finish'); + +sub ora_do { + # error => undef + # 0 => "0E0" (0 but true) + # >0 => >0 + my($lda, $stmt, @params) = @_; # @params are an extension to the original Oraperl. + + return $lda->do($stmt, undef, @params); # SEE DEFAULT METHOD IN DBI.pm + + # OLD CODE: + # $csr is local, cursor will be closed on exit + my $csr = $lda->prepare($stmt) or return undef; + # Oracle OCI will automatically execute DDL statements in prepare()! + # We must be carefull not to execute them again! This needs careful + # examination and thought. + # Perhaps oracle is smart enough not to execute them again? + my $ret = $csr->execute(@params); + my $rows = $csr->rows; + ($rows == 0) ? "0E0" : $rows; +} + + +# ----------------------------------------------------------------- +# +# &ora_titles($csr [, $truncate]) +# &ora_lengths($csr) +# &ora_types($csr) + +sub ora_titles{ + my($csr, $trunc) = @_; + warn "ora_titles: truncate option not implemented" if $trunc; + @{$csr->{'NAME'}}; +} +sub ora_lengths{ + @{shift->{'ora_lengths'}} # oracle specific +} +sub ora_types{ + @{shift->{'ora_types'}} # oracle specific +} + + +# ----------------------------------------------------------------- +# +# &ora_commit($lda) +# &ora_rollback($lda) +# &ora_autocommit($lda, $on_off) +# &ora_version + +*ora_commit = _func_ref('db::commit'); +*ora_rollback = _func_ref('db::rollback'); + +sub ora_autocommit { + my($lda, $mode) = @_; + $lda->{AutoCommit} = $mode; + "0E0"; +} +sub ora_version { + my($sw) = DBI->internal; + print "\n"; + print "Oraperl emulation interface version $Oraperl::VERSION\n"; + print "$Oraperl::drh->{Attribution}\n"; + print "$sw->{Attribution}\n\n"; +} + + +# ----------------------------------------------------------------- +# +# $ora_errno +# $ora_errstr + +# This is really internal knowledge but it saves using tie and +# performance for ora_errno is very important. +*Oraperl::ora_errno = \$DBD::Oracle::err; +*Oraperl::ora_errstr = \$DBD::Oracle::errstr; + + +# ----------------------------------------------------------------- +# +# $ora_verno +# $ora_debug not supported, use $h->debug(2) where $h is $lda or $csr +# $ora_cache not supported +# $ora_long used at ora_open() +# $ora_trunc used at ora_open() + +$Oraperl::ora_verno = '3.000'; # to distinguish it from oraperl 2.4 + +# ora_long is left unset so that the DBI $h->{LongReadLen} attrib will be used +# by default. If ora_long is set then LongReadLen will be ignored (sadly) but +# that behaviour may change later to only apply to oraperl mode handles. +#$Oraperl::ora_long = 80; # 80, oraperl default +$Oraperl::ora_trunc = 0; # long trunc is error, oraperl default + + +# ----------------------------------------------------------------- +# +# Non-oraperl extensions added here to make it easy to still run +# script using oraperl (by avoiding $csr->blob_read(...)) + +*ora_readblob = _func_ref('st::blob_read'); + + +1; +__END__ + +=head1 NAME + +Oraperl - Perl access to Oracle databases for old oraperl scripts + +=head1 SYNOPSIS + + eval 'use Oraperl; 1' || die $@ if $] >= 5; # ADD THIS LINE TO OLD SCRIPTS + + $lda = &ora_login($system_id, $name, $password) + $csr = &ora_open($lda, $stmt [, $cache]) + &ora_bind($csr, $var, ...) + &ora_fetch($csr [, $trunc]) + &ora_close($csr) + &ora_logoff($lda) + + &ora_do($lda, $stmt) + + &ora_titles($csr) + &ora_lengths($csr) + &ora_types($csr) + &ora_commit($lda) + &ora_rollback($lda) + &ora_autocommit($lda, $on_off) + &ora_version() + + $ora_cache + $ora_long + $ora_trunc + $ora_errno + $ora_errstr + $ora_verno + + $ora_debug + +=head1 DESCRIPTION + +Oraperl is an extension to Perl which allows access to Oracle databases. + +The functions which make up this extension are described in the +following sections. All functions return a false or undefined (in the +Perl sense) value to indicate failure. You do not need to understand +the references to OCI in these descriptions. They are here to help +those who wish to extend the routines or to port them to new machines. + +The text in this document is largely unchanged from the original Perl4 +oraperl manual written by Kevin Stock . Any comments +specific to the DBD::Oracle Oraperl emulation are prefixed by B. +See the DBD::Oracle and DBI manuals for more information. + +B In order to make the oraperl function definitions available in +perl5 you need to arrange to 'use' the Oraperl.pm module in each file +or package which uses them. You can do this by simply adding S> in each file or package. If you need to make the scripts work +with both the perl4 oraperl and perl5 you should add add the following +text instead: + + eval 'use Oraperl; 1' || die $@ if $] >= 5; + +=head2 Principal Functions + +The main functions for database access are &ora_login(), &ora_open(), +&ora_bind(), &ora_fetch(), &ora_close(), &ora_do() and &ora_logoff(). + +=over 2 + +=item * ora_login + + $lda = &ora_login($system_id, $username, $password) + +In order to access information held within an Oracle database, a +program must first log in to it by calling the &ora_login() function. +This function is called with three parameters, the system ID (see +below) of the Oracle database to be used, and the Oracle username and +password. The value returned is a login identifier (actually an Oracle +Login Data Area) referred to below as $lda. + +Multiple logins may be active simultaneously. This allows a simple +mechanism for correlating or transferring data between databases. + +Most Oracle programs (for example, SQL*Plus or SQL*Forms) examine the +environment variable ORACLE_SID or TWO_TASK to determine which database +to connect to. In an environment which uses several different +databases, it is easy to make a mistake, and attempt to run a program +on the wrong one. Also, it is cumbersome to create a program which +works with more than one database simultaneously. Therefore, Oraperl +requires the system ID to be passed as a parameter. However, if the +system ID parameter is an empty string then oracle will use the +existing value of ORACLE_SID or TWO_TASK in the usual manner. + +Example: + + $lda = &ora_login('personnel', 'scott', 'tiger') || die $ora_errstr; + +This function is equivalent to the OCI olon and orlon functions. + +B note that a name is assumed to be a TNS alias if it does not +appear as the name of a SID in /etc/oratab or /var/opt/oracle/oratab. +See the code in Oracle.pm for the full logic of database name handling. + +B Since the returned $lda is a Perl5 reference the database login +identifier is now automatically released if $lda is overwritten or goes +out of scope. + +=item * ora_open + + $csr = &ora_open($lda, $statement [, $cache]) + +To specify an SQL statement to be executed, the program must call the +&ora_open() function. This function takes at least two parameters: a +login identifier (obtained from &ora_login()) and the SQL statement to +be executed. An optional third parameter specifies the size of the row +cache to be used for a SELECT statement. The value returned from +&ora_open() is a statement identifier (actually an ORACLE Cursor) +referred to below as $csr. + +If the row cache size is not specified, a default size is +used. As distributed, the default is five rows, but this +may have been changed at your installation (see the +&ora_version() function and $ora_cache variable below). + +Examples: + + $csr = &ora_open($lda, 'select ename, sal from emp order by ename', 10); + + $csr = &ora_open($lda, 'insert into dept values(:1, :2, :3)'); + +This function is equivalent to the OCI oopen and oparse functions. For +statements which do not contain substitution variables (see the section +Substitution Variables below), it also uses of the oexec function. For +SELECT statements, it also makes use of the odescr and odefin functions +to allocate memory for the values to be returned from the database. + +=item * ora_bind + + &ora_bind($csr, $var, ...) + +If an SQL statement contains substitution variables (see the section +Substitution Variables below), &ora_bind() is used to assign actual +values to them. This function takes a statement identifier (obtained +from &ora_open()) as its first parameter, followed by as many +parameters as are required by the statement. + +Example: + + &ora_bind($csr, 50, 'management', 'Paris'); + +This function is equivalent to the OCI obndrn and oexec statements. + +The OCI obndrn function does not allow empty strings to be bound. As +distributed, $ora_bind therefore replaces empty strings with a single +space. However, a compilation option allows this substitution to be +suppressed, causing &ora_bind() to fail. The output from the +&ora_version() function specifies which is the case at your installation. + +=item * ora_fetch + + $nfields = &ora_fetch($csr) + + @data = &ora_fetch($csr [, $trunc]) + +The &ora_fetch() function is used in conjunction with a SQL SELECT +statement to retrieve information from a database. This function takes +one mandatory parameter, a statement identifier (obtained from +&ora_open()). + +Used in a scalar context, the function returns the number of fields +returned by the query but no data is actually fetched. This may be +useful in a program which allows a user to enter a statement interactively. + +Example: + + $nfields = &ora_fetch($csr); + +Used in an array context, the value returned is an array containing the +data, one element per field. Note that this will not work as expected: + + @data = &ora_fetch($csr) || die "..."; # WRONG + +The || forces a scalar context so ora_fetch returns the number of fields. + +An optional second parameter may be supplied to indicate whether the +truncation of a LONG or LONG RAW field is to be permitted (non-zero) or +considered an error (zero). If this parameter is not specified, the +value of the global variable $ora_trunc is used instead. Truncation of +other datatypes is always considered a error. + +B The optional second parameter to ora_fetch is not supported. +A DBI usage error will be generated if a second parameter is supplied. +Use the global variable $ora_trunc instead. Also note that the +experimental DBI blob_read method can be used to retrieve a long: + + $csr->blob_read($field, $offset, $len [, \$dest, $destoffset]); + +If truncation occurs, $ora_errno will be set to 1406. &ora_fetch() +will complete successfully if truncation is permitted, otherwise it +will fail. + +&ora_fetch() will fail at the end of the data or if an error occurs. It +is possible to distinguish between these cases by testing the value of +the variable $ora_errno. This will be zero for end of data, non-zero if +an error has occurred. + +Example: + + while (($deptno, $dname, $loc) = &ora_fetch($csr)) + { + warn "Truncated!!!" if $ora_errno == 1406; + # do something with the data + } + warn $ora_errstr if $ora_errno; + +This function is equivalent to the OCI ofetch function. + +=item * ora_close + + &ora_close($csr) + +If an SQL statement is no longer required (for example, all the data +selected has been processed, or no more rows are to be inserted) then +the statement identifier should be released. This is done by calling +the &ora_close() function with the statement identifier as its only +parameter. + +This function is equivalent to the OCI oclose function. + +B Since $csr is a Perl5 reference the statement/cursor is now +automatically closed if $csr is overwritten or goes out of scope. + + +=item * ora_do + + &ora_do($lda, $statement) + +Not all SQL statements return data or contain substitution +variables. In these cases the &ora_do() function may be +used as an alternative to &ora_open() and &ora_close(). +This function takes two parameters, a login identifier and +the statement to be executed. + +Example: + + &ora_do($lda, 'drop table employee'); + +This function is roughly equivalent to + + &ora_close( &ora_open($lda, $statement) ) + +B oraperl v2 used to return the string 'OK' to indicate +success with a zero numeric value. The Oraperl emulation now +uses the string '0E0' to achieve the same effect since it does +not cause any C<-w> warnings when used in a numeric context. + +=item * ora_logoff + + &ora_logoff($lda) + +When the program no longer needs to access a given database, the login +identifier should be released using the &ora_logoff() function. + +This function is equivalent to the OCI ologoff function. + +B Since $lda is a Perl5 reference the database login identifier +is now automatically released if $lda is overwritten or goes out of scope. + +=back + +=head2 Ancillary Functions + +Additional functions available are: &ora_titles(), +&ora_lengths(), &ora_types(), &ora_autocommit(), +&ora_commit(), &ora_rollback() and &ora_version(). + +The first three are of most use within a program which +allows statements to be entered interactively. See, for +example, the sample program sql which is supplied with +Oraperl and may have been installed at your site. + +=over 2 + +=item * ora_titles + + @titles = &ora_titles($csr) + +A program may determine the field titles of an executed +query by calling &ora_titles(). This function takes a +single parameter, a statement identifier (obtained from +&ora_open()) indicating the query for which the titles are +required. The titles are returned as an array of strings, +one for each column. + +Titles are truncated to the length of the field, as reported +by the &ora_lengths() function. + +B oraperl v2.2 actually changed the behaviour such that the +titles were not truncated unless an optional second parameter was +true. This was not reflected in the oraperl manual. The Oraperl +emulation adopts the non truncating behaviour and doesn't support the +truncate parameter. + + +=item * ora_lengths + + @lengths = &ora_lengths($csr) + +A program may determine the length of each of the fields +returned by a query by calling the &ora_lengths() function. +This function takes a single parameter, a statement +identifier (obtained from &ora_open()) indicating the query +for which the lengths are required. The lengths are +returned as an array of integers, one for each column. + + +=item * ora_types + + @types = &ora_types($csr) + +A program may determine the type of each of the fields returned by a +query by calling the &ora_types() function. This function takes a +single parameter, a statement identifier (obtained from &ora_open()) +indicating the query for which the lengths are required. The types are +returned as an array of integers, one for each field. + +These types are defined in your OCI documentation. The correct +interpretation for Oracle v6 is given in the file oraperl.ph. + + +=item * ora_autocommit + + &ora_autocommit($lda, $on_or_off) + +Autocommit mode (in which each transaction is committed immediately, +without waiting for an explicit commit) may be enabled or disabled +using &ora_autocommit(). This function takes two parameters, a login +identifier (obtained from &ora_login()) and a true/false value +indicating whether autocommit is to be enabled (non-zero) or disabled +(zero). By default, autocommit is off. + +Note that autocommit can only be set per login, not per statement. If +you need to control autocommit by statement (for example, to allow +deletions to be rolled back, but insertions to be committed +immediately) you should make multiple calls to &ora_login() and use a +separate login identifier for each statement. + + +=item * ora_commit, ora_rollback + + &ora_commit($lda) + &ora_rollback($lda) + +Modifications to a database may be committed or rolled back using the +&ora_commit() and &ora_rollback() functions. These functions take a +single parameter, a login identifier obtained from &ora_login(). + +Transactions which have been committed (either explicitly by a call to +&ora_commit() or implicitly through the use of &ora_autocommit()) +cannot be subsequently rolled back. + +Note that commit and rollback can only be used per login, not per +statement. If you need to commit or rollback by statement you should +make multiple calls to &ora_login() and use a separate login identifier +for each statement. + + +=item * ora_version + + &ora_version() + +The &ora_version() function prints the version number and +copyright information concerning Oraperl. It also prints +the values of various compilation time options. It does not +return any value, and should not normally be used in a +program. + +Example: + + perl -MOraperl -e 'ora_version()' + + This is Oraperl, version 2, patch level 0. + + Debugging is available, including the -D flag. + Default fetch row cache size is 5. + Empty bind values are replaced by a space. + + Perl is copyright by Larry Wall; type oraperl -v for details. + Additions for oraperl: Copyright 1991, 1992, Kevin Stock. + + Oraperl may be distributed under the same conditions as Perl. + +This function is the equivalent of Perl's C<-v> flag. + +B The Oraperl emulation printout is similar but not identical. + +=back + +=head1 VARIABLES + +Six special variables are provided, $ora_cache, $ora_long, +$ora_trunc, $ora_errno, $ora_errstr and $ora_verno. + +=head2 Customisation Variables + +These variables are used to dictate the behaviour of Oraperl +under certain conditions. + +=over 2 + +=item * $ora_cache + +The $ora_cache variable determines the default cache size used by the +&ora_open() function for SELECT statements if an explicit cache size is +not given. + +It is initialised to the default value reported by &ora_version() but +may be set within a program to apply to all subsequent calls to +&ora_open(). Cursors which are already open are not affected. As +distributed, the default value is five, but may have been altered at +your installation. + +As a special case, assigning zero to $ora_cache resets it to the +default value. Attempting to set $ora_cache to a negative value results +in a warning. + + +=item * $ora_long + +Normally, Oraperl interrogates the database to determine the length of +each field and allocates buffer space accordingly. This is not +possible for fields of type LONG or LONGRAW. To allocate space +according to the maximum possible length (65535 bytes) would obviously +be extremely wasteful of memory. + +Therefore, when &ora_open() determines that a field is a LONG type, it +allocates the amount of space indicated by the $ora_long variable. This +is initially set to 80 (for compatibility with Oracle products) but may +be set within a program to whatever size is required. + +$ora_long is only used when fetching data, not when inserting it. + + +=item * $ora_trunc + +Since Oraperl cannot determine exactly the maximum length of a LONG +field, it is possible that the length indicated by $ora_long is not +sufficient to store the data fetched. In such a case, the optional +second parameter to &ora_fetch() indicates whether the truncation +should be allowed or should provoke an error. + +If this second parameter is not specified, the value of $ora_trunc is +used as a default. This only applies to LONG and LONGRAW data types. +Truncation of a field of any other type is always considered an error +(principally because it indicates a bug in Oraperl). + +=back + +=head2 Status Variables + +These variables report information about error conditions or about +Oraperl itself. They may only be read; a fatal error occurs if a +program attempts to change them. + +=over 2 + +=item * $ora_errno + +$ora_errno contains the Oracle error code provoked by the last function +call. + +There are two cases of particular interest concerning &ora_fetch(). If +a LONG or LONGRAW field is truncated (and truncation is allowed) then +&ora_fetch() will complete successfully but $ora_errno will be set to +1406 to indicate the truncation. When &ora_fetch() fails, $ora_errno +will be set to zero if this was due to the end of data or an error code +if it was due to an actual error. + + +=item * $ora_errstr + +The $ora_errstr variable contains the Oracle error message +corresponding to the current value of $ora_errno. + + +=item * $ora_verno + +The $ora_verno variable contains the version number of Oraperl in the +form v.ppp where v is the major version number and ppp is the +patchlevel. For example, in Oraperl version 3, patch level 142, +$ora_verno would contain the value 3.142 (more or less, allowing for +floating point error). + +=back + + +=head1 SUBSTITUTION VARIABLES + +Oraperl allows an SQL statement to contain substitution variables. +These consist of a colon followed by a number. For example, a program +which added records to a telephone list might use the following call to +&ora_open(): + + $csr = &ora_open($csr, "insert into telno values(:1, :2)"); + +The two names :1 and :2 are called substitution variables. The +function &ora_bind() is used to assign values to these variables. For +example, the following statements would add two new people to the +list: + + &ora_bind($csr, "Annette", "472-8836"); + &ora_bind($csr, "Brian", "937-1823"); + +Note that the substitution variables must be assigned consecutively +beginning from 1 for each SQL statement, as &ora_bind() assigns its +parameters in this order. Named substitution variables (for example, +:NAME, :TELNO) are not permitted. + +B Substitution variables are now bound as type 1 (VARCHAR2) +and not type 5 (STRING) by default. This can alter the behaviour of +SQL code which compares a char field with a substitution variable. +See the String Comparison section in the Datatypes chapter of the +Oracle OCI manual for more details. + +You can work around this by using DBD::Oracle's ability to specify +the Oracle type to be used on a per field basis: + + $char_attrib = { ora_type => 5 }; # 5 = STRING (ala oraperl2.4) + $csr = ora_open($dbh, "select foo from bar where x=:1 and y=:2"); + $csr->bind_param(1, $value_x, $char_attrib); + $csr->bind_param(2, $value_y, $char_attrib); + ora_bind($csr); # bind with no parameters since we've done bind_param()'s + + +=head1 DEBUGGING + +B The Oraperl $ora_debug variable is not supported. However +detailed debugging can be enabled at any time by executing + + $h->debug(2); + +where $h is either a $lda or a $csr. If debugging is enabled on an +$lda then it is automatically passed on to any cursors returned by +&ora_open(). + +=head1 EXAMPLE + + format STDOUT_TOP = + Name Phone + ==== ===== + . + + format STDOUT = + @<<<<<<<<<< @>>>>>>>>>> + $name, $phone + . + + die "You should use oraperl, not perl\n" unless defined &ora_login; + $ora_debug = shift if $ARGV[0] =~ /^\-#/; + + $lda = &ora_login('t', 'kstock', 'kstock') + || die $ora_errstr; + $csr = &ora_open($lda, 'select * from telno order by name') + || die $ora_errstr; + + $nfields = &ora_fetch($csr); + print "Query will return $nfields fields\n\n"; + + while (($name, $phone) = &ora_fetch($csr)) { write; } + warn $ora_errstr if $ora_errno; + + die "fetch error: $ora_errstr" if $ora_errno; + + do ora_close($csr) || die "can't close cursor"; + do ora_logoff($lda) || die "can't log off Oracle"; + + +=head1 NOTES + +In keeping with the philosophy of Perl, there is no pre-defined limit +to the number of simultaneous logins or SQL statements which may be +active, nor to the number of data fields which may be returned by a +query. The only limits are those imposed by the amount of memory +available, or by Oracle. + + +=head1 WARNINGS + +The Oraperl emulation software shares no code with the original +oraperl. It is built on top of the new Perl5 DBI and DBD::Oracle +modules. These modules are still evolving. (One of the goals of +the Oraperl emulation software is to allow useful work to be done +with the DBI and DBD::Oracle modules whilst insulating users from +the ongoing changes in their interfaces.) + +It is quite possible, indeed probable, that some differences in +behaviour will exist. These are probably confined to error handling. + +B differences in behaviour which are not documented here should be +reported to Tim.Bunce@ig.co.uk B CC'd to dbi-users@fugue.com. + + +=head1 SEE ALSO + +=over 2 + +=item Oracle Documentation + +SQL Language Reference Manual. +Programmer's Guide to the Oracle Call Interfaces. + +=item Books + +Programming Perl by Larry Wall and Randal Schwartz. +Learning Perl by Randal Schwartz. + +=item Manual Pages + +perl(1) + +=back + +=head1 AUTHORS + +Perl by Larry Wall . + +ORACLE by Oracle Corporation, California. + +Original Oraperl 2.4 code and documentation +by Kevin Stock . + +DBI and Oraperl emulation using DBD::Oracle +by + +=cut diff --git a/README b/README new file mode 100644 index 00000000..bba3426d --- /dev/null +++ b/README @@ -0,0 +1,264 @@ + +DBD::Oracle -- an Oracle 7 and Oracle 8 interface for Perl 5. + + Copyright (c) 1994,1995,1996,1997,1998,1999 Tim Bunce, England. + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file, + with the exception that it cannot be placed on a CD-ROM or similar media + for commercial distribution without the prior approval of the author. + + PLEASE READ THE ENTIRE README FILE CAREFULLY ! + + +*** QUICK START GUIDE: + + The DBI requires one or more 'driver' modules to talk to databases. + Fetch, build and install the DBI module as per it's README file. + Then delete its source directory tree since it's no longer needed. + Use the 'perldoc DBI' command to read the DBI documentation. + Fetch the DBD::Oracle driver module and unpack it. + Follow the guidelines in this README file caefully. + + +*** *BEFORE* BUILDING, TESTING AND INSTALLING this you will need to: + + Build, test and install Perl 5 (at least 5.004, preferably + version 5.004_04 or later). + It is very important to TEST it and INSTALL it! + + Build, test and install the DBI module (at least DBI 1.08). + It is very important to TEST it and INSTALL it! + + Remember to *read* the DBI README file and this one CAREFULLY! + + Install enough Oracle software to enable DBD::Oracle to build. + That usually includes Pro*C. That's not very specific because it + varies so much between Oracle releases. + + +*** BUILDING: + + perl Makefile.PL # use a perl that's in your PATH + make + +Don't worry about most warnings, specifically "end-of-loop code not +reached", "ANSI C forbids braced-groups within expressions", "cast +increases required alignment of target type" and "passing arg 2 of +`oerhms' with different width due to prototype". + +If you have problems see the 'IF YOU HAVE PROBLEMS' section below. +If it's builds without error you can then run the tests. For the +main test to work it must be able to connect to an Oracle database. + +You will need to set either the TWO_TASK or ORACLE_SID environment +variables to the correct values for your database. Consult Oracle +documentation for more details. Test your setting by connecting to +the database using an Oracle tool such as sqlplus. Once you can do +that then you can test DBD::Oracle knowing that it should work. + +The supplied test will connect to the database using the value of the +ORACLE_USERID environment variable so you should set that to the correct +value before starting the test. Please read README.login. + + make test + + make install (if the tests look okay) + + +*** IF YOU HAVE PROBLEMS: + +Make sure you are using a recent perl (5.004_05, 5.005_03 or later) and +make sure it's on your PATH so you can say 'perl Makefile.PL' and not +'/path/to/perl Makefile.PL'. + +If you get compiler errors refering to Perl's own header files +(.../CORE/*.h) then there is something wrong with your installation. +It is best to use a Perl that was built on the system you are trying to +use and it's also important to use the same compiler that was used to +build the Perl you are using. + +If you have build/link or core dump problems try: + perl Makefile.PL -p +If it helps then please let me know (and please include a copy +of the log from the failed default build, the log from the build that +worked, plus the output of the "perl -V" command). + +The new enhanced Oracle 8 OCI is now supported by DBD::Oracle versions +above 0.54. If the new code causes you problems you can build +DBD::Oracle for Oracle 8 to use the Oracle 7 OCI API by doing: + perl Makefile.PL -8 + +Do not hand edit the generated Makefile unless you are completely sure +you understand the implications! Always try to make changes via the +Makefile.PL command line and/or editing the Makefile.PL. +You should not need to make any changes. If you do please let me +know so that I can try to make it automatic in a later release. + +If you just can't login or login takes a long time then read +README.login and possibly edit test.pl to suit. + +If you can't get it to build on a minimally configured client system +then read README.client, it might help but basically I can't help much. +Others on the dbi-users mailing list probably can. + +If you have linking problems (errors related to libraries or functions) +then you could try forcing a 'static' build using: + + make realclean + perl Makefile.PL LINKTYPE=static + make + make perl (you'll need to use and install _this_ new perl binary) + make test + make -f Makefile.aperl inst_perl MAP_TARGET=perl (install new perl) + make install (install DBD::Oracle) + + +>>> Also carefully read the README.help file which is full of useful +>>> tips and workarounds for various problems of various systems. + + +*** HOW TO REPORT PROBLEMS + +Please don't post problems to comp.lang.perl.* or perl5-porters. +This software is supported via the dbi-users mailing list. For more +information and to keep informed about progress you can join the +mailing list via http://www.fugue.com/dbi (if you are unable to use the +web you can subscribe by sending a message to dbi-request@fugue.com, it +may take a few days to be processed). + +Please post details of any problems (or changes you needed to make) to +dbi-users@fugue.com and CC them to me at Tim.Bunce@ig.co.uk. But note... + +** IT IS IMPORTANT TO INCLUDE *ALL* THE FOLLOWING INFORMATION: + +1. A complete log of all steps of the build, e.g.: + + (do a make realclean first) + perl Makefile.PL -v (note the -v for verbose) + make + make test + make test TEST_VERBOSE=1 (only if any of the t/* tests fail) + + Make sure to include the 'stderr' output. The best way to do this is + to use the "script" command (man script). If that's not available + then (assuming you're not using csh) do "command > command.log 2>&1" + The "2>&1" is required (after the stdout redirect) to redirect stderr + to the same place. + +2. Full details of which version of Oracle you're using (if it + wasn't automatically found and printed by "perl Makefile.PL") + +3. The output of perl -V (that's a capital V, not lowercase) + +4. If you get errors like "undefined symbol", "symbol not found", + "undefined reference", "Text relocation remains" or any similar + error then include the output of "perl Makefile.PL -s XXX" + where XXX is the name of one of the symbols. + Please don't send the entire output of this command, + just any obviously 'interesting' parts (if there are any). + See also the LINKTYPE=static notes above. + +5. If you get a core dump, rebuild DBD::Oracle with debugging + enabled by executing: perl Makefile.PL -g (note the -g option) + then rerun the code to get a new core dump file, finally use a + debugger (gdb, sdb, dbx, adb etc) to get a stack trace from it. + NOTE: I may not be able to help you much without a stack trace! + It is worth fetching and building the GNU GDB debugger (4.15) if + you don't have a good debugger on your system. If desparate try: + make perl; ./perl script; echo '$c' | adb ./perl core + +6. If the stack trace mentions XS_DynaLoader_dl_load_file then rerun + make test after setting the environment variable PERL_DL_DEBUG to 2. + +It is important to check that you are using the latest version before +posting. If you're not then I'm *very* likely to simply say "upgrade to +the latest". You would do yourself a favour by upgrading beforehand. + +Please remember that I'm _very_ busy. Try to help yourself first, +then try to help me help you by following these guidelines carefully. +And remember, please don't mail me directly - use the dbi-users +mailing list. + +Regards, +Tim. + +=============================================================================== +Examples and other info: + +README.help -- READ IT FIRST IF YOU HAVE ANY PROBLEMS AT ALL! +README.clients -- building/using DBD::Oracle on minimally configured systems +README.login -- help for login problems +README.longs -- examples dealing with LONG types (blobs) + +DBI 'home page': http://www.arcana.co.uk/technologia/DBI + +Master archive site for Perl DB information: + ftp://ftp.demon.co.uk/pub/perl/db/ +Mailing list archive: /DBI/perldb-interest/ +Perl 4 Oraperl (v2.4) /perl4/oraperl/ + +Searchable index of the dbi-users mailing list: +http://www.coe.missouri.edu/~faq/lists/dbiusers/ + +IOUW 1996 Paper on connecting Oracle to the Web: +http://www.cse.psu.edu/~groenvel/IOUW96/paper/. + +ftp://ftp.bf.rmit.edu.au/pub/Oracle/sources/... + +Jeff Stander's stuff stands out for Oraperl: +Directories of interest might be + /pub/Oracle/sources + /pub/Oracle/sources/jstander + /pub/Oracle/sources/jstander/distrib + /pub/Oracle/sources/jstander/tsmlib + /pub/Oracle/sources/jstander/wdbex + /pub/Oracle/sources/web/scripts + /pub/Oracle/sources/dba + /pub/Oracle/sources/dba/imp2sql7 + /pub/Oracle/sources/Lonnroth + /pub/Oracle/sources/harrison + +Send stuff for the archive in + [.{cpio|tar|zip}][.{gz|Z|zip}].uu + format if by mail to me (orafaq@bf.rmit.edu.au) + And drop the .uu if using ftp, putting file(s) in + ftp://ftp.bf.rmit.edu.au/incoming/Oracle + +http://www.bf.rmit.edu.au/~orafaq/perlish.html +ftp://ftp.bf.rmit.edu.au/pub/perl/db +ftp://ftp.bf.rmit.edu.au/pub/Oracle +ftp://ftp.bf.rmit.edu.au/pub/Oracle/sources +ftp://ftp.bf.rmit.edu.au/pub/Oracle/OS/MS/NT/ntoraperl.zip + +http://www.wmd.de/wmd/staff/pauck/misc/oracle_on_linux.html + +=============================================================================== +Some platforms on which the DBI and DBD::Oracle modules run: + + AIX + DEC Alpha + DEC UNIX + DG/UX + HP-UX + Linux (on platforms supported by Oracle 8) + Motorola M88100 (SVR3.2) + OSF/1 + Pyramid SMP DC/OSx + SCO + SGI IRIX + Sequent DYNIX/ptx + Solaris 1 and 2 + Unisys U6000/300 + VMS + Windows NT + and others + +(please let me know if your system is not listed). + +=============================================================================== + +See the large README.help file for lots of hints and advice about build and +runtime issues. + +End. diff --git a/README.clients b/README.clients new file mode 100644 index 00000000..38402033 --- /dev/null +++ b/README.clients @@ -0,0 +1,275 @@ +This file contains some random notes relating to minimal Oracle +configurations for building and/or using DBD::Oracle / Oraperl. + +------------------------------------------------------------------------------- +With recent versions of Oracle (specifically >= 7.3) you may be +able to build DBD::Oracle without Pro*C installed by using the Oracle +supplied oracle.mk file: + + perl Makefile.PL -m $ORACLE_HOME/rdbms/demo/oracle.mk + +(The oracle.mk file might also be found in $ORACLE_HOME/rdbms/public/) + +------------------------------------------------------------------------------- +From: James Cooper + +> [...], what do I need in addition to perl5 to access an Oracle database +> on another system from a unix box (Solaris 2.5) that doesn't have an +> oracle database running on it ? +> +> In other words are their some oracle shared objects, etc. I need ? + +I don't have experience with Solaris, but on IRIX 5.3, I simply installed +SQL*Net ($ORACLE_HOME/network/admin/*) and the OCI libraries which are in +$ORACLE_HOME/lib. You'll also need the header files from +$ORACLE_HOME/sqllib/public/*.h and $ORACLE_HOME/rdbms/demo/*.h (you won't +need them all, but you can get rid of them after DBD::Oracle compiles). + +[You'll probably need at least ocommon in addition to network. But if you +use the Oracle installer (as you always should) it'll probably install +ocommon for you.] + +So just put that stuff on your client box and install DBI and DBD::Oracle +there. Once DBD::Oracle is installed you can remove the OCI libraries and +headers (make sure to keep SQL*Net!) + +Other than that, getting it working isn't too hard. If you're not +familiar with SQL*Net, let me know. I'm no expert, but I know the basics. +The main thing is to have a good tnsnames.ora file in +$ORACLE_HOME/network/admin + +------------------------------------------------------------------------------- +From: Jon Meek + +For my compilation of DBD-Oracle/Solaris2.5/Oracle7.2.x(x=2, I think), I +just pulled the required files in the rdbms directory from the Oracle CD. +The files I needed were: + +$ ls -lR +drwxr-xr-x 2 oracle apbr 512 May 15 17:43 demo/ +drwxr-xr-x 2 oracle apbr 512 May 15 16:20 lib/ +drwxr-xr-x 2 oracle apbr 512 May 15 16:18 mesg/ +drwxr-xr-x 2 oracle apbr 512 May 15 17:38 public/ + +./demo: +-r--r--r-- 1 oracle apbr 4509 Jun 29 1995 ociapr.h +-r--r--r-- 1 oracle apbr 5187 Jun 29 1995 ocidfn.h +-rw-rw-r-- 1 oracle apbr 6659 Jun 29 1995 oratypes.h + +./lib: +-rw-r--r-- 1 oracle apbr 1132 Jul 6 1995 clntsh.mk +-rwxr-xr-x 1 oracle apbr 5623 Jul 17 1995 genclntsh.sh* +-rw-r--r-- 1 oracle apbr 15211 Jul 5 1995 oracle.mk +-rw-r--r-- 2 oracle apbr 3137 May 15 16:20 osntab.s +-rw-r--r-- 2 oracle apbr 3137 May 15 16:20 osntabst.s +-rw-r--r-- 1 oracle apbr 9 May 15 16:19 psoliblist +-rw-r--r-- 1 oracle apbr 39 May 15 16:21 sysliblist + +./mesg: +-r--r--r-- 1 oracle apbr 183296 Jul 11 1995 oraus.msb +-r--r--r-- 1 oracle apbr 878114 Jul 11 1995 oraus.msg + +./public: +-r--r--r-- 1 oracle apbr 5187 Jun 29 1995 ocidfn.h + +Jon + +------------------------------------------------------------------------------- +Jon Meek Tue, 18 Feb 1997 + +This was for Oracle 7.2.2.3.0 (client side for DBD:Oracle build) and +SQL*net v2. I have heard that sqlnet.ora might not be needed. + +ls -lR oracle +oracle: +total 2 +drwxr-xr-x 3 meekj apbr 512 Nov 3 11:46 network/ + +oracle/network: +total 2 +drwxr-xr-x 2 meekj apbr 512 Nov 3 11:46 admin/ + +oracle/network/admin: +total 6 +-rw-r--r-- 1 meekj apbr 309 Nov 3 11:46 sqlnet.ora +-rw-r--r-- 1 meekj apbr 1989 Nov 3 11:46 tnsnames.ora + +------------------------------------------------------------------------------- + +From: Lack Mr G M +Date: Thu, 23 Jan 1997 18:24:03 +0000 + + I noticed the appended in the README.clients file of the DBD-Oracle +distribution. My experience is somewhat different (and simpler). + + On Irix5.3 (ie. what this user was using) I built DBI and DBD-Oracle +on a system with Oracle and Pro*C installed. I tested it on another +system (where I knew an oracle id). I installed it from a third (which +had write rights to the master copies of the NFS mounted directories), +but this didn't have Oracle installed. + + Having done this all of my systems (even those without a hint of +oracle on them) could access remote Oracle servers by setting TWO_TASK +appropriately. SQL*Net didn't seem to come into it. + + The dynamically-loadable library created (auto/DBD/Oracle/Oracle.so) +contains no reference to any dynamic Oracle library. + + Exactly the same happened for my Solaris systems. + + From: James Cooper + > [...], what do I need in addition to perl5 to access an Oracle database + > on another system from a unix box (Solaris 2.5) that doesn't have an + > oracle database running on it ? + > + > In other words are their some oracle shared objects, etc. I need ? + +I don't have experience with Solaris, but on IRIX 5.3, I simply installed +SQL*Net ($ORACLE_HOME/network/admin/*) and the OCI libraries which are in +$ORACLE_HOME/lib. You'll also need the header files from +$ORACLE_HOME/sqllib/public/*.h and $ORACLE_HOME/rdbms/demo/*.h (you won't +need them all, but you can get rid of them after DBD::Oracle compiles). + +So just put that stuff on your client box and install DBI and DBD::Oracle +there. Once DBD::Oracle is installed you can remove the OCI libraries and +headers (make sure to keep SQL*Net!) + +------------------------------------------------------------------------------- +OS/Oracle version: Solaris 2 and Oracle 7.3 + +Problem: DBD::Oracle works on the database machine, but not from remote +machines (via TCP). SQL*Plus, however, does work from the remote machines. + +Cause: $ORACLE_HOME/ocommon/nls/admin/data/lx1boot.nlb is missing + +Solution: Make sure $ORACLE_HOME/ocommon is available on the remote machine. + +This was the first time I had used DBD::Oracle with Oracle 7.3.2. Oracle +7.1 has a somewhat different directory structure, and seems to store files +in different places relative to $ORACLE_HOME. So I just hadn't NFS +exported all the files I needed to. I figured that as long as SQL*Plus +was happy, I had all the necessary files to run DBD::Oracle (since that +was always the case with 7.1). But I was wrong. + +James Cooper + +------------------------------------------------------------------------------- +To: dbi-users@fugue.com +Subject: Re: Oracle Licencing... +Date: Thu, 15 May 1997 11:54:09 -0700 +From: Mark Dedlow + +Please forgive the continuation of this somewhat off-topic issue, +but I wanted to correct/update my previous statement, and it's +probably of interest to many DBD-Oracle users. + +> > In general, as I understand it, Oracle doesn't license the client runtime +> > libraries directly, rather they get you for SQL*NET. It is typically +> > about $100 per node. You have to have that licensed on any machine +> > that runs DBD-Oracle. + +Oracle recently changed policy. sqlnet now comes with RDBMS licenses. +If you have named RDBMS licenses, you can install sqlnet on as many +client machines as you have named licenses for the server. If you +have concurrent RDBMS licenses, you can install sqlnet on as many +client machines as you like, and only use concurrently as many +as you have concurrent server RDBMS licenses. + +OCI, Pro*C, et. al. only requires you to have a development license, +per developer. The compiled apps can be distributed unlimited. +The client where the client app resides must be licensed to use +sqlnet, by the above terms, i.e. by virtue of what the licenses on +the server are that the client is connecting to. + +This means one could legitimately distribute DBD-Oracle in compiled form. +Probably not recommended :-) + +But is does mean one can compile DBD-Oracle and distribute it internally +to your org without more licensing, as long as the targets have sqlnet. + +Obviously, this is not a legal ruling. I don't work for Oracle. +But this is what my sales rep tells me as of today. + +Mark +------------------------------------------------------------------------------- + +From: Wintermute + +Ok, you may think me daft for this but I just figured out what was +necessary in using DBI/DBD:Oracle on a machine that needs to access a +remote Oracle database. + +What the docs tell you is that you just need enough of Oracle installed +to compile it. They don't say that you need to keep that "just enough" +around for the DBI to work properly!! + +So here's my predicament so that others might benefit from my bumbling. + +I needed to install Perl, DBI, and DBD:Oracle on a machine running a +Fast Track web server (hostname Leviathan) that is to access a remote +Oracle database (henceforth called Yog-Sothoth (appropriate for the +beast that it is)). Leviathan doesn't have enough space for the 500M +install that Oracle 7 for Solaris 2.5.1 wants so I had to figure out a +way to get things done. Here's a brief list of the steps I took for +Leviathan. + +1. Got the GCC binary dist for Solaris 2.6 and installed +2. Got Perl 5.004_01 source/compiled/installed +3. Got the DBI .90 compiled/installed +4. Got DBD:Oracle... + + (and here's where it gets interesting). + + I exported the /opt/oracle7 directory from Yog-Sothoth to +Leviathan in +order to compile DBD:Oracle, then umount'ed it afterwards. Tried 'make +test' after it had compiled and watched it flounder and fail. For the +life of me I couldn't figure out why this could be so, so I went back +and adjusted my TWO_TASK/ORACLE_USERID env vars. + No luck. + Wash/Rinse/Repeat. + Still no luck. +I started to get desperate about this time, so instead of screwing with +it anymore I installed the module under the Perl heirarchy just to be +done for the moment with it (figuring that the 'make test' script could +be fallible). I neglected to mention that the errors I was getting were +coming from the Oracle database on the remote machine, so I knew it +worked in part, just not well enough to hold the connection for some +reason. + +After having no luck with my own Perl connect script I tried remounting +the nfs volume with Oracle on it and setting ORACLE_HOME to it. When I +ran that very same Perl script it WORKED! Well sort of. None of the +short connection methods worked, I was forced to use the long method of +connecting IE: name/password@dbname(DESCRIPTION=(ADDRESS=(...etc.etc. + +So here I am figuring that I'm doing something right, but there's +something I'm missing. Well it turns out that it's not me, it's the +machine that's missing it. If you are going to be using the DBD:Oracle +driver with DBI, you'll need more than just it after compile time, +you'll need some Oracle files as well. + +(BTW I'm running Oracle 7.3.2.2.0) + +You'll need everything in /var/opt/oracle (on the machine that houses +Oracle), as well as $ORACLE_HOME/ocommon/nls. Why National Language +Support is needed I'll never know. ocommon/nls has to reside under the +directory your $ORACLE_HOME points to, and it's best to leave +/var/opt/oracle/'s path alone. + +When I made these adjustments on the Oracle'less box and tried the 'make + +test' again, it ran through without a hitch. I'll be doing some more +intensive things with it from here on out and if anything changes I'll +let you all know, however this seems odd that nothing is mentioned in +the documentation about what residual files need to be around after +compiling the DBD:Oracle for it to work successfully. + +Like I said, don't flame me for being stupid, but I just had to get this +story off my chest since I've been puzzling over it all day and I feel +that other people may want to do the same thing as I did, and will run +into the same problems. + +-- Wintermute + +------------------------------------------------------------------------------- diff --git a/README.explain b/README.explain new file mode 100644 index 00000000..ca03be3e --- /dev/null +++ b/README.explain @@ -0,0 +1,193 @@ +explain +======= + +DISCLAIMER & COPYRIGHT +---------------------- + +Copyright (c) 1998 Alan Burlison + +You may distribute under the terms of either the GNU General Public License +or the Artistic License, as specified in the Perl README file, with the +exception that it cannot be placed on a CD-ROM or similar media for commercial +distribution without the prior approval of the author. + +This code is provided with no warranty of any kind, and is used entirely at +your own risk. + +This code was written by the author as a private individual, and is in no way +endorsed or warrantied by Sun Microsystems. + +WHAT IS IT? +----------- +explain is a GUI-based tool that enables easier visualisation of Oracle Query +plans. A query plan is the access path that Oracle will use to satisfy a SQL +query. The Oracle query optimiser is responsible for deciding on the optimal +path to use. Needless to say, understanding such plans requires a fairly +sophisticated knowledge of Oracle architecture and internals. + +explain allows a user to interactively edit a SQL statemant and view the +resulting query plan with the click of a single button. The effects of +modifying the SQL or of adding hints can be rapidly established. + +explain allows the user to grab all the SQL currently cached by Oracle. The SQL +capture can be filtered and sorted by different criterea, e.g. all SQL matching +a pattern, order by number of executions etc. + +explain is written using Perl, DBI/DBD::Oracle and Tk. + +PREREQUISITES +------------- +1. Oracle 7 or Oracle 8, with SQL*Net if appropriate +2. Perl 5.004_04 or later +3. DBI version 0.93 or later +4. DBD::Oracle 0.49 or later +5. Tk 800.005 or later +6. Tk-Tree 3.00401 or later + +Items 2 through 6 can be obtained from any CPAN mirror. + +INSTALLATION +------------ +1. Check you have all the prequisites installed and working. +2. Check the #! line in the script points to where your Perl interpreter is + installed. +3. Copy the "explain" script to somewhere on your path. +4. Make sure the "explain" script is executable. +5. Make sure you have run the script $ORACLE_HOME/rdbms/admin/utlxplan.sql + from a SQL*Plus session. This script creates the PLAN_TABLE that is used + by Oracle when explaining query plans. + +HOW TO USE +---------- + +Type "explain" at the shell prompt. A window will appear with a menu bar and +three frames, labelled "Query Plan", "Query Step Details" and "SQL Editor". At +the bottom of the window is a single button labelled "Explain". A login dialog +will also appear, into which you should enter the database username, password +and database instance name (SID). The parameters you enter are passed to the +DBI->connect() method, so if you have any problems refer to the DBI and +DBD::Oracle documentation. + +Optionally you may supply up to two command-line arguments. If the first +argument is of the form username/password@database, explain will use this to +log in to Oracle, otherwise if it is a filename it will be loaded into the SQL +editor. If two arguments are supplied, the second one will be assumed to be a +filename. + +Examples: + explain scott/tiger@DB query.sql + explain / query.sql (assumes OPS$ user authentication) + explain query.sql + + +Explain functionality +--------------------- + +The menu bar has one pulldown menu, "File", which allows you to login to Oracle, +Grab the contents of the Oracle SQL cache, Load SLQ from files, Save SQL to +files and to Exit the program. + +The "SQL Editor" frame allows the editing of a SQL statement. This should be +just a single statement - multiple statements are not allowed. Refer to the +documentation for the Tk text widget for a description of the editing keys +available. Text may be loaded and saved by using the "File" pulldown menu. + +Once you have entered a SQL statement, the "Explain" button at the bottom of +the window will generate the query plan for the statement. A tree +representation of the plan will appear in the "Query Plan" frame. Individual +"legs" of the plan may be expanded and collapsed by clicking on the "+' and "-" +boxes on the plan tree. The tree is drawn so that the "innermost" or "first" +query steps are indented most deeply. The connecting lines show the +"parent-child" relationships between the query steps. For a comprehensive +explanation of the meaning of query plans you should refer to the relevant +Oracle documentation. + +Single-clicking on a plan step in the Query Plan pane will display more +detailed information on that query step in the Query Step Details frame. This +information includes Oracle's estimates of cost, cardinality and bytes +returned. The exact information displayed depends on the Oracle version. +Again, for detailed information on the meaning of these fields, refer to the +Oracle documentation. + +Double-clicking on a plan step that refers to either a table or an index will +pop up a dialog box showing the definitiaon of the table or index in a format +similar to that of the SQL*Plus 'desc' command. + +Grab functionality +----------------- + +The explain window has an option on the "File" menu labelled "Grab SQL ...". +Selecting this will popup a new top-level window containing a menu bar and +three frames, labelled "SQL Cache", "SQL Statement Statistics" and "SQL +Selection Criterea". At the bottom of the window is a single button labelled +"Grab". + +The menu bar has one pulldown menu, "File", which allows you to Save the +contents of the SQL Cache frame and Close the Grab window. + +The "SQL Cache" frame shows the statements currently in the Oracle SQL cache. +Text may be saved by using the "File" pulldown menu. + +The "SQL Selection Criterea" frame allows you to specify which SQL statements +you are interested in, and how you want them sorted. The pattern used to select +statements is a normal perl regexp. Once you have defined the selection +criterea, clicking the "Grab" button will read all the matching statements from +the SQL cache and display them in the top frame. + +Single-clicking on a statement in the SQL Cache pane will display more +detailed information on that statement in the Sql Statement Statistics frame, +including the number of times the statement has been executed and the numbers +of rows processed by the statement. + +Double-clicking on a statement will copy it into the SQL editor in the Explain +window, so that the query plan for the statement can be examined. + +SUPPORT +------- + +Support questions and suggestions can be directed to Alan.Burlison@uk.sun.com + + +CHANGES +======= + +Version 0.51 beta 09/08/98 +--------------------------- + +Integrated into DBD::Oracle release 0.54. + +Version 0.5 beta 02/06/98 +-------------------------- +Changes made to work with Tk800.005. +Fixed bug with grab due to Oracle's inconsistent storage of the hash_value +column in v$sqlarea and v$sqltext_with_newlines. +Disallowed multiple concurrent login/save/open dialogs. +Fixed double-posting of login dialog on startup. +Tried to make it less Oracle version dependent. + +Version 0.4 beta 27/02/98 +-------------------------- +Grab functionality added, to allow interrogation of Oracle's SQL cache +Bind variables used wherever possible to prevent unnecessary reparses of the +SQL generated by explain +Extra error checking +Various code cleanups & restructuring +More extensive commenting of the source + +Version 0.3 beta 19/02/98 +-------------------------- +Changed to use new Tk FileSelect instead of older FileDialog. +Added facility to supply user/pass@database & SQL filename on the command-line. +Thanks to Eric Zylberstejn for the patch + suggestions. +Added check on login to Oracle for a PLAN_TABLE in the user's schema. + +Version 0.2 beta 05/02/98 +-------------------------- +Changed to work with both Oracle 7 and 8 statistics. +Pop-up table & index description dialogs added. +First public version. + +Version 0.1 beta 27/01/98 +-------------------------- +Initial version. +Not publically released. diff --git a/README.help b/README.help new file mode 100644 index 00000000..a4935314 --- /dev/null +++ b/README.help @@ -0,0 +1,335 @@ +=============================================================================== +Platform or Oracle Version specific notes, hints, tips etc: + +Note that although some of these refer to specific systems and versions the +same or similar problems may exist on other systems or versions. + +Most of this mess is due to Oracle's fondness for changing the +build/link process for OCI applications between versions. + +------------------------------------------------------------------------------- +If you get compiler errors refering to Perl's own header files +(.../CORE/*.h) then there is something wrong with your installation. +It is best to use a Perl that was built on the system you are trying to +use and it's also important to use the same compiler that was used to +build the Perl you are using. + +------------------------------------------------------------------------------- +Assorted runtime problems are caused by Oracle version mismatches: + +If you have problems then ensure that the version of Oracle you are +talking to is the same one you used to build your DBD::Oracle module. + +------------------------------------------------------------------------------- +Bad free() warnings: + +These are generally caused by problems in Oracle's own library code. +You can use this code to hide them: + + $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /^Bad free/ } + +If you're using an old perl version (below 5.004) then upgrading will +probably fix the warnings (since later versions can disable that warning) +and is highly recommended anyway. + +Alternatively you can rebuild Perl without perl's own malloc and/or +upgrade Oracle to a more recent version that doesn't have the problem. + +------------------------------------------------------------------------------- +Can't find libclntsh.so at run time: + +Dave Moellenhoff : libclntsh.so is the shared +library composed of all the other Oracle libs you used to have to +statically link. Oracle didn't start providing it until 7.2 and later. +libclntsh.so should be in $ORACLE_HOME/lib. If it's missing, try +running $ORACLE_HOME/rdbms/lib/genclntsh.sh and it should create it. + +Also: Never copy libclntsh.so to a different machine or Oracle version. +If DBD::Oracle was built on a machine with a different path to libclntsh.so +then you'll need to set set an environment variable, typically +LD_LIBRARY_PATH, to include the directory containing libclntsh.so. + +But: LD_LIBRARY_PATH is typically ignored if the script is running set-uid +(which is common in some httpd/CGI configurations). In this case +either rebuild with LD_RUN_PATH set to include the path to libclntsh +or create a symbolic link so that libclntsh is available via the same +path as it was when the module was built. (On Solaris the command +"ldd -s Oracle.so" can be used to see how the linker is searching for it.) + + +------------------------------------------------------------------------------- +Error while trying to retrieve text for error ...: + +From Lou Henefeld : We discovered that we needed +some files from the $ORACLE_HOME/ocommon/nls/admin/data directory: + lx00001.nlb, lx10001.nlb, lx1boot.nlb, lx20001.nlb +If your national language is different from ours (American English), +you will probably need different nls data files. + + +------------------------------------------------------------------------------- +ORA-01019: unable to allocate memory in the user side + +From Ethan Tuttle : My experience: ORA-01019 errors +occur when using Oracle 7.3.x shared libraries on a machine that +doesn't have all necessary Oracle files in $ORACLE_HOME. + +It used to be with 7.2 libraries that all one needed was the tnsnames.ora +file for a DBD-Oracle client to connect. Not so with 7.3.x. I'm not sure +exactly which additional files are needed on the client machine. + +Furthermore, from what I can tell, the path to ORACLE_HOME is resolved and +compiled into either libclntsh.so or the DBD-Oracle. Thus, copying a +minimal ORACLE_HOME onto a client machine won't work unless the path to +ORACLE_HOME is the same on the client machine as it is on the machine +where DBD-Oracle was compiled. + +ORA-01019 can also be caused by corrupt Oracle config files such as +/etc/oratab. + +ORA-01019 can also be caused by using a different version of the +message catalogs ($ORACLE_HOME/ocommon/nls/admin/data) to that used +when DBD::Oracle was compiled. + +Also try building with oracle.mk if your DBD::Oracle defaulted to proc.mk. + +------------------------------------------------------------------------------- +SCO - For general help enabling dynamic loding under SCO 5 + + http://www2.arkansas.net/~jcoy/perl5/ + +------------------------------------------------------------------------------- +AIX - warnings like these when building perl are not usually a problem: + +ld: 0711-415 WARNING: Symbol Perl_sighandler is already exported. +ld: 0711-319 WARNING: Exported symbol not defined: Perl_abs_amg + +When building on AIX check to make sure that all of bos.adt (13 pieces) +and all of bos.compat (11 pieces) are installed. + +Thanks to Mike Moran for this information. + +------------------------------------------------------------------------------- +AIX 4 - core dump on login and similar problems + +set + cc='xlc_r' +in config.sh. Rebuild everything, and make sure xlc_r is used everywhere. +set environment + ORACCENV='cc=xlc_r'; export ORACCENV +to enforce this in oraxlc + +Thanks to Goran Thyni for this information. + +------------------------------------------------------------------------------- +HP-UX: General + +HP's bundled C compiler is dumb. Very dumb. You're almost bound to have +problems if you use it - you'll certainly need to do a 'static link' +(see elsewhere). It is recommended that you use HP's ANSI C compiler +(which costs) or fetch and build the free GNU GCC compiler (v2.7.2.2 or later). + +Note that using shared libraries on HP-UX 10.10 (and others?) requires +patch 441647. With thanks to John Liptak . + +------------------------------------------------------------------------------- +HP-UX: Terry Greenlaw + +I traced a problem with "ld: Invalid loader fixup needed" to the file +libocic.a. On HP-UX 9 it contains position-dependant code and cannot be +used to generate dynamic load libraries. The only shared library that +Oracle ships under HP-UX is liboracle.sl which replaces libxa.a, +libsql.a, libora.a, libcvg.a, and libnlsrtl.a. The OCI stuff still +appears to only link statically under HU-UX 9.x [10.x seems okay]. + +You'll need to build DBD::Oracle statically linked into the perl binary. +See the static linking notes below. + +If you get an error like: Bad magic number for shared library: Oracle.a +You'll need to build DBD::Oracle statically linked into the perl binary. + +HP-UX 10 and Oracle 7.2.x do work together when creating dynamic libraries. +The problem was older Oracle libraries were built without the +z flag to cc, +and were therefore position-dependent libraries that can't be linked +dynamically. Newer Oracle releases don't have this problem and it may be +possible to even use the newer Oracle libraries under HP-UX 9. Oracle 7.3 +will ONLY work under HP-UX 10, however. + +HP-UX 10 and Oracle 7.3.x seem to have problems. You'll probably need +to build DBD::Oracle statically linked (see below). The problem seems +to be related to Oracle's own shared library code trying to do a +dynamic load (from lxfgno() in libnlsrtl3.a or libclntsh.sl). If you +get core dumps on login try uncommenting the /* #define signed */ line +in dbdimp.h as a long-shot. Please let me know if this fixes it for you +(but I doubt it will). + +------------------------------------------------------------------------------- +For platforms which require static linking. + +You'll need to build DBD::Oracle statically linked and then link it +into a perl binary: + + perl Makefile.PL LINKTYPE=static + make + make perl (makes a perl binary in current directory) + make test FULLPERL=./perl (run tests using the new perl binary) + make install + +You will probably need to have already built and installed a static +version of the DBI in order that it be automatically included when +you do the 'make perl' above. + +Remember that you must use this new perl binary to access Oracle. + +------------------------------------------------------------------------------- +Error: Can't find loadable object for module DBD::Oracle in @INC ... + +You probably built DBD::Oracle for static linking rather than dynamic +linking. See 'For platforms which require static linking' above for +more info. If your platform supports dynamic linking then try to work +out why DBD::Oracle got built for static linking. + +------------------------------------------------------------------------------- +Error: Syntax warnings/errors relating to 'signed' + +Remove the /* and */ surrounding the '/* #define signed */' line in dbdimp.h + +------------------------------------------------------------------------------- +ORA-00900: invalid SQL statement "begin ... end" + +You probably don't have PL/SQL Oracle properly/fully installed. + +------------------------------------------------------------------------------- +Connection/Login slow. Takes a long time and may coredump + +Oracle bug number: 227321 related to changing the environment before +connecting to oracle. Reported to be fixed in 7.1.6 (or by patch 353611). + +To work around this bug, do not set any environment variables in your +oraperl script before you call ora_login, and when you do call +ora_login, the first argument must be the empty string. This means +that you have to be sure that your environment variables ORACLE_SID +and ORACLE_HOME are set properly before you execute any oraperl +script. It is probably also possible to pass the SID to ora_login as +part of the username (for example, ora_login("", "SCOTT/TIGER@PROD", +"")), although I have not tested this. +This workaround is based on information from Kevin Stock. + +Also check $ORACLE_HOME/otrace/admin. If it contains big *.dat files +then you may have otrace enabled. Try setting EPC_DISABLED=TRUE +in the environment of the database and listener before they're started. +Oracle 7.3.2.2.0 sets this to FALSE by default, which turns on tracing +of all SQL statements, and will cause very slow connects once that +trace file gets big. You can also add (ENVS='EPC_DISABLED=TRUE') to +the SID_DESC part of listener.ora entries. (With thanks to Johan +Verbrugghen jverbrug@be.oracle.com) + +------------------------------------------------------------------------------- +Connection/Login takes a long time + +Try connect('', 'user/passwd@tnsname', ''). See README.login and item above. + +------------------------------------------------------------------------------- +Error: ORA-00604: error occurred at recursive SQL level (DBD: login failed) + +This can happen if TWO_TASK is defined but you connect using ORACLE_SID. + +------------------------------------------------------------------------------- +Error: ld: Undefined symbols _environ _dlopen _dlclose ... +Environment: SunOS 4.1.3, Oracle 7.1.6 Steve Livingston + +If you get link errors like: ld: Undefined symbols _environ _dlopen _dlclose ... +and the link command line includes '-L/usr/5lib -lc' then comment out the +'CLIBS= $(OTHERLIBS) -L/usr/5lib -lc' line in the Makefile. + +------------------------------------------------------------------------------- +Error: fatal: relocation error: symbol not found: main +Environment: Solaris, GCC + +Do not use GNU as or GNU ld on Solaris. Delete or rename them, they are +just bad news. In the words of John D Groenveld : +Run, dont walk, to your console and 'mv /opt/gnu/bin/as /opt/gnu/bin/gas; +mv /opt/gnu/bin/ld /opt/gnu/bin/gld'. You can add -v to the gcc command +in the Makefile to see what GCC is using. + +------------------------------------------------------------------------------- +Error: relocation error:symbol not found:setitimer +Environment: SVR4, stephen.zander@mckesson.com + +Error: can't load ./blib/arch/auto/DBD/Oracle/Oracle.so for module DBD::Oracle: +DynamicLinker:/usr/local/bin/perl:relocation error:symbol not found:setitimer +Fix: Try adding the '-lc' to $ORACLE_HOME/rdbms/lib/sysliblist (just +make sure it's not on a new line). + +------------------------------------------------------------------------------- +Error: Undefined symbols __cg92_used at link time. +Environment: Solaris, GCC + +Fix: If you're compiling Oracle applications with gcc on Solaris you need to +link with a file called $ORACLE_HOME/lib/__fstd.o. If you compile with the +SparcWorks compiler you need to add the command line option on -xcg92 +to resolve these symbol problems cleanly. + +Alligator Descartes + +------------------------------------------------------------------------------- +Environment: SunOS 4.1.3, Oracle 7.1.3 John Carlson + +Problem: oraperl and DBD::Oracle fail to link. Some messing around with +the library order makes the link succeed. Now I get a "Bad free()" when +ora_logoff is called. + +Solution: +In my case, this was caused by a faulty oracle install. The install grabbed +the wrong version of mergelib (The X11R6 one) instead of the one in +$ORACLE_HOME/bin. Try a more limited path and reinstall Oracle again. + +------------------------------------------------------------------------------- +Environment: SGI IRIX 6 - Mark Duffield + +Oracle only supports "-32" and "-mips2" compilation flags, not "-n32". +Configure and build perl with -32 flag (see perl hints/irix_6.sh file +in the perl distribution). +Rebuild DBI (which will now use the -32 flag). +Rebuild DBD::Oracle (which will now use the -32 flag). + +Since IRIX depends on the perl executable in /usr/sbin, you'll have to +keep it around along with the one you just built. Some care will need +to be taken to make sure that you are getting the right perl, either +through explicitly running the perl you want, or with a file header in +your perl file. The file header is probably the better solution of the two. + +In summary, until Oracle provides support for either the "-n32" or the "-64" +compiler switches, you'll have to have a perl, DBI, and DBD-Oracle which are +compiled and linked "-32". I understand that Oracle is working on a 64bit +versions of V7.3.3 for SGI (or MIPS ABI as they call it), but I don't have +any firm dates. + +------------------------------------------------------------------------------- +Environment: 64-bit platforms (DEC Alpha, OSF, SGI/IRIX64 v6.4) + +Problem: 0 ORA-00000: normal, successful completion + +Solution: Add '#define A_OSF' to Oracle.h above '#include ' and +complain to Oracle about bugs in their header files on 64 bit systems. + +------------------------------------------------------------------------------- +Link errors or test core dumps + +Try each of these in turn (follow each with a make && make test): + perl Makefile.PL -b + perl Makefile.PL -c + perl Makefile.PL -l + perl Makefile.PL -n LIBCLNTSH +let me know if this helps. + +------------------------------------------------------------------------------- +Some runtime problems might be related to perl's malloc. + +This is a long shot. If all else fails and perl -V:usemymalloc says +usemymalloc='y' then try rebuilding perl using Configure -Uusemymalloc. +If this does fix it for you then please let me know. + +=============================================================================== + +End. diff --git a/README.java b/README.java new file mode 100644 index 00000000..7ab3450f --- /dev/null +++ b/README.java @@ -0,0 +1,207 @@ +README.java + +This file relates to a specific problem on Solaris platforms +for Oracle 8.1.6 (and possibly later versions) where loading +DBD::Oracle fails with an error message like: + + ``You must install a Solaris patch to run this version of + the Java runtime. + Please see the README and release notes for more information.'' + +The problem seems to be that: + +1/ By default, the Oracle shared library contains a ``Radius + authentication module'' that is implemented in Java. +2/ The Java implementation requires that the thread library is + also linked into the application. +3/ For some inexplicable reason the thread library has to be + linked to the executable that's doing the dynamic loading. + It's is not sufficient to link -lthread to DBD::Oracle. + +There are several ways to workaround this: + +1/ Remove the Radius authentication module if you don't need it. + This requires you to perform surgery on the Oracle installation. + (If the name Radius doesn't mean anything to you and you're + the person maintaining the Oracle installation then you almost + certainly don't need it.) + +2/ Use the LD_PRELOAD environment variable to force the pre-loading + of the thread library. + +3/ Link the thread library to your perl binary. + You can do that either by (re)building perl with thread support + or, I believe, it should be possible to issue a magic 'ld' command + to add linkage to the thread library to an existing perl executable. + (But you'll need to work that one out yourself. If you do please let + me know so I can add the details here to share with others.) + +Most of this information comes from Andi Lamprecht, to whom I'm very +grateful indeed. + +I've included below two of his email messages, slightly edited, where +he explains the procedure for options 1 and 2 above. I've also +appended a slight reworking of option 1 from Paul Vallee. + +Tim. + +---- + + +From: andi@sunnix.sie.siemens.at + +Have managed it to get DBD to work with Oracle 8i without these nasty Java +error! It seems to be that a thing called "NAU" links in a radius +athentication module which is written in Java and this causes the +additional java libraries in the libclntsh.so. After throwing it all out +DBD tests ran successfully. + +The steps to take are: + + - shut down Oracle server if you have one running in the installation + you're about to modify. + - take a backup copy of your Oracle installation! You have been warned! + + - go to $ORACLE_HOME/network/lib + - rebuild nautab.o with: + + make -f ins_nau.mk NAU_ADAPTERS="IDENTIX KERBEROS5 SECURID" nautab.o + + This build a new nautab.o without the radius authentication module. + + - go to $ORACLE_HOME/lib + - edit file "ldflags" and delete all occurences of "-lnrad8" and "-ljava" + and "-[LR]$ORACLE_HOME/JRE/lib/sparc/native_threads" + + - go to $ORACLE_HOME/bin + - build a new libclntsh.so with: + + genclntsh + + - start up Oracle + + - go back to the DBD-* directory and build the Oracle driver with: + + perl Makefile.PL; make; make test + +This worked for me, the database is still operational, MAYBE SOME JAVA +STUFF ISN'T WORKING. Better someone else with more experience in java +finds out ... + +The problem seems to be a dynamic linking issue. Whenever java virtual +machine is loaded, some symbols are missing (with java 1.2.2_05 these +_thread_something symbols where not found, even with linked-in +libthread.so, with java 1.1.8 some _lseek or so symbols couldn't be +resolved). Seems Oracle did a good job in integration of Java in the +database ... + +Ok, should go out now 'cause its a beatiful wheater here in Vienna! + +Greetings +A. Lamprecht + +----------- + + +From: andi@sunnix.sie.siemens.at + +For some reason libthread.so.1 isn't included as dynamic object in perl +binary and so symbols aren't found. + +The interesting output of LD_DEBUG=symbols: +symbol=thr_getstate; dlsym() starting at file=/usr/local/bin/perl +symbol=thr_getstate; lookup in file=/usr/local/bin/perl [ ELF ] +symbol=thr_getstate; lookup in file=/lib/libsocket.so.1 [ ELF ] +symbol=thr_getstate; lookup in file=/lib/libnsl.so.1 [ ELF ] +symbol=thr_getstate; lookup in file=/lib/libdl.so.1 [ ELF ] +symbol=thr_getstate; lookup in file=/lib/libm.so.1 [ ELF ] +symbol=thr_getstate; lookup in file=/lib/libc.so.1 [ ELF ] +symbol=thr_getstate; lookup in file=/lib/libcrypt_i.so.1 [ ELF ] +symbol=thr_getstate; lookup in file=/lib/libmp.so.2 [ ELF ] +symbol=thr_getstate; lookup in file=/lib/libgen.so.1 [ ELF ] +ld.so.1: /usr/local/bin/perl: fatal: thr_getstate: can't find symbol + +This list looks exactly like the one you get when ldd-ing the perl binary. +There is an option to the dynamic linker "LD_PRELOAD" and if you set it with + + LD_PRELOAD=/lib/libthread.so.1 + export LD_PRELOAD + +before starting any DBD::oracle app, the app works! + +It looks like after libjava and libjvm is loaded, the library search path +is somehow stripped to the one of the perl binary ... + +[That looks like a Solaris bug] + +Hope this helps. + +A. Lamprecht +----------- + + +From: Paul Vallee + +Andi is right. Three cheers for Andi!!! :-) + +Final Summary (this is mostly Andi's work summarized here) + +1. Copy your ORACLE_HOME in it's entirety to a new directory. +cp -r $ORACLE_HOME $ORACLE_HOME.nojava +2. Set your ORACLE_HOME variable to the new one. Save the old one for reference. +export OLD_ORACLE_HOME=$ORACLE_HOME +export ORACLE_HOME=$ORACLE_HOME.nojava +3. cd $ORACLE_HOME/network/lib +(This is your new ORACLE_HOME - the temporary one that will soon be without +Java or Radius) +4. build nautab.o with +make -f ins_nau.mk NAU_ADAPTERS="IDENTIX KERBEROS5 SECURID" nautab.o +5. go to $ORACLE_HOME/lib +edit file "ldflags" and delete all occurences of "-lnrad8" and "-ljava" +and "-[LR]$ORACLE_HOME/JRE/lib/sparc/native_threads" +I wrote this little pipeline to do this. +sed 's/-lnrad8//g' < ldflags | \ +sed 's/-ljava//g' | \ +sed "s%-L$OLD_ORACLE_HOME/JRE/lib/sparc/native_threads%%g" | \ +sed "s%-R$OLD_ORACLE_HOME/JRE/lib/sparc/native_threads%%g" | > newldflags +If you look at newldflags, and like it, then run: +cp ldflags oldldflags; cp newldflags ldflags +6. go to $ORACLE_HOME/bin and build a new libclntsh.so with "genclntsh" +genclntsh +7. go to your DBD::oracle install directory and go through the regular +install process. +perl Makefile.PL; make; make install +(I find the make test less useful than my test.pl perl file.) +8. Set LD_LIBRARY_PATH=$ORACLE_HOME/lib. +This part is very important - remember that at this stage ORACLE_HOME is set +to the nojava home. Make this permanent by explicitly setting +LD_LIBRARY_PATH to the nojava lib directory in your .profile. +This is the step that stalled me - thanks again to Andi. +9. Test this out. I use the following, which I call test.pl, which fails +nicely if we've failed, and is very quiet if we've succeeded: +#!/usr/bin/perl +use strict; +use DBI; +use DBD::Oracle; +0; +./test.pl should have no output. Congratulations. +10. Get rid of everything other than libclntsh.so in your new ORACLE_HOME - +the rest is a waste of space. +cd $ORACLE_HOME; cd .. +mv $ORACLE_HOME $ORACLE_HOME.rmme +mkdir $ORACLE_HOME; mkdir $ORACLE_HOME/lib +cp $ORACLE_HOME.rmme/lib/libclntsh.so $ORACLE_HOME/lib +11. Run test.pl again just to be sure it still works. +12. If test.pl is still working, then we can reclaim space with +rm -fr $ORACLE_HOME.rmme + +Note that in my opinion this is a workaround - there is no reason on the +face of it that I can fathom that we shouldn't be able to use DBD::Oracle to +connect to Oracle with Java compiled in. (?) + +Enjoy, +Paul Vallee +Principal +The Pythian Group, Inc. +------------------------------------------------------------------------------ + diff --git a/README.login b/README.login new file mode 100644 index 00000000..33c2d56b --- /dev/null +++ b/README.login @@ -0,0 +1,2 @@ +This information is now in the DBD::Oracle module pod documentation. +Use the 'perldoc DBD::Oracle' command to read it. diff --git a/README.longs b/README.longs new file mode 100644 index 00000000..623440d5 --- /dev/null +++ b/README.longs @@ -0,0 +1,81 @@ +Some examples related to the use of LONG types. + +For complete working code, take a look at the t/long.t file. + +---------------------------------------------------------------------- + +You must fetch the row before you can fetch the longs associated with +that row. In other words, use the following alorithm... + + 1) login + 2) prepare( select ... ) + 3) execute + 4) while rows to fetch do + 5) fetch row + 6) repeat + 7) fetch chunk of long + 8) until have all of it + 9) done + +If your select selects more than one row the need for step 4 may +become a bit clearer... the blob_read always applies to the row +that was last fetched. + +Thanks to Jurgen Botz + +---------------------------------------------------------------------- +Example for reading LONG fields via blob_read: + + $dbh->{RaiseError} = 1; + $dbh->{LongTruncOk} = 1; # truncation on initial fetch is ok + $sth = $dbh->prepare("SELECT key, long_field FROM table_name"); + $sth->execute; + while ( ($key) = $sth->fetchrow_array) { + my $offset = 0; + my $lump = 4096; # use benchmarks to get best value for you + my @frags; + while (1) { + my $frag = $sth->blob_read(1, $offset, $lump); + last unless defined $frag; + my $len = length $frag; + last unless $len; + push @frags, $frag; + $offset += $len; + } + my $blob = join "", @frags; + print "$key: $blob\n"; + } + +With thanks to james.taylor@srs.gov and desilva@ind70.industry.net. + +---------------------------------------------------------------------- + +Example for inserting LONGS From: Andrew Berry + +# Assuming the existence of @row and an associative array (%clauses) containing the +# column names and placeholders, and an array @types containing column types ... + + $ih = $db->prepare("INSERT INTO $table ($clauses{names}) + VALUES ($clauses{places})") + || die "prepare insert into $table: " . $db->errstr; + + $attrib{'ora_type'} = $longrawtype; # $longrawtype == 24 + + ##-- bind the parameter for each of the columns + for ($i = 0; $i < @types; $i++) { + + ##-- long raw values must have their type attribute explicitly specified + if ($types[$i] == $longrawtype) { + $ih->bind_param($i+1, $row[$i], \%attrib) + || die "binding placeholder for LONG RAW " . $db->errstr; + } + ##-- other values work OK with the default attributes + else { + $ih->bind_param($i+1, $row[$i]) + || die "binding placeholder" . $db->errstr; + } + } + + $ih->execute || die "execute INSERT into $table: " . $db->errstr; + +---------------------------------------------------------------------- diff --git a/README.sec b/README.sec new file mode 100644 index 00000000..72920db6 --- /dev/null +++ b/README.sec @@ -0,0 +1,142 @@ +I have no intention of becoming a channel for Oracle Support Services +but this is a significant security hole and so I'm making an exception. + +----- Forwarded message from Oracle Support Services ----- + +Date: Fri, 7 May 1999 06:29:09 -0700 +From: Oracle Support Services +Subject: SUID Security Issue + +Platform: UNIX + +Distribution: Internal & External + +Problem Subject Line: SUID Security + +Product: Oracle Enterprise Manager 2.0.4 + Oracle Data Server + +Oracle Version: 8.0.3, 8.0.4, 8.0.5, 8.1.5 + +Component: Intelligent Agent + Oracle Data Server + +Component Version: 8.0.3, 8.0.4, 8.0.5, 8.1.5 + +Sub-Component: N/A + +Platform Version: All Unix Versions. + +Errors: N/A + +Revision Date: 6-March-1999 + +Problem Description: + +On UNIX platforms, some executable files have the setuid (SUID) +bit on. It may be possible for a knowledgeable user to use +these executables to bypass your system security by elevating +their operating system privileges. Oracle Corporation has +identified issues regarding executables with SUID set in +Oracle releases 8.0.3, 8.0.4, 8.0.5 and 8.1.5 on UNIX platforms +only. This problem will be fixed in Oracle releases 8.0.6 and +8.1.6. + +Depending on your Oracle installation, the available patch will 1) +correct the SUID bits on applicable files, and/or 2) delete the +oratclsh file. This shell script should be run immediately, and also +should be run after each relink of Oracle. + +You can download the patch from Oracle Support?s MetaLink website by +going to the following URL, +http://support.oracle.com/ml/plsql/mlv15.frame?call_type=download&javaFlag=JAVA. +Once you are in this page, select 'Oracle RDBMS' as the product +and then click on the 'Go' button. Then download patch named 'setuid.' + +Please contact Oracle Worldwide Support for any additional issues. + +----- End forwarded message ----- + +Date: Sat, 08 May 1999 19:12:52 -0700 +From: Mark Dedlow + +I went to the URL listed for the patch, but it appears you can't get to +it directly. It requires a Oracle Metalink account, and even then, you +have to follow a bunch of links to get it, you can't go direct (at +least I couldn't at the URL in the announcement). + +You don't really need the patch however, it's just a shell script that +in effect does chmod -s on everything in $ORACLE_HOME/bin except +'oracle' and 'dbsnmp' (needed only for OEM or SNMP). + +Also, although the patch didn't address the issue, make sure _nothing_ +below ORACLE_HOME is owned by root. There are some installations that +make certain files setuid to root (files that are trivial to compromise). + +Mark + + +------------------------------------------------------------------------------ + +From: Dan Sugalski +Date: Mon, 10 May 1999 09:13:28 -0700 + +The patch actually removes the setuid bit on a number of oracle +executables. The 'unset' list is: + +lsnrctl oemevent onrsd osslogin tnslsnr tnsping trcasst trcroute cmctl +cmadmin cmgw names namesctl otrccref otrcfmt otrcrep otrccol oracleO + +While the 'must set' list is: + +oracle dbsnmp + +The shell script to fix the bits properly was posted to the oracle list +running at telelists.com. Check the archives there for it if you want. +(www.telelists.com) I think it's also gone out to one of the BUGTRAQ +lists, and some of the CERTs might have it too. + + Dan + +------------------------------------------------------------------------------ + +Date: Wed, 12 May 1999 11:49:45 -0700 +From: Mark Dedlow + +> The patch actually removes the setuid bit on a number of oracle +> executables. The 'unset' list is: +> +> lsnrctl oemevent onrsd osslogin tnslsnr tnsping trcasst trcroute cmctl +> cmadmin cmgw names namesctl otrccref otrcfmt otrcrep otrccol oracleO + +Actually, there's a little more than that. For each item in that list, +it also looks for a version of the file with a 0 or O appended to it +(these are backups the link makefiles create), so the above list isn't +exactly complete. + +The important issues are simply: + + o *ONLY* $ORACLE_HOME/bin/oracle requires setuid bit set for + the Oracle RDBMS and tools to function. + + o *IF* you run dbsnmp, it must be setuid. (If you don't know what dbsnmp + is, you're probably not running it -- it's a remote monitoring/control + daemon) + +Armed with that knowledge, you can use any technique you like to achieve +the desired results. For example, this achieves it: + +find $ORACLE_HOME/bin -perm -2000 ! -name oracle ! -name dbsnmp | xargs chmod -s + +Mark + +------------------------------------------------------------------------------ + +One further note I'll pass on anonymously and without comment: + +> please include something like: "After removing the setuid bits, slap +> your system administrator for running root.sh as root without actually +> reading it first." +> :) + +------------------------------------------------------------------------------ diff --git a/README.win32 b/README.win32 new file mode 100644 index 00000000..039ef07d --- /dev/null +++ b/README.win32 @@ -0,0 +1,41 @@ +Update 10/24/97 -- Jeff Urlwin + +Tested with Oracle 8 and OCI 8. Well, not the *new* OCI api, but +using the same api as always. This version now searches for OCI +include and library files in $ORACLE_HOME\OCI80, then +$ORACLE_HOME\OCI73. It will use the first of these found. + +In order for the tests to connect successfully, I had to +set the environment variable ORACLE_USERID to +scott/tiger@mydb (where mydb is the tns name of your server) + +4/8/97 -- Jeff Urlwin + +This version requires Perl 5.003_94 or later. (It was tested with +5.003_94 and will be with 5.004). It does *NOT* work with the +(non-standard) ActiveWare port. + +Even though the Oracle libraries under Win32 (NT) do not require the +environment variable ORACLE_HOME be set for proper operation, the +Makefile.PL does. Please set the ORACLE_HOME variable to your oracle +home directory. Mine, for example, is H:\ORANT. + +The environment variable TWO_TASK is not supported under Windows. +Instead Oracle uses the settings LOCAL and REMOTE as described in +the Oracle Networking Documentation, "Oracle Network Products Getting +Started for Windows Platforms." + +This version was created and tested with the 7.3 client libraries (see +if you have an OCI73 directory). This version of the Oracle clients +have a convenient organization, including OCI73\INCLUDE, OCI73\LIB, +etc. It also has a nice samples directory to test with. Older +versions had the OCI samples under RDMBS72. This version has not been +tested (and will not currently work) with anything other than the 7.3 +versions. + +Questions should be directed towards the dbi-users mailing list. I will +try to answer them quickly there. Please put something about Win32 or +95 or NT in the subject, as I get TONS of other email and spend a fair +amount of time weeding out messages that are not relevant to what I +do. I may miss something if the subject is not clear. + diff --git a/README.wingcc b/README.wingcc new file mode 100644 index 00000000..a1a770ab --- /dev/null +++ b/README.wingcc @@ -0,0 +1,22 @@ +19-may-1999 + +added support for mingw32 and cygwin32 environments. + +Makefile.PL should find and make use of OCI include +files, but you have to build an import library for +OCI.DLL and put it somewhere in library search path. +one of the possible ways to do this is issuing command + +dlltool --input-def oci.def --output-lib liboci.a + +in the directory where you unpacked DBD::Oracle distribution +archive. this will create import library for Oracle 8.0.4. + +BUGS: + +- make clean does not make clean enough. (fixed?) + +- liboci.a must be made before running Makefile.PL + otherwise it will not be added to link list. + +- Win32::Registry access was not tested under cygwin. diff --git a/Todo b/Todo new file mode 100644 index 00000000..a9d3e219 --- /dev/null +++ b/Todo @@ -0,0 +1,48 @@ +[ In no particular order ] + +add docs about OPS$ login + +bind type 1 or 5?! + +Add hint about SQL*Plus commands if execute gets an ORA-0900 invalid SQL +statement? Maybe just if common SQL*Plus command word is first word. + +Support SERVICE_NAME in new connect syntax (allow inplace of SID) + +warn (trace_msg?) if ORACLE_HOME changes after first connect +relates to Apache::DBI scenario where changing ORACLE_HOME +upsets existing connections. + +fetchall_arrayref in C (start with XS version in DBI for all drivers?) + +PRECISION for oci7 on VARCHAR etc + +Detect "Error while trying to retrieve text for error ORA-XXXX" +and add "refer to oracle docs or use 'oerr ora XXXX'". + +blob_read for oci8 with LONGs + +connect(..., { ora_module_name => $0 }); + +bind_param(... { TYPE => SQL_* }) esp SQL_LONGVARCHAR etc + +$sth = $dbh->prepare("select ... for update"); +$dbh->commit; +$sth->execute; # fails ? auto-re-prepare? + +ora_bind() failed err = ORA-01026: multiple buffers of size > 4000 in +the bind list (DBD: oexec error) + +http://outside.organic.com/mail-archives/dbi-users/Nov1997/0116.html + +Handle PL/SQL arrays. + +Non-blocking + +Tests: +RAW types at max length + +http://www.oracle-users.com/html/freeware.html + +http://freespace.virgin.net/j.hatcher/ociwrap.htm + diff --git a/dbdimp.c b/dbdimp.c new file mode 100644 index 00000000..d4ae94e4 --- /dev/null +++ b/dbdimp.c @@ -0,0 +1,1836 @@ +/* + $Id: dbdimp.c,v 1.61 2000/07/14 21:52:08 timbo Exp $ + + Copyright (c) 1994,1995,1996,1997,1998 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file, + with the exception that it cannot be placed on a CD-ROM or similar media + for commercial distribution without the prior approval of the author. + +*/ + +#include "Oracle.h" + + +/* XXX DBI should provide a better version of this */ +#define IS_DBI_HANDLE(h) \ + (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV && \ + SvRMAGICAL(SvRV(h)) && (SvMAGIC(SvRV(h)))->mg_type == 'P') + + +DBISTATE_DECLARE; + +int ora_fetchtest; + +static int ora_login_nomsg; /* don't fetch real login errmsg if true */ +static int ora_sigchld_restart = 1; +#ifndef OCI_V8_SYNTAX +static int set_sigint_handler = 0; +#endif + +static int ora2sql_type _((int oratype)); + +void ora_free_phs_contents _((phs_t *phs)); +static void dump_env_to_trace(); + +void +dbd_init(dbistate) + dbistate_t *dbistate; +{ + char *p; + DBIS = dbistate; + dbd_init_oci(dbistate); + + if ((p=getenv("DBD_ORACLE_LOGIN_NOMSG"))) + ora_login_nomsg = atoi(p); + if ((p=getenv("DBD_ORACLE_SIGCHLD"))) + ora_sigchld_restart = atoi(p); +} + + +int +dbd_discon_all(drh, imp_drh) + SV *drh; + imp_drh_t *imp_drh; +{ + dTHR; + + /* The disconnect_all concept is flawed and needs more work */ + if (!dirty && !SvTRUE(perl_get_sv("DBI::PERL_ENDING",0))) { + sv_setiv(DBIc_ERR(imp_drh), (IV)1); + sv_setpv(DBIc_ERRSTR(imp_drh), + (char*)"disconnect_all not implemented"); + DBIh_EVENT2(drh, ERROR_event, + DBIc_ERR(imp_drh), DBIc_ERRSTR(imp_drh)); + return FALSE; + } + return FALSE; +} + + + +void +dbd_fbh_dump(fbh, i, aidx) + imp_fbh_t *fbh; + int i; + int aidx; /* array index */ +{ + FILE *fp = DBILOGFP; + fprintf(fp, " fbh %d: '%s'\t%s, ", + i, fbh->name, (fbh->nullok) ? "NULLable" : "NO null "); + fprintf(fp, "otype %3d->%3d, dbsize %ld/%ld, p%d.s%d\n", + fbh->dbtype, fbh->ftype, (long)fbh->dbsize,(long)fbh->disize, + fbh->prec, fbh->scale); + if (fbh->fb_ary) { + fprintf(fp, " out: ftype %d, bufl %d. indp %d, rlen %d, rcode %d\n", + fbh->ftype, fbh->fb_ary->bufl, fbh->fb_ary->aindp[aidx], + fbh->fb_ary->arlen[aidx], fbh->fb_ary->arcode[aidx]); + } +} + + +int +ora_dbtype_is_long(dbtype) + int dbtype; +{ + /* Is it a LONG, LONG RAW, LONG VARCHAR or LONG VARRAW type? */ + /* Return preferred type code to use if it's a long, else 0. */ + if (dbtype == 8 || dbtype == 24) /* LONG or LONG RAW */ + return dbtype; /* --> same */ + if (dbtype == 94) /* LONG VARCHAR */ + return 8; /* --> LONG */ + if (dbtype == 95) /* LONG VARRAW */ + return 24; /* --> LONG RAW */ + return 0; +} + +static int +oratype_bind_ok(dbtype) /* It's a type we support for placeholders */ + int dbtype; +{ + /* basically we support types that can be returned as strings */ + switch(dbtype) { + case 1: /* VARCHAR2 */ + case 5: /* STRING */ + case 8: /* LONG */ + case 23: /* RAW */ + case 24: /* LONG RAW */ + case 96: /* CHAR */ + case 97: /* CHARZ */ + case 106: /* MLSLABEL */ + case 102: /* SQLT_CUR OCI 7 cursor variable */ + case 112: /* SQLT_CLOB / long */ + case 113: /* SQLT_BLOB / long */ + case 116: /* SQLT_RSET OCI 8 cursor variable */ + return 1; + } + return 0; +} + + +/* --- allocate and free oracle oci 'array' buffers --- */ + +fb_ary_t * +fb_ary_alloc(bufl, size) + int bufl; + int size; +{ + fb_ary_t *fb_ary; + /* these should be reworked to only to one Newz() */ + /* and setup the pointers in the head fb_ary struct */ + Newz(42, fb_ary, sizeof(fb_ary_t), fb_ary_t); + Newz(42, fb_ary->abuf, size * bufl, ub1); + Newz(42, fb_ary->aindp, size, sb2); + Newz(42, fb_ary->arlen, size, ub2); + Newz(42, fb_ary->arcode, size, ub2); + fb_ary->bufl = bufl; + return fb_ary; +} + +void +fb_ary_free(fb_ary) + fb_ary_t *fb_ary; +{ + Safefree(fb_ary->abuf); + Safefree(fb_ary->aindp); + Safefree(fb_ary->arlen); + Safefree(fb_ary->arcode); + Safefree(fb_ary); +} + + +/* ================================================================== */ + + +int +dbd_db_login(dbh, imp_dbh, dbname, uid, pwd) + SV *dbh; imp_dbh_t *imp_dbh; char *dbname; char *uid; char *pwd; +{ + return dbd_db_login6(dbh, imp_dbh, dbname, uid, pwd, Nullsv); +} + + +int +dbd_db_login6(dbh, imp_dbh, dbname, uid, pwd, attr) + SV *dbh; + imp_dbh_t *imp_dbh; + char *dbname; + char *uid; + char *pwd; + SV *attr; +{ + dTHR; + sword status; + +#ifdef OCI_V8_SYNTAX + D_imp_drh_from_dbh; + + if (DBIS->debug >= 6 ) + dump_env_to_trace(); + + if (!imp_drh->envhp) { + /* OCI_OBJECT needed for OCIDescribeAny of table with LOBs else */ + /* you get a core dump (Not doc'd in 8.0.4). Thanks Oracle! */ + ub4 init_mode = OCI_OBJECT; + SV **init_mode_sv; + DBD_ATTRIB_GET_IV(attr, "ora_init_mode",13, init_mode_sv, init_mode); + OCIInitialize_log_stat(init_mode, 0, 0,0,0, status); + if (status != OCI_SUCCESS) { + oci_error(dbh, NULL, status, + "OCIInitialize. Check ORACLE_HOME and NLS settings etc."); + return 0; + } + OCIEnvInit_log_stat( &imp_drh->envhp, OCI_DEFAULT, 0, 0, status); + if (status != OCI_SUCCESS) { + oci_error(dbh, (OCIError*)imp_dbh->envhp, status, "OCIEnvInit"); + return 0; + } + } + imp_dbh->envhp = imp_drh->envhp; + + OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->errhp, OCI_HTYPE_ERROR, status); + OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->srvhp, OCI_HTYPE_SERVER, status); + OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->svchp, OCI_HTYPE_SVCCTX, status); + + OCIServerAttach_log_stat(imp_dbh, dbname, status); + if (status != OCI_SUCCESS) { + oci_error(dbh, imp_dbh->errhp, status, "OCIServerAttach"); + OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status); + OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status); + OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status); + return 0; + } + + OCIAttrSet_log_stat( imp_dbh->svchp, OCI_HTYPE_SVCCTX, imp_dbh->srvhp, + (ub4) 0, OCI_ATTR_SERVER, imp_dbh->errhp, status); + + OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->authp, OCI_HTYPE_SESSION, status); + + { + ub4 cred_type = ora_parse_uid(imp_dbh, &uid, &pwd); + SV **sess_mode_type_sv; + ub4 sess_mode_type = OCI_DEFAULT; + DBD_ATTRIB_GET_IV(attr, "ora_session_mode",16, sess_mode_type_sv, sess_mode_type); + OCISessionBegin_log_stat( imp_dbh->svchp, imp_dbh->errhp, imp_dbh->authp, + cred_type, sess_mode_type, status); + } + if (status != OCI_SUCCESS) { + oci_error(dbh, imp_dbh->errhp, status, "OCISessionBegin"); + OCIServerDetach_log_stat(imp_dbh->srvhp, imp_dbh->errhp, OCI_DEFAULT, status); + OCIHandleFree_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION,status); + OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status); + OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status); + OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status); + return 0; + } + + OCIAttrSet_log_stat(imp_dbh->svchp, (ub4) OCI_HTYPE_SVCCTX, + imp_dbh->authp, (ub4) 0, + (ub4) OCI_ATTR_SESSION, imp_dbh->errhp, status); + +#else + if (DBIS->debug >= 6 ) + dump_env_to_trace(); + + imp_dbh->lda = &imp_dbh->ldabuf; + imp_dbh->hda = &imp_dbh->hdabuf[0]; + /* can give duplicate free errors (from Oracle) if connect fails */ + status = orlon(imp_dbh->lda, imp_dbh->hda, (text*)uid,-1, (text*)pwd,-1,0); + + if (status) { + int rc = imp_dbh->lda->rc; + char buf[100]; + char *msg; + switch(rc) { /* add helpful hints to some errors */ + case 0: msg = "login failed, check your config, e.g. ORACLE_HOME/bin on your PATH etc"; break; + case 1019: msg = "login failed, probably a symptom of a deeper problem"; break; + default: msg = "login failed"; break; + } + if (ora_login_nomsg) { + /* oerhms in ora_error may hang or corrupt memory (!) after a connect */ + /* failure in some specific versions of Oracle 7.3.x. So we provide a */ + /* way to skip the message lookup if ora_login_nomsg is true (set via */ + /* env var above). */ + sprintf(buf, + "ORA-%05d: (Text for error %d not fetched. Use 'oerr ORA %d' command.)", + rc, rc, rc); + msg = buf; + } + ora_error(dbh, ora_login_nomsg ? NULL : imp_dbh->lda, rc, msg); + return 0; + } + + if (!set_sigint_handler) { + set_sigint_handler = 1; + /* perl's sign handler is sighandler */ + /* osnsui(??, sighandler, NULL?) */ + /* OCI8: osnsui(word *handlp, void (*astp), char * ctx) + ** osnsui: Operating System dependent Network Set User-side + ** Interrupt. Add an interrupt handling procedure astp. + ** Whenever a user interrupt(such as a ^C) occurs, call astp + ** with argument ctx. Put in *handlp handle for this + ** handler so that it may be cleared with osncui. + ** Note that there may be many handlers; each should + ** be cleared using osncui. An error code is + ** returned if an error occurs. + */ + } + +#ifdef SA_RESTART +#ifndef SIGCLD +#define SIGCLD SIGCHLD +#endif + /* If orlon has installed a handler for SIGCLD, then reinstall it */ + /* with SA_RESTART. We only do this if connected ok since I've */ + /* seen the process loop after being interrupted after connect failed. */ + if (ora_sigchld_restart) { + struct sigaction act; + if (sigaction( SIGCLD, (struct sigaction*)0, &act ) == 0 + && (act.sa_handler != SIG_DFL && act.sa_handler != SIG_IGN) + && (act.sa_flags & SA_RESTART) == 0) { + /* XXX we should also check that act.sa_handler is not the perl handler */ + act.sa_flags |= SA_RESTART; + sigaction( SIGCLD, &act, (struct sigaction*)0 ); + if (DBIS->debug >= 3) + warn("dbd_db_login: sigaction errno %d, handler %lx, flags %lx", + errno,act.sa_handler,act.sa_flags); + if (DBIS->debug >= 2) + fprintf(DBILOGFP, " dbd_db_login: set SA_RESTART on Oracle SIGCLD handler.\n"); + } + } +#endif /* HAS_SIGACTION */ + +#endif /* OCI_V8_SYNTAX */ + + DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */ + DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing */ + imp_dbh->ph_type = 1; + return 1; +} + + +int +dbd_db_commit(dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ +#ifdef OCI_V8_SYNTAX + sword status; + OCITransCommit_log_stat(imp_dbh->svchp, imp_dbh->errhp, OCI_DEFAULT, status); + if (status != OCI_SUCCESS) { + oci_error(dbh, imp_dbh->errhp, status, "OCITransCommit"); +#else + if (ocom(imp_dbh->lda)) { + ora_error(dbh, imp_dbh->lda, imp_dbh->lda->rc, "commit failed"); +#endif + return 0; + } + return 1; +} + +int +dbd_db_rollback(dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ +#ifdef OCI_V8_SYNTAX + sword status; + OCITransRollback_log_stat(imp_dbh->svchp, imp_dbh->errhp, OCI_DEFAULT, status); + if (status != OCI_SUCCESS) { + oci_error(dbh, imp_dbh->errhp, status, "OCITransRollback"); +#else + if (orol(imp_dbh->lda)) { + ora_error(dbh, imp_dbh->lda, imp_dbh->lda->rc, "rollback failed"); +#endif + return 0; + } + return 1; +} + + +int +dbd_db_disconnect(dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + dTHR; + + /* We assume that disconnect will always work */ + /* since most errors imply already disconnected. */ + DBIc_ACTIVE_off(imp_dbh); + + /* Oracle will commit on an orderly disconnect. */ + /* See DBI Driver.xst file for the DBI approach. */ + +#ifdef OCI_V8_SYNTAX + { + sword s_se, s_sd; + OCISessionEnd_log_stat(imp_dbh->svchp, imp_dbh->errhp, imp_dbh->authp, + OCI_DEFAULT, s_se); + if (s_se) oci_error(dbh, imp_dbh->errhp, s_se, "OCISessionEnd"); + OCIServerDetach_log_stat(imp_dbh->srvhp, imp_dbh->errhp, OCI_DEFAULT, s_sd); + if (s_sd) oci_error(dbh, imp_dbh->errhp, s_sd, "OCIServerDetach"); + if (s_se || s_sd) + return 0; + } +#else + if (ologof(imp_dbh->lda)) { + ora_error(dbh, imp_dbh->lda, imp_dbh->lda->rc, "disconnect error"); + return 0; + } +#endif + /* We don't free imp_dbh since a reference still exists */ + /* The DESTROY method is the only one to 'free' memory. */ + /* Note that statement objects may still exists for this dbh! */ + return 1; +} + + +void +dbd_db_destroy(dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + if (DBIc_ACTIVE(imp_dbh)) + dbd_db_disconnect(dbh, imp_dbh); +#ifdef OCI_V8_SYNTAX + { sword status; + OCIHandleFree_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION,status); + OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status); + OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status); + OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status); + } +#else + /* Nothing in imp_dbh to be freed */ +#endif + DBIc_IMPSET_off(imp_dbh); +} + + +int +dbd_db_STORE_attrib(dbh, imp_dbh, keysv, valuesv) + SV *dbh; + imp_dbh_t *imp_dbh; + SV *keysv; + SV *valuesv; +{ + STRLEN kl; + char *key = SvPV(keysv,kl); + SV *cachesv = NULL; + int on = SvTRUE(valuesv); + + if (kl==10 && strEQ(key, "AutoCommit")) { +#ifndef OCI_V8_SYNTAX + if ( (on) ? ocon(imp_dbh->lda) : ocof(imp_dbh->lda) ) { + ora_error(dbh, imp_dbh->lda, imp_dbh->lda->rc, "ocon/ocof failed"); + /* XXX um, we can't return FALSE and true isn't acurate so we croak */ + croak(SvPV(DBIc_ERRSTR(imp_dbh),na)); + } +#endif /* OCI V8 handles this as OCIExecuteStmt */ + DBIc_set(imp_dbh,DBIcf_AutoCommit, on); + } + else if (kl==12 && strEQ(key, "RowCacheSize")) { + imp_dbh->RowCacheSize = SvIV(valuesv); + } + else if (kl==11 && strEQ(key, "ora_ph_type")) { + if (SvIV(valuesv)!=1 && SvIV(valuesv)!=5 && SvIV(valuesv)!=96 && SvIV(valuesv)!=97) + croak("ora_ph_type must be 1 (VARCHAR2), 5 (STRING), 96 (CHAR), or 97 (CHARZ)"); + imp_dbh->ph_type = SvIV(valuesv); + } + else { + return FALSE; + } + if (cachesv) /* cache value for later DBI 'quick' fetch? */ + hv_store((HV*)SvRV(dbh), key, kl, cachesv, 0); + return TRUE; +} + + +SV * +dbd_db_FETCH_attrib(dbh, imp_dbh, keysv) + SV *dbh; + imp_dbh_t *imp_dbh; + SV *keysv; +{ + STRLEN kl; + char *key = SvPV(keysv,kl); + SV *retsv = Nullsv; + /* Default to caching results for DBI dispatch quick_FETCH */ + int cacheit = FALSE; + + /* AutoCommit FETCH via DBI */ + + if (kl==10 && strEQ(key, "AutoCommit")) { + retsv = boolSV(DBIc_has(imp_dbh,DBIcf_AutoCommit)); + } + else if (kl==12 && strEQ(key, "RowCacheSize")) { + retsv = newSViv(imp_dbh->RowCacheSize); + } + else if (kl==11 && strEQ(key, "ora_ph_type")) { + retsv = newSViv(imp_dbh->ph_type); + } + if (!retsv) + return Nullsv; + if (cacheit) { /* cache for next time (via DBI quick_FETCH) */ + SV **svp = hv_fetch((HV*)SvRV(dbh), key, kl, 1); + sv_free(*svp); + *svp = retsv; + (void)SvREFCNT_inc(retsv); /* so sv_2mortal won't free it */ + } + if (retsv == &sv_yes || retsv == &sv_no) + return retsv; /* no need to mortalize yes or no */ + return sv_2mortal(retsv); +} + + + +/* ================================================================== */ + + + +void +dbd_preparse(imp_sth, statement) + imp_sth_t *imp_sth; + char *statement; +{ + D_imp_dbh_from_sth; + bool in_literal = FALSE; + char in_comment = '\0'; + char *src, *start, *dest; + phs_t phs_tpl; + SV *phs_sv; + int idx=0; + char *style="", *laststyle=Nullch; + STRLEN namelen; + + /* allocate room for copy of statement with spare capacity */ + /* for editing '?' or ':1' into ':p1' so we can use obndrv. */ + imp_sth->statement = (char*)safemalloc(strlen(statement) * 3); + + /* initialise phs ready to be cloned per placeholder */ + memset(&phs_tpl, 0, sizeof(phs_tpl)); + phs_tpl.imp_sth = imp_sth; + phs_tpl.ftype = imp_dbh->ph_type; + phs_tpl.maxlen_bound = -1; /* not yet bound */ + + src = statement; + dest = imp_sth->statement; + while(*src) { + + if (in_comment) { + /* 981028-jdl on mocha. Adding all code which deals with */ + /* in_comment variable (its declaration plus 2 code blocks). */ + /* Text appearing within comments should be scanned for neither */ + /* placeholders nor for single quotes (which toggle the in_literal */ + /* boolean). Comments like "3:00" demonstrate the former problem, */ + /* and contractions like "don't" demonstrate the latter problem. */ + /* The comment style is stored in in_comment; each style is */ + /* terminated in a different way. */ + if (in_comment == '-' && *src == '\n') { + in_comment = '\0'; + } + else if (in_comment == '/' && *src == '*' && *(src+1) == '/') { + *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */ + in_comment = '\0'; + } + *dest++ = *src++; + continue; + } + + if (in_literal) { + if (*src == in_literal) + in_literal = 0; + *dest++ = *src++; + continue; + } + + /* Look for comments: '-- oracle-style' or C-style */ + if ((*src == '-' && *(src+1) == '-') || + (*src == '/' && *(src+1) == '*')) + { + in_comment = *src; + /* We know *src & the next char are to be copied, so do */ + /* it. In the case of C-style comments, it happens to */ + /* help us avoid slash-asterisk-slash oddities. */ + *dest++ = *src++; + *dest++ = *src++; + continue; + } + + if (*src != ':' && *src != '?') { + + if (*src == '\'' || *src == '"') + in_literal = *src; + + *dest++ = *src++; + continue; + } + + /* only here for : or ? outside of a comment or literal */ + + start = dest; /* save name inc colon */ + *dest++ = *src++; + if (*start == '?') { /* X/Open standard */ + sprintf(start,":p%d", ++idx); /* '?' -> ':p1' (etc) */ + dest = start+strlen(start); + style = "?"; + + } else if (isDIGIT(*src)) { /* ':1' */ + idx = atoi(src); + *dest++ = 'p'; /* ':1'->':p1' */ + if (idx <= 0) + croak("Placeholder :%d invalid, placeholders must be >= 1", idx); + while(isDIGIT(*src)) + *dest++ = *src++; + style = ":1"; + + } else if (isALNUM(*src)) { /* ':foo' */ + while(isALNUM(*src)) /* includes '_' */ + *dest++ = *src++; + style = ":foo"; + } else { /* perhaps ':=' PL/SQL construct */ + continue; + } + *dest = '\0'; /* handy for debugging */ + namelen = (dest-start); + if (laststyle && style != laststyle) + croak("Can't mix placeholder styles (%s/%s)",style,laststyle); + laststyle = style; + if (imp_sth->all_params_hv == NULL) + imp_sth->all_params_hv = newHV(); + phs_tpl.sv = &sv_undef; + phs_sv = newSVpv((char*)&phs_tpl, sizeof(phs_tpl)+namelen+1); + hv_store(imp_sth->all_params_hv, start, namelen, phs_sv, 0); + strcpy( ((phs_t*)(void*)SvPVX(phs_sv))->name, start); + } + *dest = '\0'; + if (imp_sth->all_params_hv) { + DBIc_NUM_PARAMS(imp_sth) = (int)HvKEYS(imp_sth->all_params_hv); + if (DBIS->debug >= 2) + fprintf(DBILOGFP, " dbd_preparse scanned %d distinct placeholders\n", + (int)DBIc_NUM_PARAMS(imp_sth)); + } +} + + +int +calc_cache_rows(num_fields, est_width, cache_rows, has_longs) + int num_fields, est_width, cache_rows, has_longs; +{ + /* Use guessed average on-the-wire row width calculated above */ + /* and add in overhead of 5 bytes per field plus 8 bytes per row. */ + /* The n*5+8 was determined by studying SQL*Net v2 packets. */ + /* It could probably benefit from a more detailed analysis. */ + est_width += num_fields*5 + 8; + + if (has_longs) /* override/disable caching */ + cache_rows = 1; /* else read_blob can't work */ + + else if (cache_rows < 1) { /* automatically size the cache */ + int txfr_size; + /* 0 == try to pick 'optimal' cache for this query (default) */ + /* <0 == base cache on target transfer size of -n bytes. */ + if (cache_rows == 0) { + /* Oracle packets on ethernet have max size of around 1460. */ + /* We'll aim to fill our row cache with around 10 per go. */ + /* Using 10 means any 'runt' packets will have less impact. */ + txfr_size = 10 * 1460; /* default transfer/cache size */ + } + else { /* user is specifying desired transfer size in bytes */ + txfr_size = -cache_rows; + } + cache_rows = txfr_size / est_width; /* maybe 1 or 0 */ + /* To ensure good performance with large rows (near or larger */ + /* than our target transfer size) we set a minimum cache size. */ + if (cache_rows < 6) /* is cache a 'useful' size? */ + cache_rows = (cache_rows>0) ? 6 : 4; + } + if (cache_rows > 32767) /* keep within Oracle's limits */ + cache_rows = 32767; + + return cache_rows; +} + + +static int +ora_sql_type(imp_sth, name, sql_type) + imp_sth_t *imp_sth; + char *name; + int sql_type; +{ + /* XXX should detect DBI reserved standard type range here */ + + switch (sql_type) { + case SQL_NUMERIC: + case SQL_DECIMAL: + case SQL_INTEGER: + case SQL_BIGINT: + case SQL_TINYINT: + case SQL_SMALLINT: + case SQL_FLOAT: + case SQL_REAL: + case SQL_DOUBLE: + case SQL_VARCHAR: + return 1; /* Oracle VARCHAR2 */ + + case SQL_CHAR: + return 96; /* Oracle CHAR */ + + case SQL_BINARY: + case SQL_VARBINARY: + return 23; /* Oracle RAW */ + + case SQL_LONGVARBINARY: + return 24; /* Oracle LONG RAW */ + + case SQL_LONGVARCHAR: + return 8; /* Oracle LONG */ + + case SQL_DATE: + case SQL_TIME: + case SQL_TIMESTAMP: + default: + if (imp_sth && DBIc_WARN(imp_sth) && name) + warn("SQL type %d for '%s' is not fully supported, bound as SQL_VARCHAR instead", + sql_type, name); + return ora_sql_type(imp_sth, name, SQL_VARCHAR); + } +} + + + +static int +dbd_rebind_ph_char(sth, imp_sth, phs, alen_ptr_ptr) + SV *sth; + imp_sth_t *imp_sth; + phs_t *phs; + ub2 **alen_ptr_ptr; +{ + STRLEN value_len; + +/* for inserting longs: */ +/* sv_insert +4 */ +/* sv_chop(phs->sv, SvPV(phs->sv,na)+4); XXX */ + + /* convert to a string ASAP */ + if (!SvPOK(phs->sv) && SvOK(phs->sv)) + sv_2pv(phs->sv, &na); + + if (DBIS->debug >= 2) { + char *val = neatsvpv(phs->sv,0); + fprintf(DBILOGFP, " bind %s <== %.1000s (", phs->name, val); + if (SvOK(phs->sv)) + fprintf(DBILOGFP, "size %ld/%ld/%ld, ", + (long)SvCUR(phs->sv),(long)SvLEN(phs->sv),phs->maxlen); + else fprintf(DBILOGFP, "NULL, "); + fprintf(DBILOGFP, "ptype %d, otype %d%s)\n", + (int)SvTYPE(phs->sv), phs->ftype, + (phs->is_inout) ? ", inout" : ""); + } + + /* At the moment we always do sv_setsv() and rebind. */ + /* Later we may optimise this so that more often we can */ + /* just copy the value & length over and not rebind. */ + + if (phs->is_inout) { /* XXX */ + if (SvREADONLY(phs->sv)) + croak(no_modify); + if (imp_sth->ora_pad_empty) + croak("Can't use ora_pad_empty with bind_param_inout"); + /* phs->sv _is_ the real live variable, it may 'mutate' later */ + /* pre-upgrade high to reduce risk of SvPVX realloc/move */ + (void)SvUPGRADE(phs->sv, SVt_PVNV); + /* ensure room for result, 28 is magic number (see sv_2pv) */ + SvGROW(phs->sv, ((phs->maxlen < 28) ? 28 : phs->maxlen)+1/*for null*/); + } + else { + /* phs->sv is copy of real variable, upgrade to at least string */ + (void)SvUPGRADE(phs->sv, SVt_PV); + } + + /* At this point phs->sv must be at least a PV with a valid buffer, */ + /* even if it's undef (null) */ + /* Here we set phs->progv, phs->indp, and value_len. */ + if (SvOK(phs->sv)) { + phs->progv = SvPV(phs->sv, value_len); + phs->indp = 0; + } + else { /* it's null but point to buffer incase it's an out var */ + phs->progv = SvPVX(phs->sv); /* can be NULL (undef) */ + phs->indp = -1; + value_len = 0; + } + if (imp_sth->ora_pad_empty && value_len==0) { + sv_setpv(phs->sv, " "); + phs->progv = SvPV(phs->sv, value_len); + } + phs->sv_type = SvTYPE(phs->sv); /* part of mutation check */ + phs->maxlen = SvLEN(phs->sv)-1; /* avail buffer space */ + if (phs->maxlen < 0) /* can happen with nulls */ + phs->maxlen = 0; + +#ifdef OCI_V8_SYNTAX + phs->alen = value_len + phs->alen_incnull; +#else + if (value_len + phs->alen_incnull <= UB2MAXVAL) { + phs->alen = value_len + phs->alen_incnull; + *alen_ptr_ptr = &phs->alen; + if (((IV)phs->alen) > phs->maxlen && phs->indp != -1) + croak("panic: dbd_rebind_ph alen %ld > maxlen %ld (incnul %d)", + phs->alen,phs->maxlen, phs->alen_incnull); + } + else { + phs->alen = 0; + *alen_ptr_ptr = NULL; /* Can't use alen for long LONGs (>64k) */ + if (phs->is_inout) + croak("Can't bind LONG values (>%ld) as in/out parameters", (long)UB2MAXVAL); + } +#endif + + if (DBIS->debug >= 3) { + fprintf(DBILOGFP, " bind %s <== '%.*s' (size %ld/%ld, otype %d, indp %d)\n", + phs->name, + (int)(phs->alen>SvIV(DBIS->neatsvpvlen) ? SvIV(DBIS->neatsvpvlen) : phs->alen), + (phs->progv) ? phs->progv : "", + (long)phs->alen, (long)phs->maxlen, phs->ftype, phs->indp); + } + + return 1; +} + + +#ifdef OCI_V8_SYNTAX +#ifndef MM_CURSOR_FIX +/* + * Rebind an "in" cursor ref to its real statement handle + * This allows passing cursor refs as "in" to pl/sql (but only if you got the + * cursor from pl/sql to begin with) + */ +int +pp_rebind_ph_rset_in(SV *sth, imp_sth_t *imp_sth, phs_t *phs) +{ + /*dTHR; -- do we need to do this??? */ + SV * sth_csr = phs->sv; + D_impdata(imp_sth_csr, imp_sth_t, sth_csr); + sword status; + + if (dbis->debug >= 3) + fprintf(DBILOGFP, " pp_rebind_ph_rset_in: BEGIN\n calling OCIBindByName(stmhp=%p, bndhp=%p, errhp=%p, name=%s, csrstmhp=%p, ftype=%d)\n", imp_sth->stmhp, phs->bndhp, imp_sth->errhp, phs->name, imp_sth_csr->stmhp, phs->ftype); + + OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp, + (text*)phs->name, strlen(phs->name), + &imp_sth_csr->stmhp, + 0, + phs->ftype, 0, + NULL, + 0, 0, + NULL, + OCI_DEFAULT, + status + ); + if (dbis->debug >= 3) + fprintf(DBILOGFP, " after OCIBindByName, status=%d\n", status); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCIBindByName SQLT_RSET"); + return 0; + } + if (dbis->debug >= 3) + fprintf(DBILOGFP, " pp_rebind_ph_rset_in: END\n"); + return 2; +} +#endif +#endif + + +int +pp_exec_rset(SV *sth, imp_sth_t *imp_sth, phs_t *phs, int pre_exec) +{ + if (pre_exec) { /* pre-execute - allocate a statement handle */ + dSP; + D_imp_dbh_from_sth; + SV *sth_i; + HV *init_attr = newHV(); + int count; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " bind %s - allocating new sth...\n", phs->name); +#ifdef OCI_V8_SYNTAX + { + sword status; + if (!phs->desc_h || 1) { /* XXX phs->desc_t != OCI_HTYPE_STMT) { */ + if (phs->desc_h) { + OCIHandleFree_log_stat(phs->desc_h, phs->desc_t, status); + phs->desc_h = NULL; + } + phs->desc_t = OCI_HTYPE_STMT; + OCIHandleAlloc_ok(imp_sth->envhp, &phs->desc_h, phs->desc_t, status); + } + phs->progv = (void*)&phs->desc_h; + phs->maxlen = 0; + OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp, + (text*)phs->name, strlen(phs->name), + phs->progv, 0, + phs->ftype, 0, /* using &phs->indp triggers ORA-01001 errors! */ + NULL, 0, 0, NULL, OCI_DEFAULT, status); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCIBindByName SQLT_RSET"); + return 0; + } + } +#else + { + Cda_Def *cda; + assert(phs->ftype == 102); /* SQLT_CUR */ + Newz(0, cda, 1, Cda_Def); + if (oopen(cda, imp_dbh->lda, (text*)0, -1, -1, (text*)0, -1)) { + ora_error(sth, cda, cda->rc, "oopen error for cursor"); + Safefree(cda); + return 0; + } + if (obndra(imp_sth->cda, (text *)phs->name, -1, + (ub1*)cda, (sword)-1, /* cast reduces max size */ + (sword)phs->ftype, -1, 0, 0, &phs->arcode, 0, (ub4 *)0, (text *)0, -1, -1) + ) { + D_imp_dbh_from_sth; + ora_error(sth, imp_dbh->lda, imp_sth->cda->rc, "obndra failed for cursor"); + Safefree(cda); + return 0; + } + phs->progv = (void*)cda; + phs->maxlen = -1; + } +#endif + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv_2mortal(newRV(DBIc_MY_H(imp_dbh)))); + XPUSHs(sv_2mortal(newRV((SV*)init_attr))); + PUTBACK; + count = perl_call_pv("DBI::_new_sth", G_ARRAY); + SPAGAIN; + if (count != 2) + croak("panic: DBI::_new_sth returned %d values instead of 2", count); + sth_i = POPs; /* discard inner handle */ + sv_setsv(phs->sv, POPs); /* save outer handle */ + SvREFCNT_dec(init_attr); + PUTBACK; + FREETMPS; + LEAVE; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " bind %s - allocated %s...\n", + phs->name, neatsvpv(phs->sv, 0)); + + } + else { /* post-execute - setup the statement handle */ + dTHR; + SV * sth_csr = phs->sv; + D_impdata(imp_sth_csr, imp_sth_t, sth_csr); + + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " bind %s - initialising new %s for cursor 0x%lx...\n", + phs->name, neatsvpv(sth_csr,0), (unsigned long)phs->progv); + +#ifdef OCI_V8_SYNTAX + /* copy appropriate handles from parent statement */ + imp_sth_csr->envhp = imp_sth->envhp; + imp_sth_csr->errhp = imp_sth->errhp; + imp_sth_csr->srvhp = imp_sth->srvhp; + imp_sth_csr->svchp = imp_sth->svchp; + + /* assign statement handle from placeholder descriptor */ + imp_sth_csr->stmhp = phs->desc_h; + phs->desc_h = NULL; /* tell phs that we own it now */ + + /* force stmt_type since OCIAttrGet(OCI_ATTR_STMT_TYPE) doesn't work! */ + imp_sth_csr->stmt_type = OCI_STMT_SELECT; +#else + + imp_sth_csr->cda = (void*)phs->progv; + imp_sth_csr->cda->ft = 4; /* persuade dbd_describe it's a SELECT */ + phs->progv = NULL; /* tell phs that we own it now */ + +#endif + + DBIc_IMPSET_on(imp_sth_csr); + + /* set ACTIVE so dbd_describe doesn't do explicit OCI describe */ + DBIc_ACTIVE_on(imp_sth_csr); + if (!dbd_describe(sth_csr, imp_sth_csr)) { + return 0; + } +#ifndef OCI_V8_SYNTAX + imp_sth_csr->cda->rpc= 0; /* nothing already fetched into cache */ +#endif + } + return 1; +} + + +#ifndef OCI_V8_SYNTAX +static int +dbd_rebind_ph_cursor(sth, imp_sth, phs) + SV *sth; + imp_sth_t *imp_sth; + phs_t *phs; +{ + assert(phs->ftype == 102); + phs->out_prepost_exec = pp_exec_rset; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " bind %s to cursor (at execute)\n", phs->name); + return 2; +} +#endif + + + + +static int +dbd_rebind_ph(sth, imp_sth, phs) + SV *sth; + imp_sth_t *imp_sth; + phs_t *phs; +{ + ub2 *alen_ptr = NULL; + int done = 0; + + switch (phs->ftype) { +#ifdef OCI_V8_SYNTAX + case SQLT_CLOB: + case SQLT_BLOB: + done = dbd_rebind_ph_lob(sth, imp_sth, phs); + break; + case SQLT_RSET: + done = dbd_rebind_ph_rset(sth, imp_sth, phs); + break; +#else + case 102: /* SQLT_CUR */ + done = dbd_rebind_ph_cursor(sth, imp_sth, phs); + break; +#endif + default: + done = dbd_rebind_ph_char(sth, imp_sth, phs, &alen_ptr); + } + if (done != 1) { + if (done == 2) { /* the rebind did the OCI bind call itself successfully */ + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " bind %s done for ftype %d\n", + phs->name, phs->ftype); + return 1; + } + return 0; /* the rebind failed */ + } + +#ifdef OCI_V8_SYNTAX + if (phs->maxlen > phs->maxlen_bound) { + sword status; + int at_exec = (phs->desc_h == NULL); + OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp, + (text*)phs->name, strlen(phs->name), + phs->progv, + phs->maxlen ? (sb4)phs->maxlen : 1, /* else bind "" fails */ + phs->ftype, &phs->indp, + NULL, /* ub2 *alen_ptr not needed with OCIBindDynamic */ + &phs->arcode, + 0, /* max elements that can fit in allocated array */ + NULL, /* (ptr to) current number of elements in array */ + at_exec ? OCI_DATA_AT_EXEC : OCI_DEFAULT, + status + ); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCIBindByName"); + return 0; + } + if (at_exec) { + OCIBindDynamic_log(phs->bndhp, imp_sth->errhp, (dvoid *)phs, dbd_phs_in, + (dvoid *)phs, dbd_phs_out, status); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCIBindByName"); + return 0; + } + } + } + +#else + /* Since we don't support LONG VAR types we must check */ + /* for lengths too big to pass to obndrv as an sword. */ + if (phs->maxlen > MINSWORDMAXVAL && sizeof(sword)<4) /* generally 32K */ + croak("Can't bind %s, value is too long (%ld bytes, max %d)", + phs->name, phs->maxlen, MINSWORDMAXVAL); + + if (obndra(imp_sth->cda, (text *)phs->name, -1, + (ub1*)phs->progv, (sword)phs->maxlen, /* cast reduces max size */ + (sword)phs->ftype, -1, + &phs->indp, alen_ptr, &phs->arcode, 0, (ub4 *)0, + (text *)0, -1, -1)) { + D_imp_dbh_from_sth; + ora_error(sth, imp_dbh->lda, imp_sth->cda->rc, "obndra failed"); + return 0; + } +#endif + phs->maxlen_bound = phs->maxlen ? phs->maxlen : 1; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " bind %s done\n", phs->name); + return 1; +} + + +int +dbd_bind_ph(sth, imp_sth, ph_namesv, newvalue, sql_type, attribs, is_inout, maxlen) + SV *sth; + imp_sth_t *imp_sth; + SV *ph_namesv; + SV *newvalue; + IV sql_type; + SV *attribs; + int is_inout; + IV maxlen; +{ + D_imp_dbh_from_sth; + SV **phs_svp; + STRLEN name_len; + char *name = Nullch; + char namebuf[30]; + phs_t *phs; + + /* check if placeholder was passed as a number */ + + if (SvGMAGICAL(ph_namesv)) /* eg if from tainted expression */ + mg_get(ph_namesv); + if (!SvNIOKp(ph_namesv)) { + name = SvPV(ph_namesv, name_len); + } + if (SvNIOKp(ph_namesv) || (name && isDIGIT(name[0]))) { + sprintf(namebuf, ":p%d", (int)SvIV(ph_namesv)); + name = namebuf; + name_len = strlen(name); + } + assert(name != Nullch); + + if (SvTYPE(newvalue) > SVt_PVLV) /* hook for later array logic */ + croak("Can't bind a non-scalar value (%s)", neatsvpv(newvalue,0)); + if (SvROK(newvalue) && !IS_DBI_HANDLE(newvalue)) + /* dbi handle allowed for cursor variables */ + croak("Can't bind a reference (%s)", neatsvpv(newvalue,0)); + if (SvTYPE(newvalue) == SVt_PVLV && is_inout) /* may allow later */ + croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)"); + + if (DBIS->debug >= 2) { + fprintf(DBILOGFP, " bind %s <== %s (type %ld", + name, neatsvpv(newvalue,0), (long)sql_type); + if (is_inout) + fprintf(DBILOGFP, ", inout 0x%lx, maxlen %ld", + (long)newvalue, (long)maxlen); + if (attribs) + fprintf(DBILOGFP, ", attribs: %s", neatsvpv(attribs,0)); + fprintf(DBILOGFP, ")\n"); + } + + phs_svp = hv_fetch(imp_sth->all_params_hv, name, name_len, 0); + if (phs_svp == NULL) + croak("Can't bind unknown placeholder '%s' (%s)", name, neatsvpv(ph_namesv,0)); + phs = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */ + + if (phs->sv == &sv_undef) { /* first bind for this placeholder */ + phs->ftype = imp_dbh->ph_type; + phs->is_inout = is_inout; + if (is_inout) { + /* phs->sv assigned in the code below */ + ++imp_sth->has_inout_params; + /* build array of phs's so we can deal with out vars fast */ + if (!imp_sth->out_params_av) + imp_sth->out_params_av = newAV(); + av_push(imp_sth->out_params_av, SvREFCNT_inc(*phs_svp)); + } + + if (attribs) { /* only look for ora_type on first bind of var */ + SV **svp; + /* Setup / Clear attributes as defined by attribs. */ + /* XXX If attribs is EMPTY then reset attribs to default? */ + if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_type",8, 0)) != NULL) { + int ora_type = SvIV(*svp); + if (!oratype_bind_ok(ora_type)) + croak("Can't bind %s, ora_type %d not supported by DBD::Oracle", + phs->name, ora_type); + if (sql_type) + croak("Can't specify both TYPE (%d) and ora_type (%d) for %s", + sql_type, ora_type, phs->name); + phs->ftype = ora_type; + } + if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_field",9, 0)) != NULL) { + phs->ora_field = SvREFCNT_inc(*svp); + } + } + if (sql_type) + phs->ftype = ora_sql_type(imp_sth, phs->name, sql_type); + +#ifndef OCI_V8_SYNTAX + /* treat Oracle8 LOBS as simple LONGs for Oracle7 */ + if (phs->ftype==112 || phs->ftype==113) + phs->ftype = 8; + /* treat Oracle8 SQLT_RSET as SQLT_CUR for Oracle7 */ + if (phs->ftype==116) + phs->ftype = 102; +#else + /* treat Oracle7 SQLT_CUR as SQLT_RSET for Oracle8 */ + if (phs->ftype==102) + phs->ftype = 116; +#endif + + /* some types require the trailing null included in the length. */ + phs->alen_incnull = (phs->ftype==SQLT_STR || phs->ftype==SQLT_AVC); + + } /* was first bind for this placeholder */ + + /* check later rebinds for any changes */ + else if (is_inout != phs->is_inout) { + croak("Can't rebind or change param %s in/out mode after first bind (%d => %d)", + phs->name, phs->is_inout , is_inout); + } + else if (sql_type && phs->ftype != ora_sql_type(imp_sth, phs->name, sql_type)) { + croak("Can't change TYPE of param %s to %d after initial bind", + phs->name, sql_type); + } + + phs->maxlen = maxlen; /* 0 if not inout */ + + if (!is_inout) { /* normal bind to take a (new) copy of current value */ + if (phs->sv == &sv_undef) /* (first time bind) */ + phs->sv = newSV(0); + sv_setsv(phs->sv, newvalue); + } + else if (newvalue != phs->sv) { + if (phs->sv) + SvREFCNT_dec(phs->sv); + phs->sv = SvREFCNT_inc(newvalue); /* point to live var */ + } + + return dbd_rebind_ph(sth, imp_sth, phs); +} + + +int +dbd_st_execute(sth, imp_sth) /* <= -2:error, >=0:ok row count, (-1=unknown count) */ + SV *sth; + imp_sth_t *imp_sth; +{ + dTHR; + ub4 row_count = 0; + int debug = DBIS->debug; + int outparams = (imp_sth->out_params_av) ? AvFILL(imp_sth->out_params_av)+1 : 0; + +#ifdef OCI_V8_SYNTAX + D_imp_dbh_from_sth; + sword status; + int is_select = (imp_sth->stmt_type == OCI_STMT_SELECT); + + if (debug >= 2) + fprintf(DBILOGFP, " dbd_st_execute %s (out%d, lob%d)...\n", + oci_stmt_type_name(imp_sth->stmt_type), outparams, imp_sth->has_lobs); +#else + + if (!imp_sth->done_desc) { + /* describe and allocate storage for results (if any needed) */ + if (!dbd_describe(sth, imp_sth)) + return -2; /* dbd_describe already called ora_error() */ + } + if (debug >= 2) + fprintf(DBILOGFP, + " dbd_st_execute (for sql f%d after oci f%d, out%d)...\n", + imp_sth->cda->ft, imp_sth->cda->fc, outparams); +#endif + + if (outparams) { /* check validity of bind_param_inout SV's */ + int i = outparams; + while(--i >= 0) { + phs_t *phs = (phs_t*)(void*)SvPVX(AvARRAY(imp_sth->out_params_av)[i]); + /* Make sure we have the value in string format. Typically a number */ + /* will be converted back into a string using the same bound buffer */ + /* so the progv test below will not trip. */ + + /* is the value a null? */ + phs->indp = (SvOK(phs->sv)) ? 0 : -1; + + /* Some checks for mutated storage since we pointed oracle at it. */ + if (phs->out_prepost_exec) { + if (!phs->out_prepost_exec(sth, imp_sth, phs, 1)) + return -2; /* out_prepost_exec already called ora_error() */ + } + else + if (SvTYPE(phs->sv) != phs->sv_type + || (SvOK(phs->sv) && !SvPOK(phs->sv)) + /* SvROK==!SvPOK so cursor (SQLT_CUR) handle will call dbd_rebind_ph */ + /* that suits us for now */ + || SvPVX(phs->sv) != phs->progv + || (SvPOK(phs->sv) && SvCUR(phs->sv) > UB2MAXVAL) + ) { + if (!dbd_rebind_ph(sth, imp_sth, phs)) + croak("Can't rebind placeholder %s", phs->name); + } + else { + /* String may have grown or shrunk since it was bound */ + /* so tell Oracle about it's current length */ + phs->alen = SvCUR(phs->sv) + phs->alen_incnull; + if (debug >= 2) + fprintf(DBILOGFP, + " with %s = '%.*s' (len %ld/%ld, indp %d, otype %d, ptype %d)\n", + phs->name, (int)phs->alen, + (phs->indp == -1) ? "" : SvPVX(phs->sv), + (long)phs->alen, (long)phs->maxlen, phs->indp, + phs->ftype, (int)SvTYPE(phs->sv)); + } + } + } + +#ifdef OCI_V8_SYNTAX + + OCIStmtExecute_log_stat(imp_sth->svchp, imp_sth->stmhp, imp_sth->errhp, + (is_select) ? 0 : 1, + 0, 0, 0, + /* we don't AutoCommit on select so LOB locators work */ + (DBIc_has(imp_dbh,DBIcf_AutoCommit) && !is_select) + ? OCI_COMMIT_ON_SUCCESS : OCI_DEFAULT, + status); + if (status != OCI_SUCCESS && status != OCI_SUCCESS_WITH_INFO) { + oci_error(sth, imp_sth->errhp, status, + ora_sql_error(imp_sth,"OCIStmtExecute")); + return -2; + } + if (is_select) { + DBIc_ACTIVE_on(imp_sth); + DBIc_ROW_COUNT(imp_sth) = 0; /* reset (possibly re-exec'ing) */ + row_count = 0; + } + else { + OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status); + } + + if (debug >= 2) { + ub2 sqlfncode; + OCIAttrGet_stmhp_stat(imp_sth, &sqlfncode, 0, OCI_ATTR_SQLFNCODE, status); + fprintf(DBILOGFP, + " dbd_st_execute %s returned (%s, rpc%ld, fn%d, out%d)\n", + oci_stmt_type_name(imp_sth->stmt_type), + oci_status_name(status), + (long)row_count, sqlfncode, imp_sth->has_inout_params); + } + + if (is_select && !imp_sth->done_desc) { + /* describe and allocate storage for results (if any needed) */ + if (!dbd_describe(sth, imp_sth)) + return -2; /* dbd_describe already called oci_error() */ + } + if (imp_sth->has_lobs && imp_sth->stmt_type != OCI_STMT_SELECT) { + if (!post_execute_lobs(sth, imp_sth, row_count)) + return -2; /* post_insert_lobs already called oci_error() */ + } + +#else + + /* reset cache counters */ + imp_sth->in_cache = 0; + imp_sth->next_entry = 0; + imp_sth->eod_errno = 0; + + /* Trigger execution of the statement */ + if (DBIc_NUM_FIELDS(imp_sth) > 0) { /* is a SELECT */ + /* The number of fields is used because imp_sth->cda->ft is unreliable. */ + /* Specifically an update (5) may change to select (4) after odesc(). */ + if (oexfet(imp_sth->cda, (ub4)imp_sth->cache_rows, 0, 0) + && imp_sth->cda->rc != 1403 /* other than no more data */ ) { + char * hint = "oexfet error"; + if (imp_sth->cda->rc == 932) /* inconsistent data types */ + hint = "oexfet error, e.g., can't select LOB fields using DBD::Oracle built for Oracle 7"; + ora_error(sth, imp_sth->cda, imp_sth->cda->rc, hint); + return -2; + } + DBIc_ACTIVE_on(imp_sth); + imp_sth->in_cache = imp_sth->cda->rpc; /* cache loaded */ + if (imp_sth->cda->rc == 1403) + imp_sth->eod_errno = 1403; + } + else { /* NOT a select */ + if (oexec(imp_sth->cda)) { + char *msg = "oexec error"; + switch(imp_sth->cda->rc) { + case 3108: + msg = "perhaps you're using Oracle 8 functionality but this DBD::Oracle was built for Oracle 7"; + break; + } + ora_error(sth, imp_sth->cda, imp_sth->cda->rc, msg); + return -2; + } + } + row_count = imp_sth->cda->rpc; + + if (debug >= 2) + fprintf(DBILOGFP, + " dbd_st_execute complete (rc%d, w%02x, rpc%ld, eod%d, out%d)\n", + imp_sth->cda->rc, imp_sth->cda->wrn, + row_count, imp_sth->eod_errno, + imp_sth->has_inout_params); +#endif + + if (outparams) { /* check validity of bound output SV's */ + int i = outparams; + while(--i >= 0) { + phs_t *phs = (phs_t*)(void*)SvPVX(AvARRAY(imp_sth->out_params_av)[i]); + SV *sv = phs->sv; + + if (phs->out_prepost_exec) { + if (!phs->out_prepost_exec(sth, imp_sth, phs, 0)) + return -2; /* out_prepost_exec already called ora_error() */ + } + else + /* phs->alen has been updated by Oracle to hold the length of the result */ + if (phs->indp == 0) { /* is okay */ + SvPOK_only(sv); + SvCUR(sv) = phs->alen; + *SvEND(sv) = '\0'; + if (debug >= 2) + fprintf(DBILOGFP, + " out %s = '%s'\t(len %ld, arcode %d)\n", + phs->name, SvPV(sv,na), (long)phs->alen, phs->arcode); + } + else + if (phs->indp > 0 || phs->indp == -2) { /* truncated */ + SvPOK_only(sv); + SvCUR(sv) = phs->alen; + *SvEND(sv) = '\0'; + if (debug >= 2) + fprintf(DBILOGFP, + " out %s = '%s'\t(TRUNCATED from %d to %ld, arcode %d)\n", + phs->name, SvPV(sv,na), phs->indp, (long)phs->alen, phs->arcode); + } + else + if (phs->indp == -1) { /* is NULL */ + (void)SvOK_off(phs->sv); + if (debug >= 2) + fprintf(DBILOGFP, + " out %s = undef (NULL, arcode %d)\n", + phs->name, phs->arcode); + } + else croak("panic: %s bad indp %d, arcode %d", + phs->name, phs->indp, phs->arcode); + } + } + + return row_count; /* row count (0 will be returned as "0E0") */ +} + + + + +int +dbd_st_blob_read(sth, imp_sth, field, offset, len, destrv, destoffset) + SV *sth; + imp_sth_t *imp_sth; + int field; + long offset; + long len; + SV *destrv; + long destoffset; +{ + ub4 retl = 0; + SV *bufsv; + imp_fbh_t *fbh = &imp_sth->fbh[field]; + int ftype = fbh->ftype; + + bufsv = SvRV(destrv); + sv_setpvn(bufsv,"",0); /* ensure it's writable string */ + SvGROW(bufsv, destoffset+len+1); /* SvGROW doesn't do +1 */ + +#ifdef OCI_V8_SYNTAX + retl = ora_blob_read_piece(sth, imp_sth, fbh, bufsv, + offset, len, destoffset); + if (!SvOK(bufsv)) /* ora_blob_read_piece recorded error */ + return 0; + ftype = ftype; /* no unused */ + +#else + + if (len > 65535) { + warn("Oracle OCI7 doesn't allow blob_read to reliably fetch chunks longer than 65535 bytes"); + len = 65535; + } + + switch (fbh->ftype) { + case 94: ftype = 8; break; + case 95: ftype = 24; break; + } + + /* The +1 on field was a mistake that's too late to fix :-( */ + if (oflng(imp_sth->cda, (sword)field+1, + ((ub1*)SvPVX(bufsv)) + destoffset, len, + ftype, &retl, offset)) { + ora_error(sth, imp_sth->cda, imp_sth->cda->rc, "oflng error"); + /* XXX database may have altered the buffer contents */ + return 0; + } +#endif + + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " blob_read field %d+1, ftype %d, offset %ld, len %ld, destoffset %ld, retlen %ld\n", + field, imp_sth->fbh[field].ftype, offset, len, destoffset, retl); + + SvCUR_set(bufsv, destoffset+retl); + + *SvEND(bufsv) = '\0'; /* consistent with perl sv_setpvn etc */ + + return 1; +} + + +int +dbd_st_rows(sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ +#ifdef OCI_V8_SYNTAX + ub4 row_count = 0; + sword status; + OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCIAttrGet OCI_ATTR_ROW_COUNT"); + return -1; + } + return row_count; +#else + /* spot common mistake of checking $h->rows just after ->execute */ + if ( imp_sth->in_cache > 0 /* has unfetched rows */ + && imp_sth->in_cache== imp_sth->cda->rpc /* NO rows fetched yet */ + && DBIc_WARN(imp_sth) /* provide a way to disable warning */ + ) { + warn("$h->rows count is incomplete before all rows fetched.\n"); + } + /* imp_sth->in_cache should always be 0 for non-select statements */ + return imp_sth->cda->rpc - imp_sth->in_cache; /* fetched rows */ +#endif +} + + +int +dbd_st_finish(sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + dTHR; + D_imp_dbh_from_sth; + + if (!DBIc_ACTIVE(imp_sth)) + return 1; + + /* Cancel further fetches from this cursor. */ + /* We don't close the cursor till DESTROY (dbd_st_destroy). */ + /* The application may re execute(...) it. */ + + /* Turn off ACTIVE here regardless of errors below. */ + DBIc_ACTIVE_off(imp_sth); + + if (imp_sth->disable_finish) /* see ref cursors */ + return 1; + + if (!DBIc_ACTIVE(imp_dbh)) /* no longer connected */ + return 1; + + if (dirty) /* don't walk on the wild side */ + return 1; + +#ifdef OCI_V8_SYNTAX +{ sword status; + OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 0, OCI_FETCH_NEXT, + OCI_DEFAULT, status); + if (status != OCI_SUCCESS && status != OCI_SUCCESS_WITH_INFO) { + oci_error(sth, imp_sth->errhp, status, "Finish OCIStmtFetch"); + return 0; + } +} +#else + if (ocan(imp_sth->cda)) { + /* oracle 7.3 code can core dump looking up an error message */ + /* if we have logged out of the database. This typically */ + /* happens during global destruction. This should catch most: */ + if (dirty && imp_sth->cda->rc == 3114) + ora_error(sth, NULL, imp_sth->cda->rc, + "ORA-03114: not connected to ORACLE (ocan)"); + else + ora_error(sth, imp_sth->cda, imp_sth->cda->rc, "ocan error"); + return 0; + } +#endif + return 1; +} + + +void +ora_free_fbh_contents(fbh) + imp_fbh_t *fbh; +{ + if (fbh->fb_ary) + fb_ary_free(fbh->fb_ary); + sv_free(fbh->name_sv); +#ifdef OCI_V8_SYNTAX + if (fbh->desc_h) + OCIDescriptorFree_log(fbh->desc_h, fbh->desc_t); +#endif +} + +void +ora_free_phs_contents(phs) + phs_t *phs; +{ +#ifdef OCI_V8_SYNTAX + if (phs->desc_h) + OCIDescriptorFree_log(phs->desc_h, phs->desc_t); +#else + if (phs->ftype == 102 && phs->progv) { /* SQLT_CUR */ + /* should not normally happen since new child sth takes */ + /* ownership of the cursor and sets phs->progv to NULL. */ + oclose((Cda_Def*)phs->progv); + Safefree(phs->progv); + phs->progv = NULL; + } +#endif + sv_free(phs->ora_field); + sv_free(phs->sv); +} + + +void +dbd_st_destroy(sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + D_imp_dbh_from_sth; + int fields; + int i; + +#ifdef OCI_V8_SYNTAX + { + sword status; + if (imp_sth->lob_refetch) + ora_free_lob_refetch(sth, imp_sth); + OCIHandleFree_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, status); + if (status != OCI_SUCCESS) + oci_error(sth, imp_sth->errhp, status, "OCIHandleFree"); + } +#else + oclose(imp_sth->cda); /* ignore error ? */ + if (imp_sth->cda != &imp_sth->cdabuf) { + /* we assume that the cda was allocated for a ref cursor */ + /* bound to a placeholder on a different statement. */ + /* We own the cda buffer now so we need to free it. */ + Safefree(imp_sth->cda); + } + imp_sth->cda = NULL; +#endif + + /* Free off contents of imp_sth */ + + fields = DBIc_NUM_FIELDS(imp_sth); + imp_sth->in_cache = 0; + imp_sth->eod_errno = 1403; + for(i=0; i < fields; ++i) { + imp_fbh_t *fbh = &imp_sth->fbh[i]; + ora_free_fbh_contents(fbh); + } + Safefree(imp_sth->fbh); + Safefree(imp_sth->statement); + + if (imp_sth->out_params_av) + sv_free((SV*)imp_sth->out_params_av); + + if (imp_sth->all_params_hv) { + HV *hv = imp_sth->all_params_hv; + SV *sv; + char *key; + I32 retlen; + hv_iterinit(hv); + while( (sv = hv_iternextsv(hv, &key, &retlen)) != NULL ) { + if (sv != &sv_undef) { + phs_t *phs = (phs_t*)(void*)SvPVX(sv); + ora_free_phs_contents(phs); + } + } + sv_free((SV*)imp_sth->all_params_hv); + } + + DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ +} + + +int +dbd_st_STORE_attrib(sth, imp_sth, keysv, valuesv) + SV *sth; + imp_sth_t *imp_sth; + SV *keysv; + SV *valuesv; +{ + STRLEN kl; + SV *cachesv = NULL; + char *key = SvPV(keysv,kl); +/* + int on = SvTRUE(valuesv); + int oraperl = DBIc_COMPAT(imp_sth); */ + + if (strEQ(key, "ora_fetchtest")) { + ora_fetchtest = SvIV(valuesv); + } + else + return FALSE; + + if (cachesv) /* cache value for later DBI 'quick' fetch? */ + hv_store((HV*)SvRV(sth), key, kl, cachesv, 0); + return TRUE; +} + + +SV * +dbd_st_FETCH_attrib(sth, imp_sth, keysv) + SV *sth; + imp_sth_t *imp_sth; + SV *keysv; +{ + STRLEN kl; + char *key = SvPV(keysv,kl); + int i; + SV *retsv = NULL; + /* Default to caching results for DBI dispatch quick_FETCH */ + int cacheit = TRUE; + /* int oraperl = DBIc_COMPAT(imp_sth); */ + + if (kl==13 && strEQ(key, "NUM_OF_PARAMS")) /* handled by DBI */ + return Nullsv; + + if (!imp_sth->done_desc && !dbd_describe(sth, imp_sth)) { + STRLEN lna; + /* dbd_describe has already called ora_error() */ + /* we can't return Nullsv here because the xs code will */ + /* then just pass the attribute name to DBI for FETCH. */ + croak("Describe failed during %s->FETCH(%s): %ld: %s", + SvPV(sth,na), key, (long)SvIV(DBIc_ERR(imp_sth)), + SvPV(DBIc_ERRSTR(imp_sth),lna) + ); + } + + i = DBIc_NUM_FIELDS(imp_sth); + + if (kl==11 && strEQ(key, "ora_lengths")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) + av_store(av, i, newSViv((IV)imp_sth->fbh[i].disize)); + + } else if (kl==9 && strEQ(key, "ora_types")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) + av_store(av, i, newSViv(imp_sth->fbh[i].dbtype)); + + } else if (kl==4 && strEQ(key, "TYPE")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) + av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh[i].dbtype))); + + } else if (kl==5 && strEQ(key, "SCALE")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) + av_store(av, i, newSViv(imp_sth->fbh[i].scale)); + + } else if (kl==9 && strEQ(key, "PRECISION")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) + av_store(av, i, newSViv(imp_sth->fbh[i].prec)); + +#ifndef OCI_V8_SYNTAX +#ifdef XXXXX + } else if (kl==9 && strEQ(key, "ora_rowid")) { + /* return current _binary_ ROWID (oratype 11) uncached */ + /* Use { ora_type => 11 } when binding to a placeholder */ + retsv = newSVpv((char*)&imp_sth->cda->rid, sizeof(imp_sth->cda->rid)); + cacheit = FALSE; +#endif +#endif + + } else if (kl==17 && strEQ(key, "ora_est_row_width")) { + retsv = newSViv(imp_sth->est_width); + cacheit = TRUE; + + } else if (kl==4 && strEQ(key, "NAME")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) + av_store(av, i, newSVpv((char*)imp_sth->fbh[i].name,0)); + + } else if (kl==8 && strEQ(key, "NULLABLE")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) + av_store(av, i, boolSV(imp_sth->fbh[i].nullok)); + + } else { + return Nullsv; + } + if (cacheit) { /* cache for next time (via DBI quick_FETCH) */ + SV **svp = hv_fetch((HV*)SvRV(sth), key, kl, 1); + sv_free(*svp); + *svp = retsv; + (void)SvREFCNT_inc(retsv); /* so sv_2mortal won't free it */ + } + return sv_2mortal(retsv); +} + +/* --------------------------------------- */ + +static int +ora2sql_type(oratype) + int oratype; +{ + switch(oratype) { /* oracle Internal (not external) types */ + case SQLT_CHR: return SQL_VARCHAR; + case SQLT_NUM: return SQL_DECIMAL; + case SQLT_LNG: return SQL_LONGVARCHAR; /* long */ + case SQLT_DAT: return SQL_DATE; + case SQLT_BIN: return SQL_BINARY; /* raw */ + case SQLT_LBI: return SQL_LONGVARBINARY; /* long raw */ + case SQLT_AFC: return SQL_CHAR; /* Ansi fixed char */ + } + /* else map type into DBI reserved standard range */ + return -9000 - oratype; +} + +static void +dump_env_to_trace() { + FILE *fp = DBILOGFP; + int i = 0; + char *p; + extern char **environ; + fprintf(fp, "Environment variables:\n"); + do { + p = (char*)environ[i++]; + fprintf(fp,"\t%s\n",p); + } while ((char*)environ[i] != '\0'); +} diff --git a/dbdimp.h b/dbdimp.h new file mode 100644 index 00000000..2e102113 --- /dev/null +++ b/dbdimp.h @@ -0,0 +1,303 @@ +/* + $Id: dbdimp.h,v 1.37 2000/07/11 22:14:20 timbo Exp $ + + Copyright (c) 1994,1995,1996,1997,1998,1999 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file, + with the exception that it cannot be placed on a CD-ROM or similar media + for commercial distribution without the prior approval of the author. + +*/ + + +#if defined(get_no_modify) && !defined(no_modify) +#define no_modify PL_no_modify +#endif + + +/* ====== Include Oracle Header Files ====== */ + +#ifndef CAN_PROTOTYPE +#define signed /* Oracle headers use signed */ +#endif + +/* The following define avoids a problem with Oracle >=7.3 where + * ociapr.h has the line: + * sword obindps(struct cda_def *cursor, ub1 opcode, text *sqlvar, ... + * In some compilers that clashes with perls 'opcode' enum definition. + */ +#define opcode opcode_redefined + +/* Hack to fix broken Oracle oratypes.h on OSF Alpha. Sigh. */ +#if defined(__osf__) && defined(__alpha) +#ifndef A_OSF +#define A_OSF +#endif +#endif + +/* egcs-1.1.2 does not have _int64 */ +#if defined(__MINGW32__) || defined(__CYGWIN32__) +#define _int64 long long +#endif + + +/* This is slightly backwards because we want to auto-detect OCI8 */ +/* and thus the existance of oci.h while still working for Oracle7 */ +#include +#include + +#if defined(SQLT_NTY) && !defined(NO_OCI8) /* === use Oracle 8 === */ + +/* ori.h uses 'dirty' as an arg name in prototypes so we use this */ +/* hack to prevent ori.h being read (since we don't need it) */ +#define ORI_ORACLE + +#include + +#else /* === use Oracle 7 === */ + +#ifdef CAN_PROTOTYPE +# include +#else +# include +#endif + +#ifndef HDA_SIZE +#define HDA_SIZE 512 +#endif + +#endif /* === ------------ === */ + +/* ------ end of Oracle include files ------ */ + + + +/* ====== define data types ====== */ + +typedef struct imp_fbh_st imp_fbh_t; + + +struct imp_drh_st { + dbih_drc_t com; /* MUST be first element in structure */ +#ifdef OCI_V8_SYNTAX + OCIEnv *envhp; +#endif +}; + + +/* Define dbh implementor data structure */ +struct imp_dbh_st { + dbih_dbc_t com; /* MUST be first element in structure */ + +#ifdef OCI_V8_SYNTAX + OCIEnv *envhp; /* copy of drh pointer */ + OCIError *errhp; + OCIServer *srvhp; + OCISvcCtx *svchp; + OCISession *authp; +#else + Lda_Def ldabuf; + Lda_Def *lda; /* points to ldabuf */ + ub1 hdabuf[HDA_SIZE]; + ub1 *hda; /* points to hdabuf */ +#endif + + int RowCacheSize; + int ph_type; /* default oratype for placeholders */ +}; + + +typedef struct lob_refetch_st lob_refetch_t; + +/* Define sth implementor data structure */ +struct imp_sth_st { + dbih_stc_t com; /* MUST be first element in structure */ + +#ifdef OCI_V8_SYNTAX + OCIEnv *envhp; /* copy of dbh pointer */ + OCIError *errhp; /* copy of dbh pointer */ + OCIServer *srvhp; /* copy of dbh pointer */ + OCISvcCtx *svchp; /* copy of dbh pointer */ + OCIStmt *stmhp; + ub2 stmt_type; /* OCIAttrGet OCI_ATTR_STMT_TYPE */ + U16 auto_lob; + int has_lobs; + lob_refetch_t *lob_refetch; +#else + Cda_Def *cda; /* normally just points to cdabuf below */ + Cda_Def cdabuf; +#endif + int disable_finish; /* fetched cursors can core dump in finish */ + + /* Input Details */ + char *statement; /* sql (see sth_scan) */ + HV *all_params_hv; /* all params, keyed by name */ + AV *out_params_av; /* quick access to inout params */ + int ora_pad_empty; /* convert ""->" " when binding */ + + /* Select Column Output Details */ + int done_desc; /* have we described this sth yet ? */ + imp_fbh_t *fbh; /* array of imp_fbh_t structs */ + char *fbh_cbuf; /* memory for all field names */ + int t_dbsize; /* raw data width of a row */ + IV long_readlen; /* local copy to handle oraperl */ + + /* Select Row Cache Details */ + int cache_rows; + int in_cache; + int next_entry; + int eod_errno; + int est_width; /* est'd avg row width on-the-wire */ + + /* (In/)Out Parameter Details */ + bool has_inout_params; +}; +#define IMP_STH_EXECUTING 0x0001 + + +typedef struct fb_ary_st fb_ary_t; /* field buffer array */ +struct fb_ary_st { /* field buffer array EXPERIMENTAL */ + ub2 bufl; /* length of data buffer */ + sb2 *aindp; /* null/trunc indicator variable */ + ub1 *abuf; /* data buffer (points to sv data) */ + ub2 *arlen; /* length of returned data */ + ub2 *arcode; /* field level error status */ +}; + +struct imp_fbh_st { /* field buffer EXPERIMENTAL */ + imp_sth_t *imp_sth; /* 'parent' statement */ + int field_num; /* 0..n-1 */ + + /* Oracle's description of the field */ +#ifdef OCI_V8_SYNTAX + OCIParam *parmdp; + OCIDefine *defnp; + void *desc_h; /* descriptor if needed (LOBs etc) */ + ub4 desc_t; /* OCI type of descriptorh */ + int (*fetch_func) _((SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV *dest_sv)); + ub2 dbsize; + ub2 dbtype; /* actual type of field (see ftype) */ + ub2 prec; /* XXX docs say ub1 but ub2 is needed */ + sb1 scale; + ub1 nullok; + void *special; /* hook for special purposes (LOBs etc) */ +#else + sb4 dbsize; + sb2 dbtype; /* actual type of field (see ftype) */ + sb2 prec; + sb2 scale; + sb2 nullok; + sb4 cbufl; /* length of select-list item 'name' */ +#endif + SV *name_sv; /* only set for OCI8 */ + char *name; + sb4 disize; /* max display/buffer size */ + + /* Our storage space for the field data as it's fetched */ + sword ftype; /* external datatype we wish to get */ + fb_ary_t *fb_ary; /* field buffer array */ +}; + + +typedef struct phs_st phs_t; /* scalar placeholder */ + +struct phs_st { /* scalar placeholder EXPERIMENTAL */ + imp_sth_t *imp_sth; /* 'parent' statement */ + sword ftype; /* external OCI field type */ + + SV *sv; /* the scalar holding the value */ + int sv_type; /* original sv type at time of bind */ + bool is_inout; + + IV maxlen; /* max possible len (=allocated buffer) */ + sb4 maxlen_bound; /* and Oracle bind has been called */ + +#ifdef OCI_V8_SYNTAX + OCIBind *bndhp; + void *desc_h; /* descriptor if needed (LOBs etc) */ + ub4 desc_t; /* OCI type of desc_h */ + ub4 alen; +#else + ub2 alen; /* effective length ( <= maxlen ) */ +#endif + ub2 arcode; + + sb2 indp; /* null indicator */ + char *progv; + + int (*out_prepost_exec)_((SV *, imp_sth_t *, phs_t *, int pre_exec)); + SV *ora_field; /* from attribute (for LOB binds) */ + int alen_incnull; /* 0 or 1 if alen should include null */ + char name[1]; /* struct is malloc'd bigger as needed */ +}; + + +/* ------ define functions and external variables ------ */ + +extern int ora_fetchtest; + +void dbd_init_oci _((dbistate_t *dbistate)); +void dbd_preparse _((imp_sth_t *imp_sth, char *statement)); +void dbd_fbh_dump _((imp_fbh_t *fbh, int i, int aidx)); +void ora_free_fbh_contents _((imp_fbh_t *fbh)); +int ora_dbtype_is_long _((int dbtype)); +int calc_cache_rows _((int num_fields, int est_width, int cache_rows, int has_longs)); +fb_ary_t *fb_ary_alloc _((int bufl, int size)); +int ora_db_reauthenticate _((SV *dbh, imp_dbh_t *imp_dbh, char *uid, char *pwd)); + +#define OTYPE_IS_LONG(t) ((t)==8 || (t)==24 || (t)==94 || (t)==95) + +#ifdef OCI_V8_SYNTAX + +int oci_error _((SV *h, OCIError *errhp, sword status, char *what)); +char *oci_stmt_type_name _((int stmt_type)); +char *oci_status_name _((sword status)); +int dbd_rebind_ph_lob _((SV *sth, imp_sth_t *imp_sth, phs_t *phs)); +void ora_free_lob_refetch _((SV *sth, imp_sth_t *imp_sth)); +int post_execute_lobs _((SV *sth, imp_sth_t *imp_sth, ub4 row_count)); +ub4 ora_parse_uid _((imp_dbh_t *imp_dbh, char **uidp, char **pwdp)); +char *ora_sql_error _((imp_sth_t *imp_sth, char *msg)); + +sb4 dbd_phs_in _((dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index, + dvoid **bufpp, ub4 *alenp, ub1 *piecep, dvoid **indpp)); +sb4 dbd_phs_out _((dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index, + dvoid **bufpp, ub4 **alenpp, ub1 *piecep, + dvoid **indpp, ub2 **rcodepp)); +int dbd_rebind_ph_rset _((SV *sth, imp_sth_t *imp_sth, phs_t *phs)); + +#else /* is OCI 7 */ + +void ora_error _((SV *h, Lda_Def *lda, int rc, char *what)); + +#endif /* OCI_V8_SYNTAX */ + +#include "ocitrace.h" + + + +/* These defines avoid name clashes for multiple statically linked DBD's */ + +#define dbd_init ora_init +#define dbd_db_login ora_db_login +#define dbd_db_login6 ora_db_login6 +#define dbd_db_do ora_db_do +#define dbd_db_commit ora_db_commit +#define dbd_db_rollback ora_db_rollback +#define dbd_db_disconnect ora_db_disconnect +#define dbd_db_destroy ora_db_destroy +#define dbd_db_STORE_attrib ora_db_STORE_attrib +#define dbd_db_FETCH_attrib ora_db_FETCH_attrib +#define dbd_st_prepare ora_st_prepare +#define dbd_st_rows ora_st_rows +#define dbd_st_execute ora_st_execute +#define dbd_st_fetch ora_st_fetch +#define dbd_st_finish ora_st_finish +#define dbd_st_destroy ora_st_destroy +#define dbd_st_blob_read ora_st_blob_read +#define dbd_st_STORE_attrib ora_st_STORE_attrib +#define dbd_st_FETCH_attrib ora_st_FETCH_attrib +#define dbd_describe ora_describe +#define dbd_bind_ph ora_bind_ph + +/* end */ diff --git a/hints/svr4.pl b/hints/svr4.pl new file mode 100644 index 00000000..28d9ea91 --- /dev/null +++ b/hints/svr4.pl @@ -0,0 +1,126 @@ +my $archname = $Config::Config{archname} || die; +$att{LIBS} ||= []; +$att{LIBS}->[0] ||= ''; + +# Some SVR4 systems may need to link against -lc to pick up things like +# fpsetmask, sys_nerr and ecvt. +my @libs = qw(-lsocket -lnsl -lm -ldl); # general svr4 default + +# modified by Davide Migliavacca +if ($archname eq 'RM400-svr4') { + @libs = qw(-lucb); +} + +push @libs, '-lc'; + +warn "$^O LIBS attribute defaulted to '$att{LIBS}->[0]' for '$archname'"; +$att{LIBS}->[0] .= " ".join(" ", @libs); # append libs +warn "$^O LIBS attribute updated to '$att{LIBS}->[0]'"; + + +__END__ + +From doughera@lafcol.lafayette.edu Mon Aug 21 07:01:51 1995 +Date: Fri, 18 Aug 1995 15:33:22 -0400 (EDT) +From: Andy Dougherty +Subject: Re: [MM] Re: hints file for Oracle +To: Tim Bunce +In-Reply-To: <9508181853.ab12333@post.demon.co.uk> +Mime-Version: 1.0 +Content-Type: TEXT/PLAIN; charset=US-ASCII + +On Fri, 18 Aug 1995, Tim Bunce wrote: +> > From: Alan Burlison +> > +> > Tim, +> > +> > The following hints file is required for DBD::Oracle on svr4, you might +> > like to add it to the next release :-) +> > +> > File: Oracle/hints/svr4.pl +> > +> > # Some SVR4 systems may need to link against -lc to pick up things like +> > $att{LIBS} = [ '-lsocket -lnsl -lm -ldl -lc' ]; +> +> Umm, 'some', 'may', 'things like'. Care to clarify? +> +> Why _exactly_ is this needed, and why doesn't MakeMaker do this already? +> (CC'd to the MakeMaker mailing list.) + +That looks like a bad editing of the ODBM_File/hints/svr4.pl: + +########################## hints/svr4.pl ######################### +# Some SVR4 systems may need to link against routines in -lucb for +# odbm. Some may also need to link against -lc to pick up things like +# ecvt. +$att{LIBS} = ['-ldbm -lucb -lc']; +################################################################### + +"Some" includes Unisys 6000 (or something like that). I don't know +if it includes anything else. It doesn't include Unixware 2.1, but it +might include Esix. It's *really* hard to get accurate info. + +"May" because some do and some don't, and any listing gets out of date +quickly as vendors issue different versions, and probably more than +half the info you *do* get about specific versions is wrong. Hence all +the vague weasel-words. + +"Things like" is ecvt() for Unisys (for ODBM_File). Since some linkers +only report the first missing symbol, it's sometimes hard (and +sometimes pointless) to get a complete list of things that you need). + +Basically, there are *many* SVR4-derived systems out there, and there are +many little idiosyncracies; the best bet is to put someone else's name +and email address in the hint file so you can blame them :-). + + Andy Dougherty doughera@lafcol.lafayette.edu + + +From: Tye McQueen +Subject: Re: [MM] Re: hints file for Oracle +Date: Fri, 18 Aug 1995 16:01:39 -0500 (CDT) +Cc: aburlison@cix.compulink.co.uk, perldb-interest@vix.com, + makemaker@franz.ww.tu-berlin.de + +Excerpts from the mail message of Tim Bunce: +) > From: Alan Burlison +) > +) > The following hints file is required for DBD::Oracle on svr4, you might +) > like to add it to the next release :-) +) > +) > File: Oracle/hints/svr4.pl +) > +) > # Some SVR4 systems may need to link against -lc to pick up things like +) > $att{LIBS} = [ '-lsocket -lnsl -lm -ldl -lc' ]; +) +) Umm, 'some', 'may', 'things like'. Care to clarify? +) +) Why _exactly_ is this needed, and why doesn't MakeMaker do this already? +) (CC'd to the MakeMaker mailing list.) +) +) Is anyone else using DBD::Oracle on an svr4 system (not solaris 2)? + +That looks like something I wrote. I'll take credit and blame +for it at least for the sake of the next paragraph. + +So far "some" is only whatever Unisys system Alan and one other +person have used. "may" is because, as far as I could tell from +my end, some of the dynamically loaded extensions worked okay +before this fix but one of them didn't. "thinks like" must be +because I couldn't remember which routine was not being found +and then forgot to finish my sentence. I think it was _ecvt(). + +The description is very vague because it doesn't make sense to +me why it is needed and I don't have access to a system to play +around with it if I really wanted to try to figure it out. But +it seems to fix the few problems it addresses and have not heard +of it hurting anything yet (and I've tested it on my machines). + +I'm putting together a README.svr4 for Perl that will describe this +and many other things in case people are curious or run into a +problem and need to know why some of the strange things were done. +-- +Tye McQueen tye@metronet.com || tye@doober.usu.edu + Nothing is obvious unless you are overlooking something + http://www.metronet.com/~tye/ (scripts, links, nothing fancy) + diff --git a/oci.def b/oci.def new file mode 100644 index 00000000..d39ca971 --- /dev/null +++ b/oci.def @@ -0,0 +1,368 @@ +; this file was produced from Oracle 8.0.4 OCI.DLL by pexports program +; written by Anders Norlander +; http://www.acc.umu.se/~anorland/gnu-win32/index.html +; +; to make liboci.a run +; dlltool --input-def oci.def --output-lib liboci.a +; +LIBRARY OCI.dll +EXPORTS +OCIAQDeq +OCIAQEnq +OCIAttrGet +OCIAttrSet +OCIBindArrayOfStruct +OCIBindByName +OCIBindByPos +OCIBindDynamic +OCIBindObject +OCIBreak +OCICacheFlush +OCICacheFlushRefresh +OCICacheFree +OCICacheGetObjects +OCICacheRefresh +OCICacheRegister +OCICacheUnmark +OCICacheUnpin +OCICollAppend +OCICollAssign +OCICollAssignElem +OCICollGetElem +OCICollMax +OCICollSize +OCICollTrim +OCIDateAddDays +OCIDateAddMonths +OCIDateAssign +OCIDateCheck +OCIDateCompare +OCIDateDaysBetween +OCIDateFromText +OCIDateLastDay +OCIDateNextDay +OCIDateSysDate +OCIDateToText +OCIDateZoneToZone +OCIDefineArrayOfStruct +OCIDefineByPos +OCIDefineDynamic +OCIDefineObject +OCIDescribeAny +OCIDescriptorAlloc +OCIDescriptorFree +OCIDurationBegin +OCIDurationEnd +OCIDurationGetParent +OCIEnvInit +OCIErrorGet +OCIHandleAlloc +OCIHandleFree +OCIInitialize +OCIIterCreate +OCIIterDelete +OCIIterGetCurrent +OCIIterInit +OCIIterNext +OCIIterPrev +OCILdaToSvcCtx +OCILobAppend +OCILobAssign +OCILobCharSetForm +OCILobCharSetId +OCILobCopy +OCILobDisableBuffering +OCILobEnableBuffering +OCILobErase +OCILobFileClose +OCILobFileCloseAll +OCILobFileExists +OCILobFileGetName +OCILobFileIsOpen +OCILobFileOpen +OCILobFileSetName +OCILobFlushBuffer +OCILobGetLength +OCILobIsEqual +OCILobLoadFromFile +OCILobLocatorIsInit +OCILobRead +OCILobTrim +OCILobWrite +OCILogoff +OCILogon +OCINumberAbs +OCINumberAdd +OCINumberArcCos +OCINumberArcSin +OCINumberArcTan +OCINumberArcTan2 +OCINumberAssign +OCINumberCeil +OCINumberCmp +OCINumberCos +OCINumberDiv +OCINumberExp +OCINumberFloor +OCINumberFromInt +OCINumberFromReal +OCINumberFromText +OCINumberHypCos +OCINumberHypSin +OCINumberHypTan +OCINumberIntPower +OCINumberIsZero +OCINumberLn +OCINumberLog +OCINumberMod +OCINumberMul +OCINumberNeg +OCINumberPower +OCINumberRound +OCINumberSetZero +OCINumberSin +OCINumberSqrt +OCINumberSub +OCINumberTan +OCINumberToInt +OCINumberToReal +OCINumberToText +OCINumberTrunc +OCIObjectAlwaysLatest +OCIObjectArrayPin +OCIObjectCopy +OCIObjectExists +OCIObjectFlush +OCIObjectFlushRefresh +OCIObjectFree +OCIObjectGetAttr +OCIObjectGetInd +OCIObjectGetObjectRef +OCIObjectGetProperty +OCIObjectGetTypeRef +OCIObjectIsDirtied +OCIObjectIsDirty +OCIObjectIsLoaded +OCIObjectIsLocked +OCIObjectLock +OCIObjectMarkDelete +OCIObjectMarkDeleteByRef +OCIObjectMarkUpdate +OCIObjectNew +OCIObjectNotAlwaysLatest +OCIObjectPin +OCIObjectPinCountReset +OCIObjectPinTable +OCIObjectRefresh +OCIObjectSetAttr +OCIObjectUnmark +OCIObjectUnmarkByRef +OCIObjectUnpin +OCIParamGet +OCIParamSet +OCIPasswordChange +OCIRawAllocSize +OCIRawAssignBytes +OCIRawAssignRaw +OCIRawPtr +OCIRawResize +OCIRawSize +OCIRefAssign +OCIRefClear +OCIRefFromHex +OCIRefHexSize +OCIRefIsEqual +OCIRefIsNull +OCIRefToHex +OCIResultSetToStmt +OCISecurityAbortIdentity +OCISecurityClosePersona +OCISecurityCloseWallet +OCISecurityCreateIdentity +OCISecurityCreatePersona +OCISecurityCreateWallet +OCISecurityDeEnvelope +OCISecurityDecrypt +OCISecurityDestroyWallet +OCISecurityEncrypt +OCISecurityEncryptExpansion +OCISecurityEnvelope +OCISecurityFreeIdentity +OCISecurityGetIdentity +OCISecurityGetProtection +OCISecurityHash +OCISecurityHashExpansion +OCISecurityInitBlock +OCISecurityInitialize +OCISecurityKeyedHash +OCISecurityKeyedHashExpansion +OCISecurityOpenPersona +OCISecurityOpenWallet +OCISecurityPKDecrypt +OCISecurityPKEncryptExpansion +OCISecurityPurgeBlock +OCISecurityRandomBytes +OCISecurityRandomNumber +OCISecurityRemoveIdentity +OCISecurityRemovePersona +OCISecurityReuseBlock +OCISecuritySeedRandom +OCISecuritySetBlock +OCISecuritySetProtection +OCISecuritySign +OCISecuritySignDetExpansion +OCISecuritySignDetached +OCISecuritySignExpansion +OCISecurityStorePersona +OCISecurityStoreTrustedIdentity +OCISecurityTerminate +OCISecurityValidate +OCISecurityVerify +OCISecurityVerifyDetached +OCISecurity_PKEncrypt +OCIServerAttach +OCIServerDetach +OCIServerVersion +OCISessionBegin +OCISessionEnd +OCIStmtBindByName +OCIStmtBindByPos +OCIStmtExecute +OCIStmtFetch +OCIStmtGetBindInfo +OCIStmtGetPieceInfo +OCIStmtPrepare +OCIStmtSetPieceInfo +OCIStringAllocSize +OCIStringAssign +OCIStringAssignText +OCIStringPtr +OCIStringResize +OCIStringSize +OCISvcCtxToLda +OCITableDelete +OCITableExists +OCITableFirst +OCITableLast +OCITableNext +OCITablePrev +OCITableSize +OCITransCommit +OCITransDetach +OCITransForget +OCITransPrepare +OCITransRollback +OCITransStart +OCITypeArrayByName +OCITypeArrayByRef +OCITypeAttrByName +OCITypeAttrNext +OCITypeAttrs +OCITypeByName +OCITypeByRef +OCITypeCollElem +OCITypeCollExtTypeCode +OCITypeCollSize +OCITypeCollTypeCode +OCITypeElemCharSetForm +OCITypeElemCharSetID +OCITypeElemDefaultValue +OCITypeElemExtTypeCode +OCITypeElemFlags +OCITypeElemLength +OCITypeElemName +OCITypeElemNumPrec +OCITypeElemNumScale +OCITypeElemParamMode +OCITypeElemParameterizedType +OCITypeElemType +OCITypeElemTypeCode +OCITypeIterFree +OCITypeIterNew +OCITypeIterSet +OCITypeMethodByName +OCITypeMethodEncap +OCITypeMethodFlags +OCITypeMethodMap +OCITypeMethodName +OCITypeMethodNext +OCITypeMethodOrder +OCITypeMethodOverload +OCITypeMethodParams +OCITypeMethods +OCITypeName +OCITypeParamByName +OCITypeParamByPos +OCITypeParamPos +OCITypeResult +OCITypeSchema +OCITypeTypeCode +OCITypeVTInit +OCITypeVTInsert +OCITypeVTSelect +OCITypeVersion +obindps +obndra +obndrn +obndrv +obreak +ocan +ocibre +ocibrn +ocibrv +ociclo +ocicof +ocicom +ocidefn +ocidfn +ocidsc +ociepacm +ocieperr +ociepgoe +ociepmsg +ocierr +ociexe +ociexn +ocifet +ocilof +ocilon +ociope +ocirlo +ocirol +ocisq3 +oclose +ocof +ocom +ocon +odefin +odefinps +odescr +odessp +odsc +oerhms +oermsg +oexec +oexfet +oexn +ofen +ofetch +oflng +ogetpi +ognfd +olog +ologof +ologon +olon +oname +onbclr +onbset +onbtst +oopen +oopt +oparse +opinit +orlon +orol +ortgcty +osetpi +osql3 diff --git a/oci7.c b/oci7.c new file mode 100644 index 00000000..427d8824 --- /dev/null +++ b/oci7.c @@ -0,0 +1,553 @@ +/* + $Id: oci7.c,v 1.11 1999/06/14 00:41:48 timbo Exp $ + + Copyright (c) 1994,1995,1996,1997,1998,1999 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file, + with the exception that it cannot be placed on a CD-ROM or similar media + for commercial distribution without the prior approval of the author. + +*/ + +#include "Oracle.h" + + +#ifdef OCI_V8_SYNTAX + + /* see oci8.c */ + +#else + +DBISTATE_DECLARE; + +static SV *ora_long; +static SV *ora_trunc; +static SV *ora_cache; +static SV *ora_cache_o; /* for ora_open() cache override */ + +void +dbd_init_oci(dbistate) + dbistate_t *dbistate; +{ + DBIS = dbistate; + ora_long = perl_get_sv("Oraperl::ora_long", GV_ADDMULTI); + ora_trunc = perl_get_sv("Oraperl::ora_trunc", GV_ADDMULTI); + ora_cache = perl_get_sv("Oraperl::ora_cache", GV_ADDMULTI); + ora_cache_o = perl_get_sv("Oraperl::ora_cache_o", GV_ADDMULTI); +} + + +void +ora_error(h, lda, rc, what) + SV *h; + Lda_Def *lda; + int rc; + char *what; +{ + D_imp_xxh(h); + SV *errstr = DBIc_ERRSTR(imp_xxh); + sv_setiv(DBIc_ERR(imp_xxh), (IV)rc); /* set err early */ + if (lda) { /* is oracle error (allow for non-oracle errors) */ + int len; + char msg[1024]; + /* Oracle oerhms can do duplicate free if connect fails. */ + /* Ignore 'with different width due to prototype' gcc warning */ + oerhms(lda, rc, (text*)msg, sizeof(msg)); /* may hang! */ + len = strlen(msg); + if (len && msg[len-1] == '\n') + msg[len-1] = '\0'; /* trim off \n from end of message */ + sv_setpv(errstr, (char*)msg); + if (what) { + sv_catpv(errstr, " (DBD: "); + sv_catpv(errstr, what); + sv_catpv(errstr, ")"); + } + } + else sv_setpv(errstr, what); + DBIh_EVENT2(h, ERROR_event, DBIc_ERR(imp_xxh), errstr); +} + + +int +dbd_describe(h, imp_sth) + SV *h; + imp_sth_t *imp_sth; +{ + static sb4 *f_cbufl; /* XXX not thread safe */ + static U32 f_cbufl_max; + + D_imp_dbh_from_sth; + I32 long_buflen; + sb1 *cbuf_ptr; + int t_cbufl=0; + I32 num_fields; + int has_longs = 0; + int est_width = 0; /* estimated avg row width (for cache) */ + int i = 0; + + + if (imp_sth->done_desc) + return 1; /* success, already done it */ + imp_sth->done_desc = 1; + + /* ora_trunc is checked at fetch time */ + /* long_buflen: length for long/longraw (if >0), else 80 (ora app dflt) */ + /* Ought to be for COMPAT mode only but was relaxed before LongReadLen existed */ + long_buflen = (SvOK(ora_long) && SvIV(ora_long)>0) + ? SvIV(ora_long) : DBIc_LongReadLen(imp_sth); + if (long_buflen < 0) /* trap any sillyness */ + long_buflen = 80; /* typical oracle app default */ + +#ifndef FT_SELECT +#define FT_SELECT 4 +#endif + if (imp_sth->cda->ft != FT_SELECT) { + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " dbd_describe skipped for non-select (sql f%d, lb %ld, csr 0x%lx)\n", + imp_sth->cda->ft, (long)long_buflen, (long)imp_sth->cda); + /* imp_sth memory was cleared when created so no setup required here */ + return 1; + } + + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " dbd_describe (for sql f%d after oci f%d, lb %ld, csr 0x%lx)...\n", + imp_sth->cda->ft, imp_sth->cda->fc, (long)long_buflen, (long)imp_sth->cda); + + if (!f_cbufl) { + f_cbufl_max = 120; + New(1, f_cbufl, f_cbufl_max, sb4); + } + + /* number of rows to cache */ + if (SvOK(ora_cache_o)) imp_sth->cache_rows = SvIV(ora_cache_o); + else if (SvOK(ora_cache)) imp_sth->cache_rows = SvIV(ora_cache); + else imp_sth->cache_rows = imp_dbh->RowCacheSize; + + /* Get number of fields and space needed for field names */ + while(++i) { /* break out within loop */ + sb1 cbuf[257]; /* generous max column name length */ + sb2 dbtype = 0; /* workaround for Oracle bug #405032 */ + sb4 dbsize; + if (i >= f_cbufl_max) { + f_cbufl_max *= 2; + Renew(f_cbufl, f_cbufl_max, sb4); + } + f_cbufl[i] = sizeof(cbuf); + odescr(imp_sth->cda, i, &dbsize, &dbtype, + cbuf, &f_cbufl[i], (sb4*)0, (sb2*)0, (sb2*)0, (sb2*)0); + if (imp_sth->cda->rc || dbtype == 0) + break; + t_cbufl += f_cbufl[i]; + + /* now we calculate the approx average on-the-wire width of */ + /* each field (and thus row) to determine a 'good' cache size. */ + if (imp_sth->cache_rows > 0) + continue; /* no need, user specified a size */ + if (dbsize==0) { /* is a LONG type or 'select NULL' */ + if (OTYPE_IS_LONG(dbtype)) { + est_width += long_buflen; + ++has_longs; /* hint to auto cache sizing code */ + } + } + else /* deal with dbtypes with overblown dbsizes */ + switch(dbtype) { + case 1: /* VARCHAR2 - result of to_char() has dbsize==75 */ + /* for all but small strings we take off 25% */ + est_width += (dbsize < 32) ? dbsize : dbsize-(dbsize>>2); + break; + case 2: /* NUMBER - e.g., from a sum() or max(), dbsize==22 */ + /* Most numbers are _much_ smaller than 22 bytes */ + est_width += 4; /* > approx +/- 1_000_000 ? */ + break; + default: est_width += dbsize; + break; + } + } + if (imp_sth->cda->rc && imp_sth->cda->rc != 1007) { + D_imp_dbh_from_sth; + ora_error(h, imp_dbh->lda, imp_sth->cda->rc, "odescr failed"); + return 0; + } + imp_sth->cda->rc = 0; + num_fields = i - 1; + DBIc_NUM_FIELDS(imp_sth) = num_fields; + + /* --- Setup the row cache for this query --- */ + + /* Use guessed average on-the-wire row width calculated above */ + /* and add in overhead of 5 bytes per field plus 8 bytes per row. */ + /* The n*5+8 was determined by studying SQL*Net v2 packets. */ + /* It could probably benefit from a more detailed analysis. */ + est_width += num_fields*5 + 8; + + if (has_longs) /* override/disable caching */ + imp_sth->cache_rows = 1; /* else read_blob can't work */ + + else if (imp_sth->cache_rows < 1) { /* automatically size the cache */ + int txfr_size; + /* 0 == try to pick 'optimal' cache for this query (default) */ + /* <0 == base cache on target transfer size of -n bytes. */ + if (imp_sth->cache_rows == 0) { + /* Oracle packets on ethernet have max size of around 1460. */ + /* We'll aim to fill our row cache with slightly less than */ + /* two packets (to err on the safe side and avoid a third */ + /* almost empty packet being generated in some cases). */ + txfr_size = 1460 * 3.6; /* default transfer/cache size */ + } + else { /* user is specifying desired transfer size in bytes */ + txfr_size = -imp_sth->cache_rows; + } + imp_sth->cache_rows = txfr_size / est_width; /* maybe 1 or 0 */ + /* To ensure good performance with large rows (near or larger */ + /* than our target transfer size) we set a minimum cache size. */ + if (imp_sth->cache_rows < 6) /* is cache a 'useful' size? */ + imp_sth->cache_rows = (imp_sth->cache_rows>0) ? 6 : 4; + } + if (imp_sth->cache_rows > 32767) /* keep within Oracle's limits */ + imp_sth->cache_rows = 32767; + /* Initialise cache counters */ + imp_sth->in_cache = 0; + imp_sth->eod_errno = 0; + + + /* allocate field buffers */ + Newz(42, imp_sth->fbh, num_fields, imp_fbh_t); + /* allocate a buffer to hold all the column names */ + Newz(42, imp_sth->fbh_cbuf, t_cbufl + num_fields, char); + + cbuf_ptr = (sb1*)imp_sth->fbh_cbuf; + for(i=1; i <= num_fields && imp_sth->cda->rc != 10; ++i) { + imp_fbh_t *fbh = &imp_sth->fbh[i-1]; + fb_ary_t *fb_ary; + sb4 defin_len; + + fbh->imp_sth = imp_sth; + fbh->name = (char*)cbuf_ptr; + fbh->cbufl = f_cbufl[i]; + /* DESCRIBE */ + odescr(imp_sth->cda, i, + &fbh->dbsize, &fbh->dbtype, (sb1*)fbh->name, &fbh->cbufl, + &fbh->disize, &fbh->prec, &fbh->scale, &fbh->nullok); + fbh->name[fbh->cbufl] = '\0'; /* ensure null terminated */ + cbuf_ptr += fbh->cbufl + 1; /* increment name pointer */ + + /* Now define the storage for this field data. */ + + if (fbh->dbtype==23) { /* RAW type */ + fbh->dbsize *= 2; + fbh->disize *= 2; + } + else if (fbh->dbtype == 2 && fbh->prec == 0) { + fbh->prec = 38; + } + else if ((fbh->dbtype == 1 || fbh->dbtype == 96) && fbh->prec == 0) { + fbh->prec = fbh->dbsize; + } + + if (OTYPE_IS_LONG(fbh->dbtype)) { + long lbl; + if (fbh->dbtype==24 || fbh->dbtype==95) { + lbl = long_buflen * 2; + fbh->ftype = 95; /* get long in var raw form */ + } + else { + lbl = long_buflen; + fbh->ftype = 94; /* get long in var form */ + } + fbh->dbsize = lbl; + fbh->disize = lbl; + defin_len = fbh->disize + 4; + + } else { + /* for the time being we fetch everything (except longs) */ + /* as strings, that'll change (IV, NV and binary data etc) */ + fbh->ftype = 5; /* oraperl used 5 'STRING' */ + defin_len = fbh->disize + 1; /* +1: STRING null */ + } + /* dbsize can be zero for 'select NULL ...' */ + imp_sth->t_dbsize += fbh->dbsize; + + fbh->fb_ary = fb_ary = fb_ary_alloc(defin_len, imp_sth->cache_rows); + + /* DEFINE output column variable storage */ + if (odefin(imp_sth->cda, i, fb_ary->abuf, defin_len, + fbh->ftype, -1, fb_ary->aindp, (text*)0, -1, -1, + fb_ary->arlen, fb_ary->arcode)) { + warn("odefin error on %s: %d", fbh->name, imp_sth->cda->rc); + } + + if (DBIS->debug >= 2) + dbd_fbh_dump(fbh, i, 0); + } + imp_sth->est_width = est_width; + + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " dbd_describe'd %d columns (Row bytes: %d max, %d est avg. Cache: %d rows)\n", + (int)num_fields, imp_sth->t_dbsize, est_width, imp_sth->cache_rows); + + if (imp_sth->cda->rc && imp_sth->cda->rc != 1007) { + D_imp_dbh_from_sth; + ora_error(h, imp_dbh->lda, imp_sth->cda->rc, "odescr failed"); + return 0; + } + + return 1; +} + + +AV * +dbd_st_fetch(sth, imp_sth) + SV * sth; + imp_sth_t *imp_sth; +{ + int debug = DBIS->debug; + int num_fields; + int ChopBlanks; + int err = 0; + int i; + AV *av; + + if (!imp_sth->in_cache) { /* refill cache if empty */ + int previous_rpc; + + /* Check that execute() was executed sucessfully. This also implies */ + /* that dbd_describe() executed sucessfuly so the memory buffers */ + /* are allocated and bound. */ + if ( !DBIc_ACTIVE(imp_sth) ) { + ora_error(sth, NULL, 1, "no statement executing (perhaps you need to call execute first)"); + return Nullav; + } + + if (imp_sth->eod_errno) { + end_of_data: + { dTHR; /* for DBIc_ACTIVE_off */ + DBIc_ACTIVE_off(imp_sth); /* eg finish */ + } + if (imp_sth->eod_errno != 1403) { /* was not just end-of-fetch */ + ora_error(sth, imp_sth->cda, imp_sth->eod_errno, "cached ofetch error"); + } else { /* is simply no more data */ + sv_setiv(DBIc_ERR(imp_sth), 0); /* ensure errno set to 0 here */ + if (debug >= 3) + fprintf(DBILOGFP, " dbd_st_fetch no-more-data, rc=%d, rpc=%ld\n", + imp_sth->cda->rc, imp_sth->cda->rpc); + } + /* further fetches without an execute will arrive back here */ + return Nullav; + } + + previous_rpc = imp_sth->cda->rpc; /* remember rpc before re-fetch */ + if (ofen(imp_sth->cda, imp_sth->cache_rows)) { + /* Note that errors may happen after one or more rows have been */ + /* added to the cache. We record the error but don't handle it till */ + /* the cache is empty (which may be at once if no rows returned). */ + imp_sth->eod_errno = imp_sth->cda->rc; /* store rc for later */ + if (imp_sth->cda->rpc == previous_rpc) /* no more rows fetched */ + goto end_of_data; + /* else fall through and return the first of the fetched rows */ + } + imp_sth->next_entry = 0; + imp_sth->in_cache = imp_sth->cda->rpc - previous_rpc; + if (debug >= 4) + fprintf(DBILOGFP, + " dbd_st_fetch load-cache: prev rpc %d, new rpc %ld, in_cache %d\n", + previous_rpc, (long)imp_sth->cda->rpc, imp_sth->in_cache); + assert(imp_sth->in_cache > 0); + } + + av = DBIS->get_fbav(imp_sth); + num_fields = AvFILL(av)+1; + + if (debug >= 3) + fprintf(DBILOGFP, " dbd_st_fetch %d fields, rpc %ld (cache: %d/%d/%d)\n", + num_fields, (long)imp_sth->cda->rpc, imp_sth->next_entry, + imp_sth->in_cache, imp_sth->cache_rows); + + ChopBlanks = DBIc_has(imp_sth, DBIcf_ChopBlanks); + + for(i=0; i < num_fields; ++i) { + imp_fbh_t *fbh = &imp_sth->fbh[i]; + int cache_entry = imp_sth->next_entry; + fb_ary_t *fb_ary = fbh->fb_ary; + int rc = fb_ary->arcode[cache_entry]; + SV *sv = AvARRAY(av)[i]; /* Note: we (re)use the SV in the AV */ + ub4 datalen; + + if (rc == 1406 && OTYPE_IS_LONG(fbh->ftype)) { + /* We have a LONG field which has been truncated. */ + int oraperl = DBIc_COMPAT(imp_sth); + if (DBIc_has(imp_sth,DBIcf_LongTruncOk) || (oraperl && SvIV(ora_trunc))) { + /* user says truncation is ok */ + /* Oraperl recorded the truncation in ora_errno so we */ + /* so also but only for Oraperl mode handles. */ + if (oraperl) + sv_setiv(DBIc_ERR(imp_sth), (IV)rc); + rc = 0; /* but don't provoke an error here */ + } + /* else fall through and let rc trigger failure below */ + } + + if (rc == 0) { /* the normal case */ + char *p; + if (fbh->ftype == 94 || fbh->ftype == 95) { /* LONG VAR */ + p = (char*)&fb_ary->abuf[cache_entry * fb_ary->bufl]; + datalen = *(ub4*)p; /* XXX alignment ? */ + p += 4; + sv_setpvn(sv, p, (STRLEN)datalen); + } + else { + datalen = fb_ary->arlen[cache_entry]; + p = (char*)&fb_ary->abuf[cache_entry * fb_ary->bufl]; + /* if ChopBlanks check for Oracle CHAR type (blank padded) */ + if (ChopBlanks && fbh->dbtype == 96) { + while(datalen && p[datalen - 1]==' ') + --datalen; + } + sv_setpvn(sv, p, (STRLEN)datalen); + } + + } else if (rc == 1405) { /* field is null - return undef */ + datalen = 0; + (void)SvOK_off(sv); + + } else { /* See odefin rcode arg description in OCI docs */ + char buf[200]; + char *hint = ""; + datalen = 0; + /* These may get more case-by-case treatment eventually. */ + if (rc == 1406) { /* field truncated (see above) */ + if (OTYPE_IS_LONG(fbh->ftype)) { /* double check */ + hint = (DBIc_LongReadLen(imp_sth) > 65535) + ? ", DBI attribute LongTruncOk not set and/or LongReadLen too small or > 65535 max" + : ", DBI attribute LongTruncOk not set and/or LongReadLen too small"; + } + else { + /* Copy the truncated value anyway, it may be of use, */ + /* but it'll only be accessible via prior bind_column() */ + sv_setpvn(sv, (char*)&fb_ary->abuf[cache_entry * fb_ary->bufl], + fb_ary->arlen[cache_entry]); + } + } + else { + SvOK_off(sv); /* set field that caused error to undef */ + } + ++err; /* 'fail' this fetch but continue getting fields */ + /* Some should probably be treated as warnings but */ + /* for now we just treat them all as errors */ + sprintf(buf,"ORA-%05d error on field %d of %d, ora_type %d%s", + rc, i+1, num_fields, fbh->dbtype, hint); + ora_error(sth, imp_sth->cda, rc, buf); + } + + if (debug >= 5) + fprintf(DBILOGFP, " %d (rc=%d, otype %d, len %lu): %s\n", + i, rc, fbh->dbtype, datalen, neatsvpv(sv,0)); + } + + /* update cache counters */ + if (ora_fetchtest) /* unless we're testing performance */ + --ora_fetchtest; + else { + --imp_sth->in_cache; + ++imp_sth->next_entry; + } + + return (err) ? Nullav : av; +} + + +/* ------------------------------------------------------------ */ + + + +int +dbd_st_prepare(sth, imp_sth, statement, attribs) + SV *sth; + imp_sth_t *imp_sth; + char *statement; + SV *attribs; +{ + D_imp_dbh_from_sth; + ub4 oparse_lng = 1; /* auto v6 or v7 as suits db connected to */ + + if (!DBIc_ACTIVE(imp_dbh)) { + ora_error(sth, NULL, -1, "Database disconnected"); + return 0; + } + + imp_sth->done_desc = 0; + + if (DBIc_COMPAT(imp_sth)) { + static SV *ora_pad_empty; + if (!ora_pad_empty) { + ora_pad_empty= perl_get_sv("Oraperl::ora_pad_empty", GV_ADDMULTI); + if (!SvOK(ora_pad_empty) && getenv("ORAPERL_PAD_EMPTY")) + sv_setiv(ora_pad_empty, atoi(getenv("ORAPERL_PAD_EMPTY"))); + } + imp_sth->ora_pad_empty = (SvOK(ora_pad_empty)) ? SvIV(ora_pad_empty) : 0; + } + + if (attribs) { + SV **svp; + DBD_ATTRIB_GET_IV( attribs, "ora_parse_lang", 14, svp, oparse_lng); + } + + /* scan statement for '?', ':1' and/or ':foo' style placeholders */ + dbd_preparse(imp_sth, statement); + + if (oopen(&imp_sth->cdabuf, imp_dbh->lda, (text*)0, -1, -1, (text*)0, -1)) { + ora_error(sth, &imp_sth->cdabuf, imp_sth->cdabuf.rc, "oopen error"); + return 0; + } + imp_sth->cda = &imp_sth->cdabuf; + + /* parse the (possibly edited) SQL statement */ + imp_sth->cda->peo = 0; + if (oparse(imp_sth->cda, (text*)imp_sth->statement, (sb4)-1, + (sword)0/*oparse_defer*/, (ub4)oparse_lng) + ) { + char buf[99]; + char *hint = ""; + if (1) { /* XXX could make optional one day */ + SV *msgsv, *sqlsv; + sprintf(buf,"error possibly near <*> indicator at char %d in '", + imp_sth->cda->peo+1); + msgsv = sv_2mortal(newSVpv(buf,0)); + sqlsv = sv_2mortal(newSVpv(imp_sth->statement,0)); + sv_insert(sqlsv, imp_sth->cda->peo, 0, "<*>",3); + sv_catsv(msgsv, sqlsv); + sv_catpv(msgsv, "'"); + hint = SvPV(msgsv,na); + } + ora_error(sth, imp_sth->cda, imp_sth->cda->rc, hint); + oclose(imp_sth->cda); /* close the cursor */ + imp_sth->cda = NULL; + return 0; + } + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " dbd_st_prepare'd sql f%d\n", imp_sth->cda->ft); + + /* Describe and allocate storage for results. */ + if (!dbd_describe(sth, imp_sth)) { + return 0; + } + + DBIc_IMPSET_on(imp_sth); + return 1; +} + +int +ora_db_reauthenticate(dbh, imp_dbh, uid, pwd) + SV *dbh; + imp_dbh_t *imp_dbh; + char * uid; + char * pwd; +{ + ora_error(dbh, NULL, 1, "reauthenticate not possible when using Oracle OCI 7"); + return 0; +} + +#endif diff --git a/oci8.c b/oci8.c new file mode 100644 index 00000000..c73407f0 --- /dev/null +++ b/oci8.c @@ -0,0 +1,1442 @@ +/* + $Id: oci8.c,v 1.22 2000/07/13 22:42:02 timbo Exp $ + + Copyright (c) 1998 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file, + with the exception that it cannot be placed on a CD-ROM or similar media + for commercial distribution without the prior approval of the author. + +*/ + +#include "Oracle.h" + + +#ifdef OCI_V8_SYNTAX + + +DBISTATE_DECLARE; + +static SV *ora_long; +static SV *ora_trunc; +static SV *ora_cache; +static SV *ora_cache_o; /* for ora_open() cache override */ + +extern int pp_exec_rset _((SV *sth, imp_sth_t *imp_sth, phs_t *phs, int pre_exec)); + +void +dbd_init_oci(dbistate_t *dbistate) +{ + DBIS = dbistate; + ora_long = perl_get_sv("Oraperl::ora_long", GV_ADDMULTI); + ora_trunc = perl_get_sv("Oraperl::ora_trunc", GV_ADDMULTI); + ora_cache = perl_get_sv("Oraperl::ora_cache", GV_ADDMULTI); + ora_cache_o = perl_get_sv("Oraperl::ora_cache_o", GV_ADDMULTI); +} + + +char * +oci_status_name(sword status) +{ + SV *sv; + switch (status) { + case OCI_SUCCESS: return "SUCCESS"; + case OCI_SUCCESS_WITH_INFO: return "SUCCESS_WITH_INFO"; + case OCI_NEED_DATA: return "NEED_DATA"; + case OCI_NO_DATA: return "NO_DATA"; + case OCI_ERROR: return "ERROR"; + case OCI_INVALID_HANDLE: return "INVALID_HANDLE"; + case OCI_STILL_EXECUTING: return "STILL_EXECUTING"; + case OCI_CONTINUE: return "CONTINUE"; + } + sv = sv_2mortal(newSVpv("",0)); + sv_grow(sv, 50); + sprintf(SvPVX(sv),"(UNKNOWN OCI STATUS %d)", status); + return SvPVX(sv); +} + + +char * +oci_stmt_type_name(int stmt_type) +{ + SV *sv; + switch (stmt_type) { + case OCI_STMT_SELECT: return "SELECT"; + case OCI_STMT_UPDATE: return "UPDATE"; + case OCI_STMT_DELETE: return "DELETE"; + case OCI_STMT_INSERT: return "INSERT"; + case OCI_STMT_CREATE: return "CREATE"; + case OCI_STMT_DROP: return "DROP"; + case OCI_STMT_ALTER: return "ALTER"; + case OCI_STMT_BEGIN: return "BEGIN"; + case OCI_STMT_DECLARE: return "DECLARE"; + } + sv = sv_2mortal(newSVpv("",0)); + sv_grow(sv, 50); + sprintf(SvPVX(sv),"(STMT TYPE %d)", stmt_type); + return SvPVX(sv); +} + + +int +oci_error(SV *h, OCIError *errhp, sword status, char *what) +{ + D_imp_xxh(h); + SV *errstr = DBIc_ERRSTR(imp_xxh); + sv_setpv(errstr, ""); + if (errhp) { + text errbuf[1024]; + sb4 errcode = 0; + ub4 recno = 0; + sb4 eg_errcode = 0; + sword eg_status; + while( ++recno + && OCIErrorGet_log_stat(errhp, recno, (text*)NULL, &eg_errcode, errbuf, + (ub4)sizeof(errbuf), OCI_HTYPE_ERROR, eg_status) != OCI_NO_DATA + && eg_status != OCI_INVALID_HANDLE + && recno < 100 + ) { + if (DBIS->debug >= 4 || recno>1/*XXX temp*/) + fprintf(DBILOGFP, " OCIErrorGet after %s (er%ld:%s): %d, %ld: %s\n", + what, (long)recno, + (eg_status==OCI_SUCCESS) ? "ok" : oci_status_name(eg_status), + status, (long)eg_errcode, errbuf); + errcode = eg_errcode; + sv_catpv(errstr, (char*)errbuf); + if (*(SvEND(errstr)-1) == '\n') + --SvCUR(errstr); + } + if (what || status != OCI_ERROR) { + sv_catpv(errstr, " (DBD "); + sv_catpv(errstr, oci_status_name(status)); + if (what) { + sv_catpv(errstr, ": "); + sv_catpv(errstr, what); + } + sv_catpv(errstr, ")"); + } + /* DBIc_ERR *must* be SvTRUE (for RaiseError etc), some */ + /* errors, like OCI_INVALID_HANDLE, don't set errcode. */ + if (errcode == 0) + errcode = (status != 0) ? status : -10000; + sv_setiv(DBIc_ERR(imp_xxh), (IV)errcode); + } + else { + sv_setiv(DBIc_ERR(imp_xxh), (IV)status); + sv_catpv(errstr, oci_status_name(status)); + sv_catpv(errstr, " "); + sv_catpv(errstr, what); + } + DBIh_EVENT2(h, + (status == OCI_SUCCESS_WITH_INFO) ? WARN_event : ERROR_event, + DBIc_ERR(imp_xxh), errstr); + return 0; /* always returns 0 */ +} + + +char * +ora_sql_error(imp_sth_t *imp_sth, char *msg) +{ +#ifdef OCI_ATTR_PARSE_ERROR_OFFSET_xxx + imp_sth->cda->peo = 0; + if (oparse(imp_sth->cda, (text*)imp_sth->statement, (sb4)-1, + (sword)0/*oparse_defer*/, (ub4)oparse_lng) + ) { + char buf[99]; + char *hint = ""; + if (1) { /* XXX could make optional one day */ + SV *msgsv, *sqlsv; + sprintf(buf,"error possibly near <*> indicator at char %d in '", + imp_sth->cda->peo+1); + msgsv = sv_2mortal(newSVpv(buf,0)); + sqlsv = sv_2mortal(newSVpv(imp_sth->statement,0)); + sv_insert(sqlsv, imp_sth->cda->peo, 0, "<*>",3); + sv_catsv(msgsv, sqlsv); + sv_catpv(msgsv, "'"); + hint = SvPV(msgsv,na); + } + ora_error(sth, imp_sth->cda, imp_sth->cda->rc, hint); + oclose(imp_sth->cda); /* close the cursor */ + imp_sth->cda = NULL; + return 0; + } +#else + imp_sth = imp_sth; /* not unused */ + return msg; +#endif +} + + +int +dbd_st_prepare(sth, imp_sth, statement, attribs) + SV *sth; + imp_sth_t *imp_sth; + char *statement; + SV *attribs; +{ + D_imp_dbh_from_sth; + sword status = 0; + ub4 oparse_lng = 1; /* auto v6 or v7 as suits db connected to */ + int ora_check_sql = 1; /* to force a describe to check SQL */ + /* XXX we set ora_check_sql on for now to force setup of the */ + /* row cache. Change later to set up row cache using just a */ + /* a memory size, perhaps also default $RowCacheSize to a */ + /* negative value. OCI_ATTR_PREFETCH_MEMORY */ + + if (!DBIc_ACTIVE(imp_dbh)) { + oci_error(sth, NULL, OCI_ERROR, "Database disconnected"); + return 0; + } + + imp_sth->done_desc = 0; + + if (DBIc_COMPAT(imp_sth)) { + static SV *ora_pad_empty; + if (!ora_pad_empty) { + ora_pad_empty= perl_get_sv("Oraperl::ora_pad_empty", GV_ADDMULTI); + if (!SvOK(ora_pad_empty) && getenv("ORAPERL_PAD_EMPTY")) + sv_setiv(ora_pad_empty, atoi(getenv("ORAPERL_PAD_EMPTY"))); + } + imp_sth->ora_pad_empty = (SvOK(ora_pad_empty)) ? SvIV(ora_pad_empty) : 0; + } + + imp_sth->auto_lob = 1; + if (attribs) { + SV **svp; + DBD_ATTRIB_GET_IV( attribs, "ora_parse_lang", 14, svp, oparse_lng); + DBD_ATTRIB_GET_IV( attribs, "ora_auto_lob", 12, svp, imp_sth->auto_lob); + /* ora_check_sql only works for selects owing to Oracle behaviour */ + DBD_ATTRIB_GET_IV( attribs, "ora_check_sql", 13, svp, ora_check_sql); + } + + /* scan statement for '?', ':1' and/or ':foo' style placeholders */ + dbd_preparse(imp_sth, statement); + + imp_sth->envhp = imp_dbh->envhp; + imp_sth->errhp = imp_dbh->errhp; + imp_sth->srvhp = imp_dbh->srvhp; + imp_sth->svchp = imp_dbh->svchp; + + switch(oparse_lng) { + case 0: /* old: calls for V6 syntax - give them V7 */ + case 2: /* old: calls for V7 syntax */ + case 7: oparse_lng = OCI_V7_SYNTAX; break; + case 8: oparse_lng = OCI_V8_SYNTAX; break; + default: oparse_lng = OCI_NTV_SYNTAX; break; + } + + OCIHandleAlloc_ok(imp_dbh->envhp, &imp_sth->stmhp, OCI_HTYPE_STMT, status); + OCIStmtPrepare_log_stat(imp_sth->stmhp, imp_sth->errhp, + (text*)imp_sth->statement, (ub4)strlen(imp_sth->statement), + oparse_lng, OCI_DEFAULT, status); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCIStmtPrepare"); + OCIHandleFree_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, status); + return 0; + } + + OCIAttrGet_stmhp_stat(imp_sth, &imp_sth->stmt_type, 0, OCI_ATTR_STMT_TYPE, status); + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " dbd_st_prepare'd sql %s\n", + oci_stmt_type_name(imp_sth->stmt_type)); + + DBIc_IMPSET_on(imp_sth); + + if (ora_check_sql) { + if (!dbd_describe(sth, imp_sth)) + return 0; + } + + return 1; +} + + +sb4 +dbd_phs_in(dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index, + dvoid **bufpp, ub4 *alenp, ub1 *piecep, dvoid **indpp) +{ + phs_t *phs = octxp; + STRLEN phs_len; + if (phs->desc_h) { + *bufpp = phs->desc_h; + phs->alen = 0; + phs->indp = 0; + } + else + if (SvOK(phs->sv)) { + *bufpp = SvPV(phs->sv, phs_len); + phs->alen = (phs->alen_incnull) ? phs_len+1 : phs_len;; + phs->indp = 0; + } + else { + *bufpp = SvPVX(phs->sv); /* not actually used? */ + phs->alen = 0; + phs->indp = -1; + } + *alenp = phs->alen; + *indpp = &phs->indp; + *piecep = OCI_ONE_PIECE; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " dbd_phs_in '%s' (%ld,%ld): len %2ld, ind %d%s\n", + phs->name, ul_t(iter), ul_t(index), ul_t(phs->alen), phs->indp, + (phs->desc_h) ? " via descriptor" : ""); + if (index > 0 || iter > 0) + croak("Arrays and multiple iterations not currently supported by DBD::Oracle"); + return OCI_CONTINUE; +} + +sb4 +dbd_phs_out(dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index, + dvoid **bufpp, ub4 **alenpp, ub1 *piecep, + dvoid **indpp, ub2 **rcodepp) +{ + phs_t *phs = octxp; + if (phs->desc_h) { + *bufpp = phs->desc_h; + phs->alen = 0; + } + else { + *bufpp = SvPVX(phs->sv); + phs->alen = SvLEN(phs->sv); /* max buffer size now, actual data len later */ + } + *alenpp = &phs->alen; + *indpp = &phs->indp; + *rcodepp= &phs->arcode; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " dbd_phs_out '%s' (%ld,%ld): len %2ld, piece %d%s\n", + phs->name, ul_t(iter), ul_t(index), ul_t(phs->alen), *piecep, + (phs->desc_h) ? " via descriptor" : ""); + if (index > 0 || iter > 0) + croak("Arrays and multiple iterations not currently supported by DBD::Oracle"); + *piecep = OCI_ONE_PIECE; + return OCI_CONTINUE; +} + + +static int +fetch_func_varfield(SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV *dest_sv) +{ + fb_ary_t *fb_ary = fbh->fb_ary; + char *p = (char*)&fb_ary->abuf[0]; + ub4 datalen = *(ub4*)p; /* XXX alignment ? */ + p += 4; + sv_setpvn(dest_sv, p, (STRLEN)datalen); + return 1; +} + + +/* ------ */ + + +#ifdef moved_to_dbdimp +int +pp_exec_rset(SV *sth, imp_sth_t *imp_sth, phs_t *phs, int pre_exec) +{ + if (pre_exec) { /* pre-execute - allocate a statement handle */ + dSP; + D_imp_dbh_from_sth; + SV *sth_i; + HV *init_attr = newHV(); + int count; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " bind %s - allocating new sth...\n", phs->name); + ENTER; + PUSHMARK(SP); + XPUSHs(sv_2mortal(newRV(DBIc_MY_H(imp_dbh)))); + XPUSHs(sv_2mortal(newRV((SV*)init_attr))); + PUTBACK; + count = perl_call_pv("DBI::_new_sth", G_ARRAY); + SPAGAIN; + if (count != 2) + croak("panic: DBI::_new_sth returned %d values instead of 2", count); + sth_i = SvREFCNT_inc(POPs); + sv_setsv(phs->sv, SvREFCNT_inc(POPs)); /* outer handle */ + PUTBACK; + LEAVE; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " bind %s - allocated %s...\n", + phs->name, neatsvpv(phs->sv, 0)); + + } + else { /* post-execute - setup the statement handle */ + dTHR; + SV * sth_csr = phs->sv; + D_impdata(imp_sth_csr, imp_sth_t, sth_csr); + + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " bind %s - initialising new %s...\n", + phs->name, neatsvpv(sth_csr,0)); + +#ifdef OCI_V8_SYNTAX + /* copy appropriate handles from parent statement */ + imp_sth_csr->envhp = imp_sth->envhp; + imp_sth_csr->errhp = imp_sth->errhp; + imp_sth_csr->srvhp = imp_sth->srvhp; + imp_sth_csr->svchp = imp_sth->svchp; + + /* assign statement handle from placeholder descriptor */ + imp_sth_csr->stmhp = phs->desc_h; + imp_sth_csr->disable_finish = 1; /* else finish core dumps in kpuccan()! */ + + /* force stmt_type since OCIAttrGet(OCI_ATTR_STMT_TYPE) doesn't work! */ + imp_sth_csr->stmt_type = OCI_STMT_SELECT; +#else + +#endif + + DBIc_IMPSET_on(imp_sth); + + /* set ACTIVE so dbd_describe doesn't do explicit OCI describe */ + DBIc_ACTIVE_on(imp_sth_csr); + if (!dbd_describe(sth_csr, imp_sth_csr)) { + return 0; + } + } + return 1; +} +#endif + + +int +dbd_rebind_ph_rset(SV *sth, imp_sth_t *imp_sth, phs_t *phs) +{ +#ifndef MM_CURSOR_FIX + /* Only do this part for inout cursor refs because pp_exec_rset only gets called for all the output params */ + if (phs->is_inout) { +#endif + phs->out_prepost_exec = pp_exec_rset; + return 2; /* OCI bind done */ +#ifndef MM_CURSOR_FIX + } + else { + /* Call a special rebinder for cursor ref "in" params */ + return(pp_rebind_ph_rset_in(sth, imp_sth, phs)); + } +#endif +} + + +/* ------ */ + +int +dbd_rebind_ph_lob(SV *sth, imp_sth_t *imp_sth, phs_t *phs) +{ + sword status; + ub4 lobEmpty = 0; + + if (!phs->desc_h) { + ++imp_sth->has_lobs; + phs->desc_t = OCI_DTYPE_LOB; + OCIDescriptorAlloc_ok(imp_sth->envhp, + &phs->desc_h, phs->desc_t); + } + OCIAttrSet_log_stat(phs->desc_h, phs->desc_t, + &lobEmpty, 0, OCI_ATTR_LOBEMPTY, imp_sth->errhp, status); + if (status != OCI_SUCCESS) + return oci_error(sth, imp_sth->errhp, status, "OCIAttrSet OCI_ATTR_LOBEMPTY"); + phs->progv = (void*)&phs->desc_h; + phs->maxlen = sizeof(OCILobLocator*); + + return 1; +} + + +ub4 +ora_blob_read_piece(SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV *dest_sv, + long offset, long len, long destoffset) +{ + ub4 loblen = 0; + ub4 buflen; + ub4 amtp = 0; + OCILobLocator *lobl = (OCILobLocator*)fbh->desc_h; + sword ftype = fbh->ftype; + sword status; + + if (ftype != 112 && ftype != 113) { + oci_error(sth, imp_sth->errhp, OCI_ERROR, + "blob_read not currently supported for non-LOB types with OCI 8 " + "(but with OCI 8 you can set $dbh->{LongReadLen} to the length you need," + "so you don't need to call blob_read at all)"); + (void)SvOK_off(dest_sv); /* signal error */ + return 0; + } + + OCILobGetLength_log_stat(imp_sth->svchp, imp_sth->errhp, lobl, &loblen, status); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCILobGetLength"); + (void)SvOK_off(dest_sv); /* signal error */ + return 0; + } + + amtp = (loblen > len) ? len : loblen; + buflen = amtp; /* set right semantics for OCILobRead */ + + /* + * We assume our caller has already done the + * equivalent of the following: + * (void)SvUPGRADE(dest_sv, SVt_PV); + * SvGROW(dest_sv, buflen+destoffset+1); + */ + + if (loblen > 0) { + ub1 * bufp = (ub1 *)(SvPVX(dest_sv)); + bufp += destoffset; + + OCILobRead_log_stat(imp_sth->svchp, imp_sth->errhp, lobl, + &amtp, 1 + offset, bufp, buflen, + 0, 0, 0, SQLCS_IMPLICIT, status); + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " OCILobRead field %d %s: LOBlen %ld, LongReadLen %ld, BufLen %ld, Got %ld\n", + fbh->field_num+1, oci_status_name(status), ul_t(loblen), + imp_sth->long_readlen, ul_t(buflen), ul_t(amtp)); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCILobRead"); + (void)SvOK_off(dest_sv); /* signal error */ + return 0; + } + } + else { + assert(amtp == 0); + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " OCILobRead field %d %s: LOBlen %ld, LongReadLen %ld, BufLen %ld, Got %ld\n", + fbh->field_num+1, "SKIPPED", ul_t(loblen), + imp_sth->long_readlen, ul_t(buflen), ul_t(amtp)); + } + + /* + * We assume our caller will perform + * the equivalent of the following: + * SvCUR(dest_sv) = amtp; + * *SvEND(dest_sv) = '\0'; + * SvPOK_on(dest_sv); + */ + + return(amtp); +} + + + +static int +fetch_func_autolob(SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV *dest_sv) +{ + ub4 loblen = 0; + ub4 buflen; + ub4 amtp = 0; + OCILobLocator *lobloc = (OCILobLocator*)fbh->desc_h; + sword status; + + /* this function is not called for NULL lobs */ + + OCILobGetLength_log_stat(imp_sth->svchp, imp_sth->errhp, lobloc, &loblen, status); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCILobGetLength"); + return 0; + } + + amtp = (loblen > imp_sth->long_readlen) ? imp_sth->long_readlen : loblen; + buflen = amtp; /* set right semantics for OCILobRead */ + + if (loblen > imp_sth->long_readlen) { /* LOB will be truncated */ + int oraperl = DBIc_COMPAT(imp_sth); + if (DBIc_has(imp_sth,DBIcf_LongTruncOk) || (oraperl && SvIV(ora_trunc))) { + /* user says truncation is ok */ + /* Oraperl recorded the truncation in ora_errno so we */ + /* so also but only for Oraperl mode handles. */ + if (oraperl) + sv_setiv(DBIc_ERR(imp_sth), 1406); + } + else { + char buf[300]; + sprintf(buf,"fetching field %d of %d. LOB value truncated from %ld to %ld. %s", + fbh->field_num+1, DBIc_NUM_FIELDS(imp_sth), ul_t(amtp), ul_t(amtp), + "DBI attribute LongReadLen too small and/or LongTruncOk not set"); + oci_error(sth, NULL, OCI_ERROR, buf); + sv_setiv(DBIc_ERR(imp_sth), (IV)24345); /* appropriate ORA error number */ + (void)SvOK_off(dest_sv); + return 0; + } + } + + (void)SvUPGRADE(dest_sv, SVt_PV); + SvGROW(dest_sv, buflen+1); + + if (loblen > 0) { + OCILobRead_log_stat(imp_sth->svchp, imp_sth->errhp, lobloc, + &amtp, 1, SvPVX(dest_sv), buflen, 0, 0, 0, SQLCS_IMPLICIT, status); + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " OCILobRead field %d %s: LOBlen %ld, LongReadLen %ld, BufLen %ld, Got %ld\n", + fbh->field_num+1, oci_status_name(status), ul_t(loblen), + imp_sth->long_readlen, ul_t(buflen), ul_t(amtp)); + if (status != OCI_SUCCESS) { + oci_error(sth, imp_sth->errhp, status, "OCILobRead"); + (void)SvOK_off(dest_sv); + return 0; + } + } + else { + assert(amtp == 0); + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " OCILobRead field %d %s: LOBlen %ld, LongReadLen %ld, BufLen %ld, Got %ld\n", + fbh->field_num+1, "SKIPPED", ul_t(loblen), + imp_sth->long_readlen, ul_t(buflen), ul_t(amtp)); + } + + /* tell perl what we've put in its dest_sv */ + SvCUR(dest_sv) = amtp; + *SvEND(dest_sv) = '\0'; + SvPOK_on(dest_sv); + + return 1; +} + + +static int +fetch_func_loblocator(SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV *dest_sv) +{ + /* + OCILobLocator *lobl = (OCILobLocator*)fbh->desc_h; + sword status; + */ + sv_setsv(dest_sv, &sv_no); + croak("LOB Locators are not directly accessible yet."); + return 1; +} + + +int +dbd_describe(SV *h, imp_sth_t *imp_sth) +{ + D_imp_dbh_from_sth; + I32 long_readlen; + ub4 num_fields; + int has_longs = 0; + int est_width = 0; /* estimated avg row width (for cache) */ + int i = 0; + sword status; + + if (imp_sth->done_desc) + return 1; /* success, already done it */ + imp_sth->done_desc = 1; + + /* ora_trunc is checked at fetch time */ + /* long_readlen: length for long/longraw (if >0), else 80 (ora app dflt) */ + /* Ought to be for COMPAT mode only but was relaxed before LongReadLen existed */ + long_readlen = (SvOK(ora_long) && SvIV(ora_long)>0) + ? SvIV(ora_long) : DBIc_LongReadLen(imp_sth); + if (long_readlen < 0) /* trap any sillyness */ + long_readlen = 80; /* typical oracle app default */ + + if (imp_sth->stmt_type != OCI_STMT_SELECT) { + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " dbd_describe skipped for %s\n", + oci_stmt_type_name(imp_sth->stmt_type)); + /* imp_sth memory was cleared when created so no setup required here */ + return 1; + } + + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " dbd_describe %s (%s, lb %ld)...\n", + oci_stmt_type_name(imp_sth->stmt_type), + DBIc_ACTIVE(imp_sth) ? "implicit" : "EXPLICIT", (long)long_readlen); + + /* We know it's a select and we've not got the description yet, so if the */ + /* sth is not 'active' (executing) then we need an explicit describe. */ + if ( !DBIc_ACTIVE(imp_sth) ) { + OCIStmtExecute_log_stat(imp_sth->svchp, imp_sth->stmhp, imp_sth->errhp, + 0, 0, 0, 0, OCI_DESCRIBE_ONLY, status); + if (status != OCI_SUCCESS) { + oci_error(h, imp_sth->errhp, status, + ora_sql_error(imp_sth, "OCIStmtExecute/Describe")); + return 0; + } + } + + OCIAttrGet_stmhp_stat(imp_sth, &num_fields, 0, OCI_ATTR_PARAM_COUNT, status); + if (status != OCI_SUCCESS) { + oci_error(h, imp_sth->errhp, status, "OCIAttrGet OCI_ATTR_PARAM_COUNT"); + return 0; + } + DBIc_NUM_FIELDS(imp_sth) = num_fields; + Newz(42, imp_sth->fbh, num_fields, imp_fbh_t); + + + /* Get number of fields and space needed for field names */ + for(i = 1; i <= num_fields; ++i) { + char *p; + ub4 atrlen; + int avg_width = 0; + imp_fbh_t *fbh = &imp_sth->fbh[i-1]; + fbh->imp_sth = imp_sth; + fbh->field_num = i; + + OCIParamGet_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, imp_sth->errhp, + (dvoid*)&fbh->parmdp, (ub4)i, status); + if (status != OCI_SUCCESS) { + oci_error(h, imp_sth->errhp, status, "OCIParamGet"); + return 0; + } + + OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->dbtype, 0, OCI_ATTR_DATA_TYPE, status); + OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->dbsize, 0, OCI_ATTR_DATA_SIZE, status); + /* OCI_ATTR_PRECISION returns 0 for most types including some numbers */ + OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->prec, 0, OCI_ATTR_PRECISION, status); + OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->scale, 0, OCI_ATTR_SCALE, status); + OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->nullok, 0, OCI_ATTR_IS_NULL, status); + OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->name, &atrlen, OCI_ATTR_NAME,status); + fbh->name_sv = newSVpv(fbh->name,atrlen); + fbh->name = SvPVX(fbh->name_sv); + + fbh->ftype = 5; /* default: return as null terminated string */ + switch (fbh->dbtype) { + /* the simple types */ + case 1: /* VARCHAR2 */ + case 96: /* CHAR */ + fbh->disize = fbh->dbsize; + fbh->prec = fbh->disize; + break; + case 23: /* RAW */ + fbh->disize = fbh->dbsize * 2; + fbh->prec = fbh->disize; + break; + + case 2: /* NUMBER */ + if (!fbh->prec) /* is 0 for FLOATing point */ + fbh->prec = 38; /* max prec */ + fbh->disize = 130+3; /* worst case! 1**-130 */ + avg_width = 4; /* > approx +/- 1_000_000 ? */ + break; + + case 12: /* DATE */ + /* actually dependent on NLS default date format*/ + fbh->disize = 75; /* a generous default */ + fbh->prec = fbh->disize; + break; + + case 8: /* LONG */ + fbh->disize = long_readlen; + fbh->dbsize = (fbh->disize>65535) ? 65535 : fbh->disize; + fbh->ftype = 94; /* VAR form */ + fbh->fetch_func = fetch_func_varfield; + ++has_longs; + break; + case 24: /* LONG RAW */ + fbh->disize = long_readlen * 2; + fbh->dbsize = (fbh->disize>65535) ? 65535 : fbh->disize; + fbh->ftype = 95; /* VAR form */ + fbh->fetch_func = fetch_func_varfield; + ++has_longs; + break; + + case 11: /* ROWID */ + case 104: /* ROWID Desc */ + fbh->disize = 20; + fbh->prec = fbh->disize; + break; + + case 112: /* CLOB */ + case 113: /* BLOB */ + fbh->ftype = fbh->dbtype; + fbh->disize = fbh->dbsize; + fbh->fetch_func = (imp_sth->auto_lob) + ? fetch_func_autolob : fetch_func_loblocator; + fbh->desc_t = OCI_DTYPE_LOB; + OCIDescriptorAlloc_ok(imp_sth->envhp, &fbh->desc_h, fbh->desc_t); + break; + + case 105: /* MLSLABEL */ + case 108: /* User Defined */ + case 111: /* REF */ + default: + /* XXX unhandled type may lead to errors or worse */ + fbh->disize = fbh->dbsize; + p = "Field %d has an Oracle type (%d) which is not explicitly supported"; + if (DBIS->debug >= 1) + fprintf(DBILOGFP, p, i, fbh->dbtype); + if (dowarn) + warn(p, i, fbh->dbtype); + break; + } + if (fbh->ftype == 5) + fbh->disize += 1; /* allow for null terminator */ + + /* dbsize can be zero for 'select NULL ...' */ + imp_sth->t_dbsize += fbh->dbsize; + if (!avg_width) + avg_width = fbh->dbsize; + est_width += avg_width; + + if (DBIS->debug >= 2) + dbd_fbh_dump(fbh, i, 0); + } + imp_sth->est_width = est_width; + + /* --- Setup the row cache for this query --- */ + + /* number of rows to cache */ + if (SvOK(ora_cache_o)) imp_sth->cache_rows = SvIV(ora_cache_o); + else if (SvOK(ora_cache)) imp_sth->cache_rows = SvIV(ora_cache); + else imp_sth->cache_rows = imp_dbh->RowCacheSize; + if (imp_sth->cache_rows >= 0) { /* set cache size by row count */ + ub4 cache_rows = calc_cache_rows(num_fields, + est_width, imp_sth->cache_rows, has_longs); + imp_sth->cache_rows = cache_rows; /* record updated value */ + OCIAttrSet_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, + &cache_rows, sizeof(cache_rows), OCI_ATTR_PREFETCH_ROWS, + imp_sth->errhp, status); + if (status != OCI_SUCCESS) { + oci_error(h, imp_sth->errhp, status, "OCIAttrSet OCI_ATTR_PREFETCH_ROWS"); + return 0; + } + } + else { /* set cache size by memory */ + ub4 cache_mem = -imp_sth->cache_rows; + ub4 cache_rows = 100000; /* set high so memory is the limit */ + OCIAttrSet_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, + &cache_rows, sizeof(cache_rows), OCI_ATTR_PREFETCH_ROWS, + imp_sth->errhp, status); + if (! status) { + OCIAttrSet_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, + &cache_mem, sizeof(cache_mem), OCI_ATTR_PREFETCH_MEMORY, + imp_sth->errhp, status); + } + if (status != OCI_SUCCESS) { + oci_error(h, imp_sth->errhp, status, + "OCIAttrSet OCI_ATTR_PREFETCH_ROWS/OCI_ATTR_PREFETCH_MEMORY"); + return 0; + } + } + + imp_sth->long_readlen = long_readlen; + /* Initialise cache counters */ + imp_sth->in_cache = 0; + imp_sth->eod_errno = 0; + + for(i=1; i <= num_fields; ++i) { + imp_fbh_t *fbh = &imp_sth->fbh[i-1]; + int ftype = fbh->ftype; + /* add space for STRING null term, or VAR len prefix */ + sb4 define_len = (ftype==94||ftype==95) ? fbh->disize+4 : fbh->disize; + fb_ary_t *fb_ary; + + fbh->fb_ary = fb_ary_alloc(define_len, 1); + fb_ary = fbh->fb_ary; + + OCIDefineByPos_log_stat(imp_sth->stmhp, &fbh->defnp, imp_sth->errhp, (ub4) i, + (fbh->desc_h) ? (dvoid*)&fbh->desc_h : (dvoid*)fb_ary->abuf, + (fbh->desc_h) ? -1 : define_len, + fbh->ftype, + fb_ary->aindp, + (ftype==94||ftype==95) ? NULL : fb_ary->arlen, + fb_ary->arcode, OCI_DEFAULT, status); + if (status != OCI_SUCCESS) { + oci_error(h, imp_sth->errhp, status, "OCIDefineByPos"); + return 0; + } + + } + + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " dbd_describe'd %d columns (row bytes: %d max, %d est avg, cache: %d)\n", + (int)num_fields, imp_sth->t_dbsize, imp_sth->est_width, imp_sth->cache_rows); + + return 1; +} + + +AV * +dbd_st_fetch(SV *sth, imp_sth_t *imp_sth) +{ + sword status; + int num_fields = DBIc_NUM_FIELDS(imp_sth); + int ChopBlanks; + int err; + int i; + AV *av; + + /* Check that execute() was executed sucessfully. This also implies */ + /* that dbd_describe() executed sucessfuly so the memory buffers */ + /* are allocated and bound. */ + if ( !DBIc_ACTIVE(imp_sth) ) { + oci_error(sth, NULL, OCI_ERROR, + "no statement executing (perhaps you need to call execute first)"); + return Nullav; + } + + if (ora_fetchtest && DBIc_ROW_COUNT(imp_sth)>0) { + --ora_fetchtest; /* trick for testing performance */ + status = OCI_SUCCESS; + } + else { + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " dbd_st_fetch %d fields...\n", DBIc_NUM_FIELDS(imp_sth)); + OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 1, OCI_FETCH_NEXT, + OCI_DEFAULT, status); + } + + if (status != OCI_SUCCESS) { + ora_fetchtest = 0; + if (status == OCI_NO_DATA) { + dTHR; /* for DBIc_ACTIVE_off */ + DBIc_ACTIVE_off(imp_sth); /* eg finish */ + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " dbd_st_fetch no-more-data\n"); + return Nullav; + } + if (status != OCI_SUCCESS_WITH_INFO) { + dTHR; /* for DBIc_ACTIVE_off */ + DBIc_ACTIVE_off(imp_sth); /* eg finish */ + oci_error(sth, imp_sth->errhp, status, "OCIStmtFetch"); + return Nullav; + } + /* for OCI_SUCCESS_WITH_INFO we fall through and let the */ + /* per-field rcode value be dealt with as we fetch the data */ + } + + av = DBIS->get_fbav(imp_sth); + + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " dbd_st_fetch %d fields %s\n", + num_fields, oci_status_name(status)); + + ChopBlanks = DBIc_has(imp_sth, DBIcf_ChopBlanks); + + err = 0; + for(i=0; i < num_fields; ++i) { + imp_fbh_t *fbh = &imp_sth->fbh[i]; + fb_ary_t *fb_ary = fbh->fb_ary; + int rc = fb_ary->arcode[0]; + SV *sv = AvARRAY(av)[i]; /* Note: we (re)use the SV in the AV */ + + if (rc == 1406 /* field was truncated */ + && ora_dbtype_is_long(fbh->dbtype)/* field is a LONG */ + ) { + int oraperl = DBIc_COMPAT(imp_sth); + if (DBIc_has(imp_sth,DBIcf_LongTruncOk) || (oraperl && SvIV(ora_trunc))) { + /* user says truncation is ok */ + /* Oraperl recorded the truncation in ora_errno so we */ + /* so also but only for Oraperl mode handles. */ + if (oraperl) + sv_setiv(DBIc_ERR(imp_sth), (IV)rc); + rc = 0; /* but don't provoke an error here */ + } + /* else fall through and let rc trigger failure below */ + } + + if (rc == 0) { /* the normal case */ + if (fbh->fetch_func) { + if (!fbh->fetch_func(sth, imp_sth, fbh, sv)) + ++err; /* fetch_func already called oci_error */ + } + else { + int datalen = fb_ary->arlen[0]; + char *p = (char*)&fb_ary->abuf[0]; + /* if ChopBlanks check for Oracle CHAR type (blank padded) */ + if (ChopBlanks && fbh->dbtype == 96) { + while(datalen && p[datalen - 1]==' ') + --datalen; + } + sv_setpvn(sv, p, (STRLEN)datalen); + } + + } else if (rc == 1405) { /* field is null - return undef */ + (void)SvOK_off(sv); + + } else { /* See odefin rcode arg description in OCI docs */ + char buf[200]; + char *hint = ""; + /* These may get more case-by-case treatment eventually. */ + if (rc == 1406) { /* field truncated (see above) */ + if (!fbh->fetch_func) { + /* Copy the truncated value anyway, it may be of use, */ + /* but it'll only be accessible via prior bind_column() */ + sv_setpvn(sv, (char*)&fb_ary->abuf[0], + fb_ary->arlen[0]); + } + if (ora_dbtype_is_long(fbh->dbtype)) /* double check */ + hint = ", LongReadLen too small and/or LongTruncOk not set"; + } + else { + (void)SvOK_off(sv); /* set field that caused error to undef */ + } + ++err; /* 'fail' this fetch but continue getting fields */ + /* Some should probably be treated as warnings but */ + /* for now we just treat them all as errors */ + sprintf(buf,"ORA-%05d error on field %d of %d, ora_type %d%s", + rc, i+1, num_fields, fbh->dbtype, hint); + oci_error(sth, imp_sth->errhp, OCI_ERROR, buf); + } + + if (DBIS->debug >= 5) + fprintf(DBILOGFP, " %d (rc=%d): %s\n", + i, rc, neatsvpv(sv,0)); + } + + return (err) ? Nullav : av; +} + + +ub4 +ora_parse_uid(imp_dbh, uidp, pwdp) + imp_dbh_t *imp_dbh; + char **uidp; + char **pwdp; +{ + sword status; + /* OCI 8 does not seem to allow uid to be "name/pass" :-( */ + /* so we have to split it up ourselves */ + if (strlen(*pwdp)==0 && strchr(*uidp,'/')) { + SV *tmpsv = sv_2mortal(newSVpv(*uidp,0)); + *uidp = SvPVX(tmpsv); + *pwdp = strchr(*uidp, '/'); + *(*pwdp)++ = '\0'; + /* XXX look for '@', e.g. "u/p@d" and "u@d" and maybe "@d"? */ + } + if (**uidp == '\0' && **pwdp == '\0') { + return OCI_CRED_EXT; + } + OCIAttrSet_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION, + *uidp, strlen(*uidp), + (ub4) OCI_ATTR_USERNAME, imp_dbh->errhp, status); + OCIAttrSet_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION, + (strlen(*pwdp)) ? *pwdp : NULL, strlen(*pwdp), + (ub4) OCI_ATTR_PASSWORD, imp_dbh->errhp, status); + return OCI_CRED_RDBMS; +} + + +int +ora_db_reauthenticate(dbh, imp_dbh, uid, pwd) + SV *dbh; + imp_dbh_t *imp_dbh; + char * uid; + char * pwd; +{ + sword status; + /* XXX should possibly create new session before ending the old so */ + /* that if the new one can't be created, the old will still work. */ + OCISessionEnd_log_stat(imp_dbh->svchp, imp_dbh->errhp, + imp_dbh->authp, OCI_DEFAULT, status); /* XXX check status here?*/ + OCISessionBegin_log_stat( imp_dbh->svchp, imp_dbh->errhp, imp_dbh->authp, + ora_parse_uid(imp_dbh, &uid, &pwd), (ub4) OCI_DEFAULT, status); + if (status != OCI_SUCCESS) { + oci_error(dbh, imp_dbh->errhp, status, "OCISessionBegin"); + return 0; + } + return 1; +} + + +#ifdef not_used_curently +static char * +rowid2hex(OCIRowid *rowid) +{ + int i; + SV *sv = sv_2mortal(newSVpv("",0)); + for (i = 0; i < OCI_ROWID_LEN; i++) { + char buf[6]; + sprintf(buf, "%02X ", (int)(((ub1*)rowid)[i])); + sv_catpv(sv, buf); + } + return SvPVX(sv); +} +#endif + + +static void * +alloc_via_sv(STRLEN len, SV **svp, int mortal) +{ + SV *sv = newSVpv("",0); + sv_grow(sv, len+1); + memset(SvPVX(sv), 0, len); + if (mortal) + sv_2mortal(sv); + if (svp) + *svp = sv; + return SvPVX(sv); +} + + +char * +find_ident_after(char *src, char *after, STRLEN *len, int copy) +{ + int seen_key = 0; + char *orig = src; + char *p; + while(*src) { + if (*src == '\'' || *src == '"') { + char delim = *src; + while(*src && *src != delim) ++src; + } + else if (*src == '-' && src[1] == '-') { + while(*src && *src != '\n') ++src; + } + else if (*src == '/' && src[1] == '*') { + while(*src && !(*src == '*' && src[1]=='/')) ++src; + } + else if (isALPHA(*src)) { + if (seen_key) { + char *start = src; + while(*src && (isALNUM(*src) || *src=='.')) + ++src; + *len = src - start; + if (copy) { + p = alloc_via_sv(*len, 0, 1); + strncpy(p, start, *len); + p[*len] = '\0'; + return p; + } + return start; + } + else if ( toLOWER(*src)==toLOWER(*after) + && (src==orig ? 1 : !isALPHA(src[-1])) + ) { + p = after; + while(*p && *src && toLOWER(*p)==toLOWER(*src)) + ++p, ++src; + if (!*p) + seen_key = 1; + } + ++src; + } + else + ++src; + } + return NULL; +} + + +struct lob_refetch_st { + SV *sql_select; + OCIStmt *stmthp; + OCIBind *bindhp; + OCIRowid *rowid; + OCIParam *parmdp_tmp; + OCIParam *parmdp_lob; + int num_fields; + SV *fbh_ary_sv; + imp_fbh_t *fbh_ary; +}; + + +static int +init_lob_refetch(SV *sth, imp_sth_t *imp_sth) +{ + SV *sv; + SV *sql_select; + HV *lob_cols_hv = NULL; + sword status; + OCIError *errhp = imp_sth->errhp; + OCIDescribe *dschp = NULL; + OCIParam *parmhp = NULL, *collisthd = NULL; + ub2 numcols = 0; + imp_fbh_t *fbh; + int unmatched_params; + I32 i; + char *p; + lob_refetch_t *lr = NULL; + STRLEN tablename_len; + char *tablename; + + switch (imp_sth->stmt_type) { + case OCI_STMT_UPDATE: + tablename = find_ident_after(imp_sth->statement, + "update", &tablename_len, 1); + break; + case OCI_STMT_INSERT: + tablename = find_ident_after(imp_sth->statement, + "into", &tablename_len, 1); + break; + default: + return oci_error(sth, errhp, OCI_ERROR, + "LOB refetch attempted for unsupported statement type"); + } + if (!tablename) + return oci_error(sth, errhp, OCI_ERROR, + "Unable to parse table name for LOB refetch"); + + OCIHandleAlloc_ok(imp_sth->envhp, &dschp, OCI_HTYPE_DESCRIBE, status); + OCIDescribeAny_log_stat(imp_sth->svchp, errhp, tablename, strlen(tablename), + OCI_OTYPE_NAME, 1, OCI_PTYPE_TABLE, dschp, status); + if (status != OCI_SUCCESS) { + OCIHandleFree_log_stat(dschp, OCI_HTYPE_DESCRIBE, status); + return oci_error(sth, errhp, status, "OCIDescribeAny/LOB refetch"); + } + + OCIAttrGet_log_stat(dschp, OCI_HTYPE_DESCRIBE, + &parmhp, 0, OCI_ATTR_PARAM, errhp, status); + if ( ! status ) { + OCIAttrGet_log_stat(parmhp, OCI_DTYPE_PARAM, + &numcols, 0, OCI_ATTR_NUM_COLS, errhp, status); + } + if ( ! status ) { + OCIAttrGet_log_stat(parmhp, OCI_DTYPE_PARAM, + &collisthd, 0, OCI_ATTR_LIST_COLUMNS, errhp, status); + } + if (status != OCI_SUCCESS) { + OCIHandleFree_log_stat(dschp, OCI_HTYPE_DESCRIBE, status); + return oci_error(sth, errhp, status, "OCIDescribeAny/OCIAttrGet/LOB refetch"); + } + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " lob refetch from table %s, %d columns:\n", + tablename, numcols); + + for (i = 1; i <= numcols; i++) { + OCIParam *colhd; + ub2 col_dbtype; + char *col_name; + ub4 col_name_len; + OCIParamGet_log_stat(collisthd, OCI_DTYPE_PARAM, errhp, (dvoid**)&colhd, + i, status); + if (status) + break; + OCIAttrGet_log_stat(colhd, OCI_DTYPE_PARAM, &col_dbtype, 0, + OCI_ATTR_DATA_TYPE, errhp, status); + if (status) + break; + OCIAttrGet_log_stat(colhd, OCI_DTYPE_PARAM, &col_name, &col_name_len, + OCI_ATTR_NAME, errhp, status); + if (status) + break; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, " lob refetch table col %d: '%.*s' otype %d\n", + (int)i, (int)col_name_len,col_name, col_dbtype); + if (col_dbtype != SQLT_CLOB && col_dbtype != SQLT_BLOB) + continue; + if (!lob_cols_hv) + lob_cols_hv = newHV(); + sv = newSViv(col_dbtype); + (void)sv_setpvn(sv, col_name, col_name_len); + (void)SvIOK_on(sv); /* what a wonderful hack! */ + hv_store(lob_cols_hv, col_name,col_name_len, sv,0); + } + if (status != OCI_SUCCESS) { + OCIHandleFree_log_stat(dschp, OCI_HTYPE_DESCRIBE, status); + return oci_error(sth, errhp, status, + "OCIDescribeAny/OCIParamGet/OCIAttrGet/LOB refetch"); + } + if (!lob_cols_hv) + return oci_error(sth, errhp, OCI_ERROR, + "LOB refetch failed, no lobs in table"); + + /* our bind params are in %imp_sth->all_params_hv + our table cols are in %lob_cols_hv + we now iterate through our bind params + and allocate them to the appropriate table columns + */ + Newz(1, lr, 1, lob_refetch_t); + unmatched_params = 0; + lr->num_fields = 0; + lr->fbh_ary = alloc_via_sv(sizeof(imp_fbh_t) * HvKEYS(lob_cols_hv)+1, + &lr->fbh_ary_sv, 0); + + sql_select = newSVpv("select ",0); + + hv_iterinit(imp_sth->all_params_hv); + while( (sv = hv_iternextsv(imp_sth->all_params_hv, &p, &i)) != NULL ) { + int matched = 0; + phs_t *phs = (phs_t*)(void*)SvPVX(sv); + if (sv == &sv_undef || !phs) + croak("panic: unbound params"); + if (phs->ftype != SQLT_CLOB && phs->ftype != SQLT_BLOB) + continue; + + hv_iterinit(lob_cols_hv); + while( (sv = hv_iternextsv(lob_cols_hv, &p, &i)) != NULL ) { + char sql_field[200]; + if (phs->ora_field) { /* must match this phs by field name */ + if (SvCUR(phs->ora_field) != SvCUR(sv) + || ibcmp( SvPV(phs->ora_field,na), SvPV(sv,na), SvCUR(sv) ) ) + continue; + } + else /* basic dumb match by type */ + if (phs->ftype != SvIV(sv)) + continue; + else { /* got a type match - check it's safe */ + SV *sv_other; + char *p_other; + /* would any other lob field match this type? */ + while( (sv_other = hv_iternextsv(lob_cols_hv, &p_other, &i)) != NULL ) { + if (phs->ftype != SvIV(sv_other)) + continue; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " both %s and %s have type %d - ambiguous\n", + SvPV(sv,na), SvPV(sv_other,na), (int)SvIV(sv_other)); + Safefree(lr); + return oci_error(sth, errhp, OCI_ERROR, + "Need bind_param(..., { ora_field=>... }) attribute to identify table LOB field names"); + } + } + matched = 1; + sprintf(sql_field, "%s%s \"%s\"", + (SvCUR(sql_select)>7)?", ":"", p, &phs->name[1]); + sv_catpv(sql_select, sql_field); + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " lob refetch %s param: otype %d, matched field '%s' %s(%s)\n", + phs->name, phs->ftype, p, + (phs->ora_field) ? "by name " : "by type ", sql_field); + hv_delete(lob_cols_hv, p, i, 0); + fbh = &lr->fbh_ary[lr->num_fields++]; + fbh->name = phs->name; + fbh->dbtype = phs->ftype; + fbh->ftype = fbh->dbtype; + fbh->disize = 99; + fbh->desc_t = OCI_DTYPE_LOB; + OCIDescriptorAlloc_ok(imp_sth->envhp, &fbh->desc_h, fbh->desc_t); + break; /* we're done with this placeholder now */ + } + if (!matched) { + ++unmatched_params; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " lob refetch %s param: otype %d, UNMATCHED\n", + phs->name, phs->ftype); + } + } + if (unmatched_params) { + Safefree(lr); + return oci_error(sth, errhp, OCI_ERROR, + "Can't match some parameters to LOB fields in the table, check type and name"); + } + + sv_catpv(sql_select, " from "); + sv_catpv(sql_select, tablename); + sv_catpv(sql_select, " where rowid = :rid for update"); /* get row with lock */ + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " lob refetch sql: %s\n", SvPVX(sql_select)); + lr->sql_select = sql_select; + + lr->stmthp = NULL; + lr->bindhp = NULL; + lr->rowid = NULL; + lr->parmdp_tmp = NULL; + lr->parmdp_lob = NULL; + + + OCIHandleAlloc_ok(imp_sth->envhp, &lr->stmthp, OCI_HTYPE_STMT, status); + OCIStmtPrepare_log_stat(lr->stmthp, errhp, + (text*)SvPVX(sql_select), SvCUR(sql_select), OCI_NTV_SYNTAX, + OCI_DEFAULT, status); + if (status != OCI_SUCCESS) + return oci_error(sth, errhp, status, "OCIStmtPrepare/LOB refetch"); + + /* bind the rowid input */ + OCIDescriptorAlloc_ok(imp_sth->envhp, &lr->rowid, OCI_DTYPE_ROWID); + OCIBindByName_log_stat(lr->stmthp, &lr->bindhp, errhp, (text*)":rid", 4, + &lr->rowid, sizeof(OCIRowid*), SQLT_RDD, 0,0,0,0,0, OCI_DEFAULT, status); + if (status != OCI_SUCCESS) + return oci_error(sth, errhp, status, "OCIBindByPos/LOB refetch"); + + /* define the output fields */ + for(i=0; i < lr->num_fields; ++i) { + OCIDefine *defnp = NULL; + imp_fbh_t *fbh = &lr->fbh_ary[i]; + phs_t *phs; + SV **phs_svp = hv_fetch(imp_sth->all_params_hv, fbh->name,strlen(fbh->name), 0); + if (!phs_svp) + croak("panic: LOB refetch for '%s' param (%d) - name not found", + fbh->name,i+1); + phs = (phs_t*)(void*)SvPVX(*phs_svp); + fbh->special = phs; + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " lob refetch %d for '%s' param: ftype %d setup\n", + (int)i+1,fbh->name, fbh->dbtype); + OCIDefineByPos_log_stat(lr->stmthp, &defnp, errhp, i+1, + &fbh->desc_h, -1, fbh->ftype, 0,0,0, OCI_DEFAULT, status); + if (status != OCI_SUCCESS) + return oci_error(sth, errhp, status, "OCIDefineByPos/LOB refetch"); + } + + imp_sth->lob_refetch = lr; /* structure copy */ + return 1; +} + + +int +post_execute_lobs(SV *sth, imp_sth_t *imp_sth, ub4 row_count) /* XXX leaks handles on error */ +{ + /* To insert a new LOB transparently (without using 'INSERT . RETURNING .') */ + /* we have to insert an empty LobLocator and then fetch it back from the */ + /* server before we can call OCILobWrite on it! This function handles that. */ + sword status; + int i; + OCIError *errhp = imp_sth->errhp; + ub4 rowid_iter = 0; + lob_refetch_t *lr; + + if (row_count == 0) + return 1; /* nothing to do */ + if (row_count > 1) + return oci_error(sth, errhp, OCI_ERROR, "LOB refetch attempted for multiple rows"); + + if (!imp_sth->lob_refetch) + if (!init_lob_refetch(sth, imp_sth)) + return 0; /* init_lob_refetch already called oci_error */ + lr = imp_sth->lob_refetch; + + OCIAttrGet_stmhp_stat(imp_sth, (dvoid**)lr->rowid, &rowid_iter, OCI_ATTR_ROWID, + status); + if (status != OCI_SUCCESS) + return oci_error(sth, errhp, status, "OCIAttrGet OCI_ATTR_ROWID /LOB refetch"); + + OCIStmtExecute_log_stat(imp_sth->svchp, lr->stmthp, errhp, + 1, 0, NULL, NULL, OCI_DEFAULT, status); /* execute and fetch */ + if (status != OCI_SUCCESS) + return oci_error(sth, errhp, status, + ora_sql_error(imp_sth,"OCIStmtExecute/LOB refetch")); + + for(i=0; i < lr->num_fields; ++i) { + imp_fbh_t *fbh = &lr->fbh_ary[i]; + phs_t *phs = (phs_t*)fbh->special; + ub4 amtp = SvCUR(phs->sv); + if (amtp > 0) { /* since amtp==0 & OCI_ONE_PIECE fail (OCI 8.0.4) */ + OCILobWrite_log_stat(imp_sth->svchp, errhp, + fbh->desc_h, &amtp, 1, SvPVX(phs->sv), amtp, OCI_ONE_PIECE, + 0,0, 0,SQLCS_IMPLICIT, status); + } + else { + OCILobTrim_log_stat(imp_sth->svchp, errhp, fbh->desc_h, 0, status); + } + if (DBIS->debug >= 3) + fprintf(DBILOGFP, + " lob refetch %d for '%s' param: ftype %d, len %ld: %s %s\n", + i+1,fbh->name, fbh->dbtype, ul_t(amtp), + (amtp > 0) ? "LobWrite" : "LobTrim", oci_status_name(status)); + if (status != OCI_SUCCESS) { + return oci_error(sth, errhp, status, "OCILobTrim/OCILobWrite/LOB refetch"); + } + } + + return 1; +} + +void +ora_free_lob_refetch(SV *sth, imp_sth_t *imp_sth) +{ + lob_refetch_t *lr = imp_sth->lob_refetch; + int i; + sword status; + OCIHandleFree_log_stat(lr->stmthp, OCI_HTYPE_STMT, status); + if (status != OCI_SUCCESS) + oci_error(sth, imp_sth->errhp, status, "ora_free_lob_refetch/OCIHandleFree"); + for(i=0; i < lr->num_fields; ++i) { + imp_fbh_t *fbh = &lr->fbh_ary[i]; + ora_free_fbh_contents(fbh); + } + sv_free(lr->sql_select); + sv_free(lr->fbh_ary_sv); + Safefree(imp_sth->lob_refetch); + imp_sth->lob_refetch = NULL; +} + + +#endif diff --git a/ocitrace.h b/ocitrace.h new file mode 100644 index 00000000..8f832990 --- /dev/null +++ b/ocitrace.h @@ -0,0 +1,249 @@ +#ifdef OCI_V8_SYNTAX + +/* OCI functions "wrapped" to produce tracefile dumps (may be handy when giving + diagnostic info to Oracle Support, or just learning about OCI) + Macros are named "_log" as a mnemonic that they log to the tracefile if needed + Macros named "_log_stat" return status in last parameter. +*/ + +#define DBD_OCI_TRACEON (DBIS->debug >= 6) +#define DBD_OCI_TRACEFP (DBILOGFP) +#define OciTp ("OCI") /* OCI Trace Prefix */ +#define OciTstr(s) ((s) ? (text*)(s) : (text*)"") +#define ul_t(v) ((unsigned long)(v)) +#define pul_t(v) ((unsigned long *)(v)) +#define sl_t(v) ((signed long)(v)) +#define psl_t(v) ((signed long *)(v)) + +/* XXX TO DO + + 1. Add parenthesis around all macro args. (or do item 4 below case-by-case) + DMG: Partly done, sort of. At least the types all match the doc'd casts, anyway. + + 2. #define a set of OciTxxx macros for different types of parameters + that would allow + a: casting to be hidden + b: casting easily changed on different platforms (64bit etc) + c: mapping of some type values to strings, + d: return pointed-to value instead of pointer where applicable + + How to output arguments that are handles to opaque entities (OCIEnv*, etc)? + Output of pointer address is a quick n' dirty way of identifying + any number of handles that may be allocated.... yuck... + It sure would be nice to give something more mnemonic! (and meaningful!) + XXX Turn pointers into variable names by adding a prefix letter and, where + appropriate an &, thus: "...,&p%ld,...", + If done well the log will read like a compilable program. +*/ + + +#define OCIAttrGet_log_stat(th,ht,ah,sp,at,eh,stat) \ + stat = OCIAttrGet(th,ht,ah,sp,at,eh); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sAttrGet(%p,%lu,%p,%p,%lu,%p)=%s\n", \ + OciTp, (void*)th,ul_t(ht),(void*)ah,pul_t(sp),ul_t(at),(void*)eh,\ + oci_status_name(stat)),stat : stat + +#define OCIAttrGet_parmdp(imp_sth, parmdp, p, l, a, stat) \ + OCIAttrGet_log_stat(parmdp, OCI_DTYPE_PARAM, \ + (void*)(p), (l), (a), imp_sth->errhp, stat) + +#define OCIAttrGet_stmhp_stat(imp_sth, p, l, a, stat) \ + OCIAttrGet_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, \ + (void*)(p), (l), (a), imp_sth->errhp, stat) + +#define OCIAttrSet_log_stat(th,ht,ah,s,a,eh,stat) \ + stat=OCIAttrSet(th,ht,ah,s,a,eh); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sAttrSet(%p,%u,%p,%lu,%lu,%p)=%s\n", \ + OciTp, (void*)th,(ht),(void*)(ah),ul_t(s),ul_t(a),(void*)eh, \ + oci_status_name(stat)),stat : stat + +#define OCIBindByName_log_stat(sh,bp,eh,p,pl,v,vs,dt,in,al,rc,mx,cu,md,stat) \ + stat=OCIBindByName(sh,bp,eh,p,pl,v,vs,dt,in,al,rc,mx,cu,md); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sBindByName(%p,%p,%p,\"%s\",%ld,%p,%ld,%u,%p,%p,%p,%lu,%p,%lu)=%s\n",\ + OciTp, (void*)sh,(void*)bp,(void*)eh,p,sl_t(pl),(void*)(v), \ + sl_t(vs),(ub2)(dt),(void*)(in),(ub2*)(al),(ub2*)(rc), \ + ul_t((mx)),pul_t((cu)),ul_t((md)), \ + oci_status_name(stat)),stat : stat + +#define OCIBindDynamic_log(bh,eh,icx,cbi,ocx,cbo,stat) \ + stat=OCIBindDynamic(bh,eh,icx,cbi,ocx,cbo); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sBindDynamic(%p,%p,%p,%p,%p,%p)=%s\n", \ + OciTp, (void*)bh,(void*)eh,(void*)icx,(void*)cbi, \ + (void*)ocx,(void*)cbo, \ + oci_status_name(stat)),stat : stat + +#define OCIDefineByPos_log_stat(sh,dp,eh,p,vp,vs,dt,ip,rp,cp,m,stat) \ + stat=OCIDefineByPos(sh,dp,eh,p,vp,vs,dt,ip,rp,cp,m); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sDefineByPos(%p,%p,%p,%lu,%p,%ld,%u,%p,%p,%p,%lu)=%s\n", \ + OciTp, (void*)sh,(void*)dp,(void*)eh,ul_t((p)),(void*)(vp), \ + sl_t(vs),(ub2)dt,(void*)(ip),(ub2*)(rp),(ub2*)(cp),ul_t(m), \ + oci_status_name(stat)),stat : stat + +#define OCIDescribeAny_log_stat(sh,eh,op,ol,opt,il,ot,dh,stat) \ + stat=OCIDescribeAny(sh,eh,op,ol,opt,il,ot,dh); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sDescribeAny(%p,%p,%p,%lu,%u,%u,%u,%p)=%s\n", \ + OciTp, (void*)sh,(void*)eh,(void*)op,ul_t(ol), \ + (ub1)opt,(ub1)il,(ub1)ot,(void*)dh, \ + oci_status_name(stat)),stat : stat + +#define OCIDescriptorAlloc_ok(envhp, p, t) \ + if (DBD_OCI_TRACEON) fprintf(DBD_OCI_TRACEFP, \ + "%sDescriptorAlloc(%p,%p,%lu,0,0)\n", \ + OciTp,(void*)envhp,(void*)(p),ul_t(t)); \ + if (OCIDescriptorAlloc((envhp), (void**)(p), (t), 0, 0)==OCI_SUCCESS); \ + else croak("OCIDescriptorAlloc (type %ld) failed",t) + +#define OCIDescriptorFree_log(d,t) \ + if (DBD_OCI_TRACEON) fprintf(DBD_OCI_TRACEFP, \ + "%sDescriptorFree(%p,%lu)\n", OciTp, (void*)d,ul_t(t)); \ + OCIDescriptorFree(d,t) + +#define OCIEnvInit_log_stat(ev,md,xm,um,stat) \ + stat=OCIEnvInit(ev,md,xm,um); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sEnvInit(%p,%lu,%lu,%p)=%s\n", \ + OciTp, (void*)ev,ul_t(md),ul_t(xm),(void*)um, \ + oci_status_name(stat)),stat : stat + +#define OCIErrorGet_log_stat(hp,rn,ss,ep,bp,bs,t, stat) \ + ((stat = OCIErrorGet(hp,rn,ss,ep,bp,bs,t)), \ + ((DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sErrorGet(%p,%lu,\"%s\",%p,\"%s\",%lu,%lu)=%s\n", \ + OciTp, (void*)hp,ul_t(rn),OciTstr(ss),psl_t(ep), \ + bp,ul_t(bs),ul_t(t), oci_status_name(stat)),stat : stat)) + +#define OCIHandleAlloc_log_stat(ph,hp,t,xs,ump,stat) \ + stat=OCIHandleAlloc(ph,hp,t,xs,ump); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sHandleAlloc(%p,%p,%lu,%lu,%p)=%s\n", \ + OciTp, (void*)ph,(void*)hp,ul_t(t),ul_t(xs),(void*)ump, \ + oci_status_name(stat)),stat : stat + +#define OCIHandleAlloc_ok(envhp, p, t, stat) \ + OCIHandleAlloc_log_stat((envhp),(void**)(p),(t),0,0, stat); \ + if (stat==OCI_SUCCESS) ; \ + else croak("OCIHandleAlloc (type %lu) failed",ul_t(t)) + +#define OCIHandleFree_log_stat(hp,t,stat) \ + stat=OCIHandleFree( (hp), (t)); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sHandleFree(%p,%lu)=%s\n",OciTp,(void*)hp,ul_t(t), \ + oci_status_name(stat)),stat : stat + +#define OCIInitialize_log_stat(md,cp,mlf,rlf,mfp,stat) \ + stat=OCIInitialize(md,cp,mlf,rlf,mfp); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sInitialize(%lu,%p,%p,%p,%p)=%s\n", \ + OciTp, ul_t(md),(void*)cp,(void*)mlf,(void*)rlf,(void*)mfp, \ + oci_status_name(stat)),stat : stat + +#define OCILobGetLength_log_stat(sh,eh,lh,l,stat) \ + stat=OCILobGetLength(sh,eh,lh,l); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sLobGetLength(%p,%p,%p,%p)=%s\n", \ + OciTp, (void*)sh,(void*)eh,(void*)lh,pul_t(l), \ + oci_status_name(stat)),stat : stat + +#define OCILobRead_log_stat(sv,eh,lh,am,of,bp,bl,cx,cb,csi,csf,stat) \ + stat=OCILobRead(sv,eh,lh,am,of,bp,bl,cx,cb,csi,csf); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sLobRead(%p,%p,%p,%p,%lu,%p,%lu,%p,%p,%u,%u)=%s\n", \ + OciTp, (void*)sv,(void*)eh,(void*)lh,pul_t(am),ul_t(of), \ + (void*)bp,ul_t(bl),(void*)cx,(void*)cb,(ub2)csi,(ub1)csf, \ + oci_status_name(stat)),stat : stat + +#define OCILobTrim_log_stat(sv,eh,lh,l,stat) \ + stat=OCILobTrim(sv,eh,lh,l); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sLobtrim(%p,%p,%p,%lu)=%s\n", \ + OciTp, (void*)sv,(void*)eh,(void*)lh,ul_t(l), \ + oci_status_name(stat)),stat : stat + +#define OCILobWrite_log_stat(sv,eh,lh,am,of,bp,bl,p,cx,cb,csi,csf,stat) \ + stat=OCILobWrite(sv,eh,lh,am,of,bp,bl,p,cx,cb,csi,csf); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sLobWrite(%p,%p,%p,%p,%lu,%p,%lu,%u,%p,%p,%u,%u)=%s\n", \ + OciTp, (void*)sv,(void*)eh,(void*)lh,pul_t(am),ul_t(of), \ + (void*)bp,ul_t(bl),(ub1)p, \ + (void*)cx,(void*)cb,(ub2)csi,(ub1)csf, \ + oci_status_name(stat)),stat : stat + +#define OCIParamGet_log_stat(hp,ht,eh,pp,ps,stat) \ + stat=OCIParamGet(hp,ht,eh,pp,ps); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sParamGet(%p,%lu,%p,%p,%lu)=%s\n", \ + OciTp, (void*)hp,ul_t((ht)),(void*)eh,(void*)pp,ul_t(ps), \ + oci_status_name(stat)),stat : stat + +#define OCIServerAttach_log_stat(imp_dbh, dbname,stat) \ + stat=OCIServerAttach( imp_dbh->srvhp, imp_dbh->errhp, \ + (text*)dbname, strlen(dbname), 0); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sServerAttach(%p, %p, \"%s\", %d, 0)=%s\n", \ + OciTp, (void*)imp_dbh->srvhp,(void*)imp_dbh->errhp, dbname, \ + strlen(dbname), oci_status_name(stat)),stat : stat + +#define OCIStmtExecute_log_stat(sv,st,eh,i,ro,si,so,md,stat) \ + stat=OCIStmtExecute(sv,st,eh,i,ro,si,so,md); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sStmtExecute(%p,%p,%p,%lu,%lu,%p,%p,%lu)=%s\n", \ + OciTp, (void*)sv,(void*)st,(void*)eh,ul_t((i)), \ + ul_t((ro)),(void*)(si),(void*)(so),ul_t((md)), \ + oci_status_name(stat)),stat : stat + +#define OCIStmtFetch_log_stat(sh,eh,nr,or,md,stat) \ + stat=OCIStmtFetch(sh,eh,nr,or,md); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sStmtFetch(%p,%p,%lu,%u,%lu)=%s\n", \ + OciTp, (void*)sh,(void*)eh,ul_t(nr),(ub2)or,ul_t(md), \ + oci_status_name(stat)),stat : stat + +#define OCIStmtPrepare_log_stat(sh,eh,s,sl,l,m,stat) \ + stat=OCIStmtPrepare(sh,eh,s,sl,l,m); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sStmtPrepare(%p,%p,'%s',%lu,%lu,%lu)=%s\n", \ + OciTp, (void*)sh,(void*)eh,s,ul_t(sl),ul_t(l),ul_t(m), \ + oci_status_name(stat)),stat : stat + +#define OCIServerDetach_log_stat(sh,eh,md,stat) \ + stat=OCIServerDetach(sh,eh,md); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sServerDetach(%p,%p,%lu)=%s\n", \ + OciTp, (void*)sh,(void*)eh,ul_t(md), \ + oci_status_name(stat)),stat : stat + +#define OCISessionBegin_log_stat(sh,eh,uh,cr,md,stat) \ + stat=OCISessionBegin(sh,eh,uh,cr,md); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sSessionBegin(%p,%p,%p,%lu,%lu)=%s\n", \ + OciTp, (void*)sh,(void*)eh,(void*)uh,ul_t(cr),ul_t(md), \ + oci_status_name(stat)),stat : stat + +#define OCISessionEnd_log_stat(sh,eh,ah,md,stat) \ + stat=OCISessionEnd(sh,eh,ah,md); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sSessionEnd(%p,%p,%p,%lu)=%s\n", \ + OciTp, (void*)sh,(void*)eh,(void*)ah,ul_t(md), \ + oci_status_name(stat)),stat : stat + +#define OCITransCommit_log_stat(sh,eh,md,stat) \ + stat=OCITransCommit(sh,eh,md); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sTransCommit(%p,%p,%lu)=%s\n", \ + OciTp, (void*)sh,(void*)eh,ul_t(md), \ + oci_status_name(stat)),stat : stat + +#define OCITransRollback_log_stat(sh,eh,md,stat) \ + stat=OCITransRollback(sh,eh,md); \ + (DBD_OCI_TRACEON) ? fprintf(DBD_OCI_TRACEFP, \ + "%sTransRollback(%p,%p,%lu)=%s\n", \ + OciTp, (void*)sh,(void*)eh,ul_t(md), \ + oci_status_name(stat)),stat : stat + +#endif /* OCI_V8_SYNTAX */ diff --git a/ora_explain.PL b/ora_explain.PL new file mode 100644 index 00000000..479bcbaa --- /dev/null +++ b/ora_explain.PL @@ -0,0 +1,1814 @@ +# -*- perl -*- + +use strict; + +my $script = <<'SCRIPT'; +~startperl~ -w + +#!/usr/local/bin/perl -w + +################################################################################ +# Copyright (c) 1999 Alan Burlison +# +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License, as specified in the Perl README file, with the +# exception that it cannot be placed on a CD-ROM or similar media for commercial +# distribution without the prior approval of the author. +# +# This code is provided with no warranty of any kind, and is used entirely at +# your own risk. +# +# This code was written by the author as a private individual, and is in no way +# endorsed or warrantied by Sun Microsystems. +# +# Support questions and suggestions can be directed to Alan.Burlison@uk.sun.com +# +################################################################################ + +use strict; +use File::Basename; +use DBI; +use Tk; +use Tk::Balloon; +use Tk::ErrorDialog; +use Tk::ROText; + +################################################################################ +# Subclassed version of Tk::Tree that allows button3 to have a callback attached + +package Tk::B3Tree; +use strict; +use base qw(Tk::Tree); +Construct Tk::Widget qw(B3Tree); + +sub ClassInit +{ +my ($class, $mw) = @_; +$class->SUPER::ClassInit($mw); +$mw->bind($class, "<3>", "Button3"); +return $class; +} + +sub Populate +{ +my ($self, $args) = @_; +$self->SUPER::Populate($args); +$self->ConfigSpecs(-b3command => [ "CALLBACK", "b3command", "B3command", + undef ]); +} + +sub Button3 +{ +my $w = shift; +my $Ev = $w->XEvent; +my $ent = $w->GetNearest($Ev->y); +return unless (defined($ent) and length($ent)); +$w->Callback(-b3command => $ent); +} + +################################################################################ + +package main; +use vars qw($VERSION); +$VERSION = "1.1"; + +# Globals +# $ProgName Program name (without pathname) +# $Db Database handle +# $DbName Oracle database name +# $User Oracle user name +# $Schema Oracle schema name +# $SqlMarker String used to identify SQL generated by explain +# $OracleVersion Oracle version number +# $CharWidth Width of a character in pixels +# $Plan Current query plan as a Perl data structure +# $LoginDialog Login dialog +# $SchemaDialog Schema dialog +# $SaveDialog Save File dialog +# $OpenDialog Open File dialog +# $FileDir Current file save/open directory +# $PlanMain Query plan main window +# $PlanTitle Title of query plan main window +# $PlanTree Tree used to display the query plan +# $PlanStep ROText used to display the selected plan step details +# $PlanSql Text used to allow SQL editing +# $Balloon For balloon help +# $GrabMain SQL cache grab main window +# $GrabStatus Text label used for feedback/status info +# $GrabSelection Tag of currently selected SQL statement in the SQL cache +# $GrabSql ROText used to hold the contents of the SQL cache +# $GrabDetails ROText used to display the selected statement details +use vars qw($ProgName $Db $DbName $User $Schema $SqlMarker $OracleVersion + $CharWidth $Plan $LoginDialog $SchemaDialog $OpenDialog $SaveDialog + $FileDir $PlanMain $PlanTitle $PlanTree $PlanStep $PlanSql $Balloon + $GrabMain $GrabStatus $GrabSelection $GrabSql $GrabDetails); +$SqlMarker = "/* This statement was generated by explain */"; + +################################################################################ +# Switch the hourglass on or off + +sub busy($) +{ +my ($state) = @_; +if ($state && $PlanMain->grabCurrent()) { $PlanMain->Busy(-recurse => 1); } +else { $PlanMain->Unbusy(1); } +} + +################################################################################ +# Display an error message in a dialog + +sub error($@) +{ +my ($parent, @lines) = @_; + +my ($msg, $height, $width); +$msg = join("\n", @lines); +$msg =~ s/\n$//; +$msg =~ s/ \(DBD:/\n(DBD:/; +$msg =~ s/(indicator at char \d+ in) /$1\n/; +@lines = split("\n", $msg); +$height = @lines; +$width = 0; +foreach my $line (@lines) + { my $l = length($line); $width = $l if ($l > $width); } +$width = 80 if ($width > 80); +$height = 4 if ($height < 4); +$height = 10 if ($height > 10); + +busy(0); +my $dialog = $PlanMain->Toplevel(-title => "Error"); +$dialog->withdraw(); +my $text = $dialog->Scrolled("ROText", -height => $height, -width => $width, + -borderwidth => 3, -relief => "raised", + -wrap => "word", -scrollbars => "oe") + ->pack(-padx => 6, -pady => 6, -expand => 1, -fill => "both"); +$text->insert("1.0", $msg); + +my $ok_cb = sub { $dialog->destroy() }; +$dialog->Button(-text => "OK", -default => "active", -command => $ok_cb) + ->pack(-padx => 6, -pady => 6); +$dialog->bind("", $ok_cb); +$dialog->Popup; +} + +################################################################################ + +sub about($;$) +{ +my ($parent, $win) = @_; +my $msg = <Toplevel(-title => "About $ProgName"); +$dialog->withdraw(); +$dialog->resizable(0, 0); +my $text = $dialog->Text(-borderwidth => 3, -width => 80, -height => 16, + -relief => "raised") + ->pack(-padx => 6, -pady => 6); +$text->insert("1.0", $msg); +my $cb; +if ($win) + { + $$win = $dialog; + $cb = sub { $dialog->destroy(); undef($$win); }; + } +else + { + $cb = sub { $dialog->destroy(); }; + } +$dialog->Button(-text => "OK", -command => $cb)->pack(-padx => 6, -pady => 6); +$dialog->Popup(); +return($dialog); +} + +################################################################################ + +sub update_title() +{ +$PlanMain->configure(-title => + $User + ? $User eq $Schema + ? "$ProgName - connected to $DbName as $User" + : "$ProgName - connected to $DbName as $User [schema $Schema]" + : "$ProgName - not connected" + ); +} + +################################################################################ + +sub help($) +{ +my ($parent) = @_; +require Tk::Pod; +$parent->Pod(-file => $0, -scrollbars => "e"); +} + +################################################################################ +# Login to the database. The new database handle is put into $Db, and the +# Oracle version number is put into $OracleVersion + +sub login($$$) +{ +my ($database, $username, $password) = @_; + +busy(1); +# Close any existing handle +if ($Db) + { + $Db->disconnect(); + $Db = undef; + $DbName = $User = $Schema = undef; + update_title(); + } + +# Connect and initialise +$Db = DBI->connect("dbi:Oracle:$database", $username, $password, + { AutoCommit => 0, PrintError => 0}) + || die("Can't login to Oracle:\n$DBI::errstr\n"); +$Db->{LongReadLen} = 4096; +$Db->{LongTruncOk} = 1; + +# Get the user name and check the Oracle version +my $qry = $Db->prepare(qq( + $SqlMarker select user, version from product_component_version + where lower(product) like '%oracle%' +)); +if (! $qry->execute()) + { + my $err = $DBI::errstr; + $qry->finish(); + $Db->disconnect(); + $Db = undef; + die("Can't fetch Oracle version:\n$err\n"); + } +($User, $OracleVersion) = $qry->fetchrow_array(); +$qry->finish(); +$DbName = $database || $ENV{TWO_TASK} || $ENV{ORACLE_SID}; +$Schema = $User; + +# Check there is a plan_table for this user +$qry = $Db->prepare(qq( + $SqlMarker select 1 from user_tables where table_name = 'PLAN_TABLE' +)); +$qry->execute(); +if (! $qry->fetchrow_arrayref()) + { + $qry->finish(); + $Db->disconnect(); + $Db = undef; + die("User $User does not have a PLAN_TABLE.\n", + "Run the script utlxplan.sql to create one.\n"); + } + +busy(0); +return(1); +} + +################################################################################ +# Clear the plan tree & details windows + +sub clear_plan() +{ +$PlanTitle->configure(-text => "Query Plan") if ($PlanTitle); +$PlanTree->delete("all") if ($PlanTree); +$PlanStep->delete("1.0", "end") if ($PlanStep); +} + +################################################################################ +# Clear the SQL editor pane + +sub clear_editor() +{ +$PlanTitle->configure(-text => "Query Plan") if ($PlanTitle); +$PlanTree->delete("all") if ($PlanTree); +$PlanStep->delete("1.0", "end") if ($PlanStep); +$PlanSql->delete("1.0", "end"); +} + +################################################################################ +# Display the structure of an index + +sub disp_index($$) +{ +my ($owner, $index) = @_; + +# Create the index definition frame +busy(1); +my $dialog = $PlanMain->Toplevel(-title => "Index"); +$dialog->withdraw(); +$dialog->resizable(0, 0); +my $index_fr = $dialog->Frame(-borderwidth => 3, -relief => "raised"); +$index_fr->Label(-text => "$owner.$index", -relief => "ridge", + -borderwidth => 1) + ->grid(-column => 0, -row => 0, -columnspan => 2, -sticky => "we", + -ipadx => 3); +$index_fr->Label(-text => "Table", -relief => "ridge", -borderwidth => 1) + ->grid(-column => 0, -row => 1, -sticky => "we", -ipadx => 3); +$index_fr->Label(-text => "Column", -relief => "ridge", -borderwidth => 1) + ->grid(-column => 1, -row => 1, -sticky => "we", -ipadx => 3); + +# Show the table columns the index is built upon +my $qry = $Db->prepare(qq( + $SqlMarker select table_owner, table_name, column_name + from all_ind_columns + where index_owner = :1 and index_name = :2 + order by column_position +)); +$qry->execute($owner, $index) || die("Index columns:\n$DBI::errstr\n"); + +# For each column in the index, display its details +my ($tab_txt, $col_txt); +while ((my ($tab_owner, $table, $column) = $qry->fetchrow_array())) + { + $tab_txt .= "$tab_owner.$table\n"; + $col_txt .= "$column\n"; + } +$qry->finish(); +chop($tab_txt, $col_txt); +$index_fr->Label(-text => $tab_txt, -relief => "ridge", -borderwidth => 1, + -justify => "left") + ->grid(-column => 0, -row => 2, -sticky => "we", -ipadx => 3); +$index_fr->Label(-text => $col_txt, -relief => "ridge", -borderwidth => 1, + -justify => "left") + ->grid(-column => 1, -row => 2, -sticky => "we", -ipadx => 3); +$index_fr->pack(-side => "top", -fill => "x"); + +# Pack the grid and add the close button +$dialog->Button(-text => "Close", -command => sub { $dialog->destroy(); }) + ->pack(-padx => 6, -pady => 6); + +$dialog->Popup(); +busy(0); +return(1); +} + +################################################################################ +# Callback for adding/removing index definitions to a table dialog + +sub disp_table_cb($$$$$) +{ +my ($owner, $table, $num_cols, $index_fr, $index_bn) = @_; + +# If this is the first time through, fetch the index definitions +busy(1); +if (! $index_fr->children()) + { + # This will retrieve the names & owners of all the indexes on the table + my $qry = $Db->prepare(qq( + $SqlMarker select owner, index_name + from all_indexes + where table_owner = :1 and table_name = :2 + order by owner, index_name + )); + + # Build up a list of all the indexes + $qry->execute($owner, $table) || die("Table indexes:\n$DBI::errstr\n"); + my (@indexes, $ind_owner, $ind_name); + while (($ind_owner, $ind_name) = $qry->fetchrow_array()) + { push(@indexes, { owner => $ind_owner, name => $ind_name }); } + $qry->finish(); + + # Special for no indexes + if (@indexes == 0) + { + $index_fr->Label(-text => "No\nindexes\ndefined", -relief => "ridge", + -borderwidth => 1)->pack(-ipadx => 3, -ipady => 4); + } + else + { + # Do the header label + $index_fr->Label(-text => "Index\norder", -relief => "ridge", + -borderwidth => 1) + ->grid(-column => 0, -row => 0, -sticky => "we", -ipadx => 3, + -ipady => 2, -columnspan => scalar(@indexes), -rowspan => 2); + + # This will retrieve (table column id, index position) for an index + $qry = $Db->prepare(qq( + $SqlMarker select atc.column_id, aic.column_position + from all_tab_columns atc, all_ind_columns aic + where aic.index_owner = :1 and aic.index_name = :2 + and atc.owner = aic.table_owner and atc.table_name = aic.table_name + and atc.column_name = aic.column_name + order by aic.index_name, atc.column_id + )); + + # For each index, add a label describing the index + my $cb = sub { disp_index($_[1], $_[2]); }; + my $grid_col = 0; + foreach my $index (@indexes) + { + ($ind_owner, $ind_name) = @{$index}{qw(owner name)}; + $qry->execute($ind_owner, $ind_name) + || die("Index columns:\n$DBI::errstr\n"); + my $index_txt; + my $col = 1; + while (my ($col_id, $col_pos) = $qry->fetchrow_array()) + { + $index_txt .= "\n" x ($col_id - $col) . "$col_pos\n"; + $col = $col_id + 1; + } + $index_txt .= "\n" x ($num_cols - ($col - 1)); + chop($index_txt); + my $label = $index_fr->Label(-text => $index_txt, -relief => "ridge", + -borderwidth => 1, -justify => "left") + ->grid(-column => $grid_col, -row => 2, -sticky => "w", + -ipadx => 3); + $label->bind("<1>", [ $cb, $ind_owner, $ind_name ]); + $Balloon->attach($label, -msg => "$ind_owner.$ind_name", + -balloonposition => "mouse"); + $grid_col++; + } + } + } +if ($index_bn->cget(-text) eq "Indexes") + { + $index_bn->configure(-text => "Hide Indexes"); + $index_fr->pack(-side => "right", -expand => 1); + } +else + { + $index_bn->configure(-text => "Indexes"); + $index_fr->packForget(); + } +busy(0); +return(1); +} + +################################################################################ +# Display a popup dialog showing the structure of a table + +sub disp_table($$) +{ +my ($owner, $table) = @_; + +# Create the dialog for displaying the object details +busy(1); +my $dialog = $PlanMain->Toplevel(-title => "Table"); +$dialog->withdraw(); +$dialog->resizable(0, 0); + +# Create the table definition frame +my $box1 = $dialog->Frame(-borderwidth => 3, -relief => "raised"); +my $box2 = $box1->Frame(-borderwidth => 0); +my $table_fr = $box2->Frame(-borderwidth => 1, -relief => "flat"); +$table_fr->Label(-text => "$owner.$table", + -relief => "ridge", -borderwidth => 1) + ->grid(-column => 0, -row => 0, -columnspan => 2, -sticky => "we"); +$table_fr->Label(-text => "Name", -relief => "ridge", -borderwidth => 1) + ->grid(-column => 0, -row => 1, -sticky => "we", -ipadx => 3); +$table_fr->Label(-text => "Type", -relief => "ridge", -borderwidth => 1) + ->grid(-column => 1, -row => 1, -sticky => "we", -ipadx => 3); + +# This will get the table description +my $qry = $Db->prepare(qq( + $SqlMarker select column_name, data_type, data_length, + data_precision, data_scale + from all_tab_columns + where owner = :1 and table_name = :2 + order by column_id + )); +$qry->execute($owner, $table) + || die("Table columns:\n$DBI::errstr\n"); + +my ($num_cols, $name_txt, $type_txt); +while ((my ($name, $type, $length, $precision, $scale) + = $qry->fetchrow_array())) + { + if ($precision) + { + $type .= "($precision"; + $type .= ",$scale" if ($scale); + $type .= ")"; + } + elsif ($type =~ /CHAR/) + { + $type .= "($length)"; + } + $name_txt .= "$name\n"; + $type_txt .= "$type\n"; + $num_cols++; + } +$qry->finish(); +chop($name_txt, $type_txt); +$table_fr->Label(-text => $name_txt, -relief => "ridge", -borderwidth => 1, + -justify => "left") + ->grid(-column => 0, -row => 2, -sticky => "we", -ipadx => 3); +$table_fr->Label(-text => $type_txt, -relief => "ridge", -borderwidth => 1, + -justify => "left") + ->grid(-column => 1, -row => 2, -sticky => "we", -ipadx => 3); +$table_fr->pack(-side => "left"); + +# Now create a frame for the index definition & pack the whole lot +my $index_fr = $box2->Frame(-borderwidth => 1, -relief => "flat"); +$box2->pack(); +$box1->pack(-side => "top", -fill => "x", -expand => 1); + +# Create the buttons at the bottom +$box1 = $dialog->Frame(-borderwidth => 0); +$box1->Button(-text => "Close", -command => sub { $dialog->destroy(); }) + ->pack(-padx => 6, -side => "left", -expand => 1); +my $index_bn; +$index_bn = $box1->Button(-text => "Indexes") + ->pack(-padx => 6, -side => "left", -expand => 1); +$index_bn->configure(-command => sub { disp_table_cb($owner, $table, $num_cols, + $index_fr, $index_bn); }); +$box1->pack(-side => "bottom", -pady => 6); + +$dialog->Popup(); +busy(0); +return(1); +} + +################################################################################ +# Display the query plan tree + +sub disp_plan_tree() +{ +$PlanTitle->configure(-text => $Plan->{title}); +$PlanTree->delete("all"); +my $steps = 0; +foreach my $step (@{$Plan->{id}}) + { + my $item = $PlanTree->add($step->{key}, -text => $step->{desc}); + $steps++; + } +$PlanTree->autosetmode(); +if ($steps) + { + $PlanTree->selectionSet("1"); + disp_plan_step("1"); + } +} + +################################################################################ +# Display the statistics for a given plan step + +sub disp_plan_step($) +{ +my ($key) = @_; +my $row = $Plan->{key}{$key}; +$PlanStep->delete("1.0", "end"); +my $info = ""; +$info .= "Cost:\t\t$row->{COST}\t(Estimate of the cost of this step)\n" + . "Cardinality:\t$row->{CARDINALITY}\t" + . "(Estimated number of rows fetched by this step)\n" + . "Bytes:\t\t$row->{BYTES}\t" + . "(Estimated number of bytes fetched by this step)\n" + if ($row->{COST}); +$info .= "\nPartition\nStart:\t$row->{PARTITION_START}\tStop:\t\t" + . "$row->{PARTITION_STOP}\tId:\t\t$row->{PARTITION_ID}\n" + if ($row->{PARTITION_START}); +$info .= "\nSQL used by Parallel Query Slave:\n$row->{OTHER}" + if ($row->{OTHER}); +$PlanStep->insert("1.0", $info); +} + +################################################################################ +# Display a popup dialog showing the structure of the table or index used in +# the passed plan step + +sub disp_plan_step_obj($) +{ +my ($key) = @_; + +# Get the plan step & return if it doesn't refer to an object +my $row = $Plan->{key}{$key}; +return(1) if (! $row->{OBJECT_NAME}); + +# Work out the type of the object - table or index +busy(1); +my $qry = $Db->prepare(qq( + $SqlMarker select object_type from all_objects + where object_name = :1 and owner = :2 +)); +$qry->execute($row->{OBJECT_NAME}, $row->{OBJECT_OWNER}) + || die("Object type:\n$DBI::errstr\n"); +my ($object_type) = $qry->fetchrow_array(); +$qry->finish(); +busy(0); + +if ($object_type eq "TABLE") + { + disp_table($row->{OBJECT_OWNER}, $row->{OBJECT_NAME}); + } +elsif ($object_type eq "INDEX") + { + disp_index($row->{OBJECT_OWNER}, $row->{OBJECT_NAME}); + } +else + { + die("Unknown object type $object_type", + "for $row->{OBJECT_OWNER}.$row->{OBJECT_NAME}\n"); + } +} + +################################################################################ +# Display a list of available indexes on a table, and display the selected +# table definition + +sub disp_index_popup($) +{ +my ($key) = @_; + +# Get the plan step & return if it doesn't refer to an object +my $row = $Plan->{key}{$key}; +return(1) if (! $row->{OBJECT_NAME}); + +# Work out the type of the object - table or index +busy(1); +my $qry = $Db->prepare(qq( + $SqlMarker select object_type from all_objects + where object_name = :1 and owner = :2 +)); +$qry->execute($row->{OBJECT_NAME}, $row->{OBJECT_OWNER}) + || die("Object type:\n$DBI::errstr\n"); +my ($object_type) = $qry->fetchrow_array(); +$qry->finish(); +if ($object_type ne "TABLE") + { + busy(0); + return(1); + } + +# Build the popup menu +$qry = $Db->prepare(qq( + $SqlMarker select owner, index_name from all_indexes + where table_name = :1 and table_owner = :2 +)); +$qry->execute($row->{OBJECT_NAME}, $row->{OBJECT_OWNER}) + || die("Table indexes:\n$DBI::errstr\n"); +my $menu = $PlanMain->Menu(-tearoff => 0, -disabledforeground => "#000000"); +$menu->command(-label => "Indexes", -state => "disabled"); + +$menu->separator(); +my $count = 0; +while ((my ($index_owner, $index_name) = $qry->fetchrow_array())) + { + $menu->command(-label => "$index_owner.$index_name", + -command => [ \&disp_index, $index_owner, $index_name ]); + $count++; + } +$qry->finish(); +busy(0); +$menu->Popup(-popover => "cursor", -popanchor => "nw") if ($count); +return(1); +} + +################################################################################ +# Produce the query plan for the SQL in $PlanSql and store it in $Plan + +sub _explain() +{ +# Check there is some SQL +my $stmt = $PlanSql->get("1.0", "end"); +$stmt =~ s/;//g; +die("You have not supplied any SQL\n") if ($stmt =~ /^\s*$/); + +# Check we are logged on +die("You are not logged on to Oracle\n") if (! $Db); + +# Set up the various query strings +# Note that for some reason you can't use bind variables in 'explain plan' +my $prefix = "explain plan set statement_id = '$$' for\n"; +my $plan_sql = qq( + $SqlMarker select level, operation, options, object_node, object_owner, + object_name, object_instance, object_type, id, parent_id, position, + other); +if ($OracleVersion ge "7.3") + { $plan_sql .= qq(, cost, cardinality, bytes, other_tag) }; +if ($OracleVersion ge "8") + { $plan_sql .= qq(, partition_start, partition_stop, partition_id) }; +$plan_sql .= qq( + from plan_table + where statement_id = :1 + connect by prior id = parent_id and statement_id = :1 + start with id = 0 and statement_id = :1 +); + +# Clean any old stuff from the plan_table +busy(1); +$Db->do(qq($SqlMarker delete from plan_table where statement_id = :1), + undef, $$) + || die("Delete from plan_table:\n$DBI::errstr\n"); +$Db->commit(); + +# Switch schema if required +if ($Schema ne $User) + { + $Db->do(qq($SqlMarker alter session set current_schema = $Schema)) + || die("Cannot change schema to $Schema:\n$DBI::errstr\n"); + } + +# Explain the plan - need to save message if failed! +$Plan = { schema => $Schema, sql => $stmt }; +my $fail; +$fail = $DBI::errstr if (!$Db->do($prefix . $stmt)); + +# Switch back schema if required +if ($Schema ne $User) + { + $Db->do(qq($SqlMarker alter session set current_schema = $User)) + || die("Set current schema to $User:\n$DBI::errstr\n"); + } +# Now we can safely die if the exmplai plan failed +die("Explain plan:\n$fail\n") if ($fail); + +# Read back the plan +my $qry = $Db->prepare($plan_sql) + || die("Unsupported PLAN_TABLE format:\n$DBI::errstr\n"); +$qry->execute($$) || die("Read plan:\n$DBI::errstr\n"); +while (my $row = $qry->fetchrow_hashref()) + { + if ($row->{ID} == 0) + { + $Plan->{title} = "Query Plan for " . lc($row->{OPERATION}); + $Plan->{title} .= ". Cost = $row->{POSITION}" if ($row->{POSITION}); + } + else + { + # Line wrap the OTHER field + $row->{OTHER} =~ s/((.{1,80})(\s+|,|$))/$1\n/g if ($row->{OTHER}); + + # Construct a descriptive string for the query step + my $desc = "$row->{OPERATION}"; + $desc .= " $row->{OPTIONS}" if ($row->{OPTIONS}); + $desc .= " $row->{OBJECT_TYPE}" if ($row->{OBJECT_TYPE}); + $desc .= " of $row->{OBJECT_OWNER}.$row->{OBJECT_NAME}" + if ($row->{OBJECT_OWNER} && $row->{OBJECT_NAME}); + $desc .= " using PQS $row->{OBJECT_NODE} $row->{OTHER_TAG}" + if ($row->{OBJECT_NODE}); + $row->{desc} = $desc; + + # Construct a hierarchical key for the query step + if (! $row->{PARENT_ID}) + { + my $key = "$row->{POSITION}"; + $row->{key} = $key; + $Plan->{id}[$row->{ID} - 1] = $row; + $Plan->{key}{$key} = $row; + } + else + { + my $parent = $Plan->{id}[$row->{PARENT_ID} - 1]; + my $key = "$parent->{key}.$row->{POSITION}"; + $row->{key} = $key; + $Plan->{id}[$row->{ID} - 1] = $row; + $Plan->{key}{$key} = $row; + $parent->{child}[$row->{POSITION} - 1] = $row; + } + } + } +# Top of the tree is step 0 +$Plan->{tree} = $Plan->{id}[0]; + +# Clean up +$qry->finish(); +$Db->do(qq($SqlMarker delete from plan_table where statement_id = :1), + undef, $$); +$Db->commit(); +busy(0); +return(1); +} + +################################################################################ +# Wrapper for _explain - adds error handling + +sub explain +{ +clear_plan(); +if (! eval { _explain(); }) { error($PlanMain, $@); } +else { disp_plan_tree(); } +} + +################################################################################ +# Display a login dialog + +sub login_dialog($) +{ +my ($parent) = @_; + +# Create the dialog +if (! $LoginDialog) + { + my $username = "/"; + my $password = ""; + my $database = $ENV{TWO_TASK} || $ENV{ORACLE_SID}; + + $LoginDialog = $parent->Toplevel(-title => "Login to Oracle"); + $LoginDialog->withdraw(); + $LoginDialog->resizable(0, 0); + my $box; + + # Create the entry labels & fields + $box = $LoginDialog->Frame(-borderwidth => 1, -relief => "raised"); + $box->Label(-text => "Username") + ->grid(-column => 0, -row => 0, -sticky => "w"); + $box->Entry(-textvariable => \$username, -width => 30) + ->grid(-column => 1, -row => 0, -sticky => "w"); + $box->Label(-text => "Password") + ->grid(-column => 0, -row => 1, -sticky => "w"); + $box->Entry(-textvariable => \$password, -width => 30, -show => "*") + ->grid(-column => 1, -row => 1, -sticky => "w"); + $box->Label(-text => "Database") + ->grid(-column => 0, -row => 2, -sticky => "w"); + $box->Entry(-textvariable => \$database, -width => 30) + ->grid(-column => 1, -row => 2, -sticky => "w"); + $box->pack(-expand => 1, -fill => "both", -ipadx => 6, -ipady => 6); + + # Create the buttons & callbacks + $box = $LoginDialog->Frame(-borderwidth => 1, -relief => "raised"); + my $cb = sub + { + if (! eval { login($database, $username, $password); }) + { + error($parent, $@); + $LoginDialog->raise($parent); + } + else + { + update_title(); + $LoginDialog->withdraw(); + } + }; + $box->Button(-text => "Login", -default => "active", -command => $cb) + ->pack(-side => "left", -expand => 1, -pady => 6); + $box->Button(-text => "Cancel", -command => sub { $LoginDialog->withdraw() }) + ->pack(-side => "right", -expand => 1, -pady => 6); + $box->pack(-expand => 1, -fill => "both"); + $LoginDialog->bind("", $cb); + } + +# Activate the dialog +$LoginDialog->Popup(); +} + +################################################################################ + +sub schema_dialog($) +{ +my ($parent) = @_; + +if (! $Db) + { + error($parent, "You are not logged on to Oracle\n"); + return; + } + +# Create the dialog +if (! $SchemaDialog) + { + $SchemaDialog = $parent->Toplevel(-title => "Change Schema"); + $SchemaDialog->withdraw(); + $SchemaDialog->resizable(0, 0); + my ($box, $schema); + + # Create the entry labels & fields + $box = $SchemaDialog->Frame(-borderwidth => 1, -relief => "raised"); + $box->Label(-text => "Schema") + ->pack(-side => "left", -anchor => "e", -expand => 1); + $box->Entry(-textvariable => \$schema, -width => 30) + ->pack(-side => "right", -anchor => "w", -expand => 1); + $box->pack(-expand => 1, -fill => "both", -ipadx => 6, -ipady => 6); + + # Create the buttons & callbacks + $box = $SchemaDialog->Frame(-borderwidth => 1, -relief => "raised"); + my $cb = sub + { + # Try changing to the specified schema + $schema = uc($schema); + if (! $Db->do(qq($SqlMarker alter session set current_schema = $schema))) + { + error($parent, "Cannot change schema to $schema:", $DBI::errstr); + $SchemaDialog->raise($parent); + } + else + { + # Change back to the user's schema + $Db->do(qq($SqlMarker alter session set current_schema = $User)) + || die("Cannot change schema to $User\n$DBI::errstr"); + $Schema = $schema; + update_title(); + $SchemaDialog->withdraw(); + } + }; + $box->Button(-text => "Default", -command => sub { $schema = $User; }) + ->pack(-side => "left", -expand => 1, -pady => 6); + $box->Button(-text => "Apply", -default => "active", -command => $cb) + ->pack(-side => "left", -expand => 1, -pady => 6); + $box->Button(-text => "Cancel", + -command => sub { $SchemaDialog->withdraw() }) + ->pack(-side => "left", -expand => 1, -pady => 6); + $box->pack(-expand => 1, -fill => "both"); + $SchemaDialog->bind("", $cb); + } + +# Activate the dialog +$SchemaDialog->Popup(); +} + +################################################################################ +# Open a file and read it into the SQL editor frame + +sub open_file($) +{ +# Open the file +my ($file) = @_; +use IO::File; +my $fh; +if (! ($fh = IO::File->new($file, "r"))) + { + error($PlanMain, "Cannot open $file:\n", $!); + return(0); + } + +# Clear the plan, plan details & SQL editor, then load into the SQL editor +clear_editor(); +while (my $line = $fh->getline()) + { + $PlanSql->insert("end", $line); + } +$fh->close(); +return(1); +} + +################################################################################ +# Display a file open dialog & load into the SQL editor + +sub open_dialog($) +{ +my ($parent) = @_; + +# Put up the dialog +require Cwd; import Cwd; +require Tk::FileSelect; +$FileDir = cwd() if (! $FileDir); +if (! $OpenDialog) + { + $OpenDialog = $parent->FileSelect(-title => "Open File", + -create => 0); + } +$OpenDialog->configure(-directory => $FileDir); +my $file = $OpenDialog->Show(); +return if (! $file); +$FileDir = $OpenDialog->cget(-directory); +open_file($file); +} + +################################################################################ +# Display a file save dialog & save the contents of the passed Text widget + +sub save_dialog($$) +{ +my ($parent, $text) = @_; + +# Put up the dialog +require Cwd; import Cwd; +require IO::File; +require Tk::FileSelect; +$FileDir = cwd() if (! $FileDir); +if (! $SaveDialog) + { + $SaveDialog = $parent->FileSelect(-title => "Save File", + -create => 1); + } +$SaveDialog->configure(-directory => $FileDir); +my $file = $SaveDialog->Show(); +return if (! $file); +$FileDir = $SaveDialog->cget(-directory); + +# Save the Text widget contents to the selected file +my $fh; +if (! ($fh = IO::File->new($file, "w"))) + { + error($PlanMain, "Cannot open $file:\n", $!); + return; + } +$fh->print($text->get("1.0", "end")); +$fh->close(); +} + +################################################################################ +# Copy SQL from the grab window into the explain SQL editor + +sub copy_sql($$) +{ +my ($text, $tag) = @_; +return if (! defined($tag)); +clear_editor(); +$PlanSql->insert("end", $text->get("$tag.first", "$tag.last")); +$Schema = $text->tag("cget", $tag, -data); +update_title(); +$PlanMain->deiconify(); +} + +################################################################################ +# Display info from v$sqlarea for the selected statement in the SQL cache + +sub disp_sql_cache_info($$) +{ +my ($address, $puid) = @_; + +# Empty the widget & prepare the SQL +$GrabDetails->delete("1.0", "end"); +busy(1); +my $qry = $Db->prepare(qq( + $SqlMarker select executions, disk_reads, buffer_gets, rows_processed, + sorts, loads, parse_calls, first_load_time + from v\$sqlarea where address = :1 +)) || die("Statement info:\n$DBI::errstr\n"); + +# Read the info. Note that the statement *may* have been purged from the cache! +$qry->execute($address); +if (! (my ($executions, $disk_reads, $buffer_gets, $rows_processed, + $sorts, $loads, $parse_calls, $first_load_time) + = $qry->fetchrow_array())) + { + $GrabDetails->insert("1.0", "This statement is no longer in the SQL cache"); + } +else + { + $first_load_time =~ s!/! !; + $GrabDetails->insert("1.0", "First executed by user", "bold", + " $puid ", "", + " at", "bold", " $first_load_time\n"); + $GrabDetails->insert("end", "Total ", "bold"); + $GrabDetails->insert("end", sprintf("Executions: %8d\n", $executions)); + my $fmt = + "Disk reads: %8d Buffer gets: %8d Rows processed: %8d\n" + . "Sorts: %8d Loads: %8d Parse calls: %8d\n"; + $GrabDetails->insert("end", + sprintf($fmt, $disk_reads, $buffer_gets, $rows_processed, + $sorts, $loads, $parse_calls)); + if ($executions > 0) + { + $GrabDetails->insert("end", "Average per Execution\n", "bold"); + $fmt = + "Disk reads: %8.1f Buffer gets: %8.1f " + . "Rows processed: %8.1f\n" + . "Sorts: %8.1f Loads: %8.1f " + . "Parse calls: %8.1f\n"; + $GrabDetails->insert("end", + sprintf($fmt, $disk_reads / $executions, $buffer_gets / $executions, + $rows_processed / $executions, $sorts / $executions, + $loads / $executions, $parse_calls / $executions)); + } + } +busy(0); + +# Display the formated info +return(1); +} + +################################################################################ +# Callback for whenever a bit of grabbed SQL is selected + +sub grab_select_cb($$) +{ +my ($text, $tag) = @_; +$text->tag("configure", $GrabSelection, -background => undef) + if ($GrabSelection); +$text->tag("configure", $tag, -background => "#43ce80"); +my $puid = $text->tag("cget", $tag, -data); +$GrabSelection = $tag; +if (! eval { disp_sql_cache_info($tag, $puid); }) + { error($GrabMain, $@); } +} + +################################################################################ +# Scan v$sqlarea for SQL statements matching the specified conditions. +# $order_by is a v$sqlarea column name used to rank the statements +# $sort_by is "asc" or "desc" +# $user is who first issued the statement (case insensitive) +# $pattern is a perl regexp used to filter the SQL +# $rows is the maximum number of rows to display + +sub grab($$$$$$$) +{ +my ($ordering, $order_by, $sort_by, $no_sys, $user, $pattern, $rows) = @_; + +# Check we are logged on +die("You are not logged on to Oracle\n") if (! $Db); + +# Munge args as necessary +$no_sys = $no_sys ? qq{and user_name not in ('SYS', 'SYSTEM')} : qq{}; +$rows = -1 if ($rows !~ /^\d+$/); +$user = uc($user); + +# Clear the frames +$GrabSql->delete("1.0", "end"); +$GrabDetails->delete("1.0", "end"); +$GrabStatus->configure(-text => "Please wait..."); + +# Define the callbacks for highlighting etc +my $highlight = sub + { + my ($text, $tag) = @_; + $text->tag("configure", $tag, -relief => "raised", -borderwidth => 1); + }; +my $normal = sub + { + my ($text, $tag) = @_; + $text->tag("configure", $tag, -relief => "flat"); + }; + +# Prepare the queries +busy(1); +my $qry1 = qq{$SqlMarker select address, username from v\$sqlarea, all_users}; +$qry1 .= qq{ where sql_text not like '\%$SqlMarker\%'}; +$qry1 .= qq{ and sql_text not like '\%insert into \%plan_table\%'}; +$qry1 .= qq{ and sql_text not like '\%explain plan\%'}; +$qry1 .= qq{ and user_id = parsing_user_id}; # if($user || $no_sys); +$qry1 .= qq{ and username = :1} if ($user); +$qry1 .= qq{ and username not in ('SYS', 'SYSTEM')} if ($no_sys); +if ($ordering eq "total") + { $qry1 .= qq{ order by $order_by $sort_by}; } +elsif ($ordering eq "average") + { $qry1 .= qq{ order by $order_by / greatest(executions, 1) $sort_by}; } +$qry1 = $Db->prepare($qry1) || die("SQL Cache capture:\n$DBI::errstr\n"); + +my $qry2; +if ($OracleVersion ge "7.2") + { + $qry2 = $Db->prepare(qq( + $SqlMarker select sql_text from v\$sqltext_with_newlines + where address = :1 order by piece)) + || die("SQL text:\n$DBI::errstr\n"); + } +else{ + $qry2 = $Db->prepare(qq( + $SqlMarker select sql_text from v\$sqltext + where address = :1 order by piece)) + || die("SQL text:\n$DBI::errstr\n"); + } + +# For each SQL query in the shared pool... +if ($user) { $qry1->execute($user) || die("SQL text:\n$DBI::errstr\n"); } +else { $qry1->execute() || die("SQL text:\n$DBI::errstr\n"); } +my $count = 0; +my $first_address; +while ($count != $rows && (my ($address, $puid) = $qry1->fetchrow_array())) + { + # ...glue together the components of the SQL string & print out + $qry2->execute($address) || die("SQL text:\n$DBI::errstr\n"); + my ($sql_text) = ""; + while (my ($sql) = $qry2->fetchrow_array()) + { + $sql_text .= $sql; + } + $qry2->finish(); + $sql_text =~ s/^\s+//; + $sql_text =~ s/\n\s*\n/\n/; + $sql_text =~ s/\s+$//s; + + # Skip if it doesn't match the supplied pattern + next if ($pattern && eval { $sql_text !~ /$pattern/is; }); + + # Display the statement and set up the bindings + $GrabSql->insert("end", $sql_text, $address, "\n\n"); + $GrabSql->tag("configure", $address, -data => $puid); + $GrabSql->tag("bind", $address, "" => [ $highlight, $address ]); + $GrabSql->tag("bind", $address, "" => [ $normal, $address ]); + $GrabSql->tag("bind", $address, "" => [ \©_sql, $address]); + $GrabSql->tag("bind", $address, "<1>" => [ \&grab_select_cb, $address ]); + $GrabSql->update(); + + $count++; + $first_address = $address if (! defined($first_address)); + if ($rows > 0) + { $GrabStatus->configure(-text => "$count of $rows queries grabbed"); } + else + { $GrabStatus->configure(-text => "$count queries grabbed"); } + } + +# Clean up +$qry1->finish(); +grab_select_cb($GrabSql, $first_address) if ($first_address); +$GrabStatus->configure(-text => "$count queries grabbed"); +busy(0); +return(1); +} + +################################################################################ +# Create a top-level window for getting SQL from the shared pool cache + +sub grab_main +{ +# If it already exists, just make it visible) +if ($GrabMain) + { + $GrabMain->deiconify(); + $GrabMain->raise($PlanMain); + return; + } + +# Otherwise, build the grab window +$GrabMain = $PlanMain->Toplevel(-title => "$ProgName - SQL cache"); +$GrabMain->protocol("WM_DELETE_WINDOW", sub { $GrabMain->withdraw(); }); + +# Defaults & callbacks +my $ordering = ""; +my $order_by = ""; +my $sort_by = ""; +my $no_sys = 1; +my $user = ""; +my $pattern = ""; +my $rows = 100; +my $grab_cb = sub + { + if (! eval { grab($ordering, $order_by, $sort_by, $no_sys, + $user, $pattern, $rows); }) + { error($GrabMain, $@); } + }; +my (%ord_bn, %sort_bn); # For "order by" and "sort order" buttons +my $ord_bn_cb = sub + { + if ($ordering eq "") + { + $order_by = ""; + $sort_by = ""; + foreach my $bn (values(%ord_bn)) + { $bn->configure(-state => "disabled"); } + foreach my $bn (values(%sort_bn)) + { $bn->configure(-state => "disabled"); } + } + elsif ($ordering eq "total") + { + $order_by = "disk_reads" if ($order_by eq ""); + $sort_by = "desc" if ($sort_by eq ""); + foreach my $bn (values(%ord_bn)) + { $bn->configure(-state => "normal"); } + foreach my $bn (values(%sort_bn)) + { $bn->configure(-state => "normal"); } + } + else # $ordering eq "average" + { + $order_by = "disk_reads" + if ($order_by eq "" || $order_by eq "executions"); + $sort_by = "desc" if ($sort_by eq ""); + foreach my $bn (values(%ord_bn)) + { $bn->configure(-state => "normal"); } + $ord_bn{executions}->configure(-state => "disabled"); + $ord_bn{first_load_time}->configure(-state => "disabled"); + foreach my $bn (values(%sort_bn)) + { $bn->configure(-state => "normal"); } + } + }; + +### Menubar +my $menubar = $GrabMain->Frame(-relief => "raised", -borderwidth => 3); +$menubar->pack(-fill => "x"); + +my $menubar_file = $menubar->Menubutton(-text => "File", -underline => 0); +$menubar_file->command(-label => "Save File ...", -underline => 0, + -command => sub { save_dialog($PlanMain, $GrabSql); }); +$menubar_file->separator(); +$menubar_file->command(-label => "Capture SQL", -underline => 0, + -command => $grab_cb); +$menubar_file->command(-label => "Copy to Explain", -underline => 9, + -command => sub { copy_sql($GrabSql, $GrabSelection); }); +$menubar_file->command(-label => "Close", -underline => 1, + -command => sub { $GrabMain->withdraw(); }); +$menubar_file->pack(-side => "left"); + +my $menubar_help = $menubar->Menubutton(-text => "Help", -underline => 0); +$menubar_help->command(-label => "About ...", -underline => 0, + -command => sub { about($GrabMain); }); +$menubar_help->command(-label => "Usage ...", -underline => 0, + -command => sub { help($GrabMain); }); +$menubar_help->pack(-side => "right"); + +### SQL cache display +my ($frame, $frame1, $frame2, $frame3); +$frame = $GrabMain->Frame(-borderwidth => 3, -relief => "raised"); +$frame1 = $frame->Frame(-highlightthickness => 0); +$frame1->Label(-text => "SQL Cache")->pack(-side => "left"); +$GrabStatus = $frame1->Label(-text => "")->pack(-side => "right"); +$frame1->pack(-fill => "x"); +$GrabSql = $frame->Scrolled("ROText", -setgrid => "true", -scrollbars => "oe", + -height => 15, -width => 80, -borderwidth => 0, + -wrap => "word") + ->pack(-fill => "both", -expand => 1); +$frame->pack(-fill => "both", -expand => 1); + +### SQL statement details +$frame = $GrabMain->Frame(-borderwidth => 3, -relief => "raised"); +$frame->Label(-text => "SQL Statement Statistics")->pack(-anchor => "nw"); +$GrabDetails = $frame->ROText(-height => 7, -width => 80, -borderwidth => 0, + -setgrid => "true", -wrap => "none") + ->pack(-fill => "x"); +$GrabDetails->tagConfigure("bold", -font => "bold"); +$frame->pack(-fill => "x"); + +### SQL selection +$frame = $GrabMain->Frame(-borderwidth => 3, -relief => "raised"); +$frame->Label(-text => "SQL Selection Criterea")->pack(-anchor => "w"); +$frame1 = $frame->Frame(-highlightthickness => 1); + +## SQL sort frame +$frame1->Label(-text => "Order SQL by") + ->grid(-column => 0, -row => 0, -sticky => "w", -columnspan => 2); +$frame2 = $frame1->Frame(-highlightthickness => 0); + +# Ordering frame +$frame3 = $frame2->Frame(-highlightthickness => 1); +$frame3->Radiobutton(-text => "No ordering", -highlightthickness => 0, + -value => "", -variable => \$ordering, + -command => $ord_bn_cb) + ->pack(-anchor => "w"); +$frame3->Radiobutton(-text => "Total", -highlightthickness => 0, + -value => "total", -variable => \$ordering, + -command => $ord_bn_cb) + ->pack(-anchor => "w"); +$frame3->Radiobutton(-text => "Average per execution", + -highlightthickness => 0, -value => "average", + -variable => \$ordering, -command => $ord_bn_cb) + ->pack(-anchor => "w"); +$frame3->pack(-side => "left", -padx => 6); + +# Order by frame +$frame3 = $frame2->Frame(-highlightthickness => 1); +$ord_bn{disk_reads} = + $frame3->Radiobutton(-text => "Disk reads", -highlightthickness => 0, + -value => "disk_reads", -variable => \$order_by, + -command => $ord_bn_cb) + ->grid(-column => 0, -row => 0, -sticky => "w"); +$ord_bn{buffer_gets} = + $frame3->Radiobutton(-text => "Buffer gets", -highlightthickness => 0, + -value => "buffer_gets", -variable => \$order_by, + -command => $ord_bn_cb) + ->grid(-column => 1, -row => 0, -sticky => "w"); +$ord_bn{rows_processed} = + $frame3->Radiobutton(-text => "Rows processed", -highlightthickness => 0, + -value => "rows_processed", -variable => \$order_by, + -command => $ord_bn_cb) + ->grid(-column => 0, -row => 1, -sticky => "w"); +$ord_bn{sorts} = + $frame3->Radiobutton(-text => "Sorts", -highlightthickness => 0, + -value => "sorts", -variable => \$order_by, + -command => $ord_bn_cb) + ->grid(-column => 1, -row => 1, -sticky => "w"); +$ord_bn{loads} = + $frame3->Radiobutton(-text => "Loads", -highlightthickness => 0, + -value => "loads", -variable => \$order_by, + -command => $ord_bn_cb) + ->grid(-column => 0, -row => 2, -sticky => "w"); +$ord_bn{parse_calls} = + $frame3->Radiobutton(-text => "Parse calls", -highlightthickness => 0, + -value => "parse_calls", -variable => \$order_by, + -command => $ord_bn_cb) + ->grid(-column => 1, -row => 2, -sticky => "w"); +$ord_bn{executions} = + $frame3->Radiobutton(-text => "Executions", -highlightthickness => 0, + -value => "executions", -variable => \$order_by, + -command => $ord_bn_cb) + ->grid(-column => 0, -row => 3, -sticky => "w"); +$ord_bn{first_load_time} = + $frame3->Radiobutton(-text => "First load", -highlightthickness => 0, + -value => "first_load_time", -variable => \$order_by, + -command => $ord_bn_cb) + ->grid(-column => 1, -row => 3, -sticky => "w"); +$frame3->pack(-side => "left", -padx => 6); + +# Sort order frame +$frame3 = $frame2->Frame(-highlightthickness => 1); +$sort_bn{desc} = + $frame3->Radiobutton(-text => "Descending", -highlightthickness => 0, + -value => "desc", -variable => \$sort_by, + -command => $ord_bn_cb) + ->grid(-column => 0, -row => 0, -sticky => "w"); +$sort_bn{asc} = + $frame3->Radiobutton(-text => "Ascending", -highlightthickness => 0, + -value => "asc", -variable => \$sort_by, + -command => $ord_bn_cb) + ->grid(-column => 0, -row => 1, -sticky => "w"); +$frame3->pack(-side => "right", -padx => 6); +$frame2->grid(-column => 0, -row => 1, -sticky => "w", -columnspan => 2); + +## Other options frame +$frame2 = $frame1->Frame(-highlightthickness => 0); +$frame2->Checkbutton(-text => "Exclude queries by SYS or SYSTEM", + -variable => \$no_sys, -offvalue => 0, -onvalue => 1, + -highlightthickness => 0) + ->grid(-column => 0, -row => 0, -sticky => "w", -columnspan => 2); +$frame2->Label(-text => "First user to execute statement") + ->grid(-column => 0, -row => 1, -sticky => "w"); +$frame2->Entry(-textvariable => \$user, -width => 30) + ->grid(-column => 1, -row => 1, -sticky => "w"); +$frame2->Label(-text => "SQL matches pattern") + ->grid(-column => 0, -row => 2, -sticky => "w"); +$frame2->Entry(-textvariable => \$pattern, -width => 30) + ->grid(-column => 1, -row => 2, -sticky => "w"); +$frame2->Label(-text => "Maximum number of statements") + ->grid(-column => 0, -row => 3, -sticky => "w"); +$frame2->Entry(-textvariable => \$rows, -width => 4) + ->grid(-column => 1, -row => 3, -sticky => "w"); +$frame2->grid(-column => 0, -row => 2, -sticky => "we", + -columnspan => 2, -padx => 6, -pady => 6); +$frame1->pack(-fill => "x"); +&$ord_bn_cb(); # Set the buttons to the initial state +$frame->pack(-fill => "x", ipadx => 6, -ipady => 6); + +### Buttons +$frame = $GrabMain->Frame(-borderwidth => 3, -relief => "raised"); +$frame->Button(-text => "Capture SQL", -command => $grab_cb) + ->pack(-side => "left", -expand => 1, -pady => 6); +$frame->Button(-text => "Copy to Explain", + -command => sub { copy_sql($GrabSql, $GrabSelection); }) + ->pack(-side => "left", -expand => 1, -pady => 6); +$frame->Button(-text => "Close", -command => sub { $GrabMain->withdraw(); }) + ->pack(-side => "left", -expand => 1, -pady => 6); +$frame->pack(-fill => "x"); +} + +################################################################################ +# Main + +### Main window +$ProgName = basename($0); +$ProgName =~ s/\..*$//; +$PlanMain = MainWindow->new(); +$PlanMain->withdraw(); +update_title(); +$Balloon = $PlanMain->Balloon(); + +### Splash screen +my $splash; +if (@ARGV == 0 || $ARGV[0] ne '-q') + { + about($PlanMain, \$splash); + $splash->after(10000, + sub { if ($splash) { $splash->destroy(); undef($splash); } }); + $PlanMain->update(); + } +else + { shift(@ARGV); } + +### Menubar +my $menubar = $PlanMain->Frame(-relief => "raised", -borderwidth => 3); + +# Create a bold font $ figure out charcter spacing +my $t = $PlanMain->Text(); +my $f = $t->cget(-font); +$t->fontCreate("bold", $PlanMain->fontActual($f), -weight => "bold"); +$CharWidth = $PlanMain->fontMeasure($f, "X"); +undef($f); +$t->destroy(); +undef($t); + +my $menubar_file = $menubar->Menubutton(-text => "File", -underline => 0); +$menubar_file->command(-label => "Login ...", -underline => 0, + -command => sub { login_dialog($PlanMain); }); +$menubar_file->command(-label => "Schema ...", -underline => 2, + -command => sub { schema_dialog($PlanMain); }); +$menubar_file->command(-label => "Explain", -underline => 0, + -command => \&explain); +$menubar_file->command(-label => "SQL Cache ...", -underline => 4, + -command => \&grab_main); +$menubar_file->separator(); +$menubar_file->command(-label => "Open File ...", -underline => 0, + -command => sub { open_dialog($PlanMain); }); +$menubar_file->command(-label => "Save File ...", -underline => 0, + -command => sub { save_dialog($PlanMain, $PlanSql); }); +$menubar_file->separator(); +$menubar_file->command(-label => "Exit", -underline => 1, + -command => sub { $Db->disconnect() if ($Db); exit(0); }); +$menubar_file->pack(-side => "left"); + +my $menubar_help = $menubar->Menubutton(-text => "Help", -underline => 0); +$menubar_help->command(-label => "About ...", -underline => 0, + -command => sub { about($PlanMain); }); +$menubar_help->command(-label => "Usage ...", -underline => 0, + -command => sub { help($PlanMain); }); +$menubar_help->pack(-side => "right"); +$menubar->pack(-fill => "x"); + +### Query plan tree +my $frame; +$frame = $PlanMain->Frame(-borderwidth => 3, -relief => "raised"); +$PlanTitle = $frame->Label(-text => "Query Plan")->pack(-anchor => "nw"); +my $b1_cb = sub + { error($PlanMain, $@) if (! eval { disp_plan_step_obj($_[0])}); }; +my $b3_cb = sub + { error($PlanMain, $@) if (! eval { disp_index_popup($_[0])}); }; +$PlanTree = $frame->Scrolled("B3Tree", -height => 15, -width => 80, + -borderwidth => 0, -highlightthickness => 1, + -scrollbars => "osoe", + -browsecmd => \&disp_plan_step, + -command => $b1_cb, -b3command => $b3_cb) + ->pack(-expand => 1, -fill => "both"); +$frame->pack(-expand => 1, -fill => "both"); + +### Query plan statement details +$frame = $PlanMain->Frame(-borderwidth => 3, -relief => "raised"); +$frame->Label(-text => "Query Step Details")->pack(-anchor => "nw"); +$PlanStep = $frame->Scrolled("ROText", -height => 8, -width => 80, + -borderwidth => 0, -wrap => "none", + -setgrid => "true", -scrollbars => "osoe") + ->pack(-fill => "x"); +$frame->pack(-fill => "x"); + +### SQL text editor +$frame = $PlanMain->Frame(-borderwidth => 3, -relief => "raised"); +$frame->Label(-text => "SQL Editor")->pack(-anchor => "nw"); +$PlanSql = $frame->Scrolled("Text", -setgrid => "true", -scrollbars => "oe", + -borderwidth => 0, -height => 15, -width => 80, + -wrap => "word") + ->pack(-expand => 1, -fill => "both"); +$frame->pack(-expand => 1, -fill => "both"); + +### Buttons +$frame = $PlanMain->Frame(-borderwidth => 3, -relief => "raised"); +$frame->Button(-text => "Explain", -command => \&explain) + ->pack(-side => "left", -expand => 1, -pady => 6); +$frame->Button(-text => "Clear", -command => \&clear_editor) + ->pack(-side => "left", -expand => 1, -pady => 6); +$frame->Button(-text => "SQL Cache", -command => \&grab_main) + ->pack(-side => "left", -expand => 1, -pady => 6); +$frame->pack(-fill => "x"); + +### user/pass@db command-line argument processing +$PlanMain->update(); +$PlanMain->deiconify(); +$splash->raise() if (defined($splash)); +if (@ARGV >= 1 && $ARGV[0] =~ /\w*\/\w*(@\w+)?/) + { + my ($username, $password, $database) = split(/[\/@]/, shift(@ARGV)); + if (! $username) { $username = "/"; $password = ""; } + if (! $database) { $database = $ENV{TWO_TASK} || $ENV{ORACLE_SID}; } + error($PlanMain, $@) if (! eval { login($database, $username, $password); }); + update_title(); + } +else + { + login_dialog($PlanMain); + } + +### SQL filename argument processing +if (@ARGV >= 1 && -r $ARGV[0]) + { + my $file = shift(@ARGV); + if (open_file($file)) + { + $FileDir = dirname($file); + explain() if ($Db); + } + } + +# Doncha just love GUI programming :-) +MainLoop(); + +################################################################################ +__END__ + +=head1 NAME + +explain, ora_explain - Visualise Oracle query plans + +=head1 SYNOPSIS + + $ explain [ [ user/password@database ] sql script ] + $ ora_explain [ [ user/password@database ] sql script ] + +B When bundled with DBD::Oracle, the script is called ora_explain + +=head1 DESCRIPTION + +Explain is a GUI-based tool that enables easier visualisation of Oracle Query +plans. A query plan is the access path that Oracle will use to satisfy a SQL +query. The Oracle query optimiser is responsible for deciding on the optimal +path to use. Needless to say, understanding such plans requires a fairly +sophisticated knowledge of Oracle architecture and internals. + +Explain allows a user to interactively edit a SQL statemant and view the +resulting query plan with the click of a single button. The effects of +modifying the SQL or of adding hints can be rapidly established. + +Explain allows the user to capture all the SQL currently cached by Oracle. The +SQL capture can be filtered and sorted by different criterea, e.g. all SQL +matching a pattern, order by number of executions etc. + +Explain is written using Perl, DBI/DBD::Oracle and Tk. + +=head1 PREREQUISITES + +=over 2 + +=item 1. + +Oracle 7 or Oracle 8, with SQL*Net if appropriate + +=item 2. + +L or later + +=item 3. + +L version 1.02 or later + +=item 4. + +L 0.54 or later + +=item 5. + +L 800.011 or later + +=item 6. + +L 3.15 or later + +=back + +Items 2 through 6 can be obtained from any CPAN mirror. + +=head1 INSTALLATION + +=over 2 + +=item 1. + +Check you have all the prequisites installed and working. + +=item 2. + +Run 'perl Makefile.PL; make instal1' + +=item 3. + +Make sure you have run the script $ORACLE_HOME/rdbms/admin/utlxplan.sql +from a SQL*Plus session. This script creates the PLAN_TABLE that is used +by Oracle when explaining query plans. + +=back + +=head1 HOW TO USE + +Type "explain" or "ora_explain" at the shell prompt. A window will appear with +a menu bar and three frames, labelled "Query Plan", "Query Step Details" and +"SQL Editor". At the bottom of the window are three buttons labelled +"Explain", "Clear" and "SQL Cache". A login dialog will also appear, into +which you should enter the database username, password and database instance +name (SID). The parameters you enter are passed to the DBI->connect() method, +so if you have any problems refer to the DBI and DBD::Oracle documentation. + +Optionally you may supply up to two command-line arguments. If the first +argument is of the form username/password@database, explain will use this to +log in to Oracle, otherwise if it is a filename it will be loaded into the SQL +editor. If two arguments are supplied, the second one will be assumed to be a +filename. + +Examples: + + explain scott/tiger@DEMO query.sql + explain / query.sql + explain query.sql + +=head2 Explain functionality + +The menu bar has two pulldown menus, "File" and "Help". "File" allows you to +login to Oracle, Change the current schema, Capture the contents of the Oracle +SQL cache, Load SQL from files, Save SQL to files and to Exit the program. +"Help" allows you to view release information and read this documentation. + +The "SQL Editor" frame allows the editing of a SQL statement. This should be +just a single statement - multiple statements are not allowed. Refer to the +documentation for the Tk text widget for a description of the editing keys +available. Text may be loaded and saved by using the "File" pulldown menu. + +Once you have entered a SQL statement, the "Explain" button at the bottom of +the window will generate the query plan for the statement. A tree +representation of the plan will appear in the "Query Plan" frame. Individual +"legs" of the plan may be expanded and collapsed by clicking on the "+' and "-" +boxes on the plan tree. The tree is drawn so that the "innermost" or "first" +query steps are indented most deeply. The connecting lines show the +"parent-child" relationships between the query steps. For a comprehensive +explanation of the meaning of query plans you should refer to the relevant +Oracle documentation. The "Clear" button will empty the editor & query plan +tree panes. + +Single-clicking on a plan step in the Query Plan pane will display more +detailed information on that query step in the Query Step Details frame. This +information includes Oracle's estimates of cost, cardinality and bytes +returned. The exact information displayed depends on the Oracle version. +Again, for detailed information on the meaning of these fields, refer to the +Oracle documentation. + +Double-clicking on a plan step that refers to either a table or an index will +pop up a dialog box showing the definition of the table or index in a format +similar to that of the SQL*Plus 'desc' command. + +The dialog that appears has a button labelled 'Index'. Clicking on this will +expand the table dialog to show all the indexes defined on the table. Each +column represents an index, and the figures define the order that the table +columns appears in the index. To find out the name of an index, position the +mouse over the index column. A single click will display the definition of the +index in a seperate dialog. + +Right-clicking on a plan step that refers to a table will pop up a menu showing +a list of the indexes available for the table. Selecting an index will display +its definition in a dialog box. + +=head2 Capture SQL Cache functionality + +The explain window has an option on the "File" menu labelled "SQL Cache ...", +as well as a button with the same function. Selecting this will popup a new +top-level window containing a menu bar and three frames, labelled "SQL Cache", +"SQL Statement Statistics" and "SQL Selection Criterea". At the bottom of the +window are three buttons labelled "Capture SQL", "Explain" and "Close". + +The menu bar has two pulldown menus "File" and "Help". "File" allows you to +Save the contents of the SQL Cache pane to a file, copy the selected SQL +statement to the Explain window and Close the Grab window. + +The "SQL Cache" frame shows the statements currently in the Oracle SQL cache. +As you move the cursor over this window, each SQL statement will be highlighted +with an outline box. Single-clicking on a statement in the SQL Cache pane will +highlight the stamement in green and display more detailed information on that +statement in the SQL Statement Statistics frame. + +If you want to save the entire contents of the SQL Cache pane, you can do this +from the "File" menu. + +The "SQL Selection Criterea" frame allows you to specify which SQL statements +you are interested in, and how you want them sorted. The pattern used to select +statements is a normal perl regexp. Once you have defined the selection +criterea, clicking the "Capture SQL" button will read all the matching +statements from the SQL cache and display them in the top frame. + +Double-clicking on a statement in the "SQL Cache" pane, selecting "Explain" +from the "File" menu or clicking the "Explain" button will copy the currently +highlighted statement in the "SQL Cache" pane to the SQL editor in the Explain +window, so that the query plan for the statement can be examined. Note also +that the current schema will be changed to that of the user who first executed +the captured statement. + +=head1 SEE ALSO + +This tool assumes that you already know how to interpret Oracle query plans. +If need an explanation of the information displayed by this tool, you should +refer to the appropriate Oracle documentation. Information can be found in the +"Concepts" and "Oracle Tuning" manuals - look for "Query plan" and "Explain +plan". Two other useful sources of information are: + + Oracle Performance Tuning, 2nd ed. + Mark Gurry and Peter Corrigan + O'Reilly & Associates, Inc. + ISBN 1-56592-237-9 + + Advanced Oracle Tuning and Administration + Eyal Aronoff, Kevin Loney and Noorali Sonawalla + Oracle Press (Osborne) + ISBN 0-07-882241-6 + +=head1 SUPPORT + +Support questions and suggestions can be directed to Alan.Burlison@uk.sun.com + +=head1 COPYRIGHT AND DISCLAIMER + +Copyright (c) 1999 Alan Burlison + +You may distribute under the terms of either the GNU General Public License +or the Artistic License, as specified in the Perl README file, with the +exception that it cannot be placed on a CD-ROM or similar media for commercial +distribution without the prior approval of the author. + +This code is provided with no warranty of any kind, and is used entirely at +your own risk. + +This code was written by the author as a private individual, and is in no way +endorsed or warrantied by Sun Microsystems. + +=cut +SCRIPT + +use Config; + +my $file = __FILE__; $file =~ s/\.PL$//; + +$script =~ s/\~(\w+)\~/$Config{$1}/eg; +if (!(open(FILE, ">$file")) || + !(print FILE $script) || + !(close(FILE))) { + die "Error while writing $file: $!\n"; +} +print "Extracted $file from ",__FILE__," with variable substitutions.\n"; + +# End. diff --git a/oraperl.ph b/oraperl.ph new file mode 100644 index 00000000..99f62994 --- /dev/null +++ b/oraperl.ph @@ -0,0 +1,53 @@ +# DBD::Oracle Oraperl emulation. This file is not relevant to the +# emulation but is included for completeness only. +# I have updated %ora_types in case it's used. Tim Bunce. + +# oraperl.ph +# +# Various constants which may be useful in oraperl programs +# +# Author: Kevin Stock +# Date: 28th October 1991 +# Last Change: 8th April 1992 + + +# Oraperl error codes, set in $ora_errno + +$ORAP_NOMEM = 100001; # out of memory +$ORAP_INVCSR = 100002; # invalid cursor supplied +$ORAP_INVLDA = 100003; # invalid lda supplied +$ORAP_NOSID = 100004; # couldn't set ORACLE_SID +$ORAP_BADVAR = 100005; # bad colon variable sequence +$ORAP_NUMVARS = 100006; # wrong number of colon variables +$ORAP_NODATA = 100007; # statement does not return data + + +# Oraperl debugging codes for $ora_debug +# From version 2, you shouldn't really use these. + +$ODBG_EXEC = 8; # program execution +$ODBG_STRNUM = 32; # string/numeric conversions +$ODBG_MALLOC = 128; # memory allocation/release + +# Oracle datatypes +# I don't know whether these are valid for all versions. + +%ora_types = +( + 1, 'character array', + 2, 'number', + 3, 'signed integer', + 4, 'float', + 7, 'packed decimal', + 8, 'long string', + 9, 'varchar', + 11, 'rowid', + 12, 'date', + 15, 'varraw', + 23, 'raw', + 24, 'long raw', + 96, 'char', + 106,'mlslabel', +); + +1; diff --git a/t/base.t b/t/base.t new file mode 100755 index 00000000..f760fdc8 --- /dev/null +++ b/t/base.t @@ -0,0 +1,48 @@ +#!perl -w + +# Base DBD Driver Test + +print "1..$tests\n"; + +require DBI; +print "ok 1\n"; + +import DBI; +print "ok 2\n"; + +$switch = DBI->internal; +(ref $switch eq 'DBI::dr') ? print "ok 3\n" : print "not ok 3\n"; + +eval { + +# This is a special case. install_driver should not normally be used. +$drh = DBI->install_driver('Oracle'); +(ref $drh eq 'DBI::dr') ? print "ok 4\n" : print "not ok 4\n"; + +}; +if ($@) { + $@ =~ s/\n\n+/\n/g if $@; + warn "Failed to load Oracle extension and/or shared libraries:\n$@" if $@; + warn "The remaining tests will probably also fail with the same error.\a\n\n"; + # try to provide some useful pointers for some cases + if ($@ =~ /Solaris patch.*Java/i) { + warn "*** Please read the README.java file for help. ***\n"; + } + else { + warn "*** Please read the README and README.help files for help. ***\n"; + } + warn "\n"; + sleep 5; +} + +print "ok 5\n" if $drh->{Version}; + +BEGIN { $tests = 5 } +exit 0; +# end. + +__END__ + +You must install a Solaris patch to run this version of +the Java runtime. +Please see the README and release notes for more information. diff --git a/t/general.t b/t/general.t new file mode 100644 index 00000000..fa95d229 --- /dev/null +++ b/t/general.t @@ -0,0 +1,82 @@ +#!perl -w + +sub ok ($$;$) { + my($n, $ok, $warn) = @_; + ++$t; + die "sequence error, expected $n but actually $t" + if $n and $n != $t; + ($ok) ? print "ok $t\n" + : print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n"; + if (!$ok && $warn) { + $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1'; + warn "$warn\n"; + } +} + +use DBI; +$| = 1; + +my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger'; +my $dbh = DBI->connect('dbi:Oracle:', $dbuser, ''); + +unless($dbh) { + warn "Unable to connect to Oracle ($DBI::errstr)\nTests skiped.\n"; + print "1..0\n"; + exit 0; +} + +print "1..$tests\n"; + +my($sth, $p1, $p2, $tmp); + +$sth = $dbh->prepare(q{ + /* also test preparse doesn't get confused by ? :1 */ + select * from user_tables -- ? :1 +}); +ok(0, $sth->execute); +ok(0, $sth->{NUM_OF_FIELDS}); +eval { $p1=$sth->{NUM_OFFIELDS_typo} }; +ok(0, $@ =~ /attribute/); +ok(0, $sth->{Active}); +ok(0, $sth->finish); +ok(0, !$sth->{Active}); + +$sth = $dbh->prepare("select * from user_tables"); +ok(0, $sth->execute); +ok(0, $sth->{Active}); +1 while ($sth->fetch); # fetch through to end +ok(0, !$sth->{Active}); + +# so following test works with other NLS settings/locations +ok(0, $dbh->do("ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'"), 1); + +ok(0, $tmp = $dbh->selectall_arrayref(q{ + select 1 * power(10,-130) "smallest?", + 9.9999999999 * power(10,125) "biggest?" + from dual +})); +my @tmp = @{$tmp->[0]}; +#warn "@tmp"; $tmp[0]+=0; $tmp[1]+=0; warn "@tmp"; +ok(0, $tmp[0] <= 1e-130, $tmp[0]); +ok(0, $tmp[1] >= 9.99e+125, $tmp[1]); + + +eval { + $dbh->{RaiseError} = 1; + $dbh->do("some invalid sql statement"); +}; +ok(0, $@ =~ /DBD::Oracle::db do failed:/, "eval error: ``$@'' expected 'do failed:'"); +$dbh->{RaiseError} = 0; + +# --- + +ok(0, $dbh->ping); +$dbh->disconnect; +$dbh->{PrintError} = 0; +ok(0, !$dbh->ping); + +exit 0; +BEGIN { $tests = 16 } +# end. + +__END__ diff --git a/t/long.t b/t/long.t new file mode 100644 index 00000000..04008c26 --- /dev/null +++ b/t/long.t @@ -0,0 +1,344 @@ +#!perl -w + +use DBI; +use DBD::Oracle qw(:ora_types ORA_OCI); +use strict; + +# +# Search for 'ocibug' to find code related to OCI LONG bugs. +# + +$| = 1; +my $t = 0; +my $failed = 0; +my %ocibug; +my $table = "dbd_ora__drop_me"; + +my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger'; +my $dbh = DBI->connect('dbi:Oracle:', $dbuser, '', { + AutoCommit => 1, + PrintError => 0, +}); + +unless($dbh) { + warn "Unable to connect to Oracle ($DBI::errstr)\nTests skiped.\n"; + print "1..0\n"; + exit 0; +} + +unless(create_table("lng LONG")) { + warn "Unable to create test table ($DBI::errstr)\nTests skiped.\n"; + print "1..0\n"; + exit 0; +} + + +my @test_sets = ( + [ "LONG", undef ], + [ "LONG RAW", ORA_LONGRAW ] +); +push @test_sets, + [ "CLOB", ORA_CLOB ], + [ "BLOB", ORA_BLOB ] + if ORA_OCI >= 8; + +# Set size of test data (in 10KB units) +# Minimum value 3 (else tests fail because of assumptions) +# Normal value 8 (to test 64KB threshold well) +my $sz = 8; + +my $tests; +my $tests_per_set = 35; +$tests = @test_sets * $tests_per_set; +print "1..$tests\n"; + +my($sth, $p1, $p2, $tmp, @tmp); +#$dbh->trace(4); + +foreach (@test_sets) { + run_long_tests( @$_ ); +} + + +sub run_long_tests { + my ($type_name, $type_num) = @_; + +# relationships between these lengths are important # e.g. +my $long_data0 = ("0\177x\0X" x 2048) x (1 ); # 10KB < 64KB +my $long_data1 = ("1234567890" x 1024) x ($sz ); # 80KB >> 64KB && > long_data2 +my $long_data2 = ("2bcdefabcd" x 1024) x ($sz-1); # 70KB > 64KB && < long_data1 + +# special hack for long_data0 since RAW types need pairs of HEX +$long_data0 = "00FF" x (length($long_data0) / 2) if $type_name =~ /RAW/i; + +my $len_data0 = length($long_data0); +my $len_data1 = length($long_data1); +my $len_data2 = length($long_data2); +print "long_data0 length $len_data0\n"; +print "long_data1 length $len_data1\n"; +print "long_data2 length $len_data2\n"; + +# warn if some of the key aspects of the data sizing are tampered with +warn "long_data0 is > 64KB: $len_data0\n" + if $len_data0 > 65535; +warn "long_data1 is < 64KB: $len_data1\n" + if $len_data1 < 65535; +warn "long_data2 is not smaller than $long_data1 ($len_data2 > $len_data1)\n" + if $len_data2 >= $len_data1; + + +if (!create_table("lng $type_name", 1)) { + # typically OCI 8 client talking to Oracle 7 database + warn "Unable to create test table for '$type_name' data ($DBI::err). Tests skipped.\n"; + foreach (1..$tests_per_set) { ok(0, 1) } + return; +} + +print " --- insert some $type_name data\n"; +ok(0, $sth = $dbh->prepare("insert into $table values (?, ?, SYSDATE)"), 1); +$sth->bind_param(2, undef, { ora_type => $type_num }) or die $DBI::errstr + if $type_num; +ok(0, $sth->execute(40, $long_data0), 1); +ok(0, $sth->execute(41, $long_data1), 1); +ok(0, $sth->execute(42, $long_data2), 1); + + +print " --- fetch $type_name data back again -- truncated - LongTruncOk == 1\n"; +$dbh->{LongReadLen} = 20; +$dbh->{LongTruncOk} = 1; +print "LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n"; + +# This behaviour isn't specified anywhere, sigh: +my $out_len = $dbh->{LongReadLen}; +$out_len *= 2 if ($type_name =~ /RAW/i); + +ok(0, $sth = $dbh->prepare("select * from $table order by idx"), 1); +ok(0, $sth->execute, 1); +ok(0, $tmp = $sth->fetchall_arrayref, 1); +ok(0, $tmp->[0][1] eq substr($long_data0,0,$out_len), + cdif($tmp->[0][1], substr($long_data0,0,$out_len), "Len ".length($tmp->[0][1])) ); +ok(0, $tmp->[1][1] eq substr($long_data1,0,$out_len), + cdif($tmp->[1][1], substr($long_data1,0,$out_len), "Len ".length($tmp->[1][1])) ); +ok(0, $tmp->[2][1] eq substr($long_data2,0,$out_len), + cdif($tmp->[2][1], substr($long_data2,0,$out_len), "Len ".length($tmp->[2][1])) ); + + +print " --- fetch $type_name data back again -- truncated - LongTruncOk == 0\n"; +$dbh->{LongReadLen} = $len_data1 - 10; # so $long_data0 fits but long_data1 doesn't +$dbh->{LongReadLen} = $dbh->{LongReadLen} / 2 if $type_name =~ /RAW/i; +$dbh->{LongTruncOk} = 0; +print "LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n"; + +ok(0, $sth = $dbh->prepare("select * from $table order by idx"), 1); +ok(0, $sth->execute, 1); + +ok(0, $tmp = $sth->fetchrow_arrayref, 1); +ok(0, $tmp->[1] eq $long_data0, length($tmp->[1])); + +ok(0, !defined $sth->fetchrow_arrayref, + "truncation error not triggered " + ."(LongReadLen $dbh->{LongReadLen}, data ".length($tmp->[1]||0).")"); +$tmp = $sth->err || 0; +ok(0, $tmp == 1406 || $tmp == 24345, 1); + + +print " --- fetch $type_name data back again -- complete - LongTruncOk == 0\n"; +$dbh->{LongReadLen} = $len_data1 +1000; +$dbh->{LongTruncOk} = 0; +print "LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n"; + +ok(0, $sth = $dbh->prepare("select * from $table order by idx"), 1); +#$sth->trace(4); +ok(0, $sth->execute, 1); + +ok(0, $tmp = $sth->fetchrow_arrayref, 1); +ok(0, $tmp->[1] eq $long_data0, length($tmp->[1])); + +ok(0, $tmp = $sth->fetchrow_arrayref, 1); +ok(0, $tmp->[1] eq $long_data1, length($tmp->[1])); + +ok(0, $tmp = $sth->fetchrow_arrayref, 1); +if ($tmp->[1] eq $long_data2) { + ok(0, 1); +} +elsif (length($tmp->[1]) == length($long_data1) + && DBD::Oracle::ORA_OCI() == 7 + && substr($tmp->[1], 0, length($long_data2)) eq $long_data2 +) { + print "OCI7 buffer overwite bug detected\n"; + $ocibug{LongReadLen} = __LINE__; # see also blob_read tests below + # The bug: + # If you fetch a LONG field and then fetch another row + # which has a LONG field shorter than the previous + # then the second long will appear to have the + # longer portion of first appended to it! + ok(0, 1); +} +else { + ok(0, $tmp->[1] eq $long_data2, + cdif($tmp->[1],$long_data2, "Len ".length($tmp->[1])) ); +} +$sth->trace(0); + + +print " --- fetch $type_name data back again -- via blob_read\n"; +if (ORA_OCI >= 8 && $type_name =~ /LONG/i) { + print "Skipped blob_read tests for LONGs with OCI8 - not currently supported.\n"; + foreach (1..11) { ok(0,1) } + return; +} +#$dbh->trace(4); +$dbh->{LongReadLen} = 1024 * 90; +$dbh->{LongTruncOk} = 1; +ok(0, $sth = $dbh->prepare("select * from $table order by idx"), 1); +ok(0, $sth->execute, 1); +ok(0, $tmp = $sth->fetchrow_arrayref, 1); + +ok(0, blob_read_all($sth, 1, \$p1, 4096) == length($long_data0), 1); +ok(0, $p1 eq $long_data0, cdif($p1, $long_data0)); + +ok(0, $tmp = $sth->fetchrow_arrayref, 1); +ok(0, blob_read_all($sth, 1, \$p1, 12345) == length($long_data1), 1); +ok(0, $p1 eq $long_data1, cdif($p1, $long_data1)); + +ok(0, $tmp = $sth->fetchrow_arrayref, 1); +my $len = blob_read_all($sth, 1, \$p1, 34567); + +if ($len == length($long_data2)) { + ok(0, $len == length($long_data2), $len); + # Oracle may return the right length but corrupt the string. + ok(0, $p1 eq $long_data2, cdif($p1, $long_data2) ); +} +elsif ($len == length($long_data1) + && DBD::Oracle::ORA_OCI() == 7 + && substr($p1, 0, length($long_data2)) eq $long_data2 +) { + print "OCI7 buffer overwite bug detected\n"; + $ocibug{blob_read} = __LINE__; # see also blob_read tests below + # The bug: + # If you use blob_read to read a LONG field + # and then fetch another row + # and use blob_read to read that LONG field + # If the second LONG is shorter than the first + # then the second long will appear to have the + # longer portion of first appended to it. + ok(0, 1); + ok(0, 1, 0); +} +else { + ok(0, 0, "Fetched length $len, expected ".length($long_data2)); + ok(0, 0, 0); +} + +} # end of run_long_tests + +if (%ocibug) { + my @lines = sort values %ocibug; + warn "\n\aYour version of Oracle 7 OCI has a bug that affects fetching LONG data.\n"; + warn "See the t/long.t script near lines @lines for more information.\n"; + warn "You can safely ignore this if: You don't fetch data from LONG fields;\n"; + warn "Or the LONG data you fetch is never longer than 65535 bytes long;\n"; + warn "Or you only fetch one LONG record in the life of a statement handle.\n"; +} + +if ($failed) { + warn "\nSome tests for LONG data type handling failed. These are generally Oracle bugs.\n"; + warn "Please report this to the dbi-users mailing list, and include the\n"; + warn "Oracle version number of both the client and the server.\n"; + warn "Please also include the output of the 'perl -V' command.\n"; + warn "(If you can, please study t/long.t to investigate the cause.\n"; + warn "Feel free to edit the tests to see what's happening in more detail.\n"; + warn "Especially by adding trace() calls around the failing tests.\n"; + warn "Run the tests manually using the command \"perl -Mblib t/long.t\")\n"; + warn "Meanwhile, if the other tests have passed you can use DBD::Oracle.\n\n"; +} + +sleep 6 if $failed || %ocibug; + +exit 0; +BEGIN { $tests = 27 } +END { + $dbh->do(qq{ drop table $table }) if $dbh; +} +# end. + + +# ---- + +sub create_table { + my ($fields, $drop) = @_; + my $sql = "create table $table ( idx integer, $fields, dt date )"; + $dbh->do(qq{ drop table $table }) if $drop; + $dbh->do($sql); + if ($dbh->err && $dbh->err==955) { + $dbh->do(qq{ drop table $table }); + warn "Unexpectedly had to drop old test table '$table'\n" unless $dbh->err; + $dbh->do($sql); + } + return 0 if $dbh->err; + print "$sql\n"; + return 1; +} + +sub blob_read_all { + my ($sth, $field_idx, $blob_ref, $lump) = @_; + + $lump ||= 4096; # use benchmarks to get best value for you + my $offset = 0; + my @frags; + while (1) { + my $frag = $sth->blob_read($field_idx, $offset, $lump); + return unless defined $frag; + my $len = length $frag; + last unless $len; + push @frags, $frag; + $offset += $len; + #warn "offset $offset, len $len\n"; + } + $$blob_ref = join "", @frags; + return length($$blob_ref); +} + +sub unc { + my @str = @_; + foreach (@str) { s/([\000-\037\177-\377])/ sprintf "\\%03o", ord($_) /eg; } + return join "", @str unless wantarray; + return @str; +} + +sub cdif { + my ($s1, $s2, $msg) = @_; + $msg = ($msg) ? ", $msg" : ""; + my ($l1, $l2) = (length($s1), length($s2)); + return "Strings are identical$msg" if $s1 eq $s2; + return "Strings are of different lengths ($l1 vs $l2)$msg" # check substr matches? + if $l1 != $l2; + my $i; + for($i=0; $i < $l1; ++$i) { + my ($c1,$c2) = (ord(substr($s1,$i,1)), ord(substr($s2,$i,1))); + next if $c1 == $c2; + return sprintf "Strings differ at position %d (\\%03o vs \\%03o)$msg", + $i,$c1,$c2; + } + return "(cdif error $l1/$l2/$i)"; +} + + +sub ok ($$;$) { + my($n, $ok, $warn) = @_; + $warn ||= ''; + ++$t; + die "sequence error, expected $n but actually $t" + if $n and $n != $t; + if ($ok) { + print "ok $t\n"; + } + else { + $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1'; + warn "# failed test $t at line ".(caller)[2].". $warn\n"; + print "not ok $t\n"; + ++$failed; + } +} + +__END__ diff --git a/t/plsql.t b/t/plsql.t new file mode 100644 index 00000000..0113a719 --- /dev/null +++ b/t/plsql.t @@ -0,0 +1,290 @@ +#!perl -w + +sub ok ($$;$) { + my($n, $ok, $warn) = @_; + ++$t; + die "sequence error, expected $n but actually $t" + if $n and $n != $t; + ($ok) ? print "ok $t\n" + : print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n"; + if (!$ok && $warn) { + $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1'; + warn "$warn\n"; + } +} + +use DBI; +use DBD::Oracle qw(ORA_RSET); +use strict; + +$| = 1; + +my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger'; +my $dbh = DBI->connect('', $dbuser, '', 'Oracle'); + +unless($dbh) { + warn "Unable to connect to Oracle ($DBI::errstr)\nTests skiped.\n"; + print "1..0\n"; + exit 0; +} + +# ORA-00900: invalid SQL statement +# ORA-06553: PLS-213: package STANDARD not accessible +my $tst = $dbh->prepare(q{declare foo char(50); begin RAISE INVALID_NUMBER; end;}); +if ($dbh->err && ($dbh->err==900 || $dbh->err==6553 || $dbh->err==600)) { + warn "Your Oracle server doesn't support PL/SQL" if $dbh->err== 900; + warn "Your Oracle PL/SQL is not properly installed" if $dbh->err==6553||$dbh->err==600; + warn "Tests skipped\n"; + print "1..0\n"; + exit 0; +} + +my $tests; +print "1..$tests\n"; + +my($csr, $p1, $p2, $tmp, @tmp); +#DBI->trace(4,"trace.log"); + + +# --- test raising predefined exception +ok(0, $csr = $dbh->prepare(q{ + begin RAISE INVALID_NUMBER; end; +}), 1); + +# ORA-01722: invalid number +ok(0, ! $csr->execute, 1); +ok(0, $DBI::err == 1722); +ok(0, $DBI::err == 1722); # make sure error doesn't get cleared + + +# --- test raising user defined exception +ok(0, $csr = $dbh->prepare(q{ + DECLARE FOO EXCEPTION; + begin raise FOO; end; +}), 1); + +# ORA-06510: PL/SQL: unhandled user-defined exception +ok(0, ! $csr->execute, 1); +ok(0, $DBI::err == 6510); + + +# --- test raise_application_error with literal values +ok(0, $csr = $dbh->prepare(q{ + declare err_num number; err_msg char(510); + begin RAISE_APPLICATION_ERROR(-20101,'app error'); end; +}), 1); + +# ORA-20101: app error +ok(0, ! $csr->execute, 1); +ok(0, $DBI::err == 20101); +ok(0, $DBI::errstr =~ m/app error/); + + +# --- test raise_application_error with 'in' parameters +ok(0, $csr = $dbh->prepare(q{ + declare err_num varchar2(555); err_msg varchar2(510); + --declare err_num number; err_msg char(510); + begin + err_num := :1; + err_msg := :2; + raise_application_error(-20000-err_num, 'msg is '||err_msg); + end; +}), 1); + +ok(0, ! $csr->execute(42, "hello world"), 1); +ok(0, $DBI::err == 20042, $DBI::err); +ok(0, $DBI::errstr =~ m/msg is hello world/, 1); + +# --- test named numeric in/out parameters +ok(0, $csr = $dbh->prepare(q{ + begin + :arg := :arg * :mult; + end; +}), 1); + +$p1 = 3; +ok(0, $csr->bind_param_inout(':arg', \$p1, 4), 1); +ok(0, $csr->bind_param(':mult', 2), 1); +ok(0, $csr->execute, 1); +ok(0, $p1 == 6); +# execute 10 times from $p1=1, 2, 4, 8, ... 1024 +$p1 = 1; foreach (1..10) { $csr->execute || die $DBI::errstr; } +ok(0, $p1 == 1024); + +# --- test undef parameters +ok(0, $csr = $dbh->prepare(q{ + declare foo char(500); + begin foo := :arg; end; +}), 1); +my $undef; +ok(0, $csr->bind_param_inout(':arg', \$undef,10), 1); +ok(0, $csr->execute, 1); + + +# --- test named string in/out parameters +ok(0, $csr = $dbh->prepare(q{ + declare str varchar2(1000); + begin + :arg := nvl(upper(:arg), 'null'); + :arg := :arg || :append; + end; +}), 1); + +undef $p1; +$p1 = "hello world"; +ok(0, $csr->bind_param_inout(':arg', \$p1, 1000), 1); +ok(0, $csr->bind_param(':append', "!"), 1); +ok(0, $csr->execute, 1); +ok(0, $p1 eq "HELLO WORLD!"); +# execute 10 times growing $p1 to force realloc +foreach (1..10) { + $p1 .= " xxxxxxxxxx"; + $csr->execute || die $DBI::errstr; +} +my $expect = "HELLO WORLD!" . (" XXXXXXXXXX!" x 10); +ok(0, $p1 eq $expect); + + +# --- test binding a null and getting a string back +undef $p1; +ok(0, $csr->execute, 1); +ok(0, $p1 eq 'null!'); + +$csr->finish; + + +ok(0, $csr = $dbh->prepare(q{ + begin + :out := nvl(upper(:in), 'null'); + end; +}), 1); +#$csr->trace(3); +my $out; +ok(0, $csr->bind_param_inout(':out', \$out, 1000), 1); + +ok(0, $csr->bind_param(':in', "foo", DBI::SQL_CHAR()), 1); +ok(0, $csr->execute, 1); +ok(0, $out eq "FOO"); + +ok(0, $csr->bind_param(':in', ""), 1); +ok(0, $csr->execute, 1); +ok(0, $out eq "null"); + + +# --- test out buffer being too small +ok(0, $csr = $dbh->prepare(q{ + begin + select rpad('foo',200) into :arg from dual; + end; +}), 1); +#$csr->trace(3); +undef $p1; # force buffer to be freed +ok(0, $csr->bind_param_inout(':arg', \$p1, 20), 1); +# Execute fails with: +# ORA-06502: PL/SQL: numeric or value error +# ORA-06512: at line 3 (DBD ERROR: OCIStmtExecute) +$tmp = $csr->execute; +#$tmp = undef if DBD::Oracle::ORA_OCI()==8; # because BindByName given huge max len +ok(0, !defined $tmp, 1); +# rebind with more space - and it should work +ok(0, $csr->bind_param_inout(':arg', \$p1, 200), 1); +ok(0, $csr->execute, 1); +ok(0, length($p1) == 200, 0); + + +# --- test plsql_errstr function +#$csr = $dbh->prepare(q{ +# create or replace procedure perl_dbd_oracle_test as +# begin +# procedure filltab( stuff out tab ); asdf +# end; +#}); +#ok(0, ! $csr); +#if ($dbh->err && $dbh->err == 6550) { # PL/SQL error +# warn "errstr: ".$dbh->errstr; +# my $msg = $dbh->func('plsql_errstr'); +# warn "plsql_errstr: $msg"; +# ok(0, $msg =~ /Encountered the symbol/, "plsql_errstr: $msg"); +#} +#else { +# warn "plsql_errstr test skipped ($DBI::err)\n"; +# ok(0, 1); +#} +#die; + +# --- test dbms_output_* functions +$dbh->{PrintError} = 1; +ok(0, $dbh->func(30000, 'dbms_output_enable'), 1); + +#$dbh->trace(3); +my @ary = ("foo", ("bar" x 15), "baz", "boo"); +ok(0, $dbh->func(@ary, 'dbms_output_put'), 1); + +@ary = scalar $dbh->func('dbms_output_get'); # scalar context +ok(0, @ary==1 && $ary[0] && $ary[0] eq 'foo', 0); + +@ary = scalar $dbh->func('dbms_output_get'); # scalar context +ok(0, @ary==1 && $ary[0] && $ary[0] eq 'bar' x 15, 0); + +@ary = $dbh->func('dbms_output_get'); # list context +ok(0, join(':',@ary) eq 'baz:boo', 0); +$dbh->{PrintError} = 0; +#$dbh->trace(0); + +# --- test cursor variables +if (1) { + my $cur_query = q{ + SELECT object_name, owner FROM all_objects + WHERE object_name LIKE :p1 and ROWNUM <= 3 + }; + my $cur1 = 42; + #$dbh->trace(4); + my $parent = $dbh->prepare(qq{ + BEGIN OPEN :cur1 FOR $cur_query; END; + }); + ok(0, $parent); + ok(0, $parent->bind_param(":p1", "V%")); + ok(0, $parent->bind_param_inout(":cur1", \$cur1, 0, { ora_type => ORA_RSET } )); + ok(0, $parent->execute()); + my @r; + push @r, @tmp while @tmp = $cur1->fetchrow_array; + ok(0, @r == 3*2, "rows: ".@r); + #$dbh->trace(0); $parent->trace(0); + + # compare results with normal execution of query + my $s1 = $dbh->selectall_arrayref($cur_query, undef, "V%"); + my @s1 = map { @$_ } @$s1; + ok(0, "@r" eq "@s1", "\nref=(@r),\nsql=(@s1)"); + + # --- test re-bind and re-execute of same 'parent' statement + my $cur1_str = "$cur1"; + #$dbh->trace(4); $parent->trace(4); + ok(0, $parent->bind_param(":p1", "U%")); + ok(0, $parent->execute()); + ok(0, "$cur1" ne $cur1_str); # must be ref to new handle object + @r = (); + push @r, @tmp while @tmp = $cur1->fetchrow_array; + #$dbh->trace(0); $parent->trace(0); $cur1->trace(0); + my $s2 = $dbh->selectall_arrayref($cur_query, undef, "U%"); + my @s2 = map { @$_ } @$s2; + ok(0, "@r" eq "@s2", "\nref=(@r),\nsql=(@s2)"); +} + + + +# --- To do + # test NULLs at first bind + # NULLs later binds. + # returning NULLs + # multiple params, mixed types and in only vs inout + +# --- test ping +ok(0, $dbh->ping); +$dbh->disconnect; +ok(0, !$dbh->ping); + +exit 0; +BEGIN { $tests = 63 } +# end. + +__END__ diff --git a/t/reauth.t b/t/reauth.t new file mode 100644 index 00000000..ca53fca9 --- /dev/null +++ b/t/reauth.t @@ -0,0 +1,46 @@ +#!perl -w + +sub ok ($$;$) { + my($n, $ok, $warn) = @_; + ++$t; + die "sequence error, expected $n but actually $t" + if $n and $n != $t; + ($ok) ? print "ok $t\n" + : print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n"; + if (!$ok && $warn) { + $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1'; + warn "$warn\n"; + } +} + +use DBI; +$| = 1; + +my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger'; +my $dbuser_2 = $ENV{ORACLE_USERID_2} || ''; + +sub give_up { warn @_ if @_; print "1..0\n"; exit 0; } + +if ($dbuser_2 eq '') { + print("ORACLE_USERID_2 not defined.\nTests skiped.\n"); + give_up(); +} +(my $uid1 = uc $dbuser) =~ s:/.*::; +(my $uid2 = uc $dbuser_2) =~ s:/.*::; +if ($uid1 eq $uid2) { + give_up("ORACLE_USERID_2 not unique.\nTests skiped.\n") +} + +my $dbh = DBI->connect('dbi:Oracle:', $dbuser, ''); + +unless($dbh) { + give_up("Unable to connect to Oracle ($DBI::errstr)\nTests skiped.\n"); +} + +print "1..3\n"; + +ok(0, ($dbh->selectrow_array("SELECT USER FROM DUAL"))[0] eq $uid1 ); +ok(0, $dbh->func($dbuser_2, '', 'reauthenticate')); +ok(0, ($dbh->selectrow_array("SELECT USER FROM DUAL"))[0] eq $uid2 ); + +$dbh->disconnect; diff --git a/test.pl b/test.pl new file mode 100755 index 00000000..eaf0a6f4 --- /dev/null +++ b/test.pl @@ -0,0 +1,390 @@ +#!/usr/local/bin/perl -w + +use ExtUtils::testlib; + +die "Use 'make test' to run test.pl\n" unless "@INC" =~ /\bblib\b/; + +# $Id: test.pl,v 1.2 1999/06/08 00:15:02 timbo Exp $ +# +# Copyright (c) 1995-1998, Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +# XXX +# XXX PLEASE NOTE THAT THIS CODE IS A RANDOM HOTCH-POTCH OF TESTS AND +# XXX TEST FRAMEWORKS AND IS IN *NO WAY* A TO BE USED AS A STYLE GUIDE! +# XXX + +require 'getopts.pl'; + +$| = 1; +print q{Oraperl test application $Revision: 1.2 $}."\n"; + +$SIG{__WARN__} = sub { + ($_[0] =~ /^(Bad|Duplicate) free/) + ? warn "\n*** Read the README file about Bad free() warnings!\n": warn @_; +}; + +use Config; +my $os = $Config{osname}; +$opt_d = 0; # debug +$opt_l = 0; # log +$opt_n = 5; # num of loops +$opt_m = 0; # do mem leek test +$opt_c = undef; # set RowCacheSize for some tests +$opt_p = 1; # do perf test +$opt_f = 0; # do fetch test +&Getopts('md:n:f:c:lp ') || die "Invalid options\n"; + +$ENV{PERL_DBI_DEBUG} = 2 if $opt_d; +#$ENV{ORACLE_HOME} ||= '/usr/oracle' unless ($^O eq 'MSWin32'); + +$dbname = $ARGV[0] || ''; # if '' it'll use TWO_TASK/ORACLE_SID +$dbuser = $ENV{ORACLE_USERID} || 'scott/tiger'; + +eval 'use Oraperl; 1' || die $@ if $] >= 5; + +&test_extfetch_perf($opt_f) if $opt_f; + +&test_leak(100) if $opt_m; + +&ora_version; + +my @data_sources = DBI->data_sources('Oracle'); +print "Data sources:\n\t", join("\n\t",@data_sources),"\n\n"; + +print "\nConnecting\n", + " to '$dbname' (from command line, else uses ORACLE_SID or TWO_TASK - recommended)\n"; +print " as '$dbuser' (via ORACLE_USERID env var or default - recommend name/passwd\@dbname)\n"; +printf("(ORACLE_SID='%s', TWO_TASK='%s')\n", $ENV{ORACLE_SID}||'', $ENV{TWO_TASK}||''); +printf("(LOCAL='%s', REMOTE='%s')\n", $ENV{LOCAL}||'', $ENV{REMOTE}||'') if $os eq 'MSWin32'; + +{ # test connect works first + local($l) = &ora_login($dbname, $dbuser, ''); + unless($l) { + warn "ora_login: $ora_errno: $ora_errstr\n"; + # Try to help dumb users who don't know how to connect to oracle... + warn "\nHave you set the environment variable ORACLE_USERID ?\n" + if ($ora_errno == 1017); # ORA-01017: invalid username/password + warn "\nHave you included your password in ORACLE_USERID ? (e.g., 'user/passwd')\n" + if ($ora_errno == 1017 and $dbuser !~ m:/:); + warn "\nHave you set the environment variable ORACLE_SID or TWO_TASK?\n" + if ($ora_errno == 2700); # error translating ORACLE_SID + warn "\nORACLE_SID or TWO_TASK possibly not right, or server not running.\n" + if ($ora_errno == 1034); # ORA-01034: ORACLE not available + warn "\nTWO_TASK possibly not set correctly right.\n" + if ($ora_errno == 12545); + warn "\n"; + warn "Generally set TWO_TASK or ORACLE_SID but not both at the same time.\n"; + warn "Try to connect to the database using an oracle tool like sqlplus\n"; + warn "only if that works should you suspect problems with DBD::Oracle.\n"; + warn "Try leaving dbname value empty and set dbuser to name/passwd\@dbname.\n"; + die "\nTest aborted.\n"; + } + if ($os ne 'MSWin32' and $os ne 'VMS') { + my $backtick = `sleep 1; echo Backticks OK`; + unless ($backtick) { # $! == Interrupted system call + print "Warning: Oracle's SIGCHLD signal handler breaks perl ", + "`backticks` commands: $!\n(d_sigaction=$Config{d_sigaction})\n"; + } + } + #test_bind_csr($l); + #test_auto_reprepare($l); + &ora_logoff($l) || warn "ora_logoff($l): $ora_errno: $ora_errstr\n"; +} +$start = time; + +rename("test.log","test.olog") if $opt_l; +eval 'DBI->_debug_dispatch(3,"test.log");' if $opt_l; + +&test_intfetch_perf() if $opt_p; + +&test1(); + +print "\nTesting repetitive connect/open/close/disconnect:\n"; +print "Expect sequence of digits, no other messages:\n"; +#DBI->internal->{DebugDispatch} = 2; +foreach(1..$opt_n) { print "$_ "; &test2(); } +print "\n"; + +print "\nTest interaction of explicit close/logoff and implicit DESTROYs\n"; +print "Expect just 'done.', no other messages:\n"; +$lda2 = &ora_login($dbname, $dbuser, ''); +$csr2 = &ora_open($lda2, "select 42 from dual") || die "ora_open: $ora_errno: $ora_errstr\n"; +&ora_close($csr2) || warn "ora_close($csr2): $ora_errno: $ora_errstr\n"; +&ora_logoff($lda2) || warn "ora_logoff($lda2): $ora_errno: $ora_errstr\n"; +print "done.\n"; + +&test_cache(); + +$dur = time - $start; +print "\nTest complete ($dur seconds).\n"; +print "If the tests above have produced the 'expected' output then they have passed.\n"; + +exit 0; + + +sub test1 { + local($lda) = &ora_login($dbname, $dbuser, '') + || die "ora_login: $ora_errno: $ora_errstr\n"; + + &ora_commit($lda) || warn "ora_commit($lda): $ora_errno: $ora_errstr\n"; + &ora_rollback($lda) || warn "ora_rollback($lda): $ora_errno: $ora_errstr\n"; + &ora_autocommit($lda, 1); + &ora_autocommit($lda, 0); + + # Test ora_do with harmless non-select statement + &ora_do($lda, "set transaction read only ") + || warn "ora_do: $ora_errno: $ora_errstr"; + + # DBI::dump_results($lda->tables()); + + # $lda->debug(2); + + { + #$lda->trace(2); + local($csr) = &ora_open($lda, + "select to_number('7.2', '9D9', + 'NLS_NUMERIC_CHARACTERS =''.,''' + ) num_t, + SYSDATE date_t, + USER char_t, + ROWID rowid_t, + NULL null_t + from dual") || die "ora_open: $ora_errno: $ora_errstr\n"; + $csr->{RaiseError} = 1; + + print "Fields: ",scalar(&ora_fetch($csr)),"\n"; + die "ora_fetch in scalar context error" unless &ora_fetch($csr)==5; + print "Names: ",DBI::neat_list([&ora_titles($csr)], 0,"\t"),"\n"; + print "Lengths: ",DBI::neat_list([&ora_lengths($csr)],0,"\t"),"\n"; + print "OraTypes: ",DBI::neat_list([&ora_types($csr)], 0,"\t"),"\n"; + print "SQLTypes: ",DBI::neat_list($csr->{TYPE}, 0,"\t"),"\n"; + print "Scale: ",DBI::neat_list($csr->{SCALE}, 0,"\t"),"\n"; + print "Precision: ",DBI::neat_list($csr->{PRECISION}, 0,"\t"),"\n"; + print "Nullable: ",DBI::neat_list($csr->{NULLABLE}, 0,"\t"),"\n"; + print "Est row width: $csr->{ora_est_row_width}\n"; + print "Prefetch cache: $csr->{RowsInCache}\n" if $csr->{RowsInCache}; + + print "Data rows:\n"; + #$csr->debug(2); + while(@fields = $csr->fetchrow_array) { + die "ora_fetch returned ".@fields." fields instead of 5!" + if @fields != 5; + die "Perl list/scalar context error" if @fields==1; + print " fetch: ", DBI::neat_list(\@fields),"\n"; + } + + &ora_close($csr) || warn "ora_close($csr): $ora_errno: $ora_errstr\n"; + print "\n"; + + print "csr reassigned (forces destruction)...\n"; + + #$lda->debug(2); + $csr = &ora_open($lda,<<"") || die "ora_open: $ora_errno: $ora_errstr\n"; + select TABLE_NAME from ALL_TABLES + where TABLE_NAME like :1 and ROWNUM < 5 + + #$lda->debug(0); + print "Fetch list of tables:\n"; +# print "BindParams error $csr->{BindParams}\n" unless $csr->{BindParams}==1; + &ora_bind($csr, '%'); + + #DBI::dump_handle($lda, "lda"); + #DBI::dump_handle($csr, "csr"); + + while(@fields = &ora_fetch($csr)){ + print "Fetched: "; print "@fields\n"; + } + warn "ora_fetch($csr): $ora_errno: $ora_errstr\n" if $ora_errno; + + print "Test ora_do with harmless non-select statement ", + "(set transaction read only)\n"; + print "Expect an 'ORA-01453' error message:\n"; + &ora_do($lda, "set transaction read only ") + || warn "ora_do: $ora_errno: $ora_errstr\n"; + + print "csr out of scope...\n"; + } + + print "ora_logoff...\n"; + &ora_logoff($lda) || warn "ora_logoff($lda): $ora_errno: $ora_errstr\n"; + + print "lda out of scope...\n"; +} + + +sub test2 { # also used by test_leak() + my $skip_sth = shift; + local($l) = &ora_login($dbname, $dbuser, ''); + warn "ora_login: $ora_errno: $ora_errstr\n" if $ora_errno; + return unless $l; + unless ($skip_sth) { + local($c) = &ora_open($l, "set transaction read only")#"select 42,42,42,42,42,42,42 from dual") + || die "ora_open: $ora_errno: $ora_errstr\n"; + local(@row); + @row = &ora_fetch($c); + &ora_close($c) || warn "ora_close($c): $ora_errno: $ora_errstr\n"; + } + &ora_logoff($l) || warn "ora_logoff($l): $ora_errno: $ora_errstr\n"; +} + + +sub test_leak { + local($count) = @_; + local($ps) = (-d '/proc') ? "ps -lp " : "ps -l"; + local($i) = 0; + print "\nMemory leak test:\n"; + while(++$i <= $count) { + system("echo $i; $ps$$") if (($i % 10) == 0); + &test2(1); + } + system("echo $i; $ps$$") if (($i % 10) == 0); + print "Done.\n\n"; +} + + +sub test_cache { + local($cache) = 5; + print "\nTesting row cache ($cache).\n"; + local($l) = &ora_login($dbname, $dbuser, '') + || die "ora_login: $ora_errno: $ora_errstr\n"; + local($csr, $rows, $max); + local($start) = time; + #$l->trace(3); + foreach $max (1, 0, $cache-1, $cache, $cache+1) { + $csr = &ora_open($l, q{ + select object_name, rownum from all_objects where rownum <= :1 + }, $cache); + &ora_bind($csr, $max) || die $ora_errstr; + $rows = count_fetch($csr); + die "test_cache $rows/$max" if $rows != $max; + &ora_bind($csr, $max+2) || die $ora_errstr; + $rows = count_fetch($csr); + die "test_cache $rows/$max+2" if $rows != $max+2; + } + # this test will only show timing improvements when + # run over a modem link. It's primarily designed to + # test boundary cases in the cache code. + print "Test completed in ".(time-$start)." seconds.\n"; +} +sub count_fetch { + local($csr) = @_; + local($rows) = 0; + # while((@row) = &ora_fetch($csr)) { + while((@row) = $csr->fetchrow_array) { + ++$rows; + } + die "count_fetch $ora_errstr" if $ora_errno; + return $rows; +} + + +sub test_intfetch_perf { + print "\nTesting internal row fetch overhead.\n"; + local($lda) = &ora_login($dbname, $dbuser, '') + || die "ora_login: $ora_errno: $ora_errstr\n"; + DBI->trace(0); + $lda->trace(0); + local($csr) = &ora_open($lda,"select 0,1,2,3,4,5,6,7,8,9 from dual"); + local($max) = 50000; + $csr->{ora_fetchtest} = $max; + require Benchmark; + $t0 = new Benchmark; + 1 while $csr->fetchrow_arrayref; + $td = Benchmark::timediff((new Benchmark), $t0); + $csr->{ora_fetchtest} = 0; + printf("$max fetches: ".Benchmark::timestr($td)."\n"); + printf("%d per clock second, %d per cpu second\n\n", + $max/($td->real ? $td->real : 1), + $max/($td->cpu_a ? $td->cpu_a : 1)); +} + +sub test_extfetch_perf { + my $max = shift; + print "\nTesting external row fetch overhead.\n"; + my $rows = 0; + my $dbh = DBI->connect("dbi:Oracle:$dbname", $dbuser, '', { RaiseError => 1 }); + #$dbh->trace(2); + $dbh->{RowCacheSize} = $::opt_c if defined $::opt_c; + my $fields = (0) ? "*" : "object_name, status, object_type"; + my $sth = $dbh->prepare(q{ + select all * from all_objects o1 + union all select all * from all_objects o1 + union all select all * from all_objects o1 + union all select all * from all_objects o1 + union all select all * from all_objects o1 + union all select all * from all_objects o1 + union all select all * from all_objects o1 + union all select all * from all_objects o1 + union all select all * from all_objects o1 + --, all_objects o2 + --where o1.object_id <= 400 and o2.object_id <= 400 + }, { ora_check_sql => 1 }); + + require Benchmark; + $t0 = new Benchmark; + $sth->execute; + $sth->trace(0); + $sth->fetchrow_arrayref; # fetch one before starting timer + $td = Benchmark::timediff((new Benchmark), $t0); + printf("Execute: ".Benchmark::timestr($td)."\n"); + + print "Fetching data with RowCacheSize $dbh->{RowCacheSize}...\n"; + $t1 = new Benchmark; + 1 while $sth->fetchrow_arrayref && ++$rows < $max; + $td = Benchmark::timediff((new Benchmark), $t1); + printf("$rows fetches: ".Benchmark::timestr($td)."\n"); + printf("%d per clock second, %d per cpu second\n", + $rows/($td->real ? $td->real : 1), + $rows/($td->cpu_a ? $td->cpu_a : 1)); + my $ps = (-d '/proc') ? "ps -lp " : "ps -l"; + system("echo Process memory size; $ps$$"); + print "\n"; + $sth->finish; + $dbh->disconnect; + exit 1; +} + + +sub test_bind_csr { + local($lda) = @_; +$lda->{RaiseError} =1; +$lda->trace(2); +my $out_csr = $lda->prepare(q{select 42 from dual}); # sacrificial csr XXX +$csr = $lda->prepare(q{ + begin + OPEN :csr_var FOR select * from all_tables; + end; +}); +$csr->bind_param_inout(':csr_var', \$out_csr, 100, { ora_type => 102 }); +$csr->execute(); +# at this point $out_csr should be a handle on a new oracle cursor +@row = $out_csr->fetchrow_array; + + exit 1; +} + +sub test_auto_reprepare { + local($dbh) = @_; + $dbh->do(q{drop table timbo}); + $dbh->{RaiseError} =1; + #$dbh->trace(2); + $dbh->do(q{create table timbo ( foo integer)}); + $dbh->do(q{insert into timbo values (91)}); + $dbh->do(q{insert into timbo values (92)}); + $dbh->do(q{insert into timbo values (93)}); + $dbh->commit; + $Oraperl::ora_cache = $Oraperl::ora_cache = 1; + my $sth = $dbh->prepare(q{select * from timbo for update}); + $sth->execute; $sth->dump_results; + $sth->execute; + print $sth->fetchrow_array,"\n"; + $dbh->commit; + print $sth->fetchrow_array,"\n"; + $dbh->do(q{drop table timbo}); + exit 1; +} + +# end.