DBD-Sybase-1.24/0000755000175000017500000000000014577756334013534 5ustar mpepplermpepplerDBD-Sybase-1.24/README0000644000175000017500000001326614361730257014407 0ustar mpepplermpeppler DBD::Sybase -- a Sybase DBI driver for Perl 5. Copyright (c) 1996-2022 Michael Peppler You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. https://github.com/mpeppler/DBD-Sybase This Sybase DBI driver is built using the Sybase OpenClient Client Library (aka CT-library). You will need to have that installed before you can do anything with this package. You will also need Tim Bunce's DBI module, latest release. DBI is available from CPAN, in "CPAN"/authors/id/TIMB/DBI-1.xx-tar.gz The Sybase OpenClient libraries are of course available from Sybase. See http://www.sybase.com or http://www.peppler.org for details. An alternative is to use the FreeTDS reimplementation of Client Library. With FreeTDS DBD::Sybase can be used to query a MS-SQL 7 or 2000 database server from a Unix/linux host. See http://www.freetds.org for details. If you use FreeTDS please read the README.freetds file. DBD::Sybase is a reasonably complete implementation of the DBI spec, but there are still some features that are missing. Please see the DBD::Sybase man page for details. Getting Help ============ If you are stuck please start by searching the Web, the appropriate mailing lists, etc, as it is likely that someone else will have experienced the same problem before you. You can report issues at https://github.com/mpeppler/DBD-Sybase/issues For recent changes please see the CHANGES file. Building: --------- Make sure that the SYBASE environment variable points to the Sybase installation that you want to use for this build. The easiest way to do this is to source the SYBASE.sh/SYBASE.csh or SYBASE.bat file in the root directory of the Sybase installation you want to use. This version attempts to find out which libraries it needs by looking at $SYBASE/lib ($SYBASE/$SYBASE_OCS/lib for ASE 12.x installations.) This behaviour works on Unix and VMS systems, but on Win32 you still have to edit the CONFIG file the old way). It assumes that $SYBASE is set and points to the Sybase installation directory that you want to use to build DBD::Sybase, and will also use the value of $SYBASE_OCS if it is set. Then run perl Makefile.PL You will be prompted to choose build options (chained mode for AutoCommit, threaded libraries when using a threaded perl) and for server/user/pwd to use for the "make test" step. If there were warnings about missing libraries, go to the manual configuration, below. Run make If the make failed, go to the manual configuration, below. Run make test If this succeeds you can install the package, via make install (which you probably have to run as root.) Manual Configuration: --------------------- If the automatic configuration fails, then you will have to edit the CONFIG file, and set the EXTRA_LIBS entry according to your OS and Sybase release, and then run perl Makefile.PL --file The CONFIG file can be used to set certain system variables that are needed for the build. SYBASE is the root directory of your Sybase installation. DBD::Sybase will use $SYBASE/lib and $SYBASE/include during the build. EXTRA_LIBS lists any extra libraries that are required on your system. For example, Solaris 2.x needs -ltli. See your OS specific documentation supplement from Sybase to determine what is required. DBI_INCLUDE is the directory where DBI installed its include files. Makefile.PL will normally deduce this directory from perl's Config module, so you only need to set this if Makefile.PL fails. LINKTYPE. Uncomment and set to 'static' if you want to build DBD::Sybase statically (ie always included in a new perl binary). Edit PWD, and set the user, password and server that you want to use for the 'make test'. Run perl Makefile.PL, make, make test. If everything's fine, run "make install" to move the files to your installed perl library tree. Automated build with no prompts: -------------------------------- You can run Makefile.PL with command line arguments to accept defaults and build DBD::Sybase in an automated manner (without prompts). The syntax is: perl Makefile.PL --accept_test_defaults --chained {Y, N} --threaded_libs {Y, N} Known Problems: =============== Solaris 2.x: ----------- On Solaris 2.x make test will fail if LD_LIBRARY_PATH is set and has /usr/lib or /lib before $SYBASE/lib. This is because both Solaris 2.x and Sybase have a library called libintl.so, and if /usr/lib is placed before $SYBASE/lib in LD_LIBRARY_PATH the dynamic loader will search the wrong library when loading DBD::Sybase. In general it is not necessary to set LD_LIBRARY_PATH on Solaris, and it is only rarely necessary to include /usr/lib or /lib in the LD_LIBRARY_PATH as those directories will be searched by default. Linux: ------ If the LANG or LC_ALL environment variable is set and points to an entry that does not exist in $SYBASE/locales/locales.dat (in the [linux] section) then you may get a core dump. This is an OpenClient problem. FreeTDS: -------- See the README.freetds file for details. Regression Tests: ----------------- The regression tests cover the normal operations, but can't check for all combination of data and access modes. You should always test with your own scripts/data before moving a new release into production. NOTE: t/fail.t will *fail* on test #8 if you are connecting to an 11.0.3.3 server. This is a bug in the server, and not something that I can do anything about, unfortunately. It's a fairly obscure constraint violation condition - read the code if you are interested. See perldoc DBD::Sybase for details about the package. Comments, criticism, etc. welcome! Michael -- Michael Peppler mpeppler@peppler.org http://www.peppler.org/ DBD-Sybase-1.24/MANIFEST0000644000175000017500000000100714577756303014657 0ustar mpepplermpepplerMANIFEST BUGS CHANGES CONFIG README README.vms README.freetds PWD.factory Sybase.h Sybase.pm Sybase.xs Makefile.PL dbdimp.c dbdimp.h t/autocommit.t t/base.t t/fail.t t/login.t t/main.t t/multi_sth.t t/place.t t/exec.t t/nsql.t t/thread.t t/utf8.t t/xblob.t t/xblk.t t/screen.jpg t/_test.pm eg/README eg/Show.cgi eg/dbschema.pl eg/check-space.pl dbivport.h META.yml Module meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) DBD-Sybase-1.24/CHANGES0000644000175000017500000005516514577756303014537 0ustar mpepplermpepplerRelease 1.24 Added support for asymmetric password encryption. Fix issue with milliseconds not being returned for bigdatetime in ISO mode. Release 1.23 Fix failing binding of integer values to unsigned int columns when using placeholders. Release 1.22 Map prepare_cached as prepare to avoid various issues with transactions. Release 1.20 Fix issue with locale variable incorrectly set on AIX. Allow passwords > 32 characters. Release 1.19 Fix compilation issue when CS_BIG_TIME is not defined. Release 1.18 Fix further issues with FreeTDS. Improved error handling for numeric/decimal values. Fix logic error in the finish() call when syb_flush_finish is enabled. Release 1.17 Fix various longstanding build issues with FreeTDS and/or MS-SQL Update CPAN metadata to reflect github repo Release 1.16 Fix buffer overflow with ASE 16.x Release 1.15 Minor fixes to allow building on Windows. Fixed syntax error at compile time for some compilers Allow database names with special chars in the name. Change to ct_data_info() to flag an error in case the CS_IODESC returned doesn't include a valid text pointer - this happens if the text/image column is nullable and has not been initialized in the database. Release 1.14 Fix bad size handling for unicode data. Remove default charset setting to utf8 (this had been done in 1.11 as part of improved utf8 handling, but has negative side-effects. If unicode handling is needed then set "charset=utf8" as part of the connection string. Enforce the fact that utf8/unicode handling only works with OpenClient 15.x or later. Release 1.13 Fix for incorrect UTF8 handling when retrieving UNICODE data (Jean-Pierre Rupp). Release 1.12 Bug/Typo/Compatibility fixes with various versions of OpenClient. Experimental: Handle in/out parameters (Merijn Broeren) Release 1.11 Remove reliance on PERL_POLLUTE. Add better support for utf8 (Dave Rolsky) Release 1.10 Handle 15.x datatypes correctly. Add LONGMS date format symbol to handle microseconds for bigdatetime. Add support for CS_LONGCHAR_TYPE (Mark Aufflick) Document syb_isdead(). Handle 64bit builds with FreeTDS (Ian Grant/Hans Kristian Rosbach) Add foreign_key_info & statistics_info (Jim Radford) Change behavior of large fixed precision numeric types (money, bigint) to be converted to a string internally and returned as such to the caller (behavior similar to numeric/decimal). This can be reverted to the old behavior by defining SYB_NATIVE_NUM. Release 1.09 Behavior change: A new connection level attribute (syb_disconnect_in_child) has been added to allow automatical handling of InactiveDestroy across forks. By default in 1.09 a connection will NOT get closed if the process ID of the process that is exiting is not the same as the PID of the process that created the connection. Detect ASE error 5702 (The server is terminating this process) as a fatal error for the connection. Bug Fixes 645 - Spurious COMMIT calls sent to the dataserver during the login/connect calls. 628 - Increase size of Kerberos Principal string buffer 627 - Spurious sigset_t declaration. Release 1.08 Detect missing libblk.a library, and disable the BLK api calls if necessary. Added code to force dlopen() to use RTLD_GLOBAL. Corrected ct_option() functionality detection. Fixed incorrect handling of bind_params() (Thanks to Tim Bunce). Added serverType DSN parameter. Added tds_keepalive DSN parameter. Fixed incorrect handling of multiple result sets with DBI 1.53 and later. Re-wrote $dbh->ping() in C, it's now four times faster. Allow automated build without prompts. Improved nsql(). Added corrected handling of DATE and TIME values (ASE 12.5.2 and later). Added handling of UNSIGNED INT and BIGINT (ASE 15 and later). Added PERL_NO_GET_CONTEXT #define. Bug Fixes 624 - Empty strings incorrectly passed as NULL. 616 - Spurious error message when the login request times out. 614 - Documentation improvement for syb_xxx methods. 610 - Segfault when using signals with the threaded libraries and perl >= 5.8. Release 1.07 Changed the t/xblk.t test to lookup the charset used by the server and specify this in the connect() string. This should avoid failures when the client and server uses charsets of different sizes (utf8 vs. iso_1, for example). Better error reporting when the connection data is incorrect for the test scripts. Modified $dbh->ping() slightly. Bug Fixes 604 - Add missing mode parameter to mkdir in t/xblob.t 606 - Memory leak in the BLK API. Release 1.06 Fix off-by-one error for ISO date format. Clear error/warning when connecting to a Replication Server. Fix AutoCommit "off" behavior when CHAINED mode is turned off. Fix $dbh->begin_work() behavior. Note: This version fails 4 tests in t/xblk.t when building against the 15.0 Beta OCS libraries. Bug Fixes 582 - ISO date formatting off by one for months. 591 - NUM_OF_PARAMS isn't handled properly 593 - Connection can become unusable due a bug in get_server_version(). 597 - Prepared stored procs with placeholders return corrupted recordset on second fetch. 599 - The call to "prepare" also executes the statement. 600 - $sth->finish sometimes fails to properly clean up the handle. Release 1.05 BEHAVIOR CHANGE - $dbh->{LongReadLen} must now be called before $dbh->prepare(). Previously you could call this after the $dbh->prepare() but before the $sth->execute(). Install private statement handle methods for TEXT/IMAGE handling to avoid $h->func() calls, and update documentation. Implement experimental BLK API via prepare/execute loop. Change default "AutoCommit" off mode from explicit transactions to using the "chained" mode if it is available. Add $sth->syb_describe() call, taken from Sybase::CTlib's ct_describe(). Add ISO8601 date/time format for output. Fix $sth->finish() behavior when syb_flush_finish is turned on. Changed do { } while($sth->{syb_more_results}); idiom to use redo instead. Better/more consistent handling of multiple sth on a single dbh, and new test file. Bugs Fixed: 580 - Binding binary/varbinary values to placeholders sometimes fails. 575 - Fails three tests under Tru-64. 577 - perl Makefile.PL fails if umask is 0. 578 - Better warning for calling $dbh->{LongReadLen} if $dbh is busy. 572 - Minor documentation update for bind_param(). Release 1.04 Bugs Fixed: 566 - $sth->{NAME} fails right after prepare(). Release 1.03 Added linking of threaded Sybase libs if perl is built with threading turned on. Added CLONE() method. Minor changes to dbdimp.c to be thread-safe. Added t/thread.t test script. Changes to Makefile.PL to make configuration easier. Add support for Kerberos-based network login. Handle new library names (libsybct vs. libct). Make sure that cached statement handle attributes (NAME_lc, etc) are cleared when multiple result sets are processed. Add host and port connection properties, to allow connections to ASE servers that are not defined in the interfaces file (requires OCS 12.5.1) Add ability to dynamically increase the maximum number of connections (thanks to Ed Avis). Add ability to ignore stored proc return status in nsql() (thanks to Merijn Broeren) Fix Makefile.PL umask() issue on Win32 (thanks to Darin Delegal). Bugs Fixed: 541 - $sth->{NAME} fails right after prepare(). 551 - Tests fail when using perl 5.6.1. 556 - Add support for user-supplied SSL certificate file. 557 - type_info_all broken with ASE 11.0.x 562 - syb_flush_finish doesn't work during the connect() phase. 563 - Memory leak when syb_binary_images is set. Release 1.02 Added syb_server_version attribute. This is filled in at connect() time with the numeric version number (11.0.3.3, 12.5.1, etc) of the server that you are connected to. Bugs Fixed: 520 - t/exec.t fails on Win32. 533 - logic error in deadlock retry in nsql(). 532 - t/xblob.t test provides false positive for win32. 534 - Placeholder prepare() fails with ASE 11.0.x Release 1.01 Automatically finish() statement handles if they are re-executed before all the rows have been fetched. Added support for new tables() syntax, thanks to Stephen Wilcoxon. Added support for DATE and TIME datatypes (available in the ASE 12.5.1 release, currently undergoing beta testing). Allow user to specify a database to use for the tests instead of using "tempdb" (useful if user does not have SA privileges). Bugs Fixed: 517 - getpwnam() isn't portable. 493 - Second execute on a prepared handle fails. 487 - Add connection information to error messages. 407 - Second+ statement does not use db from "use database". Release 1.00 Added data_sources(). Allow "SQL_BINARY" placeholder parameters to be passed either as a hex string (with or without leading 0x), or as raw binary data. Bugs Fixed: 477 - segfault when servermsg_cb is called with a null connection 480 - Makefile.PL searches system dirs before PERL5LIB dirs when looking for DBI installation. 485 - Incorrect handling of large varbinary columns on fetches. 489 - (same as 497, see below). 492 - Can't compile on Win2k. 494 - Do not try to use the ocs.cfg file if it exists. 495 - Incorrect handling of parameters when using placeholders & stored procs. 497 - implicit type conversions with prepared statements often fail 503 - Binary placeholders with stored procedures. 506 - Default scriptName/hostname connect() params. 508 - DBD::Sybase doesn't build under Win2k. Release 0.95 Support for building DBD::Sybase in 64 bit mode with the 64 bit version of OpenClient on Solaris, HP-UX, AIX, etc. (note that perl itself must also be built in 64 bit mode for this to work!) Added column_info() method. Added G_EVAL flag to syb_err_handler calls. Improved syb_err_handler handling (thanks to Matthew Persico) Fixed memory leak when opening additional connections for multiple statement handles on a single database handle (thanks to Stefan Harbeck) Applied minor patch by Alex Fridman to get to build on WinNT. Force a ct_cancel() if, due to syb_do_proc_status, we force a failure on a request that could have more results pending (Blaise Lepeuple) Added syb_cancel_request_on_error attribute (see bug 471). Warning - the default value for this attribute changes the behavior of $sth->execute() when there is a failure that is detected in multi-statement requests. Added syb_bind_empty_string_as_null attribute (see bug 446) to allow user configurable empty string binding semantics (convert to single space [default] or to NULL). Bugs Fixed: 431 - fetchrow_hashref() has incorrect keys when retrieving multiple result sets. 437 - imp_sth->numRows in st_next_result not always set. 444 - Incorrect example for ct_get_data(). ct_get_data() SEGV if passed a non-reference for $image. 394 - $sth->{CursorName} fails hard. 449 - ct_get_data() limited to 32k 450 - Fix incorrect NULLABLE handling. 452 - Incorrect $sth->finish() handling in syb_flush_finish mode (thanks to Steve Willer). 443 - $sth->fetch produces error if called after $sth->execute on statement that doesn't return any rows. 411 - statement handle attributes do not change between result sets. 430 - $dbh->prepare can return undef without triggering RaiseError. 436 - Problems with make test generating errors creating Makefile.aperl. 441 - amadmin who,sqm fails while in a transaction. 446 - Empty string converts to a space (fixed by making this configurable). 448 - define strncasecmp as strnicmp for Win32 systems. 454 - syb_err_handler won't catch connect-time error. 456 - ping still fails if connection is dead. 461 - Memory leak if NOT using placeholders in selects and calling execute() multiple times. 464 - Binding an empty string for a date field causes "1/1/1900" to be inserted (instead of NULL). 469 - nsql error handling bug. 447 - syb_db_disconnect(): ct_con_drop() failed. 471 - Certain class of errors isn't detected by DBD::Sybase. Documentation changes to explain why ... WHERE (product_code = ? OR (? IS NULL AND product_code IS NULL)) doesn't work with Sybase. Release 0.94 Added optional SQL buffer argument to syb_err_handler. Interactive setting of user/server/pwd entries in PWD for "make test". Add syb_failed_db_fatal and syb_no_child_con attributes. Bugs Fixed: 408 - Add the YYYYMMDD format to _date_fmt(). 414 - Binding '' is interpreted as NULL. 415 - Fix buffer overlow in syb_db_login(). 418 - Fix incorrect handing of CS_CANCELED return code in st_next_result(). 421 - ActiveState patches. Release 0.93 Added password encryption option to connect() request (contributed by Tin Martone) Added initial nsql(). Added ct_get_data(), ct_send_data() and friends func(). Added ?-style placeholder support for exec proc statements. Changed getExtraLibs() in Makefile.PL to *not* link with -linsck or -ltli (this avoids problems if the $SYBASE/config/libtcl.cfg file has been set to load the threaded version of these libraries.) Added support for primary_key_info(). (release 0.92 was never publicly released for various reasons) Bugs Fixed: 366 ping() fails if connection has been marked dead 364 t/fail.t bug. Release 0.91 Removed artificial 1024 byte limit on char/varchar datatypes in result sets. Bug Fixes: 213: BLOBs are returned in HEX, not binary. Release 0.90 Release number sequence change: I'm dropping the "alpha" qualifier and I expect to release 1.00 fairly soon. Small Makefile.PL fix for Sybase 12.0 installation directory changes. Applied patch from Tim Ayers to allow 0x type formatting for binary data fetches (similar to what Sybase::CTlib and Sybase::DBlib allow). Fixed some t/ scripts to not fail when run against MS-SQL. Corrected the handling of timeout events in the client callback. Bug Fixes: 349: CS_NUMERIC bindings for ?-style placeholders fails for large values. 345: Dynamic statement ids get re-used. 351: prepared statements with placeholders cause handle to become unusable if *first* execute fails. 352: ping() doesn't work right in Apache::DBI (thanks to Kiriakos Georgiou) 353: syb_quoted_identifier doesn't work. 354: Calling fetch() after prepare() but no execute() fails with internal DBI error. This should also fix bug # 278 and 288. 297: type_info() returns incorrect or no data. 344: timeout doesn't work correctly. Release 0.23 Bug Fixes: 331: ? marks in comments are parsed as placeholders. 343: Errors in stored procs cause data rows from proc to be thrown away. 255: $dbh->execute does not fail it executing proc without permissions. Release 0.22 Bug Fixes: 271: execute() does not restart a transaction after a rollback or commit when running multiple execute() calls for the same statement handle. 294: SEGV on executing a prepared statement with undef values. 295: SEGV due to printf w/ null pointer 299: Missing dTHR in syb_st_prepare(). Release 0.21 Added constant() function, so that if DBD::Sybase is use'd you can access some CS_xxx_RESULT constants. Added $sth->func('syb_output_params') to allow for easier retrieval of stored proc OUTPUT parameters. Added syb_do_proc_status database attribute to allow $sth->execute to handle stored procedure return status directly, and to fail if the stored proc has a non-0 return status. This should also fix bug 255. Errors with severity 10 or below are not stored in $DBI::err anymore. Use $dbh->{syb_err_handler} to get at those warning messages. Added t/fail.t test script to better test failure modes. Setting AutoCommit on a $dbh with active statement handles is now a fatal error. Bug Fixes: 255: Memory leak for prepared statements that are not executed. 264: make test fails when building DBD::Sybase against OpenClient 10.x. 266: make test fails when building DBD::Sybase with perl 5.004_04 or earlier. 268: $sth->execute(x,y,z) (ie executing a prepare'd statment that has ?-style placeholders) does not return undef if a constraint violation occurs on the insert/update/delete. Release 0.20 Fix code to allow prepare, execute, execute, execute... on statements that don't include ?-style placeholders. Fix LENGTH/PRECISION/SCALE $sth attributes to be closer to the DBI spec. Fix core dump problem when binding undef values and having trace >= 2. Add syb_quoted_identifier connection/database handle attribute. Add syb_oc_version read-only database handle attribute, returns the Sybase library version that this binary is currently using. Added the syb_rowcount $dbh attribute. Added $sth->cancel(). Call the syb_err_handler (if one is defined) for client-side errors. Release 0.19 Setting chained/non-chained mode was still broken. syb_flush_finish mode didn't quite work right either. Added more verbose traces. Release 0.18 Add $h->{syb_chained_txn} attribute to switch between CHAINED transactions and explicit named transactions for AutoCommit=0 mode. The default is for syb_chained_txn to be off (ie 0.13 behaviour). Fixed typo in syb_db_commit() to actually commit instead of doing a rollback. Added an autocommit.t test (which still needs some work). Disable opening new connection for secondary $sth handles off of a single $dbh handle when AutoCommit == 0. Release 0.17 Fix AutoCommit = 0 problems introduced with 0.15 for MS-SQL or older Sybase server (ie TDS 4.x protocol connections). Add syb_dynamic_supported $dbh attribute to check whether the connection supports ?-style placeholders. Release 0.16 Added code to define PL_xxx symbols for pre 5.005 perls. New syb_flush_finish attribute (contributed by Steve Miller). Patch to Makefile.PL for VMS systems. Better library detection code in Makefile.PL. Release 0.15 Added an error handler callback which can intercept error messages and provide ad-hoc handling of error situations. In AutoCommit == 0 mode, use CS_OPT_CHAINXACTS mode on the server instead of issuing explicit transactions. $dbh->LongReadLen and LongTruncOK now work. First cut at the type_info() and type_info_all() methods. perl Makefile.PL now attempts to discover the libraries directly based on what it finds in $SYBASE/lib. Release 0.14 Added a 'timeout' connection attribute (contributed by Tom May) to handle timeout errors during normal processing. SQL PRINT statements are now handled by a warn() call (instead a printf() call) so that they can be caught by a __WARN__ handler. Make sure $dbh->do() returns immediately when an error is encountered. Include dbd-sybase.pod (Tim Bunce's Driver Summary for DBD::Sybase). Release 0.13 Bug fix release - binding undef (NULL) variables when using ? style placeholders didn't work. Incorrect login didn't get flagged properly (this bug was introduced in 0.11.) Added database attribute to the connect() call. Release 0.12 Bug fix release - recent versions of DBI make an array that DBD::Sybase uses read-only, causing errors when multiple result sets are retrieved where the second result set is wider (has more columns) than the first one. Release 0.11 Adds support for multiple $sth for a single $dbh (this is done by openeing a new connection in prepare() if the previously prepared statement is still active. Add support for date formatting via $dbh->func($fmt, '_date_fmt'). Added two new connect attributes: scriptName and hostname. Setting these can help identify processes in the Sybase sysprocesses table. Release 0.10 Fixes stupid Makefile.PL bug. Fixes incorrect freeing of memory when mixing prepare() statements with ? placeholders and prepare() statements without them. Release 0.09 Features: Added $sth->{syb_result_type} which returns the numerical value of the current result set. The values are defined in $SYBASE/include/cspublic.h. Made $sth->{TYPE} compatible with generic DBI values, and added $sth->{syb_types} to get the native Sybase types. Added $dbh->tables and $dbh->table_info. Finally got rid of the "Use of uninitialized value" message in connect() (thanks to Tom May for this) Fixed at least some of the memory leaks (thanks to Bryan Mawhinney) Added Sybase specific do() sub that will handle multiple result sets. Added $dbh->{syb_show_sql} and $dbh->{syb_show_eed} to add more control to error reporting. Implemented $dbh->ping() method (first cut - may need improvement!) Bug Fixes: 244: fetch gets infinite loop on sproc error 246: extended error messages go to STDOUT. Release 0.08 Features: Added ? placeholder processing. This is done by calling ct_dynamic() and friends if the statement being executed includes ? type placeholders. Bug Fixes: 210: print statements are lost 231: error messages are lost 238: reformat error messages 241: remove the necessity for users to call $sth->finish Release 0.07 Bug fixes: 204: One form of DBI->connect() fails when specifying the server name. 211: $dbh->do("use database") fails with RaiseError is true. 230: fetch() does not return correct results for certain stored procs situations. Release 0.06 Added ability to specify interfaces file in the connect() call. Added eg/dbschema.pl (ported from Sybase::DBlib). Fixed incorrect handling of AutoCommit and PrintError attributes to connect(). Bugs fixed: 203: Executing sp_helprotect fails. Release 0.05 Added explicit assignement of LDDLFLAGS and LDFLAGS in Makefile.PL to make sure that -L$SYBASE/lib comes first in the list of -L flags. Added documentation. Added ability to specify character set, language, packet size in the connect() call. Small Win32 portability patch to Makefile.PL from Matt Herbert. Bugs fixed: 198: connect failure does not return undef 199: DBD::Sybase interaction with Apache::DBI 0.74 Release 0.04 Fixed counting of active statement handles. Add implicit rollback of open transactions on disconnect. Add implicit commit when changing AutoCommit from off to on. Release 0.03 First ALPHA release of native DBD::Sybase implementation. Release 0.02 Some fixes to the emulation layer. Release 0.01 Proof of concept release - built as an emulation layer on top of Sybase::CTlib (part of sybperl 2.x). DBD-Sybase-1.24/Sybase.pm0000644000175000017500000023264514577756303015330 0ustar mpepplermpeppler# -*-Perl-*- # Copyright (c) 1996-2023 Michael Peppler # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # Based on DBD::Oracle Copyright (c) 1994,1995,1996,1997 Tim Bunce { package DBD::Sybase; use DBI (); use DynaLoader (); use Exporter (); use Sys::Hostname (); @ISA = qw(DynaLoader Exporter); @EXPORT = qw(CS_ROW_RESULT CS_CURSOR_RESULT CS_PARAM_RESULT CS_STATUS_RESULT CS_MSG_RESULT CS_COMPUTE_RESULT); $hostname = Sys::Hostname::hostname(); $init_done = 0; $VERSION = '1.24'; require_version DBI 1.30; # dl_open() calls need to use the RTLD_GLOBAL flag if # you are going to use the Kerberos libraries. # There are systems / OSes where this does not work (AIX 5.x, for example) # set to 1 to get RTLD_GLOBAL turned on. sub dl_load_flags { 0x00 } bootstrap DBD::Sybase $VERSION; $drh = undef; # holds driver handle once initialised sub driver { return $drh if $drh; my ( $class, $attr ) = @_; $class .= "::dr"; ($drh) = DBI::_new_drh( $class, { 'Name' => 'Sybase', 'Version' => $VERSION, 'Attribution' => 'Sybase DBD by Michael Peppler', } ); if ( $DBI::VERSION >= 1.37 && !$DBD::Sybase::init_done ) { DBD::Sybase::db->install_method('syb_nsql'); DBD::Sybase::db->install_method('syb_date_fmt'); DBD::Sybase::db->install_method('syb_isdead'); DBD::Sybase::st->install_method('syb_ct_get_data'); DBD::Sybase::st->install_method('syb_ct_data_info'); DBD::Sybase::st->install_method('syb_ct_send_data'); DBD::Sybase::st->install_method('syb_ct_prepare_send'); DBD::Sybase::st->install_method('syb_ct_finish_send'); DBD::Sybase::st->install_method('syb_output_params'); DBD::Sybase::st->install_method('syb_describe'); ++$DBD::Sybase::init_done; } $drh; } sub CLONE { undef $drh; } 1; } { package DBD::Sybase::dr; # ====== DRIVER ====== use strict; sub connect { my ( $drh, $dbase, $user, $auth, $attr ) = @_; my $server = $dbase || $ENV{DSQUERY} || 'SYBASE'; my ($this) = DBI::_new_dbh( $drh, { 'Name' => $server, 'Username' => $user, 'CURRENT_USER' => $user, } ); DBD::Sybase::db::_login( $this, $server, $user, $auth, $attr ) or return undef; return $this; } sub data_sources { my @s; if ( $^O eq 'MSWin32' ) { open( INTERFACES, "$ENV{SYBASE}/ini/sql.ini" ) or return; @s = map { /\[(\S+)\]/i; "dbi:Sybase:server=$1" } grep /\[/i, ; close(INTERFACES); } else { open( INTERFACES, "$ENV{SYBASE}/interfaces" ) or return; @s = map { /^(\S+)/i; "dbi:Sybase:server=$1" } grep /^[^\s\#]/i, ; close(INTERFACES); } return @s; } } { package DBD::Sybase::db; # ====== DATABASE ====== use strict; use DBI qw(:sql_types); use Carp; sub prepare { my ( $dbh, $statement, $attribs ) = @_; # create a 'blank' sth my $sth = DBI::_new_sth( $dbh, { 'Statement' => $statement, } ); DBD::Sybase::st::_prepare( $sth, $statement, $attribs ) or return undef; $sth; } # prepare_cached doesn't really work correctly with Sybase, given that you can't easily have # more than one active statement handle for a given database handle. # You only get the advantage of not having to re-parse/compile # the statement *if* you have placeholders in the statement. # In other cases the driver will attempt to open a new connection if more than one statement handle is needed # which will cause things like transactions to behave incorrectly. sub prepare_cached { my ( $dbh, $statement, $attribs, $if_active ) = @_; # We ignore the $if_active attribute... # always prepare a new statement return prepare($dbh, $statement, $attribs); } sub tables { my $dbh = shift; my $catalog = shift; my $schema = shift || '%'; my $table = shift || '%'; my $type = shift || '%'; $type =~ s/[\'\"\s]//g; # strip quotes and spaces if ( $type =~ /,/ ) { # multiple types $type = '[' . join( '', map { substr( $_, 0, 1 ) } split /,/, $type ) . ']'; } else { $type = substr( $type, 0, 1 ); } $type =~ s/T/U/; my $sth; if ( $catalog and $catalog ne '%' ) { $sth = $dbh->prepare( "select o.name from $catalog..sysobjects o, $catalog..sysusers u where o.type like '$type' and o.name like '$table' and o.uid = u.uid and u.name like '$schema'" ); } else { $sth = $dbh->prepare( "select o.name from sysobjects o, sysusers u where o.type like '$type' and o.name like '$table' and o.uid = u.uid and u.name like '$schema'" ); } $sth->execute; my @names; my $dat; while ( $dat = $sth->fetch ) { push( @names, $dat->[0] ); } @names; } # NOTE - RaiseError & PrintError is turned off while we are inside this # function, so we must check for any error, and return immediately if # any error is found. # XXX add optional deadlock detection? sub do { my ( $dbh, $statement, $attr, @params ) = @_; my $sth = $dbh->prepare( $statement, $attr ) or return undef; $sth->execute(@params) or return undef; return undef if $sth->err; if ( defined( $sth->{syb_more_results} ) ) { { while ( my $dat = $sth->fetch ) { return undef if $sth->err; # XXX do something intelligent here... } redo if $sth->{syb_more_results}; } } my $rows = $sth->rows; ( $rows == 0 ) ? "0E0" : $rows; } # This will only work if the statement handle used to do the insert # has been properly freed. Otherwise this will try to fetch @@identity # from a different (new!) connection - which is obviously wrong. sub last_insert_id { my ( $dbh, $catalog, $schema, $table, $field, $attr ) = @_; # parameters are ignored. my $sth = $dbh->prepare('select @@identity'); if ( !$sth->execute ) { return undef; } my $value; ($value) = $sth->fetchrow_array; $sth->finish; return $value; } sub table_info { my $dbh = shift; my $catalog = $dbh->quote(shift); my $schema = $dbh->quote(shift); my $table = $dbh->quote(shift); my $type = $dbh->quote(shift); # https://github.com/mpeppler/DBD-Sybase/issues/53 # sp_tables is broken in ASE 15 and later... #my $sth = $dbh->prepare("sp_tables $table, $schema, $catalog, $type"); my $sth = $dbh->prepare( q{ select TABLE_QUALIFIER = db_name() , TABLE_OWNER = u.name , TABLE_NAME = o.name , TABLE_TYPE = case o.type when 'U' then 'TABLE' when 'V' then 'VIEW' when 'S' then 'SYSTEM TABLE' end , REMARKS = NULL from sysobjects o join sysusers u on u.uid = o.uid where o.type in ('U', 'V', 'S') and o.id > 99 }); $sth->execute; $sth; } { my $names = [ qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE ) ]; # Technique of using DBD::Sponge borrowed from DBD::mysql... sub column_info { my $dbh = shift; my $catalog = $dbh->quote(shift); my $schema = $dbh->quote(shift); my $table = $dbh->quote(shift); my $column = $dbh->quote(shift); my $sth = $dbh->prepare("sp_columns $table, $schema, $catalog, $column"); return undef unless $sth; if ( !$sth->execute() ) { return DBI::set_err( $dbh, $sth->err(), $sth->errstr() ); } my @cols; while ( my $d = $sth->fetchrow_arrayref() ) { push( @cols, [ @$d[ 0 .. 11 ], @$d[ 14 .. 19 ] ] ); } my $dbh2; if ( !( $dbh2 = $dbh->{'~dbd_driver~_sponge_dbh'} ) ) { $dbh2 = $dbh->{'~dbd_driver~_sponge_dbh'} = DBI->connect("DBI:Sponge:"); if ( !$dbh2 ) { DBI::set_err( $dbh, 1, $DBI::errstr ); return undef; } } my $sth2 = $dbh2->prepare( "SHOW COLUMNS", { 'rows' => \@cols, 'NAME' => $names, 'NUM_OF_FIELDS' => scalar(@$names) } ); if ( !$sth2 ) { DBI::set_err( $sth2, $dbh2->err(), $dbh2->errstr() ); } $sth2->execute; $sth2; } } sub primary_key_info { my $dbh = shift; my $catalog = $dbh->quote(shift); # == database in Sybase terms my $schema = $dbh->quote(shift); # == owner in Sybase terms my $table = $dbh->quote(shift); my $sth = $dbh->prepare("sp_pkeys $table, $schema, $catalog"); $sth->execute; $sth; } sub foreign_key_info { my $dbh = shift; my $pk_catalog = $dbh->quote(shift); # == database in Sybase terms my $pk_schema = $dbh->quote(shift); # == owner in Sybase terms my $pk_table = $dbh->quote(shift); my $fk_catalog = $dbh->quote(shift); # == database in Sybase terms my $fk_schema = $dbh->quote(shift); # == owner in Sybase terms my $fk_table = $dbh->quote(shift); my $sth = $dbh->prepare( "sp_fkeys $pk_table, $pk_schema, $pk_catalog, $fk_table, $fk_schema, $fk_catalog" ); $sth->execute; $sth; } sub statistics_info { my $dbh = shift; my $catalog = $dbh->quote(shift); # == database in Sybase terms my $schema = $dbh->quote(shift); # == owner in Sybase terms my $table = $dbh->quote(shift); my $is_unique = shift; my $quick = shift; my $sth = $dbh->prepare( "sp_indexes \@\@servername, $table, $schema, $catalog, NULL, $is_unique"); $sth->execute; $sth; } sub ping_pl { # old code - now implemented by syb_ping() in dbdimp.c my $dbh = shift; return 0 if DBD::Sybase::db::_isdead($dbh); # Use "select 1" suggested by Henri Asseily. my $sth = $dbh->prepare("select 1"); return 0 if !$sth; my $rc = $sth->execute; # Changed && to || for 1.07. return 0 if ( !defined($rc) || DBD::Sybase::db::_isdead($dbh) ); $sth->finish; return 1; } # Allows us to cache this data as it is static. my @type_info; sub type_info_all { my ($dbh) = @_; if(scalar(@type_info) > 0) { return \@type_info; } # Calling sp_datatype_info returns the appropriate data for the server that # we are currently connected to. # In general the data is static, so it's not really necessary, but ASE 12.5 # introduces some changes, in particular char/varchar max lenghts that depend # on the server's page size. 12.5.1 introduces the DATE and TIME datatypes. my $sth = $dbh->prepare("sp_datatype_info"); my $data; if ( $sth->execute ) { $data = $sth->fetchall_arrayref; } my $ti = [ { TYPE_NAME => 0, DATA_TYPE => 1, PRECISION => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE => 9, MONEY => 10, AUTO_INCREMENT => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, sql_data_type => 15, sql_datetime_sub => 16, num_prec_radix => 17, interval_precision => 18, USERTYPE => 19 }, ]; # ASE 11.x only returns 13 columns, MS-SQL return 20... my $columnCount = @{ $data->[0] }; foreach my $columnName ( keys( %{ $ti->[0] } ) ) { if ( $ti->[0]->{$columnName} >= $columnCount ) { delete( $ti->[0]->{$columnName} ); } } push( @$ti, @$data ); foreach (@$ti) { push(@type_info, $_); } return \@type_info; } # First straight port of DBlib::nsql. # mpeppler, 2/19/01 # Updated by Merijn Broeren 4/17/2007 # This version *can* handle ? placeholders sub nsql { my ( $dbh, $sql, $type, $callback, $option ) = @_; my ( @res, %resbytype ); my $retrycount = $dbh->FETCH('syb_deadlock_retry'); my $retrysleep = $dbh->FETCH('syb_deadlock_sleep') || 60; my $retryverbose = $dbh->FETCH('syb_deadlock_verbose'); my $nostatus = $dbh->FETCH('syb_nsql_nostatus'); $option = $callback if ref($callback) eq 'HASH' and ref($option) ne 'HASH'; my $bytype = $option->{bytype} || 0; my $merge = $bytype eq 'merge'; my @default_types = ( DBD::Sybase::CS_ROW_RESULT(), DBD::Sybase::CS_CURSOR_RESULT(), DBD::Sybase::CS_PARAM_RESULT(), DBD::Sybase::CS_MSG_RESULT(), DBD::Sybase::CS_COMPUTE_RESULT() ); my $oktypes = $option->{oktypes} || ( $nostatus ? [@default_types] : [ @default_types, DBD::Sybase::CS_STATUS_RESULT() ] ); my %oktypes = map { ( $_ => 1 ) } @$oktypes; my @params = $option->{arglist} ? @{ $option->{arglist} } : (); if ( ref $type ) { $type = ref $type; } elsif ( not defined $type ) { $type = ""; } my $sth = $dbh->prepare($sql); return unless $sth; my $raiserror = $dbh->FETCH('RaiseError'); my $errstr; my $err; # Rats - RaiseError doesn't seem to work inside of this routine. # So we fake it with lots of die() statements. # $sth->{RaiseError} = 1; DEADLOCK: { # Initialize $err before each iteration through this loop. # Otherwise, we inherit the value from the previous failure. $err = undef; # ditto for @res, %resbytype @res = (); %resbytype = (); # Use RaiseError technique to throw a fatal error if anything goes # wrong in the execute or fetch phase. eval { $sth->execute(@params) || die $sth->errstr; { my $result_type = $sth->{syb_result_type}; my ( @set, $data ); if ( not exists $oktypes{$result_type} ) { while ( $data = $sth->fetchrow_arrayref ) { ; # do not include return status rows.. } } elsif ( $type eq "HASH" ) { while ( $data = $sth->fetchrow_hashref ) { die $sth->errstr if ( $sth->err ); if ( ref $callback eq "CODE" ) { unless ( $callback->(%$data) ) { return; } } else { push( @set, {%$data} ); } } } elsif ( $type eq "ARRAY" ) { while ( $data = $sth->fetchrow_arrayref ) { die $sth->errstr if ( $sth->err ); if ( ref $callback eq "CODE" ) { unless ( $callback->(@$data) ) { return; } } else { push( @set, ( @$data == 1 ? $$data[0] : [@$data] ) ); } } } else { # If you ask for nothing, you get nothing. But suck out # the data just in case. while ( $data = $sth->fetch ) { 1; } # NB this is actually *counting* the result sets which are not ignored above $res[0]++; # Return non-null (true) } die $sth->errstr if ( $sth->err ); if (@set) { if ($merge) { $resbytype{$result_type} ||= []; push @{ $resbytype{$result_type} }, @set; } elsif ($bytype) { push @res, { $result_type => [@set] }; } else { push @res, @set; } } redo if $sth->{syb_more_results}; } }; # If $@ is set then something failed in the eval{} call above. if ($@) { $errstr = $@; $err = $sth->err || $dbh->err; if ( $retrycount && $err == 1205 ) { if ( $retrycount < 0 || $retrycount-- ) { carp "SQL deadlock encountered. Retrying...\n" if $retryverbose; sleep($retrysleep); redo DEADLOCK; } else { carp "SQL deadlock retry failed ", $dbh->FETCH('syb_deadlock_retry'), " times. Aborting.\n" if $retryverbose; last DEADLOCK; } } last DEADLOCK; } } # # If we picked any sort of error, then don't feed the data back. # if ($err) { if ($raiserror) { croak($errstr); } return; } elsif ( ref $callback eq "CODE" ) { return 1; } else { if ($merge) { return %resbytype; } else { return @res; } } } if ( $DBI::VERSION >= 1.37 ) { *syb_nsql = *nsql; } } { package DBD::Sybase::st; # ====== STATEMENT ====== use strict; sub syb_output_params { my ($sth) = @_; my @results; my $status; { while ( my $d = $sth->fetch ) { # The tie() doesn't work here, so call the FETCH method # directly.... if ( $sth->FETCH('syb_result_type') == 4042 ) { push( @results, @$d ); } elsif ( $sth->FETCH('syb_result_type') == 4043 ) { $status = $d->[0]; } } redo if $sth->FETCH('syb_more_results'); } # XXX What to do if $status != 0??? @results; } sub exec_proc { my ($sth) = @_; my @results; my $status; $sth->execute || return undef; { while ( my $d = $sth->fetch ) { # The tie() doesn't work here, so call the FETCH method # directly.... if ( $sth->FETCH('syb_result_type') == 4043 ) { $status = $d->[0]; } } redo if $sth->FETCH('syb_more_results'); } # XXX What to do if $status != 0??? $status; } } 1; __END__ =head1 NAME DBD::Sybase - Sybase database driver for the DBI module =head1 SYNOPSIS use DBI; $dbh = DBI->connect("dbi:Sybase:", $user, $passwd); # See the DBI module documentation for full details =head1 DESCRIPTION DBD::Sybase is a Perl module which works with the DBI module to provide access to Sybase databases. =head1 Connecting to Sybase =head2 The interfaces file The DBD::Sybase module is built on top of the Sybase I API. This library makes use of the Sybase I file (I on Win32 machines) to make a link between a logical server name (e.g. SYBASE) and the physical machine / port number that the server is running on. The OpenClient library uses the environment variable B to find the location of the I file, as well as other files that it needs (such as locale files). The B environment is the path to the Sybase installation (eg '/usr/local/sybase'). If you need to set it in your scripts, then you I set it in a C block: BEGIN { $ENV{SYBASE} = '/opt/sybase/11.0.2'; } my $dbh = DBI->connect('dbi:Sybase:', $user, $passwd); =head2 Specifying the server name The server that DBD::Sybase connects to defaults to I, but can be specified in two ways. You can set the I environement variable: $ENV{DSQUERY} = "ENGINEERING"; $dbh = DBI->connect('dbi:Sybase:', $user, $passwd); Or you can pass the server name in the first argument to connect(): $dbh = DBI->connect("dbi:Sybase:server=ENGINEERING", $user, $passwd); =head2 Specifying other connection specific parameters It is sometimes necessary (or beneficial) to specify other connection properties. Currently the following are supported: =over 4 =item server Specify the server that we should connect to. $dbh = DBI->connect("dbi:Sybase:server=BILLING", $user, $passwd); The default server is I, or the value of the I<$DSQUERY> environment variable, if it is set. =item host =item port If you built DBD::Sybase with OpenClient 12.5.1 or later, then you can use the I and I values to define the server you want to connect to. This will by-pass the server name lookup in the interfaces file. This is useful in the case where the server hasn't been entered in the interfaces file. $dbh = DBI->connect("dbi:Sybase:host=db1.domain.com;port=4100", $user, $passwd); =item maxConnect By default DBD::Sybase (and the underlying OpenClient libraries) is limited to openening 25 simultaneous connections to one or more database servers. If you need more than 25 connections at the same time, you can use the I option to increase this number. $dbh = DBI->connect("dbi:Sybase:maxConnect=100", $user, $passwd); =item database Specify the database that should be made the default database. $dbh = DBI->connect("dbi:Sybase:database=sybsystemprocs", $user, $passwd); This is equivalent to $dbh = DBI->connect('dbi:Sybase:', $user, $passwd); $dbh->do("use sybsystemprocs"); =item charset Specify the character set that the client uses. $dbh = DBI->connect("dbi:Sybase:charset=iso_1", $user, $passwd); The default charset used depends on the locale that the application runs in. If you wish to interact with unicode varaiables (see syb_enable_utf8, below) then you should set charset=utf8. Note however that this means that Sybase will expect all data sent to it for char/varchar columns to be encoded in utf8 (e.g. sending iso8859-1 characters like e-grave, etc). =item language Specify the language that the client uses. $dbh = DBI->connect("dbi:Sybase:language=us_english", $user, $passwd); Note that the language has to have been installed on the server (via langinstall or sp_addlanguage) for this to work. If the language is not installed the session will default to the default language of the server. =item packetSize Specify the network packet size that the connection should use. Using a larger packet size can increase performance for certain types of queries. See the Sybase documentation on how to enable this feature on the server. $dbh = DBI->connect("dbi:Sybase:packetSize=8192", $user, $passwd); =item interfaces Specify the location of an alternate I file: $dbh = DBI->connect("dbi:Sybase:interfaces=/usr/local/sybase/interfaces", $user, $passwd); =item loginTimeout Specify the number of seconds that DBI->connect() will wait for a response from the Sybase server. If the server fails to respond before the specified number of seconds the DBI->connect() call fails with a timeout error. The default value is 60 seconds, which is usually enough, but on a busy server it is sometimes necessary to increase this value: $dbh = DBI->connect("dbi:Sybase:loginTimeout=240", # wait up to 4 minutes $user, $passwd); =item timeout Specify the number of seconds after which any Open Client calls will timeout the connection and mark it as dead. Once a timeout error has been received on a connection it should be closed and re-opened for further processing. Setting this value to 0 or a negative number will result in an unlimited timeout value. See also the Open Client documentation on CS_TIMEOUT. $dbh = DBI->connect("dbi:Sybase:timeout=240", # wait up to 4 minutes $user, $passwd); =item scriptName Specify the name for this connection that will be displayed in sp_who (ie in the sysprocesses table in the I column). $dbh=DBI->connect("dbi:Sybase:scriptName=myScript", $user, $password); =item hostname Specify the hostname that will be displayed by sp_who (and will be stored in the hostname column of sysprocesses).. $dbh=DBI->connect("dbi:Sybase:hostname=kiruna", $user, $password); =item tdsLevel Specify the TDS protocol level to use when connecting to the server. Valid values are CS_TDS_40, CS_TDS_42, CS_TDS_46, CS_TDS_495 and CS_TDS_50. In general this is automatically negotiated between the client and the server, but in certain cases this may need to be forced to a lower level by the client. $dbh=DBI->connect("dbi:Sybase:tdsLevel=CS_TDS_42", $user, $password); B: Setting the tdsLevel below CS_TDS_495 will disable a number of features, ?-style placeholders and CHAINED non-AutoCommit mode, in particular. =item encryptPassword Specify the use of the client password encryption supported by CT-Lib. Specify a value of 1 to use encrypted passwords. Set to a value > 1 to also enable asymetric password encryption. $dbh=DBI->connect("dbi:Sybase:encryptPassword=1", $user, $password); =item kerberos Note: Requires OpenClient 11.1.1 or later. Sybase and OpenClient can use Kerberos to perform network-based login. If you use Kerberos for authentication you can use this feature and pass a kerberos serverprincipal using the C parameter: $dbh = DBI->connect("dbi:Sybase:kerberos=$serverprincipal", '', ''); In addition, if you have a system for retrieving Kerberos serverprincipals at run-time you can tell DBD::Sybase to call a perl subroutine to get the serverprincipal from connect(): sub sybGetPrinc { my $srv = shift; return the serverprincipal... } $dbh = DBI->connect('dbi:Sybase:server=troll', '', '', { syb_kerberos_serverprincipal => \&sybGetPrinc }); The subroutine will be called with one argument (the server that we will connect to, using the normal Sybase behavior of checking the DSQUERY environment variable if no server is specified in the connect()) and is expected to return a string (the Kerberos serverprincipal) to the caller. =item sslCAFile Specify the location of an alternate I file for SSL connection negotiation: $dbh->DBI->connect("dbi:Sybase:sslCAFile=/usr/local/sybase/trusted.txt.ENGINEERING", $user, $password); =item bulkLogin Set this to 1 if the connection is going to be used for a bulk-load operation (see I elsewhere in this document.) $dbh->DBI->connect("dbi:Sybase:bulkLogin=1", $user, $password); =item serverType Tell DBD::Sybase what the server type is. Defaults to ASE. Setting it to something else will prevent certain actions (such as setting options, fetching the ASE version via @@version, etc.) and avoid spurious errors. =item tds_keepalive Set this to 1 to tell OpenClient to enable the KEEP_ALIVE attribute on the connection. Default 1. =back These different parameters (as well as the server name) can be strung together by separating each entry with a semi-colon: $dbh = DBI->connect("dbi:Sybase:server=ENGINEERING;packetSize=8192;language=us_english;charset=iso_1", $user, $pwd); =head1 Handling Multiple Result Sets Sybase's Transact SQL has the ability to return multiple result sets from a single SQL statement. For example the query: select b.title, b.author, s.amount from books b, sales s where s.authorID = b.authorID order by b.author, b.title compute sum(s.amount) by b.author which lists sales by author and title and also computes the total sales by author returns two types of rows. The DBI spec doesn't really handle this situation, nor the more hairy exec my_proc @p1='this', @p2='that', @p3 out where C could return any number of result sets (ie it could perform an unknown number of C, or affected by an I or I statement to the I value. Setting it back to 0 clears the limit. This attribute can only be set if the database handle is idle. Default is for this attribute to be B<0>. =item syb_do_proc_status (bool) Setting this attribute causes $sth->execute() to fetch the return status of any executed stored procs in the SQL being executed. If the return status is non-0 then $sth->execute() will report that the operation failed. B The result status is NOT the first result set that is fetched from a stored proc execution. If the procedure includes SELECT statements then these will be fetched first, which means that C<$sth->execute> will NOT return a failure in that case as DBD::Sybase won't have seen the result status yet at that point. The RaiseError will NOT be triggered by a non-0 return status if there isn't an associated error message either generated by Sybase (duplicate insert error, etc) or generated in the procedure via a T-SQL C statement. Setting this attribute does B affect existing $sth handles, only those that are created after setting it. To change the behavior of an existing $sth handle use $sth->{syb_do_proc_status}. The proc status is available in $sth->{syb_proc_status} after all the result sets in the procedure have been processed. The default is for this attribute to be B. =item syb_use_bin_0x If set, BINARY and VARBINARY values are prefixed with '0x' in the result. The default is off. =item syb_binary_images If set, IMAGE data is returned in raw binary format. Otherwise the data is converted to a long hex string. The default is off. =item syb_oc_version (string) Returns the identification string of the version of Client Library that this binary is currently using. This is a read-only attribute. For example: troll (7:59AM):348 > perl -MDBI -e '$dbh = DBI->connect("dbi:Sybase:", "sa"); print "$dbh->{syb_oc_version}\n";' Sybase Client-Library/11.1.1/P/Linux Intel/Linux 2.2.5 i586/1/OPT/Mon Jun 7 07:50:21 1999 This is very useful information to have when reporting a problem. =item syb_server_version =item syb_server_version_string These two attributes return the Sybase server version, respectively version string, and can be used to turn server-specific functionality on or off. Example: print "$dbh->{syb_server_version}\n$dbh->{syb_server_version_string}\n"; prints 12.5.2 Adaptive Server Enterprise/12.5.2/EBF 12061 ESD#2/P/Linux Intel/Enterprise Linux/ase1252/1844/32-bit/OPT/Wed Aug 11 21:36:26 2004 =item syb_failed_db_fatal (bool) If this is set, then a connect() request where the I specified doesn't exist or is not accessible will fail. This needs to be set in the attribute hash passed during the DBI->connect() call to be effective. Default: off =item syb_no_child_con (bool) If this attribute is set then DBD::Sybase will B allow multiple simultaneously active statement handles on one database handle (i.e. multiple $dbh->prepare() calls without completely processing the results from any existing statement handle). This can be used to debug situations where incorrect or unexpected results are found due to the creation of a sub-connection where the connection attributes (in particular the current database) are different. Default: off =item syb_bind_empty_string_as_null (bool) If this attribute is set then an empty string (i.e. "") passed as a parameter to an $sth->execute() call will be converted to a NULL value. If the attribute is not set then an empty string is converted to a single space. Default: off =item syb_cancel_request_on_error (bool) If this attribute is set then a failure in a multi-statement request (for example, a stored procedure execution) will cause $sth->execute() to return failure, and will cause any other results from this request to be discarded. The default value (B) changes the behavior that DBD::Sybase exhibited up to version 0.94. Default: on =item syb_date_fmt (string) Defines the date/time conversion string when fetching data. See the entry for the C method elsewhere in this document for a description of the available formats. =item syb_has_blk (bool) This read-only attribute is set to TRUE if the BLK API is available in this version of DBD::Sybase. =item syb_disconnect_in_child (bool) Sybase client library allows using opened connections across a fork (i.e. the opened connection can be used in the child process). DBI by default will set flags such that this connection will be closed when the child process terminates. This is in most cases not what you want. DBI provides the InactiveDestroy attribute to control this, but you have to set this attribute manually as it defaults to False (i.e. when DESTROY is called for the handle the connection is closed). The syb_disconnect_in_child attribute attempts to correct this - the default is for this attribute to be False - thereby inhibitting the closing of the connection(s) when the current process ID doesn't match the process ID that created the connection. Default: off =item syb_enable_utf8 (bool) If this attribute is set then DBD::Sybase will convert UNIVARCHAR, UNICHAR, and UNITEXT data to Perl's internal utf-8 encoding when they are retrieved. Updating a unicode column will cause Sybase to convert any incoming data from utf-8 to its internal utf-16 encoding. This feature requires OpenClient 15.x to work. Default: off =back =head2 Statement Handle Attributes The following read-only attributes are available at the statement level: =over 4 =item syb_more_results (bool) See the discussion on handling multiple result sets above. =item syb_result_type (int) Returns the numeric result type of the current result set. Useful when executing stored procedurs to determine what type of information is currently fetchable (normal select rows, output parameters, status results, etc...). =item syb_do_proc_status (bool) See above (under Database Handle Attributes) for an explanation. =item syb_proc_status (read-only) If syb_do_proc_status is set, then the return status of stored procedures will be available via $sth->{syb_proc_status}. =item syb_no_bind_blob (bool) If set then any IMAGE or TEXT columns in a query are B returned when calling $sth->fetch (or any variation). Instead, you would use $sth->syb_ct_get_data($column, \$data, $size); to retrieve the IMAGE or TEXT data. If $size is 0 then the entire item is fetched, otherwis you can call this in a loop to fetch chunks of data: while(1) { $sth->syb_ct_get_data($column, \$data, 1024); last unless $data; print OUT $data; } The fetched data is still subject to Sybase's TEXTSIZE option (see the SET command in the Sybase reference manual). This can be manipulated with DBI's B attribute, but C<$dbh->{LongReadLen}> I be set before $dbh->prepare() is called to take effect (this is a change in 1.05 - previously you could call it after the prepare() but before the execute()). Note that LongReadLen has no effect when using DBD::Sybase with an MS-SQL server. B: The IMAGE or TEXT column that is to be fetched this way I be I in the select list. See also the description of the ct_get_data() API call in the Sybase OpenClient manual, and the "Working with TEXT/IMAGE columns" section elsewhere in this document. =back =head1 Controlling DATETIME output formats By default DBD::Sybase will return I and I columns in the I format. This can be changed via a private B method. The syntax is $dbh->syb_date_fmt($fmt); where $fmt is a string representing the format that you want to apply. Note that this requires DBI 1.37 or later. The formats are based on Sybase's standard conversion routines. The following subset of available formats has been implemented: =over 4 =item LONG Nov 15 1998 11:30:11:496AM =item LONGMS New with ASE 15.5 - for bigtime/bigdatetime datatypes, includes microseconds: Apr 7 2010 10:40:33.532315PM =item SHORT Nov 15 1998 11:30AM =item DMY4_YYYY 15 Nov 1998 =item MDY1_YYYY 11/15/1998 =item DMY1_YYYY 15/11/1998 =item DMY2_YYYY 15.11.1998 =item YMD3_YYYY 19981115 =item HMS 11:30:11 =item ISO 2004-08-21 14:36:48.080 =item ISO_strict 2004-08-21T14:36:48.080Z Note that Sybase has no concept of a timezone, so the trailing "Z" is really not correct (assumes that the time is in UTC). However, there is no guarantee that the client and the server run in the same timezone, so assuming the timezone of the client isn't really a valid option either. =back =head1 Retrieving OUTPUT parameters from stored procedures Sybase lets you pass define B parameters to stored procedures, which are a little like parameters passed by reference in C (or perl.) In Transact-SQL this is done like this declare @id_value int, @id_name char(10) exec my_proc @name = 'a string', @number = 1234, @id = @id_value OUTPUT, @out_name = @id_name OUTPUT -- Now @id_value and @id_name are set to whatever 'my_proc' set @id and @out_name to So how can we get at @param using DBD::Sybase? If your stored procedure B returns B parameters, then you can use this shorthand: $sth = $dbh->prepare('...'); $sth->execute; @results = $sth->syb_output_params(); This will return an array for all the OUTPUT parameters in the proc call, and will ignore any other results. The array will be undefined if there are no OUTPUT params, or if the stored procedure failed for some reason. The more generic way looks like this: $sth = $dbh->prepare("declare \@id_value int, \@id_name exec my_proc @name = 'a string', @number = 1234, @id = @id_value OUTPUT, @out_name = @id_name OUTPUT"); $sth->execute; { while($d = $sth->fetch) { if($sth->{syb_result_type} == 4042) { # it's a PARAM result $id_value = $d->[0]; $id_name = $d->[1]; } } redo if $sth->{syb_more_results}; } So the OUTPUT params are returned as one row in a special result set. =head1 Multiple active statements on one $dbh It is possible to open multiple active statements on a single database handle. This is done by opening a new physical connection in $dbh->prepare() if there is already an active statement handle for this $dbh. This feature has been implemented to improve compatibility with other drivers, but should not be used if you are coding directly to the Sybase driver. The C attribute controls whether this feature is turned on. If it is FALSE (the default), then multiple statement handles are supported. If it is TRUE then multiple statements on the same database handle are disabled. Also see below for interaction with AutoCommit. If AutoCommit is B then multiple statement handles on a single $dbh is B supported. This is to avoid various deadlock problems that can crop up in this situation, and because you will not get real transactional integrity using multiple statement handles simultaneously as these in reality refer to different physical connections. =head2 prepare_cached DBD::Sybase maps B to B to avoid possible issues with having a statement handle being kept active outside of the driver's control. DBD::Sybase (and the underlying TDS protocol) doesn't easily support having more than one active SQL statement on a given connection (database handle). Caching a statement handle is only useful if it can be reused without reparsing and recompiling it, which is only possible with Sybase if you use ?-style placeholders (see below). In addition, as DBD::Sybase will attempt to emulate the ability to have more than one active SQL statement on a database handle by opening additional connections this has significant side effects on transaction management. See also the B attribute. =head1 Working with IMAGE and TEXT columns DBD::Sybase can store and retrieve IMAGE or TEXT data (aka "blob" data) via standard SQL statements. The B handle attribute controls the maximum size of IMAGE or TEXT data being returned for each data element. When using standard SQL the default for IMAGE data is to be converted to a hex string, but you can use the I handle attribute to change this behaviour. Alternatively you can use something like $binary = pack("H*", $hex_string); to do the conversion. IMAGE and TEXT datatypes can B be passed as parameters using ?-style placeholders, and placeholders can't refer to IMAGE or TEXT columns (this is a limitation of the TDS protocol used by Sybase, not a DBD::Sybase limitation.) There is an alternative way to access and update IMAGE/TEXT data using the natice OpenClient API. This is done via $h->func() calls, and is, unfortunately, a little convoluted. =head2 Handling IMAGE/TEXT data with syb_ct_get_data()/syb_ct_send_data() With DBI 1.37 and later you can call all of these ct_xxx() calls directly as statement handle methods by prefixing them with syb_, so for example $sth->func($col, $dataref, $numbytes, 'ct_fetch_data'); becomes $sth->syb_ct_fetch_data($col, $dataref, $numbytes); =over 4 =item $len = ct_fetch_data($col, $dataref, $numbytes) The ct_get_data() call allows you to fetch IMAGE/TEXT data in raw format, either in one piece or in chunks. To use this function you must set the I statement handle to I. ct_get_data() takes 3 parameters: The column number (starting at 1) of the query, a scalar ref and a byte count. If the byte count is 0 then we read as many bytes as possible. Note that the IMAGE/TEXT column B be B in the select list for this to work. The call sequence is: $sth = $dbh->prepare("select id, img from some_table where id = 1"); $sth->{syb_no_bind_blob} = 1; $sth->execute; while($d = $sth->fetchrow_arrayref) { # The data is in the second column $len = $sth->syb_ct_get_data(2, \$img, 0); # with DBI 1.33 and earlier, this would be # $len = $sth->func(2, \$img, 0, 'ct_get_data'); } ct_get_data() returns the number of bytes that were effectively fetched, so that when fetching chunks you can do something like this: while(1) { $len = $sth->syb_ct_get_data(2, $imgchunk, 1024); ... do something with the $imgchunk ... last if $len != 1024; } To explain further: Sybase stores IMAGE/TEXT data separately from normal table data, in a chain of pagesize blocks (a Sybase database page is defined at the server level, and can be 2k, 4k, 8k or 16k in size.) To update an IMAGE/TEXT column Sybase needs to find the head of this chain, which is known as the "text pointer". As there is no I clause when the ct_send_data() API is used we need to retrieve the I for the correct data item first, which is done via the ct_data_info(CS_GET) call. Subsequent ct_send_data() calls will then know which data item to update. =item $status = ct_data_info($action, $column, $attr) ct_data_info() is used to fetch or update the CS_IODESC structure for the IMAGE/TEXT data item that you wish to update. $action should be one of "CS_SET" or "CS_GET", $column is the column number of the active select statement (ignored for a CS_SET operation) and $attr is a hash ref used to set the values in the struct. ct_data_info() must be first called with CS_GET to fetch the CS_IODESC structure for the IMAGE/TEXT data item that you wish to update. Then you must update the value of the I structure element to the length (in bytes) of the IMAGE/TEXT data that you are going to insert, and optionally set the I to B to enable full logging of the operation. ct_data_info(CS_GET) will I if the IMAGE/TEXT data for which the CS_IODESC is being fetched is NULL. If you have a NULL value that needs updating you must first update it to some non-NULL value (for example an empty string) using standard SQL before you can retrieve the CS_IODESC entry. This actually makes sense because as long as the data item is NULL there is B I and no TEXT page chain for that item. See the ct_send_data() entry below for an example. =item ct_prepare_send() ct_prepare_send() must be called to initialize a IMAGE/TEXT write operation. See the ct_send_data() entry below for an example. =item ct_finish_send() ct_finish_send() is called to finish/commit an IMAGE/TEXT write operation. See the ct_send_data() entry below for an example. =item ct_send_data($image, $bytes) Send $bytes bytes of $image to the database. The request must have been set up via ct_prepare_send() and ct_data_info() for this to work. ct_send_data() returns B on success, and B on failure. In this example, we wish to update the data in the I column where the I column is 1. We assume that DBI is at version 1.37 or later and use the direct method calls: # first we need to find the CS_IODESC data for the data $sth = $dbh->prepare("select img from imgtable where id = 1"); $sth->execute; while($sth->fetch) { # don't care about the data! $sth->syb_ct_data_info('CS_GET', 1); } # OK - we have the CS_IODESC values, so do the update: $sth->syb_ct_prepare_send(); # Set the size of the new data item (that we are inserting), and make # the operation unlogged $sth->syb_ct_data_info('CS_SET', 1, {total_txtlen => length($image), log_on_update => 0}); # now transfer the data (in a single chunk, this time) $sth->syb_ct_send_data($image, length($image)); # commit the operation $sth->syb_ct_finish_send(); The ct_send_data() call can also transfer the data in chunks, however you must know the total size of the image before you start the insert. For example: # update a database entry with a new version of a file: my $size = -s $file; # first we need to find the CS_IODESC data for the data $sth = $dbh->prepare("select img from imgtable where id = 1"); $sth->execute; while($sth->fetch) { # don't care about the data! $sth->syb_ct_data_info('CS_GET', 1); } # OK - we have the CS_IODESC values, so do the update: $sth->syb_ct_prepare_send(); # Set the size of the new data item (that we are inserting), and make # the operation unlogged $sth->syb_ct_data_info('CS_SET', 1, {total_txtlen => $size, log_on_update => 0}); # open the file, and store it in the db in 1024 byte chunks. open(IN, $file) || die "Can't open $file: $!"; while($size) { $to_read = $size > 1024 ? 1024 : $size; $bytesread = read(IN, $buff, $to_read); $size -= $bytesread; $sth->syb_ct_send_data($buff, $bytesread); } close(IN); # commit the operation $sth->syb_ct_finish_send(); =back =head1 AutoCommit, Transactions and Transact-SQL When $h->{AutoCommit} is I all data modification SQL statements that you issue (insert/update/delete) will only take effect if you call $dbh->commit. DBD::Sybase implements this via two distinct methods, depending on the setting of the $h->{syb_chained_txn} attribute and the version of the server that is being accessed. If $h->{syb_chained_txn} is I, then the DBD::Sybase driver will send a B before the first $dbh->prepare(), and after each call to $dbh->commit() or $dbh->rollback(). This works fine, but will cause any SQL that contains any I (or other DDL) statements to fail. These I statements can be burried in a stored procedure somewhere (for example, C creates two temp tables when it is run). You I get around this limit by setting the C option (at the database level, via C.) You should be aware that this can have serious effects on performance as this causes locks to be held on certain system tables for the duration of the transaction. If $h->{syb_chained_txn} is I, then DBD::Sybase sets the I option, which tells Sybase not to commit anything automatically. Again, you will need to call $dbh->commit() to make any changes to the data permanent. =head1 Behavior of $dbh->last_insert_id This version of DBD::Sybase includes support for the last_insert_id() call, with the following caveats: The last_insert_id() call is simply a wrapper around a "select @@identity" query. To be successful (i.e. to return the correct value) this must be executed on the same connection as the INSERT that generated the new IDENTITY value. Therefore the statement handle that was used to perform the insert B have been closed/freed before last_insert_id() can be called. Otherwise last_insert_id() will be forced to open a different connection to perform the query, and will return an invalid value (usually in this case it will return 0). last_insert_id() ignores any parameters passed to it, and will NOT return the last @@identity value generated in the case where placeholders were used, or where the insert was encapsulated in a stored procedure. =head1 Using ? Placeholders & bind parameters to $sth->execute DBD::Sybase supports the use of ? placeholders in SQL statements as long as the underlying library and database engine supports it. It does this by using what Sybase calls I. The ? placeholders allow you to write something like: $sth = $dbh->prepare("select * from employee where empno = ?"); # Retrieve rows from employee where empno == 1024: $sth->execute(1024); while($data = $sth->fetch) { print "@$data\n"; } # Now get rows where empno = 2000: $sth->execute(2000); while($data = $sth->fetch) { print "@$data\n"; } When you use ? placeholders Sybase goes and creates a temporary stored procedure that corresponds to your SQL statement. You then pass variables to $sth->execute or $dbh->do, which get inserted in the query, and any rows are returned. DBD::Sybase uses the underlying Sybase API calls to handle ?-style placeholders. For select/insert/update/delete statements DBD::Sybase calls the ct_dynamic() family of Client Library functions, which gives DBD::Sybase data type information for each parameter to the query. You can only use ?-style placeholders for statements that return a single result set, and the ? placeholders can only appear in a B clause, in the B clause of an B statement, or in the B list of an B statement. The DBI docs mention the following regarding NULL values and placeholders: =over 4 Binding an `undef' (NULL) to the placeholder will not select rows which have a NULL `product_code'! Refer to the SQL manual for your database engine or any SQL book for the reasons for this. To explicitly select NULLs you have to say "`WHERE product_code IS NULL'" and to make that general you have to say: ... WHERE (product_code = ? OR (? IS NULL AND product_code IS NULL)) and bind the same value to both placeholders. =back This will I work with a Sybase database server. If you attempt the above construct you will get the following error: =over 4 The datatype of a parameter marker used in the dynamic prepare statement could not be resolved. =back The specific problem here is that when using ? placeholders the prepare() operation is sent to the database server for parameter resoltion. This extracts the datatypes for each of the placeholders. Unfortunately the C construct doesn't tie the ? placeholder with an existing table column, so the database server can't find the data type. As this entire operation happens inside the Sybase libraries there is no easy way for DBD::Sybase to work around it. Note that Sybase will normally handle the C construct the same way that other systems handle C, so the convoluted construct that is described above is not necessary to obtain the correct results when querying a Sybase database. The underlying API does not support ?-style placeholders for stored procedures, but see the section on titled B elsewhere in this document. ?-style placeholders can B be used to pass TEXT or IMAGE data items to the server. This is a limitation of the TDS protocol, not of DBD::Sybase. There is also a performance issue: OpenClient creates stored procedures in tempdb for each prepare() call that includes ? placeholders. Creating these objects requires updating system tables in the tempdb database, and can therefore create a performance hotspot if a lot of prepare() statements from multiple clients are executed simultaneously. This problem has been corrected for Sybase 11.9.x and later servers, as they create "lightweight" temporary stored procs which are held in the server memory cache and don't affect the system tables at all. In general however I find that if your application is going to run against Sybase it is better to write ad-hoc stored procedures rather than use the ? placeholders in embedded SQL. Out of curiosity I did some simple timings to see what the overhead of doing a prepare with ? placehoders is vs. a straight SQL prepare and vs. a stored procedure prepare. Against an 11.0.3.3 server (linux) the placeholder prepare is significantly slower, and you need to do ~30 execute() calls on the prepared statement to make up for the overhead. Against a 12.0 server (solaris) however the situation was very different, with placeholder prepare() calls I faster than straight SQL prepare(). This is something that I I don't understand, but the numbers were pretty clear. In all cases stored proc prepare() calls were I faster, and consistently so. This test did not try to gauge concurrency issues, however. It is not possible to retrieve the last I value after an insert done with ?-style placeholders. This is a Sybase limitation/bug, not a DBD::Sybase problem. For example, assuming table I has an identity column: $dbh->do("insert foo(col1, col2) values(?, ?)", undef, "string1", "string2"); $sth = $dbh->prepare('select @@identity') || die "Can't prepare the SQL statement: $DBI::errstr"; $sth->execute || die "Can't execute the SQL statement: $DBI::errstr"; #Get the data back. while (my $row = $sth->fetchrow_arrayref()) { print "IDENTITY value = $row->[0]\n"; } will always return an identity value of 0, which is obviously incorrect. This behaviour is due to the fact that the handling of ?-style placeholders is implemented using temporary stored procedures in Sybase, and the value of C<@@identity> is reset when the stored procedure has executed. Using an explicit stored procedure to do the insert and trying to retrieve C<@@identity> after it has executed results in the same behaviour. Please see the discussion on Dynamic SQL in the OpenClient C Programmer's Guide for details. The guide is available on-line at http://sybooks.sybase.com/ =head1 Calling Stored Procedures DBD::Sybase handles stored procedures in the same way as any other Transact-SQL statement. The only real difference is that Sybase stored procedures always return an extra result set with the I from the proc which corresponds to the I statement in the stored procedure code. This result set with a single row is always returned last and has a result type of CS_STATUS_RESULT (4043). By default this result set is returned like any other, but you can ask DBD::Sybase to process it under the covers via the $h->{syb_do_proc_status} attribute. If this attribute is set then DBD::Sybase will process the CS_STATUS_RESULT result set itself, place the return status value in $sth->{syb_proc_status}, and possibly raise an error if the result set is different from 0. Note that a non-0 return status will B cause $sth->execute to return a failure code if the proc has at least one other result set that returned rows (reason: the rows are returned and fetched before the return status is seen). =head2 Stored Procedures and Placeholders DBD::Sybase has the ability to use ?-style placeholders as parameters to stored proc calls. The requirements are that the stored procedure call be initiated with an "exec" and that it be the only statement in the batch that is being prepared(): For example, this prepares a stored proc call with named parameters: my $sth = $dbh->prepare("exec my_proc \@p1 = ?, \@p2 = ?"); $sth->execute('one', 'two'); You can also use positional parameters: my $sth = $dbh->prepare("exec my_proc ?, ?"); $sth->execute('one', 'two'); You may I mix positional and named parameter in the same prepare. You I mix placeholder parameters and hard coded parameters. For example $sth = $dbh->prepare("exec my_proc \@p1 = 1, \@p2 = ?"); will I work - because the @p1 parameter isn't parsed correctly and won't be sent to the server. You can specify I parameters in the usual way, but you can B use bind_param_inout() to get the output result - instead you have to call fetch() and/or $sth->func('syb_output_params'): my $sth = $dbh->prepare("exec my_proc \@p1 = ?, \@p2 = ?, \@p3 = ? OUTPUT "); $sth->execute('one', 'two', 'three'); my (@data) = $sth->syb_output_params(); DBD::Sybase does not attempt to figure out the correct parameter type for each parameter (it would be possible to do this for most cases, but there are enough exceptions that I preferred to avoid the issue for the time being). DBD::Sybase defaults all the parameters to SQL_CHAR, and you have to use bind_param() with an explicit type value to set this to something different. The type is then remembered, so you only need to use the explicit call once for each parameter: my $sth = $dbh->prepare("exec my_proc \@p1 = ?, \@p2 = ?"); $sth->bind_param(1, 'one', SQL_CHAR); $sth->bind_param(2, 2.34, SQL_FLOAT); $sth->execute; .... $sth->execute('two', 3.456); etc... Note that once a type has been defined for a parameter you can't change it. When binding SQL_NUMERIC or SQL_DECIMAL data you may get fatal conversion errors if the scale or the precision exceeds the size of the target parameter definition. For example, consider the following stored proc definition: declare proc my_proc @p1 numeric(5,2) as... and the following prepare/execute snippet: my $sth = $dbh->prepare("exec my_proc \@p1 = ?"); $sth->bind_param(1, 3.456, SQL_NUMERIC); This generates the following error: DBD::Sybase::st execute failed: Server message number=241 severity=16 state=2 line=0 procedure=dbitest text=Scale error during implicit conversion of NUMERIC value '3.456' to a NUMERIC field. You can tell Sybase (and DBD::Sybase) to ignore these sorts of errors by setting the I option: $dbh->do("set arithabort off"); See the I command in the Sybase Adaptive Server Enterprise Reference Manual for more information on the set command and on the arithabort option. =head1 Other Private Methods =head2 DBD::Sybase private Database Handle Methods =over 4 =item $bool = $dbh->syb_isdead Tests the connection to see if the connection has been marked DEAD by OpenClient. The connection can get marked DEAD if an error occurs on the connection, or the connection fails. =back =head2 DBD::Sybase private Statement Handle Methods =over 4 =item @data = $sth->syb_describe([$assoc]) Retrieves the description of each of the output columns of the current result set. Each element of the returned array is a reference to a hash that describes the column. The following fields are set: NAME, TYPE, SYBTYPE, MAXLENGTH, SCALE, PRECISION, STATUS. You could use it like this: my $sth = $dbh->prepare("select name, uid from sysusers"); $sth->execute; my @description = $sth->syb_describe; print "$description[0]->{NAME}\n"; # prints name print "$description[0]->{MAXLENGTH}\n"; # prints 30 .... while(my $row = $sth->fetch) { .... } The STATUS field is a string which can be tested for the following values: CS_CANBENULL, CS_HIDDEN, CS_IDENTITY, CS_KEY, CS_VERSION_KEY, CS_TIMESTAMP and CS_UPDATABLE. See table 3-46 of the Open Client Client Library Reference Manual for a description of each of these values. The TYPE field is the data type that Sybase::CTlib converts the column to when retrieving the data, so a DATETIME column will be returned as a CS_CHAR_TYPE column. The SYBTYPE field is the real Sybase data type for this column. I =back =head1 Experimental Bulk-Load Functionality B: This feature requires that the I library be available at build time. This is not always the case if the Sybase SDK isn't installed. You can test the $dbh->{syb_has_blk} attribute to see if the BLK api calls are available in your copy of DBD::Sybase. Starting with release 1.04.2 DBD::Sybase has the ability to use Sybase's BLK (bulk-loading) API to perform fast data loads. Basic usage is as follows: my $dbh = DBI->connect('dbi:Sybase:server=MY_SERVER;bulkLogin=1', $user, $pwd); $dbh->begin_work; # optional. my $sth = $dbh->prepare("insert the_table values(?, ?, ?, ?, ?)", {syb_bcp_attribs => { identity_flag => 0, identity_column => 0 }}}); while() { chomp; my @row = split(/\|/, $_); # assume a pipe-delimited file... $sth->execute(@row); } $dbh->commit; print "Sent ", $sth->rows, " to the server\n"; $sth->finish; First, you need to specify the new I attribute in the connection string, which turns on the CS_BULK_LOGIN property for the connection. Without this property the BLK api will not be functional. You call $dbh->prepare() with a regular INSERT statement and the special I attribute to turn on BLK handling of the data. The I sub-attribute can be set to 1 if your source data includes the values for the target table's IDENTITY column. If the target table has an IDENTITY column but you want the insert operation to generate a new value for each row then leave I at 0, but set I to the column number of the identity column (it's usually the first column in the table, but not always.) The number of placeholders in the INSERT statement I correspond to the number of columns in the table, and the input data I be in the same order as the table's physical column order. Any column list in the INSERT statement (i.e. I is ignored. The value of AutoCommit is ignored for BLK operations - rows are only commited when you call $dbh->commit. You can call $dbh->rollback to cancel any uncommited rows, but this I cancels the rest of the BLK operation: any attempt to load rows to the server after a call to $dbh->rollback() will fail. If a row fails to load due to a CLIENT side error (such as a data conversion error) then $sth->execute() will return a failure (i.e. false) and $sth->errstr will have the reason for the error. If a row fails on the SERVER side (for example due to a duplicate row error) then the entire batch (i.e. between two $dbh->commit() calls) will fail. This is normal behavior for BLK/bcp. The Bulk-Load API is very sensitive to data conversion issues, as all the conversions are handled on the client side, and the row is pre-formatted before being sent to the server. By default any conversion that is flagged by Sybase's cs_convert() call will result in a failed row. Some of these conversion errors are patently fatal (e.g. converting 'Feb 30 2001' to a DATETIME value...), while others are debatable (e.g. converting 123.456 to a NUMERIC(6,2) which results in a loss of precision). The default behavior of failing any row that has a conversion error in it can be modified by using a special error handler. Returning 0 from this handler tells DBD::Sybase to fail this row, and returning 1 means that we still want to try to send the row to the server (obviously Sybase's internal code can still fail the row at that point.) You set the handler like this: DBD::Sybase::syb_set_cslib_cb(\&handler); and a sample handler: sub cslib_handler { my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_; print "Layer: $layer, Origin: $origin, Severity: $severity, Error: $errno\n"; print $msg; print $osmsg if($osmsg); print $blkmsg if $blkmsg; return 1 if($errno == 36) return 0; } Please see the t/xblk.t test script for some examples. Reminder - this is an I implementation. It may change in the future, and it could be buggy. =head1 Using DBD::Sybase with MS-SQL MS-SQL started out as Sybase 4.2, and there are still a lot of similarities between Sybase and MS-SQL which makes it possible to use DBD::Sybase to query a MS-SQL dataserver using either the Sybase OpenClient libraries or the FreeTDS libraries (see http://www.freetds.org). However, using the Sybase libraries to query an MS-SQL server has certain limitations. In particular ?-style placeholders are not supported (although support when using the FreeTDS libraries is possible in a future release of the libraries), and certain B attributes may not be supported. Sybase defaults the TEXTSIZE attribute (aka B) to 32k, but MS-SQL 7 doesn't seem to do that correctly, resulting in very large memory requests when querying tables with TEXT/IMAGE data columns. The work-around is to set TEXTSIZE to some decent value via $dbh->{LongReadLen} (if that works - I haven't had any confirmation that it does) or via $dbh->do("set textsize "); =head1 nsql The nsql() call is a direct port of the function of the same name that exists in Sybase::DBlib. From 1.08 it has been extended to offer new functionality. Usage: @data = $dbh->func($sql, $type, $callback, $options, 'nsql'); If the DBI version is 1.37 or later, then you can also call it this way: @data = $dbh->syb_nsql($sql, $type, $callback, $options); This executes the query in $sql, and returns all the data in @data. The $type parameter can be used to specify that each returned row be in array form (i.e. $type passed as 'ARRAY', which is the default) or in hash form ($type passed as 'HASH') with column names as keys. If $callback is specified it is taken as a reference to a perl sub, and each row returned by the query is passed to this subroutine I of being returned by the routine (to allow processing of large result sets, for example). If $options is specified and is a HASH ref, the following keys affect the value returned by nsql(): =over 4 =item oktypes => [...] This generalises I (see below) by ignoring any result sets which are of a type not listed. =item bytype => 0|1|'merge' If this option is set to a true value, each result set will be returned as the value of a hash, the key of which is the result type of this result set as defined by the CS_*_TYPE values described above. If the special value 'merge' is used, result sets of the same type will be catenated (as nsql() does by default) into a single array of results and the result of the nsql() call will be a single hash keyed by result type. Usage is better written %data = $dbh->syb_nsql(...) in this case. =item arglist => [...] This option provides support for placeholders in the SQL query passed to nsql(). Each time the SQL statement is executed the array value of this option will be passed as the parameter list to the execute() method. =back Note that if $callback is omitted, a hash reference in that parameter position will be interpreted as an option hash if no hash reference is found in the $options parameter position. C also checks three special attributes to enable deadlock retry logic (I none of these attributes have any effect anywhere else at the moment): =over 4 =item syb_deadlock_retry I Set this to a non-0 value to enable deadlock detection and retry logic within nsql(). If a deadlock error is detected (error code 1205) then the entire batch is re-submitted up to I times. Default is 0 (off). =item syb_deadlock_sleep I Number of seconds to sleep between deadlock retries. Default is 60. =item syb_deadlock_verbose (bool) Enable verbose logging of deadlock retry logic. Default is off. =item syb_nsql_nostatus (bool) If true then stored procedure return status values (i.e. results of type CS_STATUS_RESULT) are ignored. =back Deadlock detection will be added to the $dbh->do() method in a future version of DBD::Sybase. =head1 Multi-Threading DBD::Sybase is thread-safe (i.e. can be used in a multi-threaded perl application where more than one thread accesses the database server) with the following restrictions: =over 4 =item * perl version >= 5.8 DBD::Sybase requires the use of I, available in the perl 5.8.0 release. It will not work with the older 5.005 threading model. =item * Sybase thread-safe libraries Sybase's Client Library comes in two flavors. DBD::Sybase must find the thread-safe version of the libraries (ending in _r on Unix/linux). This means Open Client 11.1.1 or later. In particular this means that you can't use the 10.0.4 libraries from the free 11.0.3.3 release on linux if you want to use multi-threading. Note: when using perl >= 5.8 with the thread-safe libraries (libct_r.so, etc) then signal handling is broken and any signal delivered to the perl process will result in a segmentation fault. It is recommended in that case to link with the non-threadsafe libraries. =item * use DBD::Sybase You I include the C line in your program. This is needed because DBD::Sybase needs to do some setup I the first thread is started. =back You can check to see if your version of DBD::Sybase is thread-safe at run-time by calling DBD::Sybase::thread_enabled(). This will return I if multi-threading is available. See t/thread.t for a simple example. =head1 BUGS You can run out of space in the tempdb database if you use a lot of calls with bind variables (ie ?-style placeholders) without closing the connection and Sybase 11.5.x or older. This is because Sybase creates stored procedures for each prepare() call. In 11.9.x and later Sybase will create "light-weight" stored procedures which don't use up any space in the tempdb database. The primary_key_info() method will only return data for tables where a declarative "primary key" constraint was included when the table was created. I have a simple bug tracking database at http://www.peppler.org/bugdb/ . You can use it to view known problems, or to report new ones. =head1 SEE ALSO L Sybase OpenClient C manuals. Sybase Transact SQL manuals. =head1 AUTHOR DBD::Sybase by Michael Peppler =head1 COPYRIGHT The DBD::Sybase module is Copyright (c) 1996-2023 Michael Peppler. The DBD::Sybase module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 ACKNOWLEDGEMENTS Tim Bunce for DBI, obviously! See also L. =cut DBD-Sybase-1.24/PWD.factory0000644000175000017500000000013014010471204015515 0ustar mpepplermpeppler# $Id: PWD.factory,v 1.1 2004/01/05 22:09:41 mpeppler Exp $ DB= SRV=SYBASE UID=sa PWD= DBD-Sybase-1.24/Sybase.xs0000644000175000017500000001162614010471204015310 0ustar mpepplermpeppler/* -*-C-*- */ /* $Id: Sybase.xs,v 1.19 2011/04/25 08:59:17 mpeppler Exp $ Copyright (c) 1997-2011 Michael Peppler Uses from Driver.xst Copyright (c) 1994,1995,1996,1997 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. */ #include "Sybase.h" DBISTATE_DECLARE; MODULE = DBD::Sybase PACKAGE = DBD::Sybase I32 constant() ALIAS: CS_ROW_RESULT = CS_ROW_RESULT CS_CURSOR_RESULT = CS_CURSOR_RESULT CS_PARAM_RESULT = CS_PARAM_RESULT CS_STATUS_RESULT = CS_STATUS_RESULT CS_MSG_RESULT = CS_MSG_RESULT CS_COMPUTE_RESULT = CS_COMPUTE_RESULT CODE: if (!ix) { char *what = GvNAME(CvGV(cv)); croak("Unknown DBD::Sybase constant '%s'", what); } else { RETVAL = ix; } OUTPUT: RETVAL void timeout(value) int value CODE: ST(0) = sv_2mortal(newSViv(syb_set_timeout(value))); void thread_enabled() CODE: ST(0) = sv_2mortal(newSViv(syb_thread_enabled())); void set_cslib_cb(cb) SV * cb CODE: ST(0) = sv_2mortal(newSVsv(syb_set_cslib_cb(cb))); MODULE = DBD::Sybase PACKAGE = DBD::Sybase::db void _isdead(dbh) SV * dbh ALIAS: syb_isdead = 1 CODE: D_imp_dbh(dbh); ST(0) = sv_2mortal(newSViv(imp_dbh->isDead)); void _date_fmt(dbh, fmt) SV * dbh char * fmt ALIAS: syb_date_fmt = 1 CODE: D_imp_dbh(dbh); ST(0) = syb_db_date_fmt(dbh, imp_dbh, fmt) ? &PL_sv_yes : &PL_sv_no; void ping(dbh) SV * dbh CODE: D_imp_dbh(dbh); ST(0) = sv_2mortal(newSViv(syb_ping(dbh, imp_dbh))); MODULE = DBD::Sybase PACKAGE = DBD::Sybase::st void cancel(sth) SV * sth ALIAS: syb_cancel = 1 CODE: D_imp_sth(sth); ST(0) = syb_st_cancel(sth, imp_sth) ? &PL_sv_yes : &PL_sv_no; void ct_get_data(sth, column, bufrv, buflen=0) SV * sth int column SV * bufrv int buflen ALIAS: syb_ct_get_data = 1 CODE: { D_imp_sth(sth); int len = syb_ct_get_data(sth, imp_sth, column, bufrv, buflen); ST(0) = sv_2mortal(newSViv(len)); } void ct_data_info(sth, action, column, attr=&PL_sv_undef) SV * sth char * action int column SV * attr ALIAS: syb_ct_data_info = 1 CODE: { D_imp_sth(sth); int sybaction; if(strEQ(action, "CS_SET")) { sybaction = CS_SET; } else if (strEQ(action, "CS_GET")) { sybaction = CS_GET; } ST(0) = syb_ct_data_info(sth, imp_sth, sybaction, column, attr) ? &PL_sv_yes : &PL_sv_no; } void ct_send_data(sth, buffer, size) SV * sth char * buffer int size ALIAS: syb_ct_send_data = 1 CODE: D_imp_sth(sth); ST(0) = syb_ct_send_data(sth, imp_sth, buffer, size) ? &PL_sv_yes : &PL_sv_no; void ct_prepare_send(sth) SV * sth ALIAS: syb_ct_prepare_send = 1 CODE: D_imp_sth(sth); ST(0) = syb_ct_prepare_send(sth, imp_sth) ? &PL_sv_yes : &PL_sv_no; void ct_finish_send(sth) SV * sth ALIAS: syb_ct_finish_send = 1 CODE: D_imp_sth(sth); ST(0) = syb_ct_finish_send(sth, imp_sth) ? &PL_sv_yes : &PL_sv_no; void syb_describe(sth, doAssoc = 0) SV * sth int doAssoc PPCODE: { D_imp_sth(sth); int i, k; HV *hv; SV *sv; char statbuff[255]; struct { int stat; char name[30]; } stat[] = { { CS_CANBENULL, "CS_CANBENULL" }, { CS_HIDDEN, "CS_HIDDEN" }, { CS_IDENTITY, "CS_IDENTITY" }, { CS_KEY, "CS_KEY" }, { CS_VERSION_KEY, "CS_VERSION_KEY" }, { CS_TIMESTAMP, "CS_TIMESTAMP" }, { CS_UPDATABLE, "CS_UPDATABLE" }, { CS_UPDATECOL, "CS_UPDATECOL" }, { CS_RETURN, "CS_RETURN" }, { 0, "" } }; /* lifted almost verbatim from Sybase::CTlib's CTlib.xs file... */ for(i = 0; i < imp_sth->numCols; ++i) { hv = newHV(); hv_store(hv, "NAME", 4, newSVpv(imp_sth->datafmt[i].name,0), 0); hv_store(hv, "TYPE", 4, newSViv(imp_sth->datafmt[i].datatype), 0); hv_store(hv, "MAXLENGTH", 9, newSViv(imp_sth->datafmt[i].maxlength), 0); hv_store(hv, "SYBMAXLENGTH", 12, newSViv(imp_sth->coldata[i].realLength), 0); hv_store(hv, "SYBTYPE", 7, newSViv(imp_sth->coldata[i].realType), 0); hv_store(hv, "SCALE", 5, newSViv(imp_sth->datafmt[i].scale), 0); hv_store(hv, "PRECISION", 9, newSViv(imp_sth->datafmt[i].precision), 0); statbuff[0] = 0; for(k = 0; stat[k].stat > 0; ++k) { if(imp_sth->datafmt[i].status & stat[k].stat) { strcat(statbuff, stat[k].name); strcat(statbuff, " "); } } hv_store(hv, "STATUS", 6, newSVpv(statbuff, 0), 0); sv = newRV_noinc((SV*)hv); if(doAssoc) XPUSHs(sv_2mortal(newSVpv(imp_sth->datafmt[i].name, 0))); XPUSHs(sv_2mortal(sv)); } } MODULE = DBD::Sybase PACKAGE = DBD::Sybase INCLUDE: Sybase.xsi DBD-Sybase-1.24/eg/0000755000175000017500000000000014577756334014127 5ustar mpepplermpepplerDBD-Sybase-1.24/eg/README0000644000175000017500000000053014010471204014751 0ustar mpepplermpeppler$Id: README,v 1.1 2001/03/06 01:17:21 mpeppler Exp $ The files in this directory are *examples*. In particular, dbschema.pl is a quick port I did from the dbschema.pl version using Sybase::DBlib, and has not been updated with recent enhancements and bug fixes to dbschema.pl (now maintained by David Owen, http://www.midsomer.org). Michael DBD-Sybase-1.24/eg/Show.cgi0000755000175000017500000000611714010471204015507 0ustar mpepplermpeppler#!/usr/local/bin/perl # $Id: Show.cgi,v 1.4 2001/06/04 14:06:39 mpeppler Exp $ # # Show a Sybase stored proc etc, in HTML. # Usage: http://host/cgi-bin/Show.cgi?server=SERVERNAME&database=DATABASE # where SERVERNAME is the server you wish to connect to (eg SYBASE) # and DATABASE is the database in which you wish to view the objects. use strict; use DBI; use CGI; my $query = new CGI; print $query->header; print $query->start_html(-title => "Show a Sybase Object"); my $server = $query->param('server'); my $database = $query->param('database'); my $state = $query->param('__state__') || 0; if(!$database) { error("Please supply the database parameter.

"); } my $dbh = DBI->connect("dbi:Sybase:$server", 'sa', ''); ($dbh->do("use $database") != -2) || error("The database $database deosn't exist"); SWITCH_STATE: while(1) { ($state == 0) && do { my($values, $labels) = getObjects(); print "

Show a Sybase objects definition:

\n"; print "

Please select an object:

\n"; print $query->start_form; print $query->scrolling_list(-name=>'object', '-values'=>$values, -labels=>$labels, -size=>10); $query->param(-name=>'__state__', '-values'=>1); print $query->hidden(-name=>'__state__'); print $query->hidden(-name=>'database'); print $query->hidden(-name=>'server'); print $query->submit; print $query->end_form; last SWITCH_STATE; }; ($state == 1) && do { print "

Show a Sybase object's definition:

\n"; my $objId = $query->param('object'); my $html = getText($objId); print $html; last SWITCH_STATE; }; } print $query->end_html; $dbh->disconnect; exit(0); sub getObjects { my $sth = $dbh->prepare(" select distinct 'obj' = o.name, 'user' = u.name, o.id, o.type from dbo.sysobjects o, dbo.sysusers u, dbo.sysprocedures p where u.uid = o.uid and o.id = p.id and p.status & 4096 != 4096 order by o.name "); $sth->execute; my $dat; my @values; my %labels; my $value; while($dat = $sth->fetchrow_hashref) { $value = "$dat->{id} - $dat->{type}"; push(@values, $value); $labels{$value} = "$dat->{user}.$dat->{obj}"; } $sth->finish; (\@values, \%labels); } sub getText { my $objId = shift; $objId =~ s/[\D\-\s]+$//; my $sth = $dbh->prepare("select text from dbo.syscomments where id = $objId"); $sth->execute; my $html = ''; my $text; while(($text) = $sth->fetchrow) { $html .= $text; } $sth->finish; TsqlToHtml($html); } sub TsqlToHtml { my $html = shift; $html =~ s/\n/
\n/g; $html =~ s/\b(as|begin|between|declare|delete|drop|else|end|exec|exists|go|if|insert|procedure|return|set|update|values|from|select|where|and|or|create|order by)\b/$1<\/b>/ig; $html =~ s/\b(tinyint|smallint|int|char|varchar|datetime|smalldatetime|money|smallmoney|numeric|decimal|text|binary|varbinary|image)\b/$1<\/i>/gi; $html =~ s/\t/\ \ \ \ /g; $html =~ s/ /\ /sg; $html; } sub error { print "

Error!

\n"; print @_; print $query->end_html; exit(0); } DBD-Sybase-1.24/eg/dbschema.pl0000755000175000017500000005240514010471204016207 0ustar mpepplermpeppler#!/usr/local/bin/perl -w # # $Id: dbschema.pl,v 1.1 1997/11/03 18:08:41 mpeppler Exp $ # # dbschema.pl A script to extract a database structure from # a Sybase database # # Written by: Michael Peppler (mpeppler@mbay.net) # Substantially rewritten by David Whitmarsh from a partial # System 10 implementation by Ashu Joglekar # Ported to DBI/DBD::Sybase by Michael Peppler # # Last Mods: 31 October 1997 # # Usage: dbschema.pl -d database -o script.name -t pattern -s server -v # where database is self-explanatory (default: master) # script.name is the output file (default: script.isql) # pattern is the pattern of object names (in sysobjects) # that we will look at (default: %), and server is # the server to connect to (default, the value of $ENV{DSQUERY}). # # -v turns on a verbose switch. # # Changes: 11/18/93 - bpapp - Put in interactive SA password prompt # 11/18/93 - bpapp - Get protection information for views and # stored procedures. # 02/22/94 - mpeppler - Merge bpapp's changes with itf version' # 09/15/94 - mpeppler - Minor changes for use with Sybperl2 # alpha1 # 13/10/95 - Ashu Joglekar - System 10 w/o RI # 11/11/96 - David Whitmarsh - # Use Sybase::DBlib # System 10 declarative RI # constraints # Eliminate key truncation problems # Optional password command line # Debugged and strictified # Some index/key options # 17/2/97 - Michael Peppler # Fixed small ',' problem in printKeys() # 11/3/97 - David Whitmarsh # bug handling user defined types used as # identity columns. # addtype now has scale, prec # removed spurious addtypes for nchar etc. # null/not null/identity on types # 12/3/97 - Michael Peppler # Added -i switch to set an alternate interfaces # file. # # If anyone knows a way to distinguish between key and reference # declarations made at column and table level, let me know. #------------------------------------------------------------------------------ use strict; use DBI; use Getopt::Std; sub getPerms; sub getObj; sub printKeys; sub getComment; sub PrintCols; sub DumpTable; my ($dbh, @dat, $dat, $udflt, $urule, %udflt, %urule, %tables, @tabnames, @col); my $sth; my ($rule, $dflt, $date, $name); select (STDOUT); $| = 1; # make unbuffered getopts ('u:p:d:t:o:s:i:v'); $Getopt::Std::opt_u = `whoami` unless $Getopt::Std::opt_u; $Getopt::Std::opt_d = 'master' unless $Getopt::Std::opt_d; $Getopt::Std::opt_o = 'script.isql' unless $Getopt::Std::opt_o; $Getopt::Std::opt_t = '%' unless $Getopt::Std::opt_t; $Getopt::Std::opt_s = $ENV{DSQUERY} unless $Getopt::Std::opt_s; open(SCRIPT, "> $Getopt::Std::opt_o") || die "Can't open $Getopt::Std::opt_o: $!\n"; open(LOG, "> $Getopt::Std::opt_o.log") || die "Can't open $Getopt::Std::opt_o.log: $!\n"; # # Log us in to Sybase as '$Getopt::Std::opt_u' and prompt for password. # if (!$Getopt::Std::opt_p) { print "\nPassword: "; system("stty -echo"); chop($Getopt::Std::opt_p = <>); system("stty echo"); } my $ifile = ''; if($Getopt::Std::opt_i) { $ifile = "interfaces=$Getopt::Std::opt_i"; } $dbh = DBI->connect("dbi:Sybase:server=$Getopt::Std::opt_s;$ifile", $Getopt::Std::opt_u, $Getopt::Std::opt_p); $dbh->do("use $Getopt::Std::opt_d"); $date = scalar(localtime); print "dbschema.pl on Database $Getopt::Std::opt_d\n"; print LOG "Error log from dbschema.pl on Database $Getopt::Std::opt_d on $date\n\n"; print LOG "The following objects cannot be reliably created from the script in $Getopt::Std::opt_o. Please correct the script to remove any inconsistencies.\n\n"; print SCRIPT "/* This Isql script was generated by dbschema.pl on $date. */\n"; print SCRIPT "\nuse $Getopt::Std::opt_d\ngo\n"; # Change to the appropriate database # first, Add the appropriate user data types: # print "Add user-defined data types..."; print SCRIPT "/* Add user-defined data types: */\n\n"; $sth = $dbh->prepare (< 100 and st.usertype < 100 and st.name not in ('intn', 'nvarchar', 'sysname', 'nchar') SQLEND ); $sth->execute; while((@dat = $sth->fetchrow)) { print SCRIPT "sp_addtype $dat[1], "; ($dat[2] =~ /char\b|binary\b/ and print SCRIPT "'$dat[2]($dat[0])'") or ($dat[2] =~ /\bnumeric\b|\bdecimal\b/ and print SCRIPT "'$dat[2]($dat[5],$dat[6])'") or print SCRIPT "$dat[2]"; (($dat[8] == 1) and print SCRIPT ", 'identity'") or (($dat[7] == 1) and print SCRIPT ", 'null'") or print SCRIPT ", 'not null'"; print SCRIPT "\ngo\n"; # Now remember the default & rule for later. $urule{$dat[1]} = $dat[4] if defined($dat[4]); $udflt{$dat[1]} = $dat[3] if defined($dat[3]); } $sth->finish(); print "Done\n"; print "Create rules..."; print SCRIPT "\n/* Now we add the rules... */\n\n"; getObj('Rule', 'R'); print "Done\n"; print "Create defaults..."; print SCRIPT "\n/* Now we add the defaults... */\n\n"; getObj('Default', 'D'); print "Done\n"; print "Bind rules & defaults to user data types..."; print SCRIPT "/* Bind rules & defaults to user data types... */\n\n"; while(($dat, $dflt)=each(%udflt)) { print SCRIPT "sp_bindefault $dflt, $dat\ngo\n"; } while(($dat, $rule) = each(%urule)) { print SCRIPT "sp_bindrule $rule, $dat\ngo\n"; } print "Done\n"; print "Create Tables & Indices..."; print "\n" if $Getopt::Std::opt_v; # the fourth column set to 'N' becomes the indicator that this table has been # printed $sth = $dbh->prepare (<execute; while((@dat = $sth->fetchrow)) { $tables{$dat[1] . "." . $dat[0]} = [ @dat ]; @tabnames = ( @tabnames, $dat[1] . "." . $dat[0] ); } $sth->finish; foreach $name (@tabnames) { DumpTable ($tables{$name}, ()); } print "Done\n"; # # The key definitions - sp_primarykey etc, not constraints # Primary keys first, then foreign and common # printKeys (); # # Now create any views that might exist # print "Create views..."; print SCRIPT "\n/* Now we add the views... */\n\n"; getObj('View', 'V'); print "Done\n"; # # Now create any stored procs that might exist # print "Create stored procs..."; print SCRIPT "\n/* Now we add the stored procedures... */\n\n"; getObj('Stored Proc', 'P'); print "Done\n"; # # Now create the triggers # print "Create triggers..."; print SCRIPT "\n/* Now we add the triggers... */\n\n"; getObj('Trigger', 'TR'); print "Done\n"; print "\nLooks like I'm all done!\n"; close(SCRIPT); close(LOG); $dbh->disconnect; sub getPerms { my ($obj) = $_[0]; my ($ret, @dat, $act, $cnt); $sth = $dbh->prepare ("sp_helprotect '$obj'\n"); $sth->execute; $cnt = 0; while(@dat = $sth->fetchrow) { $act = 'to'; $act = 'from' if $dat[0] =~ /Revoke/; print SCRIPT "$dat[2] $dat[3] on $obj $act $dat[1]\n"; ++$cnt; } $sth->finish; $cnt; } sub getObj { my ($objname, $obj) = @_; my (@dat, @items, @vi, $found, $text); $sth = $dbh->prepare (<execute; while((@dat = $sth->fetchrow)) { push (@items, [ @dat ]); # and save it in a list } $sth->finish; foreach (@items) { @vi = @$_; $found = 0; $sth = $dbh->prepare ("select text from dbo.syscomments where id = $vi[2]"); $sth->execute; print SCRIPT "/* $objname $vi[0], owner $vi[1] */\n"; while(($text) = $sth->fetchrow) { if(!$found && $vi[1] ne 'dbo') { ++$found if($text =~ /$vi[1]/); } print SCRIPT $text; } $sth->finish; print SCRIPT "\ngo\n"; if(!$found && $vi[1] ne 'dbo') { print "**Warning**\n$objname $vi[0] has owner $vi[1]\nbut this is not mentioned in the CREATE PROC statement!!\n"; print LOG "$objname $vi[0] (owner $vi[1])\n"; } if ($obj eq 'V' || $obj eq 'P') { getPerms("$vi[0]") && print SCRIPT "go\n"; } } } sub printKeys { print "Create sp_*key definitions..."; print SCRIPT "\n/* Now create the key definitions ...*/\n\n"; $sth = $dbh->prepare (<execute; while((@dat = $sth->fetchrow)) { if ($dat[0] eq "primary") { print SCRIPT "sp_primarykey $dat[1],"; PrintCols (@dat[3..10]); print SCRIPT "\ngo\n"; } if ($dat[0] eq "foreign") { print SCRIPT "sp_foreignkey $dat[1], $dat[2],"; PrintCols (@dat[11..18]); print SCRIPT "\ngo\n"; } if ($dat[0] eq "common") { print SCRIPT "sp_commonkey $dat[1], $dat[2],"; PrintCols (@dat[3..10]); print SCRIPT "\ngo\n"; } } $sth->finish; print "done\n" } sub getComment { my ($objid) = @_; my ($line, $text); $sth = $dbh->prepare ( qq(select text from dbo.syscomments where id = $objid)); $sth->execute; $text = ""; while(($line) = $sth->fetchrow) { $text = $text . $line; } $sth->finish; return $text; } sub PrintCols { my ($col, $first); $first = 1; while ($col = shift (@_)) { last if ($col eq '*'); print SCRIPT ", " if !$first; $first = 0; print SCRIPT "$col"; } } # Note: this is a recursive subroutine. # If the current table references another that is in the list of # tables to be dumped, and if that table has not yet been dumped, # then DumpTable is called to dump it before proceeding sub DumpTable { my ($tabref, @referers) = @_; return if @$tabref[3] eq "Y"; my @nul = ('not null','null'); my (@dat, $dat, @col); my (@refcols, @reflist, @field, $rule, $dflt, %rule, %dflt, $ddlrule, $ddldflt); my ($refname, $first, $matchstring, $field, @constrids, $constrid); my ($frgntabref); my ($nultype); # first, get any reference and ensure that dependent tables have already been # created $sth = $dbh->prepare (<execute; while((@refcols = $sth->fetchrow)) { push (@reflist, [ @refcols ]); } $sth->finish; foreach (@reflist) { @refcols = @$_; # if the foreign table is in a foreign database or is not in # our table list, then don't do any more than add it to the list next if $refcols[0] ne $Getopt::Std::opt_d; $refname = $refcols[3] . "." . $refcols[2]; next if not defined ($tables{$refname}); $frgntabref = $tables{$refname}; # otherwise check if it's already been dumped, if so, continue next if @$frgntabref[3] eq "Y"; # make sure we aren't in a refernce loop by checking to see if this table is # already in the heirarchy of refering tables that led to the current invocation grep ($refname, @referers) && print SCRIPT "/* WARNING: circular foreign key reference to $refname */\n" && print LOG "@$tabref[1].@$tabref[0] in circular foreign key reference to $refname\n"; # so dump the referenced tables first DumpTable ($frgntabref, @referers, $refname); } print "Creating table @$tabref[0], owner @$tabref[1]\n" if $Getopt::Std::opt_v; print SCRIPT "/* Start of description of table @$tabref[1].@$tabref[0] */\n\n"; $sth = $dbh->prepare (<execute; undef(%rule); undef(%dflt); print SCRIPT "\n\nCREATE TABLE @$tabref[1].@$tabref[0] (\n"; $first = 1; @col = (); while (@field = $sth->fetchrow) { push @col, [ @field ]; } $sth->finish; foreach (@col) { @field = @$_; print SCRIPT ",\n" if !$first; # add a , and a \n if not first field in table # get the declarative rule and default (if set) if ($field[9] != 0) { $ddldflt = getComment ($field[11]); } else { $ddldflt = ""; } if ($field[10] != 0) { $ddlrule = getComment ($field[12]); } else { $ddlrule = ""; } # Check if its an identity column if ($field[8] == 1) { $nultype = "identity"; } else { $nultype = $nul[$field[5]]; } print SCRIPT "\t$field[0] \t$field[1]"; print SCRIPT "($field[2])" if $field[1] =~ /char|bin/; print SCRIPT "($field[3],$field[4])" if $field[1] =~ /\bnumeric\b|\bdecimal\b/; print SCRIPT " $ddldflt $nultype $ddlrule"; if (defined ($field[7]) && ((!defined ($urule{$field[1]})) || $urule{$field[1]} ne $field[7]) && ($field[10] == 0)) { $rule{"@$tabref[0].$field[0]"} = $field[7]; } if (defined ($field[6]) && ((!defined ($udflt{$field[1]})) || $udflt{$field[1]} ne $field[6]) && ($field[9] == 0)) { $dflt{"@$tabref[0].$field[0]"} = $field[6]; } $first = 0 if $first; } # references foreach (@reflist) { @refcols = @$_; print SCRIPT ","; $refname = $refcols[3] . "." . $refcols[2]; if ($refcols[0] ne $Getopt::Std::opt_d) { print SCRIPT "\n/* The following reference is in database ** $refcols[0], edit the script to create the reference manually "; print LOG "Reference for @$tabref[1].@$tabref[0] in foreign database\n\t"; $refname = $refcols[0] . "." . $refname; } print SCRIPT "\n\t"; $matchstring = substr($refcols[1], 0, 8) . "[_0-9][_0-9]*"; $refcols[1] !~ /$matchstring/ && print SCRIPT "CONSTRAINT $refcols[1] "; print SCRIPT "FOREIGN KEY ("; PrintCols (@refcols[4..19]); print SCRIPT ") REFERENCES $refname ("; PrintCols (@refcols[20..35]); print SCRIPT ")"; if ($refcols[0] ne $Getopt::Std::opt_d) { print SCRIPT "*/"; } } # now get the indexes and keys... # print "Indexes for table @$tabref[1].@$tabref[0]\n" if $Getopt::Std::opt_v; $sth = $dbh->prepare (<execute; @col = (); while((@field = $sth->fetchrow)) { # if this is a key or unique constraint, print out the details # otherwise buffer it up to print as an index afterwards if ($field[3] & 2) { print (SCRIPT ",\n\t"); print SCRIPT "CONSTRAINT $field[0] " unless ($field[3] & 8); if ($field[2] & 2048) { print SCRIPT "PRIMARY KEY "; print SCRIPT "NONCLUSTERED " if ($field[1] != 1); } else { print SCRIPT "UNIQUE "; print SCRIPT "CLUSTERED " if ($field[1] == 1); } print SCRIPT "("; PrintCols (@field[4..19]); print SCRIPT ")"; } else { push @col, [ @field ]; } } $sth->finish; # Now do the table level check constraints @constrids = (); $sth = $dbh->prepare (<execute; while (@field = $sth->fetchrow) { @constrids = (@constrids, $field[0]); } $sth->finish; foreach $constrid (@constrids) { print SCRIPT ",\n\t" . getComment ($constrid); } print SCRIPT "\n)\ngo\n"; # end of CREATE TABLE foreach (@col) { # now print the indexes @field = @$_; print SCRIPT "\nCREATE "; print SCRIPT "UNIQUE " if $field[2] & 2; print SCRIPT "CLUSTERED " if $field[1] == 1; print SCRIPT "INDEX $field[0]\n"; print SCRIPT "ON @$tabref[1].@$tabref[0] ("; PrintCols (@field[4..19]); print SCRIPT ")"; $first = 1; if ($field[2] & 64) { print SCRIPT " WITH ALLOW_DUP_ROW"; $first = 0; } if ($field[2] & 1) { print SCRIPT (($first == 0) ? ", " : " WITH ") . "IGNORE_DUP_KEY"; $first = 0; } if ($field[2] & 4) { print SCRIPT (($first == 0) ? ", " : " WITH ") . "IGNORE_DUP_ROW"; $first = 0; } print SCRIPT "\ngo\n"; } getPerms("@$tabref[1].@$tabref[0]") && print SCRIPT "go\n"; print "Bind rules & defaults to columns...\n" if $Getopt::Std::opt_v; print SCRIPT "/* Bind rules & defaults to columns... */\n\n"; if(@$tabref[1] ne 'dbo' && (keys(%dflt) || keys(%rule))) { print SCRIPT "/* The owner of the table is @$tabref[1]. * I can't bind the rules/defaults to a table of which I am not the owner. * The procedures below will have to be run manualy by user @$tabref[1]. */"; print LOG "Defaults/Rules for @$tabref[1].@$tabref[0] could not be bound\n"; } while(($dat, $dflt)=each(%dflt)) { print SCRIPT "/* " if @$tabref[1] ne 'dbo'; print SCRIPT "sp_bindefault $dflt, '$dat'"; if(@$tabref[1] ne 'dbo') { print SCRIPT " */\n"; } else { print SCRIPT "\ngo\n"; } } while(($dat, $rule) = each(%rule)) { print SCRIPT "/* " if @$tabref[1] ne 'dbo'; print SCRIPT "sp_bindrule $rule, '$dat'"; if(@$tabref[1] ne 'dbo') { print SCRIPT " */\n"; } else { print SCRIPT "\ngo\n"; } } print SCRIPT "\n/* End of description of table @$tabref[1].@$tabref[0] */\n"; @$tabref[3] = "Y"; } DBD-Sybase-1.24/eg/check-space.pl0000755000175000017500000000540014010471204016600 0ustar mpepplermpeppler#!/usr/bin/perl -w # # $Id: check-space.pl,v 1.1 2001/12/13 01:05:26 mpeppler Exp $ # # List the spaceusage of a database, and the space usage of each # user table in the DB. use strict; use DBI; use Getopt::Long; my %args; GetOptions(\%args, '-U=s', '-P=s', '-S=s', '-D=s'); my $dbh = DBI->connect("dbi:Sybase:server=$args{S};database=$args{D}", $args{U}, $args{P}); $dbh->{syb_do_proc_status} = 1; my $dbinfo; # First check space in the DB: my $sth = $dbh->prepare("sp_spaceused"); $sth->execute; do { while(my $d = $sth->fetch) { if($d->[0] =~ /$args{D}/) { $d->[1] =~ s/[^\d.]//g; $dbinfo->{size} = $d->[1]; } else { foreach (@$d) { s/\D//g; } $dbinfo->{reserved} = $d->[0] / 1024; $dbinfo->{data} = $d->[1] / 1024; $dbinfo->{index} = $d->[2] / 1024; } # print "@$d\n"; } } while($sth->{syb_more_results}); # Get the actual device usage from sp_helpdb to get the free log space $sth = $dbh->prepare("sp_helpdb $args{D}"); $sth->execute; do { while(my $d = $sth->fetch) { #print "@$d\n"; if($d->[2] && $d->[2] =~ /log only/) { $d->[1] =~ s/[^\d\.]//g; $dbinfo->{log} += $d->[1]; } if($d->[0] =~ /log only .* (\d+)/) { $dbinfo->{logfree} = $1 / 1024; } } } while($sth->{syb_more_results}); $dbinfo->{size} -= $dbinfo->{log}; #if(($dbinfo->{reserved} / $dbinfo->{size}) > 0.75) { # warn "WARNING: smlive free space is below 25%\n"; #} my $freepct = ($dbinfo->{size} - $dbinfo->{reserved}) / $dbinfo->{size}; print "$args{S}/$args{D} spaceusage report\n\n"; printf "Database size: %10.2f MB\n", $dbinfo->{size}; printf "Log size: %10.2f MB\n", $dbinfo->{log}; printf "Free Log: %10.2f MB\n", $dbinfo->{logfree}; printf "Reserved: %10.2f MB\n", $dbinfo->{reserved}; printf "Data: %10.2f MB\n", $dbinfo->{data}; printf "Indexes: %10.2f MB\n", $dbinfo->{index}; printf "Free space: %10.2f %%\n", $freepct * 100; if($freepct < .25) { printf "**WARNING**: Free space is below 25%% (%.2f%%)\n\n", $freepct * 100; } print "\nTable information (in MB):\n\n"; printf "%15s %15s %10s %10s %10s\n\n", "Table", "Rows", "Reserved", "Data", "Indexes"; my @tables = getTables($dbh); foreach (@tables) { my $sth = $dbh->prepare("sp_spaceused $_"); $sth->execute; do { while(my $d = $sth->fetch) { foreach (@$d) { s/KB//; s/\s//g; } printf("%15.15s %15d %10.2f %10.2f %10.2f\n", $d->[0], $d->[1], $d->[2] / 1024, $d->[3] / 1024, $d->[4] / 1024); # print "@$d\n"; } } while($sth->{syb_more_results}); } sub getTables { my $dbh = shift; my $sth = $dbh->table_info; my @tables; do { while(my $d = $sth->fetch) { push(@tables, $d->[2]) unless $d->[3] =~ /SYSTEM|VIEW/; } } while($sth->{syb_more_results}); @tables; } DBD-Sybase-1.24/Makefile.PL0000644000175000017500000003667114361730257015506 0ustar mpepplermpeppler# $Id: Makefile.PL,v 1.48 2012/10/26 19:11:54 mpeppler Exp $ use ExtUtils::MakeMaker; require 5.004; use strict; # If either of these aren't available on your system then you need to # get them! use DBI; use DBI::DBD; use Config; use Getopt::Long; use vars qw($SYBASE $inc_string $lib_string $LINKTYPE $written_pwd_file $newlibnames $libdir); $LINKTYPE = 'dynamic'; $written_pwd_file = 'PWD'; # regexp to find libct/libsybct, and avoid picking up libct_cu which isn't anything we want at all... # https://github.com/mpeppler/DBD-Sybase/issues/64 my $libct_re = qr/\blib(syb)?ct(64)?\./i; # freetds can be installed in system lib directories. We can pick those out # from Config{libsdir} my @libsdir = split(' ', $Config{libsdirs}); my $file; my $chained; my $threaded_libs; my $accept_test_defaults; GetOptions( '--file' => \$file, '--chained:s' => \$chained, '--threaded_libs:s' => \$threaded_libs, '--accept_test_defaults' => \$accept_test_defaults ); select(STDOUT); $| = 1; configure(); configPwd(); my $lddlflags = $Config{lddlflags}; # According to https://github.com/mpeppler/DBD-Sybase/issues/62 we don't need to set # lddlflags or ldflags on Windows. $lddlflags = "-L$SYBASE/$libdir $lddlflags" unless $^O eq 'VMS' || $^O eq 'MSWin32'; my $ldflags = $Config{ldflags}; $ldflags = "-L$SYBASE/$libdir $ldflags" unless $^O eq 'VMS' || $^O eq 'MSWin32'; WriteMakefile( 'NAME' => 'DBD::Sybase', PREREQ_PM => { 'DBI' => '0' }, LIBS => [$lib_string], INC => $inc_string, clean => { FILES => "Sybase.xsi $written_pwd_file" }, OBJECT => '$(O_FILES)', 'VERSION_FROM' => 'Sybase.pm', 'LDDLFLAGS' => $lddlflags, # 'LDFLAGS' => $ldflags, LINKTYPE => $LINKTYPE, ( $^O eq 'VMS' ? ( MAN3PODS => { 'Sybase.pm' => 'blib/man3/DBD_Sybase.3' } ) : ( MAN3PODS => { 'Sybase.pm' => 'blib/man3/DBD::Sybase.3' } ) ), ABSTRACT => 'DBI driver for Sybase datasources', AUTHOR => 'Michael Peppler (mpeppler@peppler.org)', ( $] >= 5.005 && $^O eq 'MSWin32' && $Config{archname} =~ /-object\b/i ? ( CAPI => 'TRUE' ) : () ), 'dist' => { 'TARFLAGS' => 'cvf', 'COMPRESS' => 'gzip' }, ( $^O eq 'VMS' ? ( PM => 'Sybase.pm' ) : () ), META_MERGE => { 'meta-spec' => { version => 2 }, resources => { bugtracker => { web => 'https://github.com/mpeppler/DBD-Sybase/issues', }, repository => { url => 'https://github.com/mpeppler/DBD-Sybase.git', web => 'https://github.com/mpeppler/DBD-Sybase', type => 'git', } }, } ); sub MY::postamble { return dbd_postamble(); } sub configure { my %attr; my ( $key, $val ); my $sybase_dir = $ENV{SYBASE}; if ( !$sybase_dir ) { # PR 517 - getpwnam() isn't portable. eval q{ $sybase_dir = (getpwnam('sybase'))[7]; }; } open( IN, "CONFIG" ) || die "Can't open CONFIG: $!"; while () { chomp; next if /^\s*\#/; next if /^\s*$/; ( $key, $val ) = split( /\s*=\s*/, $_ ); $key =~ s/\s//g; $val =~ s/\s*$//; $attr{$key} = $val; } if ( -d $sybase_dir ) { $SYBASE = $sybase_dir; } else { if ( $attr{SYBASE} && -d $attr{SYBASE} ) { $SYBASE = $attr{SYBASE}; } } if ( !$SYBASE || $SYBASE =~ /^\s*$/ ) { die "Please set SYBASE in CONFIG, or set the \$SYBASE environment variable"; } $SYBASE = VMS::Filespec::unixify($SYBASE) if $^O eq 'VMS'; if ( $^O eq 'darwin' ) { my $osxdir = 'Applications/Sybase/System'; $SYBASE = $osxdir if -d $SYBASE && -d $osxdir; } # System 12.0 has a different directory structure... if ( defined( $ENV{SYBASE_OCS} ) ) { # if $SYBASE_OCS is an absolute path, then use that if ( $ENV{SYBASE_OCS} =~ m!^/! ) { $SYBASE = $ENV{SYBASE_OCS}; } else { $SYBASE .= "/$ENV{SYBASE_OCS}"; } } my @libdir = ( "$SYBASE/lib", "$SYBASE/lib64", @libsdir); if ( $^O eq 'MSWin32' ) { @libdir = ("$SYBASE/dll"); } foreach my $l (@libdir) { if ( -d $l ) { if ( checkLib($l) ) { $libdir = $l; last; } } } die "Can't find any Sybase libraries in " . join( ' or ', @libdir ) unless defined $libdir; my $inc_found = 0; if ( -d "$SYBASE/include" && -f "$SYBASE/include/cspublic.h" ) { ++$inc_found; $inc_string = "-I$SYBASE/include"; } # In some freetds installations the include files have been moved # into /usr/include/freetds. if ( -d "$SYBASE/include/freetds" && "$SYBASE/include/freetds/cspublic.h" ) { ++$inc_found; $inc_string = "-I$SYBASE/include/freetds"; } die "Can't find the Client Library include files under $SYBASE" unless ($inc_found); my $version = getLibVersion($libdir); # if(!$version || $version lt '12') { #print "FreeTDS or older Client Library. Enabling CS-Lib Callbacks\n"; #$inc_string .= " -DUSE_CSLIB_CB=1"; # } checkChainedAutoCommit(); # print "OS = $^O\n"; my %libname = loadSybLibs( $libdir, $^O eq 'MSWin32' ? qr/lib/ : $^O eq 'VMS' ? qr/olb/ : qr/(?:so|a|sl)/ ); my $libtype = ''; if ( $^O eq 'MSWin32' ) { if ( $version ge '15' ) { # $libsub is "dll" on Windows... $lib_string = "-L$libdir -llibsybct.lib -llibsybcs.lib -llibsybtcl.lib -llibsybcomn.lib -llibsybintl.lib -llibsybblk.lib $attr{EXTRA_LIBS} -lm"; } else { $lib_string = "-L$libdir -llibct.lib -llibcs.lib -llibtcl.lib -llibcomn.lib -llibintl.lib -llibblk.lib $attr{EXTRA_LIBS} -lm"; } } elsif ( $^O eq 'VMS' ) { $lib_string = "-L$SYBASE/lib -llibct.olb -llibcs.olb -llibtcl.olb -llibcomn.olb -llibintl.olb -llibblk.olb $attr{EXTRA_LIBS}"; } elsif ( $^O =~ /cygwin/ ) { # $lib_string = "-L$SYBASE/lib -lct -lcs -lblk"; # $inc_string .= " -D_MSC_VER=800"; $inc_string .= " -D_MSC_VER=800"; my $bits64 = ""; if ($Config{ptrsize} == 8) { $bits64 = 64; $inc_string .= " -DSYB_LP64"; } if ($version ge '15') { $lib_string = "-L$SYBASE/lib -lsybct$bits64 -lsybcs$bits64 -lsybblk$bits64"; } else { $lib_string = "-L$SYBASE/lib -lct$bits64 -lcs$bits64 -lblk$bits64"; } } else { # Supplied by Erick Calder. I'm not sure why libsybsrv is needed... $attr{EXTRA_LIBS} .= " -lsybsrv" if $^O eq 'darwin'; my $extra = getExtraLibs( $attr{EXTRA_LIBS}, $version ); if ($file) { $lib_string = "-L$libdir -lct -lcs -ltcl -lcomn -lintl -lblk $attr{EXTRA_LIBS} -ldl -lm"; } else { $lib_string = "-L$libdir -lct -lcs -ltcl -lcomn -lintl -lblk $extra -ldl -lm"; } if ($newlibnames) { foreach (qw(ct cs tcl comn intl blk)) { $lib_string =~ s/-l$_/-lsyb$_/; } } elsif ( $^O =~ /linux|freebsd/i ) { $lib_string =~ s/-ltcl/-lsybtcl/; } # Logic to replace normal libs with _r (re-entrant) libs if # usethreads is defined provided by W. Phillip Moore (wpm@ms.com) # I have no idea if this works on Win32 systems (probably not!) if ( $Config{usethreads} ) { print "Running in threaded mode - looking for _r libraries...\n"; if ( checkForThreadedLibs() ) { my $found = 0; foreach ( split( /\s+/, $lib_string ) ) { next unless /^-l(\S+)/; my $oldname = $1; my $newname = $1 . "_r"; next unless exists $libname{$newname}; print "Found -l$newname for -l$oldname\n"; ++$found; $lib_string =~ s/-l$oldname\b/-l$newname/; } if ( !$found ) { print "No thread-safe Sybase libraries found\n"; $inc_string .= ' -DNO_THREADS '; } else { $libtype .= '_r'; } } else { print "OK - I'll use the normal libs\n\n"; } } # If we are building for a 64 bit platform that also supports 32 bit # (i.e. Solaris 8, HP-UX11, etc) then we need to make some adjustments if ( $Config{use64bitall} ) { # Tru64/DEC OSF does NOT use the SYB_LP64 define # as it is ALWAYS in 64 bit mode. $inc_string .= ' -DSYB_LP64' unless $^O eq 'dec_osf'; print "Running in 64bit mode - looking for '64' libraries...\n"; my $found = 0; foreach ( split( /\s+/, $lib_string ) ) { next unless /^-l(\S+)/; my $oldname = $1; my $newname = $1 . '64'; next unless exists $libname{$newname}; print "Found -l$newname for -l$oldname\n"; $lib_string =~ s/-l$oldname\b/-l$newname/; ++$found; } if ($found) { $libtype .= '64'; } } } # Is the blk library available? #my @k = keys(%libname); #print "@k\n"; #print "libtype = $libtype\n"; if ( my @l = grep( /(syb)?blk$libtype/, keys(%libname) ) ) { print "BLK api available - found: @l\n"; } else { print "BLK api NOT available.\n"; $inc_string .= ' -DNO_BLK=1'; } my $config_sitearch = $Config{sitearchexp}; my $attr_dbi_include = $attr{DBI_INCLUDE}; if ( $^O eq 'VMS' ) { $config_sitearch = VMS::Filespec::unixify($config_sitearch); $attr_dbi_include = VMS::Filespec::unixify($attr_dbi_include); } my @try = ( @INC, $Config{sitearchexp} ); unshift @try, $attr{DBI_INCLUDE} if $attr{DBI_INCLUDE}; my $dbidir; for my $trydir (@try) { if ( -e "$trydir/auto/DBI/DBIXS.h" ) { $dbidir = "$trydir/auto/DBI"; last; } } die "Can't find the DBI include files. Please set DBI_INCLUDE in CONFIG" if !$dbidir; $inc_string .= " -I$dbidir"; if ( $attr{LINKTYPE} ) { $LINKTYPE = $attr{LINKTYPE}; } } sub loadSybLibs { my ( $dir, $extensionRegexp ) = @_; my %libname = (); opendir( SYBLIB, $dir ) or die "Unable to opendir $dir: $!\n"; foreach ( readdir(SYBLIB) ) { next unless -f "$dir/$_"; next unless /^lib(\S+)\.$extensionRegexp/; $libname{$1} = 1; } closedir(SYBLIB); return %libname; } sub getLibVersion { my $lib = shift; opendir( DIR, $lib ); # reverse to pick up libsybct before libct... my @files = reverse( grep( /$libct_re/, readdir(DIR) ) ); closedir(DIR); my $file; foreach (@files) { $file = "$lib/$_"; last if -e $file; } open( IN, $file ) || die "Can't open $file: $!"; binmode(IN); my $version; while () { if (/S(?:AP|ybase) Client-Library\/([^\/]+)\//) { $version = $1; last; } } close(IN); if ( !$version ) { print "Unknown Client Library version - assuming FreeTDS.\n"; } else { print "Sybase OpenClient $version found.\n"; } return $version; } sub getExtraLibs { my $cfg = shift; my $version = shift; opendir( DIR, "$libdir" ) || die "Can't access $libdir: $!"; my %files = map { $_ =~ s/lib([^\.]+)\..*/$1/; $_ => 1 } grep( /lib/ && -f "$libdir/$_", readdir(DIR) ); closedir(DIR); my %x = map { $_ => 1 } split( ' ', $cfg ); my $dlext = $Config{dlext} || 'so'; foreach my $f ( keys(%x) ) { my $file = $f; $file =~ s/-l//; next if ( $file =~ /^-/ ); delete( $x{$f} ) unless exists( $files{$file} ); } foreach my $f (qw(insck tli sdna dnet_stub tds skrb gss)) { $x{"-l$f"} = 1 if exists $files{$f} && -f "$libdir/lib$f.$dlext"; } if ( $version gt '11' ) { delete( $x{-linsck} ); delete( $x{-ltli} ); } # if($version ge '12.5.1') { # delete($x{-lskrb}); # } join( ' ', keys(%x) ); } sub checkLib { my $dir = shift; opendir( DIR, "$dir" ) || die "Can't access $dir: $!"; my @files = grep( /$libct_re/i, readdir(DIR) ); closedir(DIR); if ( grep( /libsybct/, @files ) ) { $newlibnames = 1; } else { $newlibnames = 0; } scalar(@files); } sub configPwd { open( IN, "PWD.factory" ) || die "Can't open PWD.factory: $!"; my %pwd; while () { chomp; next if (/^\s*\#/); next if (/^\s*$/); my ( $key, $val ) = split( /=/, $_ ); $pwd{$key} = $val || "undef"; } close(IN); if ($accept_test_defaults) { $pwd{SRV} = $pwd{SRV}; $pwd{UID} = $pwd{UID}; $pwd{PWD} = $pwd{PWD}; $pwd{DB} = $pwd{DB}; } else { print "The DBD::Sybase module need access to a Sybase server to run the tests.\n"; print "To clear an entry please enter 'undef'\n"; print "Sybase server to use (default: $pwd{SRV}): "; $pwd{SRV} = getAns(0) || $pwd{SRV}; print "User ID to log in to Sybase (default: $pwd{UID}): "; $pwd{UID} = getAns(0) || $pwd{UID}; print "Password (default: $pwd{PWD}): "; $pwd{PWD} = getAns(1) || $pwd{PWD}; print "Sybase database to use on $pwd{SRV} (default: $pwd{DB}): "; $pwd{DB} = getAns(0) || $pwd{DB}; } warn "\n* Writing login information, including password, to file $written_pwd_file.\n\n"; # Create the file non-readable by anyone else. my $old_umask; unless ( $^O =~ /MSWin32/ ) { $old_umask = umask(077); warn "cannot umask(): $!" unless defined($old_umask); } open( OUT, ">$written_pwd_file" ) || die "Can't open $written_pwd_file: $!"; unless ( $^O =~ /MSWin32/ ) { umask($old_umask) != 077 && warn "strange return from umask()"; } print OUT <= 5.008 ) { $ret = 0; print <; if ( $flag && -t ) { eval { Term::ReadKey::ReadMode('normal'); }; print "\n"; # because newline from user wasn't echo'd } $ans =~ s/^\s+//; $ans =~ s/\s+$//; return $ans; }DBD-Sybase-1.24/dbdimp.c0000644000175000017500000056071014577756303015144 0ustar mpepplermpeppler/* Copyright (c) 1997-2023 Michael Peppler You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. Based on DBD::Oracle dbdimp.c, Copyright (c) 1994,1995 Tim Bunce */ #include "Sybase.h" /* Defines needed for perl 5.005 / threading */ #if defined(op) #undef op #endif #if !defined(PATCHLEVEL) #include "patchlevel.h" /* this is the perl patchlevel.h */ #endif #if PATCHLEVEL < 5 && SUBVERSION < 5 #define PL_na na #define PL_sv_undef sv_undef #define PL_dirty dirty #endif #ifndef PerlIO # define PerlIO FILE # define PerlIO_printf fprintf # define PerlIO_stderr() stderr # define PerlIO_close(f) fclose(f) # define PerlIO_open(f,m) fopen(f,m) # define PerlIO_flush(f) fflush(f) # define PerlIO_puts(f,s) fputs(s,f) #endif /* Requested by Alex Fridman */ #ifdef WIN32 # define strncasecmp _strnicmp #endif /*#define NO_CHAINED_TRAN 1*/ #if !defined(NO_CHAINED_TRAN) #define NO_CHAINED_TRAN 0 #endif /* some systems have trouble with ct_cancel(). If FLUSH_FINISH is 1 then the default behavior is to fetch all results from the server when $sth->finish() is called instead of the normal ct_cancel(CS_CANCEL_ALL) call. */ #if !defined(FLUSH_FINISH) #define FLUSH_FINISH 0 #endif #if !defined(PROC_STATUS) #define PROC_STATUS 0 #endif /* in versions up to 1.17 we always issue a ROLLBACK TRAN on disconnect With Sybase this is fine as a ROLLBACK with no corresponding BEGIN TRAN is a no-op. But this generates an error message with MS-SQL. So we now skip this, as any active transaction will in any case be rolled back if the conection is closed. */ #if !defined(ROLLBACK_ON_EXIT) #define ROLLBACK_ON_EXIT 0 #endif /* * In DBD::Sybase 1.09 and before, certain large numeric types (money, bigint) * were being kept in native format, and then returned to the caller as a perl NV * data item. An NV is really a float, so there was loss of precision, especially for bigint * data which is a 64bit int. * In 1.10 these datatypes behave the same way as numeric/decimal - converted to a char string * and returned that way to the caller, who can then use Math::BigInt, etc. * If you want to revert to the previous behavior, you need to define SYB_NATIVE_NUM. * * #define SYB_NATIVE_NUM */ /* FreeTDS doesn't always define these symbols */ #if defined(CS_VERSION_110) #if !defined BLK_VERSION_110 #define BLK_VERSION_110 BLK_VERSION_100 #endif #endif #if defined(CS_VERSION_120) #if !defined BLK_VERSION_120 #define BLK_VERSION_120 BLK_VERSION_110 #endif #endif #if defined(CS_VERSION_125) #if !defined BLK_VERSION_125 #define BLK_VERSION_125 BLK_VERSION_120 #endif #endif #if defined(CS_VERSION_150) #if !defined BLK_VERSION_150 #define BLK_VERSION_150 BLK_VERSION_125 #endif #endif #if defined(CS_VERSION_155) #if !defined BLK_VERSION_155 #define BLK_VERSION_155 BLK_VERSION_150 #endif #endif #if defined(CS_VERSION_157) #if !defined BLK_VERSION_157 #define BLK_VERSION_157 BLK_VERSION_155 #endif #endif #if !defined(CS_LONGCHAR_TYPE) #define CS_LONGCHAR_TYPE CS_CHAR_TYPE #endif DBISTATE_DECLARE; static void cleanUp _((imp_dbh_t *, imp_sth_t *)); static char *GetAggOp _((CS_INT)); static CS_INT get_cwidth _((CS_DATAFMT *)); static CS_INT display_dlen _((CS_DATAFMT *)); static CS_RETCODE display_header _((imp_dbh_t *, CS_INT, CS_DATAFMT*)); static CS_RETCODE describe _((SV *sth, imp_sth_t *, int)); static CS_RETCODE fetch_data _((imp_dbh_t *, CS_COMMAND*)); static CS_RETCODE CS_PUBLIC clientmsg_cb _((CS_CONTEXT*, CS_CONNECTION*, CS_CLIENTMSG*)); static CS_RETCODE CS_PUBLIC servermsg_cb _((CS_CONTEXT*, CS_CONNECTION*, CS_SERVERMSG*)); static CS_RETCODE CS_PUBLIC cslibmsg_cb(CS_CONTEXT *context, CS_CLIENTMSG *errmsg); static CS_COMMAND *syb_alloc_cmd _((imp_dbh_t *, CS_CONNECTION*, int mode)); static void dealloc_dynamic _((imp_sth_t *)); static int map_syb_types _((int)); static int map_sql_types _((int)); static CS_CONNECTION *syb_db_connect _((struct imp_dbh_st *)); static int syb_db_use _((imp_dbh_t *, CS_CONNECTION *)); static int syb_st_describe_proc _((SV *sth, imp_sth_t *, char *)); static void syb_set_error(imp_dbh_t *, int, char *); static char *my_strdup _((char *)); static void fetchKerbTicket(imp_dbh_t *imp_dbh); static CS_RETCODE syb_blk_init(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth); static void blkCleanUp(imp_sth_t *imp_sth, imp_dbh_t *imp_dbh); static int getTableName(char *statement, char *table, int maxwidth); static int toggle_autocommit(SV *dbh, imp_dbh_t *imp_dbh, int flag); static int datetime2str(ColData *colData, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale); #if defined(CS_DATE_TYPE) static int date2str(CS_DATE *d, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale); static int time2str(ColData *colData, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale); #endif static int syb_get_date_fmt(imp_dbh_t *imp_dbh, char *fmt); static int cmd_execute(SV *sth, imp_sth_t *imp_sth); #if defined(DBD_CAN_HANDLE_UTF8) static int is_high_bit_set(const unsigned char *val, STRLEN size); #endif static CS_BINARY *to_binary(char *str, STRLEN *outlen); static int get_server_version(SV *dbh, imp_dbh_t *imp_dbh, CS_CONNECTION *con); static void clear_cache(SV *sth, imp_sth_t *imp_sth); static int _dbd_rebind_ph(SV *sth, imp_sth_t *imp_sth, phs_t *phs, int maxlen); static CS_RETCODE get_cs_msg(CS_CONTEXT *context, char *msg, SV *sth, imp_sth_t *imp_sth); static CS_INT BLK_VERSION; #if PERL_VERSION >= 8 && defined(_REENTRANT) static perl_mutex context_alloc_mutex[1]; #endif /*#define USE_CSLIB_CB 1 */ static CS_CONTEXT *context; static CS_LOCALE *glocale; static char scriptName[255]; static char hostname[255]; static char *ocVersion; #define LOCALE(s) ((s)->locale ? (s)->locale : glocale) static SV *cslib_cb; static int syb_set_options(imp_dbh_t *imp_dbh, CS_INT action, CS_INT option, CS_VOID *value, CS_INT len, CS_INT *outlen) { if (DBIc_DBISTATE(imp_dbh)->debug >= 5) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_set_options: optSupported = %d\n", imp_dbh->optSupported); } if (!imp_dbh->optSupported) { return CS_FAIL; } return ct_options(imp_dbh->connection, action, option, value, len, outlen); } static void syb_set_error(imp_dbh_t *imp_dbh, int err, char *errstr) { dTHX; sv_setiv(DBIc_ERR(imp_dbh), err); if (SvOK(DBIc_ERRSTR(imp_dbh))) { sv_catpv(DBIc_ERRSTR(imp_dbh), errstr); } else { sv_setpv(DBIc_ERRSTR(imp_dbh), errstr); } } static CS_RETCODE CS_PUBLIC cslibmsg_cb(CS_CONTEXT *context, CS_CLIENTMSG *errmsg) { dTHX; #if 0 if(DBIS->debug >= 4) { PerlIO_printf(DBILOGFP, " cslibmsg_cb -> %s\n", errmsg->msgstring); if (errmsg->osstringlen> 0) { PerlIO_printf(DBILOGFP, " cslibmsg_cb -> %s\n", errmsg->osstring); } } #endif if (cslib_cb) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSViv(CS_LAYER(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_ORIGIN(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_SEVERITY(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_NUMBER(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSVpv(errmsg->msgstring, 0))); if (errmsg->osstringlen > 0) { XPUSHs(sv_2mortal(newSVpv(errmsg->osstring, 0))); } else { XPUSHs(&PL_sv_undef); } PUTBACK; if ((count = perl_call_sv(cslib_cb, G_SCALAR)) != 1) { croak("A cslib handler cannot return a LIST"); } SPAGAIN; retval = POPi; PUTBACK; FREETMPS; LEAVE; return retval; } PerlIO_printf(PerlIO_stderr(), "\nCS Library Message:\n"); PerlIO_printf(PerlIO_stderr(), "Message number: LAYER = (%d) ORIGIN = (%d) ", CS_LAYER(errmsg->msgnumber), CS_ORIGIN(errmsg->msgnumber)); PerlIO_printf(PerlIO_stderr(), "SEVERITY = (%d) NUMBER = (%d)\n", CS_SEVERITY(errmsg->msgnumber), CS_NUMBER(errmsg->msgnumber)); PerlIO_printf(PerlIO_stderr(), "Message String: %s\n", errmsg->msgstring); if (errmsg->osstringlen > 0) { PerlIO_printf(PerlIO_stderr(), "Operating System Error: %s\n", errmsg->osstring); } return CS_SUCCEED; } static CS_RETCODE CS_PUBLIC clientmsg_cb(CS_CONTEXT *context, CS_CONNECTION *connection, CS_CLIENTMSG *errmsg) { dTHX; imp_dbh_t *imp_dbh = NULL; char buff[255]; if (connection) { if ((ct_con_props(connection, CS_GET, CS_USERDATA, &imp_dbh, CS_SIZEOF(imp_dbh), NULL)) != CS_SUCCEED) { croak("Panic: clientmsg_cb: Can't find handle from connection"); } if(DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " clientmsg_cb -> %s\n", errmsg->msgstring); if (errmsg->osstringlen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " clientmsg_cb -> %s\n", errmsg->osstring); } } /* if LongTruncOK is set then ignore this error. */ if(DBIc_is(imp_dbh, DBIcf_LongTruncOk) && CS_NUMBER(errmsg->msgnumber) == 132) { return CS_SUCCEED; } if(imp_dbh->err_handler) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSViv(CS_NUMBER(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_SEVERITY(errmsg->msgnumber)))); XPUSHs(sv_2mortal(newSViv(0))); XPUSHs(sv_2mortal(newSViv(0))); XPUSHs(&PL_sv_undef); XPUSHs(&PL_sv_undef); XPUSHs(sv_2mortal(newSVpv(errmsg->msgstring, 0))); if(imp_dbh->sql) { XPUSHs(sv_2mortal(newSVpv(imp_dbh->sql, 0))); } else { XPUSHs(&PL_sv_undef); } XPUSHs(sv_2mortal(newSVpv("client", 0))); PUTBACK; if((count = perl_call_sv(imp_dbh->err_handler, G_SCALAR | G_EVAL)) != 1) { croak("An error handler can't return a LIST."); } SPAGAIN; if(SvTRUE(ERRSV)) { POPs; retval = 1; } else { retval = POPi; } PUTBACK; FREETMPS; LEAVE; /* If the called sub returns 0 then ignore this error */ if(retval == 0) { return CS_SUCCEED; } } sv_setiv(DBIc_ERR(imp_dbh), (IV)CS_NUMBER(errmsg->msgnumber)); if(SvOK(DBIc_ERRSTR(imp_dbh))) { sv_catpv(DBIc_ERRSTR(imp_dbh), "OpenClient message: "); } else { sv_setpv(DBIc_ERRSTR(imp_dbh), "OpenClient message: "); } sprintf(buff, "LAYER = (%d) ORIGIN = (%d) ", CS_LAYER(errmsg->msgnumber), CS_ORIGIN(errmsg->msgnumber)); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); sprintf(buff, "SEVERITY = (%d) NUMBER = (%d)\n", CS_SEVERITY(errmsg->msgnumber), CS_NUMBER(errmsg->msgnumber)); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); sprintf(buff, "Server %s, database %s\n", imp_dbh->server, imp_dbh->curr_db); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); sv_catpv(DBIc_ERRSTR(imp_dbh), "Message String: "); sv_catpv(DBIc_ERRSTR(imp_dbh), errmsg->msgstring); sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); if (errmsg->osstringlen> 0) { sv_catpv(DBIc_ERRSTR(imp_dbh), "Operating System Error: "); sv_catpv(DBIc_ERRSTR(imp_dbh), errmsg->osstring); sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); } if(CS_NUMBER(errmsg->msgnumber) == 6) { /* disconnect */ imp_dbh->isDead = 1; } /* If this is a timeout message, cancel the current request. If the cancel fails, then return CS_FAIL, and mark the connection dead. Do NOT return CS_FAIL in all cases, as this makes the connection unusable, and that may not be the correct behavior in all situations. */ if (CS_SEVERITY(errmsg->msgnumber) == CS_SV_RETRY_FAIL && CS_NUMBER(errmsg->msgnumber) == 63 && CS_ORIGIN(errmsg->msgnumber) == 2 && CS_LAYER(errmsg->msgnumber) == 1) { CS_INT status; status = 0; if (ct_con_props(connection, CS_GET, CS_LOGIN_STATUS, (CS_VOID *)&status, CS_UNUSED, NULL) != CS_SUCCEED) { imp_dbh->isDead = 1; return CS_FAIL; } if (!status) { /* We're not logged in, so just return CS_FAIL to abort the login request */ imp_dbh->isDead = 1; return CS_FAIL; } if(ct_cancel(connection, NULL, CS_CANCEL_ATTN) == CS_FAIL) { imp_dbh->isDead = 1; return CS_FAIL; } return CS_SUCCEED; } } else { /* !connection */ PerlIO_printf(PerlIO_stderr(), "OpenClient message: "); PerlIO_printf(PerlIO_stderr(), "LAYER = (%d) ORIGIN = (%d) ", CS_LAYER(errmsg->msgnumber), CS_ORIGIN(errmsg->msgnumber)); PerlIO_printf(PerlIO_stderr(), "SEVERITY = (%d) NUMBER = (%d)\n", CS_SEVERITY(errmsg->msgnumber), CS_NUMBER(errmsg->msgnumber)); PerlIO_printf(PerlIO_stderr(), "Message String: %s\n", errmsg->msgstring); if (errmsg->osstringlen> 0) { PerlIO_printf(PerlIO_stderr(), "Operating System Error: %s\n", errmsg->osstring); } } return CS_SUCCEED; } static CS_RETCODE CS_PUBLIC servermsg_cb(CS_CONTEXT *context, CS_CONNECTION *connection, CS_SERVERMSG *srvmsg) { CS_COMMAND *cmd; CS_RETCODE retcode; imp_dbh_t *imp_dbh = NULL; char buff[1024]; dTHX; /* add check on connection not being NULL (PR/477) just to be on the safe side - freetds can call the server callback with a NULL connection */ if (connection && (ct_con_props(connection, CS_GET, CS_USERDATA, &imp_dbh, CS_SIZEOF(imp_dbh), NULL)) != CS_SUCCEED) { croak("Panic: servermsg_cb: Can't find handle from connection"); } if(imp_dbh && DBIc_DBISTATE(imp_dbh)->debug >= 4) { if(srvmsg->msgnumber) { PerlIO_printf(DBIc_LOGPIO(imp_dbh)," servermsg_cb -> number=%d severity=%d ", srvmsg->msgnumber, srvmsg->severity); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "state=%d line=%d ", srvmsg->state, srvmsg->line); if (srvmsg->svrnlen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "server=%s ", srvmsg->svrname); } if (srvmsg->proclen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "procedure=%s ", srvmsg->proc); } PerlIO_printf(DBIc_LOGPIO(imp_dbh), "text=%s\n", srvmsg->text); } else { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " servermsg_cb -> %s\n", srvmsg->text); } } /* Track the "current" database */ /* Borrowed from sqsh's cmd_connect.c */ if(srvmsg->msgnumber == 5701 || srvmsg->msgnumber == 5703 || srvmsg->msgnumber == 5704) { char *c; int i; if(srvmsg->text != NULL && (c = strchr( srvmsg->text, '\'' )) != NULL) { i = 0; /* XXX This assumes that the DB name is 30 chars or less. */ for( ++c; i <= 30 && *c != '\0' && *c != '\''; ++c ) { buff[i++] = *c; } buff[i] = '\0'; /* * On some systems, if the charset is mis-configured in the * SQL Server, it will come back as the string "". If * this is the case, then we want to ignore this value. */ if (strcmp( buff, "" ) != 0) { switch (srvmsg->msgnumber) { case 5701: if(imp_dbh && DBIc_ACTIVE(imp_dbh) && imp_dbh->connection == connection) { strcpy(imp_dbh->curr_db, buff); } break; case 5703: /* Language */ break; case 5704: /* charset */ break; default: break; } } } return CS_SUCCEED; } /* Trap msg 17001 (No SRV_OPTION handler installed.) */ if(imp_dbh && srvmsg->msgnumber == 17001) { imp_dbh->optSupported = 0; if(DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " servermsg_cb() -> ct_option is %ssupported\n", imp_dbh->optSupported == 1 ?"":"not "); } } if(imp_dbh && imp_dbh->err_handler) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSViv(srvmsg->msgnumber))); XPUSHs(sv_2mortal(newSViv(srvmsg->severity))); XPUSHs(sv_2mortal(newSViv(srvmsg->state))); XPUSHs(sv_2mortal(newSViv(srvmsg->line))); if(srvmsg->svrnlen> 0) { XPUSHs(sv_2mortal(newSVpv(srvmsg->svrname, 0))); } else { XPUSHs(&PL_sv_undef); } if(srvmsg->proclen> 0) { XPUSHs(sv_2mortal(newSVpv(srvmsg->proc, 0))); } else { XPUSHs(&PL_sv_undef); } XPUSHs(sv_2mortal(newSVpv(srvmsg->text, 0))); if(imp_dbh->sql) { XPUSHs(sv_2mortal(newSVpv(imp_dbh->sql, 0))); } else { XPUSHs(&PL_sv_undef); } XPUSHs(sv_2mortal(newSVpv("server", 0))); PUTBACK; if((count = perl_call_sv(imp_dbh->err_handler, G_SCALAR | G_EVAL)) != 1) { croak("An error handler can't return a LIST."); } SPAGAIN; if(SvTRUE(ERRSV)) { POPs; retval = 1; } else { retval = POPi; } PUTBACK; FREETMPS; LEAVE; /* If the called sub returns 0 then ignore this error */ if(retval == 0) { return CS_SUCCEED; } } if(imp_dbh && srvmsg->msgnumber) { /* error 5702 (severity=10 state=1 text=ASE is terminating this process) * may be delivered only via servermsg_cb. If we don't deal with it here * the command can appear to complete successfully. errstr will contain * the error message but err will be false. */ if(srvmsg->severity > 10 || srvmsg->msgnumber == 5702) { sv_setiv(DBIc_ERR(imp_dbh), (IV)srvmsg->msgnumber); imp_dbh->lasterr = srvmsg->msgnumber; imp_dbh->lastsev = srvmsg->severity; if (srvmsg->msgnumber == 5702) { ct_close(connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } } if(SvOK(DBIc_ERRSTR(imp_dbh))) { sv_catpv(DBIc_ERRSTR(imp_dbh), "Server message "); } else { sv_setpv(DBIc_ERRSTR(imp_dbh), "Server message "); } sprintf(buff, "number=%d severity=%d ", srvmsg->msgnumber, srvmsg->severity); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); sprintf(buff, "state=%d line=%d", srvmsg->state, srvmsg->line); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); if (srvmsg->svrnlen> 0) { sv_catpv(DBIc_ERRSTR(imp_dbh), " server="); sv_catpv(DBIc_ERRSTR(imp_dbh), srvmsg->svrname); } if (srvmsg->proclen> 0) { sv_catpv(DBIc_ERRSTR(imp_dbh), " procedure="); sv_catpv(DBIc_ERRSTR(imp_dbh), srvmsg->proc); } sv_catpv(DBIc_ERRSTR(imp_dbh), " text="); sv_catpv(DBIc_ERRSTR(imp_dbh), srvmsg->text); if(imp_dbh->showSql) { sv_catpv(DBIc_ERRSTR(imp_dbh), " Statement="); sv_catpv(DBIc_ERRSTR(imp_dbh), imp_dbh->sql); } if (imp_dbh->showEed && srvmsg->status & CS_HASEED) { sv_catpv(DBIc_ERRSTR(imp_dbh), "\n[Start Extended Error]\n"); if (ct_con_props(connection, CS_GET, CS_EED_CMD, &cmd, CS_UNUSED, NULL) != CS_SUCCEED) { warn("servermsg_cb: ct_con_props(CS_EED_CMD) failed"); return CS_FAIL; } retcode = fetch_data(imp_dbh, cmd); sv_catpv(DBIc_ERRSTR(imp_dbh), "\n[End Extended Error]\n"); } else { retcode = CS_SUCCEED; } sv_catpv(DBIc_ERRSTR(imp_dbh), " "); return retcode; } else { if(srvmsg->msgnumber) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "Server message: number=%d severity=%d ", srvmsg->msgnumber, srvmsg->severity); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "state=%d line=%d ", srvmsg->state, srvmsg->line); if (srvmsg->svrnlen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "server=%s ", srvmsg->svrname); } if (srvmsg->proclen> 0) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "procedure=%s ", srvmsg->proc); } PerlIO_printf(DBIc_LOGPIO(imp_dbh), "text=%s\n", srvmsg->text); } else { warn("%s\n", srvmsg->text); } PerlIO_flush(DBIc_LOGPIO(imp_dbh)); } return CS_SUCCEED; } static CS_CHAR * GetAggOp(CS_INT op) { CS_CHAR *name; switch ((int) op) { case CS_OP_SUM: name = "sum"; break; case CS_OP_AVG: name = "avg"; break; case CS_OP_COUNT: name = "count"; break; case CS_OP_MIN: name = "min"; break; case CS_OP_MAX: name = "max"; break; default: name = "unknown"; break; } return name; } static CS_INT get_cwidth(CS_DATAFMT *column) { CS_INT len; switch ((int) column->datatype) { case CS_CHAR_TYPE: case CS_LONGCHAR_TYPE: case CS_VARCHAR_TYPE: case CS_TEXT_TYPE: case CS_IMAGE_TYPE: len = column->maxlength; break; case CS_BINARY_TYPE: case CS_VARBINARY_TYPE: case CS_LONGBINARY_TYPE: #if defined(CS_UNICHAR_TYPE) case CS_UNICHAR_TYPE: case CS_UNITEXT_TYPE: #endif len = (2 * column->maxlength) + 2; break; case CS_BIT_TYPE: case CS_TINYINT_TYPE: len = 3; break; case CS_SMALLINT_TYPE: #if defined(CS_USMALLINT_TYPE) case CS_USMALLINT_TYPE: #endif len = 6; break; case CS_INT_TYPE: #if defined(CS_UINT_TYPE) case CS_UINT_TYPE: #endif len = 11; break; #if defined(CS_BIGINT_TYPE) case CS_BIGINT_TYPE: case CS_UBIGINT_TYPE: len = 22; #endif case CS_REAL_TYPE: case CS_FLOAT_TYPE: len = 20; break; case CS_MONEY_TYPE: case CS_MONEY4_TYPE: len = 24; break; case CS_DATETIME_TYPE: case CS_DATETIME4_TYPE: #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: case CS_TIME_TYPE: #endif #if defined(CS_BIGDATETIME_TYPE) case CS_BIGDATETIME_TYPE: case CS_BIGTIME_TYPE: #endif len = 40; break; #if 1 // According to Sebastien Pardo (https://github.com/mpeppler/DBD-Sybase/issues/48) // The following is needed to handle very large CS_NUMERIC values. // This code was removed between 1.09 and 1.15. I'm re-enabling it as this appears to // only affect the binding of numeric data types in row fetches, and column displays in // the error handler, which shouldn't really be an issue. case CS_NUMERIC_TYPE: case CS_DECIMAL_TYPE: // CS_MAX_PREC is 77 (theoretical max precision) - using the precision/scale of the result set // seems more appropriate. //len = (CS_MAX_PREC + 2); len = column->precision + column->scale + 2; break; #endif #ifdef CS_UNIQUE_TYPE case CS_UNIQUE_TYPE: len = 40; break; #endif default: len = column->maxlength; break; } return len; } static CS_INT display_dlen(CS_DATAFMT *column) { CS_INT len; len = get_cwidth(column); switch ((int) column->datatype) { case CS_CHAR_TYPE: case CS_LONGCHAR_TYPE: case CS_VARCHAR_TYPE: case CS_TEXT_TYPE: case CS_IMAGE_TYPE: case CS_BINARY_TYPE: case CS_VARBINARY_TYPE: len = MIN(len, MAX_CHAR_BUF); break; default: break; } return MAX(strlen(column->name) + 1, len); } static CS_RETCODE display_header(imp_dbh_t *imp_dbh, CS_INT numcols, CS_DATAFMT *columns) { dTHX; CS_INT i; CS_INT l; CS_INT j; CS_INT disp_len; sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); for (i = 0; i < numcols; i++) { disp_len = display_dlen(&columns[i]); sv_catpv(DBIc_ERRSTR(imp_dbh), columns[i].name); l = disp_len - strlen(columns[i].name); for (j = 0; j < l; j++) { sv_catpv(DBIc_ERRSTR(imp_dbh), " "); } } sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); for (i = 0; i < numcols; i++) { disp_len = display_dlen(&columns[i]); l = disp_len - 1; for (j = 0; j < l; j++) { sv_catpv(DBIc_ERRSTR(imp_dbh), "-"); } sv_catpv(DBIc_ERRSTR(imp_dbh), " "); } sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); return CS_SUCCEED; } void syb_init(dbistate_t *dbistate) { dTHX; SV *sv; CS_INT netio_type = CS_SYNC_IO; STRLEN lna; CS_INT outlen; CS_RETCODE retcode = CS_FAIL; CS_INT cs_ver; CS_INT boolean = CS_FALSE; DBIS = dbistate; #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_INIT (context_alloc_mutex); #endif #if 0 /* Do signal handling stuff... */ /* Set up signal set with just SIGUSR1. */ sigemptyset(&set); sigaddset(&set, SIGINT); /* Block SIGINT */ sigprocmask(SIG_BLOCK, &set, NULL); #endif #if defined(CS_CURRENT_VERSION) if (retcode != CS_SUCCEED) { cs_ver = CS_CURRENT_VERSION; retcode = cs_ctx_alloc(cs_ver, &context); } #endif #if defined(CS_VERSION_150) if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_150; retcode = cs_ctx_alloc(cs_ver, &context); } #endif #if defined(CS_VERSION_125) if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_125; retcode = cs_ctx_alloc(cs_ver, &context); } #endif #if defined(CS_VERSION_120) if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_120; retcode = cs_ctx_alloc(cs_ver, &context); } #endif #if defined(CS_VERSION_110) if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_110; retcode = cs_ctx_alloc(cs_ver, &context); } #endif if (retcode != CS_SUCCEED) { cs_ver = CS_VERSION_100; retcode = cs_ctx_alloc(cs_ver, &context); } if (retcode != CS_SUCCEED) { croak("DBD::Sybase initialize: cs_ctx_alloc(%d) failed", cs_ver); } #if defined(CS_CURRENT_VERSION) if (cs_ver = CS_CURRENT_VERSION) { BLK_VERSION = CS_CURRENT_VERSION; } #endif #if defined(CS_VERSION_150) if (cs_ver == CS_VERSION_150) { BLK_VERSION = BLK_VERSION_150; } #endif #if defined(CS_VERSION_125) if (cs_ver == CS_VERSION_125) { BLK_VERSION = BLK_VERSION_125; } #endif #if defined(CS_VERSION_120) if (cs_ver == CS_VERSION_120) { BLK_VERSION = BLK_VERSION_120; } #endif #if defined(CS_VERSION_110) if (cs_ver == CS_VERSION_110) { BLK_VERSION = BLK_VERSION_110; } #endif if (cs_ver == CS_VERSION_100) { BLK_VERSION = BLK_VERSION_100; } #if USE_CSLIB_CB if (cs_config(context, CS_SET, CS_MESSAGE_CB, (CS_VOID *)cslibmsg_cb, CS_UNUSED, NULL) != CS_SUCCEED) { /* Release the context structure. */ (void)cs_ctx_drop(context); croak("DBD::Sybase initialize: cs_config(CS_MESSAGE_CB) failed"); } #else if (cs_diag(context, CS_INIT, CS_UNUSED, CS_UNUSED, NULL) != CS_SUCCEED) { warn("cs_diag(CS_INIT) failed"); } #endif #if defined(CS_EXTERNAL_CONFIG) if (cs_config(context, CS_SET, CS_EXTERNAL_CONFIG, &boolean, CS_UNUSED, NULL) != CS_SUCCEED) { /* Ignore this error... */ /* warn("Can't set CS_EXTERNAL_CONFIG to false"); */ } #endif if ((retcode = ct_init(context, cs_ver)) != CS_SUCCEED) { #if 1 cs_ctx_drop(context); #endif context = NULL; croak("DBD::Sybase initialize: ct_init(%d) failed", cs_ver); } if ((retcode = ct_callback(context, NULL, CS_SET, CS_CLIENTMSG_CB, (CS_VOID *) clientmsg_cb)) != CS_SUCCEED) { croak("DBD::Sybase initialize: ct_callback(clientmsg) failed"); } if ((retcode = ct_callback(context, NULL, CS_SET, CS_SERVERMSG_CB, (CS_VOID *) servermsg_cb)) != CS_SUCCEED) { croak("DBD::Sybase initialize: ct_callback(servermsg) failed"); } if ((retcode = ct_config(context, CS_SET, CS_NETIO, &netio_type, CS_UNUSED, NULL)) != CS_SUCCEED) { croak("DBD::Sybase initialize: ct_config(netio) failed"); } #if defined(MAX_CONNECT) netio_type = MAX_CONNECT; if((retcode = ct_config(context, CS_SET, CS_MAX_CONNECT, &netio_type, CS_UNUSED, NULL)) != CS_SUCCEED) { croak("DBD::Sybase initialize: ct_config(max_connect) failed"); } #endif { char out[1024], *p; retcode = ct_config(context, CS_GET, CS_VER_STRING, (CS_VOID*) out, 1024, &outlen); if ((p = strchr(out, '\n'))) *p = 0; ocVersion = my_strdup(out); } if ((sv = perl_get_sv("0", FALSE))) { char *p; strcpy(scriptName, SvPV(sv, lna)); if ((p = strrchr(scriptName, '/'))) { char tmp[255]; ++p; strncpy(tmp, p, 250); strcpy(scriptName, tmp); } /* PR 506 */ if (!strcmp(scriptName, "-e")) { strcpy(scriptName, "perl -e"); } } /* PR 506 - get hostname */ if ((sv = perl_get_sv("DBD::Sybase::hostname", FALSE))) { strcpy(hostname, SvPV(sv, lna)); /*fprintf(stderr, "Got hostname: %s\n", hostname);*/ } if (dbistate->debug >= 3) { char *p = ""; if ((sv = perl_get_sv("DBD::Sybase::VERSION", FALSE))) { p = SvPV(sv, lna); } PerlIO_printf(dbistate->logfp, " syb_init() -> DBD::Sybase %s initialized\n", p); PerlIO_printf(dbistate->logfp, " OpenClient version: %s\n", ocVersion); } if ((retcode = cs_loc_alloc(context, &glocale)) != CS_SUCCEED) { warn("cs_loc_alloc failed"); } if (retcode == CS_SUCCEED) { if ((retcode = cs_locale(context, CS_SET, glocale, CS_LC_ALL, (CS_CHAR*) NULL, CS_UNUSED, (CS_INT*) NULL)) != CS_SUCCEED) { warn("cs_locale(CS_LC_ALL) failed"); } } /* Set default charset to utf8. The charset can still be overridden * via the charset=xxxx connection attribute. */ /* if (retcode == CS_SUCCEED) { if ((retcode = cs_locale(context, CS_SET, locale, CS_SYB_CHARSET, "utf8", CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("cs_locale(CS_SYB_CHARSET) failed"); } }*/ if (retcode == CS_SUCCEED) { CS_INT type = CS_DATES_SHORT; if ((retcode = cs_dt_info(context, CS_SET, glocale, CS_DT_CONVFMT, CS_UNUSED, (CS_VOID*) &type, CS_SIZEOF(CS_INT), NULL)) != CS_SUCCEED) { warn("cs_dt_info() failed"); } } if (retcode == CS_SUCCEED) { if ((retcode = cs_config(context, CS_SET, CS_LOC_PROP, glocale, CS_UNUSED, NULL)) != CS_SUCCEED) { // Ignored for now. /* warn("cs_config(CS_LOC_PROP) failed"); */ } } } int syb_thread_enabled(void) { int retcode = 0; #if PERL_VERSION >= 8 && defined(_REENTRANT) && !defined(NO_THREADS) retcode = 1; #endif return retcode; } int syb_set_timeout(int timeout) { dTHX; CS_RETCODE retcode; if (timeout <= 0) { timeout = CS_NO_LIMIT; /* set negative or 0 length timeout to default no limit */ } /* XXX: DBIS and DBILOGFP need to be fixed */ if (DBIS->debug >= 3) { PerlIO_printf(DBILOGFP, " syb_set_timeout() -> ct_config(CS_TIMEOUT,%d)\n", timeout); } #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_LOCK (context_alloc_mutex); #endif if ((retcode = ct_config(context, CS_SET, CS_TIMEOUT, &timeout, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("ct_config(CS_SET, CS_TIMEOUT) failed"); } #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_UNLOCK (context_alloc_mutex); #endif return retcode; } static int extractFromDsn(char *tag, char *source, char *dest, int size) { char *p = strstr(source, tag); char *q = dest; if (!p) { return 0; } p += strlen(tag); while (p && *p && *p != ';' && --size) { *q++ = *p++; } *q = 0; return 1; } static int fetchAttrib(SV *attribs, char *key) { dTHX; if (attribs) { SV **svp; if ((svp = hv_fetch((HV*) SvRV(attribs), key, strlen(key), 0)) != NULL) { return SvIV(*svp); } } return 0; } static SV * fetchSvAttrib(SV *attribs, char *key) { dTHX; if (attribs) { SV **svp; if ((svp = hv_fetch((HV*) SvRV(attribs), key, strlen(key), 0)) != NULL) { return newSVsv(*svp); } } return NULL; } /* side-effect: sets the BCP related flags in imp_sth */ static void getBcpAttribs(imp_sth_t *imp_sth, SV *attribs) { dTHX; SV **svp; #define BCP_ATTRIB "syb_bcp_attribs" if (!attribs || !SvOK(attribs)) { return; } if ((svp = hv_fetch((HV*) SvRV(attribs), BCP_ATTRIB, strlen(BCP_ATTRIB), 0)) != NULL) { imp_sth->bcpFlag = 1; imp_sth->bcpIdentityFlag = fetchAttrib(*svp, "identity_flag"); imp_sth->bcpIdentityCol = fetchAttrib(*svp, "identity_column"); } } int syb_db_login(SV *dbh, imp_dbh_t *imp_dbh, char *dsn, char *uid, char *pwd, SV *attribs) { dTHX; int retval; imp_dbh->server[0] = 0; imp_dbh->charset[0] = 0; imp_dbh->packetSize[0] = 0; imp_dbh->language[0] = 0; imp_dbh->ifile[0] = 0; imp_dbh->loginTimeout[0] = 0; imp_dbh->timeout[0] = 0; imp_dbh->hostname[0] = 0; imp_dbh->scriptName[0] = 0; imp_dbh->database[0] = 0; imp_dbh->curr_db[0] = 0; imp_dbh->encryptPassword[0] = 0; imp_dbh->showSql = 0; imp_dbh->showEed = 0; imp_dbh->flushFinish = FLUSH_FINISH; imp_dbh->doRealTran = NO_CHAINED_TRAN; /* default to use chained transaction mode */ imp_dbh->chainedSupported = 1; imp_dbh->quotedIdentifier = 0; imp_dbh->rowcount = 0; imp_dbh->doProcStatus = PROC_STATUS; imp_dbh->useBin0x = 0; imp_dbh->binaryImage = 0; imp_dbh->deadlockRetry = 0; imp_dbh->deadlockSleep = 0; imp_dbh->deadlockVerbose = 0; imp_dbh->nsqlNoStatus = 0; imp_dbh->noChildCon = 0; imp_dbh->failedDbUseFatal = fetchAttrib(attribs, "syb_failed_db_fatal"); imp_dbh->bindEmptyStringNull = fetchAttrib(attribs, "syb_bind_empty_string_as_null"); imp_dbh->err_handler = fetchSvAttrib(attribs, "syb_err_handler"); imp_dbh->alwaysForceFailure = 1; imp_dbh->kerberosPrincipal[0] = 0; imp_dbh->kerbGetTicket = fetchSvAttrib(attribs, "syb_kerberos_serverprincipal"); imp_dbh->disconnectInChild = fetchAttrib(attribs, "syb_disconnect_in_child"); imp_dbh->host[0] = 0; imp_dbh->port[0] = 0; imp_dbh->enable_utf8 = fetchAttrib(attribs, "syb_enable_utf8"); #if !defined(DBD_CAN_HANDLE_UTF8) if (imp_dbh->enable_utf8) { warn("The current version of OpenClient can't handle utf8 data."); } imp_dbh->enable_utf8 = 0; #endif imp_dbh->blkLogin[0] = 0; imp_dbh->dateFmt = 0; imp_dbh->inUse = 0; imp_dbh->init_done = 0; if (strchr(dsn, '=')) { extractFromDsn("server=", dsn, imp_dbh->server, 64); extractFromDsn("charset=", dsn, imp_dbh->charset, 64); extractFromDsn("database=", dsn, imp_dbh->database, 260); extractFromDsn("packetSize=", dsn, imp_dbh->packetSize, 64); extractFromDsn("language=", dsn, imp_dbh->language, 64); extractFromDsn("interfaces=", dsn, imp_dbh->ifile, 255); extractFromDsn("loginTimeout=", dsn, imp_dbh->loginTimeout, 64); extractFromDsn("timeout=", dsn, imp_dbh->timeout, 64); extractFromDsn("scriptName=", dsn, imp_dbh->scriptName, 255); extractFromDsn("hostname=", dsn, imp_dbh->hostname, 255); extractFromDsn("tdsLevel=", dsn, imp_dbh->tdsLevel, 30); extractFromDsn("encryptPassword=", dsn, imp_dbh->encryptPassword, 10); extractFromDsn("kerberos=", dsn, imp_dbh->kerberosPrincipal, 255); extractFromDsn("host=", dsn, imp_dbh->host, 64); extractFromDsn("port=", dsn, imp_dbh->port, 20); extractFromDsn("maxConnect=", dsn, imp_dbh->maxConnect, 25); extractFromDsn("sslCAFile=", dsn, imp_dbh->sslCAFile, 255); extractFromDsn("bulkLogin=", dsn, imp_dbh->blkLogin, 10); extractFromDsn("tds_keepalive=", dsn, imp_dbh->tds_keepalive, 10); extractFromDsn("serverType=", dsn, imp_dbh->serverType, 30); } else { strncpy(imp_dbh->server, dsn, 64); imp_dbh->server[63] = 0; } strncpy(imp_dbh->uid, uid, UID_PWD_SIZE); imp_dbh->uid[UID_PWD_SIZE - 1] = 0; strncpy(imp_dbh->pwd, pwd, UID_PWD_SIZE); imp_dbh->pwd[UID_PWD_SIZE - 1] = 0; sv_setpv(DBIc_ERRSTR(imp_dbh), ""); if (imp_dbh->kerbGetTicket) { fetchKerbTicket(imp_dbh); } imp_dbh->pid = getpid(); #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_LOCK(context_alloc_mutex); #endif if ((imp_dbh->connection = syb_db_connect(imp_dbh)) == NULL) { retval = 0; } else { retval = 1; } #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_UNLOCK(context_alloc_mutex); #endif if (!retval) { return retval; } if (!imp_dbh->serverType[0] || !strncasecmp(imp_dbh->serverType, "ase", 3)) { get_server_version(dbh, imp_dbh, imp_dbh->connection); } DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */ DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing*/ DBIc_LongReadLen(imp_dbh) = 32768; return 1; } static CS_CONNECTION *syb_db_connect(imp_dbh_t *imp_dbh) { dTHR; CS_RETCODE retcode; CS_CONNECTION *connection = NULL; char ofile[255]; int len; /* Allow increase of the max number of connections - patch supplied by Ed Avis */ if (imp_dbh->maxConnect[0]) { /* Maximum number of connections. */ const char * const s = imp_dbh->maxConnect; int i; i = atoi(s); if (i < 1) { warn("maxConnect must be positive, not '%s'", s); return 0; } #if defined(CS_MAX_CONNECT) if ((retcode = ct_config(context, CS_SET, CS_MAX_CONNECT, (CS_VOID*) &i, CS_UNUSED, NULL)) != CS_SUCCEED) { croak("ct_config(max_connect) failed"); } #else warn("ct_config(max_connect) not supported"); #endif } if (imp_dbh->ifile[0]) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_config(CS_IFILE,%s)\n", imp_dbh->ifile); } if ((retcode = ct_config(context, CS_GET, CS_IFILE, ofile, 255, NULL)) != CS_SUCCEED) { warn("ct_config(CS_GET, CS_IFILE) failed"); } if (retcode == CS_SUCCEED) { if ((retcode = ct_config(context, CS_SET, CS_IFILE, imp_dbh->ifile, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_config(CS_SET, CS_IFILE, %s) failed", imp_dbh->ifile); return NULL; } } } if (imp_dbh->loginTimeout[0]) { int timeout = atoi(imp_dbh->loginTimeout); if (timeout <= 0) { timeout = 60; /* set negative or 0 length timeout to default 60 seconds */ } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh)," syb_db_login() -> ct_config(CS_LOGIN_TIMEOUT,%d)\n", timeout); } if ((retcode = ct_config(context, CS_SET, CS_LOGIN_TIMEOUT, &timeout, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("ct_config(CS_SET, CS_LOGIN_TIMEOUT) failed"); } } if (imp_dbh->timeout[0]) { int timeout = atoi(imp_dbh->timeout); if (timeout <= 0) { timeout = CS_NO_LIMIT; /* set negative or 0 length timeout to default no limit */ } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_config(CS_TIMEOUT,%d)\n", timeout); } if ((retcode = ct_config(context, CS_SET, CS_TIMEOUT, &timeout, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("ct_config(CS_SET, CS_TIMEOUT) failed"); } } if (imp_dbh->language[0] == 0 && imp_dbh->charset[0] == 0) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh)," syb_db_login() -> using global CS_LOCALE data\n"); } } else { CS_INT type = CS_DATES_SHORT; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> using private CS_LOCALE data\n"); } /* Set up the proper locale - to handle character sets, etc. */ if ((retcode = cs_loc_alloc(context, &imp_dbh->locale) != CS_SUCCEED)) { warn("cs_loc_alloc failed"); return 0; } if (cs_locale(context, CS_SET, imp_dbh->locale, CS_LC_ALL, (CS_CHAR*) NULL, CS_UNUSED, (CS_INT*) NULL) != CS_SUCCEED) { warn("cs_locale(CS_LC_ALL) failed"); return 0; } if (imp_dbh->language[0] != 0) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> cs_locale(CS_SYB_LANG,%s)\n", imp_dbh->language); } if (cs_locale(context, CS_SET, imp_dbh->locale, CS_SYB_LANG, (CS_CHAR*) imp_dbh->language, CS_NULLTERM, (CS_INT*) NULL) != CS_SUCCEED) { warn("cs_locale(CS_SYB_LANG, %s) failed", imp_dbh->language); return 0; } } if (imp_dbh->charset[0] != 0) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> cs_locale(CS_SYB_CHARSET,%s)\n", imp_dbh->charset); } if (cs_locale(context, CS_SET, imp_dbh->locale, CS_SYB_CHARSET, (CS_CHAR*) imp_dbh->charset, CS_NULLTERM, (CS_INT*) NULL) != CS_SUCCEED) { warn("cs_locale(CS_SYB_CHARSET, %s) failed", imp_dbh->charset); return 0; } } if (cs_dt_info(context, CS_SET, imp_dbh->locale, CS_DT_CONVFMT, CS_UNUSED, (CS_VOID*) &type, CS_SIZEOF(CS_INT), NULL) != CS_SUCCEED) { warn("cs_dt_info() failed"); } } #if defined(CS_CON_KEEPALIVE) if (imp_dbh->tds_keepalive[0]) { int tds_keepalive = atoi(imp_dbh->tds_keepalive); if (tds_keepalive != 1) { tds_keepalive = 0; } if(DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "syb_db_login() -> ct_config(CS_CON_KEEPALIVE,%d)\n", tds_keepalive); } if((retcode = ct_config(context, CS_SET, CS_CON_KEEPALIVE, &tds_keepalive, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("ct_config(CS_SET, CS_CON_KEEPALIVE) failed"); } } #endif if ((retcode = ct_con_alloc(context, &connection)) != CS_SUCCEED) { warn("ct_con_alloc failed"); return 0; } if (imp_dbh->locale) { if (ct_con_props(connection, CS_SET, CS_LOC_PROP, (CS_VOID*)imp_dbh->locale, CS_UNUSED, (CS_INT*)NULL) != CS_SUCCEED) { warn("ct_con_props(CS_LOC_PROP) failed"); return 0; } } if ((retcode = ct_con_props(connection, CS_SET, CS_USERDATA, &imp_dbh, CS_SIZEOF(imp_dbh), NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_USERDATA) failed"); return 0; } if (imp_dbh->tdsLevel[0] != 0) { CS_INT value = 0; if (strEQ(imp_dbh->tdsLevel, "CS_TDS_40")) { value = CS_TDS_40; } else if (strEQ(imp_dbh->tdsLevel, "CS_TDS_42")) { value = CS_TDS_42; } else if (strEQ(imp_dbh->tdsLevel, "CS_TDS_46")) { value = CS_TDS_46; } else if (strEQ(imp_dbh->tdsLevel, "CS_TDS_495")) { value = CS_TDS_495; } else if (strEQ(imp_dbh->tdsLevel, "CS_TDS_50")) { value = CS_TDS_50; } if (value) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_con_props(CS_TDS_VERSION,%s)\n", imp_dbh->tdsLevel); } if (ct_con_props(connection, CS_SET, CS_TDS_VERSION, (CS_VOID*)&value, CS_UNUSED, (CS_INT*)NULL) != CS_SUCCEED) { warn("ct_con_props(CS_TDS_VERSION, %s) failed", imp_dbh->tdsLevel); } } else { warn("Unkown tdsLevel value %s found", imp_dbh->tdsLevel); } } if (imp_dbh->packetSize[0] != 0) { int i = atoi(imp_dbh->packetSize); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_con_props(CS_PACKETSIZE,%d)\n", i); } if (ct_con_props(connection, CS_SET, CS_PACKETSIZE, (CS_VOID*)&i, CS_UNUSED, (CS_INT*)NULL) != CS_SUCCEED) { warn("ct_con_props(CS_PACKETSIZE, %d) failed", i); return 0; } } #if defined(CS_SEC_NETWORKAUTH) if(imp_dbh->kerberosPrincipal[0] == 0) { #endif if (retcode == CS_SUCCEED && *imp_dbh->uid) { if ((retcode = ct_con_props(connection, CS_SET, CS_USERNAME, imp_dbh->uid, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_USERNAME) failed"); return 0; } } if (retcode == CS_SUCCEED && *imp_dbh->pwd) { if ((retcode = ct_con_props(connection, CS_SET, CS_PASSWORD, imp_dbh->pwd, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_PASSWORD) failed"); return 0; } } #if defined(CS_SEC_NETWORKAUTH) } else { /* ** If we're using Kerberos, set the appropriate connection properties ** (which requires the Sybase Kerberos principal name). */ CS_INT i = CS_TRUE; if(DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_con_props(CS_SERVERPRINCIPAL,%s)\n", imp_dbh->kerberosPrincipal); } if ((retcode = ct_con_props(connection, CS_SET, CS_SEC_NETWORKAUTH, (CS_VOID *) &i, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SEC_NETWORKAUTH) failed"); return 0; } if ((retcode = ct_con_props(connection, CS_SET, CS_SEC_SERVERPRINCIPAL, imp_dbh->kerberosPrincipal, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SEC_SERVERPRINCIPAL) failed"); return 0; } } #endif if (retcode == CS_SUCCEED) { if ((retcode = ct_con_props(connection, CS_SET, CS_APPNAME, *imp_dbh->scriptName ? imp_dbh->scriptName : scriptName, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_APPNAME, %s) failed", imp_dbh->scriptName); return 0; } if ((retcode = ct_con_props(connection, CS_SET, CS_HOSTNAME, *imp_dbh->hostname ? imp_dbh->hostname : hostname, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_HOSTNAME, %s) failed", imp_dbh->hostname); return 0; } } if (retcode == CS_SUCCEED) { if (imp_dbh->encryptPassword[0] != 0) { int level = atoi(imp_dbh->encryptPassword); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> encryptPassword = %d\n",level); } int i = CS_TRUE; /* CS_SEC_ENCRYPTION must be true to enable the additional properties below */ if (level != 0) { if ((retcode = ct_con_props(connection, CS_SET, CS_SEC_ENCRYPTION, (CS_VOID*)&i, CS_UNUSED, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SEC_ENCRYPTION, true) failed"); return 0; } } #if defined(CS_SEC_EXTENDED_ENCRYPTION) /* Set the level to > 1 to enable asymetric password encryption. This also disables non-encrypted retries */ if (level > 1) { CS_INT extendedEncryption = CS_TRUE; CS_INT nonEncryptionRetry = CS_FALSE; if ((retcode = ct_con_props(connection, CS_SET, CS_SEC_EXTENDED_ENCRYPTION, &extendedEncryption, CS_UNUSED, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SEC_EXTENDED_ENCRYPTION, true) failed"); return 0; } if ((retcode = ct_con_props(connection, CS_SET, CS_SEC_NON_ENCRYPTION_RETRY, &nonEncryptionRetry, CS_UNUSED, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SEC_NON_ENCRYPTION_RETRY, false) failed"); return 0; } } #endif } } #if defined(CS_PROP_SSL_CA) if(retcode == CS_SUCCEED) { if(imp_dbh->sslCAFile[0] != 0) { if((retcode = ct_con_props(connection, CS_SET, CS_PROP_SSL_CA, imp_dbh->sslCAFile, CS_NULLTERM, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_PROP_SSL_CA, %s) failed", imp_dbh->sslCAFile); return 0; } } } #endif if (retcode == CS_SUCCEED && imp_dbh->host[0] && imp_dbh->port[0]) { #if defined(CS_SERVERADDR) char buff[255]; sprintf(buff, "%.64s %.20s", imp_dbh->host, imp_dbh->port); if((retcode = ct_con_props(connection, CS_SET, CS_SERVERADDR, (CS_VOID*)buff, CS_NULLTERM, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_SERVERADDR) failed"); return 0; } #else croak("This version of OpenClient doesn't support CS_SERVERADDR"); #endif } if (retcode == CS_SUCCEED && imp_dbh->blkLogin[0] != 0) { CS_INT flag = CS_TRUE; if ((retcode = ct_con_props(connection, CS_SET, CS_BULK_LOGIN, (CS_VOID*)&flag, CS_UNUSED, (CS_INT*)NULL)) != CS_SUCCEED) { warn("ct_con_props(CS_BULK_LOGIN) failed"); return 0; } } if (retcode == CS_SUCCEED) { len = *imp_dbh->server == 0 ? 0 : CS_NULLTERM; // Try to connect - if this fails we do some cleanup... if ((retcode = ct_connect(connection, imp_dbh->server, len)) != CS_SUCCEED) { if (glocale != NULL) { cs_loc_drop(context, glocale); } ct_con_drop(connection); return 0; } } if (imp_dbh->ifile[0]) { if ((retcode = ct_config(context, CS_SET, CS_IFILE, ofile, CS_NULLTERM, NULL)) != CS_SUCCEED) { warn("ct_config(CS_SET, CS_IFILE, %s) failed", ofile); } } if (imp_dbh->database[0] || imp_dbh->curr_db[0]) { int ret = syb_db_use(imp_dbh, connection); if (imp_dbh->failedDbUseFatal && ret < 0) { /* cleanup, and return NULL */ ct_close(connection, CS_FORCE_CLOSE); if (glocale != NULL) { cs_loc_drop(context, glocale); } ct_con_drop(connection); return 0; } } if (imp_dbh->chainedSupported) { CS_BOOL value = CS_FALSE; /* Default to ct_option supported... */ imp_dbh->optSupported = 1; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> checking for chained transactions\n"); } retcode = ct_options(connection, CS_SET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); if (retcode == CS_FAIL) { imp_dbh->doRealTran = 1; imp_dbh->chainedSupported = 0; } #if 0 /* This appears not to work - and hides the assignement to optSupported done in the server callback */ /* No SRV_OPTION handler on the server... */ if (imp_dbh->lasterr == 17001) { imp_dbh->optSupported = 0; } else { imp_dbh->optSupported = 1; } #endif if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> ct_option is %ssupported\n", imp_dbh->optSupported == 1 ?"":"not "); } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_login() -> chained transactions are %s supported\n", retcode == CS_FAIL ? "not" : ""); } } #if 0 if(!imp_dbh->optSupported) { imp_dbh->chainedSupported = 0; imp_dbh->doRealTran = 1; /* XXX ??? */ } #endif if (imp_dbh->connection) { /* we're setting a sub-connection, so make sure that any attributes such as syb_quoted_identifier and syb_rowcount are set here too */ if (imp_dbh->quotedIdentifier && imp_dbh->optSupported) { CS_INT value = 1; retcode = ct_options(connection, CS_SET, CS_OPT_QUOTED_IDENT, &value, CS_UNUSED, NULL); if (retcode != CS_SUCCEED) { warn("Setting of CS_OPT_QUOTED_IDENT failed."); } } #if defined(CS_OPT_ROWCOUNT) if(imp_dbh->rowcount && imp_dbh->optSupported) { CS_INT value = imp_dbh->rowcount; retcode = ct_options(connection, CS_SET, CS_OPT_ROWCOUNT, &value, CS_UNUSED, NULL); if(retcode != CS_SUCCEED) { warn("Setting of CS_OPT_ROWCOUNT failed."); } } #endif } return connection; } static int syb_db_use(imp_dbh_t *imp_dbh, CS_CONNECTION *connection) { CS_COMMAND *cmd = syb_alloc_cmd(imp_dbh, connection, 1); CS_RETCODE ret; CS_INT restype; char statement[255]; int retval = 0; char *db; if (!cmd) { return -1; } if (DBIc_ACTIVE(imp_dbh) && imp_dbh->curr_db[0]) { db = imp_dbh->curr_db; } else { db = imp_dbh->database; } sprintf(statement, "use [%s]", db); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_use() -> ct_command(%s)\n", statement); } ret = ct_command(cmd, CS_LANG_CMD, statement, CS_NULLTERM, CS_UNUSED); if (ret != CS_SUCCEED) { warn("ct_command failed for '%s'", statement); return -1; } ret = ct_send(cmd); if (ret != CS_SUCCEED) { warn("ct_send failed for '%s'", statement); return -1; } while ((ret = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_use() -> ct_results(%d)\n", restype); } if (restype == CS_CMD_FAIL) { warn("DBD::Sybase - can't change context to database %s\n", imp_dbh->database); retval = -1; } } ct_cmd_drop(cmd); return retval; } static int extract_version(char *buff, char *ver) { if (!strncmp(buff, "Adaptive", 8) || !strncmp(buff, "SQL Server", 10)) { char *p, *s; if ((p = strchr(buff, '/'))) { ++p; if ((s = strchr(p, '/'))) { int len = s - p; if (len >= VERSION_SIZE) { len = VERSION_SIZE; } strncpy(ver, p, len); } else { strncpy(ver, p, 10); } } } else if (!strncmp(buff, "Microsoft SQL Server", 20)) { strcpy(ver, "MS-SQL"); } else { strcpy(ver, "Unknown"); } return 0; } static int get_server_version(SV *dbh, imp_dbh_t *imp_dbh, CS_CONNECTION *con) { CS_COMMAND *cmd = syb_alloc_cmd(imp_dbh, con, 1); CS_RETCODE ret; CS_INT restype; char statement[60]; char buff[255]; char version[sizeof(imp_dbh->serverVersion)]; int retval = 0; char *db; if (!cmd) { return -1; } memset(version, 0, sizeof(imp_dbh->serverVersion)); sprintf(statement, "select @@version"); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> ct_command(%s)\n", statement); } ret = ct_command(cmd, CS_LANG_CMD, statement, CS_NULLTERM, CS_UNUSED); if (ret != CS_SUCCEED) { warn("ct_command failed for '%s'", statement); return -1; } ret = ct_send(cmd); if (ret != CS_SUCCEED) { warn("ct_send failed for '%s'", statement); return -1; } while ((ret = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> ct_results(%d)\n", restype); } if (restype == CS_CMD_FAIL) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> Can't get version value\n"); } retval = -1; } if (restype == CS_ROW_RESULT) { CS_DATAFMT datafmt; CS_INT len; CS_SMALLINT indicator; CS_INT retcode; CS_INT rows; ct_describe(cmd, 1, &datafmt); datafmt.format = CS_FMT_NULLTERM; datafmt.maxlength = sizeof(buff); ct_bind(cmd, 1, &datafmt, buff, &len, &indicator); while ((retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> version = %s\n", buff); } strncpy(imp_dbh->serverVersionString, buff, sizeof(imp_dbh->serverVersionString)); extract_version(buff, version); strncpy(imp_dbh->serverVersion, version, sizeof(imp_dbh->serverVersion)); if (!strncmp("MS-SQL", version, 6)) { imp_dbh->isMSSql = 1; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " get_server_version() -> version = %s\n", imp_dbh->serverVersion); } } } } ct_cmd_drop(cmd); return retval; } int syb_ping(SV *dbh, imp_dbh_t *imp_dbh) { dTHX; CS_COMMAND *cmd; CS_RETCODE ret; CS_INT restype; char *statement = "/* ping */"; if (DBIc_ACTIVE_KIDS(imp_dbh)) { DBIh_SET_ERR_CHAR(dbh, (imp_xxh_t *)imp_dbh, NULL, -1, "Can't call ping() with active statement handles", NULL, NULL); return -1; } DBIh_CLEAR_ERROR(imp_dbh); cmd = syb_alloc_cmd(imp_dbh, imp_dbh->connection, 0 /*silent*/); if (!cmd) { return 0; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_ping() -> ct_command(%s)\n", statement); } ret = ct_command(cmd, CS_LANG_CMD, statement, CS_NULLTERM, CS_UNUSED); if (ret != CS_SUCCEED) { ct_cmd_drop(cmd); return 0; } ret = ct_send(cmd); if (ret != CS_SUCCEED) { ct_cmd_drop(cmd); return 0; } while ((ret = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_ping() -> ct_results(%d)\n", restype); } if (imp_dbh->isDead) { ct_cmd_drop(cmd); return 0; } /* Ignored - we don't care if there is a syntax error - only that the communication with the server worked */ } DBIh_CLEAR_ERROR(imp_dbh); ct_cmd_drop(cmd); return 1; } int syb_db_date_fmt(SV *dbh, imp_dbh_t *imp_dbh, char *fmt) { CS_INT type; if (!strncmp(fmt, "ISO_strict", 10)) { imp_dbh->dateFmt = 2; return 1; } if (!strcmp(fmt, "ISO")) { imp_dbh->dateFmt = 1; return 1; } imp_dbh->dateFmt = 0; if (!strcmp(fmt, "LONG")) { type = CS_DATES_LONG; } else if (!strcmp(fmt, "SHORT")) { type = CS_DATES_SHORT; } else if (!strcmp(fmt, "DMY4_YYYY")) { type = CS_DATES_DMY4_YYYY; } else if (!strcmp(fmt, "MDY1_YYYY")) { type = CS_DATES_MDY1_YYYY; } else if (!strcmp(fmt, "DMY1_YYYY")) { type = CS_DATES_DMY1_YYYY; } else if (!strcmp(fmt, "DMY2_YYYY")) { type = CS_DATES_DMY2_YYYY; } else if (!strcmp(fmt, "YMD3_YYYY")) { type = CS_DATES_YMD3_YYYY; } else if (!strcmp(fmt, "HMS")) { type = CS_DATES_HMS; } else if (!strcmp(fmt, "LONGMS")) { #if defined(CS_DATES_LONGUSA_YYYY) type = CS_DATES_LONGUSA_YYYY; #else type = CS_DATES_LONG; #endif } else { warn("Invalid format %s in _date_fmt", fmt); return 0; } if (cs_dt_info(context, CS_SET, LOCALE(imp_dbh), CS_DT_CONVFMT, CS_UNUSED, (CS_VOID*) &type, CS_SIZEOF(CS_INT), NULL) != CS_SUCCEED) { warn("cs_dt_info() failed"); return 0; } return 1; } static int syb_get_date_fmt(imp_dbh_t *imp_dbh, char *fmt) { CS_INT type; char *p; if (imp_dbh->dateFmt == 2) { strcpy(fmt, "ISO_strict"); return 1; } if (imp_dbh->dateFmt == 1) { strcpy(fmt, "ISO"); return 1; } if (cs_dt_info(context, CS_GET, LOCALE(imp_dbh), CS_DT_CONVFMT, CS_UNUSED, (CS_VOID*) &type, CS_SIZEOF(CS_INT), NULL) != CS_SUCCEED) { warn("cs_dt_info() failed"); return 0; } switch (type) { case CS_DATES_LONG: p = "LONG"; break; case CS_DATES_SHORT: p = "SHORT"; break; case CS_DATES_DMY4_YYYY: p = "DMY4_YYYY"; break; case CS_DATES_MDY1_YYYY: p = "MDY1_YYYY"; break; case CS_DATES_DMY1_YYYY: p = "DMY1_YYYY"; break; case CS_DATES_DMY2_YYYY: p = "DMY2_YYYY"; break; case CS_DATES_YMD3_YYYY: p = "YMD3_YYYY"; break; case CS_DATES_HMS: p = "HMS"; break; default: p = "Unknown"; break; } strcpy(fmt, p); return 1; } int syb_discon_all(SV *drh, imp_drh_t *imp_drh) { /* disconnect_all is not implemented */ return 1; } #if defined(NO_BLK) static int syb_blk_done(imp_sth_t *imp_sth, CS_INT type) { return 1; } #else static int syb_blk_done(imp_sth_t *imp_sth, CS_INT type) { CS_RETCODE ret; /* if $dbh->commit is called but no rows have been successfully sent to the server then blk_done(CS_BLK_BATCH) fails. Avoid the failure by simply not calling blk_done() in that situation. */ if (type == CS_BLK_BATCH && !imp_sth->bcpRows) { return 1; } ret = blk_done(imp_sth->bcp_desc, type, &imp_sth->numRows); if (DBIc_DBISTATE(imp_sth)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " syb_blk_done -> blk_done(%d, %d) = %d\n", type, imp_sth->numRows, ret); } /* reset row counter if blk_done was successful */ if (ret == CS_SUCCEED) { if (type == CS_BLK_CANCEL) { imp_sth->bcpRows = -1; } else { imp_sth->bcpRows = 0; } } if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " syb_blk_done(%d) -> ret = %d, rows = %d\n", type, ret, imp_sth->numRows); } return ret == CS_SUCCEED; } #endif int syb_db_commit(SV *dbh, imp_dbh_t *imp_dbh) { CS_COMMAND *cmd; char buff[128]; CS_INT restype; CS_RETCODE retcode; int failFlag = 0; if (imp_dbh->imp_sth && imp_dbh->imp_sth->bcpFlag) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_commit() -> bcp op, calling syb_blk_done()\n"); } return syb_blk_done(imp_dbh->imp_sth, CS_BLK_BATCH); } if (imp_dbh->doRealTran && !imp_dbh->inTransaction) { return 1; } if (DBIc_is(imp_dbh, DBIcf_AutoCommit)) { warn("commit ineffective with AutoCommit"); return 1; } cmd = syb_alloc_cmd(imp_dbh, imp_dbh->connection, 1); if (imp_dbh->doRealTran) { sprintf(buff, "\nCOMMIT TRAN %s\n", imp_dbh->tranName); } else { strcpy(buff, "\nCOMMIT TRAN\n"); } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_commit() -> ct_command(%s)\n", buff); } retcode = ct_command(cmd, CS_LANG_CMD, buff, CS_NULLTERM, CS_UNUSED); if (retcode != CS_SUCCEED) { return 0; } if (ct_send(cmd) != CS_SUCCEED) { return 0; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_commit() -> ct_send() OK\n"); } while ((retcode = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_commit() -> ct_results(%d) == %d\n", restype, retcode); } if (restype == CS_CMD_FAIL) { failFlag = 1; } } ct_cmd_drop(cmd); imp_dbh->inTransaction = 0; return !failFlag; } int syb_db_rollback(SV *dbh, imp_dbh_t *imp_dbh) { CS_COMMAND *cmd; char buff[128]; CS_INT restype; CS_RETCODE retcode; int failFlag = 0; if (imp_dbh->imp_sth && imp_dbh->imp_sth->bcpFlag) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_rollback() -> bcp op, calling syb_blk_done()\n"); } return syb_blk_done(imp_dbh->imp_sth, CS_BLK_CANCEL); } if (imp_dbh->doRealTran && !imp_dbh->inTransaction) { return 1; } if (DBIc_is(imp_dbh, DBIcf_AutoCommit)) { warn("rollback ineffective with AutoCommit"); return 1; } cmd = syb_alloc_cmd(imp_dbh, imp_dbh->connection, 1); if (imp_dbh->doRealTran) { sprintf(buff, "\nROLLBACK TRAN %s\n", imp_dbh->tranName); } else { strcpy(buff, "\nROLLBACK TRAN\n"); } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_rollback() -> ct_command(%s)\n", buff); } retcode = ct_command(cmd, CS_LANG_CMD, buff, CS_NULLTERM, CS_UNUSED); if (retcode != CS_SUCCEED) { return 0; } if (ct_send(cmd) != CS_SUCCEED) { return 0; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_rollback() -> ct_send() OK\n"); } while ((retcode = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_rollback() -> ct_results(%d) == %d\n", restype, retcode); } if (restype == CS_CMD_FAIL) { failFlag = 1; } } ct_cmd_drop(cmd); imp_dbh->inTransaction = 0; return !failFlag; } static int syb_db_opentran(SV *dbh, imp_dbh_t *imp_dbh) { CS_COMMAND *cmd; char buff[128]; CS_INT restype; CS_RETCODE retcode; int failFlag = 0; if (DBIc_is(imp_dbh, DBIcf_AutoCommit) || imp_dbh->inTransaction) { return 1; } cmd = syb_alloc_cmd(imp_dbh, imp_dbh->connection, 1); sprintf(imp_dbh->tranName, "DBI%x", (void*)imp_dbh); sprintf(buff, "\nBEGIN TRAN %s\n", imp_dbh->tranName); retcode = ct_command(cmd, CS_LANG_CMD, buff, CS_NULLTERM, CS_UNUSED); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_opentran() -> ct_command(%s) = %d\n", buff, retcode); } if (retcode != CS_SUCCEED) { return 0; } retcode = ct_send(cmd); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_opentran() -> ct_send() = %d\n", retcode); } if (retcode != CS_SUCCEED) { return 0; } while ((retcode = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_opentran() -> ct_results(%d) == %d\n", restype, retcode); } if (restype == CS_CMD_FAIL) { failFlag = 1; } } ct_cmd_drop(cmd); if (!failFlag) { imp_dbh->inTransaction = 1; } return !failFlag; } int syb_db_disconnect(SV *dbh, imp_dbh_t *imp_dbh) { dTHX; CS_RETCODE retcode; /* If we are called in a process that is different from the one where the handle * was created then we do NOT disconnect. */ if (imp_dbh->disconnectInChild == 0 && imp_dbh->pid != getpid()) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " syb_db_disconnect() -> imp_dbh->pid (%d) != pid (%d) - not closing connection\n", imp_dbh->pid, getpid()); } return 0; } /* rollback if we get disconnected and no explicit commit has been called (when in non-AutoCommit mode) */ /* For Sybase, issuing a ROLLBACK TRAN with no corresponding BEGIN TRAN is a no-op, and has no side effects. However, for MS-SQL this generates a warning message. Given that an ongoing transaction is automatically rolled back if the connection is aborted it would seem that issuing this rollback on the disconnect call is realy unnecessary. */ #if ROLLBACK_ON_EXIT if (imp_dbh->isDead == 0) { /* only call if connection still active */ if (!DBIc_is(imp_dbh, DBIcf_AutoCommit)) { syb_db_rollback(dbh, imp_dbh); } } #endif if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_disconnect() -> ct_close()\n"); } if ((retcode = ct_close(imp_dbh->connection, CS_FORCE_CLOSE)) != CS_SUCCEED) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_disconnect(): ct_close() failed\n"); } if (imp_dbh->locale && (retcode = cs_loc_drop(context, imp_dbh->locale)) != CS_SUCCEED) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_disconnect(): cs_loc_drop() failed\n"); } if ((retcode = ct_con_drop(imp_dbh->connection)) != CS_SUCCEED) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_disconnect(): ct_con_drop() failed\n"); } DBIc_ACTIVE_off(imp_dbh); return 1; } void syb_db_destroy(SV *dbh, imp_dbh_t *imp_dbh) { if (DBIc_ACTIVE(imp_dbh)) { syb_db_disconnect(dbh, imp_dbh); } /* Nothing in imp_dbh to be freed */ DBIc_IMPSET_off(imp_dbh); } /* NOTE: if you set any new attributes here that need to be passed on to Sybase (for example via ct_options()) then make sure that you also code the same thing in syb_db_connect() so that connections opened for nested statement handles correctly handle this issue */ int syb_db_STORE_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv) { dTHX; STRLEN kl; int on; char *key = SvPV(keysv, kl); if (kl == 15 && strEQ(key, "syb_chained_txn")) { on = SvTRUE(valuesv); if (imp_dbh->chainedSupported) { int autocommit = DBIc_is(imp_dbh, DBIcf_AutoCommit); /* if we're connected to an MSSQL instance, then do not attempt to execute a COMMIT TRAN - as that will generate an error message if we are not in a transaction. If the switch is attempted in a transaction then the perl program will have to be modified to add an explicit call to commit instead.*/ if (!autocommit && !imp_dbh->isMSSql) { syb_db_commit(dbh, imp_dbh); } if (on) { imp_dbh->doRealTran = 0; } else { imp_dbh->doRealTran = 1; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_STORE() -> syb_chained_txn => %d\n", on); } if (!autocommit && imp_dbh->optSupported) { CS_BOOL value = on ? CS_TRUE : CS_FALSE; CS_RETCODE ret; ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " syb_db_STORE() -> syb_chained_txn AutoCommit off CS_OPT_CHAINXACTS(%d) => %d\n", value, ret); } } } else { /* XXX - should this issue a warning???? */ } return TRUE; } if (kl == 10 && strEQ(key, "AutoCommit")) { int crnt = (DBIc_has(imp_dbh, DBIcf_AutoCommit) > 0); int ret; /* Move the check for ACTIVE_KIDS below the check for the bcp flag * as that inhibits the setting of the autocommit variable anyway. */ if (imp_dbh->imp_sth && imp_dbh->imp_sth->bcpFlag) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_db_STORE(): AutoCommit value changes inhibitted during BCP ops\n"); } return TRUE; } on = SvTRUE(valuesv); if (DBIc_ACTIVE_KIDS(imp_dbh) && ((on && !crnt) || (!on && crnt))) { croak( "panic: can't change AutoCommit (from %d to %d) with active statement handles", on, crnt); } ret = toggle_autocommit(dbh, imp_dbh, on); DBIc_set(imp_dbh, DBIcf_AutoCommit, on); return TRUE; } if (kl == 11 && strEQ(key, "LongTruncOK")) { DBIc_set(imp_dbh, DBIcf_LongTruncOk, SvTRUE(valuesv)); return TRUE; } if (kl == 11 && strEQ(key, "LongReadLen")) { CS_INT value = SvIV(valuesv); CS_RETCODE ret; if (imp_dbh->inUse) { warn("Can't set LongReadLen because the database handle is in use."); return FALSE; } ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_TEXTSIZE, &value, CS_UNUSED, NULL); if (ret != CS_SUCCEED) { warn("Setting of CS_OPT_TEXTSIZE failed."); return FALSE; } DBIc_LongReadLen(imp_dbh) = value; return TRUE; } if (kl == 21 && strEQ(key, "syb_quoted_identifier")) { CS_INT value = SvIV(valuesv); CS_RETCODE ret; if (imp_dbh->inUse) { warn( "Can't set syb_quoted_identifier because the database handle is in use."); return FALSE; } ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_QUOTED_IDENT, &value, CS_UNUSED, NULL); if (ret != CS_SUCCEED) { warn("Setting of CS_OPT_QUOTED_IDENT failed."); return FALSE; } imp_dbh->quotedIdentifier = value; return TRUE; } if (kl == 12 && strEQ(key, "syb_show_sql")) { on = SvTRUE(valuesv); if (on) { imp_dbh->showSql = 1; } else { imp_dbh->showSql = 0; } return TRUE; } if (kl == 12 && strEQ(key, "syb_show_eed")) { on = SvTRUE(valuesv); if (on) { imp_dbh->showEed = 1; } else { imp_dbh->showEed = 0; } return TRUE; } if (kl == 15 && strEQ(key, "syb_err_handler")) { if (!SvOK(valuesv)) { imp_dbh->err_handler = NULL; } else if (imp_dbh->err_handler == (SV*) NULL) { imp_dbh->err_handler = newSVsv(valuesv); } else { sv_setsv(imp_dbh->err_handler, valuesv); } return TRUE; } if (kl == 15 && strEQ(key, "syb_enable_utf8")) { #if !defined(DBD_CAN_HANDLE_UTF8) warn("The current version of OpenClient can't handle utf8 data."); return FALSE; #else on = SvTRUE(valuesv); if (on) { imp_dbh->enable_utf8 = 1; } else { imp_dbh->enable_utf8 = 0; } return TRUE; #endif } if (kl == 16 && strEQ(key, "syb_row_callback")) { if (!SvOK(valuesv)) { imp_dbh->row_cb = NULL; } else if (imp_dbh->row_cb == (SV*) NULL) { imp_dbh->row_cb = newSVsv(valuesv); } else { sv_setsv(imp_dbh->row_cb, valuesv); } return TRUE; } if (kl == 16 && strEQ(key, "syb_flush_finish")) { on = SvTRUE(valuesv); if (on) { imp_dbh->flushFinish = 1; } else { imp_dbh->flushFinish = 0; } return TRUE; } if (kl == 12 && strEQ(key, "syb_rowcount")) { #if defined(CS_OPT_ROWCOUNT) CS_INT value = SvIV(valuesv); CS_RETCODE ret; if (imp_dbh->inUse) { warn( "Can't set syb_rowcount because the database handle is in use."); return FALSE; } ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_ROWCOUNT, &value, CS_UNUSED, NULL); if (ret != CS_SUCCEED) { warn("Setting of CS_OPT_ROWCOUNT failed."); return FALSE; } imp_dbh->rowcount = value; return TRUE; #else return FALSE; #endif } if (kl == 21 && strEQ(key, "syb_dynamic_supported")) { warn("'syb_dynamic_supported' is a read-only attribute"); return TRUE; } if (kl == 18 && strEQ(key, "syb_do_proc_status")) { on = SvTRUE(valuesv); if (on) { imp_dbh->doProcStatus = 1; } else { imp_dbh->doProcStatus = 0; } return TRUE; } if (kl == 14 && strEQ(key, "syb_use_bin_0x")) { on = SvTRUE(valuesv); if (on) { imp_dbh->useBin0x = 1; } else { imp_dbh->useBin0x = 0; } return TRUE; } if (kl == 17 && strEQ(key, "syb_binary_images")) { on = SvTRUE(valuesv); if (on) { imp_dbh->binaryImage = 1; } else { imp_dbh->binaryImage = 0; } return TRUE; } if (kl == 18 && strEQ(key, "syb_deadlock_retry")) { int value = SvIV(valuesv); imp_dbh->deadlockRetry = value; return TRUE; } if (kl == 18 && strEQ(key, "syb_deadlock_sleep")) { int value = SvIV(valuesv); imp_dbh->deadlockSleep = value; return TRUE; } if (kl == 20 && strEQ(key, "syb_deadlock_verbose")) { int value = SvIV(valuesv); imp_dbh->deadlockVerbose = value; return TRUE; } if (kl == 17 && strEQ(key, "syb_nsql_nostatus")) { int value = SvIV(valuesv); imp_dbh->nsqlNoStatus = value; return TRUE; } if (kl == 16 && strEQ(key, "syb_no_child_con")) { imp_dbh->noChildCon = SvIV(valuesv); return TRUE; } if (kl == 19 && strEQ(key, "syb_failed_db_fatal")) { imp_dbh->failedDbUseFatal = SvIV(valuesv); return TRUE; } if (kl == 29 && strEQ(key, "syb_bind_empty_string_as_null")) { imp_dbh->bindEmptyStringNull = SvIV(valuesv); return TRUE; } if (kl == 27 && strEQ(key, "syb_cancel_request_on_error")) { imp_dbh->alwaysForceFailure = SvIV(valuesv); return TRUE; } if (kl == 23 && strEQ(key, "syb_disconnect_in_child")) { imp_dbh->disconnectInChild = SvIV(valuesv); return TRUE; } if (kl == 18 && strEQ(key, "syb_server_version")) { strncpy(imp_dbh->serverVersion, SvPV(valuesv, PL_na), 15); return TRUE; } if (kl == 12 && strEQ(key, "syb_date_fmt")) { syb_db_date_fmt(dbh, imp_dbh, SvPV(valuesv, PL_na)); return TRUE; } return FALSE; } SV *syb_db_FETCH_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv) { dTHX; STRLEN kl; char *key = SvPV(keysv, kl); SV *retsv = NULL; if (kl == 10 && strEQ(key, "AutoCommit")) { if (DBIc_is(imp_dbh, DBIcf_AutoCommit)) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 11 && strEQ(key, "LongTruncOK")) { if (DBIc_is(imp_dbh, DBIcf_LongTruncOk)) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 11 && strEQ(key, "LongReadLen")) { retsv = newSViv(DBIc_LongReadLen(imp_dbh)); } if (kl == 12 && strEQ(key, "syb_show_sql")) { if (imp_dbh->showSql) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 12 && strEQ(key, "syb_show_eed")) { if (imp_dbh->showEed) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 8 && strEQ(key, "syb_dead")) { if (imp_dbh->isDead) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 15 && strEQ(key, "syb_err_handler")) { if (imp_dbh->err_handler) { retsv = newSVsv(imp_dbh->err_handler); } else { retsv = &PL_sv_undef; } } if (kl == 15 && strEQ(key, "syb_enable_utf8")) { if (imp_dbh->enable_utf8) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 16 && strEQ(key, "syb_row_callback")) { if (imp_dbh->row_cb) { retsv = newSVsv(imp_dbh->row_cb); } else { retsv = &PL_sv_undef; } } if (kl == 15 && strEQ(key, "syb_chained_txn")) { if (imp_dbh->doRealTran) { retsv = newSViv(0); } else { retsv = newSViv(1); } } if (kl == 18 && strEQ(key, "syb_check_tranmode")) { CS_INT value; CS_RETCODE ret; ret = syb_set_options(imp_dbh, CS_GET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); if (ret != CS_SUCCEED) { value = 0; } retsv = newSViv(value); } if (kl == 16 && strEQ(key, "syb_flush_finish")) { if (imp_dbh->flushFinish) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 21 && strEQ(key, "syb_dynamic_supported")) { CS_BOOL val; CS_RETCODE ret = ct_capability(imp_dbh->connection, CS_GET, CS_CAP_REQUEST, CS_REQ_DYN, (CS_VOID*) &val); if (ret != CS_SUCCEED || val == CS_FALSE) { retsv = newSViv(0); } else { retsv = newSViv(1); } } if (kl == 21 && strEQ(key, "syb_quoted_identifier")) { if (imp_dbh->quotedIdentifier) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 12 && strEQ(key, "syb_rowcount")) { retsv = newSViv(imp_dbh->rowcount); } if (kl == 14 && strEQ(key, "syb_oc_version")) { retsv = newSVpv(ocVersion, strlen(ocVersion)); } if (kl == 18 && strEQ(key, "syb_do_proc_status")) { retsv = newSViv(imp_dbh->doProcStatus); } if (kl == 14 && strEQ(key, "syb_use_bin_0x")) { if (imp_dbh->useBin0x) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 17 && strEQ(key, "syb_binary_images")) { if (imp_dbh->binaryImage) { retsv = newSViv(1); } else { retsv = newSViv(0); } } if (kl == 18 && strEQ(key, "syb_deadlock_retry")) { retsv = newSViv(imp_dbh->deadlockRetry); } if (kl == 18 && strEQ(key, "syb_deadlock_sleep")) { retsv = newSViv(imp_dbh->deadlockSleep); } if (kl == 20 && strEQ(key, "syb_deadlock_verbose")) { retsv = newSViv(imp_dbh->deadlockVerbose); } if (kl == 17 && strEQ(key, "syb_nsql_nostatus")) { retsv = newSViv(imp_dbh->nsqlNoStatus); } if (kl == 16 && strEQ(key, "syb_no_child_con")) { retsv = newSViv(imp_dbh->noChildCon); } if (kl == 19 && strEQ(key, "syb_failed_db_fatal")) { retsv = newSViv(imp_dbh->failedDbUseFatal); } if (kl == 29 && strEQ(key, "syb_bind_empty_string_as_null")) { retsv = newSViv(imp_dbh->bindEmptyStringNull); } if (kl == 27 && strEQ(key, "syb_cancel_request_on_error")) { retsv = newSViv(imp_dbh->alwaysForceFailure); } if (kl == 23 && strEQ(key, "syb_disconnect_in_child")) { retsv = newSViv(imp_dbh->disconnectInChild); } if (kl == 18 && strEQ(key, "syb_server_version")) { retsv = newSVpv(imp_dbh->serverVersion, 0); } if (kl == 25 && strEQ(key, "syb_server_version_string")) { retsv = newSVpv(imp_dbh->serverVersionString, 0); } if (kl == 12 && strEQ(key, "syb_date_fmt")) { char buff[50]; syb_get_date_fmt(imp_dbh, buff); retsv = newSVpv(buff, 0); } if (kl == 11 && strEQ(key, "syb_has_blk")) { #if defined(NO_BLK) retsv = &PL_sv_no; #else retsv = &PL_sv_yes; #endif } if (retsv == &PL_sv_yes || retsv == &PL_sv_no || retsv == &PL_sv_undef) { return retsv; } return sv_2mortal(retsv); } /* set mode to 0 to avoid an error message being printed if ct_cmd_alloc fails This is useful for the ping() call, for example */ static CS_COMMAND * syb_alloc_cmd(imp_dbh_t *imp_dbh, CS_CONNECTION *connection, int mode) { CS_COMMAND *cmd; CS_RETCODE retcode; if ((retcode = ct_cmd_alloc(connection, &cmd)) != CS_SUCCEED) { if (mode != 0) { syb_set_error(imp_dbh, -1, "ct_cmd_alloc failed"); } return NULL; } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_alloc_cmd() -> CS_COMMAND %x for CS_CONNECTION %x\n", cmd, connection); } return cmd; } static void dbd_preparse(imp_sth_t *imp_sth, char *statement) { dTHX; enum { DEFAULT, LITERAL, COMMENT, LINE_COMMENT, VARIABLE } STATES; int state = DEFAULT; int next_state; char last_literal = 0; char *src; phs_t phs_tpl; SV *phs_sv; int idx = 0; STRLEN namelen; char name[64]; #define VARNAME_LEN 255 char varname[VARNAME_LEN + 1]; int pos; imp_sth->statement = my_strdup(statement); /* initialise phs ready to be cloned per placeholder */ memset(&phs_tpl, 0, sizeof(phs_tpl)); phs_tpl.ftype = CS_VARCHAR_TYPE; varname[0] = 0; /* check for a leading EXEC. If it is present then set imp_sth->type to 1 to indicate that we are doing an RPC call. */ src = statement; while (isspace(*src) && *src) { /* skip over leading whitespace */ ++src; } if (!strncasecmp(src, "exec", 4)) { imp_sth->type = 1; } else if (imp_sth->bcpFlag) { imp_sth->type = 2; } else { imp_sth->type = 0; } src = statement; while (*src) { next_state = state; /* default situation */ switch (state) { case DEFAULT: if (*src == '\'' || *src == '"') { last_literal = *src; next_state = LITERAL; } else if (*src == '/' && *(src + 1) == '*') { next_state = COMMENT; } else if (*src == '-' && *(src + 1) == '-') { next_state = LINE_COMMENT; } else if (*src == '@') { varname[0] = '@'; pos = 1; next_state = VARIABLE; } break; case LITERAL: if (*src == last_literal) { next_state = DEFAULT; } break; case COMMENT: if (*(src - 1) == '*' && *src == '/') { next_state = DEFAULT; } break; case LINE_COMMENT: if (*src == '\n') { next_state = DEFAULT; } break; case VARIABLE: if (!isalnum(*src) && *src != '_') { varname[pos] = 0; next_state = DEFAULT; } else if (pos < VARNAME_LEN) { varname[pos++] = *src; } } /* printf("state = %d, *src = %c, next_state = %d\n", state, *src, next_state); */ if (state != DEFAULT || *src != '?') { ++src; state = next_state; continue; } state = next_state; if (*src != '?') { continue; } ++src; sprintf(name, ":p%d", ++idx); /* '?' -> ':p1' (etc) */ namelen = strlen(name); if (imp_sth->all_params_hv == NULL) { imp_sth->all_params_hv = newHV(); } phs_tpl.sv = &PL_sv_undef; phs_sv = newSVpv((char*) &phs_tpl, sizeof(phs_tpl) + namelen + 1); hv_store(imp_sth->all_params_hv, name, namelen, phs_sv, 0); strcpy(((phs_t*) (void*) SvPVX(phs_sv))->name, name); strcpy(((phs_t*) (void*) SvPVX(phs_sv))->varname, varname); if (imp_sth->type == 1) { /* if it's an EXEC call, check for OUTPUT */ char *p = src; do { if (*p == ',') { break; } if (isspace(*p)) { continue; } if (isalpha(*p)) { if (!strncasecmp(p, "out", 3)) { ((phs_t*) (void*) SvPVX(phs_sv))->is_inout = 1; } else { break; } } } while (*(++p)); } if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_preparse parameter %s (%s)\n", ((phs_t*) (void*) SvPVX(phs_sv))->name, ((phs_t*) (void*) SvPVX(phs_sv))->varname); } } if (imp_sth->all_params_hv) { DBIc_NUM_PARAMS(imp_sth) = (int) HvKEYS(imp_sth->all_params_hv); if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_preparse scanned %d distinct placeholders\n", (int) DBIc_NUM_PARAMS(imp_sth)); } } } static CS_RETCODE dyn_prepare(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, char* statement) { dTHX; CS_INT restype; static int tt = 1; int failed = 0; CS_BOOL val; CS_RETCODE ret; ret = ct_capability(imp_dbh->connection, CS_GET, CS_CAP_REQUEST, CS_REQ_DYN, (CS_VOID*) &val); if (ret != CS_SUCCEED || val == CS_FALSE) { croak( "Panic: dynamic SQL (? placeholders) are not supported by the server you are connecting to"); } sprintf(imp_sth->dyn_id, "DBD%d", (int) tt++); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_dynamic(CS_PREPARE) for %s\n", imp_sth->dyn_id); } imp_sth->dyn_execed = 0; imp_sth->cmd = syb_alloc_cmd(imp_dbh, imp_sth->connection ? imp_sth->connection : imp_dbh->connection, 1); ret = ct_dynamic(imp_sth->cmd, CS_PREPARE, imp_sth->dyn_id, CS_NULLTERM, statement, CS_NULLTERM); if (ret != CS_SUCCEED) { warn("ct_dynamic(CS_PREPARE) returned %d", ret); return ret; } ret = ct_send(imp_sth->cmd); if (ret != CS_SUCCEED) { warn("ct_send(ct_dynamic(CS_PREPARE)) returned %d", ret); return ret; } while ((ret = ct_results(imp_sth->cmd, &restype)) == CS_SUCCEED) { if (restype == CS_CMD_FAIL) { failed = 1; } } if (ret == CS_FAIL || failed) { warn("ct_result(ct_dynamic(CS_PREPARE)) returned %d", ret); return ret; } ret = ct_dynamic(imp_sth->cmd, CS_DESCRIBE_INPUT, imp_sth->dyn_id, CS_NULLTERM, NULL, CS_UNUSED); if (ret != CS_SUCCEED) { warn("ct_dynamic(CS_DESCRIBE_INPUT) returned %d", ret); } ret = ct_send(imp_sth->cmd); if (ret != CS_SUCCEED) { warn("ct_send(CS_DESCRIBE_INPUT) returned %d", ret); } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_dynamic(CS_DESCRIBE_INPUT) for %s\n", imp_sth->dyn_id); } while ((ret = ct_results(imp_sth->cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_results(CS_DESCRIBE_INPUT) for %s - restype %d\n", imp_sth->dyn_id, restype); } if (restype == CS_DESCRIBE_RESULT) { CS_INT num_param, outlen; int i; char name[50]; SV **svp; phs_t *phs; int ret; ret = ct_res_info(imp_sth->cmd, CS_NUMDATA, &num_param, CS_UNUSED, &outlen); if (ret != CS_SUCCEED) { warn("ct_res_info(CS_DESCRIBE_INPUT) returned %d", ret); } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_res_info(CS_DESCRIBE_INPUT) statement has %d parameters\n", num_param); } for (i = 1; i <= num_param; ++i) { sprintf(name, ":p%d", i); svp = hv_fetch(imp_sth->all_params_hv, name, strlen(name), 0); phs = ((phs_t*) (void*) SvPVX(*svp)); ct_describe(imp_sth->cmd, i, &phs->datafmt); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " dyn_prepare: ct_describe(CS_DESCRIBE_INPUT) col %d, type %d, name %s, status %d, length %d\n", i, phs->datafmt.datatype, phs->datafmt.name, phs->datafmt.status, phs->datafmt.maxlength); } } } } if (ct_dynamic(imp_sth->cmd, CS_EXECUTE, imp_sth->dyn_id, CS_NULLTERM, NULL, CS_UNUSED) != CS_SUCCEED) { ret = CS_FAIL; } else { ret = CS_SUCCEED; imp_sth->dyn_execed = 1; } return ret; } int syb_st_prepare(SV *sth, imp_sth_t *imp_sth, char *statement, SV *attribs) { dTHX; D_imp_dbh_from_sth; CS_RETCODE ret; /* PerlIO_printf(DBIc_LOGPIO(imp_dbh), "st_prepare on %x\n", imp_sth); */ sv_setpv(DBIc_ERRSTR(imp_dbh), ""); /* Don't try to initiate a new command if the connection isn't active! */ if (!DBIc_ACTIVE(imp_dbh)) { syb_set_error(imp_dbh, -1, "Database disconnected"); return 0; } /* Check to see if the syb_bcp_attribs flag is set */ getBcpAttribs(imp_sth, attribs); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_prepare() -> inUse = %d\n", imp_dbh->inUse); } if (DBIc_ACTIVE_KIDS(DBIc_PARENT_COM(imp_sth)) || imp_dbh->inUse) { int retval = 1; if (imp_dbh->noChildCon) { /* inhibit child connections to be created */ syb_set_error(imp_dbh, -1, "DBD::Sybase error: Can't create child connections when syb_no_chld_con is set"); return 0; } if (!DBIc_is(imp_dbh, DBIcf_AutoCommit)) { croak( "Panic: Can't have multiple statement handles on a single database handle when AutoCommit is OFF"); } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_prepare() parent has active kids - opening new connection\n"); } #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_LOCK(context_alloc_mutex); #endif if ((imp_sth->connection = syb_db_connect(imp_dbh)) == NULL) { retval = 0; } #if PERL_VERSION >= 8 && defined(_REENTRANT) MUTEX_UNLOCK(context_alloc_mutex); #endif if (!retval) { return retval; } } if (imp_sth->statement != NULL) { Safefree(imp_sth->statement); } imp_sth->statement = NULL; dbd_preparse(imp_sth, statement); imp_dbh->sql = imp_sth->statement; if (!DBIc_is(imp_dbh, DBIcf_AutoCommit) && imp_dbh->doRealTran) { if (syb_db_opentran(NULL, imp_dbh) == 0) { return -2; } } if ((int) DBIc_NUM_PARAMS(imp_sth)) { /* regular dynamic sql */ if (imp_sth->type == 0) { ret = dyn_prepare(imp_dbh, imp_sth, statement); if (ret != CS_SUCCEED) { return 0; } } else if (imp_sth->type == 1) { /* RPC call - get the proc name */ /* We could possibly get the proc params from syscolumns, but there are a lot of issues with that which will break it */ if (!syb_st_describe_proc(sth, imp_sth, statement)) { croak("DBD::Sybase: describe_proc failed!\n"); } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " describe_proc: procname = %s\n", imp_sth->proc); } imp_sth->cmd = syb_alloc_cmd(imp_dbh, imp_sth->connection ? imp_sth->connection : imp_dbh->connection, 1); ret = CS_SUCCEED; imp_sth->dyn_execed = 0; } else { /* BLK operation! */ ret = syb_blk_init(imp_dbh, imp_sth); } } else { /* If this is a blk request (i.e. the syb_bcp_attribs hash is set in the prepare() call, then force a failure, because no parameters (placeholders) have been defined. */ if (imp_sth->type == 2) { syb_set_error(imp_dbh, -1, "The syb_bcp_attribs attribute is set, but no placeholders found in the query"); return 0; } imp_sth->cmd = NULL; /* Early execution has some unwanted side effects - disabling it in 1.05_02. */ #if 0 if(cmd_execute(sth, imp_sth) != 0) { return 0; } #endif ret = CS_SUCCEED; } if (ret != CS_SUCCEED) { return 0; } imp_sth->doProcStatus = imp_dbh->doProcStatus; DBIc_on(imp_sth, DBIcf_IMPSET); if (!imp_sth->connection) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_prepare() -> set inUse\n"); } imp_dbh->inUse = 1; } /* Re-enable the active flag here (in 1.05_03) to fix bug with finish not getting called correctly */ DBIc_ACTIVE_on(imp_sth); return 1; } /* Extract the proc name (including database and owner) The identifiers can be quoted with square brackets ([my proc]) or, if "quoted identifier" is enabled, with double quotes. So we could have database.owner.proc database..proc owner.proc [data base]..proc proc "my proc" [my proc] */ static int syb_st_describe_proc(SV *sth, imp_sth_t *imp_sth, char *statement) { D_imp_dbh_from_sth; enum {DEFAULT, QUOTED} STATES; int state = DEFAULT; int next_state; char quote_char; char *buff = my_strdup(statement); char *src = buff; char *start; while (isspace(*src) && *src) { /* skip over leading whitespace */ ++src; } if (strncasecmp(src, "exec", 4)) { return 0; /* it's gotta start with exec(ute) */ } while (!isspace(*src) && *src) { /* could be exec or execute */ ++src; } while (isspace(*src) && *src) { /* skip over whitespace between exec and proc name */ ++src; } start = src; if (DBIc_DBISTATE(imp_dbh)->debug >= 5) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_describe_proc parsing: |%s|\n", start); } while (*src) { next_state = state; /* default situation */ switch (state) { case DEFAULT: if (*src == '[' || *src == '"') { // Determine the closing quote quote_char = (*src == '*' ? *src : ']'); next_state = QUOTED; } break; case QUOTED: if (*src == quote_char) { next_state = DEFAULT; } break; } if (state == DEFAULT && isspace(*src)) { *src = '\0'; break; } ++src; state = next_state; } if (DBIc_DBISTATE(imp_dbh)->debug >= 5) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_describe_proc after parsing: %s\n", start); } if (state == QUOTED) { warn("DBD::Sybase - error parsing the proc name in the EXEC statement\n"); Safefree(buff); return 0; } strcpy(imp_sth->proc, start); Safefree(buff); return 1; } int syb_st_rows(SV *sth, imp_sth_t *imp_sth) { return imp_sth->numRows; } static void cleanUp(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth) { int i; int numCols = DBIc_NUM_FIELDS(imp_sth); // coldata could be null here if cleanUp() has already been called due to a // processing error in the describe() function. for (i = 0; i < numCols && imp_sth->coldata != NULL; ++i) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cleanUp() -> processing column %d\n", i); } if (imp_sth->coldata[i].type == CS_CHAR_TYPE || imp_sth->coldata[i].type == CS_LONGCHAR_TYPE || imp_sth->coldata[i].type == CS_TEXT_TYPE || imp_sth->coldata[i].type == CS_IMAGE_TYPE) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cleanUp() -> Safefree for %d, type %d\n", i, imp_sth->coldata[i].type); } Safefree(imp_sth->coldata[i].value.c); } } if (imp_sth->datafmt) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cleanUp() -> Safefree(datafmt)\n"); } Safefree(imp_sth->datafmt); } if (imp_sth->coldata) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cleanUp() -> Safefree(coldata)\n"); } Safefree(imp_sth->coldata); } imp_sth->numCols = 0; imp_sth->coldata = NULL; imp_sth->datafmt = NULL; } static CS_RETCODE describe(SV* sth, imp_sth_t* imp_sth, int restype) { dTHX; D_imp_dbh_from_sth; CS_RETCODE retcode; int i; int numCols; AV* av; if((retcode = ct_res_info(imp_sth->cmd, CS_NUMDATA, &numCols, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("ct_res_info() failed"); goto GoodBye; } if(numCols <= 0) { warn("ct_res_info() returned 0 columns"); DBIc_NUM_FIELDS(imp_sth) = numCols; imp_sth->numCols = 0; goto GoodBye; } if(DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_res_info() returns %d columns\n", numCols); } /* According to Tim Bunce I shouldn't need the code below. However, if I remove it DBD::Sybase segfaults in some situations with DBI < 1.53, and there are still problems with COMPUTE BY statements with DBI >= 1.54. */ /* Adjust NUM_OF_FIELDS - which also adjusts the row buffer size */ DBIc_NUM_FIELDS(imp_sth) = 0; /* for DBI <= 1.53 */ DBIc_DBISTATE(imp_sth)->set_attr_k(sth, sv_2mortal(newSVpvn("NUM_OF_FIELDS", 13)), 0, sv_2mortal(newSViv(numCols))); #if 1 /* for DBI <= 1.53 (and 1.54 which doesn't shrink properly) */ av = DBIc_FIELDS_AV(imp_sth); if(av && av_len(av) + 1 != numCols) { SvREADONLY_off(av); /* DBI sets this readonly */ av_clear(av); i = numCols; while(i--) { av_store(av, i, newSV(0)); } SvREADONLY_on(av); /* DBI sets this readonly */ } #endif imp_sth->numCols = numCols; Newz(902, imp_sth->coldata, numCols, ColData); Newz(902, imp_sth->datafmt, numCols, CS_DATAFMT); /* this routine may be called without the connection reference */ if(restype == CS_COMPUTE_RESULT) { CS_INT comp_id, outlen; if((retcode = ct_compute_info(imp_sth->cmd, CS_COMP_ID, CS_UNUSED, &comp_id, CS_UNUSED, &outlen)) != CS_SUCCEED) { warn("ct_compute_info failed"); goto GoodBye; } } for(i = 0; i < numCols; ++i) { if((retcode = ct_describe(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i])) != CS_SUCCEED) { warn("ct_describe() failed"); cleanUp(imp_dbh, imp_sth); goto GoodBye; } /* Make sure we have at least some sort of column name: */ if(imp_sth->datafmt[i].namelen == 0) { sprintf(imp_sth->datafmt[i].name, "COL(%d)", i + 1); } if(restype == CS_COMPUTE_RESULT) { CS_INT agg_op, outlen; CS_CHAR* agg_op_name; if((retcode = ct_compute_info(imp_sth->cmd, CS_COMP_OP, (i + 1), &agg_op, CS_UNUSED, &outlen)) != CS_SUCCEED) { warn("ct_compute_info failed"); goto GoodBye; } agg_op_name = GetAggOp(agg_op); if((retcode = ct_compute_info(imp_sth->cmd, CS_COMP_COLID, (i + 1), &agg_op, CS_UNUSED, &outlen)) != CS_SUCCEED) { warn("ct_compute_info failed"); goto GoodBye; } sprintf(imp_sth->datafmt[i].name, "%s(%d)", agg_op_name, agg_op); } if(DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_describe(%d): type = %d, maxlen = %d\n", i, imp_sth->datafmt[i].datatype, imp_sth->datafmt[i].maxlength); } imp_sth->coldata[i].realType = imp_sth->datafmt[i].datatype; imp_sth->coldata[i].realLength = imp_sth->datafmt[i].maxlength; imp_sth->datafmt[i].locale = LOCALE(imp_dbh); switch(imp_sth->datafmt[i].datatype) { case CS_BIT_TYPE: case CS_TINYINT_TYPE: case CS_SMALLINT_TYPE: case CS_INT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_INT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_INT_TYPE; imp_sth->datafmt[i].datatype = CS_INT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.i, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #if defined(SYB_NATIVE_NUM) && defined(CS_UINT_TYPE) case CS_USMALLINT_TYPE: case CS_UINT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_INT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_UINT_TYPE; imp_sth->datafmt[i].datatype = CS_UINT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.ui, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #endif #if defined(SYB_NATIVE_NUM) #if defined(CS_BIGINT_TYPE) case CS_BIGINT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_BIGINT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_BIGINT_TYPE; imp_sth->datafmt[i].datatype = CS_BIGINT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.bi, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #endif #if defined(CS_UBIGINT_TYPE) case CS_UBIGINT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_UBIGINT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_UBIGINT_TYPE; imp_sth->datafmt[i].datatype = CS_UBIGINT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.ubi, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #endif #endif #if defined(SYB_NATIVE_NUM) case CS_MONEY_TYPE: case CS_MONEY4_TYPE: #endif case CS_REAL_TYPE: case CS_FLOAT_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_FLOAT); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_FLOAT_TYPE; imp_sth->datafmt[i].datatype = CS_FLOAT_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.f, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; case CS_TEXT_TYPE: case CS_IMAGE_TYPE: #if defined(CS_UNITEXT_TYPE) case CS_UNITEXT_TYPE: #endif New(902, imp_sth->coldata[i].value.c, imp_sth->datafmt[i].maxlength, char); imp_sth->datafmt[i].format = CS_FMT_UNUSED; /*CS_FMT_NULLTERM;*/ if(imp_dbh->binaryImage) { imp_sth->coldata[i].type = imp_sth->datafmt[i].datatype; } else { imp_sth->coldata[i].type = CS_TEXT_TYPE; imp_sth->datafmt[i].datatype = CS_TEXT_TYPE; } if(!imp_sth->noBindBlob) { retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], imp_sth->coldata[i].value.c, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); } break; case CS_DATETIME_TYPE: case CS_DATETIME4_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_DATETIME); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_DATETIME_TYPE; imp_sth->datafmt[i].datatype = CS_DATETIME_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.dt, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_DATE); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_DATE_TYPE; imp_sth->datafmt[i].datatype = CS_DATE_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.d, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; case CS_TIME_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_TIME); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_TIME_TYPE; imp_sth->datafmt[i].datatype = CS_TIME_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.t, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #endif #if defined(CS_BIGDATETIME_TYPE) case CS_BIGDATETIME_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_BIGDATETIME); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_BIGDATETIME_TYPE; imp_sth->datafmt[i].datatype = CS_BIGDATETIME_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.bdt, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; case CS_BIGTIME_TYPE: imp_sth->datafmt[i].maxlength = sizeof(CS_BIGTIME); imp_sth->datafmt[i].format = CS_FMT_UNUSED; imp_sth->coldata[i].type = CS_BIGTIME_TYPE; imp_sth->datafmt[i].datatype = CS_BIGTIME_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], &imp_sth->coldata[i].value.bt, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); break; #endif case CS_CHAR_TYPE: case CS_LONGCHAR_TYPE: case CS_VARCHAR_TYPE: case CS_BINARY_TYPE: case CS_VARBINARY_TYPE: case CS_NUMERIC_TYPE: case CS_DECIMAL_TYPE: default: imp_sth->datafmt[i].maxlength = get_cwidth(&imp_sth->datafmt[i]) + 1; /* MS-SQL has a varchar(max) type that will return the maxlength as INT_MAX. The +1 above will cause this to overflow and result in a negative value. */ if (imp_sth->datafmt[i].maxlength < 0) { /* Note that this is still going to try to allocate a really large buffer, so this won't really solve the issue of how any varchar(max) columns are retrieved. For text/image data this is normally handled via the TEXTLIMIT option which caps the size of any retrieved data to something reasonable that the client app/program can be expected to handle. */ imp_sth->datafmt[i].maxlength = INT_MAX; } imp_sth->datafmt[i].format = CS_FMT_UNUSED; New(902, imp_sth->coldata[i].value.c, imp_sth->datafmt[i].maxlength, char); imp_sth->coldata[i].type = CS_CHAR_TYPE; imp_sth->datafmt[i].datatype = CS_CHAR_TYPE; retcode = ct_bind(imp_sth->cmd, (i + 1), &imp_sth->datafmt[i], imp_sth->coldata[i].value.c, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); /* Now that we've accomplished the CHAR actions, set the type back to BINARY if appropriate, so the useBin0x actions work later. */ if(imp_sth->coldata[i].realType == CS_BINARY_TYPE || imp_sth->coldata[i].realType == CS_VARBINARY_TYPE) { imp_sth->coldata[i].type = imp_sth->datafmt[i].datatype = imp_sth->coldata[i].realType; } break; } /* check the return code of the call to ct_bind in the switch above: */ if(retcode != CS_SUCCEED) { warn("ct_bind() failed"); cleanUp(imp_dbh, imp_sth); break; } if(DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " describe() -> col %d, type %d, realtype %d\n", i, imp_sth->coldata[i].type, imp_sth->coldata[i].realType); } } GoodBye:; if(retcode == CS_SUCCEED) { imp_sth->done_desc = 1; } else { // If we haven't been able to describe this result set correctly, then we won't be able to fetch it // So we probably need to cancel the request: if(DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " describe() retcode is NOT CS_SUCCEED - canceling the request.\n"); } // disable flushFinish if it is set: int flushFinish = imp_dbh->flushFinish; imp_dbh->flushFinish = 0; syb_st_finish(sth, imp_sth); imp_dbh->flushFinish = flushFinish; } return retcode == CS_SUCCEED; } static void clear_sth_flags(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " clear_sth_flags() -> resetting ACTIVE, moreResults, dyn_execed, exec_done\n"); } imp_sth->moreResults = 0; imp_sth->dyn_execed = 0; imp_sth->exec_done = 0; if (!imp_sth->connection) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " clear_sth_flags() -> reset inUse flag\n"); } imp_dbh->inUse = 0; } } static int st_next_result(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; CS_COMMAND *cmd = imp_sth->cmd; CS_INT restype; CS_RETCODE retcode; int failFlag = 0; imp_sth->numRows = -1; while ((retcode = ct_results(cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> ct_results(%d) == %d\n", restype, retcode); } if (restype == CS_CMD_FAIL) { failFlag = 1; } if ((restype == CS_CMD_DONE || restype == CS_CMD_SUCCEED) && !failFlag) { ct_res_info(cmd, CS_ROW_COUNT, &imp_sth->numRows, CS_UNUSED, NULL); } switch (restype) { case CS_ROW_RESULT: case CS_PARAM_RESULT: case CS_STATUS_RESULT: case CS_CURSOR_RESULT: case CS_COMPUTE_RESULT: if (imp_sth->done_desc) { cleanUp(imp_dbh, imp_sth); clear_cache(sth, imp_sth); } retcode = describe(sth, imp_sth, restype); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "describe() retcode = %d\n", retcode); } if (restype == CS_STATUS_RESULT && (imp_sth->doProcStatus || (imp_sth->dyn_execed && imp_sth->type == 0))) { CS_INT rows_read; retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows_read); if (retcode == CS_SUCCEED) { imp_sth->lastProcStatus = imp_sth->coldata[0].value.i; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "describe() proc status code = %d\n", imp_sth->lastProcStatus); } if (imp_sth->lastProcStatus != 0) { failFlag = 2; } } else { croak("ct_fetch() for proc status failed!"); } while ((retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows_read))) { if (retcode == CS_END_DATA || retcode == CS_FAIL) { break; } } } else { goto Done; } /* exit from the ct_results() loop here if we are *NOT* in doProcStatus mode, and this is *NOT* a status result set */ } } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "ct_results(%d) final retcode = %d\n", restype, retcode); } Done: /* The lasterr/lastsev is a hack to work around Sybase OpenClient, which does NOT return CS_CMD_FAIL for constraint errors when inserting/updating data using ?-style placeholders. */ if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> lasterr = %d, lastsev = %d\n", imp_dbh->lasterr, imp_dbh->lastsev); } /* Only force a failure if there are no rows to be fetched (ie on a normal insert/update/delete operation */ if (!failFlag && imp_dbh->lasterr != 0 && imp_dbh->lastsev > 10) { if (imp_dbh->alwaysForceFailure || (restype != CS_STATUS_RESULT && restype != CS_ROW_RESULT && restype != CS_PARAM_RESULT && restype != CS_CURSOR_RESULT && restype != CS_COMPUTE_RESULT)) { failFlag = 3; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " st_next_result() -> restype is not data result or syb_cancel_request_on_error is TRUE, force failFlag\n"); } } else { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> restype is data result, do NOT force failFlag\n"); } } } /* Cancel the whole thing if we force a failure */ /* Blaise Lepeuple, 9/26/02 */ /* Only do the flush if the failure was forced rather than "normal". In the normal case the connection is in a stable/idle state */ /* XXX */ if (failFlag && (restype != CS_CMD_DONE && restype != CS_CMD_FAIL) && retcode != CS_FAIL) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> failFlag set - clear request\n"); } syb_st_finish(sth, imp_sth); } /* FreeTDS added a result code CS_END_RESULTS */ /* Do the right thing with it Frederick Staats, 6/26/03 */ if (retcode == CS_END_RESULTS) { restype = CS_CMD_DONE; } if (failFlag || retcode == CS_FAIL || retcode == CS_CANCELED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " st_next_result() -> force CS_CMD_FAIL return\n"); } restype = CS_CMD_FAIL; } imp_sth->lastResType = restype; /* clear the handle here - to be sure to always have a consistent handle view after command completion. */ if (restype == CS_CMD_DONE || restype == CS_CMD_FAIL) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " st_next_result() -> got %s: resetting ACTIVE, moreResults, dyn_execed, exec_done\n", restype == CS_CMD_DONE ? "CS_CMD_DONE" : "CS_CMD_FAIL"); } clear_sth_flags(sth, imp_sth); DBIc_ACTIVE_off(imp_sth); } else { DBIc_ACTIVE_on(imp_sth); } return restype; } static int _convert(void *ptr, char *str, CS_LOCALE *locale, CS_DATAFMT *datafmt, CS_INT *len) { dTHX; CS_DATAFMT srcfmt; CS_INT retcode; CS_INT reslen; memset(&srcfmt, 0, sizeof(srcfmt)); srcfmt.datatype = CS_CHAR_TYPE; srcfmt.maxlength = strlen(str); srcfmt.format = CS_FMT_NULLTERM; srcfmt.locale = locale; retcode = cs_convert(context, &srcfmt, str, datafmt, ptr, &reslen); /* FIXME - DBIS slow in threaded mode */ if (DBIS->debug >= 3 && retcode != CS_SUCCEED || reslen == CS_UNUSED) { PerlIO_printf(DBILOGFP, "cs_convert failed (_convert(%s, %d))", str, datafmt->datatype); } if (len) { *len = reslen; } return retcode; } static CS_RETCODE get_cs_msg(CS_CONTEXT *context, char *msg, SV *sth, imp_sth_t *imp_sth) { dTHX; CS_CLIENTMSG errmsg; CS_INT lastmsg = 0; CS_RETCODE ret; memset((void*) &errmsg, 0, sizeof(CS_CLIENTMSG)); ret = cs_diag(context, CS_STATUS, CS_CLIENTMSG_TYPE, CS_UNUSED, &lastmsg); if (DBIc_DBISTATE(imp_sth)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_sth), "get_cs_msg -> cs_diag(CS_STATUS): lastmsg = %d (ret = %d)\n", lastmsg, ret); } if (ret != CS_SUCCEED) { warn("cs_diag(CS_STATUS) failed"); return ret; } ret = cs_diag(context, CS_GET, CS_CLIENTMSG_TYPE, lastmsg, &errmsg); if (DBIc_DBISTATE(imp_sth)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_sth), "get_cs_msg -> cs_diag(CS_GET) ret = %d, errmsg=%s\n", ret, errmsg.msgstring); } if (ret != CS_SUCCEED) { warn("cs_diag(CS_GET) failed"); return ret; } DBIh_SET_ERR_CHAR(sth, (imp_xxh_t *)imp_sth, NULL, CS_NUMBER(errmsg.msgnumber), errmsg.msgstring, NULL, NULL); if (cslib_cb) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSViv(CS_LAYER(errmsg.msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_ORIGIN(errmsg.msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_SEVERITY(errmsg.msgnumber)))); XPUSHs(sv_2mortal(newSViv(CS_NUMBER(errmsg.msgnumber)))); XPUSHs(sv_2mortal(newSVpv(errmsg.msgstring, 0))); if (errmsg.osstringlen > 0) { XPUSHs(sv_2mortal(newSVpv(errmsg.osstring, 0))); } else { XPUSHs(&PL_sv_undef); } if (msg) { XPUSHs(sv_2mortal(newSVpv(msg, 0))); } else { XPUSHs(&PL_sv_undef); } PUTBACK; if ((count = perl_call_sv(cslib_cb, G_SCALAR)) != 1) { croak("A cslib handler cannot return a LIST"); } SPAGAIN; retval = POPi; PUTBACK; FREETMPS; LEAVE; return retval == 1 ? CS_SUCCEED : CS_FAIL; } #if 0 PerlIO_printf(DBIc_LOGPIO(imp_dbh), "\nCS Library Message:\n"); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "Message number: LAYER = (%ld) ORIGIN = (%ld) ", CS_LAYER(errmsg.msgnumber), CS_ORIGIN(errmsg.msgnumber)); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "SEVERITY = (%ld) NUMBER = (%ld)\n", CS_SEVERITY(errmsg.msgnumber), CS_NUMBER(errmsg.msgnumber)); PerlIO_printf(DBIc_LOGPIO(imp_dbh), "Message String: %s\n", errmsg.msgstring); if(msg) PerlIO_printf(DBIc_LOGPIO(imp_dbh), "User Message: %s\n", msg); /*fflush(stderr);*/ #endif return CS_FAIL; } /* Allocate a buffer of the appropriate size for "datatype". Only works for fixed-size datatypes */ static void * alloc_datatype(CS_INT datatype, int *len) { void *ptr; int bytes; switch (datatype) { case CS_TINYINT_TYPE: bytes = sizeof(CS_TINYINT); break; case CS_SMALLINT_TYPE: bytes = sizeof(CS_SMALLINT); break; case CS_INT_TYPE: bytes = sizeof(CS_INT); break; case CS_REAL_TYPE: bytes = sizeof(CS_REAL); break; case CS_FLOAT_TYPE: bytes = sizeof(CS_FLOAT); break; case CS_BIT_TYPE: bytes = sizeof(CS_BIT); break; case CS_DATETIME_TYPE: bytes = sizeof(CS_DATETIME); break; case CS_DATETIME4_TYPE: bytes = sizeof(CS_DATETIME4); break; case CS_MONEY_TYPE: bytes = sizeof(CS_MONEY); break; case CS_MONEY4_TYPE: bytes = sizeof(CS_MONEY4); break; case CS_NUMERIC_TYPE: bytes = sizeof(CS_NUMERIC); break; case CS_DECIMAL_TYPE: bytes = sizeof(CS_DECIMAL); break; case CS_LONG_TYPE: bytes = sizeof(CS_LONG); break; #if 0 case CS_SENSITIVITY_TYPE: bytes = sizeof(CS_SENSITIVITY); break; case CS_BOUNDARY_TYPE: bytes = sizeof(CS_BOUNDARY); break; #endif case CS_USHORT_TYPE: bytes = sizeof(CS_USHORT); break; #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: bytes = sizeof(CS_DATE); break; case CS_TIME_TYPE: bytes = sizeof(CS_TIME); break; #endif #if defined(CS_BIGINT_TYPE) case CS_BIGINT_TYPE: bytes = sizeof(CS_BIGINT); break; case CS_USMALLINT_TYPE: bytes = sizeof(CS_USMALLINT); break; case CS_UINT_TYPE: bytes = sizeof(CS_UINT); break; case CS_UBIGINT_TYPE: bytes = sizeof(CS_UBIGINT); break; #endif #if defined(CS_BIGDATETIME_TYPE) case CS_BIGDATETIME_TYPE: bytes = sizeof(CS_BIGDATETIME); break; case CS_BIGTIME_TYPE: bytes = sizeof(CS_BIGTIME); break; #endif default: warn("alloc_datatype: unkown type: %d", datatype); return NULL; } Newz(902, ptr, bytes, char); *len = bytes; return ptr; } #if defined(NO_BLK) static int syb_blk_execute(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, SV *sth) { return -1; } #else static int syb_blk_execute(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, SV *sth) { dTHX; int i; char name[32]; void *ptr; CS_CONNECTION *con = imp_sth->connection ? imp_sth->connection : imp_dbh->connection; STRLEN slen; CS_INT vlen; SV **svp; phs_t *phs; CS_RETCODE ret; #if !defined(USE_CSLIB_CB) if (cs_diag(context, CS_CLEAR, CS_CLIENTMSG_TYPE, CS_UNUSED, NULL) != CS_SUCCEED) { warn("cs_diag(CS_CLEAR) failed"); } #endif for (i = 0; i < imp_sth->numCols; ++i) { sprintf(name, ":p%d", i + 1); svp = hv_fetch(imp_sth->all_params_hv, name, strlen(name), 0); phs = ((phs_t*) (void*) SvPVX(*svp)); phs->datafmt.format = CS_FMT_UNUSED; phs->datafmt.count = 1; if (!phs->sv || !SvOK(phs->sv) || phs->sv == &PL_sv_undef) { imp_sth->coldata[i].indicator = 0; ptr = ""; imp_sth->coldata[i].valuelen = 0; if (!imp_sth->bcpIdentityFlag && imp_sth->bcpIdentityCol == i + 1) { continue; } } else { imp_sth->coldata[i].ptr = SvPV(phs->sv, slen); imp_sth->coldata[i].indicator = 0; switch (phs->datafmt.datatype) { #if 0 case CS_NUMERIC_TYPE: case CS_DECIMAL_TYPE: if(_convert(&imp_sth->coldata[i].value.num, imp_sth->coldata[i].ptr, LOCALE(imp_dbh), &phs->datafmt, &vlen) != CS_SUCCEED) { /* If the error handler returns CS_FAIL, then FAIL this row! */ #if !defined(USE_CSLIB_CB) if(get_cs_msg(context, con) != CS_SUCCEED) goto FAIL; #else warn("BLK _convert(CS_NUMERIC, %s) failed - see cslib error.", imp_sth->coldata[i].ptr); #endif } imp_sth->coldata[i].valuelen = (vlen != CS_UNUSED ? vlen : sizeof(imp_sth->coldata[i].value.num)); ptr = &imp_sth->coldata[i].value.num; break; #endif case CS_BINARY_TYPE: case CS_LONGBINARY_TYPE: case CS_LONGCHAR_TYPE: case CS_TEXT_TYPE: case CS_IMAGE_TYPE: case CS_CHAR_TYPE: /* For these types send data "as is" */ ptr = imp_sth->coldata[i].ptr; imp_sth->coldata[i].valuelen = slen; break; #if defined(CS_UNICHAR_TYPE) case CS_UNICHAR_TYPE: /* For these types send data "as is" */ ptr = imp_sth->coldata[i].ptr; imp_sth->coldata[i].valuelen = slen * 2; break; #endif default: /* for all others, call cs_convert() before sending */ if (!imp_sth->coldata[i].v_alloc) { imp_sth->coldata[i].value.p = alloc_datatype(phs->datafmt.datatype, &imp_sth->coldata[i].v_alloc); } if (_convert(imp_sth->coldata[i].value.p, imp_sth->coldata[i].ptr, LOCALE(imp_dbh), &phs->datafmt, &vlen) != CS_SUCCEED) { char msg[255]; /* If the error handler returns CS_FAIL, then FAIL this row! */ #if !defined(USE_CSLIB_CB) sprintf(msg, "cs_convert failed: column %d: (_convert(%s, %d))", i + 1, (char *) imp_sth->coldata[i].ptr, phs->datafmt.datatype); ret = get_cs_msg(context, msg, sth, imp_sth); if (ret == CS_FAIL) { goto FAIL; } #else warn("cs_convert failed: column %d: (_convert(%s, %d))", i + 1, imp_sth->coldata[i].ptr, phs->datafmt.datatype); ret = CS_FAIL; goto FAIL; #endif } imp_sth->coldata[i].valuelen = (vlen != CS_UNUSED ? vlen : imp_sth->coldata[i].v_alloc); ptr = imp_sth->coldata[i].value.p; break; } } ret = blk_bind(imp_sth->bcp_desc, i + 1, &phs->datafmt, ptr, &imp_sth->coldata[i].valuelen, &imp_sth->coldata[i].indicator); if (DBIc_DBISTATE(imp_dbh)->debug >= 5) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "blk_bind %d -> '%s' (ret = %d)\n", i + 1, (char *)imp_sth->coldata[i].ptr, ret); } if (ret != CS_SUCCEED) { goto FAIL; } } ret = blk_rowxfer(imp_sth->bcp_desc); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "blk_rowxfer() -> %d\n", ret); } if (ret == CS_SUCCEED) { imp_sth->bcpRows++; } FAIL: ; return (ret == CS_SUCCEED ? -1 : -2); } #endif static int cmd_execute(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; if (imp_sth->statement == NULL) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " cmd_execute() -> can't execute a command with a NULL statement string.\n"); } syb_set_error(imp_dbh, -1, "execute() called with an invalid SQL string."); return -2; } if (!imp_sth->dyn_execed) { if (!imp_sth->cmd) { /* only allocate a CS_COMMAND struct if there isn't one already bug# 461 */ imp_sth->cmd = syb_alloc_cmd(imp_dbh, imp_sth->connection ? imp_sth->connection : imp_dbh->connection, 1); } if (ct_command(imp_sth->cmd, CS_LANG_CMD, imp_sth->statement, CS_NULLTERM, CS_UNUSED) != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " cmd_execute() -> ct_command() failed (cmd=%x, statement=%s, imp_sth=%x)\n", imp_sth->cmd, imp_sth->statement, imp_sth); } return -2; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cmd_execute() -> ct_command() OK\n"); } } if (ct_send(imp_sth->cmd) != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cmd_execute() -> ct_send() failed\n"); } return -2; } if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cmd_execute() -> ct_send() OK\n"); } imp_sth->exec_done = 1; if (!imp_sth->connection) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cmd_execute() -> set inUse flag\n"); } imp_dbh->inUse = 1; } return 0; } int syb_st_execute(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; int restype; #if 0 /* XXX */ if(DBIc_ACTIVE_KIDS(DBIc_PARENT_COM(imp_sth))) { /* Need to detect a possible simultaneous call here and either inhibit it, or open a new connection */ } #endif imp_dbh->lasterr = 0; imp_dbh->lastsev = 0; if (imp_sth->type == 2) { return syb_blk_execute(imp_dbh, imp_sth, sth); } if (!imp_sth->exec_done) { /* bind parameters if there are any */ CS_INT rows; int i; SV **phs_svp; char namebuf[30]; int namelen; phs_t *phs; int num_params = (int) DBIc_NUM_PARAMS(imp_sth); int foundOutput = 0; boundparams_t *params = 0; /* malloc the maximum possible size for output parameters */ params = malloc(sizeof(boundparams_t) * num_params ); for (i = 1; i <= num_params; ++i) { sprintf(namebuf, ":p%d", i); namelen = strlen(namebuf); phs_svp = hv_fetch(imp_sth->all_params_hv, namebuf, namelen, 0); if (phs_svp == NULL) { croak("Can't bind unknown placeholder '%s'", namebuf); } phs = (phs_t*) SvPVX(*phs_svp); /* placeholder struct */ /* if the parameter is an output and it is bound as an inout, * store the pointer, so we can use it for ct_bind */ if ( phs->is_inout && phs->is_boundinout ) { params[foundOutput].phs = phs; foundOutput++; } if (!_dbd_rebind_ph(sth, imp_sth, phs, 0)) { free(params); return -2; } } if (cmd_execute(sth, imp_sth) != 0) { free(params); return -2; } /* if we have output parameters, fetch the result */ if( foundOutput > 0 ) { while (ct_results(imp_sth->cmd, &restype) == CS_SUCCEED && restype != CS_CMD_DONE) { if (restype == CS_CMD_FAIL) { free(params); return -2; } /* ignore restype == CS_STATUS_RESULT */ if (restype == CS_PARAM_RESULT) { /* Since we have a parameter result, bind all the output parameters */ for (i = 0; i < foundOutput; i++) { CS_DATAFMT datafmt; phs = params[i].phs; /* find the maxlenght through ct_describe */ if( ct_describe(imp_sth->cmd, i+1, &datafmt) != CS_SUCCEED) { croak("ct_describe() failed"); } phs->datafmt.maxlength = datafmt.maxlength; /* Force to string with SvPOK_only (maybe use SvPV_force ). */ SvPOK_only(phs->sv); /* grow the output SV to the max length fetch will return */ SvGROW(phs->sv, phs->datafmt.maxlength ); /* bind the SV through pointer to the physical string in the SV, * store the returned length in the params array for adjustment after fetch */ if( ct_bind(imp_sth->cmd, i+1, &phs->datafmt, SvPVX(phs->sv), ¶ms[i].len, 0) != CS_SUCCEED ) syb_set_error(imp_dbh, -1, "ct_bind() for output param failed!"); } } /* fetch all results */ while((ct_fetch(imp_sth->cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows)) == CS_SUCCEED) { } } /* set the output SV to the correct lenght */ for (i = 0; i < foundOutput; i++) { SvCUR_set(params[i].phs->sv, params[i].len); } } free(params); } restype = st_next_result(sth, imp_sth); if (restype == CS_CMD_FAIL) { return -2; } return imp_sth->numRows; } int syb_st_cancel(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; CS_CONNECTION *connection = imp_sth->connection ? imp_sth->connection : imp_dbh->connection; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_cancel() -> ct_cancel(CS_CANCEL_ATTN)\n"); } if (ct_cancel(connection, NULL, CS_CANCEL_ATTN) == CS_FAIL) { ct_close(connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } return 1; } static int fix_fbav(imp_sth_t *imp_sth, int num_fields, AV *av) { #if 0 int clear_cache = 0; int i; D_imp_dbh_from_sth; if(DBIc_DBISTATE(imp_dbh)->debug >= 3) PerlIO_printf(DBIc_LOGPIO(imp_dbh), " fix_fbav() -> num_fields = %d, numCols = %d\n", num_fields, imp_sth->numCols); /* XXX The code in the if() below is likely to break with new versions of DBI!!! */ if(num_fields < imp_sth->numCols) { int isReadonly = SvREADONLY(av); ++clear_cache; if(isReadonly) SvREADONLY_off(av); /* DBI sets this readonly */ i = imp_sth->numCols - 1; while(i >= num_fields) av_store(av, i--, newSV(0)); num_fields = AvFILL(av)+1; if(isReadonly) SvREADONLY_on(av); /* protect against shift @$row etc */ } else if(num_fields> imp_sth->numCols) { int isReadonly = SvREADONLY(av); if(isReadonly) SvREADONLY_off(av); /* DBI sets this readonly */ av_fill(av, imp_sth->numCols - 1); num_fields = AvFILL(av)+1; if(isReadonly) SvREADONLY_on(av); /* protect against shift @$row etc */ ++clear_cache; } return clear_cache; #else return 1; #endif } static void clear_cache(SV *sth, imp_sth_t *imp_sth) { dTHX; /* Code from DBI::DBD */ /* Clear cached statement handle attributes, if necessary */ hv_delete((HV*) SvRV(sth), "NAME", 4, G_DISCARD); hv_delete((HV*) SvRV(sth), "NAME_lc", 7, G_DISCARD); hv_delete((HV*) SvRV(sth), "NAME_uc", 7, G_DISCARD); hv_delete((HV*) SvRV(sth), "NAME_hash", 9, G_DISCARD); hv_delete((HV*) SvRV(sth), "NAME_hash_lc", 12, G_DISCARD); hv_delete((HV*) SvRV(sth), "NAME_hash_uc", 12, G_DISCARD); hv_delete((HV*) SvRV(sth), "NULLABLE", 8, G_DISCARD); hv_delete((HV*) SvRV(sth), "NUM_OF_FIELDS", 13, G_DISCARD); hv_delete((HV*) SvRV(sth), "PRECISION", 9, G_DISCARD); hv_delete((HV*) SvRV(sth), "SCALE", 5, G_DISCARD); hv_delete((HV*) SvRV(sth), "TYPE", 4, G_DISCARD); } AV * syb_st_fetch(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; CS_COMMAND *cmd = imp_sth->cmd; CS_INT num_fields; int ChopBlanks; int i; AV *av; CS_RETCODE retcode; CS_INT rows_read, restype; int len; /* Check that execute() was executed sucessfully. This also implies */ /* that describe() executed sucessfuly so the memory buffers */ /* are allocated and bound. */ if (!DBIc_is(imp_sth, DBIcf_ACTIVE) || !imp_sth->exec_done) { return Nullav; } /* ** Find out how many columns there are in this result set. */ retcode = ct_res_info(cmd, CS_NUMDATA, &num_fields, CS_UNUSED, NULL); if (retcode != CS_SUCCEED) { croak(" syb_st_fetch(): ct_res_info() failed"); } ChopBlanks = DBIc_has(imp_sth, DBIcf_ChopBlanks); TryAgain: retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows_read); av = DBIc_DBISTATE(imp_dbh)->get_fbav(imp_sth); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_fetch() -> ct_fetch() = %d (%d rows, %d cols)\n", retcode, rows_read, num_fields); } switch (retcode) { case CS_ROW_FAIL: /* if LongTruncOK is off, then discard this row */ if (!DBIc_is(imp_sth, DBIcf_LongTruncOk)) goto TryAgain; case CS_SUCCEED: for (i = 0; i < num_fields; ++i) { SV *sv = AvARRAY(av)[i]; /* Note: we (re)use the SV in the AV */ len = 0; if (DBIc_DBISTATE(imp_dbh)->debug >= 5) { /*char *text = neatsvpv(phs->sv,0);*/ PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_fetch() -> %d/%d/%d\n", i, imp_sth->coldata[i].valuelen, imp_sth->coldata[i].type); } /* If we're beyond the number of items in this result set or: the data is null or: noBindBlob is set and the data type is IMAGE or TEXT then: set sv to undef */ if (i >= imp_sth->numCols || imp_sth->coldata[i].indicator == CS_NULLDATA || (imp_sth->noBindBlob && (imp_sth->datafmt[i].datatype == CS_TEXT_TYPE || imp_sth->datafmt[i].datatype == CS_IMAGE_TYPE))) { /* NULL data */ (void) SvOK_off(sv); } else { #define DATE_BUFF_LEN 50 char buff[DATE_BUFF_LEN]; /* used for date conversions */ switch (imp_sth->coldata[i].type) { case CS_IMAGE_TYPE: case CS_TEXT_TYPE: case CS_CHAR_TYPE: case CS_LONGCHAR_TYPE: len = imp_sth->coldata[i].valuelen; sv_setpvn(sv, imp_sth->coldata[i].value.c, len); if ((imp_sth->coldata[i].realType == CS_CHAR_TYPE || imp_sth->coldata[i].realType == CS_LONGCHAR_TYPE) && ChopBlanks) { char *p = SvEND(sv); int len = SvCUR(sv); while (len && *--p == ' ') { --len; } if (len != SvCUR(sv)) { SvCUR_set(sv, len); *SvEND(sv) = '\0'; } } #if defined(DBD_CAN_HANDLE_UTF8) if (imp_dbh->enable_utf8 && (imp_sth->coldata[i].realType == CS_UNICHAR_TYPE #if defined(CS_UNITEXT_TYPE) || imp_sth->coldata[i].realType == CS_UNITEXT_TYPE #endif )) { U8 *value = SvPV_nolen(sv); STRLEN len = SvCUR(sv); SvUTF8_off(sv); if (is_high_bit_set(value, len) && is_utf8_string(value, len)) { SvUTF8_on(sv); } } #endif break; case CS_FLOAT_TYPE: sv_setnv(sv, imp_sth->coldata[i].value.f); break; case CS_INT_TYPE: sv_setiv(sv, imp_sth->coldata[i].value.i); break; #if defined(CS_UINT_TYPE) case CS_UINT_TYPE: sv_setnv(sv, imp_sth->coldata[i].value.ui); break; #endif #if defined(CS_BIGINT_TYPE) case CS_BIGINT_TYPE: sv_setnv(sv, imp_sth->coldata[i].value.bi); break; #endif #if defined(CS_UBIGINT_TYPE) case CS_UBIGINT_TYPE: sv_setnv(sv, imp_sth->coldata[i].value.ubi); break; #endif case CS_BINARY_TYPE: case CS_VARBINARY_TYPE: if (imp_dbh->useBin0x) { /* Add 0x to the front */ sv_setpv(sv, "0x"); } else { /* stick in empty string so the concat works */ sv_setpv(sv, ""); } len = imp_sth->coldata[i].valuelen; sv_catpvn(sv, imp_sth->coldata[i].value.c, len); break; case CS_DATETIME_TYPE: #if defined(CS_BIGDATETIME_TYPE) case CS_BIGDATETIME_TYPE: #endif len = datetime2str(&imp_sth->coldata[i], &imp_sth->datafmt[i], buff, DATE_BUFF_LEN, imp_dbh->dateFmt, LOCALE(imp_dbh)); sv_setpvn(sv, buff, len); break; #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: len = date2str(&imp_sth->coldata[i].value.d, &imp_sth->datafmt[i], buff, DATE_BUFF_LEN, imp_dbh->dateFmt, LOCALE(imp_dbh)); sv_setpvn(sv, buff, len); break; case CS_TIME_TYPE: #if defined(CS_BIGTIME_TYPE) case CS_BIGTIME_TYPE: #endif len = time2str(&imp_sth->coldata[i], &imp_sth->datafmt[i], buff, DATE_BUFF_LEN, imp_dbh->dateFmt, LOCALE(imp_dbh)); sv_setpvn(sv, buff, len); break; #endif default: croak("syb_st_fetch: unknown datatype: %d, column %d", imp_sth->datafmt[i].datatype, i + 1); } } } break; case CS_FAIL: /* ohmygod */ /* FIXME: Should we call ct_cancel() here, or should we let the programmer handle it? */ if (ct_cancel(imp_dbh->connection, NULL, CS_CANCEL_ALL) == CS_FAIL) { ct_close(imp_dbh->connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } return Nullav; break; case CS_END_DATA: /* we've seen all the data for this result set. So see if this is the end of the result sets */ restype = st_next_result(sth, imp_sth); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_fetch() -> st_next_results() == %d\n", restype); } if (restype == CS_CMD_DONE || restype == CS_CMD_FAIL) { return Nullav; } else { if (restype == CS_COMPUTE_RESULT) { /* A compute result will most likely have a different (smaller) number of columns */ num_fields = imp_sth->numCols; goto TryAgain; } imp_sth->moreResults = 1; } return Nullav; break; case -4: /*TDS_INVALID_PARAMETER:*/ /* XXX is retcode right here */ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, Nullch, retcode, "TDS_INVALID_PARAMETER from ct_fetch", Nullch, Nullch); return Nullav; case -6: /* TDS_WRONG_STATE: */ /* XXX is retcode right here */ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, Nullch, retcode, "TDS_WRONG_STATE from ct_fetch", Nullch, Nullch); return Nullav; case CS_CANCELED: /* XXX is retcode right here */ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, Nullch, retcode, "Canceled", Nullch, Nullch); return Nullav; default: warn("ct_fetch() returned an unexpected retcode %ld", (long) retcode); /* treat as a failure to avoid risk of an endless loop */ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, Nullch, retcode, "Unexpected retcode from ct_fetch", Nullch, Nullch); return Nullav; } if (imp_dbh->row_cb) { dSP; int retval, count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newRV((SV*) av))); PUTBACK; if ((count = perl_call_sv(imp_dbh->row_cb, G_SCALAR)) != 1) { croak("An error handler can't return a LIST."); } SPAGAIN; retval = POPi; PUTBACK; FREETMPS; LEAVE; /* If the called sub returns 0 then we don't return the result set to the caller, so instead try to fetch the next row... */ if (retval == 0) { goto TryAgain; } } return av; } #if defined(DBD_CAN_HANDLE_UTF8) static int is_high_bit_set(const unsigned char *val, STRLEN size) { while (*val && size--) { if (*val++ & 0x80) return 1; } return 0; } #endif #if defined(NO_BLK) static int sth_blk_finish(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, SV *sth) { return 1; } #else static int sth_blk_finish(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth, SV *sth) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " sth_blk_finish() -> Checking for pending rows\n"); } /* If there are any pending rows they should be rolled back, based on the principle that only *explicitly* commited data should be kept. */ if (imp_sth->bcpRows > 0) { if (DBIc_WARN(imp_dbh)) { warn("finish: %d uncommited rows will be rolled back", imp_sth->bcpRows); } syb_blk_done(imp_sth, CS_BLK_CANCEL); } else if (imp_sth->bcpRows == 0) { syb_blk_done(imp_sth, CS_BLK_ALL); } blkCleanUp(imp_sth, imp_dbh); /* Reset autocommit for this handle (see syb_blk_init()) */ DBIc_set(imp_dbh, DBIcf_AutoCommit, imp_sth->bcpAutoCommit); toggle_autocommit(NULL, imp_dbh, imp_sth->bcpAutoCommit); clear_sth_flags(sth, imp_sth); imp_dbh->imp_sth = NULL; return 1; } #endif int syb_st_finish(SV *sth, imp_sth_t *imp_sth) { dTHX; D_imp_dbh_from_sth; CS_CONNECTION *connection; if (imp_sth->bcp_desc) { return sth_blk_finish(imp_dbh, imp_sth, sth); } connection = imp_sth->connection ? imp_sth->connection : imp_dbh->connection; /* The SvOK() test is from Henry Asseily. It is there to avoid a possible infinite loop in the case where the handle is active, but has been invalidated by OPenSwitch. */ /* Changed to check imp_dbh->lasterr instead */ /* if (imp_dbh->flushFinish && !(SvTRUE(DBIc_ERR(imp_dbh)))) { */ /* if (imp_dbh->flushFinish && !imp_dbh->lasterr) { */ /* It is believed that the fixes applied to st_next_result() makes the imp_dbh->lasterr check unnecessary */ if (imp_dbh->flushFinish) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_finish() -> flushing\n"); } /* The clear-error below actually causes any existing errors that may have been recorded to be "forgotten". In addition, stopping on any error (which could be a simple raiserror call rather than any actual error) will potentially leave results pending on the connection. So I have now removed the clear error and the check on any existing issues on the connection. In my testing this appears to work as expected with no bad side-effects. */ //DBIh_CLEAR_ERROR(imp_sth); /* so syb_st_fetch can tell us when something goes wrong */ while (DBIc_ACTIVE(imp_sth) && !imp_dbh->isDead && imp_sth->exec_done /*&& !SvTRUE(DBIc_ERR(imp_sth))*/ ) { AV *retval; do { retval = syb_st_fetch(sth, imp_sth); } while (retval && retval != Nullav); } } else { if (DBIc_ACTIVE(imp_sth)) { #if defined(ROGUE) if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_finish() -> ct_cancel(CS_CANCEL_CURRENT)\n"); } if(ct_cancel(NULL, imp_sth->cmd, CS_CANCEL_CURRENT) == CS_FAIL) { ct_close(connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } #else if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_finish() -> ct_cancel(CS_CANCEL_ALL)\n"); } if (ct_cancel(connection, NULL, CS_CANCEL_ALL) == CS_FAIL) { ct_close(connection, CS_FORCE_CLOSE); imp_dbh->isDead = 1; } #endif } } clear_sth_flags(sth, imp_sth); DBIc_ACTIVE_off(imp_sth); return 1; } static void dealloc_dynamic(imp_sth_t *imp_sth) { dTHX; CS_RETCODE ret; CS_INT restype; if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " dealloc_dynamic: ct_dynamic(CS_DEALLOC) for %s\n", imp_sth->dyn_id); } ret = ct_dynamic(imp_sth->cmd, CS_DEALLOC, imp_sth->dyn_id, CS_NULLTERM, NULL, CS_UNUSED); if (ret != CS_SUCCEED) { if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf( DBIc_LOGPIO(imp_sth), " dealloc_dynamic: ct_dynamic(CS_DEALLOC) for %s FAILED\n", imp_sth->dyn_id); } return; } ret = ct_send(imp_sth->cmd); if (ret != CS_SUCCEED) { if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " dealloc_dynamic: ct_send(CS_DEALLOC) for %s FAILED\n", imp_sth->dyn_id); } return; } while (ct_results(imp_sth->cmd, &restype) == CS_SUCCEED) { ; } 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 != &PL_sv_undef) { phs_t *phs_tpl = (phs_t*) (void*) SvPVX(sv); sv_free(phs_tpl->sv); } } sv_free((SV*) imp_sth->all_params_hv); } if (imp_sth->out_params_av) { sv_free((SV*) imp_sth->out_params_av); } imp_sth->all_params_hv = NULL; imp_sth->out_params_av = NULL; } void syb_st_destroy(SV *sth, imp_sth_t *imp_sth) { D_imp_dbh_from_sth; CS_RETCODE ret; dTHX; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy: called on %x...\n", imp_sth); } if (PL_dirty) { DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy: dirty set, skipping\n"); } return; } if (DBIc_ACTIVE(imp_dbh)) { if (!strncmp(imp_sth->dyn_id, "DBD", 3)) { dealloc_dynamic(imp_sth); } } /* moved from the prepare() call - as we need to have this around to re-execute non-dynamic statements... */ if (imp_sth->statement != NULL) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): freeing imp_sth->statement\n"); } Safefree(imp_sth->statement); imp_sth->statement = NULL; imp_dbh->sql = NULL; } cleanUp(imp_dbh, imp_sth); if (imp_sth->cmd) { /* Gene Ressler says that this call can fail because we've already dropped the connection. I'm not sure if this is really a problem or if it can be ignored. XXX */ if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_cmd_drop() -> CS_COMMAND %x\n", imp_sth->cmd); } ret = ct_cmd_drop(imp_sth->cmd); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): cmd dropped: %d\n", ret); } } /* reset BLK data, if needed */ if (imp_sth->bcp_desc) { /* XXX Should we call blk_done(CS_BLK_ALL) here??? */ if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): blkCleanUp()\n"); } sth_blk_finish(imp_dbh, imp_sth, sth); } if (imp_sth->connection) { ret = ct_close(imp_sth->connection, CS_FORCE_CLOSE); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): connection closed: %d\n", ret); } ct_con_drop(imp_sth->connection); } else { if (DBIc_ACTIVE(imp_sth)) { if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_st_destroy(): reset inUse flag\n"); } imp_dbh->inUse = 0; } } DBIc_ACTIVE_off(imp_sth); /* Don't want DBI warning about freeing active handle */ DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ } int syb_st_blob_read(SV *sth, imp_sth_t *imp_sth, int field, long offset, long len, SV *destrv, long destoffset) { return 1; } int syb_ct_get_data(SV *sth, imp_sth_t *imp_sth, int column, SV *bufrv, int buflen) { dTHX; CS_COMMAND *cmd = imp_sth->cmd; CS_VOID *buffer; /* CS_INT buflen = imp_sth->datafmt[column-1].maxlength; */ CS_INT outlen; CS_RETCODE ret; SV *bufsv; if (buflen == 0) { buflen = imp_sth->datafmt[column - 1].maxlength; } if (DBIc_DBISTATE(imp_sth)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " ct_get_data(%d): buflen = %d\n", column, buflen); } /* Fix PR/444: segfault if passed a non-reference SV for buffer */ if (!SvROK(bufrv)) { warn("ct_get_data: buffer parameter is not a reference!"); return 0; } bufsv = SvRV(bufrv); Newz(902, buffer, buflen, char); ret = ct_get_data(cmd, column, (CS_VOID*) buffer, buflen, &outlen); if (outlen) { sv_setpvn(bufsv, buffer, outlen); } else { sv_setsv(bufsv, &PL_sv_undef); } if (DBIc_DBISTATE(imp_sth)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " ct_get_data(%d): got %d bytes (ret = %d)\n", column, outlen, ret); } Safefree(buffer); return outlen; } int syb_ct_prepare_send(SV *sth, imp_sth_t *imp_sth) { return ct_command(imp_sth->cmd, CS_SEND_DATA_CMD, NULL, CS_UNUSED, CS_COLUMN_DATA) == CS_SUCCEED; } int syb_ct_finish_send(SV *sth, imp_sth_t *imp_sth) { CS_RETCODE retcode; CS_INT restype; D_imp_dbh_from_sth; retcode = ct_send(imp_sth->cmd); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_send() = %d\n", retcode); } if (retcode != CS_SUCCEED) { return 0; } while ((retcode = ct_results(imp_sth->cmd, &restype)) == CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_results(%d) = %d\n", restype, retcode); } if (restype == CS_PARAM_RESULT) { CS_DATAFMT datafmt; CS_INT count; retcode = ct_describe(imp_sth->cmd, 1, &datafmt); if (retcode != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_describe() failed\n"); } return 0; } datafmt.maxlength = sizeof(imp_dbh->iodesc.timestamp); datafmt.format = CS_FMT_UNUSED; if ((retcode = ct_bind(imp_sth->cmd, 1, &datafmt, (CS_VOID *) imp_dbh->iodesc.timestamp, &imp_dbh->iodesc.timestamplen, NULL)) != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_bind() failed\n"); } return 0; } retcode = ct_fetch(imp_sth->cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &count); if (retcode != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_fetch() failed\n"); } return 0; } /* success... so cancel the rest of this result set */ retcode = ct_cancel(NULL, imp_sth->cmd, CS_CANCEL_CURRENT); if (retcode != CS_SUCCEED) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_finish_send(): ct_fetch() failed\n"); } return 0; } } } return 1; } int syb_ct_send_data(SV *sth, imp_sth_t *imp_sth, char *buffer, int size) { dTHX; D_imp_dbh_from_sth; if (DBIc_DBISTATE(imp_sth)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " ct_send_data(): sending buffer size %d bytes\n", size); } return ct_send_data(imp_sth->cmd, buffer, size) == CS_SUCCEED; } int syb_ct_data_info(SV *sth, imp_sth_t *imp_sth, int action, int column, SV *attr) { dTHX; D_imp_dbh_from_sth; CS_COMMAND *cmd = imp_sth->cmd; CS_RETCODE ret; if (action == CS_SET) { /* we expect the app to maybe modify certain fields of the CS_IODESC struct. This is done via the attr hash that is passed in here */ if (attr && attr != &PL_sv_undef && SvROK(attr)) { SV **svp; svp = hv_fetch((HV*) SvRV(attr), "total_txtlen", 12, 0); if (svp && SvGMAGICAL(*svp)) { /* eg if from tainted expression */ mg_get(*svp); } if (svp && SvIOK(*svp)) { imp_dbh->iodesc.total_txtlen = SvIV(*svp); } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): set total_txtlen to %d\n", imp_dbh->iodesc.total_txtlen); } svp = hv_fetch((HV*) SvRV(attr), "log_on_update", 13, 0); if (svp && SvGMAGICAL(*svp)) { /* eg if from tainted expression */ mg_get(*svp); } if (svp && SvIOK(*svp)) { imp_dbh->iodesc.log_on_update = SvIV(*svp); } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): set log_on_update to %d\n", imp_dbh->iodesc.log_on_update); } } } if (action == CS_SET) { column = CS_UNUSED; } else { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): get IODESC for column %d\n", column); } } ret = ct_data_info(cmd, action, column, &imp_dbh->iodesc); if (action == CS_GET) { if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): ret = %d, total_txtlen = %d, textptr=%x, timestamp=%x, datatype=%d\n", ret, imp_dbh->iodesc.total_txtlen, imp_dbh->iodesc.textptr, imp_dbh->iodesc.timestamp, imp_dbh->iodesc.datatype); } if (imp_dbh->iodesc.textptrlen == 0) { DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, Nullch, 0, "ct_data_info(): text pointer is not set or is undefined. The text/image column may be uninitialized in the database for this row.", Nullch, Nullch); /*warn("ct_data_info(): text pointer is not set or is undefined. The text/image column may be uninitialized in the database for this row.");*/ return 0; } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): ret = %d, total_txtlen = %d\n", ret, imp_dbh->iodesc.total_txtlen); } } else if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " ct_data_info(): ret = %d\n", ret); } return ret == CS_SUCCEED; } /* Borrowed from DBD::ODBC */ typedef struct { const char *str; unsigned len :8; unsigned array :1; unsigned filler :23; } T_st_params; #define s_A(str) { str, sizeof(str)-1 } static T_st_params S_st_fetch_params[] = { s_A("NUM_OF_PARAMS"), /* 0 */ s_A("NUM_OF_FIELDS"), /* 1 */ s_A("NAME"), /* 2 */ s_A("NULLABLE"), /* 3 */ s_A("TYPE"), /* 4 */ s_A("PRECISION"), /* 5 */ s_A("SCALE"), /* 6 */ s_A("syb_more_results"), /* 7 */ s_A("LENGTH"), /* 8 */ s_A("syb_types"), /* 9 */ s_A("syb_result_type"), /* 10 */ s_A("LongReadLen"), /* 11 */ s_A("syb_proc_status"), /* 12 */ s_A("syb_do_proc_status"), /* 13 */ s_A("syb_no_bind_blob"), /* 14 */ s_A("CursorName"), /* 15 - PR/394 */ s_A(""), /* END */ }; static T_st_params S_st_store_params[] = { s_A("syb_do_proc_status"), /* 0 */ s_A("syb_no_bind_blob"), /* 1 */ s_A(""), /* END */ }; #undef s_A SV * syb_st_FETCH_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv) { dTHX; STRLEN kl; char *key = SvPV(keysv, kl); int i; SV *retsv = NULL; T_st_params *par; for (par = S_st_fetch_params; par->len > 0; par++) { if (par->len == kl && strEQ(key, par->str)) { break; } } if (par->len <= 0) { return Nullsv; } /* NUM_OF_PARAMS is handled by DBI, and the answer is available even if done_desc is not set. Hence we need to handle this here rather than in the switch() below. Fixes PR 591, patch supplied by machj@ders.cz */ if (par - S_st_fetch_params == 0) { return Nullsv; /* handled by DBI */ } if (!imp_sth->done_desc && (par - S_st_fetch_params) < 10) { /* Because of the way Sybase returns information on returned values in a SELECT statement we can't call describe() here. */ /* Changed Nullsv to PL_sv_undef here to fix PR 541. */ return Nullsv; } i = DBIc_NUM_FIELDS(imp_sth); AV *av; switch (par - S_st_fetch_params) { case 0: /* NUM_OF_PARAMS */ return Nullsv; /* handled by DBI */ case 1: /* NUM_OF_FIELDS */ retsv = newSViv(i); break; case 2: /* NAME */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) { av_store(av, i, newSVpv(imp_sth->datafmt[i].name, 0)); } break; case 3: /* NULLABLE */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) { av_store(av, i, (imp_sth->datafmt[i].status & CS_CANBENULL) ? newSViv(1) : newSViv(0)); } break; case 4: /* TYPE */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) { av_store(av, i, newSViv(map_syb_types(imp_sth->coldata[i].realType))); } break; case 5: /* PRECISION */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) { av_store(av, i, newSViv( imp_sth->datafmt[i].precision ? imp_sth->datafmt[i].precision : imp_sth->coldata[i].realLength)); } break; case 6: /* SCALE */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) { switch (imp_sth->coldata[i].realType) { case CS_NUMERIC_TYPE: case CS_DECIMAL_TYPE: av_store(av, i, newSViv(imp_sth->datafmt[i].scale)); break; default: av_store(av, i, newSVsv(&PL_sv_undef)); } } break; case 7: retsv = newSViv(imp_sth->moreResults); break; case 8: av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) { av_store(av, i, newSViv(imp_sth->coldata[i].realLength)); } break; case 9: /* syb_types: native datatypes */ av = newAV(); retsv = newRV(sv_2mortal((SV*) av)); while (--i >= 0) { av_store(av, i, newSViv(imp_sth->coldata[i].realType)); } break; case 10: retsv = newSViv(imp_sth->lastResType); break; case 11: retsv = newSViv(DBIc_LongReadLen(imp_sth)); break; case 12: retsv = newSViv(imp_sth->lastProcStatus); break; case 13: retsv = newSViv(imp_sth->doProcStatus); break; case 14: retsv = newSViv(imp_sth->noBindBlob); break; case 15: retsv = &PL_sv_undef; /* fix for PR/394 */ break; default: return Nullsv; } if (retsv == &PL_sv_no || retsv == &PL_sv_yes || retsv == &PL_sv_undef) { return retsv; } return sv_2mortal(retsv); } int syb_st_STORE_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv) { dTHX; STRLEN kl; char *key = SvPV(keysv, kl); T_st_params *par; if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " syb_st_STORE(): key = %s\n", key); } for (par = S_st_store_params; par->len > 0; par++) { if (par->len == kl && strEQ(key, par->str)) { break; } } if (par->len <= 0) { return FALSE; } if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " syb_st_STORE(): storing %d for key = %s\n", SvTRUE(valuesv), key); } switch (par - S_st_store_params) { case 0: if (SvTRUE(valuesv)) { imp_sth->doProcStatus = 1; } else { imp_sth->doProcStatus = 0; } return TRUE; case 1: if (SvTRUE(valuesv)) { imp_sth->noBindBlob = 1; } else { imp_sth->noBindBlob = 0; } return TRUE; } return FALSE; } static int datetime2str(ColData *colData, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale) { if (type == 0) { CS_DATAFMT dstfmt; memset(&dstfmt, 0, sizeof(dstfmt)); dstfmt.datatype = CS_CHAR_TYPE; dstfmt.maxlength = len; dstfmt.format = CS_FMT_NULLTERM; dstfmt.locale = locale; cs_convert(context, srcfmt, &colData->value.dt, &dstfmt, buff, &len); return len - 1; } else { CS_DATEREC rec; int datatype; void *value; #if defined(CS_BIGDATETIME_TYPE) if(srcfmt->datatype == CS_BIGDATETIME_TYPE) { datatype = CS_BIGDATETIME_TYPE; value = &colData->value.bdt; } else #endif { datatype = CS_DATETIME_TYPE; value = &colData->value.dt; } cs_dt_crack(context, datatype, value, &rec); /* Issue 130 - cs_dt_crack on bigdatetime does not set datemsecond - instead if fills datesecfrack */ #if defined(CS_BIGDATETIME_TYPE) if (rec.datesecprec > 0) { rec.datemsecond = rec.datesecfrac / 1000; } #endif if (type == 2) { sprintf(buff, "%4.4d-%2.2d-%2.2dT%2.2d:%2.2d:%2.2d.%3.3dZ", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } else { sprintf(buff, "%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d.%3.3d", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } return strlen(buff); } return 0; } #if defined(CS_DATE_TYPE) static int date2str(CS_DATE *d, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale) { if (type == 0) { CS_DATAFMT dstfmt; memset(&dstfmt, 0, sizeof(dstfmt)); dstfmt.datatype = CS_CHAR_TYPE; dstfmt.maxlength = len; dstfmt.format = CS_FMT_NULLTERM; dstfmt.locale = locale; cs_convert(context, srcfmt, d, &dstfmt, buff, &len); return len - 1; } else { CS_DATEREC rec; cs_dt_crack(context, CS_DATE_TYPE, d, &rec); if (type == 2) { sprintf(buff, "%4.4d-%2.2d-%2.2dT%2.2d:%2.2d:%2.2d.%3.3dZ", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } else { sprintf(buff, "%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d.%3.3d", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } return strlen(buff); } return 0; } static int time2str(ColData *colData, CS_DATAFMT *srcfmt, char *buff, CS_INT len, int type, CS_LOCALE *locale) { if (type == 0) { CS_DATAFMT dstfmt; memset(&dstfmt, 0, sizeof(dstfmt)); dstfmt.datatype = CS_CHAR_TYPE; dstfmt.maxlength = len; dstfmt.format = CS_FMT_NULLTERM; dstfmt.locale = locale; cs_convert(context, srcfmt, &colData->value.t, &dstfmt, buff, &len); return len - 1; } else { CS_DATEREC rec; int datatype; void *value; #if defined(CS_BIGTIME_TYPE) if (srcfmt->datatype == CS_BIGTIME_TYPE) { datatype = CS_BIGTIME_TYPE; value = &colData->value.bt; } else #endif { datatype = CS_TIME_TYPE; value = &colData->value.t; } cs_dt_crack(context, datatype, value, &rec); /* Issue 130 - cs_dt_crack on bigdatetime does not set datemsecond - instead if fills datesecfrack */ #if defined(CS_BIGTIME_TYPE) if (rec.datesecprec > 0) { rec.datemsecond = rec.datesecfrac / 1000; } #endif if (type == 2) { sprintf(buff, "%4.4d-%2.2d-%2.2dT%2.2d:%2.2d:%2.2d.%3.3dZ", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } else { sprintf(buff, "%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d.%3.3d", rec.dateyear, rec.datemonth + 1, rec.datedmonth, rec.datehour, rec.dateminute, rec.datesecond, rec.datemsecond); } return strlen(buff); } return 0; } #endif static int to_numeric(char *str, SV *sth, imp_sth_t *imp_sth, CS_DATAFMT *datafmt, int type, CS_NUMERIC *mn) { //CS_NUMERIC mn; D_imp_dbh_from_sth; CS_DATAFMT srcfmt; CS_INT reslen; char *p; memset(mn, 0, sizeof(*mn)); if (!str || !*str) { str = "0"; } memset(&srcfmt, 0, sizeof(srcfmt)); srcfmt.datatype = CS_CHAR_TYPE; srcfmt.format = CS_FMT_NULLTERM; srcfmt.locale = LOCALE(imp_dbh); /* According to https://github.com/mpeppler/DBD-Sybase/issues/31 we need to set the datafmt.maxlength value to 35. This is not needed with Sybase client libs, but with freetds and with MS-SQL servers. */ datafmt->maxlength = 35; if (type) { /* RPC call */ if ((p = strchr(str, '.'))) { datafmt->scale = strlen(p + 1); } else { datafmt->scale = 0; } datafmt->precision = strlen(str); } else { /* dynamic SQL */ /* If the number of digits after the . is larger than the 'scale' value in datafmt, then we need to adjust it. Otherwise the conversion fails */ if ((p = strchr(str, '.'))) { int len = strlen(++p); if (len > datafmt->scale) { if (p[datafmt->scale] < '5') { p[datafmt->scale] = 0; } else { p[datafmt->scale] = 0; len = strlen(str); while (len--) { if (str[len] == '.') { continue; } if (str[len] < '9') { str[len]++; break; } str[len] = '0'; if (len == 0) { char buf[64]; buf[0] = '1'; buf[1] = 0; strcat(buf, str); strcpy(str, buf); break; } } } } } } // ensure that the max length value for the source is adjusted to any changes that may have been // done above. This is needed because FreeTDS is very picky and doesn't honor the CS_FMT_NULLTERM // setting correctly in this situation. srcfmt.maxlength = strlen(str); if ((cs_convert(context, &srcfmt, str, datafmt, mn, &reslen) != CS_SUCCEED) || (reslen == CS_UNUSED)) { char msg[64]; sprintf(msg, "cs_convert failed: to_numeric(%s)\n", str); get_cs_msg(context, msg, sth, imp_sth); if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " cs_convert failed (to_numeric(%s), type=%d, scale=%d, precision=%d, maxlen=%d)\n", str, datafmt->datatype, datafmt->scale, datafmt->precision, datafmt->maxlength); //warn("cs_convert failed (to_numeric(%s))", str); } return 0; } return 1; } static CS_MONEY to_money(char *str, CS_LOCALE *locale) { CS_MONEY mn; CS_DATAFMT srcfmt, destfmt; CS_INT reslen; memset(&mn, 0, sizeof(mn)); if (!str) { return mn; } memset(&srcfmt, 0, sizeof(srcfmt)); srcfmt.datatype = CS_CHAR_TYPE; srcfmt.maxlength = strlen(str); srcfmt.format = CS_FMT_NULLTERM; srcfmt.locale = locale; memset(&destfmt, 0, sizeof(destfmt)); destfmt.datatype = CS_MONEY_TYPE; destfmt.locale = locale; destfmt.maxlength = sizeof(CS_MONEY); destfmt.format = CS_FMT_UNUSED; if (cs_convert(context, &srcfmt, str, &destfmt, &mn, &reslen) != CS_SUCCEED) { warn("cs_convert failed (to_money(%s))", str); } if (reslen == CS_UNUSED) { warn("conversion failed: to_money(%s)", str); } return mn; } static CS_BINARY * to_binary(char *str, STRLEN *outlen) { CS_BINARY *b, *b_ptr; char s[3], *strtol_end; STRLEN i, b_len; long int x; /* Advance past the 0x. We could use the value of syb_use_bin_0x to infer whether to advance or not, but it's just as easy to explicitly check. */ if (str[0] == '0' && str[1] == 'x') { str += 2; } /* The length of 'str' _should_ be even, but we go thru some acrobatics to handle an odd length. We won't flag it as invalid, just pretend it's okay. */ b_len = (strlen(str) + 1) / 2; b = (CS_BINARY *) safemalloc(b_len); memset(b, 0, b_len); memset(&s, '\0', 3); /* Pack the characters */ b_ptr = b; for (i = 0; i < b_len; i++, str += 2) { strncpy(s, str, 2); x = strtol(s, &strtol_end, 16); if (*strtol_end != '\0') { warn("conversion failed: invalid char '%c'", *strtol_end); break; } *b_ptr++ = x; } *outlen = b_len; return b; } static int _dbd_rebind_ph(SV *sth, imp_sth_t *imp_sth, phs_t *phs, int maxlen) { dTHX; D_imp_dbh_from_sth; CS_RETCODE rc; STRLEN value_len; int i_value; double d_value; void *value; CS_NUMERIC n_value; CS_MONEY m_value; #if defined(CS_BIGINT_TYPE) CS_BIGINT bi_value; CS_UINT ui_value; #endif CS_INT datatype; int free_value = 0; /* determine the value, and length that we wish to pass to ct_param() */ datatype = phs->datafmt.datatype; if (DBIc_DBISTATE(imp_dbh)->debug >= 3) { char *text = neatsvpv(phs->sv, 0); PerlIO_printf(DBIc_LOGPIO(imp_dbh), " bind %s (%s) <== %s (", phs->name, phs->varname, text); if (SvOK(phs->sv)) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "size %ld/%ld/%ld, ", (long) SvCUR(phs->sv), (long) SvLEN(phs->sv), phs->maxlen); } else { PerlIO_printf(DBIc_LOGPIO(imp_dbh), "NULL, "); } PerlIO_printf(DBIc_LOGPIO(imp_dbh), "ptype %d, otype %d, datatype %d)\n", (int) SvTYPE(phs->sv), phs->ftype, datatype); } /* 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->sv_buf, and value_len. */ if (SvOK(phs->sv)) { phs->sv_buf = SvPV(phs->sv, value_len); switch (phs->datafmt.datatype) { case CS_INT_TYPE: case CS_SMALLINT_TYPE: case CS_TINYINT_TYPE: case CS_BIT_TYPE: phs->datafmt.datatype = CS_INT_TYPE; i_value = atoi(phs->sv_buf); value = &i_value; value_len = 4; break; #if defined(CS_UINT_TYPE) case CS_UINT_TYPE: case CS_USMALLINT_TYPE: phs->datafmt.datatype = CS_UINT_TYPE; ui_value = atoi(phs->sv_buf); value = &ui_value; value_len = 4; break; #endif #if defined(CS_BIGINT_TYPE) case CS_BIGINT_TYPE: // A CS_BIGINT is defined as long long, or _int64_t or various other typedefs // depending on the platform - so taking a guess here that atoll() will work! phs->datafmt.datatype = CS_BIGINT_TYPE; bi_value = atoll(phs->sv_buf); value = &bi_value; value_len = 8; break; #endif case CS_NUMERIC_TYPE: case CS_DECIMAL_TYPE: rc = to_numeric(phs->sv_buf, sth, imp_sth, &phs->datafmt, imp_sth->type, &n_value); if(!rc) { char errbuf[64]; sprintf(errbuf, "to_numeric() failed for '%s'", phs->sv_buf); syb_set_error(imp_dbh, -1, errbuf); return 0; } phs->datafmt.datatype = CS_NUMERIC_TYPE; value = &n_value; value_len = sizeof(n_value); break; case CS_MONEY_TYPE: case CS_MONEY4_TYPE: m_value = to_money(phs->sv_buf, LOCALE(imp_dbh)); phs->datafmt.datatype = CS_MONEY_TYPE; value = &m_value; value_len = sizeof(m_value); break; case CS_REAL_TYPE: case CS_FLOAT_TYPE: phs->datafmt.datatype = CS_FLOAT_TYPE; d_value = atof(phs->sv_buf); value = &d_value; value_len = sizeof(double); break; case CS_BINARY_TYPE: /* If this binary value is in hex format, with or without the leading 0x, then convert to actual binary value. Fix contributed by Tim Ayers */ phs->datafmt.datatype = CS_BINARY_TYPE; if ((phs->sv_buf[0] == '0' && phs->sv_buf[1] == 'x') || strspn( phs->sv_buf, "abcdefABCDEF0123456789") == value_len) { value = to_binary(phs->sv_buf, &value_len); /*warn("Got value = '%s'\n", value);*/ ++free_value; } else { value = phs->sv_buf; } /* value_len = SvCUR(phs->sv_buf); */ break; case CS_DATETIME_TYPE: case CS_DATETIME4_TYPE: phs->datafmt.datatype = CS_CHAR_TYPE; value = phs->sv_buf; value_len = CS_NULLTERM; /* PR/464: datetime values get converted to "jan 1 1900" if turned into a single space */ if (*(char*) value == 0) { value = NULL; value_len = CS_UNUSED; } break; default: phs->datafmt.datatype = CS_CHAR_TYPE; value = phs->sv_buf; /*value_len = CS_NULLTERM;*//*Allow embedded NUL bytes in strings?*/ /* PR/446: should an empty string cause a NULL, or not? */ if (*(char*) value == 0) { if (imp_dbh->bindEmptyStringNull) { value = NULL; value_len = CS_UNUSED; } else { value = " "; value_len = CS_NULLTERM; /* PR/624 */ } } break; } } else { /* it's null but point to buffer incase it's an out var */ phs->sv_buf = SvPVX(phs->sv); value_len = 0; value = NULL; } phs->sv_type = SvTYPE(phs->sv); /* part of mutation check */ phs->maxlen = SvLEN(phs->sv) - 1; /* avail buffer space */ /* value_len has current value length */ if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " bind %s <== '%.100s' (size %d, ok %d)\n", phs->name, phs->sv_buf, phs->maxlen, SvOK(phs->sv) ? 1 : 0); PerlIO_printf(DBIc_LOGPIO(imp_dbh), " datafmt: type=%d, name=%s, status=%d, len=%ld\n", phs->datafmt.datatype, phs->datafmt.name, phs->datafmt.status, value_len); PerlIO_printf(DBIc_LOGPIO(imp_dbh), " saved type: %d\n", datatype); } #if 0 /* If this handle is still active call finish()... */ if(DBIc_ACTIVE(imp_sth) && imp_sth->exec_done) { int finish = imp_dbh->flushFinish; imp_dbh->flushFinish = 1; syb_st_finish(sth, imp_sth); imp_dbh->flushFinish = finish; } #endif if (imp_sth->dyn_execed == 0) { if (imp_sth->type == 0) { if (ct_dynamic(imp_sth->cmd, CS_EXECUTE, imp_sth->dyn_id, CS_NULLTERM, NULL, CS_UNUSED) != CS_SUCCEED) return 0; } else if (imp_sth->type == 1) { if (ct_command(imp_sth->cmd, CS_RPC_CMD, imp_sth->proc, CS_NULLTERM, CS_NO_RECOMPILE) != CS_SUCCEED) { char errbuf[1024]; sprintf(errbuf, "ct_command(CS_RPC_CMD, %s) failed\n", imp_sth->proc); syb_set_error(imp_dbh, -1, errbuf); return 0; } } imp_sth->dyn_execed = 1; } if ((rc = ct_param(imp_sth->cmd, &phs->datafmt, value, value_len, 0)) != CS_SUCCEED) { syb_set_error(imp_dbh, -1, "ct_param() failed!"); } phs->datafmt.datatype = datatype; if (free_value && value != NULL) { Safefree(value); } return (rc == CS_SUCCEED); } int syb_bind_ph(SV *sth, imp_sth_t *imp_sth, SV *ph_namesv, SV *newvalue, IV sql_type, SV *attribs, int is_inout, IV maxlen) { dTHX; SV **phs_svp; STRLEN name_len; char *name; char namebuf[30]; phs_t *phs; STRLEN lna; D_imp_dbh_from_sth; #if 1 /* If this handle is still active call finish()... */ if (DBIc_ACTIVE(imp_sth) && imp_sth->exec_done) { int finish = imp_dbh->flushFinish; imp_dbh->flushFinish = 1; syb_st_finish(sth, imp_sth); imp_dbh->flushFinish = finish; } #endif /* This is the way Tim does it in DBD::Oracle to get around the tainted issue. */ 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); } if (SvTYPE(newvalue) > SVt_PVLV) { /* hook for later array logic */ croak("Can't bind non-scalar value (currently)"); } #if 0 if (SvTYPE(newvalue) == SVt_PVLV && is_inout) /* may allow later */ croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)"); #endif if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), "bind %s <== '%.200s' (attribs: %s)\n", name, SvPV(newvalue, lna), attribs ? SvPV(attribs, lna) : ""); } phs_svp = hv_fetch(imp_sth->all_params_hv, name, name_len, 0); if (phs_svp == NULL) { croak("Can't bind unknown placeholder '%s'", name); } phs = (phs_t*) SvPVX(*phs_svp); /* placeholder struct */ if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " parameter is output [%s]\n", is_inout ? "true" : "false" ); } if (phs->sv == &PL_sv_undef) { /* first bind for this placeholder */ phs->sql_type = (sql_type) ? sql_type : SQL_CHAR; phs->ftype = map_sql_types(phs->sql_type); if (imp_sth->type == 1) { /* RPC call, must set up the datafmt struct */ if (phs->varname[0] == '@') { strcpy(phs->datafmt.name, phs->varname); phs->datafmt.namelen = strlen(phs->varname); } else { phs->datafmt.namelen = 0; } phs->datafmt.datatype = phs->ftype; phs->datafmt.status = phs->is_inout ? CS_RETURN : CS_INPUTVALUE; phs->datafmt.maxlength = 0; } phs->maxlen = maxlen; /* 0 if not inout */ /* phs->is_inout = is_inout; */ #if 0 if (is_inout) { phs->sv = SvREFCNT_inc(newvalue); /* point to live var */ ++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)); } #endif /* some types require the trailing null included in the length. */ phs->alen_incnull = 0; } #if 0 /* 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", phs->name); } #endif else if (maxlen && maxlen != phs->maxlen) { croak("Can't change param %s maxlen (%ld->%ld) after first bind", phs->name, phs->maxlen, maxlen); } if (!is_inout) { /* normal bind to take a (new) copy of current value */ if (phs->sv == &PL_sv_undef) { /* (first time bind) */ phs->sv = newSV(0); } sv_setsv(phs->sv, newvalue); phs->is_boundinout = 0; } else { phs->sv = SvREFCNT_inc(newvalue); /* Take a reference to the input variable */ phs->is_boundinout = 1; if (DBIc_DBISTATE(imp_sth)->debug >= 3) { PerlIO_printf(DBIc_LOGPIO(imp_sth), " parameter is bound as inout\n"); } } /* BLK binding done at execute time, in a loop */ if (imp_sth->type == 2) { return 1; } return 1; /* _dbd_rebind_ph(sth, imp_sth, phs, 0); */ } static CS_RETCODE fetch_data(imp_dbh_t *imp_dbh, CS_COMMAND *cmd) { dTHX; CS_RETCODE retcode; CS_INT num_cols; CS_INT i; CS_INT j; CS_INT row_count = 0; CS_INT rows_read; CS_INT disp_len; CS_DATAFMT *datafmt; ColData *coldata; char buff[1024]; /* ** Find out how many columns there are in this result set. */ if ((retcode = ct_res_info(cmd, CS_NUMDATA, &num_cols, CS_UNUSED, NULL)) != CS_SUCCEED) { warn("fetch_data: ct_res_info() failed"); return retcode; } /* ** Make sure we have at least one column */ if (num_cols <= 0) { warn("fetch_data: ct_res_info() returned zero columns"); return CS_FAIL; } New(902, coldata, num_cols, ColData); New(902, datafmt, num_cols, CS_DATAFMT); for (i = 0; i < num_cols; i++) { if ((retcode = ct_describe(cmd, (i + 1), &datafmt[i])) != CS_SUCCEED) { warn("fetch_data: ct_describe() failed"); break; } datafmt[i].maxlength = display_dlen(&datafmt[i]) + 1; datafmt[i].datatype = CS_CHAR_TYPE; datafmt[i].format = CS_FMT_NULLTERM; New(902, coldata[i].value.c, datafmt[i].maxlength, char); if ((retcode = ct_bind(cmd, (i + 1), &datafmt[i], coldata[i].value.c, &coldata[i].valuelen, &coldata[i].indicator)) != CS_SUCCEED) { warn("fetch_data: ct_bind() failed"); break; } } if (retcode != CS_SUCCEED) { for (j = 0; j < i; j++) { Safefree(coldata[j].value.c); } Safefree(coldata); Safefree(datafmt); return retcode; } display_header(imp_dbh, num_cols, datafmt); while (((retcode = ct_fetch(cmd, CS_UNUSED, CS_UNUSED, CS_UNUSED, &rows_read)) == CS_SUCCEED) || (retcode == CS_ROW_FAIL)) { row_count = row_count + rows_read; /* ** Check if we hit a recoverable error. */ if (retcode == CS_ROW_FAIL) { sprintf(buff, "Error on row %d.\n", row_count); sv_catpv(DBIc_ERRSTR(imp_dbh), buff); } /* ** We have a row. Loop through the columns displaying the ** column values. */ for (i = 0; i < num_cols; i++) { /* ** Display the column value */ sv_catpv(DBIc_ERRSTR(imp_dbh), coldata[i].value.c); /* ** If not last column, Print out spaces between this ** column and next one. */ if (i != num_cols - 1) { disp_len = display_dlen(&datafmt[i]); disp_len -= coldata[i].valuelen - 1; for (j = 0; j < disp_len; j++) { sv_catpv(DBIc_ERRSTR(imp_dbh), " "); } } } sv_catpv(DBIc_ERRSTR(imp_dbh), "\n"); } /* ** Free allocated space. */ for (i = 0; i < num_cols; i++) { Safefree(coldata[i].value.c); } Safefree(coldata); Safefree(datafmt); /* ** We're done processing rows. Let's check the final return ** value of ct_fetch(). */ switch ((int) retcode) { case CS_END_DATA: retcode = CS_SUCCEED; break; case CS_FAIL: warn("fetch_data: ct_fetch() failed"); return retcode; break; default: /* unexpected return value! */ warn("fetch_data: ct_fetch() returned an expected retcode"); return retcode; break; } return retcode; } static int map_sql_types(int sql_type) { int ret; switch (sql_type) { case SQL_NUMERIC: case SQL_DECIMAL: ret = CS_NUMERIC_TYPE; break; case SQL_BIT: case SQL_INTEGER: case SQL_SMALLINT: case SQL_TINYINT: ret = CS_INT_TYPE; break; #if defined(CS_BIGINT_TYPE) case SQL_BIGINT: ret = CS_BIGINT_TYPE; break; #endif case SQL_FLOAT: case SQL_REAL: case SQL_DOUBLE: ret = CS_FLOAT_TYPE; break; case SQL_BINARY: return CS_BINARY_TYPE; break; default: ret = CS_CHAR_TYPE; } return ret; } static int map_syb_types(int syb_type) { switch (syb_type) { case CS_CHAR_TYPE: return SQL_CHAR; case CS_BINARY_TYPE: return SQL_BINARY; /* case CS_LONGCHAR_TYPE: return SQL_CHAR; * XXX */ /* case CS_LONGBINARY_TYPE: return SQL_BINARY; * XXX */ case CS_TEXT_TYPE: return SQL_LONGVARCHAR; /* XXX */ case CS_IMAGE_TYPE: return SQL_LONGVARBINARY; /* XXX */ case CS_BIT_TYPE: return SQL_BIT; case CS_TINYINT_TYPE: return SQL_TINYINT; case CS_SMALLINT_TYPE: return SQL_SMALLINT; case CS_INT_TYPE: return SQL_INTEGER; case CS_BIGINT_TYPE: return SQL_BIGINT; case CS_REAL_TYPE: return SQL_REAL; case CS_FLOAT_TYPE: return SQL_FLOAT; #if defined(CS_DATE_TYPE) case CS_DATE_TYPE: return SQL_DATE; #endif #if defined(CS_BIGDATETIME_TYPE) case CS_BIGDATETIME_TYPE: #endif case CS_DATETIME_TYPE: case CS_DATETIME4_TYPE: return SQL_DATETIME; #if defined(CS_BIGTIME_TYPE) case CS_BIGTIME_TYPE: #endif #if defined(CS_TIME_TYPE) case CS_TIME_TYPE: return SQL_TIME; #endif case CS_MONEY_TYPE: case CS_MONEY4_TYPE: case CS_DECIMAL_TYPE: return SQL_DECIMAL; case CS_NUMERIC_TYPE: return SQL_NUMERIC; case CS_VARCHAR_TYPE: return SQL_VARCHAR; case CS_VARBINARY_TYPE: return SQL_VARBINARY; /* case CS_TIMESTAMP_TYPE: return -3; */ default: return SQL_CHAR; } } static char *my_strdup(char *string) { char *buff = safemalloc(strlen(string) + 1); strcpy(buff, string); return buff; } static void fetchKerbTicket(imp_dbh_t *imp_dbh) { dTHX; if (imp_dbh->kerbGetTicket) { dSP; SV *retval; int count; char *server = imp_dbh->server; if (!*server) { char *s = getenv("DSQUERY"); if (s && *s) { server = s; } else { server = "SYBASE"; } } ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSVpv(server, 0))); PUTBACK; if ((count = perl_call_sv(imp_dbh->kerbGetTicket, G_SCALAR)) != 1) { croak("A Kerberos Ticket handler can't return a LIST."); } SPAGAIN; retval = POPs; PUTBACK; FREETMPS; LEAVE; if (SvPOK(retval)) { strncpy(imp_dbh->kerberosPrincipal, SvPVX(retval), 255); imp_dbh->kerberosPrincipal[31] = 0; } } } #if defined(NO_BLK) static CS_RETCODE syb_blk_init(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth) { return CS_SUCCEED; } #else static CS_RETCODE syb_blk_init(imp_dbh_t *imp_dbh, imp_sth_t *imp_sth) { dTHX; CS_RETCODE ret; char table[256]; int i, num_cols; SV **svp; phs_t *phs; char name[32]; if (!getTableName(imp_sth->statement, table, 256)) { char str[512]; sprintf(str, "Can't get table name from '%.256s'", imp_sth->statement); syb_set_error(imp_dbh, -1, str); return CS_FAIL; } if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_blk_init(): table=%s\n", table); } /* If AutoCommit is "officially" off here, then we need to make sure that Sybase thinks that it is *on*, otherwise the blk_init() call below will fail. */ if (!DBIc_is(imp_dbh, DBIcf_AutoCommit)) { toggle_autocommit(NULL, imp_dbh, 1); } ret = blk_alloc(imp_sth->connection ? imp_sth->connection : imp_dbh->connection, BLK_VERSION, &imp_sth->bcp_desc); if (ret != CS_SUCCEED) { goto FAIL; } ret = blk_props(imp_sth->bcp_desc, CS_SET, BLK_IDENTITY, (CS_VOID*) &imp_sth->bcpIdentityFlag, CS_UNUSED, NULL); if (ret != CS_SUCCEED) { goto FAIL; } ret = blk_init(imp_sth->bcp_desc, CS_BLK_IN, table, strlen(table)); if (ret != CS_SUCCEED) { goto FAIL; } num_cols = DBIc_NUM_PARAMS(imp_sth); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " syb_blk_init(): num_cols=%d, identityFlag=%d\n", num_cols, imp_sth->bcpIdentityFlag); } imp_sth->numCols = num_cols; /*Newz(902, imp_sth->datafmt, num_cols, CS_DATAFMT); */ Newz(902, imp_sth->coldata, num_cols, ColData); for (i = 1; i <= num_cols; ++i) { sprintf(name, ":p%d", i); svp = hv_fetch(imp_sth->all_params_hv, name, strlen(name), 0); phs = ((phs_t*) (void*) SvPVX(*svp)); memset(&phs->datafmt, 0, sizeof(CS_DATAFMT)); ret = blk_describe(imp_sth->bcp_desc, i, &phs->datafmt); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf( DBIc_LOGPIO(imp_dbh), " syb_blk_init: blk_describe()==%d col %d, type %d, status %d, length %d\n", ret, i, phs->datafmt.datatype, phs->datafmt.status, phs->datafmt.maxlength); } if (ret != CS_SUCCEED) { goto FAIL; } } FAIL: ; if (ret != CS_SUCCEED) { blkCleanUp(imp_sth, imp_dbh); } else { imp_dbh->imp_sth = imp_sth; /* hack! */ /* Turn off autocommit for this handle, mainly to silence warnings from Sybase.xsi's commit() implementation */ imp_sth->bcpAutoCommit = DBIc_is(imp_dbh, DBIcf_AutoCommit); DBIc_set(imp_dbh, DBIcf_AutoCommit, 0); } return ret; } #endif #if defined(NO_BLK) static void blkCleanUp(imp_sth_t *imp_sth, imp_dbh_t *imp_dbh) { ; } #else static void blkCleanUp(imp_sth_t *imp_sth, imp_dbh_t *imp_dbh) { int i; for (i = 0; i < imp_sth->numCols; ++i) { if (imp_sth->coldata[i].value.p && imp_sth->coldata[i].v_alloc) { Safefree(imp_sth->coldata[i].value.p); } } if (imp_sth->coldata) { Safefree(imp_sth->coldata); } imp_sth->numCols = 0; imp_sth->coldata = NULL; imp_sth->datafmt = NULL; if (imp_sth->bcp_desc) { CS_INT ret = blk_drop(imp_sth->bcp_desc); if (DBIc_DBISTATE(imp_dbh)->debug >= 4) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " blkCleanUp -> blk_drop(%d) = %d\n", imp_sth->bcp_desc, ret); } imp_sth->bcp_desc = NULL; } } #endif static int getTableName(char *statement, char *table, int maxwidth) { char *ptr = safemalloc(strlen(statement) + 1); char *p; strcpy(ptr, statement); p = strtok(ptr, " "); if (!p || !*p || strncasecmp(p, "insert", 7)) { goto FAIL; } p = strtok(NULL, " ("); if (!p || !*p) { goto FAIL; } if (!strncasecmp(p, "into", 4)) { p = strtok(NULL, " ("); } if (!p || !*p) { goto FAIL; } strncpy(table, p, maxwidth); Safefree(ptr); return 1; FAIL: Safefree(ptr); return 0; } SV *syb_set_cslib_cb(SV *cb) { #if 0 /*!defined(USE_CSLIB_CB)*/ warn("Can't set a CS-Lib callback: DBD::Sybase was not built with -DUSE_CSLIB_CB"); return &PL_sv_undef; #else dTHX; SV *old = cslib_cb; if (cslib_cb == (SV*) NULL) { cslib_cb = newSVsv(cb); } else { sv_setsv(cslib_cb, cb); } return old ? old : &PL_sv_undef; #endif } /* WARNING - dbh passed in here is in some cases NULL */ static int toggle_autocommit(SV *dbh, imp_dbh_t *imp_dbh, int flag) { CS_BOOL value; CS_RETCODE ret; int current = DBIc_is(imp_dbh, DBIcf_AutoCommit); if (!imp_dbh->init_done) { imp_dbh->init_done = 1; if (DBIc_DBISTATE(imp_dbh)->debug >= 5) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " toggle_autocommit: init_done not set, no action\n"); } return TRUE; } if (DBIc_DBISTATE(imp_dbh)->debug >= 5) { PerlIO_printf(DBIc_LOGPIO(imp_dbh), " toggle_autocommit: current = %s, new = %s\n", current ? "on" : "off", flag ? "on" : "off"); } if (flag) { if (!current && !imp_dbh->isMSSql) { /* Going from OFF to ON - so force a COMMIT on any open transaction. Note only doing this for Sybase servers as a bare COMMIT (outside of a transaction) is a no-op for Sybase, but generates an error/warning message for MS-SQL */ syb_db_commit(dbh, imp_dbh); } if (!imp_dbh->doRealTran) { value = CS_FALSE; ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); } } else { if (!imp_dbh->doRealTran) { value = CS_TRUE; ret = syb_set_options(imp_dbh, CS_SET, CS_OPT_CHAINXACTS, &value, CS_UNUSED, NULL); } } if (!imp_dbh->doRealTran && ret != CS_SUCCEED) { warn("Setting of CS_OPT_CHAINXACTS failed."); return FALSE; } return TRUE; } DBD-Sybase-1.24/CONFIG0000644000175000017500000000310214010471204014364 0ustar mpepplermpeppler# $Id: CONFIG,v 1.9 2003/03/31 23:55:11 mpeppler Exp $ # Configuration file for DBD::Sybase. # # The Makefile.PL file attempts to set reasonable defaults for the # variables in this file. # # Where is the Sybase directory on your system (include files & # libraries are expected to be found at SYBASE/include & SYBASE/lib # If not set, uses the SYBASE environment variable. SYBASE=$ENV{SYBASE}||'/opt/sybase' # Additional libraries. # Some systems require -lnsl or -lBSD. # Solaris 2.x needs -ltli # SGI IRIX needs -linsck (and may need need -ltli) # DEC OSF/1 needs -ldnet_stub and may need -lsdna and -linsck or -ltli # SunOS 4.x needs -linsck # HP-UX 10.x needs -linsck # AIX 3.2.5 needs -linsck # Linux needs -linsck # See the Sybase OpenClient Supplement for your OS/Hardware # combination. # If not set, will attempt to determine which libraries are needed by scanning the # $SYBASE/lib directory. EXTRA_LIBS= # DBI_INCLUDE # DBD::Sybase needs access to some C include files that are provided # by the DBI module. These are normally found in $Config{sitearchexp}/auto/DBI # but if they are in some other place on your system then you can specify # that directory here: # DBI_INCLUDE=/usr/local/lib/perl5/site_perl/sun4-solaris/ # BUILD_TYPE # Set this to 64 if you are building in 64 bit mode on a platform # that supports the 64bit OpenClient libraries (libct64.a, etc). # BUILD_TYPE=64 # LINKTYPE # If you wish to link DBD::Sybase statically # into perl uncomment the line below and run the make normally. Then, # when you run 'make test' a new perl binary will be built. #LINKTYPE=static DBD-Sybase-1.24/Sybase.h0000644000175000017500000001115114361730257015115 0ustar mpepplermpeppler/* $Id: Sybase.h,v 1.21 2011/10/02 14:53:49 mpeppler Exp $ Copyright (c) 1997 - 2011 Michael Peppler You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. */ #define NEED_DBIXS_VERSION 93 #define PERL_NO_GET_CONTEXT #include /* installed by the DBI module */ #include "dbivport.h" #include #include /* These defines avoid name clashes for multiple statically linked DBD's */ #define dbd_init syb_init #define dbd_db_login6 syb_db_login #define dbd_db_do syb_db_do #define dbd_db_commit syb_db_commit #define dbd_db_rollback syb_db_rollback #define dbd_db_disconnect syb_db_disconnect #define dbd_discon_all syb_discon_all #define dbd_db_destroy syb_db_destroy #define dbd_db_STORE_attrib syb_db_STORE_attrib #define dbd_db_FETCH_attrib syb_db_FETCH_attrib #define dbd_st_prepare syb_st_prepare #define dbd_st_rows syb_st_rows #define dbd_st_execute syb_st_execute #define dbd_st_fetch syb_st_fetch #define dbd_st_finish syb_st_finish #define dbd_st_destroy syb_st_destroy #define dbd_st_blob_read syb_st_blob_read #define dbd_st_STORE_attrib syb_st_STORE_attrib #define dbd_st_FETCH_attrib syb_st_FETCH_attrib #define dbd_describe syb_describe #define dbd_bind_ph syb_bind_ph /* read in our implementation details */ #include "dbdimp.h" #if defined(CS_CURRENT_VERSION) #define CTLIB_VERSION CS_CURRENT_VERSION #else #if defined(CS_VERSION_157) #define CTLIB_VERSION CS_VERSION_157 #else #if defined(CS_VERSION_155) #define CTLIB_VERSION CS_VERSION_155 #else #if defined(CS_VERSION_150) #define CTLIB_VERSION CS_VERSION_150 #else #if defined(CS_VERSION_125) #define CTLIB_VERSION CS_VERSION_125 #else #if defined(CS_VERSION_120) #define CTLIB_VERSION CS_VERSION_120 #else #if defined(CS_VERSION_110) #define CTLIB_VERSION CS_VERSION_110 #else #define CTLIB_VERSION CS_VERSION_100 #endif #endif #endif #endif #endif #endif #endif #if defined(CS_UNICHAR_TYPE) && defined(CS_VERSION_150) #if defined (is_utf8_string) #define DBD_CAN_HANDLE_UTF8 #endif #endif /*#define CTLIB_VERSION CS_VERSION_100 */ #ifndef MAX #define MAX(X,Y) (((X) > (Y)) ? (X) : (Y)) #endif #ifndef MIN #define MIN(X,Y) (((X) < (Y)) ? (X) : (Y)) #endif #if !defined(Sybase_h) #define Sybase_h 1 void syb_init _((dbistate_t *dbistate)); int syb_discon_all _((SV *drh, imp_drh_t *imp_drh)); int syb_db_login _((SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd, SV *attribs)); int syb_db_do _((SV *sv, char *statement)); int syb_db_commit _((SV *dbh, imp_dbh_t *imp_dbh)); int syb_db_rollback _((SV *dbh, imp_dbh_t *imp_dbh)); int syb_db_disconnect _((SV *dbh, imp_dbh_t *imp_dbh)); void syb_db_destroy _((SV *dbh, imp_dbh_t *imp_dbh)); int syb_db_STORE_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv)); SV *syb_db_FETCH_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv)); int syb_st_prepare _((SV *sth, imp_sth_t *imp_sth, char *statement, SV *attribs)); int syb_st_rows _((SV *sth, imp_sth_t *imp_sth)); int syb_st_execute _((SV *sth, imp_sth_t *imp_sth)); AV *syb_st_fetch _((SV *sth, imp_sth_t *imp_sth)); int syb_st_finish _((SV *sth, imp_sth_t *imp_sth)); void syb_st_destroy _((SV *sth, imp_sth_t *imp_sth)); int syb_st_blob_read _((SV *sth, imp_sth_t *imp_sth, int field, long offset, long len, SV *destrv, long destoffset)); int syb_ct_get_data _((SV *sth, imp_sth_t *imp_sth, int column, SV *bufrv, int buflen)); int syb_ct_data_info _((SV *sth, imp_sth_t *imp_sth, int action, int column, SV *attr)); int syb_ct_send_data _((SV *sth, imp_sth_t *imp_sth, char *buffer, int size)); int syb_ct_prepare_send _((SV *sth, imp_sth_t *)); int syb_ct_finish_send _((SV *sth, imp_sth_t *)); int syb_st_STORE_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv)); SV *syb_st_FETCH_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv)); int syb_describe _((SV *sth, imp_sth_t *imp_sth)); int syb_bind_ph _((SV *sth, imp_sth_t *imp_sth, SV *param, SV *value, IV sql_type, SV *attribs, int is_inout, IV maxlen)); /* prototypes for module-specific functions */ int syb_thread_enabled _((void)); int syb_set_timeout _((int timeout)); int syb_db_date_fmt _((SV *, imp_dbh_t *, char *)); SV * syb_set_cslib_cb ( SV *cb); #endif /* defined Sybase_h */ /* end of Sybase.h */ DBD-Sybase-1.24/dbdimp.h0000644000175000017500000001160014361730257015125 0ustar mpepplermpeppler/* $Id: dbdimp.h,v 1.45 2017/09/10 14:31:45 mpeppler Exp $ Copyright (c) 1997-2011 Michael Peppler You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. Based on DBD::Oracle dbdimp.h, Copyright (c) 1994,1995 Tim Bunce */ typedef struct imp_fbh_st imp_fbh_t; /* ** Maximum character buffer for displaying a column */ #define MAX_CHAR_BUF 1024 typedef struct _col_data { CS_SMALLINT indicator; CS_INT type; CS_INT realType; CS_INT realLength; union { CS_CHAR *c; CS_INT i; #if defined(CS_UINT_TYPE) CS_UINT ui; CS_BIGINT bi; CS_UBIGINT ubi; #endif CS_FLOAT f; CS_DATETIME dt; #if defined(CS_DATE_TYPE) CS_DATE d; CS_TIME t; #endif #if defined(CS_BIGDATETIME_TYPE) CS_BIGDATETIME bdt; CS_BIGTIME bt; #endif CS_MONEY mn; CS_NUMERIC num; CS_VOID *p; } value; int v_alloc; CS_INT valuelen; CS_VOID *ptr; } ColData; struct imp_drh_st { dbih_drc_t com; /* MUST be first element in structure */ }; #define MAX_SQL_SIZE 255 #define VERSION_SIZE 20 #define UID_PWD_SIZE 256 /* Define dbh implementor data structure */ struct imp_dbh_st { dbih_dbc_t com; /* MUST be first element in structure */ CS_CONNECTION *connection; CS_LOCALE *locale; CS_IODESC iodesc; char tranName[32]; int inTransaction; int doRealTran; int chainedSupported; int quotedIdentifier; int useBin0x; int binaryImage; int dateFmt; /* 0 for Sybase native, 1 for ISO8601 */ int optSupported; /* 0 if the server doesn't support ct_options() */ int lasterr; int lastsev; char uid[UID_PWD_SIZE]; char pwd[UID_PWD_SIZE]; char server[64]; char charset[64]; char packetSize[64]; char language[64]; char ifile[255]; char loginTimeout[64]; char timeout[64]; char scriptName[255]; char hostname[255]; char database[260]; char curr_db[36]; char tdsLevel[30]; char encryptPassword[10]; char kerberosPrincipal[256]; char host[64]; /* for use with CS_SERVERADDR */ char port[20]; /* for use with CS_SERVERADDR */ char maxConnect[25]; char sslCAFile[255]; char blkLogin[16]; char tds_keepalive[16]; char serverType[32]; char serverVersion[VERSION_SIZE]; char serverVersionString[255]; int isMSSql; int isDead; SV *err_handler; SV *row_cb; SV *kerbGetTicket; int enable_utf8; int showEed; int showSql; int flushFinish; int rowcount; int doProcStatus; int deadlockRetry; int deadlockSleep; int deadlockVerbose; int nsqlNoStatus; int disconnectInChild; /* if set, then OK to disconnect in child process (even if pid different from pid that created the connection), subject to the setting of InactiveDestroy */ int noChildCon; /* Don't create child connections for simultaneous statement handles */ int failedDbUseFatal; int bindEmptyStringNull; int alwaysForceFailure; /* PR/471 */ int inUse; /* Set when the primary statement handle (the one that uses the connection referred to here) is in use. */ int pid; /* Set when the connection is opened, used checked in the DESTROY() call */ int init_done; char *sql; struct imp_sth_st *imp_sth; /* needed for BCP handling */ }; typedef struct phs_st { int ftype; int sql_type; SV *sv; int sv_type; bool is_inout; bool is_boundinout; IV maxlen; char *sv_buf; CS_DATAFMT datafmt; char varname[34]; int alen_incnull; /* 0 or 1 if alen should include null */ char name[1]; /* struct is malloc'd bigger as needed */ } phs_t; /* struct to store pointer to output parameter and returned length */ typedef struct boundparams_st { phs_t *phs; int len; } boundparams_t; /* Define sth implementor data structure */ struct imp_sth_st { dbih_stc_t com; /* MUST be first element in structure */ CS_CONNECTION *connection; /* set if this is a sub-connection */ CS_COMMAND *cmd; ColData *coldata; CS_DATAFMT *datafmt; int numCols; CS_INT lastResType; CS_INT numRows; int moreResults; int doProcStatus; int lastProcStatus; int noBindBlob; int retryCount; int exec_done; /* Input Details */ char dyn_id[50]; /* The id for this ct_dynamic() call */ int dyn_execed; /* true if ct_dynamic(CS_EXECUTE) has been called */ int type; /* 0 = normal, 1 => rpc */ char proc[150]; /* used for rpc calls */ 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 syb_pad_empty; /* convert ""->" " when binding */ /* Select Column Output Details */ int done_desc; /* have we described this sth yet ? */ /* BCP functionality */ int bcpFlag; int bcpIdentityFlag; int bcpIdentityCol; CS_BLKDESC *bcp_desc; int bcpRows; /* incremented for each successful call to blk_rowxfer, set to -1 when blk_done(CS_BLK_CANCEL) has been called. */ int bcpAutoCommit; /* (In/)Out Parameter Details */ int has_inout_params; }; #define IMP_STH_EXECUTING 0x0001 int syb_ping(SV *dbh, imp_dbh_t *imp_dbh); int syb_st_cancel(SV *sth, imp_sth_t *imp_sth); DBD-Sybase-1.24/BUGS0000644000175000017500000000126014010471204014162 0ustar mpepplermpeppler$Id: BUGS,v 1.3 2011/09/06 17:26:01 mpeppler Exp $ Known problems: -------------- t/fail.t fails on test 8 if the server is 11.0.3.3. This is not a problem with DBD::Sybase, but rather a problem with the error handling of the Sybase server itself. Prepared statements with ?-style placeholders become unusable after an error on the execute, with an error similar to: Stored procedure '*00001500000000_70d40f' not found. This error shows up when DBD::Sybase is used against some versions of ASE 12.0 (known versions to be affected are 12.0 ESD#1 and ESD#2, and 12.0.0.1 ESD#3 on Solaris.) On ASE 11.9.2/linux $sth->execute() calls that follow the call that fails simply hang. DBD-Sybase-1.24/README.freetds0000644000175000017500000000344314361730257016036 0ustar mpepplermpeppler Using DBD::Sybase with FreeTDS ============================== DBD::Sybase 1.17 or later works reasonably well with FreeTDS 1.18.x, but some capabilities are limited or not available. Build process: -------------- FreeTDS normally installs in /usr/local, with the libraries in /usr/local/lib and the include files in /usr/local/include. This location is assumed below. To build DBD::Sybase you need to set the SYBASE environment variable to /usr/local. When you now run "perl Makefile.PL" you will get warnings for a few missing libraries: Note (probably harmless): No library found for -lcs Note (probably harmless): No library found for -lsybtcl Note (probably harmless): No library found for -lcomn Note (probably harmless): No library found for -lintl This is OK because FreeTDS doesn't package the functions in the same libraries as Sybase. The "make test" process will fail for a number of tests when run against a Sybase ASE server: Test Summary Report ------------------- t/main.t (Wstat: 512 Tests: 38 Failed: 2) Failed tests: 33-34 Non-zero exit status: 2 t/utf8.t (Wstat: 1792 Tests: 11 Failed: 7) Failed tests: 1, 4-6, 9-11 Non-zero exit status: 7 t/xblob.t (Wstat: 65280 Tests: 5 Failed: 0) Non-zero exit status: 255 Parse errors: Bad plan. You planned 11 tests but ran 5. Files=13, Tests=239, 16 wallclock secs ( 0.06 usr 0.03 sys + 0.72 cusr 0.40 csys = 1.21 CPU) Result: FAIL Failed 3/13 test programs. 9/239 subtests failed. Specifically, FreeTDS 1.18.x does not support "unsigned smallint", fails in handling utf8 data when fetched from an ASE server, and fails in the ct_data_info() call used in TEXT/IMAGE handling. I personally use FreeTDS when working on DBD::Sybase, given that my main computer is an iMac and there are no Sybase libraries available :-) DBD-Sybase-1.24/t/0000755000175000017500000000000014577756334013777 5ustar mpepplermpepplerDBD-Sybase-1.24/t/main.t0000644000175000017500000001404614361730257015100 0ustar mpepplermpeppler#!perl # # $Id: main.t,v 1.21 2010/04/07 20:53:38 mpeppler Exp $ # Base DBD Driver Test use lib 't'; use _test; use strict; use Test::More tests=>38; #use Test::More qw(no_plan); use Data::Dumper; BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my($switch) = DBI->internal; #DBI->trace(2); # 2=detailed handle trace print "Switch: $switch->{'Attribution'}, $switch->{'Version'}\n"; print "Available Drivers: ",join(", ",DBI->available_drivers()),"\n"; my $dbh = DBI->connect("dbi:Sybase:$Srv;database=$Db", $Uid, $Pwd, {PrintError => 0}); ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 33) { ok(0); } exit(0); } print "Connect to server version: ", $dbh->{syb_server_version}, "\n"; my $rc; $rc = $dbh->do("use master"); ok(defined($rc), 'use master'); my $sth; $sth = $dbh->prepare("select * from sysusers"); ok(defined($sth), 'prepare select sysusers'); $rc = $sth->execute; ok(defined($rc), 'execute'); ok($sth->{NUM_OF_FIELDS} > 0, 'FIELDS'); ok(@{$sth->{NAME}} > 0, 'NAME'); ok(@{$sth->{NULLABLE}} > 0, 'NULLABLE'); my $rows = 0; while(my @dat = $sth->fetchrow) { ++$rows; foreach (@dat) { $_ = '' unless defined $_; } print "@dat\n"; } ok($rows == $sth->rows, 'rows'); undef $sth; $sth = $dbh->prepare("select * from sys_users"); ok(defined($rc), 'prepare'); $rc = $sth->execute; ok(!defined($rc), 'execute (fail)'); ok($sth->err == 208, 'error code'); $sth = $dbh->prepare("select * from sysusers"); ok(defined($sth), 'prepare'); $rc = $sth->execute; ok($rc, 'execute'); my @fields = @{$sth->{NAME}}; $rows = 0; my $d; my $ok = 1; while($d = $sth->fetchrow_hashref) { ++$rows; foreach (@fields) { if(!exists($d->{$_})) { $ok = 0; } my $t = $d->{$_} || ''; print "$t "; } print "\n"; } ok($ok, 'fetch'); ok($rows == $sth->rows, 'rows'); undef $sth; $dbh->{LongReadLen} = 32000; $dbh->{syb_quoted_identifier} = 1; $rc = $dbh->do('create table #tmp("TR Number" int, "Answer Code" char(2))'); ok($rc, 'quoted identifier'); $rc = $dbh->do(qq(insert #tmp ("TR Number", "Answer Code") values(123, 'B'))); ok($rc, 'quoted identifier insert'); $dbh->{syb_quoted_identifier} = 0; # Test multiple result sets, varying column names $sth = $dbh->prepare(" select uid, name from sysusers where uid = -2 select spid, kpid, uid from master..sysprocesses where spid = \@\@spid "); ok($sth, 'prepare multiple'); $rc = $sth->execute; ok($rc, 'execute multiple'); my $result_set = 0; do { while(my $row = $sth->fetchrow_hashref) { if($result_set == 1) { ok(keys(%$row) == 3, 'number of columns, second result set'); ok($row->{spid} > 0, 'spid column in second result set'); } } ++$result_set; } while($sth->{syb_more_results}); # Test last_insert_id: SKIP: { skip 'requires DBI 1.43', 1 unless $DBI::VERSION > 1.42; # This will only work w/ DBI >= 1.43 $dbh->do("create table #idtest(id numeric(9,0) identity, c varchar(20))"); $dbh->do("insert #idtest (c) values ('123456')"); # DBI->trace(10); my $value = $dbh->last_insert_id(undef,undef,undef,undef); ok($value > 0, 'last insert id'); } #my $ti = $dbh->type_info_all; #foreach my @type_info = $dbh->type_info(DBI::SQL_CHAR); ok(@type_info >= 1, 'type_info'); ok(exists($type_info[0]->{DATA_TYPE}), 'type_info DATA_TYPE'); SKIP: { skip 'requires DBI 1.34', 3 unless $DBI::VERSION >= 1.34; my $sth = $dbh->prepare("select * from master..sysprocesses"); $sth->execute; my @desc = $sth->syb_describe; ok($desc[0]->{NAME} eq 'spid', 'describe NAME'); ok($desc[0]->{STATUS} =~ /CS_UPDATABLE/, 'describe STATUS'); ok($desc[0]->{TYPE} == 8, 'describe TYPE'); } $sth = $dbh->prepare(q|select uid, suser_name(uid), cpu, physical_io from master..sysprocesses order by uid compute sum(cpu), sum(physical_io) by uid | ); ok($sth, "Prepare compute"); $rc = $sth->execute; ok($rc, "execute compute"); my %seen_result_type_width; while(my $row = $sth->fetch) { local $^W = 0; print "$sth->{syb_result_type}: @$row\n"; $seen_result_type_width{ $sth->{syb_result_type} }->{ scalar @$row } = 1; } use Data::Dumper; is_deeply( \%seen_result_type_width, { '4040' => { '4' => 1 }, # regular rows have 4 columns '4045' => { '2' => 1 } # compute row has 2 }) or print Dumper(\%seen_result_type_width); $sth->finish; # Test new datatypes available with ASE 12.5.3 # if($dbh->{syb_server_version} ge '12.5.3') { my $sth = $dbh->prepare("select convert(date, getdate()), convert(time, getdate())"); $sth->execute; while(my $r = $sth->fetch) { print "@$r\n"; } } # Test new datatypes available with ASE 15 # SKIP: { skip 'requires ASE 15 ', 2 if $dbh->{syb_server_version} lt '15' || $dbh->{syb_server_version} eq 'Unknown' || $dbh->{syb_server_version} eq 'MS-SQL'; $dbh->{PrintError} = 1; my $sth = $dbh->prepare("select convert(unsigned smallint, power(2, 15)), convert(bigint, power(convert(bigint, 2), 32))"); my $rc = $sth->execute; if ($rc) { while(my $r = $sth->fetch) { print "@$r\n"; ok($r->[0] == 32768, "unsigned smallint"); ok($r->[1] == 4294967296, "bigint"); } } else { ok(0 == 1, "unsigned smallint"); ok(0 == 1, "bigint"); } } SKIP: { skip 'requires ASE 15.5 ', 4 if $dbh->{syb_server_version} lt '15.5' || $dbh->{syb_server_version} eq 'Unknown' || $dbh->{syb_server_version} eq 'MS-SQL'; $dbh->{PrintError} = 1; $dbh->syb_date_fmt('LONGMS'); my $sth = $dbh->prepare("select current_bigdatetime(), current_bigtime()"); $sth->execute; while(my $r = $sth->fetch) { print "@$r\n"; ok(1 == 1, "bigdatetime"); ok(1 == 1, "bigtime"); } $dbh->syb_date_fmt('ISO'); my $sth = $dbh->prepare("select current_bigdatetime(), current_bigtime()"); $sth->execute; while(my $r = $sth->fetch) { print "@$r\n"; ok(1 == 1, "bigdatetime"); ok(1 == 1, "bigtime"); } } $dbh->disconnect; DBD-Sybase-1.24/t/thread.t0000644000175000017500000000500014361730257015411 0ustar mpepplermpeppler#!perl -w # $Id: thread.t,v 1.5 2005/10/01 13:05:13 mpeppler Exp $ # Test support for threads in DBD::Sybase. use strict; use Config qw(%Config); BEGIN { if (!$Config{useithreads} || $] < 5.008) { print "1..0 # Skipped: this perl $] not configured to support iThreads\n"; exit 0; } } use threads; use DBI; use DBD::Sybase; # REQUIRED!!! BEGIN { if (!DBD::Sybase::thread_enabled()) { print "1..0 # Skipped: this DBD::Sybase not configured to support iThreads\n"; exit 0; } } use Test::More tests => 10; use Thread::Queue; use lib 't'; use _test; use vars qw($Pwd $Uid $Srv $Db); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my $database = getDatabase(); print "Using database $database\n"; my $queue = Thread::Queue->new; my $rdr = threads->create(\&reader, $queue, $database); my @thr; foreach (1 .. 3) { push(@thr, threads->create(\&test_it, $queue, $database)); } my $count = $rdr->join; my $total = 0; foreach (@thr) { $total += $_->join; } is($count, $total); sub reader { my $queue = shift; my $db = shift; my $dbh = getDbh($db); ok(defined($dbh)); my $sth = $dbh->prepare("select id from sysobjects"); ok(defined($sth)); my $rc = $sth->execute; ok($rc); my $count = 0; while(my $row = $sth->fetch) { $queue->enqueue($row->[0]); ++$count; } return $count; } sub test_it { my $queue = shift; my $db = shift; my $dbh = getDbh($db); ok(defined($dbh)); my $sth = $dbh->prepare("select name, crdate, instrig, deltrig, type, uid, sysstat, updtrig from sysobjects where id = ?"); ok(defined($sth)); my $count = 0; my $rc; my $tid = threads->tid(); while(1) { my $id = $queue->dequeue_nb; last unless(defined($id)); $rc = $sth->execute($id); # ok($rc); while(my $row = $sth->fetch) { print "$tid - fetched($id) == $row->[0]\n"; ++$count; } } return $count; } sub getDbh { my $dbname = shift || 'master'; my $dbh = DBI->connect("dbi:Sybase:$Srv;database=$dbname;timeout=60;loginTimeout=20", $Uid, $Pwd, {PrintError => 1}); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 10) { ok(0); } exit(0); } return $dbh; } sub getDatabase { my $dbh = getDbh(); my $sth = $dbh->prepare("select 1 from master..sysdatabases where name = 'sybsystemprocs'"); $sth->execute; my $database = 'master'; while(my $row = $sth->fetch) { $database = 'sybsystemprocs'; } return $database; } DBD-Sybase-1.24/t/screen.jpg0000644000175000017500000027504414010471204015740 0ustar mpepplermpepplerJFIFC  *3$&*<5?>;5:9CK`QCGZH9:SqTZcfklk@Pv~th}`ikgC11gE:Eggggggggggggggggggggggggggggggggggggggggggggggggggj" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?=};[DŚ $$G5b{&؁=D 1QFr#=ȈbaKy'UHnjĒ |ǿ@c'ݓ++Y4H-ӏRn¶E͜S83)'p9ǽE"1WfObzjRf(-~U/N@TάH#HoOR՘@(0{A9'Sxv#/@qd ?K%̍Z###'מp:8F#Oݣ28l6=E5Л'P_'N@S/k+Zlwn3nP3Г*|15`HFs=G?vC3@qd ?. wgM?(ɿ_7KK gDo7?÷q*=icbY2d*p ڋvGM?+0\~%ky둑=VKhW~sy OchF ?GN@8 aq YI a ut[[v`۟ ,>wgM?(?M8H.*${nqVS<ҳ:"A#S=84X=?'Pf(?8 [?+KkM 3ruV2_GlCtX9bN@Q/@qy-]zєēaǷN1T7i(geIq={w(a:?(?8 d7-c2gh:ߝ^$?ڰ@oEq,]{hFd ?:4RY٤%[hRy9sPi05mIUo* ,cb}d ?:4W4k5[m{`ĒsӧjkhrKI#G~X9a:4GN@TV-Yf1m'~Ks[B\Jqz6C篵wح3@qd ?+B Mvy|D! cufhJ9RG{ ,N@Q3@qm}>[US wݕI{ӃSG-F*OB1‹;V?8 ?uh?–O5e|!g(򴶹Yް7-G_QX9a?uh?C𬏶=OףS}>?8 ?uh?²>'?^=OעCz?8 l_z>'?^5uh?C𬏶=OףS}{o#_'Pf(?8 l_z>'?^5uh?C𬏶=OףS}{o#_'Pf(?8 l_z>'?^6?uQ/@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q/?±'?^=OעCz'Pf+#S}l_z,?8 ?uh?²>'?^=OעC?XmzGd`FM?(ɿ_cOmzEyW *~q?}Omld/?C~q?}Omld &~q?}Omld ?'N@VGd?X=3@q:XmzGd`FN@8 ?uV?d?X=/@q:4YmzGd`FN@Q3@q?}Omkd ?:4YmzGd`FN@Q3@q?}Omkd ?:YmzGd`FV@TWy(BQYmzL'=ע|"m'TvQȧkOZIN6ǁ~TҩZ{xa:$x0A4-ʼ8.0 ‘wW"4RRLr:6*QibsNbYtmJGwfAʥֲtMAnd6d.Geˋ="ԅLEx c'ݓ*]\V[t@TLhʼn>URG;̤#8 s4]̊;mS=9ǪW_h-͓“. @3ۨ/_Rou)(naXk۵>Owmmoim{kxwHrbP=@Y U0Y?7#bVFytak=D$ + ]AzPQ51u W?,6FG9aIP+vi[tF(ԬX/#]DۜjiJ;*t D_*IRKfqz% 4w~Kwb9v?Z%TahO/O3q9AQ m~C~j9n/-zFğ5؝CO/IO/G3?gmKUyF]Hgk\϶?gs{FO3|:yߕs38ϝoմM 唟_*)Uϰ{8|W$7QjkmKP/yP3q{v 꿱W=psu-hcYK⩟ٺ>9yj7B8cTTX#=yQDW&ݿ+|1ֺhX[KЕsJU.g|rjM:ɨTa\Ϲ # Ds!xk6:?/KSt7V>DhTs>r} {v]KUVWQgr{g\9 O{?nr >XjEV1~)P_=F3VNO/At@?s>(fy+jzC ׮;Pt y2zPLro:_*3?g70$mΥ_ }H&cC/W34>U(Ѵ3,ts>r1^0CFnU1q {P_+;06g95aO/AдDUL焿_*g=NG}ߦ7ϝo񮭴˼/@Ӵc.DUϰ{8M4o;]wVU9t bQ;FM5 B?/圿_*g=N+}ߦ7ϝo81K)Uϰ{8fM4o;]6?唿_*N:E/gu>wƍ_w~k?猿_*gYI}7ϝo}ߦDsg'gu>wƍ_w~k?真_.4M9`q8_w~hu>wƻ_=_*tMyr9`q8_w~hu>wƻ#O/IAm}ϝo}ߦΑe/?生_*g=NG}ߦ7ϝoi:!R_}y}ϝo}ߦ?4O'fhO/G3'%|7[?U(ҴS,dTs>r;7Ѿ|v/KSNe'gu>wƍ_w~kf唿_*4y}7ϝo}ߦJYU3;C?Uϰ{8M4o;]gfT.gTs>r{7Ѿ|v?:TҴ1,Ts>r7Ѿ|uLKRdhq_*g=NC}ߦ7ϝo0rO)Ogu>wƍ_w~k?真_*my}˯M4y_w~k6圃RC)'g.7\ϝoRcRch_/G3'\ϝo̹;]ѴC,THQ?w~h.7_UZQy?w~h.7b4)U_*g=N;}ߦ7ϝo񮽴!yOxKTs>r7бN8' ' 3C?_dgXKs>+hzzhv2,-7gpAg?vwPQu9SIXTxK⨻V[a̧'*AęjqgXKNϕ.}<.kuvQH{k q;tߥZT447)o>_*+I$̳@H;d@HzECqJ̼Fe6 `$Ot3.DUAykFb7Rri^c?.=ݏEE-h9g֊2w Tq)eE®:Gufc={SbNAi!PcnRu_Cv"IQI$M,A0ˌdI/.~/6\vqv}*ZbVap&G, yDl{WfMq'p4RG7-H)b%b rr3GKi.wE0d~w羙'xD\yyrH }lbU*Lbi~9׎ӂGoݿ^v⣒"IʹR2ry::q.#dEQ hnHDգgrϷ :hG*Di9|0zu熛+X(w|Ir 'Z80ݐqБОJ0$$~?Tv:ľG#>`ˍw~j/*8Ko988sϭ2-| #O@a(o_ΫNWNd}9um<MH9pTPh`ɸS,`g҉UhԺ-0S!=Բ4nI `8" 2<I gןNl2#u<06Bgt'?(qϮHl{GJM#iW12 =-PpK)'lZEkOԩÞPa]H\{I$pF261шh oNY{oUa(}pHP\۵h2& 8>mm–V2AW@/n mۼ1׏֤7F;X1=tqD`۸ݝvzgvsӏz6t8L ew(\~CӧlS:F:c{vPci >w0s@ { UYʑx X0$v?t pO )fP_t~Sҭ\+q#ۥW5F^[v2Y79'F'M$۳ `v?Bzo?49Hy^4aڀ'AULQ= $aji|DžYNOUD?/hАvMU|wch;N{P5\΍~oa@$#Ga@(l2;(UmnXҴw<5bqr{ΪnN('o7v&П@h?J~i:c@7sN jOR)Ā8 c@vޫǭ pUix4)jdRWv4it3_iaUo ';Z}fy<Pi?}G6:ҠM0f:d^@,q _4oZ)R f CZ4j[zG)sKWbģ%Oo &?Bԁ?2.}wmntqSqrC?RTТ$e}U?M4Ԥݮ&aaC _Uk_NzH{&IqXE?1V_g̻WB7Nm,&FMB|ޞʫjڄcyi{90s.8M: mߐ\*ԲB%~E9( iw*R _HtX{6#4?G4Ȩ4XJ @-z f !ƀ#]ʻA/{|U0h0gWK\11!w?G>ƚn=b`.iwU`У?B2~G5:EOӾs~O.]?R59U/`y_]iyq=N4sKrb'oaǿƃȋO>h:ds'R5? Blyt4j3i}ht8{Rbп\(ƣ7睇Ǝiw`afo*S|A.2,]h]Fa<4sOZ#QqWDpo*Ϯ4l1O.ʻ :$=wso񦶋go*TǮ4:isKfzqU ]{/ץ'hp!>TP@G_Hoؐp8gG4#֫ПͿtZ (um3ri?h)?yc8]XY RG R]p_+nC ?x/+d3='ȯf]QNcu@9kyf3m ңbGrPe #A[DŌ2tU*X^4ә8NX)IO~qҭ@lij<I^`lLfrGͷn~e  c ,"i~g^:sQ^֒Q- cӟjĪAsCsאsSL{k{ voNz/!/^FB̓ց13`ƪXjZ $j)fନ?2q 1[n{P2UKԻ 3-61H&rZ O;?BEt\H:eGfh!JsҬ=]8]\r.s?1=3~bbF1zT"VV 0_ƀIMRJM$0p"EQYKpzpZ HTn$7==;T?z 9A_ncOޔm K'+0H [:'BҼ＀8mv?I9N?px q-+fʓ?,-|'^*Ap(9Aa~P'?xԂ3oP8=N(F;/4qϵ?q@e>i<3R wa81N=hM'y_ɤ"9>\Afoe'i>7#2zBFp*_̼ҋI;>Ƙ<ӂ*s a\ǠS@X 7jBɧe &!o|bޙ~ZnʟI)al$L-2&m.?|b ._֦&2&m?Odi:y~?4g1 䞂kis ik8'h 8h cާ6ӟa/←O<% #x498u/j3kq a,xQTks>-AQ $. jhi0hx?*=?~_mnX%  IS;j?)a|r"y3SK.cs|b+IV͝4\= ;@S}c_ӾpOITh?x[`c{?_kZdҭa֓`@OpE-x@OpE-stp Ud(A?֪2@KH{IFT(V:jܺɼ/H4 ݁e׫ZٌxOQHj):/!$0g-mf1$Z-lYw?Z^9.Th_zqѧ~?^g_!E̗n ?^4k9k{A-o?7ɴ%{ffϞ/riW d[؟iw}ȟ;U'1p?^t;x?^?~R-Oe?;:-'ִCgf?60I?֬{AwFc]cJFӊؙE<ߝV j?-2+7AQҶmG{Ef t/'EP߳~R=gGR}~~q|My.5t{m))n3 clIj-GOW%Nc)x؃!&Z;_Ɠ˰?}ƎJe#p9Q'&aa$i<I}SsC. @xFtp3ssKYr_ƓeƎJeO}]Z!3;(w#zUF?|o£~w/fOZq4i+.i{$7m'j3s98I}6Xi}Ee?4Aq:.Zg i-tN;1,yCO4k5i{ N%q"gVf?5Om/Ɨѣ9xʧhv'Ա4yk5L-'hňDAsϘW'%5O6#FO$MĤ+FnfѪٴz'hE=,4`ֹٍW jN͢Fc!{DLSmڒSҤ9W"uOػYh2h<N<gbn Ąd'ȼU9ī2yT|w1׾2JiʔkcAUM! #I>bx=p(kCڥ1FA9Fp9ْ6\݌qӒsQ@Kw0?y{hkT3RW*A99괰ڷ %/;H}z=i@A <}AM/jN̿*O2/@Dڝ~|ex \q@/pTaj%N1"\Fe_e#cj)%lMUR 0qǽOSU6),c_΀.yɦM<X\CU>3 嗧c@S\OL-| НhRWm'vN?fxV"ڢ*Bkڻvx'?(?S@ dݏ Hbh$O$v8z.39Zv5ya<i nIj} X'Qjܗ/s@!?J8Yc*p?KHozo#EchcvinU4Xi 4M9w)RUsp34m @T.=zSdK]N(#u >Wr#h/`:vE !?9+pe!$u>֖<#Gv>X睪EI>$Kr*)Y<b|`Fw '݋d}PdsS瓁d^ eVR۲A%,rG$W|#O V@Co`lzS,7 Ǜ>[vz]u0e7r9 @>7f_ǑS01ه뗌t ҉J'5掸@$rOPk^7AG)A+QV<oP H2nN8-/BFB# ֘qFOȨ99<*<@ZoN@=sϯJVv3 Q(qqTFfEhMˏ wl "Ȫ#(gր,Ts*i{' 1#z8qsf˸ .ձq5w6QƱ,mȨ?QME# ەB )J:+ȔP5X/M֩j[ԟocĘ&K{Yw 5!` 'gҚ&# AOm $J]{o ) Kzoc I3 avZڍA7Rh4L fJ/ Q@!(=|;+/4*^2 ߍ5 }ҵ{q>SdG~-W ZFg=9Vo Q/YAEr9*ZΚu;?,3A'd34KMghhIm8 ;҃-Pѵ=%֝5_'Ỵ2HΎĥ܎'RT`8oڝ-ೂWqӷ ݼ>`9#j$s2;nnp?EJVcџ cqwT)TOPi|z%?i G^j+Fάt#@ Z.Dݠ~?.=1<1OaD q4併' ܼt'9?^Oh 7/hx*1>b;1un088Uݬ. )~X෹] %UB;Oz`TAy6\L IbpOQX0 Byʤck/=lӆIJ:Ue(1~E4O*INdqdc~$7w t̎ şu]=c#iOe\p1ZҒS3*I }l'SV}FA]&M ' Y16n9fhQOKjh;H {\SsV5ե8#[x[kGP9?Θ GO09qET ZGZ]fì: li0Cq% rW7ozƛw/e<*|h|,ҭաUWa:6† sӱ[y4čٴ/:5MX_Go Gi$sDҒdFۏ0*5;-2$4{LqNMgg++XiŬrL(zǵDhZp&#0Ocjv]Vрh^5-TK5K%Q2 c=1޵Ԓ>cv;Rgv7c\sNi#dc vJ%R}`-J˂ܽH;$|[EpG h]t8 sF6T{$#H􇺒Y'@\W;G|vz׫FFb&O%[VV ݏ=구%ͺL)IJ}8u5Ŧ<j 9P{8zsPY7+-\[G [&525âƱç(K)ޠd>ҤHŤDy5wP,| SCH`*ֵӦSk Mv8<'Nv/] OHt<O[TmoCRV@OGN@?W6އ KK OGeZ߅ F?+*fXp +O=tC?­oCQEt0?I:*?:(gwkzʍ*.6)4Y:\އkzʋ*:6V ܯ̰ OVއ m:%`e8#ьþyԶZd$V\X[ܧOd7V#RG(b9̶gaomLKEfXύ_2|-?[އkzʋ*e\-?V<3F.R(T ?ȭM*}k%q4r9=r@Z(5&h Ihhʌ>8߶n2Wh @K%r2FG92ҬoCQvO ei~*?]S+O iPJemxtT AR1z7f5F ?GrbubnB?Er602?suoSѹOUQٝVe$AO3-FI#z~&lqۛtnoSOK4jX_ {tnoSOK4jX_ e;wx͔ e8Zwڔc%I`rHږij5ҖvbV-gnVm;Rxj{8.%&S$ Or 6A-G"uB0GZ5K;v.Eh",aiRr2*]O{i;3b21d 'nzmJub5,9\s[^M=Q,3]B͹ُqս\}:yi/$C)eEwH)pys-;v}^(oE3ۆô(<>x?Tm$`B0xs9TD1:6b$,21mխª:4ـ1}zQfm32C#\c%2dGj*3c~V>\Fc@s <槺MJ,$rD# =cK0.jAi,'I}ל.5\=ES#լ1vK1,KxuZg]Rt(ŕJ L.G\4j&97NA8֟%E:#Hy8v0{gֱ 1'S3F%d }tK A]̭nR7xΨ ,ʫbzVd;p9`rA qYb+<ۆm vO2wr~LӞKhwXeg} [Mo Si!0f 8,CqMY(<̒1 3`0pqjK*?m?cTϘ6֍Wڂ,Sլ"Hd mۙC F3OR'6wG/QjxPOkom=1$T=d߾yq##nf8ez}46(HPE&wҋ04hcueVH##֬[-ۃe>GcϨUlK`A ?QU/,!m |yʫf?uSR?ږiiYosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yosz΍:a?ƏK4Yi[g1F|r;]wsHwo#¤n#Bj寅ЛA\mjCĐd:VΛƉkϊHtZ)YZY$$G\ rJ-o>lP>U?k mPY^ yƅTvVl(sgr@0Aq 20F8NK#-e$y#73"}jI)qyQdJyIN~= Ҙ]C*c cO<8xt2H3yJVo-Lq`k8V7gmlrvp:8c9mR} cQ̎j,g=ԩjpNB"`rSps،\ Ao,/ +V?9~#9Z,h[hʀNIZײ޶ڴHQ( Yϻ>8j} cr1)?fn@$iѣD.g[ @9;G##!wUuF&؛rSw ۶㧯fyBy!@$ÉFѰ s[1''y?1@-a?t} c̀Z)>y?1 AR} cG2h A7.dIGo??]7. 9 E'o??]a?ts O >y?1@-a?t} c̀Z)>y?1 AR} cG2h A7.dM.Yf-;K*U _a?tȴ˘PwP*f#ybÌO >y?1@-a?t} c̀k%Ē_HlGg )Ϸg钽Ɨi4I!FcdԱ1P93rpt˛x#+8*1ZQ̀yI̐#E#)$}juk6#+#F@ a@BNHZ]:< "d|APtG/y([f ALus #T=#-0ݟ-mʸ︫zeo#%m~ܜ== c̀Z)>y?1 AR} cG2h A7.dd73diIIeŴmPG:9SFfGo䲲9Xy;~|Ctom_paHy,]x`Jn[fkM&wMuq$I(T]W63n[='5z\/'o$AKfFڼV֮QijЍˀ&&?,Ą=r:\B84qb-ƪj+<&ss"cl.6qԧYKy Ēpl*mdqlC gd@3a?\WNE@P(@#QH#0Y}iM?Q%H ̂6ܹ>[?Kg\p9j6[2.IVd`[Dos+lxɜmx㚎̉2`7a\I˚OXe,y܍7qۚ\UqݘF]m@  =pFMm;KE0P෕28ǨL<HV /Xp#>}g=-!3"V}@F <`N3T.;_CQKΏtzh]Xd"92YZ09RFPϯ= itQKGP'['DgqV#6fy7ylJesy֞GE{EJ)r?(J)r?(#J)r?(#J)r?(#J)r?(#J)r?(#J)r?(#J)r?( ycbx{C9NOFrI1g]Ӷy.#XxWj?NQy 22z=i̒Tt8 [Σq%$e;>{#?xꝲ*{dc儅%ԅ2qqkW#",p8ϟڬXmԂY?Ёɩ&s@zib9<{YI pqU9-Wأl,J4d?`x'sV4$BK_8 7ePOQ)ȲF`<(V`T @ e_Ǿ;J&|G|˻=yȫ_k} ナ{ȱfÙ#hsp{ ĐYaQD @' 5; W;wu3b+NǍޓB] %sȭ;΍ls<ZGZ[jK ohMt=V<;\D rݏtUSFfpvIvG#?F9GƋFGooYoI奫 0f6yerF*[ʞiZQʷ0mu÷Lxp3l ZܷRLя0,@w q$\Erx&[ SA?ݮ.cY"I#i#dvDq'Bu 1\p0gTEePcD``X7 L5D̫p5@F9{Jx;yK[{*iL+3; (0DZ>b@L nT8Îq.[o.4fa߼:a+vf/fH+oxeI߸ku /<+`Nr( &q!~c9_^92yR5;,!I#wk=b9/v&I$^aAN㟓OsMQvV7yG}AX 4R>ߕHq}*J)woʍq}*ynCZv̉ fp՘"cU@UU GA$  ьRp6 n24}Vd?1$ בխq Ei+o fi`ǪQs4%ʴ 6c q3# r 肨 [h8Ojޠm"-Eg A'qL0If`'21WfY eB|`ߪ~+VDHLdP8'-gq0]qbH:=1CzјQXPeGn1b MIlX{·uD9meeb!N5Z\G5FNdw+p}pkЧ$F_o? f:+F%\'8=?QS]=.8Vpgk9i7hc-ĥՖ?U/Oj3_/s҅mYE6 ͐wnj4sQ l"Dw U]"q h?.@c &#y269t4T2=4R9B`q^yIʜd5mLF 0;FrAN?cGr*vgnO$g=;fYNMʌێ8?Yg3&$W8)_f7g zsG;FW9@iCo[ӿZۼ f2I1FSH&\*b:(2z9椺"hX̫e$\mi(ܱEEKJ! ˱ n3vqPZj\[HѼ譴s<qj,j\COdbLm-3DZŤyCaxH :EEf]_6̰V]TFHs󜎣iϵɵ )^oRer1 q`&6lIFI`2|[KOuYA#X Vءa36*1fpTc, {Gil9d`ӞzwMEV:@f\d`ˌdT q,D"7cg+:0{,* (]WDH9J7CB궯7 *7W'F=zhhX  +er4.{~c wH5 R4$̤y aT$Sv%ҋwy00qO=wW:]mbFb7 Os| SZ8[1MUI8?I[ǫaG NΪ2F`)!s[@$S7Ρ0V* 8 8:u(w:UbĪV!nyNfnPn) ;}ERoSѹOH q 5(@I^M wԶDC)ɑ 桏R (ۗvr#sێxҍQ$mbm܅^cFɅ!6Owp}3%4v2=*uX^ $xS䁷vLnQ O-;Fz:BA o`@㌏ګ; knۜOim-zN JciIR]v0p@>Ŀ+=?ΰ;]wKY32fWqڱبh*1<lZ۱EcQt 'W[=W-hx@7pE:tPL\*n_÷ Vʹ|h|,,/9iI2# ?ҙmdY=8Nl/"+ }q d*֢{nA::d6"mB+K`Ͼ?FC&mǓzsJ4ʉ^YyiY *{1V-٩Bd*AFSg'|85>y-4- ,F㢹>>P]A,`f5* spFJ)zmqA;; FN m]\ km-M.XQfi6_f;-&;>9TonqG1H٘pUzpNoCQIE kzʍ*J(vއ򤢀kzʍ*J(!9829@C9Θ׎ek; {lbXmp? {CklFF wn-,-vlY68ickzʍ*J)[UGSk,fF˕3CmltxcrUhcOl~UڭXi{ E;}|\Y;e=BL78szY'Qde[/m6̬0p#|U;ƨAդ=NrN'Kwqpd /j]E%q%#`lI<{@$F1y3ų׾qPhӛU 1| 1 <-$$Q6,JQ"G:9#=(ҵwLJ^_J]՚<$ ߕx}q{P[F}\(K6S$;drṹȬpR)_oC:ΥF ;GEԥi pY>\$ H^F2jizۉ.̏t*d @?3sz Ѕ 31rІ^BI88E9GA$]_jQ{iU}'Gpj4, #%vw p>Fzq#O:7 Qm7# >e 3Oьn' ;Sm #ghUʡx`xgWo%[pVFX|;{g -m lT7|ӎ榇MxnbfR͹J>x>ԷWRu ^Tw>]zOvR> RICn /h i2]Nx(mac't܃# N3ScB}ww #*6pw=2FGF1dn3^ӥy"ugT:ߔAGpjop!jqHaPTsp$MoeT]( 6pݲx4N[{o qFaq@>J-e͜41HFe3`Np [)VMw vSV3Knd/_ P YF@+sq co'Tx1Ig;PF}\(K6S$;d^JU-J&3"?ŒA~8Q<L]^z̙8 GBqzqš{v/Rq01&af;r=298XI/)FFP][ ۀx'Z-ΐ>=>U\j[&`iu 8뎆kK5 GVܹ%A=Po΍󤢤 q鮗LaWnsn[8#n0;s3[ڽ4I2#9b:gPn!%& q#LX%kBӸye]v*eYe1G) tuM=FYԀH۷#*/,^&uivy@ shKWkzHyK l {Md:o6J9!g=ǥYIA@bTc_tApy#Q5iP78 <  n'M$q"䏻q@-->i.9nׯz$ VͫnCK&Oޙ61Xu^CmUr*ݙƗU^ȩL~O (ns>,\#kE'Z[ip_+y'_`:}`_+{G*E𳝶Nٸ%i[:! Ueer6I)0vڿ n X/mn$d?³EGݚS!IesFOݯ9ɷLإ#m^s{+kWq(XYhF @BH dA{ ٷ,.9 ðqqhm7YKˇP%` 20@^0KB V{xyg.nbC;DWp̓0sڔ7o![y vV-9Ì\>Si Jb#9b9$g2*:l-ܭ*nT <xuhٍ@gf{H=5Ԟ! Xc_3$$/n'5m2J+0ځ@  z5vM=eX^VH$udǣąAH$hن`xqN:u,z[KBg E.xn fì]IvxE<#rcnH97 ]=m"⹗hڨ "/D86-ْY yIyac?SQzơ= hheg+7E/&s{"&CG\Xh)N̑ #ntFsb*daO'7uϿ ?fAKsrIB$FgǧZ$ioN3?{nbmm` v=qz~m'r>a } X䳋1IbE< 8 I]Sq{hYwgum(ެU3r>t"cjȱFurێxګ n9CƘU7lQzJs#\.zt'>F/j`8p$IO{ub7d:/ dy|ѵɢla̎"b71|:ueLjFIh833fvoD3b; ُ<=}jKXUHKT4n-\©r kfKB!@Bm\szus ˽pe\ $)dA&HYVCTr86KgN23Kp` u#wZMA6E+Jdse9Vc" F3qIg,yoa~P0Fޟ?ҧ{Et2̠R$ś8c8#)i60q+g`c==j $x 07 lpq>i,HJ˹_݆$dgW#WR[yO'^W::DK9U7.p }MSYHc Zc|qwk2@Br2d|zʁcj"%jHA!xG<`(1TcPHw#er?,\l92ͱNѐI;СuUE},muV `1/~ls=jA Bv:'HѬJar@lO~iL!̿ƻnri{W/(6zM%+$,U`.A#=MRQ26 0ws G`28[oyۊ|.ckp:p6ylkkWwX<vb2I$?*IJ4OΘ~޸[f&Tf/ qqi\Q7bT|򤢠Ѕ,mUm$ Ĩ' ryAq%U. Cƌ,zMaGwمm[l[tce!d-{±苼n2y$#M\B\a23]o!x@7pEx@:?pE̻\\]SV o` VUUSFf[fkM&wMuq$I(T]W63n[=n)"._65{(֧7vHyh-5<}:\B84qb-ē<7v{wgq,pF\GV%Ѱw.Iqco gd@3a?\WNE@P(@#QH#0Y}kiV(oS=hٌh!]y (^1IK@D2(pT`İ;X`0:#klZbm&qS~cn9j;k kW2$@K1݆rs'ϰ7jWrI3Fο0v6ƝYZp[n\c&~ڞRY䌤+Y,A ٟmՅ#=Ʈ,*r#09dI$e[g 7|P6t#6XAv88{ jYYkqWq\3dyq3 I\7nC<5{0vG!\U\#*N>@klmPy\sDVа1[h*`` tUYz )Ia`C$ʀr;6`{y/ suhWwLؠe-eRcS0FL1RC%I$&7u>T ǽd20[u %[!v98ҭ xeU2`O?@4?a-ľO%M+Ǜ|!s@+6h%`I `T!!@\(}G:lPxZwJ\@B,(1R7#O3# l Cvϸvu}MI#r0UEe7{0J,&rq`s)se܈q{J3Oy98i$!Aff`&ιȯ㰖h[ J`v&  H(rROrr 0 >_CαΧw5فa[i2@o.xk~_CΒW~_CΒ.7n~ RB9*yg?cxMt%E#b;wݸsTg$2X5Q'qP-zb-̮^uu,`%JB@g\FO$H,FHcuf<)a,]aRNlӚ֦rhhdtTmP z{tN *S"?SwKv b 1GZYXFGEf$;w9d &er<Wry2?+&KK>Y2~l0ORsϦMqfȍ[K*?6xn NOwŞ7`Nu4uIINP=3SYExcx<{cKrݬN+3(pzp,JEQԖUI{g=}M2 i~3oLJ_8(op}|S]h"U ȥ #oC%X@(h}z~/4Dx@2?}(i_qɫضLproa$GtU)`y4RH,_lMg#I&gJe sӠ$`%4?(謹8(/۟ޮG=:zTgNȷWqTb#29{O^wkػFGEEA۝T9N*JEdtRQJ.GEQp#J( kI\`2qdrG;l;pIX$g銷j[WmS=I$2zG *X7OSՔ2 Zw48WUV}WǡVAo( yw: w╗qIOyy{w瞘0y&FzU޳q ;v&Ԝaq$!VV3 ]9u#Ox?)E2n9sjZIӍb+ /Lm!1+|T*v-oi+ZZ?(褢&s@zib9<{YI pqUA,jP0AӱmբS#:'?[IlgI9.|ݖ=A=G"U Ȫ,u4lRsn}<~Z#Gi 8*(#nz.1 BHA9# ;Ϗ8=1\"6XA ;DY>][8ϯ?N:itD OpAkNe\qkB6ģk=?ιn|LwmXi7^+k$}麩鐅9欹y?VjK =sUVI iZGH4sL#kEtü oh` V`\?}zAyijG"s8=晬=qVYvlPq OLevvG4M)&Da]cSS-K#G:t|QYXoʫ-圊+=OA ,GN+r;ڱF2۩%o9rҪVvr5 5a-eY\!Qrzr9[dnp<+2=YZ@&ImWr=EvbvD [sO$UT|Ql(`69%$6i}P$O^:i[OpD2oCdc+߆ =EןT4³3P {.> N F@*1=s89h- av nHa~FEỘ6'#qQoq z#J,A^xVy.CP/ -LtCprsVLQQ;%FKTgX9o]DaRfǘdbNX-؊9RG&(;XuTP^Yb8'E P0:gzz>6]8]*!x$ZƕaAC jc(F^7pG#I;zQ`7WPicn`2J@^LԵR&RJF˯Zm6eUGpXR>Pϖ987ȷdaF.#uq;;s<ky *.+ң``iFʜv=ZU$KvtIa&y'#<^;m`Irڿ)nY+ɨz4&G993kq^%By2Yp6_*R- cYQV|F@98o%G'lWqUlp+݌`א,6*Xg?//=E5 UIZMG.F{Gg\kU Q6 ]{[?,G ġ `~ {qpIRQ C"I<8㹏O+IR Ee&Ӏ9T*7eE[X0%'/bzYuݬB"lpAϵXL{yݳnFwcv>LZ=2JD %$Ax-ȝQRd[(B~z]BբU+lî` } !5yʒ0yYO]=&؃͜cTrfQ䫌p6t6Iqd=1~Tn>ߕmoCR Wg8 '@XGPvdXw?Z xhPqFA?l8xxH T :c^9Ѭ-_ɉcݷ8)FQF?-@Ervߙ<$OSThZ9̊Uz`?thmoCVA$eYY^=+-8(m>1`p-ȂKYry eA=x8~U,-j󺓀2Hf <`c$oCP~Tn>ߕmoCRqӧQڍ*Bu'{ nsp=Hty1R*X6?0X3dkkSI}$r::Bk 㾴kiu p7vWq<I_"st$~5g[* K#tHm؞ 04tGSLvi c+8@p3ǁ5GVS(hԆ]'5zݮ-&Y fPdc%Ojo%-.jf}QhtT9*I+>Es1xVfQPK )~bmO㙣.¾g'gˡK{GͱOF?OF:AOT5v.$86g GQWoΨO {wUhR䐬 <D ] 'j21ߊ7͹qɜ:rpsgߴI!V\c?) 38G|yqLusU3o-h٭fL s‘9=(άO5m9?\gާާ,-^ wd1 Mm2{TOKP :77}:6o΍@77ާi}:5ާsz΍isz΍:6o΍P :77}:6o΍@77ާi}:5ާsz΍isz΍:6o΍P :77}:6o΍@77 J4G{Fl;TOP[h7̎?\QnoSѹOFѴ~tjOF?OFѨ#Ԯy!ʫ"H7dqym}l qӨ#F,nLkݩL#T᳴tZZVEyf}Tm\/'({5ǘۧQJ58(aqo8=7m`; Hůb?w]N֫II`reJ N?s@ ]K%IZSpNIOfiX%Q@9pZ3pd[]18ϣ~>M%yQ 9́1<mIت=sǡ?VL@a3m@lCqS[jq]_gzHamtcY'?cT߽l^?jN6co[:cvvs׏ހ.noSѹOFѴ~tzpLjdGߖܻs7owmhB#kvc].2&6ݜpG`vf{x i"ei2Gfru8Laf{ax~tB#;/L+ < py➚:B߸eO#dS3D6s-<)8N i4wܞGΤFݹq@զ3EO>^\#nޞRWGHHU| sGlUeQq422+cneKdr9ǧ2 Yf}`@\r9)U_<9aԁ\H܌ֺ[[ڤXm=!M8bC5Mi71>m2Ўῥfͣy.:֥ƕj??ҔE-NOş/?QoZ+5@̾@$b{q/O0_+{H]^zFg?^DV9yB P1᱑n>YZY$$G\ rJ-o>l@R^hʴ1)D~tV8_xܪ ȱK"@U$Ά Œ V)o`xR0(kA eErه#?<`t ?&`qXZ5A5qp4*?zq2F ^H%r)G]#p*TU\E@k[ƪ[r63×jWOHVDh&(cM0Ϸziq[۔1]9Kq{żKhRFSή-?=ݻuɻc]f}9ibA'TFdl}Y:дusrrpyV$sԌܛjQTRh3}tt2gjs.uV}L֨. TY.x`54cr1:Jr^q^ jo'Tx1Ig;S?|3L!>cV;;:9йYQuLme[M8C''wOLsZj/,o7HR0s1P?bc){|ӌmoЛh* 9lt$g878#&.>)?]]n\xq&IVt\)~hKVC J[^Bl@0Rv @=.x5x wH_t鎧f1ꚲXD,hyp !;pqɏV&\$Xf?O #nsQ"dI "'g8n1IL庚F1Pq}Hc) PJvJ$`ryz H0Ne'RYhmlOj=C.?,$l尥;94}Ri,X Hܠ1ӚGf3 [*xvqJHeEtsJYq 9.FJX7v9}xއ"$D:R R9ّpyC0h&`pF4\[-3ܹ'yfie{dӖIP$ezg=s$2u[bBnK~և>I!$ss=ijvb>c;N;:\|$=Ei.c2PDc 9bGۭXX䕒Eے#nGM!B #aш=8!13A(A˂WMH%̤u/jȑq+l7bg|qښ/TLd۴s{z Ek͜ATsr0:ˬQHmw WRL)d^r^2G^GZ//.ŅkX^0w.$ޠSjv TI zTq΍+q4oPpJ|V^H $r$/E$dSwT-0K§$1l BciH`qw9>[\TykM(9\ #ڗtӢO?—@pC)se*O Q΃Yj -F" &i~O'qRi+a>#yScrF9:$Uxd*w `r1zzR-E9̓?dFZ{Dp  1 `w<:gg[hesXr{%fI^]q㑑FzEFZl s,?(HQr2i59`[˔+:AV-KxHA9bnf>OaϠ >^{-i1(9Ni[M,ܨ;C`vx8=j5* 4Vb3g'#?I*Jvu9=srƕp6 ,epGb-䋳 '׵i}(U!!K3$ޤE|RވnAdI$f 16El\eͰf?*0w~|Չn@h=SW=O/8`mR 7`M ѽ-"Au)rm475<ĐGr{Su&HQw\DΉnb?pp[ge q efIZcȅrxѠ"4w/#$yTjz[7w:(Iv=MYD5 PIl.$Ēi/R? _t| Fmj*!ђсʐz18K%Αgdg Q=—햿ޓ?Z_`ir10^痐~7ZI|&Ŏ?;K?iQ.s'g|4kZ7^#'fHn-?_Cd|r0FQP.mM(X.dN:i$~v קf`I鶗+22'}OZٿi?sÙi9>i  :i#w;צe_wG+de=d}~_j^?;פ_^+22͹< ֥72B?Vp֐^+22 ?ߗR y?t^i8^+22 9i?:K'֭A-?/;ץ̌Y?4y?j:ÙlY?ƚo ?'ַ_?!ҿ;ק̌wzk 4V;s}vN|wG+ddŶI ?C[,ZF16??zQÙ"Y/-紟cZ`ir.JwO4{I|aci~_aG?紟imd:vN|v7z|\7HynO 'µeÙ?j~_'q-#ַW6KbFXizI'=~StHNm.V>de}ܜcHnµ;@pף:2lA>?Hn=L :i#w;צe_wG+de|O/µk7;ק̌snO&Aאґ_ҵоg^MXn=OQ;Z 'bFiCInc򑌮+liOwGvzǚ.V9$IRB{bt@z|j:!0)w`;QQ;VGh?Qh?Wa- V7TU!#@5z+ƍ "cQ1GOjswm$=Џ1r^Sk- KV>axFsA4al#̋bgzd~87PU>ɳ~ovqw\rk%I{eb] rT98 qYȫr0,@@Z H#XiL%f1Lv@K󟻊`7Ԣx%-ȡQK˖P9ak(|mA T?aHqĩ<ʠvoAj+VYk-r6 v[ꖶTFVfv*0Pab|ցbݽܨF'q=\ \iv+xu@ÒW 9ې96|^;ݴW7Ut$ʓq=c?Gdmی=1-Ssr<Οwר@ )Ia`C$ʀr; H"Vfa]EݴrNşdMYo\OO UIZMG.F{Gnvܺxr1ɓ'=k伂)9'c2BGAc[_G鉣WLwˀs=ppER֭,i(dMf+g81Y#f; > UH$KD.E;G46jI+\#H0Oc&7 xDJ Ā ~SbAffZ*p@9uGWv#՞;g u;1y@'?RԊ,*zj2ث(F^:gq(}*7oʐ E.Q~Tzg%hc&8B28POE<td,vPo/R#iTlLgs< qR>ߕEsrFaf'#QӹH%g-m$>T,e`OgF8sd v7y{6lg85K\<^8-)c 4>M<O@mЀz:5{f8عڝ`[!N38~T0]qz}E.QQړksOt_2Ev?1s, `U:*qYZM6^c*q Wm()Utttw-eu2 ۝ ;g&|?!?_ 凊g,1sijv4QEqQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEUnU1ظq>,F赢ȿZ]ff.t@L|LcùD ш31qW=O/evvG4M)&Da]cSS-K#G:tZEo㑧) Ei啥IRDxٟΑ-a/~xZky#ڧzĉyqX\mԂ iUa +;`c #KOYɯ[<PѻңjHbK'8# =YZ@&ImWr=EvbvD [sO$UT|Ql(ͻ]\Yd4Hʠ+3FO]d)7IT;!J8$1U%`H8[=&k;TWcJ1wߍu @$㡦-:GOqs&9/F2`igXgӆ@lj)5xGGwfqe(iz? M07$J0x?#s| dAvx8Ʌqץ]W)}+yf*2ŀ \r1阢ף{?;XJH&lr19=̶K0NBd. p9-p+iWª[`fJ\Q;rFx'"uxx*) ;uڟGtv&JvO8PG {yׂ!J ,ι¤%fUR%G(Q1N٥,P Uw6 INʱ ;H-Y$&hcZ]@!'')8ɨ5 hW ).w'wֺ-V[mHD_p 8,=͋YY13(2n%@!@ ` VR*R4epzӟP@./uhCP]u>yTjE;L tV.X%Q wOW14SĒQ0=%)y$:oPvG539kO_][Cs8NŐ,ws8aɦPb8! 1g8]"v ѲYS~ӬId[;p0rӺƯqErMfPʆ$q|=-W^A 4ƍv[ ;f'?w\I Ao3L[fS1V;%q$o8֛{j[ 2EbV^紽kc56FbTr? }{viL&FP2}?v^O&I2b̍xaX]Ģ9cf%LL~X 1 3.z +f޲K,H'3FG9yXdY/.M%@ T(x,M5Yq _16@8jSޥHbImo86X2Ar8Npjŧ-)Tn*FX͜vȪQHrPso/ r09'On. cH3 .OWs>u ̩-*UY5huXP~`i1z _٣f7 ##jRxZ,1c͍|̐pvno ն֧ʫm(2jd'2h 4a{Xq >lcC.I>{nV,mbHk}(̢)Gr *O^3ީbIo$?2Gq% Jc X9$ hݿS.b` XrsO):dȓ]e%*c(I O_LsRi]j,,tA23n;V+`xRQH’\ 0?)(’\ ϏCieDH7@6ܑE;6gsk,W@\QL’@.# 5F ?c]0#?JNY΢c? j+;|g3Gέjk>#ꍟO-nWEهF*GΣ~uVf[-+^ B!|n\G=EYA=ݽ̑w#nCǭy=KnM.ы!ڕ UmƟح[ːO#˝ᦚ |ɴw(8l{QA&ݢ1XĦ ʧ?{G9t}.6|m#>&y-ek\:ƻs߾4>LpQ['$$h;攘n->3ʜ^[ i~W3ǑYHp2} _|¿h۩rT)r9@ xYGU܆/FNA2Npr1'Uiwn;݉8$ɓ7_BU{-I lsw~nehmD2w'Aj_i(/Vd[Mxbp(z'H(G$>ٷ#wp88 x.Z$I[G( <:AI5~aU,Hß3Fnrcn#"]Yk/]O}/G)Oͬ\ɳk`e<:fMjՏU#O79WMj|src%p}*fY(d mۅ;H8H99yɫj{d\B!C> J,DGG僂 '^xOLkY g/{`r5<.v!!C,ftEynY^ ZY!jYxc9\C63[ݪ@#7 7HchsEs #9Pn!rFc=ĒI2חv9FU񍅶ixܘW#iR(ex+$USbBАGW\7:jg4$%Oݠf$Y4 L7̶blve`T0;bt6/ifPL1ϰ޻KKi'1T!g]>A-lY8dX{R wRD)Q]#o9A*gY"2@;ҙbEf>Cm'qmO9e%QS:/#:*M)h1ef* Hqg2J6J#k9 X!eǯb0ŇDRuG SITU1\$\˳qAaFJ'&\hm&# ud8FxSYr0.SDX3{wXF- ?yHjx9=68mYQ-0#vu+߷&5u%UiǑ8Shhq% 30MYfXX ^uUo?jgG\j|>\c`vz'&z64vԜvp"޶O3'nۂr?!/K>C, 3F\1'|goDl\qq!!Ba6o tF Nݥ𭱆l GBzw[i1KiޝIwn<OQ)'4)f>C, 3F\1'|g4 $[{k,%?~YT+d}_SZ$Zx$C 2FB,\4pXc%vơр.Oq+h So@X *0<|}r? 4Fb[ 1MX]brrX| a]mS#vrp<Oxl&O~lk.3s EQqrrhiu1dYM .S8 vӜH#djHײ[yRS*#OS4ih- S26A=ym#2ϚrWNsFg]$-}ͬN7NpqW./^+Xekyb2L`Ssc'T1v$bXUc޽}IM/ysYLMĩpWhɠR;R" mGlmSw/ uWVȦM@޼gs##tlr\LyWckk7qx\v3`Lʝ:@-E(((((((((((((((*WJ\78F赢-h3RO['ۯ*dxxtAn*EV((((((((((((((((((((O:u5?' 3CQq!<`SG`{nS |3+cq Wc\w?5?A߆/5gV5 A5Z>/]O}/G6q-uqO2AK`Yz/eYh m DѸ=kjV{\Z3]Gl("I-bAc>BHHcj󕭩%ί$U$1V8"C\I`!Q6ޡҳQٵ [9 '^^150ۤ #i0б`#;8CRiSi ䷒INO%{m\ǗǷw9 znouao,*$q R0qW9^TFDcl~L+8虶\|֐p6 Fzf1zzX]/?{s:$(!T@{ɠUkw-I5X+!#ǰ z7~wnyc 4$ 7t: ˇ-nd hRF S/!hM1MXc7G~ܮk-V̒*#)玿Y-S<&=Ww N1p`ƀiQE((((((((((((((((((((*?6QP#&?D.GZGZ]ffr|;\?` n뮾ƍ#R((((((((((((((((((((O:u5~#{ nb2va~j( f,x*<u SVC\w?5?A OEzo^u]SYj.rpOکQ]]Xc.Vv?woi7WEah_]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]?wQGՠ]T?2?jYğkΞǯ+-h-h3Q/ G@msѢYEP@QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQER7AΖt[>tmN̞?Aqp: Άj+ SB%7+Oj%]v*sV#^X?a_1F/? ?G(¯V#^X?{XwaWLj+gF/? =;5?G#USbz}k*)El1y=`Q?GpƢG(bz}ø{ cQ[?^X?1y=`Qa=_1F/? ?G(¯V#^X?{XwaWLj+gF/? =;5?G#USbz}k*)El1y=`Q?GpƢG(bz}ø{ cQ[?^X?1y=`Qa=_1F/? ?G(¯V#^X?{XwaWLj+gF/? =;5?G#USbz}k*)El1y=`Q?GpƢG(bz}ø{ cQ[?^X?1y=`Qa=_1F/? ?G(¯V#^X?{XwaWLj+gF/? =;5?G#USbz}k*)El1y=`Q?GpƢG(bz}ø{ cQ[?^X?1y=`Qa=_1F/? ?G(¯Mg3?hUQ^T=np+\#kE+\#kEu̽\D ?WV7[1?sѤ~jQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE}G󥣸Oa\}v΢zeM sC..gsޢ&ϓso3t*(.ciDL"X@1`PKVHBJ,8ǯ>訒3e2q88?1A h̡gӑϸ h+X%IcnEI@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@QWIJ\78G赢G赢G oh7`&84C'+ƍZ((((((((((((((((((((}hI5ٗIʥs1QDquq_\IY5&+s;4rʉgqz+)q̱a${^At}nk<nI #pNC($ӿQEb{b)Qi&1`sݒO\cJhU' :~t$ף͆{-"IGxfKJ)QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEUz?ڻv'pƋ_ 5( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( F8AΓks!*sϺ*+ *e|\ʹΖoUFԭ3:610Qs[;k3dyM䕝lmH׊G)EchD^gwyvvWwqsR{p1'|~a;E2N笗P{qw;ζ3PbWx0rj3=K(s)U$`FG1#n8Z,Zb~WXn>ocj}.UX-9l툆N~ܲс%3F o:ԕ}hZZe`;D2KGXr:g ǦEP{p. {S|߽t`:k:#(fU.v' ?cͨ ]!k7(-3vy3B3"A#T.# 1y$O@F(\/ 0X +կKyFS{mբ$`Pʕn\ZBdc1N ;^޾tõ+e1ڠn5[X-*q_{m .7wNz vwg5MFzF*l\\,$r! 9$cgry'[ؤXI Xg qN9\M<*DL*qXr凨ZBdc1N ;^޾PvlРQlVF_@/in{"FdllF7=X銖[aHd.fIx9z[cp̒U\`^VD[2+,rІu*ASsA4֧y?BK. Bn-PR5Uc!X$a,2FG#<YJm!H,Qc Hs9 oGl#1h킻uo'``rNӷ&~>Q&1"=47J/&M+RҖgki!Ve e T0L{䵕X.#'c$wg}x찴{fY$1? fn߼ugUPrA%f*67TAznXeY|Wp?2#_#"'eO,yAEU_Q<@4/pƤWw9p;85mDaJI$yk 1Q=&H*2bPzz&xwYĪPF6| q`-C6֑EQ0mcŒEK^ ?N(!v}{uӚ (8Z +`/9Mjݺ]m!`Fѱ^4ڼq][)") 3zTS2k.p꥓-Ap6r0 /"YdHB=d ؃zfɡmYuB#@5qe1 –ʀ@;Nt?y{eH) 82Ǫ0ÑzηA@34iTQEQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@QE![yG7q~qMQswե]Zkq5ys>s*7z)ب!8.f+yU^=s \=ċ a¦T񼓝ْ1Nَ|m'g P",[pHpƈf-f6nϮp3Mm:٬;#S cEۯ\C #wpq󍵛շ%X X2FYsĿxӡ+hJ%1!cTdc so[4[D8# :~ sFF_^ɭxsK-+j SaՃF'Ğ[ܛF<֋,ZzXE"*0031x9&ﯯwTHcdw,4cq:6q`dpY0UUK@2E\^9J.oE Ÿq8s-ݴ q rExav6?p\| N+ ! Qp)*M~x7g.$\˺"9984].- ;<Ƕi.A܀)F<3ֶr-M: )@YG<׹Fiym`g' t56WFzi6VFªiQEE M,``Fvq0 hޤwn# ȹ$)= E6x~]$ʀ$S#X_ yՊ wx)PyqVMN'd9v:8R@\%P2 >z4Qp1iSD9{eA;I8.<ZJyYI DIq&WL 9c t4Qp"᳆95V, sãItYdYJ-3b˰,KuzP/^c%FX#gr1Zz*gC Qm'y[%.g$㦢[O]Vlm{sg*}*i"E#e@01ޢ7K)`?!O'=/u;g8eV ʖ-^ #  (ӵ'Ybcq4.[%)^n)Kђ>RC| ME7E6?$Z IjSyx+fw ~S(6%1EK%Nyp0*mf.ͬhbRU%.O$}P+J.+i4MіL@"m'dWY[ew1>ann9(]G-!'h=# ?쫃$$ŃFQDeUT2arCp8m-[Qp24t}bviaq3*r1G" gErw{D 2ӹ淨swц餷0X-+$pORr $T_:>bd8`@'rEao-S(ihRDl>S˓MŸ'W3˵+' \ ;}`DB(ɔ)RNp<q&h]g8|q|A) r iQEώ ƪ|Xm:1H5e[,v.P ,$ H<:Qp0d+ݧ͂U2Ⴑ 0VO|jxB)$xcO7xc]vT ;ybvS-4& d7[w 8GoX)Kf+HҢ@QEQEQEQEQEQEQEQEQEQEQEDTqP_{#-h-h3Xüto/@Ǻ*E3N((((((((((((((((((((({ nsp=HtG$gU\nۀ$426H詥H#, H?1Nz>tEB$AUz|}9HhzQ-;N6q Xʪn;g$|t=.K/K8Xi גIyJ,it(v2qV|$Λ2`7r7qՊXn#Ynͣy1@- I|rAoyKQ\Ԯh]o.9WwC,p9Frd'y. DgE('#s/'V8±nm$ 31u$ %ܵjePyYt *Pg fCKawEH&@R?3\61P][4,7,Ef^k)ta38./,/\18, j(((((((((((((((((((((((((((((~?-hURԎ \78G赢G赢P37G0_+I 8`?@$jFfQL((((((((((((((((((()o?R{ n`RzP?:#ʥLdQc+s9&Uܧ9AImme" w1f,}KI`j(((((((((((((((((((((((((((((((((*S*T*>TObx@:?pE+\#kEuxs+wG*s Vʹ|h|,Ӣ( ((((((((((((((((((()KH:Oa((RçV^yr?`n.-ռAl|ˀ$dY)ehAs0si/,\\ƻ(Fm+3V=*QIv :@x-X!x`ȪWa% $ÜWNhb/+/*?W<9E uL[\n$w;'F{4u9YYf_13 gw9n@g$7ZXvv,wxy]v{)Ƌ˰rw/Ɣ\__yv .)7Xm$oGR^]˹?:] Z^]w6/I?:qiK:/.e޿.Iy)kG,{#V//shM`^]w6=h}{Z=e=GI?:3_Z Pv .to_αDڇS֔M^]˹?:7/X}@)Q8ch*mo_Γzx~u#ҙ5 KG9Wsgrx~tno3QzZ]ʿ^]w67F?:'Q (-tHz7Qww@Agm#;\yq\]ZWS'l.TGLT}bD# !s4JJ'7pq~7cբaۆ>_qLjLu|]F)/?¯DFdyt:ʲs)?, =C~]/Z6 }:U{#f_GZvs)? =E̿.˭/??“6~o9Yui?7(Ӭޟ!.˭N7P4okfwKցm^Ik?WQbw "!Zos S[WQb>FdZDG FI'85g˫`s)E^GHGKϰWR9{X#)yT/]v{/m\Gr2p[^sR;p? =GʾW֗5il?wӍ#^n=C'ޗ>}h6p{h#+OCS/wZp]~k{h#+g /?{Q.FEsi~F8=G1洞\'w}!BGRH@͗n;]25 +Dt8ߥgRe.1hA.fM#rw>{;ĩfFɓ qX6Fu2ך=L)$2&X,{žPEMhW rW(> Rl:J+?Wj?Z2#UgYj_X9rH87O?ZdEQ9ǓjG9YzLQ̃'RW=֤:?=֣+/T?=֥?Q̃GQZX1j9rIuˏԦ˟se*=֤:W=֣#vX;ǿse*pH֣G?Q̅U/e?=֣+4(_8B._jCs=֣#/QTU_ZdEgj/{G1ǿs fLڇ?{{G2VhQTFe}cǨA˴U#?ǿ>j9rGHO?:˟s e*2ǿi{G2V_K_Zx_ZdEP_ZD/{G2V^G~_jC`dAU%w.?R.Q΃(o_Z_ZxE*cǿQ΃('Q#Z/{G2+/QT?=֤?ZdТh _ZtEQW=֣Kj9rLڟQ̃V1ǿj9YEQ=֥+.TSSAGiGڊ\zg8RMq~+\#kE+\#kEvxw*Qp6Tw/u>W-o9<j_BTOw EV@O,Iߨq=3,9s(vc|-$;4#f 9HeݕUFI' ,w8f(;?EvWpaRny5Q-w 3(v ±٤?,_3vM7Na ϡ4sG(6m?4@z3+_֏W5\|¤TXTrc?9+?.WaM'/`~$Ӕ1,72/)֬-JiXz֣`8V$$zl_jG՚2#p?u #: ڋ ů߯'#o?XLW?!Z/a޴>սe_j_p??X8h,7?G_j?Gg_j P VP9!NdQ'4X,ok߯4꧴ XD0>oSEՏy?Zud'/sIӰYsğ @Հ_jIt-q/?Iq\G(gfr?M:dLW?ϩ=h΀j֤:ƒğ XܟΜ tX ì#a_j4$`5v~L/asҗkwjC5Qd?K8V&?4 N`X|I}ҰsZIW~ t'j/cIM#@nkC~j?s\ՄA±߯'S~ՆA4 zS~k' 4?4X,ojO֤:O֬<Q? ,7FRU1/`oZiZ,7G_jiq-Zqi#xjǼ Rk/g?s?hfН\kԟ =Z>@ڸs\ԑ럞^?Z9_֝t_n^? CI`/sߏJΗ(tZRZ֬,&r?yԣVl/b(c@lk8<_jwrV(V?SpjZj$z#,:%6FJ)MԠ}$p9>UG`3,7Гi ̪>{"3IXC`r3U9Eq&+?Q?Wq!@j34cUR^@KKIdFXL b?SjA")Nb'10Mn{sWEB.otOQXܽme1,3dUN6r0+ $qcqlb^ێhyw'NB3rd0^6S͟C &97u,J[ k\ZJ?Ӿ?AM2 GCM.TB8ddP]#]i)r 9;v9fm.41:0HrnG8]1 ^bn12,pe j?>q?qF"_T,svu!h숕vL*lltf J!qha!cqqFFp.D$bicp0Fw3⏱vRgif)1!R]vRƌ5Yi`n|1i(sGf#5-#_= !tC#8#21ðag) H#ܒ #D|yϯ:Fm'#YfM;y8 0`p{0 ֥MAsKw5&7nQSoo z8;##үT](G=j`_qO΋"l}?Q4ҍ ygqfp[?AFPz: hH4+"$oZ?W /GXW4 @lvt;,}1Gj?T\ 13g'j1}U>H#XTcOS(+@w:A_qG gzQEhawA}Ra5 ϥ&=ia1y˜hf 0k@藿'L3)}3ZؗYΗ!}Po>cڴ[BT+?:b()x>_?WTg =ha_cXc#04`֧k}Q_ꋠ2q1_G/I}hX L 1ihx䰈`֚t;TC#ғ?wT y=ia1x?L43p?Ȥ㸭vTwJ?Tr?: 5|WD kH70W~tCB}Ra^% vIӦ+C ?G c X)9??_GT]F5|=T]qO6>h`p~tAǩYcNnSy?GڧfgK6vC!tg)ϗdO7^k缟٣Sy?G`g}D|,vh7Kj$u_j{}>?4{(vyj?$t~O=j{}=;HփP#U?]Dc~?4}'hP.vzXA??nv_nSy?GڧfeK6 /O7IMG!yڧfO==-u]?+[j%?4}'hPo˲tPי}'hTO9zpRc?n}GyC?O=j{}=;?4}'hPϳjUcD+7^c缟٣Sy?G`oǗe~>ɨrך'hTO9d睗? }Dv?nSy?GڧfeNucʲtF?4{(fzaQ-8>n?睏2TO缟٣Cs+PV?nXy7^a缟٣Si?GaIjc˱tk,!yڧfO=Kڈ'?nuj{}>?4{(vvzQO/&luj{}>?4{8fzX?c7Joc0_י'hTO9PcO/Dv?nSy?Gڧfe#ӄ:t߳?ܱuj{}>?4{(vymG?n캇,%yڧf\yG`g}P 7Nj#YK\yGڮ?缿٣CsַXce_7L& 7^k/hU4{(vvz_5XKp@Wc/̾q=jfeNuc˱tF<%yڮ?缿٣w_9zcj @tִHG?5]4}{}={;=(Y#,!'"y[,z}yڮ?缿٣W_9fPz??m595U4}{}={3=0%C_#PV?nW_/hP=??畏Yy7^a/hU4{(vFq=Kڈ'vGQݟ.י{}>?4{(vvzQOY~>ɨc,!yڧfO==-u]?)K uj{}>?4{(vvz`v`Qoec̾?4}'hP=8A+#o>ͩ;/7^e缟٣Sy?G`fԿ睗?캏uj{}>?4{(vfzgٵ t?南I~?4}'hP=5&o5e>?4}'hPj?$to$u_j{}>?4{(vvzwUI>Ϩ+/י}'hTO9zcj,tִ'5TO缟٣GsE?块IO)eAU;I> 19; BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} my ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my $dbh = DBI->connect("dbi:Sybase:$Srv;database=$Db", $Uid, $Pwd, {PrintError => 1}); plan skip_all => "No connection - did you set the user, password and server name correctly in PWD?\n" unless $dbh; #plan tests => 16; SKIP: { skip "?-style placeholders aren't supported with this SQL Server", 10 unless $dbh->{syb_dynamic_supported}; my $rc; my $jan03 = 'Jan 3 1998'; my $jan25 = 'Jan 25 1998'; $rc = $dbh->do("create table #t(string varchar(20), date datetime, val float, other_val numeric(9,3))"); ok($rc, 'Create table'); my $sth = $dbh->prepare("insert #t values(?, ?, ?, ?)"); ok($sth, 'prepare'); $rc = $sth->execute("test", $jan03, 123.4, 222.3334); ok($rc, 'insert 1'); ok $sth->bind_param(1, "other test"); ok $sth->bind_param(2, $jan25); # the order of these two bind_param's is swapped on purpose ok $sth->bind_param(4, 2); ok $sth->bind_param(3, 4445123.4); $rc = $sth->execute(); ok($rc, 'insert 2'); do { local $sth->{PrintError} = 0; $rc = $sth->execute("test", "Feb 30 1998", 123.4, 222.3334); }; ok(!$rc, 'insert 3 (fail)'); $sth = $dbh->prepare("select * from #t where date > ? and val > ?"); ok($sth, 'prepare 2'); $rc = $sth->execute('Jan 1 1998', 120); ok($rc, 'select'); # get the dates in the expected locale format my $sthDates = $dbh->prepare( "select convert(datetime, '$jan03'), convert(datetime, '$jan25')"); $sthDates->execute; my ($jan03formatted, $jan25formatted) = @{$sthDates->fetchall_arrayref->[0]}; my $rows = $sth->fetchall_arrayref; is(@$rows, 2, 'fetch count'); is_deeply $rows, [ [ 'test', $jan03formatted, '123.4', '222.333' ], [ 'other test', $jan25formatted, '4445123.4', '2.000' ] ]; ok $sth->execute('Jan 1 1998', 140); $rows = $sth->fetchall_arrayref; is(@$rows, 1, 'fetch 2'); is_deeply $rows, [ [ 'other test', $jan25formatted, '4445123.4', '2.000' ] ]; SKIP: { skip 'requires ASE 15 ', 1 if $dbh->{syb_server_version} lt '15' || $dbh->{syb_server_version} eq 'Unknown' || $dbh->{syb_server_version} eq 'MS-SQL'; $dbh->do("create table #t2(t1 tinyint, t2 bigint, t3 unsigned int)"); my $sth3 = $dbh->prepare("insert #t2 values(?, ?, ?)"); $sth3->bind_param(1, 1); #, SQL_TINYINT); $sth3->bind_param(2, 3); #, SQL_BIGINT); $sth3->bind_param(3, 34000); my $rc = $sth3->execute(); ok($rc, "insert bigint"); } } $dbh->disconnect; exit(0); DBD-Sybase-1.24/t/exec.t0000644000175000017500000001246714361730257015105 0ustar mpepplermpeppler#!perl # # $Id: exec.t,v 1.9 2005/10/01 13:05:13 mpeppler Exp $ use lib 'blib/lib'; use lib 'blib/arch'; use lib 't'; use _test; use strict; #use Test::More qw(no_plan); use Test::More tests => 25; BEGIN { use_ok('DBI', ':sql_types'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); #DBI->trace(3); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); #DBI->trace(3); my $dbh = DBI->connect("dbi:Sybase:$Srv;database=$Db", $Uid, $Pwd, {PrintError=>1}); #exit; ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 22) { ok(0); } exit(0); } $SIG{__WARN__} = sub { print @_; }; my $sth = $dbh->prepare("exec sp_helpindex \@objname = ?"); ok(defined($sth), 'Prepare sp_helpindex'); my $rc; $rc = $sth->execute("sysusers"); ok(defined($rc), "exec sysusers"); get_all_results($sth); #$dbh->do("use tempdb"); $dbh->do("set arithabort off"); $dbh->do("if object_id('dbitest') is not NULL drop proc dbitest"); $rc = $dbh->do(qq{ create proc dbitest \@one varchar(20), \@two int, \@three numeric(5,2), \@four smalldatetime, \@five float output as select \@one, \@two, \@three, \@four select * from master..sysprocesses return \@two }); ok(defined($rc), "$rc (create proc)\n"); $sth = $dbh->prepare("exec dbitest \@one = ?, \@two = ?, \@three = ?, \@four = ?, \@five = ? output"); #$rc = $sth->execute("one", 2, 3.2, "jan 1 2001", 5.4); ok(defined($sth), "prepare dbitest"); $sth->bind_param(1, "one"); $sth->bind_param(2, 2, SQL_INTEGER); $sth->bind_param(3, 3.2, SQL_DECIMAL); $sth->bind_param(4, "jan 1 2001"); $sth->bind_param(5, 5.4, SQL_FLOAT); $rc = $sth->execute(); ok(defined($rc), "execute dbitest 1"); #DBI->trace(4); get_all_results($sth); $rc = $sth->execute("one", 25, 333.2, "jan 1 2001", 5.4); ok(defined($rc), "exec dbitest 2"); get_all_results($sth); $rc = $sth->execute(undef, 25, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "exec dbitest 3"); my @out = $sth->func('syb_output_params'); ok($out[0] == 5.4, "out param 1"); #print "@out\n"; #do { # local $^W = 0; # while(my $d = $sth->fetch) { # print "@$d\n"; # } #} while($sth->{syb_more_results}); # test various failure modes: $sth->{syb_do_proc_status} = 1; $dbh->{syb_flush_finish} = 0; $rc = $sth->execute(undef, 0, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 1"); get_all_results($sth); #DBI->trace(3); $rc = $sth->execute("raise", 1, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 2"); get_all_results($sth); #DBI->trace(0); # This one fails with FreeTDS (even with a Sybase back-end) my $oc_version = $dbh->{syb_oc_version}; $rc = $sth->execute(undef, 0, 3.2234, "jan 3 2001", 5.4); SKIP: { skip 'Test fails with FreeTDS', 1 if !defined($oc_version) || $oc_version =~ /freetds/; ok(defined($rc), "execute fail mode 3"); get_all_results($sth); } $dbh->{syb_flush_finish} = 1; $rc = $sth->execute(undef, 0, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 4"); get_all_results($sth); #DBI->trace(3); $rc = $sth->execute(undef, 1, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 5"); get_all_results($sth); #DBI->trace(0); $rc = $sth->execute(undef, 0, 3.2234, "jan 3 2001", 5.4); ok(defined($rc), "execute fail mode 6"); get_all_results($sth); $dbh->do("drop proc dbitest"); $dbh->do("if object_id('dbitest') is not NULL drop proc dbitest"); $rc = $dbh->do(qq{ create proc dbitest \@one varchar(20), \@two int, \@three numeric(5,2), \@four smalldatetime --, \@five float = null output as select \@one, \@two, \@three, \@four }); ok(defined($rc), "$rc (create proc)\n"); $sth = $dbh->prepare("exec dbitest ?, ?, ?, ?"); $sth->bind_param(1, 'String 1', SQL_VARCHAR); $sth->bind_param(2, 1, SQL_INTEGER); $sth->bind_param(3, 3.25, SQL_DECIMAL); $sth->bind_param(4, '2005-06-27', SQL_DATETIME); for (0 .. 1) { $sth->execute('String 1', 1, 3.25, '2005-06-27'); while(my $row = $sth->fetch) { ok($row->[2] == 3.25, "Implicit finish handling"); } } $dbh->{syb_do_proc_status} = 1; $sth = $dbh->prepare("exec dbitest ?, ?, ?, ?"); $sth->bind_param(1, 'String 1', SQL_VARCHAR); $sth->bind_param(2, 1, SQL_INTEGER); $sth->bind_param(3, 3.25, SQL_DECIMAL); $sth->bind_param(4, '2005-06-27', SQL_DATETIME); for (0 .. 1) { $sth->execute('String 1', 1, 3.25, '2005-06-27'); while(my $row = $sth->fetch) { ok($row->[2] == 3.25, "Implicit finish handling"); } } $dbh->do("drop proc dbitest"); $dbh->do("if object_id('[my dbitest]') is not NULL drop proc [my dbitest]"); $rc = $dbh->do(qq{ create proc [my dbitest] \@one varchar(20), \@two int, \@three numeric(5,2), \@four smalldatetime --, \@five float = null output as select \@one, \@two, \@three, \@four }); ok(defined($rc), "$rc (create proc)\n"); $sth = $dbh->prepare("exec [my dbitest] ?, ?, ?, ?"); $sth->bind_param(1, 'String 1', SQL_VARCHAR); $sth->bind_param(2, 1, SQL_INTEGER); $sth->bind_param(3, 3.25, SQL_DECIMAL); $sth->bind_param(4, '2005-06-27', SQL_DATETIME); for (0 .. 1) { $sth->execute('String 1', 1, 3.25, '2005-06-27'); while(my $row = $sth->fetch) { ok($row->[2] == 3.25, "Implicit finish handling"); } } $dbh->do("drop proc [my dbitest]"); sub get_all_results { my $sth = shift; do { while(my $d = $sth->fetch) { #print "@$d\n"; ; } } while($sth->{syb_more_results}); } DBD-Sybase-1.24/t/login.t0000644000175000017500000000134614361730257015263 0ustar mpepplermpeppler#!perl # # $Id: login.t,v 1.4 2007/04/12 16:09:36 mpeppler Exp $ use lib 'blib/lib'; use lib 'blib/arch'; use lib 't'; use _test; use strict; use Test::More tests => 6; use vars qw($Pwd $Uid $Srv $Db); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); #DBI->trace(3); my $dbh = DBI->connect("dbi:Sybase:$Srv;database=$Db", $Uid, $Pwd, {PrintError => 1}); #DBI->trace(0); ok($dbh, 'Connect'); ok $dbh->ping, "ping should pass after connect"; $dbh->disconnect if $dbh; ok !$dbh->ping, "ping should fail after disconnect"; $dbh = DBI->connect("dbi:Sybase:$Srv;database=$Db", 'ohmygod', 'xzyzzy', {PrintError => 0}); ok(!$dbh, 'Connect fail'); $dbh->disconnect if $dbh; exit(0); DBD-Sybase-1.24/t/fail.t0000644000175000017500000000526714361730257015074 0ustar mpepplermpeppler#!/usr/local/bin/perl # # $Id: fail.t,v 1.9 2005/10/01 13:05:13 mpeppler Exp $ use lib 'blib/lib'; use lib 'blib/arch'; use strict; use lib 't'; use _test; use Test::More tests=>12; #qw(no_plan); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my $dbh = DBI->connect("dbi:Sybase:$Srv;database=$Db", $Uid, $Pwd, {PrintError => 0, syb_flush_finish => 1}); ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 12) { ok(0); } exit(0); } my $rc; my $sth; #DBI->trace(4); # This test only works with Sybase - apparently MS-SQL will not compile the whole batch (the 3 sql statements) # in one go, and therefore won't flag the error until the second SELECT is executed. # Sybase compiles the batch in one go, and will return the error immediately. SKIP: { skip 1, "Test does not work with MS-SQL" if $dbh->{syb_server_version} eq 'Unknown' || $dbh->{syb_server_version} eq 'MS-SQL'; my $sth = $dbh->prepare(" select * from sysusers select * from no_such_table select * from master..sysdatabases "); $rc = $sth->execute; ok(!defined($rc), 'Missing table'); } $sth = $dbh->prepare("select * from sysusers\n"); $rc = $sth->execute; ok(defined($rc), 'Sysusers'); while(my $d = $sth->fetch) { ; } $rc = $dbh->do("create table #test(one int not null primary key, two int not null, three int not null, check(two != three))"); ok(defined($rc), 'Create table'); SKIP: { skip '? placeholders not supported', 3 unless $dbh->{syb_dynamic_supported}; $sth = $dbh->prepare("insert #test (one, two, three) values(?,?,?)"); $rc = $sth->execute(3, 4, 5); ok(defined($rc), 'prepare w/placeholder'); $rc = $sth->execute(3, 4, 5); ok(!defined($rc), 'execute w/placeholder'); $rc = $sth->execute(5, 3, 3); ok(!defined($rc), 'execute w/placeholder'); } $sth = $dbh->prepare(" insert #test(one, two, three) values (1, 2, 3) insert #test(one, two, three) values (4, 5, 6) insert #test(one, two, three) values (1, 2, 3) insert #test(one, two, three) values (8, 9, 10) "); $rc = $sth->execute; ok(!defined($rc), 'prepare'); $sth = $dbh->prepare("select * from #test"); $rc = $sth->execute; ok(defined($rc), 'select'); while(my $d = $sth->fetch) { print "@$d\n"; } #print "ok 11\n"; $sth = $dbh->prepare(" insert #test(one, two, three) values (11, 12, 13) select * from #test insert #test(one, two, three) values (11, 12, 13) "); $rc = $sth->execute; ok(defined($rc), 'prepare/execute multi'); do { while(my $d = $sth->fetch) { print "@$d\n"; } } while($sth->{syb_more_results}); $dbh->do("drop table #test"); DBD-Sybase-1.24/t/_test.pm0000644000175000017500000000170614361730257015442 0ustar mpepplermpeppler# $Id: _test.pm,v 1.2 2007/03/01 17:17:44 mpeppler Exp $ package _test; $| = 1; #keep stdout in sync with stderr my ( $Uid, $Pwd, $Srv, $Db ); my ($host, $port); sub load_data { my @dirs = ( './.', './..', './../..', './../../..' ); foreach (@dirs) { if ( -f "$_/PWD" ) { open( PWD, "$_/PWD" ) || die "$_/PWD is not readable: $!\n"; while () { chop; s/^\s*//; next if ( /^\#/ || /^\s*$/ ); ( $l, $r ) = split(/=/); $Uid = $r if ( $l eq UID ); $Pwd = $r if ( $l eq PWD ); $Srv = $r if ( $l eq SRV ); $Db = $r if ( $l eq DB ); } close(PWD); last; } } if ($Srv =~ /(\w+):(\w+)/) { $host = $1; $port = $2; } } sub get_info { load_data(); $Db = 'tempdb' unless $Db; my $server; if (defined($host)) { $server = "host=$host;port=$port"; } else { $server = "server=$Srv"; } return ( $Uid, $Pwd, $server, $Db ); } 1; DBD-Sybase-1.24/t/base.t0000644000175000017500000000100314010471204015034 0ustar mpepplermpeppler#!/usr/local/bin/perl -w # # $Id: base.t,v 1.2 2003/03/31 23:55:11 mpeppler Exp $ # 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"; $drh = DBI->install_driver('Sybase'); (ref $drh eq 'DBI::dr') ? print "ok 4\n" : print "not ok 4\n"; print "ok 5\n" if $drh->{Version}; #my @d = DBI->data_sources('Sybase'); #print STDERR "@d\n"; BEGIN { $tests = 5 } exit 0; # end. DBD-Sybase-1.24/t/xblob.t0000644000175000017500000001067714361730257015270 0ustar mpepplermpeppler#!perl # # $Id: xblob.t,v 1.12 2007/03/01 17:17:44 mpeppler Exp $ use lib 't'; use strict; use _test; use Test::More tests=>11; #qw(no_plan); use vars qw($Pwd $Uid $Srv $Db $loaded); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); #DBI->trace(3); my $dbh = DBI->connect("dbi:Sybase:$Srv;database=$Db", $Uid, $Pwd, {PrintError=>1}); #exit; ok($dbh, 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 11) { ok(0); } exit(0); } $dbh->do("if object_id('blob_test') != NULL drop table blob_test"); my $rc = $dbh->do("create table blob_test(id int, data image null, foo varchar(30))"); ok($rc, 'Create table'); open(IN, "t/screen.jpg") || die "Can't open t/screen.jpg: $!"; binmode(IN); my $image; { local $/; $image = ; } close(IN); my $heximg = unpack('H*', $image); $rc = $dbh->do("insert blob_test(id, data, foo) values(1, '', 'screen.jpg')"); ok($rc, 'Insert image'); #DBI->trace(3); my $sth = $dbh->prepare("select id, data from blob_test"); #$sth->{syb_no_bind_blob} = 1; $sth->execute; while($sth->fetch) { # my $d; # $sth->func(2, \$d, 0, 'ct_get_data'); $sth->func('CS_GET', 2, 'ct_data_info') || print $sth->errstr, "\n"; } $sth->func('ct_prepare_send') || print $sth->errstr, "\n"; $sth->func('CS_SET', 2, {total_txtlen => length($image), log_on_update=>1}, 'ct_data_info') || print $sth->errstr, "\n"; $sth->func($image, length($image), 'ct_send_data') || print $sth->errstr, "\n"; $sth->func('ct_finish_send') || print $sth->errstr, "\n"; $dbh->{LongReadLen} = 100000; $sth = $dbh->prepare("select id, data from blob_test"); #$dbh->{LongReadLen} = 100000; #DBI->trace(3); $sth->{syb_no_bind_blob} = 1; $sth->execute; my $heximg2 = ''; my $size = 0; while(my $d = $sth->fetch) { my $data; # open(OUT, ">/tmp/mp_conf.jpg") || die "Can't open /tmp/mp_conf.jpg: $!"; while(1) { my $read = $sth->func(2, \$data, 1024, 'ct_get_data'); $heximg2 .= unpack('H*', $data); $size += $read; last unless $read == 1024; # print OUT $data; } # close(OUT); } #warn "Got $size bytes\n"; ok($heximg eq $heximg2, 'Images are the same'); mkdir("./tmp", 0755); open(ONE, ">./tmp/hex1"); binmode(ONE); print ONE $heximg; close(ONE); open(TWO, ">./tmp/hex2"); binmode(TWO); print TWO $heximg2; close(TWO); $rc = $dbh->do("drop table blob_test"); ok($rc, 'Drop table'); SKIP: { skip 'Requires DBI 1.34', 4 unless $DBI::VERSION >= 1.34; my $rc = $dbh->do("create table blob_test(id int, data image null, foo varchar(30))"); ok($rc, 'Creat table'); open(IN, "t/screen.jpg") || die "Can't open t/screen.jpg: $!"; binmode(IN); my $image; { local $/; $image = ; } close(IN); my $heximg = unpack('H*', $image); $rc = $dbh->do("insert blob_test(id, data, foo) values(1, '', 'screen.jpg')"); ok($rc, 'Insert image'); #DBI->trace(3); my $sth = $dbh->prepare("select id, data from blob_test"); #$sth->{syb_no_bind_blob} = 1; $sth->execute; while($sth->fetch) { # my $d; # $sth->func(2, \$d, 0, 'ct_get_data'); $sth->syb_ct_data_info('CS_GET', 2) || print $sth->errstr, "\n"; } $sth->syb_ct_prepare_send() || print $sth->errstr, "\n"; $sth->syb_ct_data_info('CS_SET', 2, {total_txtlen => length($image), log_on_update=>1}) || print $sth->errstr, "\n"; $sth->syb_ct_send_data($image, length($image)) || print $sth->errstr, "\n"; $sth->syb_ct_finish_send() || print $sth->errstr, "\n"; #DBI->trace(4); $dbh->{LongReadLen} = 100000; $sth = $dbh->prepare("select id, data from blob_test"); #$dbh->{LongReadLen} = 100000; #DBI->trace(0); #DBI->trace(3); $sth->{syb_no_bind_blob} = 1; $sth->execute; my $heximg2 = ''; my $size = 0; while(my $d = $sth->fetch) { my $data; # open(OUT, ">/tmp/mp_conf.jpg") || die "Can't open /tmp/mp_conf.jpg: $!"; while(1) { my $read = $sth->syb_ct_get_data(2, \$data, 1024); $heximg2 .= unpack('H*', $data); $size += $read; last unless $read == 1024; # print OUT $data; } # close(OUT); } #warn "Got $size bytes\n"; ok($heximg eq $heximg2, 'Images are the same'); mkdir("./tmp"); open(ONE, ">./tmp/hex1"); binmode(ONE); print ONE $heximg; close(ONE); open(TWO, ">./tmp/hex2"); binmode(TWO); print TWO $heximg2; close(TWO); $rc = $dbh->do("drop table blob_test"); ok($rc, 'Drop table'); } DBD-Sybase-1.24/t/multi_sth.t0000644000175000017500000001761314363254775016177 0ustar mpepplermpeppler# -*-Perl-*- # $Id: multi_sth.t,v 1.3 2005/10/01 13:05:13 mpeppler Exp $ # # # Multiple sth on single dbh test. use lib 't'; use _test; use strict; use Test::More tests => 49; #use Test::More qw(no_plan); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase'); } use vars qw($Pwd $Uid $Srv $Db); ( $Uid, $Pwd, $Srv, $Db ) = _test::get_info(); my $dbh = DBI->connect( "dbi:Sybase:$Srv;database=$Db", $Uid, $Pwd, { PrintError => 0, AutoCommit => 1, } ); ok( defined($dbh), 'Connect' ); if ( !$dbh ) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for ( 4 .. 49 ) { ok(0); } exit(0); } test1($dbh); test2($dbh); test3($dbh); test4($dbh); test5($dbh); test6($dbh); test_cached($dbh); # Vanilla test - do the "correct" prepare/execute handling. sub test1 { my $dbh = shift; my $rc; my $sth1 = $dbh->prepare("select * from master..sysprocesses"); ok( defined($sth1), 'test1 prepare1' ); my $sth2 = $dbh->prepare("select * from sysusers"); ok( defined($sth2), 'test1 prepare2' ); $rc = $sth1->execute; ok( defined($rc), 'test1 execute1' ); $rc = 0; while ( my $d = $sth1->fetch ) { if ( $sth1->err ) { $rc = $sth1->err; } } if ( $sth1->err ) { $rc = $sth1->err; } ok( $rc == 0, "test1 fetch1" ); $rc = $sth2->execute; ok( defined($rc), 'test1 execute2' ); $rc = 0; while ( my $d = $sth2->fetch ) { if ( $sth2->err ) { $rc = $sth2->err; } } if ( $sth2->err ) { $rc = $sth2->err; } ok( $rc == 0, "test1 fetch2" ); } # Same thing, with placeholders. sub test2 { my $dbh = shift; SKIP: { skip '? placeholders not supported', 6 unless $dbh->{syb_dynamic_supported}; my $rc; my $sth1 = $dbh->prepare("select * from master..sysprocesses where spid = ?"); ok( defined($sth1), 'test2 prepare1' ); my $sth2 = $dbh->prepare("select * from sysusers where uid = ?"); ok( defined($sth2), 'test2 prepare2' ); $rc = $sth1->execute(1); ok( defined($rc), 'test2 execute1' ); $rc = 0; while ( my $d = $sth1->fetch ) { if ( $sth1->err ) { $rc = $sth1->err; } } if ( $sth1->err ) { $rc = $sth1->err; } ok( $rc == 0, "test2 fetch1" ); $rc = $sth2->execute(1); ok( defined($rc), 'test2 execute2' ); $rc = 0; while ( my $d = $sth2->fetch ) { if ( $sth2->err ) { $rc = $sth2->err; } } if ( $sth2->err ) { $rc = $sth2->err; } ok( $rc == 0, "test2 fetch2" ); } # SKIP } # Same thing, with placeholders. sub test3 { my $dbh = shift; SKIP: { skip '? placeholders not supported', 6 unless $dbh->{syb_dynamic_supported}; my $rc; my $sth1 = $dbh->prepare("select * from master..sysprocesses where spid = ?"); ok( defined($sth1), 'test3 prepare1' ); my $sth2 = $dbh->prepare("select * from sysusers where uid = ?"); ok( defined($sth2), 'test3 prepare2' ); $rc = $sth1->execute(1); ok( defined($rc), 'test3 execute1' ); # Interleaved execute() $rc = $sth2->execute(1); ok( defined($rc), 'test3 execute2' ); $rc = 0; while ( my $d = $sth1->fetch ) { if ( $sth1->err ) { $rc = $sth1->err; } } if ( $sth1->err ) { $rc = $sth1->err; } ok( $rc == 0, "test3 fetch1" ); $rc = 0; #DBI->trace(4); while ( my $d = $sth2->fetch ) { if ( $sth2->err ) { $rc = $sth2->err; } } if ( $sth2->err ) { $rc = $sth2->err; } ok( $rc == 0, "test3 fetch2" ); } #SKIP } # Same thing, first with placeholders, second without sub test4 { my $dbh = shift; SKIP: { skip '? placeholders not supported', 6 unless $dbh->{syb_dynamic_supported}; my $rc; my $sth1 = $dbh->prepare("select * from master..sysprocesses where spid = ?"); ok( defined($sth1), 'test4 prepare1' ); my $sth2 = $dbh->prepare("select * from sysusers"); ok( defined($sth2), 'test4 prepare2' ); $rc = $sth1->execute(1); ok( defined($rc), 'test4 execute1' ); # Interleaved execute() $rc = $sth2->execute(); ok( defined($rc), 'test4 execute2' ); $rc = 0; while ( my $d = $sth1->fetch ) { if ( $sth1->err ) { $rc = $sth1->err; } } if ( $sth1->err ) { $rc = $sth1->err; } ok( $rc == 0, "test4 fetch1" ); $rc = 0; #DBI->trace(4); while ( my $d = $sth2->fetch ) { if ( $sth2->err ) { $rc = $sth2->err; } } if ( $sth2->err ) { $rc = $sth2->err; } ok( $rc == 0, "test4 fetch2" ); } #SKIP } # This time, set the "no_child_con" flag, and execute the statements # sequentially. sub test5 { my $dbh = shift; SKIP: { skip '? placeholders not supported', 8 unless $dbh->{syb_dynamic_supported}; my $rc; $dbh->{syb_no_child_con} = 1; my $sth1 = $dbh->prepare("select * from master..sysprocesses where spid = ?"); ok( defined($sth1), 'test5 prepare1' ); $rc = $sth1->execute(1); ok( defined($rc), 'test5 execute1' ); $rc = 0; while ( my $d = $sth1->fetch ) { if ( $sth1->err ) { $rc = $sth1->err; } } if ( $sth1->err ) { $rc = $sth1->err; } ok( $rc == 0, "test5 fetch1" ); my $sth2 = $dbh->prepare("select * from sysusers"); ok( defined($sth2), 'test5 prepare2' ); $rc = $sth2->execute(); ok( defined($rc), 'test5 execute2' ); $rc = 0; #DBI->trace(4); while ( my $d = $sth2->fetch ) { if ( $sth2->err ) { $rc = $sth2->err; } } if ( $sth2->err ) { $rc = $sth2->err; } ok( $rc == 0, "test5 fetch2" ); $rc = $sth1->execute(1); ok( defined($rc), 'test5 execute3' ); $rc = 0; while ( my $d = $sth1->fetch ) { if ( $sth1->err ) { $rc = $sth1->err; } } if ( $sth1->err ) { $rc = $sth1->err; } ok( $rc == 0, "test5 fetch3" ); } #SKIP $dbh->{syb_no_child_con} = 0; } # This time, set the "no_child_con" flag, and execute the statements # sequentially. Same as test5, but no dynamic SQL. sub test6 { my $dbh = shift; my $rc; $dbh->{syb_no_child_con} = 1; my $sth1 = $dbh->prepare("select * from master..sysprocesses"); ok( defined($sth1), 'test6 prepare1' ); $rc = $sth1->execute(); ok( defined($rc), 'test6 execute1' ); $rc = 0; while ( my $d = $sth1->fetch ) { if ( $sth1->err ) { $rc = $sth1->err; } } if ( $sth1->err ) { $rc = $sth1->err; } ok( $rc == 0, "test6 fetch1" ); my $sth2 = $dbh->prepare("select * from sysusers"); ok( defined($sth2), 'test6 prepare2' ); $rc = $sth2->execute(); ok( defined($rc), 'test6 execute2' ); $rc = 0; #DBI->trace(4); while ( my $d = $sth2->fetch ) { if ( $sth2->err ) { $rc = $sth2->err; } } if ( $sth2->err ) { $rc = $sth2->err; } ok( $rc == 0, "test6 fetch2" ); $rc = $sth1->execute(); ok( defined($rc), 'test6 execute3' ); $rc = 0; while ( my $d = $sth1->fetch ) { if ( $sth1->err ) { $rc = $sth1->err; } } if ( $sth1->err ) { $rc = $sth1->err; } ok( $rc == 0, "test6 fetch3" ); $dbh->{syb_no_child_con} = 0; } sub test_cached { my $dbh = shift; my $sth1 = $dbh->prepare_cached("select * from master..sysprocesses", undef, 0); ok( defined($sth1), "test_cache prepare1"); my $rc = $sth1->execute(); ok( defined($rc), "test_cache execute1"); $rc = 0; while ( my $d = $sth1->fetch ) { if ( $sth1->err ) { $rc = $sth1->err; } } if ( $sth1->err ) { $rc = $sth1->err; } ok( $rc == 0, "test_cache fetch1" ); my $sth2 = $dbh->prepare_cached("select * from master..sysprocesses", undef, 0); ok( defined($sth2), "test_cache prepare2"); $rc = $sth2->execute(); ok( defined($rc), "test_cache execute2"); $rc = 0; while ( my $d = $sth2->fetch ) { if ( $sth2->err ) { $rc = $sth2->err; } } if ( $sth2->err ) { $rc = $sth2->err; } ok( $rc == 0, "test_cache fetch2" ); } DBD-Sybase-1.24/t/nsql.t0000644000175000017500000000252414361730257015127 0ustar mpepplermpeppler#!perl # # $Id: nsql.t,v 1.5 2005/10/01 13:05:13 mpeppler Exp $ use lib 't'; use _test; use strict; use Test::More tests => 7; #qw(no_plan); use vars qw($Pwd $Uid $Srv $Db); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); #DBI->trace(3); my $dbh = DBI->connect("dbi:Sybase:$Srv;database=$Db", $Uid, $Pwd, {syb_deadlock_retry=>10, syb_deadlock_verbose=>1}); #exit; ok($dbh, 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 7) { ok(0); } exit(0); } my @d = $dbh->func("select * from sysusers", 'ARRAY', 'nsql'); ok(@d >= 1, 'array'); foreach (@d) { local $^W = 0; print "@$_\n"; } #print "ok 3\n"; @d = $dbh->func("select * from sysusers", 'ARRAY', \&cb, 'nsql'); ok(@d == 1, 'array 2'); foreach (@d) { print "$_\n"; } SKIP: { skip 'requires DBI 1.34', 2 unless $DBI::VERSION >= 1.34; @d = $dbh->syb_nsql("select * from sysusers", 'ARRAY'); ok(@d >= 1, 'syb_nsql 1'); foreach (@d) { local $^W = 0; print "@$_\n"; } # print "ok 5\n"; @d = $dbh->syb_nsql("select * from sysusers", 'ARRAY', \&cb); ok(@d == 1, 'syb_nsql 2'); foreach (@d) { print "$_\n"; } # print "ok 6\n"; } sub cb { my @data = @_; local $^W = 0; print "@data\n"; 1; } DBD-Sybase-1.24/t/utf8.t0000644000175000017500000001121314361730257015033 0ustar mpepplermpeppler#!perl # # $Id: utf8.t,v 1.5 2011/10/02 15:01:50 mpeppler Exp $ use lib 't'; use _test; use strict; use Test::More; BEGIN { plan skip_all => 'This test requires Perl 5.8+' unless $] >= 5.008; } use DBI; use DBD::Sybase; use Encode (); binmode( $_, 'utf8' ) for map { Test::Builder->new->$_() } qw( output failure_output todo_output ); use vars qw($Pwd $Uid $Srv $Db); ( $Uid, $Pwd, $Srv, $Db ) = _test::get_info(); my $dbh = DBI->connect( "dbi:Sybase:$Srv;database=$Db;charset=utf8", $Uid, $Pwd, { PrintError => 1 } ); $dbh->{syb_enable_utf8} = 1; # Don't run this test on MS-SQL ("Unknown") servers... unless ($dbh->{syb_server_version} ne 'Unknown' && $dbh->{syb_server_version} ne 'MS-SQL' && $dbh->{syb_server_version} ge '15' && $dbh->{syb_enable_utf8}) { plan skip_all => 'This test requires ASE 15 or later, and OpenClient 15.x or later'; } plan tests => 11; $dbh->do("create table #utf8test (uv univarchar(510), ut unitext)"); my $ascii = 'Some text'; # This is a byte string rather than a character string - this means that when using this # to compare with the output from the DB we get a failure, even though the strings appear # to be the same. So the string needs to be converted to UTF8 characters via Encode::decode() # for use in the test. To simplify I've commented this out and use the second sample string # instead. my $utf8t = 'पट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट्टपट'; #my $utf8 = Encode::decode('UTF-8', $utf8t); my $utf8 = "\x{263A} - smiley1 - \x{263B} - smiley2" x 15; { my $quoted = $dbh->quote($ascii); $dbh->do("insert into #utf8test (uv, ut) values ($quoted, $quoted)"); my $rows = $dbh->selectall_arrayref( "select * from #utf8test", { Slice => {} } ); is_deeply( $rows, [ { uv => $ascii, ut => $ascii, } ], "got expected row back from #utf8test" ); ok( !Encode::is_utf8( $rows->[0]{uv} ), 'uv column was returned with utf8 flag off' ); ok( !Encode::is_utf8( $rows->[0]{ut} ), 'ut column was returned with utf8 flag off' ); } { $dbh->do("delete from #utf8test"); my $quoted = $dbh->quote($utf8); $dbh->do("insert into #utf8test (uv, ut) values ($quoted, $quoted)"); my $rows = $dbh->selectall_arrayref( "select * from #utf8test", { Slice => {} } ); is_deeply( $rows, [ { uv => $utf8, ut => $utf8, } ], "got expected row back from #utf8test" ); ok( Encode::is_utf8( $rows->[0]{uv} ), 'uv column was returned with utf8 flag on' ); ok( Encode::is_utf8( $rows->[0]{ut} ), 'ut column was returned with utf8 flag on' ); } $dbh->{syb_enable_utf8} = 0; { my $rows = $dbh->selectall_arrayref( "select * from #utf8test", { Slice => {} } ); ok( !Encode::is_utf8( $rows->[0]{uv} ), 'uv column was returned with utf8 flag off (syb_enable_utf8 was false)' ); ok( !Encode::is_utf8( $rows->[0]{ut} ), 'ut column was returned with utf8 flag off (syb_enable_utf8 was false)' ); } { my $dbh2 = DBI->connect( "dbi:Sybase:$Srv;database=$Db;charset=utf8", $Uid, $Pwd, { PrintError => 1, syb_enable_utf8 => 1 } ); $dbh2->do("create table #utf8test (uv univarchar(250), ut unitext)"); my $quoted = $dbh->quote($utf8); $dbh2->do("insert into #utf8test (uv, ut) values ($quoted, $quoted)"); my $rows = $dbh2->selectall_arrayref( "select * from #utf8test", { Slice => {} } ); is_deeply( $rows, [ { uv => substr($utf8, 0, 250), ut => $utf8, } ], "got expected row back from #utf8test" ); ok( Encode::is_utf8( $rows->[0]{uv} ), 'uv column was returned with utf8 flag on (syb_enable_utf8 passed to connect)' ); ok( Encode::is_utf8( $rows->[0]{ut} ), 'ut column was returned with utf8 flag on (syb_enable_utf8 passed to connect)' ); } DBD-Sybase-1.24/t/xblk.t0000644000175000017500000002754614361730257015125 0ustar mpepplermpeppler# -*-Perl-*- # $Id: xblk.t,v 1.11 2005/11/04 18:35:54 mpeppler Exp $ # # # Small BLK test script for DBD::Sybase use lib 't'; use _test; use strict; use Test::More tests => 62; BEGIN { use_ok('DBI'); use_ok('DBD::Sybase'); } use vars qw($Pwd $Uid $Srv $Db); ( $Uid, $Pwd, $Srv, $Db ) = _test::get_info(); sub cslib_cb { my ( $layer, $origin, $severity, $number, $errmsg, $osmsg, $usermsg ) = @_; print "cslib_cb: $layer $origin $severity $number $errmsg\n"; print "cslib_cb: User Message: $usermsg\n"; if ( $number == 36 ) { return 1; } return 0; } $SIG{__WARN__} = sub { print @_; }; DBD::Sybase::set_cslib_cb( \&cslib_cb ); #DBI->trace(5); my $charset = get_charset( $Srv, $Uid, $Pwd ); my $dbh = DBI->connect( "dbi:Sybase:$Srv;database=$Db;charset=$charset;bulkLogin=1", $Uid, $Pwd, { PrintError => 1, AutoCommit => 1, } ); # syb_err_handler => sub { local $^W = 0; # print "@_\n"; # return 0}}); ok( defined($dbh), 'Connect' ); if ( !$dbh ) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for ( 4 .. 62 ) { ok(1); } exit(0); } SKIP: { skip 'No BLK library available.', 59 unless $dbh->{syb_has_blk}; my $rc = $dbh->do( "create table #tmp(x numeric(9,0) identity, a1 varchar(20), i int null, n numeric(6,2), d datetime, s smalldatetime, mn money, mn1 smallmoney, b varbinary(8), img image null)" ); ok( defined($rc), 'Create table' ); test1($dbh); test2($dbh); test3($dbh); test4($dbh); test5($dbh); test6($dbh); test7($dbh); test8($dbh); } sub test1 { my $dbh = shift; $dbh->begin_work; # DBI->trace(4); my $sth = $dbh->prepare( "insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 } } ); ok( defined($sth), 'Prepare #1' ); my @data = ( [ undef, "one", 123, 123.4, 'Oct 11 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 1000 ], [ undef, "two", -1, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100 ], [ undef, "three", undef, 1234.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100 ] ); my $rc; my $i = 1; foreach (@data) { $_->[8] = pack( 'H*', $_->[8] ); $rc = $sth->execute(@$_); ok( defined($rc), "Send row $i - test 1" ); ++$i; } $rc = $dbh->commit(); ok( $rc, 'Commit test 1' ); my $rows = $sth->rows(); ok( $rows == 3, 'Rows test 1' ); $sth->finish; # DBI->trace(0); } sub test2 { my $dbh = shift; # Now test conversion failures. None of these rows should get loaded. $dbh->begin_work; my $sth = $dbh->prepare( "insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 } } ); ok( defined($sth), 'prepare #2' ); my @data = ( [ undef, "one b", 123, 123.4, 'feb 29 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 100 ], [ undef, "two b", 123456789123456, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100 ], [ undef, "three b", undef, 123456.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100 ], [ undef, "four b", undef, 126.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, "34343434343434343434.23", '21212121', 'z' x 100 ], ); my $i = 1; my $rc; foreach (@data) { $_->[8] = pack( 'H*', $_->[8] ); $rc = $sth->execute(@$_); ok( !defined($rc), "Execute row $i, test 2" ); ++$i; } $rc = $dbh->commit; ok( $rc, 'Commit test 2' ); my $rows = $sth->rows; ok( $rows == 0, 'Rows, test 2' ); $sth->finish; } # Test explicit identity value inserts. sub test3 { my $dbh = shift; $dbh->begin_work; my $sth = $dbh->prepare( "insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 1, identity_column => 0 } } ); ok( defined($sth), 'Prepare #3' ); my @data = ( [ 10, "one", 123, 123.4, 'Nov 1 2001 12:00', 'Nov 1 2001', 343434.3333, 34.23, 'deadbeef', 'z' x 100 ], [ 11, "two", -1, 123.456, '11/1/2001 12:00', '11/1/2001 11:21', 343434.3333, 34.23, '25252525', 'z' x 100 ], [ 12, "three", undef, 123, 'Nov 1 2001 12:00', 'Nov 1 2001', 343434.3333, 34.23, '43434343', 'z' x 100 ] ); my $i = 1; my $rc; foreach (@data) { $_->[8] = pack( 'H*', $_->[8] ); $rc = $sth->execute(@$_); ok( defined($rc), "Execute row $i, test 3" ); ++$i; } $rc = $dbh->commit; ok( $rc, 'Commit, test 3' ); my $rows = $sth->rows; ok( $rows == 3, 'Rows, test 3' ); $sth->finish; } # Test for prepare failures sub test4 { my $dbh = shift; $dbh->begin_work; my $sth = $dbh->prepare( "insrt #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 1, identity_column => 0 } } ); ok( !defined($sth), 'Prepare #4' ); print $dbh->errstr, "\n"; # DBI->trace(5); my $sth1 = $dbh->prepare( "select * from #tmp where foo = ?", { syb_bcp_attribs => { identity_flag => 1, identity_column => 0 } } ); ok( !defined($sth1), 'Prepare #5' ); my $sth2 = $dbh->prepare( "select * from #tmp", { syb_bcp_attribs => { identity_flag => 1, identity_column => 0 } } ); ok( !defined($sth2), 'Prepare #6' ); print $dbh->errstr, "\n"; } # Test for missing commit/finish. sub test5 { my $dbh = shift; $dbh->begin_work; my $sth = $dbh->prepare( "insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 } } ); ok( defined($sth), 'Prepare test 5' ); my @data = ( [ undef, "test5 one", 123, 123.4, 'Oct 11 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 1000 ], [ undef, "test5 two", -1, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100 ], [ undef, "test5 three", undef, 1234.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100 ] ); my $rc; my $i = 1; foreach (@data) { $_->[8] = pack( 'H*', $_->[8] ); $rc = $sth->execute(@$_); ok( defined($rc), "Send row $i - test 5" ); ++$i; } local $^W = 0; $sth->finish; } # Test for rollback. sub test6 { my $dbh = shift; $dbh->begin_work; my $sth = $dbh->prepare( "insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 } } ); ok( defined($sth), 'Prepare test 6' ); my @data = ( [ undef, "test6 one", 123, 123.4, 'Oct 11 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 1000 ], [ undef, "test6 two", -1, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100 ], [ undef, "test6 three", undef, 1234.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100 ] ); my $rc; my $i = 1; foreach (@data) { $_->[8] = pack( 'H*', $_->[8] ); $rc = $sth->execute(@$_); ok( defined($rc), "Send row $i - test 6" ); ++$i; } $rc = $dbh->rollback; ok( $rc, 'test 6 rollback' ); $rc = $sth->finish; ok( $rc, 'test 6 finish' ); $sth = undef; $dbh->begin_work; my $sth2 = $dbh->prepare("select count(*) from #tmp where a1 like 'test6 %'"); ok( defined($sth2), 'test 6 prepare select' ); $rc = $sth2->execute; ok( $rc, 'test 6 execute select' ); my $row = $sth2->fetch; ok( $row && $row->[0] == 0, 'test 6 row value' ); $sth2->finish; $sth2 = undef; $dbh->commit; $dbh->begin_work; $sth = $dbh->prepare( "insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 } } ); ok( defined($sth), 'Prepare test 6 (2)' ); foreach (@data) { $_->[8] = pack( 'H*', $_->[8] ); $rc = $sth->execute(@$_); ok( defined($rc), "Send row $i - test 6" ); ++$i; } $rc = $dbh->commit; ok( $rc, 'test 6 commit' ); foreach (@data) { $_->[8] = pack( 'H*', $_->[8] ); $rc = $sth->execute(@$_); ok( defined($rc), "Send row $i - test 6" ); ++$i; } $rc = $dbh->rollback; ok( $rc, 'test 6 rollback' ); $rc = $sth->finish; ok( $rc, 'test 6 finish' ); $sth = undef; # DBI->trace(0); } sub test7 { my $dbh = shift; $dbh->{AutoCommit} = 1; # Test some of the data in the #tmp table. my $sth = $dbh->prepare("select count(*), sum(i), sum(n) from #tmp"); ok( defined($sth), 'prepare test 7' ); my $rc = $sth->execute; ok( $rc, 'execute test 7' ); my ( $c, $i, $n ); while ( my $row = $sth->fetch ) { ( $c, $i, $n ) = @$row; print "@$row\n"; } ok( $c == 9, 'Row count' ); ok( $i == 366, 'Sum(i)' ); ok( $n == 3333.11, 'Sum(n)' ); } # Turn autocommit off, update some data, then try to run # a bcp operation. # This tests to make sure that the AutoCommit/CHAINED mode flip/flop # happens correctly sub test8 { my $dbh = shift; #DBI->trace(4); $dbh->begin_work; my $sth = $dbh->prepare("update #tmp set i = 20 where i = 123"); ok( defined($dbh), 'Prepare update test 8' ); my $rc = $sth->execute; ok( $rc, 'Execute update test 8' ); $sth = undef; $sth = $dbh->prepare( "insert #tmp values(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)", { syb_bcp_attribs => { identity_flag => 0, identity_column => 1 } } ); ok( defined($sth), 'Prepare test 8' ); my @data = ( [ undef, "one", 123, 123.4, 'Oct 11 2001 11:00', 'Oct 11 2001', 23.456789, 44.23, 'deadbeef', 'x' x 1000 ], [ undef, "two", -1, 123.456, 'Oct 12 2001 11:23', 'Oct 11 2001', 44444444444.34, 44353.44, '0a0a0a0a', 'a' x 100 ], [ undef, "three", undef, 1234.78, 'Oct 11 2001 11:00', 'Oct 11 2001', 343434.3333, 34.23, '20202020', 'z' x 100 ] ); my $i = 1; foreach (@data) { $_->[8] = pack( 'H*', $_->[8] ); $rc = $sth->execute(@$_); ok( defined($rc), "Send row $i - test 8" ); ++$i; } $rc = $dbh->commit(); ok( $rc, 'Commit test 8' ); my $rows = $sth->rows(); ok( $rows == 3, 'Rows test 8' ); # $sth->finish; $sth = undef; } sub get_charset { my $srv = shift; my $uid = shift; my $pwd = shift; my $dbh = DBI->connect( "dbi:Sybase:$srv", $uid, $pwd ); die "Can't connect to $srv" unless $dbh; my $sth = $dbh->prepare("sp_configure 'default character set id'"); $sth->execute; my $id; while ( my $r = $sth->fetch ) { $id = $r->[4]; } $sth->finish; if ( !$id ) { warn "Can't find charset id - using iso_1"; return 'iso_1'; } $sth = $dbh->prepare("select name from master..syscharsets where id = $id"); $sth->execute; my $charset; while ( my $r = $sth->fetch ) { $charset = $r->[0]; } if ( !defined($charset) ) { warn "Can't find charset name - using iso_1"; return 'iso_1'; } return $charset; } DBD-Sybase-1.24/t/autocommit.t0000644000175000017500000000407514361730257016336 0ustar mpepplermpeppler#!/usr/bin/perl # # $Id: autocommit.t,v 1.6 2005/10/01 13:05:13 mpeppler Exp $ use lib 'blib/lib'; use lib 'blib/arch'; use lib 't'; use _test; use strict; use Test::More tests => 9; #use Test::More qw(no_plan); BEGIN { use_ok('DBI'); use_ok('DBD::Sybase');} use vars qw($Pwd $Uid $Srv $Db); #DBI->trace(2); ($Uid, $Pwd, $Srv, $Db) = _test::get_info(); my $dbh = DBI->connect("dbi:Sybase:$Srv;database=$Db", $Uid, $Pwd, {PrintError => 0}); ok(defined($dbh), 'Connect'); if(!$dbh) { warn "No connection - did you set the user, password and server name correctly in PWD?\n"; for (4 .. 11) { ok(0); } exit(0); } $dbh->do("create table #ttt (foo varchar(20), bar int)"); $dbh->{AutoCommit} = 0; $dbh->do("insert #ttt values('a string', 1)"); $dbh->do("insert #ttt values('another string', 2)"); $dbh->do("insert #ttt values('foodiboo', 3)"); $dbh->do("insert #ttt values('a string', 4)"); $dbh->rollback; my $sth = $dbh->prepare("select * from #ttt"); $sth->execute; my $found = 0; while(my $d = $sth->fetch) { print "@$d\n"; ++$found; } ok(!$found, 'rollback'); $dbh->do("insert #ttt values('a string', 1)"); $dbh->do("insert #ttt values('another string', 2)"); $dbh->do("insert #ttt values('foodiboo', 3)"); $dbh->do("insert #ttt values('a string', 4)"); $dbh->commit; $sth = $dbh->prepare("select * from #ttt"); $sth->execute; $found = 0; while(my $d = $sth->fetch) { print "@$d\n"; ++$found; } ok($found == 4, 'Commit'); # Add some tests to validate the begin_work() functionality $dbh->{AutoCommit} = 1; $dbh->begin_work; $dbh->do("insert #ttt values('a string', 1)"); $dbh->do("insert #ttt values('another string', 2)"); $dbh->do("insert #ttt values('foodiboo', 3)"); $dbh->do("insert #ttt values('a string', 4)"); $dbh->commit; ok($dbh->{AutoCommit} == 1, "begin_work"); # Test to check for problems with non-chained mode. $dbh->{syb_chained_txn} = 0; $dbh->{AutoCommit} = 0; $sth = $dbh->prepare("select 5"); ok($sth, "Non-chained prepare"); my $rc = $sth->finish; ok($rc, "Finish"); $rc = $dbh->commit; ok($rc, "commit"); $dbh->disconnect; DBD-Sybase-1.24/dbivport.h0000644000175000017500000000374014010471204015506 0ustar mpepplermpeppler/* dbivport.h Provides macros that enable greater portability between DBI versions. This file should be *copied* and included in driver distributions and #included into the source, after #include DBIXS.h New driver releases should include an updated copy of dbivport.h from the most recent DBI release. */ #ifndef DBI_VPORT_H #define DBI_VPORT_H #ifndef DBIh_SET_ERR_CHAR /* Emulate DBIh_SET_ERR_CHAR Only uses the err_i, errstr and state parameters. */ #define DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method) \ sv_setiv(DBIc_ERR(imp_xxh), err_i); \ (state) ? (void)sv_setpv(DBIc_STATE(imp_xxh), state) : (void)SvOK_off(DBIc_STATE(imp_xxh)); \ sv_setpv(DBIc_ERRSTR(imp_xxh), errstr) #endif #ifndef DBIcf_Executed #define DBIcf_Executed 0x080000 #endif #ifndef DBIc_TRACE_LEVEL_MASK #define DBIc_TRACE_LEVEL_MASK 0x0000000F #define DBIc_TRACE_FLAGS_MASK 0xFFFFFF00 #define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug) #define DBIc_TRACE_LEVEL(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK) #define DBIc_TRACE_FLAGS(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK) /* DBIc_TRACE_MATCHES - true if s1 'matches' s2 (c.f. trace_msg()) DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp)) */ #define DBIc_TRACE_MATCHES(s1, s2) \ ( ((s1 & DBIc_TRACE_LEVEL_MASK) >= (s2 & DBIc_TRACE_LEVEL_MASK)) \ || ((s1 & DBIc_TRACE_FLAGS_MASK) & (s2 & DBIc_TRACE_FLAGS_MASK)) ) /* DBIc_TRACE - true if flags match & DBI level>=flaglevel, or if DBI level>level DBIc_TRACE(imp, 0, 0, 4) = if level >= 4 DBIc_TRACE(imp, DBDtf_FOO, 2, 4) = if tracing DBDtf_FOO & level>=2 or level>=4 DBIc_TRACE(imp, DBDtf_FOO, 2, 0) = as above but never trace just due to level */ #define DBIc_TRACE(imp, flags, flaglevel, level) \ ( (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \ || (level && DBIc_TRACE_LEVEL(imp) >= level) ) #endif #endif /* !DBI_VPORT_H */ DBD-Sybase-1.24/META.json0000664000175000017500000000233014577756334015155 0ustar mpepplermpeppler{ "abstract" : "DBI driver for Sybase datasources", "author" : [ "Michael Peppler (mpeppler@peppler.org)" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "DBD-Sybase", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "DBI" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/mpeppler/DBD-Sybase/issues" }, "repository" : { "type" : "git", "url" : "https://github.com/mpeppler/DBD-Sybase.git", "web" : "https://github.com/mpeppler/DBD-Sybase" } }, "version" : "1.24", "x_serialization_backend" : "JSON::PP version 2.27400_02" } DBD-Sybase-1.24/META.yml0000664000175000017500000000126114577756334015007 0ustar mpepplermpeppler--- abstract: 'DBI driver for Sybase datasources' author: - 'Michael Peppler (mpeppler@peppler.org)' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: DBD-Sybase no_index: directory: - t - inc requires: DBI: '0' resources: bugtracker: https://github.com/mpeppler/DBD-Sybase/issues repository: https://github.com/mpeppler/DBD-Sybase.git version: '1.24' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' DBD-Sybase-1.24/README.vms0000644000175000017500000000257514010471204015175 0ustar mpepplermpeppler$Id: README.vms,v 1.1 1999/05/19 15:22:37 mpeppler Exp $ From: "Craig A. Berry" To: Michael Peppler , dbi-users@fugue.com, vmsperl@perl.org Subject: DBD::Sybase 0.15 makefile.pl patch for VMS Date: Tue, 18 May 1999 17:39:59 -0500 Two minor fixes to makefile.pl were necessary. The first one avoids a double colon in the filename for MAN3PODS. The second moves the call to unixify up earlier where it needs to be. The patch at the end of this message accomplishes both. I did my build using DEC C V5.2-003 on OpenVMS Alpha V7.1 with perl 5.005_03, DBI 1.08. There is a bug in the VMS portion of Liblist.pm that messes up the order of the libraries when creating the linker options file. You can either edit sybase.opt by hand to restore the original order or apply the patch available at the following location: for 5.005_02: for 5.005_03: and a fix for File::Spec:VMS is necessary to get the test suite to even begin to work: Oh, and if you want Dynaloader to find it (pretty important), rename sybase.exe to libsybase.exe after you do the install.