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.