1/*===================================================================== 2* 3* Template::Stash::XS (Stash.xs) 4* 5* DESCRIPTION 6* This is an XS implementation of the Template::Stash module. 7* It is an alternative version of the core Template::Stash methods 8* ''get'' and ''set'' (the ones that should benefit most from a 9* speedy C implementation), along with some virtual methods (like 10* first, last, reverse, etc.) 11* 12* AUTHORS 13* Andy Wardley <abw@cpan.org> 14* Doug Steinwand <dsteinwand@citysearch.com> 15* 16* COPYRIGHT 17* Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved. 18* Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. 19* 20* This module is free software; you can redistribute it and/or 21* modify it under the same terms as Perl itself. 22* 23* NOTE 24* Be very familiar with the perlguts, perlxs, perlxstut and 25* perlapi manpages before digging through this code. 26* 27*=====================================================================*/ 28 29 30#ifdef __cplusplus 31extern "C" { 32#endif 33 34#define PERL_NO_GET_CONTEXT 35#include "EXTERN.h" 36#include "perl.h" 37#define NEED_sv_2pv_flags 38#define NEED_newRV_noinc 39#include "ppport.h" 40#include "XSUB.h" 41 42#ifdef __cplusplus 43} 44#endif 45 46#if defined(_MSC_VER) || defined(__SUNPRO_C) 47#define debug() 48#else 49#ifdef WIN32 50#define debug(format) 51#else 52#define debug(...) 53/* #define debug(...) fprintf(stderr, __VA_ARGS__) */ 54#endif 55#endif 56 57#ifdef WIN32 58#define snprintf _snprintf 59#endif 60 61#define TT_STASH_PKG "Template::Stash::XS" 62#define TT_LIST_OPS "Template::Stash::LIST_OPS" 63#define TT_HASH_OPS "Template::Stash::HASH_OPS" 64#define TT_SCALAR_OPS "Template::Stash::SCALAR_OPS" 65#define TT_PRIVATE "Template::Stash::PRIVATE" 66 67#define TT_LVALUE_FLAG 1 68#define TT_DEBUG_FLAG 2 69#define TT_DEFAULT_FLAG 4 70 71typedef enum tt_ret { TT_RET_UNDEF, TT_RET_OK, TT_RET_CODEREF } TT_RET; 72 73static TT_RET hash_op(pTHX_ SV*, char*, AV*, SV**, int); 74static TT_RET list_op(pTHX_ SV*, char*, AV*, SV**); 75static TT_RET scalar_op(pTHX_ SV*, char*, AV*, SV**, int); 76static TT_RET tt_fetch_item(pTHX_ SV*, SV*, AV*, SV**); 77static TT_RET autobox_list_op(pTHX_ SV*, char*, AV*, SV**, int); 78static SV* dotop(pTHX_ SV*, SV*, AV*, int); 79static SV* call_coderef(pTHX_ SV*, AV*); 80static SV* fold_results(pTHX_ I32); 81static SV* find_perl_op(pTHX_ char*, char*); 82static AV* mk_mortal_av(pTHX_ SV*, AV*, SV*); 83static SV* do_getset(pTHX_ SV*, AV*, SV*, int); 84static AV* convert_dotted_string(pTHX_ const char*, I32); 85static int get_debug_flag(pTHX_ SV*); 86static int cmp_arg(const void *, const void *); 87static int looks_private(pTHX_ const char*); 88static void die_object(pTHX_ SV *); 89static struct xs_arg *find_xs_op(char *); 90static SV* list_dot_first(pTHX_ AV*, AV*); 91static SV* list_dot_join(pTHX_ AV*, AV*); 92static SV* list_dot_last(pTHX_ AV*, AV*); 93static SV* list_dot_max(pTHX_ AV*, AV*); 94static SV* list_dot_reverse(pTHX_ AV*, AV*); 95static SV* list_dot_size(pTHX_ AV*, AV*); 96static SV* hash_dot_each(pTHX_ HV*, AV*); 97static SV* hash_dot_keys(pTHX_ HV*, AV*); 98static SV* hash_dot_values(pTHX_ HV*, AV*); 99static SV* scalar_dot_defined(pTHX_ SV*, AV*); 100static SV* scalar_dot_length(pTHX_ SV*, AV*); 101 102#define THROW_SIZE 64 103static char throw_fmt[] = "Can't locate object method \"%s\" via package \"%s\""; 104 105/* dispatch table for XS versions of special "virtual methods", 106 * names must be in alphabetical order 107 */ 108static const struct xs_arg { 109 const char *name; 110 SV* (*list_f) (pTHX_ AV*, AV*); 111 SV* (*hash_f) (pTHX_ HV*, AV*); 112 SV* (*scalar_f) (pTHX_ SV*, AV*); 113} xs_args[] = { 114 /* name list (AV) ops. hash (HV) ops. scalar (SV) ops. 115 -------- ---------------- --------------- ------------------ */ 116 { "defined", NULL, NULL, scalar_dot_defined }, 117 { "each", NULL, hash_dot_each, NULL }, 118/* { "first", list_dot_first, NULL, NULL }, */ 119 { "join", list_dot_join, NULL, NULL }, 120 { "keys", NULL, hash_dot_keys, NULL }, 121/* { "last", list_dot_last, NULL, NULL }, */ 122 { "length", NULL, NULL, scalar_dot_length }, 123 { "max", list_dot_max, NULL, NULL }, 124 { "reverse", list_dot_reverse, NULL, NULL }, 125 { "size", list_dot_size, NULL, NULL }, 126 { "values", NULL, hash_dot_values, NULL }, 127}; 128 129 130 131/*------------------------------------------------------------------------ 132 * tt_fetch_item(pTHX_ SV *root, SV *key_sv, AV *args, SV **result) 133 * 134 * Retrieves an item from the given hash or array ref. If item is found 135 * and a coderef then the coderef will be called and passed args. Returns 136 * TT_RET_CODEREF or TT_RET_OK and sets result. If not found, returns 137 * TT_RET_UNDEF and result is undefined. 138 *------------------------------------------------------------------------*/ 139 140static TT_RET tt_fetch_item(pTHX_ SV *root, SV *key_sv, AV *args, SV **result) { 141 STRLEN key_len; 142 char *key = SvPV(key_sv, key_len); 143 SV **value = NULL; 144 145#ifndef WIN32 146 debug("fetch item: %s\n", key); 147#endif 148 149 /* negative key_len is used to indicate UTF8 string */ 150 if (SvUTF8(key_sv)) 151 key_len = -key_len; 152 153 if (!SvROK(root)) 154 return TT_RET_UNDEF; 155 156 switch (SvTYPE(SvRV(root))) { 157 case SVt_PVHV: 158 value = hv_fetch((HV *) SvRV(root), key, key_len, FALSE); 159 break; 160 161 case SVt_PVAV: 162 if (looks_like_number(key_sv)) 163 value = av_fetch((AV *) SvRV(root), SvIV(key_sv), FALSE); 164 break; 165 } 166 167 if (value) { 168 /* trigger any tied magic to FETCH value */ 169 SvGETMAGIC(*value); 170 171 /* call if a coderef */ 172 if (SvROK(*value) 173 && (SvTYPE(SvRV(*value)) == SVt_PVCV) 174 && !sv_isobject(*value)) { 175 *result = call_coderef(aTHX_ *value, args); 176 return TT_RET_CODEREF; 177 178 } 179 else if (SvOK(*value)) { 180 *result = *value; 181 return TT_RET_OK; 182 } 183 184 } 185 186 *result = &PL_sv_undef; 187 return TT_RET_UNDEF; 188} 189 190 191 192/*------------------------------------------------------------------------ 193 * dotop(pTHX_ SV *root, SV *key_sv, AV *args, int flags) 194 * 195 * Resolves dot operations of the form root.key, where 'root' is a 196 * reference to the root item, 'key_sv' is an SV containing the 197 * operation key (e.g. hash key, list index, first, last, each, etc), 198 * 'args' is a list of additional arguments and 'TT_LVALUE_FLAG' is a 199 * flag to indicate if, for certain operations (e.g. hash key), the item 200 * should be created if it doesn't exist. Also, 'TT_DEBUG_FLAG' is the 201 * debug flag. 202 *------------------------------------------------------------------------*/ 203 204static SV *dotop(pTHX_ SV *root, SV *key_sv, AV *args, int flags) { 205 dSP; 206 STRLEN item_len; 207 char *item = SvPV(key_sv, item_len); 208 SV *result = &PL_sv_undef; 209 I32 atroot; 210 211#ifndef WIN32 212 debug("dotop(%s)\n", item); 213#endif 214 215 /* ignore _private or .private members */ 216 if (!root || looks_private(aTHX_ item)) 217 return &PL_sv_undef; 218 219 if (SvROK(root)) { 220 atroot = sv_derived_from(root, TT_STASH_PKG); 221 222 if (atroot || ((SvTYPE(SvRV(root)) == SVt_PVHV) && !sv_isobject(root))) { 223 /* root is a HASH or Template::Stash */ 224 switch(tt_fetch_item(aTHX_ root, key_sv, args, &result)) { 225 case TT_RET_OK: 226 /* return immediately */ 227 return result; 228 break; 229 230 case TT_RET_CODEREF: 231 /* fall through */ 232 break; 233 234 default: 235 /* for lvalue, create an intermediate hash */ 236 if (flags & TT_LVALUE_FLAG) { 237 SV *newhash; 238 HV *roothv = (HV *) SvRV(root); 239 newhash = SvREFCNT_inc((SV *) newRV_noinc((SV *) newHV())); 240 241 debug("- auto-vivifying intermediate hash\n"); 242 243 if (hv_store(roothv, item, item_len, newhash, 0)) { 244 /* trigger any tied magic to STORE value */ 245 SvSETMAGIC(newhash); 246 } 247 else { 248 SvREFCNT_dec(newhash); 249 } 250 return sv_2mortal(newhash); 251 } 252 253 /* try hash virtual method (not at stash root, except import) */ 254 if ((! atroot || (strcmp(item, "import") == 0)) 255 && hash_op(aTHX_ root, item, args, &result, flags) == TT_RET_UNDEF) { 256 /* try hash slice */ 257 if (SvROK(key_sv) && SvTYPE(SvRV(key_sv)) == SVt_PVAV) { 258 AV *a_av = newAV(); 259 AV *k_av = (AV *) SvRV(key_sv); 260 HV *r_hv = (HV *) SvRV(root); 261 char *t; 262 I32 i; 263 STRLEN tlen; 264 SV **svp; 265 266 for (i = 0; i <= av_len(k_av); i++) { 267 if ((svp = av_fetch(k_av, i, 0))) { 268 SvGETMAGIC(*svp); 269 t = SvPV(*svp, tlen); 270 if((svp = hv_fetch(r_hv, t, tlen, FALSE))) { 271 SvGETMAGIC(*svp); 272 av_push(a_av, SvREFCNT_inc(*svp)); 273 } 274 } 275 } 276 277 return sv_2mortal(newRV_noinc((SV *) a_av)); 278 } 279 } 280 } 281 282 } 283 else if ((SvTYPE(SvRV(root)) == SVt_PVAV) && !sv_isobject(root)) { 284 /* root is an ARRAY, try list virtuals */ 285 if (list_op(aTHX_ root, item, args, &result) == TT_RET_UNDEF) { 286 switch (tt_fetch_item(aTHX_ root, key_sv, args, &result)) { 287 case TT_RET_OK: 288 return result; 289 break; 290 291 case TT_RET_CODEREF: 292 break; 293 294 default: 295 /* try array slice */ 296 if (SvROK(key_sv) && SvTYPE(SvRV(key_sv)) == SVt_PVAV) { 297 AV *a_av = newAV(); 298 AV *k_av = (AV *) SvRV(key_sv); 299 AV *r_av = (AV *) SvRV(root); 300 I32 i; 301 SV **svp; 302 303 for (i = 0; i <= av_len(k_av); i++) { 304 if ((svp = av_fetch(k_av, i, FALSE))) { 305 SvGETMAGIC(*svp); 306 if (looks_like_number(*svp) && 307 (svp = av_fetch(r_av, SvIV(*svp), FALSE))) { 308 SvGETMAGIC(*svp); 309 av_push(a_av, SvREFCNT_inc(*svp)); 310 } 311 } 312 } 313 314 return sv_2mortal(newRV_noinc((SV *) a_av)); 315 } 316 } 317 } 318 } 319 else if (sv_isobject(root)) { 320 /* root is an object */ 321 I32 n, i; 322 SV **svp; 323 HV *stash = SvSTASH((SV *) SvRV(root)); 324 GV *gv; 325 /* char *error_string; */ 326 result = NULL; 327 328 if ((gv = gv_fetchmethod_autoload(stash, item, 1))) { 329 /* eval { @result = $root->$item(@$args); }; */ 330 331 PUSHMARK(SP); 332 XPUSHs(root); 333 n = (args && args != Nullav) ? av_len(args) : -1; 334 for (i = 0; i <= n; i++) 335 if ((svp = av_fetch(args, i, 0))) XPUSHs(*svp); 336 PUTBACK; 337 n = call_method(item, G_ARRAY | G_EVAL); 338 SPAGAIN; 339 340 if (SvTRUE(ERRSV)) { 341 char throw_str[THROW_SIZE+1]; 342 (void) POPs; /* remove undef from stack */ 343 PUTBACK; 344 result = NULL; 345 346 /* if we get an exception object throw ($@ is a 347 * ref) or a error other than "Can't locate object 348 * method "blah"" then it's a real error that need 349 * to be re-thrown. 350 */ 351 352 if (SvROK(ERRSV)) { 353 die_object(aTHX_ ERRSV); 354 } 355 else { 356 357 /* We use throw_str to construct the error message 358 * that indicates a missing method. We use snprintf() to 359 * avoid overflowing throw_str, and always ensure the 360 * last character is NULL (if the item name is too long 361 * to fit into throw_str then snprintf() doesn't add the 362 * terminating NULL 363 */ 364 snprintf(throw_str, THROW_SIZE, throw_fmt, item, HvNAME(stash)); 365 throw_str[THROW_SIZE] = '\0'; 366 367 if (! strstr( SvPV(ERRSV, PL_na), throw_str)) 368 die_object(aTHX_ ERRSV); 369 } 370 } else { 371 result = fold_results(aTHX_ n); 372 } 373 } 374 375 if (!result) { 376 /* failed to call object method, so try some fallbacks */ 377 if (SvTYPE(SvRV(root)) == SVt_PVHV) { 378 /* hash based object - first try to fetch item */ 379 switch(tt_fetch_item(aTHX_ root, key_sv, args, &result)) { 380 case TT_RET_OK: 381 /* return immediately */ 382 return result; 383 break; 384 385 case TT_RET_CODEREF: 386 /* fall through */ 387 break; 388 389 default: 390 /* then try hash vmethod if that failed */ 391 if (hash_op(aTHX_ root, item, args, &result, flags) == TT_RET_OK) 392 return result; 393 /* hash_op() will also try list_op([$hash]) */ 394 } 395 } 396 else if (SvTYPE(SvRV(root)) == SVt_PVAV) { 397 /* list based object - first try to fetch item */ 398 switch (tt_fetch_item(aTHX_ root, key_sv, args, &result)) { 399 case TT_RET_OK: 400 /* return immediately */ 401 return result; 402 break; 403 404 case TT_RET_CODEREF: 405 /* fall through */ 406 break; 407 408 default: 409 /* try list vmethod */ 410 if (list_op(aTHX_ root, item, args, &result) == TT_RET_OK) 411 return result; 412 } 413 } 414 else if (scalar_op(aTHX_ root, item, args, &result, flags) == TT_RET_OK) { 415 /* scalar_op() will also try list_op([$scalar]) */ 416 return result; 417 } 418 else if (flags & TT_DEBUG_FLAG) { 419 result = (SV *) mk_mortal_av(aTHX_ &PL_sv_undef, NULL, ERRSV); 420 } 421 } 422 } 423 } 424 /* it doesn't look like we've got a reference to anything we know about, 425 * so let's try the SCALAR_OPS pseudo-methods (but not for l-values) 426 */ 427 428 else if (!(flags & TT_LVALUE_FLAG) 429 && (scalar_op(aTHX_ root, item, args, &result, flags) 430 == TT_RET_UNDEF)) { 431 if (flags & TT_DEBUG_FLAG) 432 croak("don't know how to access [ %s ].%s\n", 433 SvPV(root, PL_na), item); 434 } 435 436 /* if we have an arrayref and the first element is defined then 437 * everything is peachy, otherwise some ugliness may have occurred 438 */ 439 440 if (SvROK(result) && SvTYPE(SvRV(result)) == SVt_PVAV) { 441 SV **svp; 442 AV *array = (AV *) SvRV(result); 443 I32 len = (array == Nullav) ? 0 : (av_len(array) + 1); 444 445 if (len) { 446 svp = av_fetch(array, 0, FALSE); 447 if (svp && (*svp != &PL_sv_undef)) { 448 return result; 449 } 450 } 451 } 452 453 if ((flags & TT_DEBUG_FLAG) 454 && (!result || !SvOK(result) || (result == &PL_sv_undef))) { 455 croak("%s is undefined\n", item); 456 } 457 458 return result; 459} 460 461 462 463/*------------------------------------------------------------------------ 464 * assign(pTHX_ SV *root, SV *key_sv, AV *args, SV *value, int flags) 465 * 466 * Resolves the final assignment element of a dotted compound variable 467 * of the form "root.key(args) = value". 'root' is a reference to 468 * the root item, 'key_sv' is an SV containing the operation key 469 * (e.g. hash key, list item, object method), 'args' is a list of user 470 * provided arguments (passed only to object methods), 'value' is the 471 * assignment value to be set (appended to args) and 'deflt' (default) 472 * is a flag to indicate that the assignment should only be performed 473 * if the item is currently undefined/false. 474 *------------------------------------------------------------------------*/ 475 476static SV *assign(pTHX_ SV *root, SV *key_sv, AV *args, SV *value, int flags) { 477 dSP; 478 SV **svp, *newsv; 479 HV *roothv; 480 AV *rootav; 481 STRLEN key_len; 482 char *key = SvPV(key_sv, key_len); 483 char *key2 = SvPV(key_sv, key_len); /* TMP DEBUG HACK */ 484 485#ifndef WIN32 486 debug("assign(%s)\n", key2); 487#endif 488 489 /* negative key_len is used to indicate UTF8 string */ 490 if (SvUTF8(key_sv)) 491 key_len = -key_len; 492 493 if (!root || !SvOK(key_sv) || key_sv == &PL_sv_undef || looks_private(aTHX_ key)) { 494 /* ignore _private or .private members */ 495 return &PL_sv_undef; 496 } 497 else if (SvROK(root)) { 498 /* see if root is an object (but not Template::Stash) */ 499 if (sv_isobject(root) && !sv_derived_from(root, TT_STASH_PKG)) { 500 HV *stash = SvSTASH((SV *) SvRV(root)); 501 GV *gv; 502 503 /* look for the named method, or an AUTOLOAD method */ 504 if ((gv = gv_fetchmethod_autoload(stash, key, 1))) { 505 I32 count = (args && args != Nullav) ? av_len(args) : -1; 506 I32 i; 507 508 /* push args and value onto stack, then call method */ 509 PUSHMARK(SP); 510 XPUSHs(root); 511 for (i = 0; i <= count; i++) { 512 if ((svp = av_fetch(args, i, FALSE))) 513 XPUSHs(*svp); 514 } 515 XPUSHs(value); 516 PUTBACK; 517 debug(" - calling object method\n"); 518 count = call_method(key, G_ARRAY); 519 SPAGAIN; 520 return fold_results(aTHX_ count); 521 } 522 } 523 524 /* drop-through if not an object or method not found */ 525 switch (SvTYPE(SvRV(root))) { 526 527 case SVt_PVHV: /* HASH */ 528 roothv = (HV *) SvRV(root); 529 530 debug(" - hash assign\n"); 531 532 /* check for any existing value if ''default'' flag set */ 533 if ((flags & TT_DEFAULT_FLAG) 534 && (svp = hv_fetch(roothv, key, key_len, FALSE))) { 535 /* invoke any tied magical FETCH method */ 536 debug(" - fetched default\n"); 537 SvGETMAGIC(*svp); 538 if (SvTRUE(*svp)) 539 return &PL_sv_undef; 540 } 541 542 /* avoid 'modification of read-only value' error */ 543 newsv = newSVsv(value); 544 hv_store(roothv, key, key_len, newsv, 0); 545 SvSETMAGIC(newsv); 546 547 return value; 548 break; 549 550 case SVt_PVAV: /* ARRAY */ 551 rootav = (AV *) SvRV(root); 552 553 debug(" - list assign\n"); 554 555 if (looks_like_number(key_sv)) { 556 /* if the TT_DEFAULT_FLAG is set then first look to see if the 557 * target is already set to some true value; if it is then 558 * we return that value (after invoking any SvGETMAGIC required 559 * for tied arrays) and bypass the assignment altogether 560 */ 561 562 if ( (flags & TT_DEFAULT_FLAG) 563 && (svp = av_fetch(rootav, SvIV(key_sv), FALSE))) { 564 565 debug(" - fetched default, invoking any tied magic\n"); 566 SvGETMAGIC(*svp); 567 568 if (SvTRUE(*svp)) 569 return &PL_sv_undef; 570 } 571 572 /* create a new SV for the value and call av_store(), 573 * incrementing the reference count on the way; we 574 * then invoke any set magic for tied arrays; if the 575 * return value from av_store is NULL (as appears to 576 * be the case with tied arrays - although the same 577 * isn't true of hv_store() for some reason???) then 578 * we decrement the reference counter because that's 579 * what perlguts tells us to do... 580 */ 581 newsv = newSVsv(value); 582 svp = av_store(rootav, SvIV(key_sv), newsv); 583 SvSETMAGIC(newsv); 584 585 return value; 586 } 587 else 588 return &PL_sv_undef; 589 590 break; 591 592 default: /* BARF */ 593 /* TODO: fix [ %s ] */ 594 croak("don't know how to assign to [ %s ].%s", 595 SvPV(SvRV(root), PL_na), key); 596 } 597 } 598 else { /* SCALAR */ 599 /* TODO: fix [ %s ] */ 600 croak("don't know how to assign to [ %s ].%s", 601 SvPV(SvRV(root), PL_na), key); 602 } 603 604 /* not reached */ 605 return &PL_sv_undef; /* just in case */ 606} 607 608 609 610/* dies and passes back a blessed object, 611 * or just a string if it's not blessed 612 */ 613static void die_object (pTHX_ SV *err) { 614 615 if (sv_isobject(err) || SvROK(err)) { 616 /* throw object via ERRSV ($@) */ 617 SV *errsv = get_sv("@", TRUE); 618 sv_setsv(errsv, err); 619 (void) die(Nullch); 620 } 621 622 /* error string sent back via croak() */ 623 croak("%s", SvPV(err, PL_na)); 624} 625 626 627/* pushes any arguments in 'args' onto the stack then calls the code ref 628 * in 'code'. Calls fold_results() to return a listref or die. 629 */ 630static SV *call_coderef(pTHX_ SV *code, AV *args) { 631 dSP; 632 SV **svp; 633 I32 count = (args && args != Nullav) ? av_len(args) : -1; 634 I32 i; 635 636 PUSHMARK(SP); 637 for (i = 0; i <= count; i++) 638 if ((svp = av_fetch(args, i, FALSE))) 639 XPUSHs(*svp); 640 PUTBACK; 641 count = call_sv(code, G_ARRAY|G_EVAL); 642 SPAGAIN; 643 644 if (SvTRUE(ERRSV)) { 645 die_object(aTHX_ ERRSV); 646 } 647 648 return fold_results(aTHX_ count); 649} 650 651 652/* pops 'count' items off the stack, folding them into a list reference 653 * if count > 1, or returning the sole item if count == 1. 654 * Returns undef if count == 0. 655 * Dies if first value of list is undef 656 */ 657static SV* fold_results(pTHX_ I32 count) { 658 dSP; 659 SV *retval = &PL_sv_undef; 660 661 if (count > 1) { 662 /* convert multiple return items into a list reference */ 663 AV *av = newAV(); 664 SV *last_sv = &PL_sv_undef; 665 SV *sv = &PL_sv_undef; 666 I32 i; 667 668 av_extend(av, count - 1); 669 for(i = 1; i <= count; i++) { 670 last_sv = sv; 671 sv = POPs; 672 if (SvOK(sv) && !av_store(av, count - i, SvREFCNT_inc(sv))) 673 SvREFCNT_dec(sv); 674 } 675 PUTBACK; 676 677 retval = sv_2mortal((SV *) newRV_noinc((SV *) av)); 678 679 if (!SvOK(sv) || sv == &PL_sv_undef) { 680 /* if first element was undef, die */ 681 die_object(aTHX_ last_sv); 682 } 683 return retval; 684 685 } else { 686 if (count) 687 retval = POPs; 688 PUTBACK; 689 return retval; 690 } 691} 692 693 694/* Iterates through array calling dotop() to resolve all items 695 * Skips the last if ''value'' is non-NULL. 696 * If ''value'' is non-NULL, calls assign() to do the assignment. 697 * 698 * SV *root; AV *ident_av; SV *value; int flags; 699 * 700*/ 701static SV* do_getset(pTHX_ SV *root, AV *ident_av, SV *value, int flags) { 702 AV *key_args; 703 SV *key; 704 SV **svp; 705 I32 end_loop, i, size = av_len(ident_av); 706 707 if (value) { 708 /* make some adjustments for assign mode */ 709 end_loop = size - 1; 710 flags |= TT_LVALUE_FLAG; 711 } else { 712 end_loop = size; 713 } 714 715 for(i = 0; i < end_loop; i += 2) { 716 if (!(svp = av_fetch(ident_av, i, FALSE))) 717 croak(TT_STASH_PKG " %cet: bad element %i", value ? 's' : 'g', i); 718 719 key = *svp; 720 721 if (!(svp = av_fetch(ident_av, i + 1, FALSE))) 722 croak(TT_STASH_PKG " %cet: bad arg. %i", value ? 's' : 'g', i + 1); 723 724 if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) 725 key_args = (AV *) SvRV(*svp); 726 else 727 key_args = Nullav; 728 729 root = dotop(aTHX_ root, key, key_args, flags); 730 731 if (!root || !SvOK(root)) 732 return root; 733 } 734 735 if (value && SvROK(root)) { 736 737 /* call assign() to resolve the last item */ 738 if (!(svp = av_fetch(ident_av, size - 1, FALSE))) 739 croak(TT_STASH_PKG ": set bad ident element at %i", i); 740 741 key = *svp; 742 743 if (!(svp = av_fetch(ident_av, size, FALSE))) 744 croak(TT_STASH_PKG ": set bad ident argument at %i", i + 1); 745 746 if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) 747 key_args = (AV *) SvRV(*svp); 748 else 749 key_args = Nullav; 750 751 return assign(aTHX_ root, key, key_args, value, flags); 752 } 753 754 return root; 755} 756 757 758/* return [ map { s/\(.*$//; ($_, 0) } split(/\./, $str) ]; 759 */ 760static AV *convert_dotted_string(pTHX_ const char *str, I32 len) { 761 AV *av = newAV(); 762 char *buf, *b; 763 int b_len = 0; 764 765 New(0, buf, len + 1, char); 766 if (!buf) 767 croak(TT_STASH_PKG ": New() failed for convert_dotted_string"); 768 769 for(b = buf; len >= 0; str++, len--) { 770 if (*str == '(') { 771 for(; (len > 0) && (*str != '.'); str++, len--) ; 772 } 773 if ((len < 1) || (*str == '.')) { 774 *b = '\0'; 775 av_push(av, newSVpv(buf, b_len)); 776 av_push(av, newSViv((IV) 0)); 777 b = buf; 778 b_len = 0; 779 } else { 780 *b++ = *str; 781 b_len++; 782 } 783 } 784 785 Safefree(buf); 786 return (AV *) sv_2mortal((SV *) av); 787} 788 789 790/* performs a generic hash operation identified by 'key' 791 * (e.g. keys, * values, each) on 'hash'. 792 * returns TT_RET_CODEREF if successful, TT_RET_UNDEF otherwise. 793 */ 794static TT_RET hash_op(pTHX_ SV *root, char *key, AV *args, SV **result, int flags) { 795 struct xs_arg *a; 796 SV *code; 797 TT_RET retval; 798 799 /* look for XS version first */ 800 if ((a = find_xs_op(key)) && a->hash_f) { 801 *result = a->hash_f(aTHX_ (HV *) SvRV(root), args); 802 return TT_RET_CODEREF; 803 } 804 805 /* look for perl version in Template::Stash module */ 806 if ((code = find_perl_op(aTHX_ key, TT_HASH_OPS))) { 807 *result = call_coderef(aTHX_ code, mk_mortal_av(aTHX_ root, args, NULL)); 808 return TT_RET_CODEREF; 809 } 810 811 /* try upgrading item to a list and look for a list op */ 812 if (!(flags & TT_LVALUE_FLAG)) { 813 /* hash.method ==> [hash].method */ 814 return autobox_list_op(aTHX_ root, key, args, result, flags); 815 } 816 817 /* not found */ 818 *result = &PL_sv_undef; 819 return TT_RET_UNDEF; 820} 821 822 823/* performs a generic list operation identified by 'key' on 'list'. 824 * Additional arguments may be passed in 'args'. 825 * returns TT_RET_CODEREF if successful, TT_RET_UNDEF otherwise. 826 */ 827static TT_RET list_op(pTHX_ SV *root, char *key, AV *args, SV **result) { 828 struct xs_arg *a; 829 SV *code; 830 831 /* look for and execute XS version first */ 832 if ((a = find_xs_op(key)) && a->list_f) { 833#ifndef WIN32 834 debug("calling internal list vmethod: %s\n", key); 835#endif 836 *result = a->list_f(aTHX_ (AV *) SvRV(root), args); 837 return TT_RET_CODEREF; 838 } 839 840 /* look for and execute perl version in Template::Stash module */ 841 if ((code = find_perl_op(aTHX_ key, TT_LIST_OPS))) { 842#ifndef WIN32 843 debug("calling perl list vmethod: %s\n", key); 844#endif 845 *result = call_coderef(aTHX_ code, mk_mortal_av(aTHX_ root, args, NULL)); 846 return TT_RET_CODEREF; 847 } 848 849#ifndef WIN32 850 debug("list vmethod not found: %s\n", key); 851#endif 852 853 /* not found */ 854 *result = &PL_sv_undef; 855 return TT_RET_UNDEF; 856} 857 858 859/* Performs a generic scalar operation identified by 'key' 860 * on 'sv'. Additional arguments may be passed in 'args'. 861 * returns TT_RET_CODEREF if successful, TT_RET_UNDEF otherwise. 862 */ 863static TT_RET scalar_op(pTHX_ SV *sv, char *key, AV *args, SV **result, int flags) { 864 struct xs_arg *a; 865 SV *code; 866 TT_RET retval; 867 868 /* look for a XS version first */ 869 if ((a = find_xs_op(key)) && a->scalar_f) { 870 *result = a->scalar_f(aTHX_ sv, args); 871 return TT_RET_CODEREF; 872 } 873 874 /* look for perl version in Template::Stash module */ 875 if ((code = find_perl_op(aTHX_ key, TT_SCALAR_OPS))) { 876 *result = call_coderef(aTHX_ code, mk_mortal_av(aTHX_ sv, args, NULL)); 877 return TT_RET_CODEREF; 878 } 879 880 /* try upgrading item to a list and look for a list op */ 881 if (!(flags & TT_LVALUE_FLAG)) { 882 /* scalar.method ==> [scalar].method */ 883 return autobox_list_op(aTHX_ sv, key, args, result, flags); 884 } 885 886 /* not found */ 887 *result = &PL_sv_undef; 888 return TT_RET_UNDEF; 889} 890 891static TT_RET autobox_list_op(pTHX_ SV *sv, char *key, AV *args, SV **result, int flags) { 892 AV *av = newAV(); 893 SV *avref = (SV *) newRV_inc((SV *) av); 894 TT_RET retval; 895 av_push(av, SvREFCNT_inc(sv)); 896 retval = list_op(aTHX_ avref, key, args, result); 897 SvREFCNT_dec(av); 898 SvREFCNT_dec(avref); 899 return retval; 900} 901 902/* xs_arg comparison function */ 903static int cmp_arg(const void *a, const void *b) { 904 return (strcmp(((const struct xs_arg *)a)->name, 905 ((const struct xs_arg *)b)->name)); 906} 907 908 909/* Searches the xs_arg table for key */ 910static struct xs_arg *find_xs_op(char *key) { 911 struct xs_arg *ap, tmp; 912 913 tmp.name = key; 914 if ((ap = (struct xs_arg *) 915 bsearch(&tmp, 916 xs_args, 917 sizeof(xs_args)/sizeof(struct xs_arg), 918 sizeof(struct xs_arg), 919 cmp_arg))) 920 return ap; 921 922 return NULL; 923} 924 925 926/* Searches the perl Template::Stash.pm module for ''key'' in the 927 * hashref named ''perl_var''. Returns SV if found, NULL otherwise. 928 */ 929static SV *find_perl_op(pTHX_ char *key, char *perl_var) { 930 SV *tt_ops; 931 SV **svp; 932 933 if ((tt_ops = get_sv(perl_var, FALSE)) 934 && SvROK(tt_ops) 935 && (svp = hv_fetch((HV *) SvRV(tt_ops), key, strlen(key), FALSE)) 936 && SvROK(*svp) 937 && SvTYPE(SvRV(*svp)) == SVt_PVCV) 938 return *svp; 939 940 return NULL; 941} 942 943 944/* Returns: @a = ($sv, @av, $more) */ 945static AV *mk_mortal_av(pTHX_ SV *sv, AV *av, SV *more) { 946 SV **svp; 947 AV *a; 948 I32 i = 0, size; 949 950 a = newAV(); 951 av_push(a, SvREFCNT_inc(sv)); 952 953 if (av && (size = av_len(av)) > -1) { 954 av_extend(a, size + 1); 955 for (i = 0; i <= size; i++) 956 if ((svp = av_fetch(av, i, FALSE))) 957 if(!av_store(a, i + 1, SvREFCNT_inc(*svp))) 958 SvREFCNT_dec(*svp); 959 } 960 961 if (more && SvOK(more)) 962 if (!av_store(a, i + 1, SvREFCNT_inc(more))) 963 SvREFCNT_dec(more); 964 965 return (AV *) sv_2mortal((SV *) a); 966} 967 968/* Returns TT_DEBUG_FLAG if _DEBUG key is true in hashref ''sv''. */ 969static int get_debug_flag (pTHX_ SV *sv) { 970 const char *key = "_DEBUG"; 971 const I32 len = 6; 972 SV **debug; 973 974 if (SvROK(sv) 975 && (SvTYPE(SvRV(sv)) == SVt_PVHV) 976 && (debug = hv_fetch((HV *) SvRV(sv), (char *) key, len, FALSE)) 977 && SvOK(*debug) 978 && SvTRUE(*debug)) 979 return TT_DEBUG_FLAG; 980 981 return 0; 982} 983 984 985static int looks_private(pTHX_ const char *name) { 986 /* SV *priv; */ 987 988 /* For now we hard-code the regex to match _private or .hidden 989 * variables, but we do check to see if $Template::Stash::PRIVATE 990 * is defined, allowing a user to undef it to defeat the check. 991 * The better solution would be to match the string using the regex 992 * defined in the $PRIVATE package varible, but I've been searching 993 * for well over an hour now and I can't find any documentation or 994 * examples showing me how to match a string against a pre-compiled 995 * regex from XS. The Perl internals docs really suck in places. 996 */ 997 998 if (SvTRUE(get_sv(TT_PRIVATE, FALSE))) { 999 return (*name == '_' || *name == '.'); 1000 } 1001 return 0; 1002} 1003 1004 1005/* XS versions of some common dot operations 1006 * ----------------------------------------- */ 1007 1008/* list.first */ 1009static SV *list_dot_first(pTHX_ AV *list, AV *args) { 1010 SV **svp; 1011 if ((svp = av_fetch(list, 0, FALSE))) { 1012 /* entry fetched from arry may be code ref */ 1013 if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) { 1014 return call_coderef(aTHX_ *svp, args); 1015 } else { 1016 return *svp; 1017 } 1018 } 1019 return &PL_sv_undef; 1020} 1021 1022 1023/* list.join */ 1024static SV *list_dot_join(pTHX_ AV *list, AV *args) { 1025 SV **svp; 1026 SV *item, *retval; 1027 I32 size, i; 1028 STRLEN jlen; 1029 char *joint; 1030 1031 if (args && (svp = av_fetch(args, 0, FALSE)) != NULL) { 1032 joint = SvPV(*svp, jlen); 1033 } else { 1034 joint = " "; 1035 jlen = 1; 1036 } 1037 1038 retval = newSVpvn("", 0); 1039 size = av_len(list); 1040 for (i = 0; i <= size; i++) { 1041 if ((svp = av_fetch(list, i, FALSE)) != NULL) { 1042 item = *svp; 1043 if (SvROK(item) && SvTYPE(SvRV(item)) == SVt_PVCV) { 1044 item = call_coderef(aTHX_ *svp, args); 1045 sv_catsv(retval, item); 1046 } else { 1047 sv_catsv(retval, item); 1048 } 1049 if (i != size) 1050 sv_catpvn(retval, joint, jlen); 1051 } 1052 } 1053 return sv_2mortal(retval); 1054} 1055 1056 1057/* list.last */ 1058static SV *list_dot_last(pTHX_ AV *list, AV *args) { 1059 SV **svp; 1060 if ((av_len(list) > -1) 1061 && (svp = av_fetch(list, av_len(list), FALSE))) { 1062 /* entry fetched from arry may be code ref */ 1063 if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) { 1064 return call_coderef(aTHX_ *svp, args); 1065 } else { 1066 return *svp; 1067 } 1068 } 1069 return &PL_sv_undef; 1070} 1071 1072 1073/* list.max */ 1074static SV *list_dot_max(pTHX_ AV *list, AV *args) { 1075 return sv_2mortal(newSViv((IV) av_len(list))); 1076} 1077 1078 1079/* list.reverse */ 1080static SV *list_dot_reverse(pTHX_ AV *list, AV *args) { 1081 SV **svp; 1082 AV *result = newAV(); 1083 I32 size, i; 1084 1085 if ((size = av_len(list)) >= 0) { 1086 av_extend(result, size + 1); 1087 for (i = 0; i <= size; i++) { 1088 if ((svp = av_fetch(list, i, FALSE)) != NULL) 1089 if (!av_store(result, size - i, SvREFCNT_inc(*svp))) 1090 SvREFCNT_dec(*svp); 1091 } 1092 } 1093 return sv_2mortal((SV *) newRV_noinc((SV *) result)); 1094} 1095 1096 1097/* list.size */ 1098static SV *list_dot_size(pTHX_ AV *list, AV *args) { 1099 return sv_2mortal(newSViv((IV) av_len(list) + 1)); 1100} 1101 1102 1103/* hash.each */ 1104static SV *hash_dot_each(pTHX_ HV *hash, AV *args) { 1105 AV *result = newAV(); 1106 HE *he; 1107 hv_iterinit(hash); 1108 while ((he = hv_iternext(hash))) { 1109 av_push(result, SvREFCNT_inc((SV *) hv_iterkeysv(he))); 1110 av_push(result, SvREFCNT_inc((SV *) hv_iterval(hash, he))); 1111 } 1112 return sv_2mortal((SV *) newRV_noinc((SV *) result)); 1113} 1114 1115 1116/* hash.keys */ 1117static SV *hash_dot_keys(pTHX_ HV *hash, AV *args) { 1118 AV *result = newAV(); 1119 HE *he; 1120 1121 hv_iterinit(hash); 1122 while ((he = hv_iternext(hash))) 1123 av_push(result, SvREFCNT_inc((SV *) hv_iterkeysv(he))); 1124 1125 return sv_2mortal((SV *) newRV_noinc((SV *) result)); 1126} 1127 1128 1129/* hash.values */ 1130static SV *hash_dot_values(pTHX_ HV *hash, AV *args) { 1131 AV *result = newAV(); 1132 HE *he; 1133 1134 hv_iterinit(hash); 1135 while ((he = hv_iternext(hash))) 1136 av_push(result, SvREFCNT_inc((SV *) hv_iterval(hash, he))); 1137 1138 return sv_2mortal((SV *) newRV_noinc((SV *) result)); 1139} 1140 1141 1142/* scalar.defined */ 1143static SV *scalar_dot_defined(pTHX_ SV *sv, AV *args) { 1144 return &PL_sv_yes; 1145} 1146 1147 1148/* scalar.length */ 1149static SV *scalar_dot_length(pTHX_ SV *sv, AV *args) { 1150 return sv_2mortal(newSViv((IV) SvUTF8(sv) ? sv_len_utf8(sv): sv_len(sv))); 1151} 1152 1153 1154/*==================================================================== 1155 * XS SECTION 1156 *====================================================================*/ 1157 1158MODULE = Template::Stash::XS PACKAGE = Template::Stash::XS 1159 1160PROTOTYPES: DISABLED 1161 1162 1163#----------------------------------------------------------------------- 1164# get(SV *root, SV *ident, SV *args) 1165#----------------------------------------------------------------------- 1166SV * 1167get(root, ident, ...) 1168 SV *root 1169 SV *ident 1170 CODE: 1171 AV *args; 1172 int flags = get_debug_flag(aTHX_ root); 1173 int n; 1174 STRLEN len; 1175 char *str; 1176 1177 /* look for a list ref of arguments, passed as third argument */ 1178 args = 1179 (items > 2 && SvROK(ST(2)) && SvTYPE(SvRV(ST(2))) == SVt_PVAV) 1180 ? (AV *) SvRV(ST(2)) : Nullav; 1181 1182 if (SvROK(ident) && (SvTYPE(SvRV(ident)) == SVt_PVAV)) { 1183 RETVAL = do_getset(aTHX_ root, (AV *) SvRV(ident), NULL, flags); 1184 1185 } 1186 else if (SvROK(ident)) { 1187 croak(TT_STASH_PKG ": get (arg 2) must be a scalar or listref"); 1188 } 1189 else if ((str = SvPV(ident, len)) && memchr(str, '.', len)) { 1190 /* convert dotted string into an array */ 1191 AV *av = convert_dotted_string(aTHX_ str, len); 1192 RETVAL = do_getset(aTHX_ root, av, NULL, flags); 1193 av_undef(av); 1194 } 1195 else { 1196 /* otherwise ident is a scalar so we call dotop() just once */ 1197 RETVAL = dotop(aTHX_ root, ident, args, flags); 1198 } 1199 1200 if (!SvOK(RETVAL)) { 1201 dSP; 1202 ENTER; 1203 SAVETMPS; 1204 PUSHMARK(SP); 1205 XPUSHs(root); 1206 XPUSHs(ident); 1207 PUTBACK; 1208 n = call_method("undefined", G_SCALAR); 1209 SPAGAIN; 1210 if (n != 1) 1211 croak("undefined() did not return a single value\n"); 1212 RETVAL = SvREFCNT_inc(POPs); 1213 PUTBACK; 1214 FREETMPS; 1215 LEAVE; 1216 } 1217 else 1218 RETVAL = SvREFCNT_inc(RETVAL); 1219 1220 OUTPUT: 1221 RETVAL 1222 1223 1224 1225#----------------------------------------------------------------------- 1226# set(SV *root, SV *ident, SV *value, SV *deflt) 1227#----------------------------------------------------------------------- 1228SV * 1229set(root, ident, value, ...) 1230 SV *root 1231 SV *ident 1232 SV *value 1233 CODE: 1234 int flags = get_debug_flag(aTHX_ root); 1235 STRLEN len; 1236 char *str; 1237 1238 /* check default flag passed as fourth argument */ 1239 flags |= ((items > 3) && SvTRUE(ST(3))) ? TT_DEFAULT_FLAG : 0; 1240 1241 if (SvROK(ident) && (SvTYPE(SvRV(ident)) == SVt_PVAV)) { 1242 RETVAL = do_getset(aTHX_ root, (AV *) SvRV(ident), value, flags); 1243 1244 } 1245 else if (SvROK(ident)) { 1246 croak(TT_STASH_PKG ": set (arg 2) must be a scalar or listref"); 1247 1248 } 1249 else if ((str = SvPV(ident, len)) && memchr(str, '.', len)) { 1250 /* convert dotted string into a temporary array */ 1251 AV *av = convert_dotted_string(aTHX_ str, len); 1252 RETVAL = do_getset(aTHX_ root, av, value, flags); 1253 av_undef(av); 1254 } 1255 else { 1256 /* otherwise a simple scalar so call assign() just once */ 1257 RETVAL = assign(aTHX_ root, ident, Nullav, value, flags); 1258 } 1259 1260 if (!SvOK(RETVAL)) 1261 RETVAL = newSVpvn("", 0); /* new empty string */ 1262 else 1263 RETVAL = SvREFCNT_inc(RETVAL); 1264 1265 OUTPUT: 1266 RETVAL 1267 1268 1269