| 1 | # $Id: Driver.xst,v 10.19 2001/05/29 23:25:55 timbo Exp $ |
| 2 | # Copyright (c) 1994,1995,1996,1997,1998 Tim Bunce |
| 3 | # |
| 4 | # You may distribute under the terms of either the GNU General Public |
| 5 | # License or the Artistic License, as specified in the Perl README file. |
| 6 | |
| 7 | |
| 8 | MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~ |
| 9 | |
| 10 | REQUIRE: 1.929 |
| 11 | PROTOTYPES: DISABLE |
| 12 | |
| 13 | BOOT: |
| 14 | items = 0; /* avoid 'unused variable' warning */ |
| 15 | DBISTATE_INIT; |
| 16 | /* XXX this interface will change: */ |
| 17 | DBI_IMP_SIZE("DBD::~DRIVER~::dr::imp_data_size", sizeof(imp_drh_t)); |
| 18 | DBI_IMP_SIZE("DBD::~DRIVER~::db::imp_data_size", sizeof(imp_dbh_t)); |
| 19 | DBI_IMP_SIZE("DBD::~DRIVER~::st::imp_data_size", sizeof(imp_sth_t)); |
| 20 | dbd_init(DBIS); |
| 21 | |
| 22 | |
| 23 | |
| 24 | # ------------------------------------------------------------ |
| 25 | # driver level interface |
| 26 | # ------------------------------------------------------------ |
| 27 | MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~::dr |
| 28 | |
| 29 | # disconnect_all renamed and ALIAS'd to avoid length clash on VMS :-( |
| 30 | void |
| 31 | discon_all_(drh) |
| 32 | SV * drh |
| 33 | ALIAS: |
| 34 | disconnect_all = 1 |
| 35 | CODE: |
| 36 | D_imp_drh(drh); |
| 37 | if (0) ix = ix; /* avoid unused variable warning */ |
| 38 | ST(0) = dbd_discon_all(drh, imp_drh) ? &sv_yes : &sv_no; |
| 39 | |
| 40 | |
| 41 | |
| 42 | # ------------------------------------------------------------ |
| 43 | # database level interface |
| 44 | # ------------------------------------------------------------ |
| 45 | MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~::db |
| 46 | |
| 47 | void |
| 48 | _login(dbh, dbname, username, password, attribs=Nullsv) |
| 49 | SV * dbh |
| 50 | char * dbname |
| 51 | SV * username |
| 52 | SV * password |
| 53 | SV * attribs |
| 54 | CODE: |
| 55 | { |
| 56 | STRLEN lna; |
| 57 | D_imp_dbh(dbh); |
| 58 | char *u = (SvOK(username)) ? SvPV(username,lna) : ""; |
| 59 | char *p = (SvOK(password)) ? SvPV(password,lna) : ""; |
| 60 | #ifdef dbd_db_login6 |
| 61 | ST(0) = dbd_db_login6(dbh, imp_dbh, dbname, u, p, attribs) ? &sv_yes : &sv_no; |
| 62 | #else |
| 63 | ST(0) = dbd_db_login( dbh, imp_dbh, dbname, u, p) ? &sv_yes : &sv_no; |
| 64 | #endif |
| 65 | } |
| 66 | |
| 67 | |
| 68 | void |
| 69 | commit(dbh) |
| 70 | SV * dbh |
| 71 | CODE: |
| 72 | D_imp_dbh(dbh); |
| 73 | if (DBIc_has(imp_dbh,DBIcf_AutoCommit)) |
| 74 | warn("commit ineffective with AutoCommit enabled"); |
| 75 | ST(0) = dbd_db_commit(dbh, imp_dbh) ? &sv_yes : &sv_no; |
| 76 | |
| 77 | void |
| 78 | rollback(dbh) |
| 79 | SV * dbh |
| 80 | CODE: |
| 81 | D_imp_dbh(dbh); |
| 82 | if (DBIc_has(imp_dbh,DBIcf_AutoCommit)) |
| 83 | warn("rollback ineffective with AutoCommit enabled"); |
| 84 | ST(0) = dbd_db_rollback(dbh, imp_dbh) ? &sv_yes : &sv_no; |
| 85 | |
| 86 | void |
| 87 | disconnect(dbh) |
| 88 | SV * dbh |
| 89 | CODE: |
| 90 | D_imp_dbh(dbh); |
| 91 | if ( !DBIc_ACTIVE(imp_dbh) ) { |
| 92 | XSRETURN_YES; |
| 93 | } |
| 94 | /* pre-disconnect checks and tidy-ups */ |
| 95 | if (DBIc_CACHED_KIDS(imp_dbh)) { |
| 96 | SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh)); /* cast them to the winds */ |
| 97 | DBIc_CACHED_KIDS(imp_dbh) = Nullhv; |
| 98 | } |
| 99 | /* Check for disconnect() being called whilst refs to cursors */ |
| 100 | /* still exists. This possibly needs some more thought. */ |
| 101 | if (DBIc_ACTIVE_KIDS(imp_dbh) && DBIc_WARN(imp_dbh) && !dirty) { |
| 102 | STRLEN lna; |
| 103 | char *plural = (DBIc_ACTIVE_KIDS(imp_dbh)==1) ? "" : "s"; |
| 104 | warn("%s->disconnect invalidates %d active statement handle%s %s", |
| 105 | SvPV(dbh,lna), (int)DBIc_ACTIVE_KIDS(imp_dbh), plural, |
| 106 | "(either destroy statement handles or call finish on them before disconnecting)"); |
| 107 | } |
| 108 | ST(0) = dbd_db_disconnect(dbh, imp_dbh) ? &sv_yes : &sv_no; |
| 109 | DBIc_ACTIVE_off(imp_dbh); /* ensure it's off, regardless */ |
| 110 | |
| 111 | |
| 112 | void |
| 113 | STORE(dbh, keysv, valuesv) |
| 114 | SV * dbh |
| 115 | SV * keysv |
| 116 | SV * valuesv |
| 117 | CODE: |
| 118 | D_imp_dbh(dbh); |
| 119 | if (SvGMAGICAL(valuesv)) |
| 120 | mg_get(valuesv); |
| 121 | ST(0) = &sv_yes; |
| 122 | if (!dbd_db_STORE_attrib(dbh, imp_dbh, keysv, valuesv)) |
| 123 | if (!DBIS->set_attr(dbh, keysv, valuesv)) |
| 124 | ST(0) = &sv_no; |
| 125 | |
| 126 | void |
| 127 | FETCH(dbh, keysv) |
| 128 | SV * dbh |
| 129 | SV * keysv |
| 130 | CODE: |
| 131 | D_imp_dbh(dbh); |
| 132 | SV *valuesv = dbd_db_FETCH_attrib(dbh, imp_dbh, keysv); |
| 133 | if (!valuesv) |
| 134 | valuesv = DBIS->get_attr(dbh, keysv); |
| 135 | ST(0) = valuesv; /* dbd_db_FETCH_attrib did sv_2mortal */ |
| 136 | |
| 137 | |
| 138 | void |
| 139 | DESTROY(dbh) |
| 140 | SV * dbh |
| 141 | PPCODE: |
| 142 | D_imp_dbh(dbh); |
| 143 | ST(0) = &sv_yes; |
| 144 | if (!DBIc_IMPSET(imp_dbh)) { /* was never fully set up */ |
| 145 | STRLEN lna; |
| 146 | if (DBIc_WARN(imp_dbh) && !dirty && DBIS->debug >= 2) |
| 147 | PerlIO_printf(DBILOGFP, |
| 148 | " DESTROY for %s ignored - handle not initialised\n", |
| 149 | SvPV(dbh,lna)); |
| 150 | } |
| 151 | else { |
| 152 | /* pre-disconnect checks and tidy-ups */ |
| 153 | if (DBIc_CACHED_KIDS(imp_dbh)) { |
| 154 | SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh)); /* cast them to the winds */ |
| 155 | DBIc_CACHED_KIDS(imp_dbh) = Nullhv; |
| 156 | } |
| 157 | if (DBIc_IADESTROY(imp_dbh)) { /* want's ineffective destroy */ |
| 158 | DBIc_ACTIVE_off(imp_dbh); |
| 159 | } |
| 160 | if (DBIc_ACTIVE(imp_dbh)) { |
| 161 | /* The application has not explicitly disconnected. That's bad. */ |
| 162 | /* To ensure integrity we *must* issue a rollback. This will be */ |
| 163 | /* harmless if the application has issued a commit. If it hasn't */ |
| 164 | /* then it'll ensure integrity. Consider a Ctrl-C killing perl */ |
| 165 | /* between two statements that must be executed as a transaction. */ |
| 166 | /* Perl will call DESTROY on the dbh and, if we don't rollback, */ |
| 167 | /* the server may automatically commit! Bham! Corrupt database! */ |
| 168 | if (!DBIc_has(imp_dbh,DBIcf_AutoCommit)) { |
| 169 | if (DBIc_WARN(imp_dbh) && (!dirty || DBIS->debug >= 3)) |
| 170 | warn("Issuing rollback() for database handle being DESTROY'd without explicit disconnect()"); |
| 171 | dbd_db_rollback(dbh, imp_dbh); /* ROLLBACK! */ |
| 172 | } |
| 173 | dbd_db_disconnect(dbh, imp_dbh); |
| 174 | DBIc_ACTIVE_off(imp_dbh); /* ensure it's off, regardless */ |
| 175 | } |
| 176 | dbd_db_destroy(dbh, imp_dbh); |
| 177 | } |
| 178 | |
| 179 | |
| 180 | # -- end of DBD::~DRIVER~::db |
| 181 | |
| 182 | |
| 183 | # ------------------------------------------------------------ |
| 184 | # statement interface |
| 185 | # ------------------------------------------------------------ |
| 186 | MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~::st |
| 187 | |
| 188 | |
| 189 | void |
| 190 | _prepare(sth, statement, attribs=Nullsv) |
| 191 | SV * sth |
| 192 | char * statement |
| 193 | SV * attribs |
| 194 | CODE: |
| 195 | { |
| 196 | D_imp_sth(sth); |
| 197 | DBD_ATTRIBS_CHECK("_prepare", sth, attribs); |
| 198 | ST(0) = dbd_st_prepare(sth, imp_sth, statement, attribs) ? &sv_yes : &sv_no; |
| 199 | } |
| 200 | |
| 201 | |
| 202 | #ifdef dbd_st_rows |
| 203 | |
| 204 | void |
| 205 | rows(sth) |
| 206 | SV * sth |
| 207 | CODE: |
| 208 | D_imp_sth(sth); |
| 209 | XST_mIV(0, dbd_st_rows(sth, imp_sth)); |
| 210 | |
| 211 | #endif |
| 212 | |
| 213 | |
| 214 | void |
| 215 | bind_param(sth, param, value, attribs=Nullsv) |
| 216 | SV * sth |
| 217 | SV * param |
| 218 | SV * value |
| 219 | SV * attribs |
| 220 | CODE: |
| 221 | { |
| 222 | IV sql_type = 0; |
| 223 | D_imp_sth(sth); |
| 224 | if (SvGMAGICAL(value)) |
| 225 | mg_get(value); |
| 226 | if (attribs) { |
| 227 | if (SvNIOK(attribs)) { |
| 228 | sql_type = SvIV(attribs); |
| 229 | attribs = Nullsv; |
| 230 | } |
| 231 | else { |
| 232 | SV **svp; |
| 233 | DBD_ATTRIBS_CHECK("bind_param", sth, attribs); |
| 234 | /* XXX we should perhaps complain if TYPE is not SvNIOK */ |
| 235 | DBD_ATTRIB_GET_IV(attribs, "TYPE",4, svp, sql_type); |
| 236 | } |
| 237 | } |
| 238 | ST(0) = dbd_bind_ph(sth, imp_sth, param, value, sql_type, attribs, FALSE, 0) |
| 239 | ? &sv_yes : &sv_no; |
| 240 | } |
| 241 | |
| 242 | |
| 243 | void |
| 244 | bind_param_inout(sth, param, value_ref, maxlen, attribs=Nullsv) |
| 245 | SV * sth |
| 246 | SV * param |
| 247 | SV * value_ref |
| 248 | IV maxlen |
| 249 | SV * attribs |
| 250 | CODE: |
| 251 | { |
| 252 | IV sql_type = 0; |
| 253 | D_imp_sth(sth); |
| 254 | SV *value; |
| 255 | if (!SvROK(value_ref) || SvTYPE(SvRV(value_ref)) > SVt_PVMG) |
| 256 | croak("bind_param_inout needs a reference to a scalar value"); |
| 257 | value = SvRV(value_ref); |
| 258 | if (SvREADONLY(value)) |
| 259 | croak("Modification of a read-only value attempted"); |
| 260 | if (SvGMAGICAL(value)) |
| 261 | mg_get(value); |
| 262 | if (attribs) { |
| 263 | if (SvNIOK(attribs)) { |
| 264 | sql_type = SvIV(attribs); |
| 265 | attribs = Nullsv; |
| 266 | } |
| 267 | else { |
| 268 | SV **svp; |
| 269 | DBD_ATTRIBS_CHECK("bind_param", sth, attribs); |
| 270 | DBD_ATTRIB_GET_IV(attribs, "TYPE",4, svp, sql_type); |
| 271 | } |
| 272 | } |
| 273 | ST(0) = dbd_bind_ph(sth, imp_sth, param, value, sql_type, attribs, TRUE, maxlen) |
| 274 | ? &sv_yes : &sv_no; |
| 275 | } |
| 276 | |
| 277 | |
| 278 | void |
| 279 | execute(sth, ...) |
| 280 | SV * sth |
| 281 | CODE: |
| 282 | D_imp_sth(sth); |
| 283 | int retval; |
| 284 | if (items > 1) { |
| 285 | /* Handle binding supplied values to placeholders */ |
| 286 | int i; |
| 287 | SV *idx; |
| 288 | if (items-1 != DBIc_NUM_PARAMS(imp_sth) |
| 289 | && DBIc_NUM_PARAMS(imp_sth) != DBIc_NUM_PARAMS_AT_EXECUTE |
| 290 | ) { |
| 291 | char errmsg[99]; |
| 292 | sprintf(errmsg,"called with %ld bind variables when %d are needed", |
| 293 | items-1, DBIc_NUM_PARAMS(imp_sth)); |
| 294 | sv_setpv(DBIc_ERRSTR(imp_sth), errmsg); |
| 295 | sv_setiv(DBIc_ERR(imp_sth), (IV)-1); |
| 296 | XSRETURN_UNDEF; |
| 297 | } |
| 298 | idx = sv_2mortal(newSViv(0)); |
| 299 | for(i=1; i < items ; ++i) { |
| 300 | SV* value = ST(i); |
| 301 | if (SvGMAGICAL(value)) |
| 302 | mg_get(value); /* trigger magic to FETCH the value */ |
| 303 | sv_setiv(idx, i); |
| 304 | if (!dbd_bind_ph(sth, imp_sth, idx, value, 0, Nullsv, FALSE, 0)) { |
| 305 | XSRETURN_UNDEF; /* dbd_bind_ph already registered error */ |
| 306 | } |
| 307 | } |
| 308 | } |
| 309 | if (DBIc_ROW_COUNT(imp_sth) > 0) /* reset for re-execute */ |
| 310 | DBIc_ROW_COUNT(imp_sth) = 0; |
| 311 | retval = dbd_st_execute(sth, imp_sth); |
| 312 | /* remember that dbd_st_execute must return <= -2 for error */ |
| 313 | if (retval == 0) /* ok with no rows affected */ |
| 314 | XST_mPV(0, "0E0"); /* (true but zero) */ |
| 315 | else if (retval < -1) /* -1 == unknown number of rows */ |
| 316 | XST_mUNDEF(0); /* <= -2 means error */ |
| 317 | else |
| 318 | XST_mIV(0, retval); /* typically 1, rowcount or -1 */ |
| 319 | |
| 320 | |
| 321 | void |
| 322 | fetchrow_arrayref(sth) |
| 323 | SV * sth |
| 324 | ALIAS: |
| 325 | fetch = 1 |
| 326 | CODE: |
| 327 | D_imp_sth(sth); |
| 328 | AV *av; |
| 329 | if (0) ix = ix; /* avoid unused variable warning */ |
| 330 | av = dbd_st_fetch(sth, imp_sth); |
| 331 | ST(0) = (av) ? sv_2mortal(newRV((SV *)av)) : &sv_undef; |
| 332 | |
| 333 | |
| 334 | void |
| 335 | fetchrow_array(sth) |
| 336 | SV * sth |
| 337 | ALIAS: |
| 338 | fetchrow = 1 |
| 339 | PPCODE: |
| 340 | D_imp_sth(sth); |
| 341 | AV *av; |
| 342 | if (0) ix = ix; /* avoid unused variable warning */ |
| 343 | av = dbd_st_fetch(sth, imp_sth); |
| 344 | if (av) { |
| 345 | int num_fields = AvFILL(av)+1; |
| 346 | int i; |
| 347 | EXTEND(sp, num_fields); |
| 348 | for(i=0; i < num_fields; ++i) { |
| 349 | PUSHs(AvARRAY(av)[i]); |
| 350 | } |
| 351 | } |
| 352 | |
| 353 | void |
| 354 | finish(sth) |
| 355 | SV * sth |
| 356 | CODE: |
| 357 | D_imp_sth(sth); |
| 358 | D_imp_dbh_from_sth; |
| 359 | if (!DBIc_ACTIVE(imp_sth)) { |
| 360 | /* No active statement to finish */ |
| 361 | XSRETURN_YES; |
| 362 | } |
| 363 | if (!DBIc_ACTIVE(imp_dbh)) { |
| 364 | /* Either an explicit disconnect() or global destruction */ |
| 365 | /* has disconnected us from the database. Finish is meaningless */ |
| 366 | DBIc_ACTIVE_off(imp_sth); |
| 367 | XSRETURN_YES; |
| 368 | } |
| 369 | #ifdef dbd_db_finish3 |
| 370 | ST(0) = dbd_st_finish3(sth, imp_sth, 0) ? &sv_yes : &sv_no; |
| 371 | #else |
| 372 | ST(0) = dbd_st_finish(sth, imp_sth) ? &sv_yes : &sv_no; |
| 373 | #endif |
| 374 | |
| 375 | |
| 376 | void |
| 377 | blob_read(sth, field, offset, len, destrv=Nullsv, destoffset=0) |
| 378 | SV * sth |
| 379 | int field |
| 380 | long offset |
| 381 | long len |
| 382 | SV * destrv |
| 383 | long destoffset |
| 384 | CODE: |
| 385 | { |
| 386 | D_imp_sth(sth); |
| 387 | if (!destrv) |
| 388 | destrv = sv_2mortal(newRV(sv_2mortal(newSV(0)))); |
| 389 | if (dbd_st_blob_read(sth, imp_sth, field, offset, len, destrv, destoffset)) |
| 390 | ST(0) = SvRV(destrv); |
| 391 | else ST(0) = &sv_undef; |
| 392 | } |
| 393 | |
| 394 | |
| 395 | void |
| 396 | STORE(sth, keysv, valuesv) |
| 397 | SV * sth |
| 398 | SV * keysv |
| 399 | SV * valuesv |
| 400 | CODE: |
| 401 | D_imp_sth(sth); |
| 402 | if (SvGMAGICAL(valuesv)) |
| 403 | mg_get(valuesv); |
| 404 | ST(0) = &sv_yes; |
| 405 | if (!dbd_st_STORE_attrib(sth, imp_sth, keysv, valuesv)) |
| 406 | if (!DBIS->set_attr(sth, keysv, valuesv)) |
| 407 | ST(0) = &sv_no; |
| 408 | |
| 409 | |
| 410 | # FETCH renamed and ALIAS'd to avoid case clash on VMS :-( |
| 411 | void |
| 412 | FETCH_attrib(sth, keysv) |
| 413 | SV * sth |
| 414 | SV * keysv |
| 415 | ALIAS: |
| 416 | FETCH = 1 |
| 417 | CODE: |
| 418 | D_imp_sth(sth); |
| 419 | SV *valuesv; |
| 420 | if (0) ix = ix; /* avoid unused variable warning */ |
| 421 | valuesv = dbd_st_FETCH_attrib(sth, imp_sth, keysv); |
| 422 | if (!valuesv) |
| 423 | valuesv = DBIS->get_attr(sth, keysv); |
| 424 | ST(0) = valuesv; /* dbd_st_FETCH_attrib did sv_2mortal */ |
| 425 | |
| 426 | |
| 427 | void |
| 428 | DESTROY(sth) |
| 429 | SV * sth |
| 430 | PPCODE: |
| 431 | D_imp_sth(sth); |
| 432 | ST(0) = &sv_yes; |
| 433 | if (!DBIc_IMPSET(imp_sth)) { /* was never fully set up */ |
| 434 | STRLEN lna; |
| 435 | if (DBIc_WARN(imp_sth) && !dirty && DBIS->debug >= 2) |
| 436 | PerlIO_printf(DBILOGFP, |
| 437 | "Statement handle %s DESTROY ignored - never set up\n", |
| 438 | SvPV(sth,lna)); |
| 439 | } |
| 440 | else { |
| 441 | if (DBIc_IADESTROY(imp_sth)) { /* want's ineffective destroy */ |
| 442 | DBIc_ACTIVE_off(imp_sth); |
| 443 | } |
| 444 | if (DBIc_ACTIVE(imp_sth)) { |
| 445 | D_imp_dbh_from_sth; |
| 446 | if (DBIc_ACTIVE(imp_dbh)) { |
| 447 | #ifdef dbd_db_finish3 |
| 448 | dbd_st_finish3(sth, imp_sth, 1); |
| 449 | #else |
| 450 | dbd_st_finish(sth, imp_sth); |
| 451 | #endif |
| 452 | } |
| 453 | else { |
| 454 | DBIc_ACTIVE_off(imp_sth); |
| 455 | } |
| 456 | } |
| 457 | dbd_st_destroy(sth, imp_sth); |
| 458 | } |
| 459 | |
| 460 | |
| 461 | |
| 462 | # end of ~DRIVER~.xh |