1/* Copyright (c) 1997-2021 2 Ewgenij Gawrilow, Michael Joswig, and the polymake team 3 Technische Universität Berlin, Germany 4 https://polymake.org 5 6 This program is free software; you can redistribute it and/or modify it 7 under the terms of the GNU General Public License as published by the 8 Free Software Foundation; either version 2, or (at your option) any 9 later version: http://www.gnu.org/licenses/gpl.txt. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15-------------------------------------------------------------------------------- 16*/ 17 18#include "polymake/perl/Ext.h" 19#include <utility> 20#include <tuple> 21 22namespace pm { namespace perl { namespace glue { 23 24namespace { 25 26Perl_check_t def_ck_CONST, def_ck_ENTERSUB, def_ck_LEAVESUB, def_ck_LEAVEEVAL, 27 def_ck_GV, def_ck_RV2SV, def_ck_RV2AV, def_ck_RV2HV, def_ck_RV2CV, def_ck_ANONCODE, def_ck_PRINT, def_ck_SYSTEM; 28Perl_ppaddr_t def_pp_GV, def_pp_GVSV, def_pp_AELEMFAST, def_pp_PADAV, def_pp_SPLIT, def_pp_LEAVESUB, def_pp_ANONCODE, 29 def_pp_ENTEREVAL, def_pp_REGCOMP, def_pp_NEXTSTATE, def_pp_DBSTATE, def_pp_ANONLIST, def_pp_SASSIGN, def_pp_PRINT; 30 31#if PerlVersion >= 5220 32Perl_ppaddr_t def_pp_MULTIDEREF; 33#endif 34 35#if defined(POLYMAKE_GATHER_CODE_COVERAGE) 36typedef void (*peep_fun_ptr)(pTHX_ OP*); 37peep_fun_ptr def_peep; 38HV* cov_stats=nullptr; 39FILE* covfile=nullptr; 40#endif 41 42const unsigned int LexCtxAutodeclare = 1u << 31; 43const unsigned int LexCtxAllowReDeclare = 1u << 30; 44const unsigned int LexCtxIndex = -1u >> 2; 45 46// compilation state to be saved during BEGIN processing 47struct ToRestore { 48 ANY saved[3]; 49 ToRestore* begin; 50 CV* cv; 51 int cur_lex_imp, cur_lex_flags; 52 int beginav_fill; 53 I32 replaced, hints; 54 bool old_state; 55}; 56 57AV *lexical_imports, *plugin_data; 58SV *plugin_code; 59int cur_lexical_import_ix = -1, cur_lexical_flags = 0; 60int shadow_stash_cnt = 0; 61ToRestore* active_begin = nullptr; 62SV *dot_lookup_key, *dot_import_key, *dot_subst_op_key, *dot_dummy_pkg_key; 63SV *lex_imp_key, *sub_type_params_key, *scope_type_params_key, *anon_lvalue_key; 64SV *iv_hint, *uv_hint; 65HV *ExplicitTypelist_stash, *args_lookup_stash, *special_imports; 66AV *type_param_names; 67Perl_keyword_plugin_t def_kw_plugin; 68char replaced_char_in_linebuffer = 0; 69 70// true if namespace mode active 71bool current_mode() { return PL_ppaddr[OP_GV] != def_pp_GV; } 72 73void catch_ptrs(pTHX_ void* to_restore); 74void reset_ptrs(pTHX_ void* to_restore); 75int keyword_func(pTHX_ char* kw, STRLEN kw_len, OP** op_ptr); 76 77int reset_ptrs_via_magic(pTHX_ SV* sv, MAGIC* mg); 78 79const MGVTBL restore_holder_vtbl={ nullptr, nullptr, nullptr, nullptr, &reset_ptrs_via_magic }; 80const MGVTBL explicit_typelist_vtbl={ nullptr, nullptr, nullptr, nullptr, nullptr }; 81 82OP* intercept_pp_gv(pTHX); 83OP* intercept_ck_sub(pTHX_ OP* o); 84 85void establish_lex_imp_ix(pTHX_ int new_ix, bool new_mode); 86 87void set_lexical_scope_hint(pTHX) 88{ 89 const int new_hint = cur_lexical_flags | cur_lexical_import_ix; 90 MAGIC hint_mg; 91 hint_mg.mg_ptr = (char*)lex_imp_key; 92 hint_mg.mg_len = HEf_SVKEY; 93 if (new_hint != 0) { 94 SvIVX(iv_hint) = new_hint; 95 Perl_magic_sethint(aTHX_ iv_hint, &hint_mg); 96 } else { 97 Perl_magic_clearhint(aTHX_ &PL_sv_undef, &hint_mg); 98 } 99} 100 101ToRestore* newToRestore(pTHX_ bool old_state) 102{ 103 ToRestore* to_restore; 104 Newx(to_restore, 1, ToRestore); 105 to_restore->begin = active_begin; 106 to_restore->beginav_fill = I32(AvFILL(PL_beginav_save)); 107 to_restore->old_state = old_state; 108 to_restore->hints = PL_hints; 109 to_restore->cur_lex_imp = cur_lexical_import_ix; 110 to_restore->cur_lex_flags = cur_lexical_flags; 111 to_restore->replaced = 0; 112 return to_restore; 113} 114 115void finish_undo(pTHX_ ToRestore* to_restore) 116{ 117 if (to_restore->replaced != 0) { 118 memcpy(PL_savestack + PL_savestack_ix, to_restore->saved, to_restore->replaced * sizeof(to_restore->saved[0])); 119 PL_savestack_ix += to_restore->replaced; 120 } 121 cur_lexical_import_ix = to_restore->cur_lex_imp; 122 cur_lexical_flags = to_restore->cur_lex_flags; 123 if (to_restore->old_state) { 124 while (AvFILL(PL_beginav_save) > to_restore->beginav_fill) { 125 SV* begin_cv = av_pop(PL_beginav_save); 126 SAVEFREESV(begin_cv); 127 } 128 PL_hints &= ~HINT_STRICT_VARS; 129 if (cur_lexical_import_ix != to_restore->cur_lex_imp) 130 set_lexical_scope_hint(aTHX); 131 } else { 132 PL_hints |= to_restore->hints & HINT_STRICT_VARS; 133 } 134 active_begin = to_restore->begin; 135 Safefree(to_restore); 136} 137 138PERL_CONTEXT* find_undo_level(pTHX_ int skip_frames) 139{ 140 PERL_CONTEXT *cx_bottom = cxstack, *cx = cx_bottom + cxstack_ix; 141 while (skip_frames--) { 142 int t; 143 do { t = CxTYPE(cx); --cx; } while (t != CXt_SUB); 144 assert(cx >= cx_bottom); 145 if (skip_debug_cx) { 146 while (CxTYPE(cx) != CXt_SUB || CvSTASH(cx->blk_sub.cv) == PL_debstash) { 147 --cx; 148 assert(cx >= cx_bottom); 149 } 150 } 151 } 152 if (CxTYPE(cx) == CXt_SUB && CvSPECIAL(cx->blk_sub.cv)) { 153 for (;;) { 154 --cx; 155 assert(cx >= cx_bottom); 156 switch (CxTYPE(cx)) { 157 case CXt_BLOCK: 158 if (skip_debug_cx) { 159 COP* cop = cx->blk_oldcop; 160 if (CopSTASH_eq(cop, PL_debstash)) 161 continue; 162 } 163 break; 164 case CXt_SUB: 165 if (skip_debug_cx && CvSTASH(cx->blk_sub.cv) == PL_debstash) 166 continue; 167 break; 168 case CXt_EVAL: 169 if (cx == cx_bottom) { 170 if (PL_curstackinfo->si_type == PERLSI_MAIN) { 171 // perl < 5.20: reached the outermost scope in the main script 172 return nullptr; 173 } else { 174 // perl >= 5.20: "require" is handled in an own stack environment 175 PERL_SI* prev_si = PL_curstackinfo->si_prev; 176 assert(prev_si); 177 return prev_si->si_cxix >= 0 ? prev_si->si_cxstack + prev_si->si_cxix : nullptr; 178 } 179 } 180 return cx-1; 181 } 182 break; 183 } 184 } 185 Perl_croak(aTHX_ "namespaces::{un,}import may not be used directly; write 'use namespaces' or 'no namespaces' instead"); 186 /* UNREACHABLE */ 187 return nullptr; 188} 189 190void insert_undo(pTHX_ int skip_frames) 191{ 192 ANY* saves; 193 PERL_CONTEXT* cx = find_undo_level(aTHX_ skip_frames); 194 ToRestore* to_restore = newToRestore(aTHX_ false); 195 196 if (cx) { 197 /* There is a useful ENTER at the beginning of yyparse() which marks the suitable position on the save stack. 198 * In newer perls this seems to be the second ENTER executed within the context block, 199 * while in the older versions one had to go deeper into the scope stack, for reasons long forgotten and obscure now */ 200 saves = PL_savestack + PL_scopestack[cx->blk_oldscopesp+1]; 201 to_restore->replaced = 3; 202 memcpy(to_restore->saved, saves, 3 * sizeof(to_restore->saved[0])); 203 (saves++)->any_dxptr = &reset_ptrs; 204 (saves++)->any_ptr = to_restore; 205 (saves++)->any_uv = SAVEt_DESTRUCTOR_X; 206 } else { 207 // we are in the main script scope, no further enclosing contexts 208 SV* restore_holder = newSV_type(SVt_PVMG); 209 sv_magicext(restore_holder, nullptr, PERL_MAGIC_ext, &restore_holder_vtbl, nullptr, 0); 210 SvMAGIC(restore_holder)->mg_ptr = (char*)to_restore; 211 to_restore->replaced = 2; 212 saves = PL_savestack; 213 memcpy(to_restore->saved, saves, 2 * sizeof(to_restore->saved[0])); 214 saves[0].any_ptr = restore_holder; 215 saves[1].any_uv = SAVEt_FREESV; 216 } 217} 218 219int reset_ptrs_via_magic(pTHX_ SV* sv, MAGIC* mg) 220{ 221 reset_ptrs(aTHX_ mg->mg_ptr); 222 return 0; 223} 224 225#if PerlVersion < 5220 226# define Perl_op_convert_list Perl_convert 227# define NewMETHOD_NAMED_OP(name, namelen) newSVOP(OP_METHOD_NAMED, 0, newSVpvn_share(name, namelen, 0)) 228#else 229# define NewMETHOD_NAMED_OP(name, namelen) newMETHOP_named(OP_METHOD_NAMED, 0, newSVpvn_share(name, namelen, 0)) 230#endif 231 232int extract_lex_imp_ix(pTHX_ COP *cop) 233{ 234 SV* sv = Perl_refcounted_he_fetch_sv(aTHX_ cop->cop_hints_hash, lex_imp_key, 0, 0); 235 return SvIOK(sv) ? SvIVX(sv) & LexCtxIndex : 0; 236} 237 238int get_lex_flags(pTHX) 239{ 240 SV* sv = Perl_refcounted_he_fetch_sv(aTHX_ PL_curcop->cop_hints_hash, lex_imp_key, 0, 0); 241 return SvIOK(sv) ? int(SvIVX(sv)) : 0; 242} 243 244int get_lex_imp_ix(pTHX) 245{ 246 return extract_lex_imp_ix(aTHX_ PL_curcop); 247} 248 249int get_lex_imp_ix_from_cv(pTHX_ CV* cv) 250{ 251 return extract_lex_imp_ix(aTHX_ (COP*)CvSTART(cv)); 252} 253 254GV* get_dotIMPORT_GV(pTHX_ HV* stash) 255{ 256 GV* imp_gv=(GV*)HeVAL(hv_fetch_ent(stash, dot_import_key, true, SvSHARED_HASH(dot_import_key))); 257 AV* dotIMPORT=nullptr; 258 if (SvTYPE(imp_gv) != SVt_PVGV) 259 gv_init_pvn(imp_gv, stash, SvPVX(dot_import_key), SvCUR(dot_import_key), GV_ADDMULTI); 260 else 261 dotIMPORT=GvAV(imp_gv); 262 263 if (!dotIMPORT) { 264 GvAV(imp_gv)=dotIMPORT=newAV(); 265 hv_delete_ent(stash, dot_dummy_pkg_key, G_DISCARD, SvSHARED_HASH(dot_dummy_pkg_key)); 266 } 267 268 return imp_gv; 269} 270 271AV* get_dotIMPORT(pTHX_ HV* stash) 272{ 273 return GvAV(get_dotIMPORT_GV(aTHX_ stash)); 274} 275 276void set_dotIMPORT(pTHX_ HV* stash, AV* dotIMPORT) 277{ 278 GV* imp_gv=(GV*)HeVAL(hv_fetch_ent(stash, dot_import_key, true, SvSHARED_HASH(dot_import_key))); 279 gv_init_pvn(imp_gv, stash, SvPVX(dot_import_key), SvCUR(dot_import_key), GV_ADDMULTI); 280 GvAV(imp_gv)=(AV*)SvREFCNT_inc_simple_NN((SV*)dotIMPORT); 281} 282 283void set_dotDUMMY_PKG(pTHX_ HV* stash) 284{ 285 GV* dummy_gv=(GV*)HeVAL(hv_fetch_ent(stash, dot_dummy_pkg_key, true, SvSHARED_HASH(dot_dummy_pkg_key))); 286 if (SvTYPE(dummy_gv) != SVt_PVGV) { 287 gv_init_pvn(dummy_gv, stash, SvPVX(dot_dummy_pkg_key), SvCUR(dot_dummy_pkg_key), GV_ADDMULTI); 288 sv_setiv(GvSVn(dummy_gv), 1); 289 } 290} 291 292bool is_dummy_pkg(pTHX_ HV* stash, bool allow_set=false) 293{ 294 if (HE* dummy_he=hv_fetch_ent(stash, dot_dummy_pkg_key, false, SvSHARED_HASH(dot_dummy_pkg_key))) { 295 SV* sv=GvSV((GV*)HeVAL(dummy_he)); 296 return sv && SvIOK(sv) && SvIV(sv) != 0; 297 } 298 if (allow_set && HvTOTALKEYS(stash) <= 1) { 299 set_dotDUMMY_PKG(aTHX_ stash); 300 return true; 301 } 302 return false; 303} 304 305bool equal_arrays(AV* ar1, AV* ar2) 306{ 307 if (AvFILLp(ar1) != AvFILLp(ar2)) return false; 308 if (AvFILLp(ar1)>=0) { 309 for (SV **lookp=AvARRAY(ar1), **endp=lookp+AvFILLp(ar1), **lookp2=AvARRAY(ar2); lookp<=endp; ++lookp, ++lookp2) { 310 if (SvRV(*lookp) != SvRV(*lookp2)) return false; 311 } 312 } 313 return true; 314} 315 316SSize_t skip_spaces(pTHX_ SSize_t pos) 317{ 318 for (; pos < SSize_t(SvCUR(PL_parser->linestr)) || lex_next_chunk(LEX_KEEP_PREVIOUS); ++pos) { 319 if (!isSPACE(PL_parser->linestart[pos])) 320 return pos; 321 } 322 return -1; 323} 324 325bool find_stash_in_import_list(AV* import_av, HV* stash) 326{ 327 if (AvFILLp(import_av)>=0) { 328 for (SV **lookp=AvARRAY(import_av), **endp=lookp+AvFILLp(import_av); lookp<=endp; ++lookp) 329 if ((HV*)SvRV(*lookp)==stash) return true; 330 } 331 return false; 332} 333 334int store_lex_lookup_stash(pTHX_ SV* stash_ref) 335{ 336 SV* stash = SvRV(stash_ref); 337 for (SV **lookp = AvARRAY(lexical_imports), **const endp = lookp + AvFILLp(lexical_imports); 338 ++lookp <= endp; ) { 339 if (SvRV(*lookp) == stash) 340 return int(lookp - AvARRAY(lexical_imports)); 341 } 342 av_push(lexical_imports, SvREFCNT_inc_simple_NN(stash_ref)); 343 return int(AvFILLp(lexical_imports)); 344} 345 346AV* get_dotARRAY(pTHX_ HV* stash, SV* arr_name_sv, bool create) 347{ 348 HE* arr_gve=hv_fetch_ent(stash, arr_name_sv, create, SvSHARED_HASH(arr_name_sv)); 349 if (create) { 350 GV* arr_gv=(GV*)HeVAL(arr_gve); 351 if (SvTYPE(arr_gv) != SVt_PVGV) 352 gv_init_pvn(arr_gv, stash, SvPVX(arr_name_sv), SvCUR(arr_name_sv), GV_ADDMULTI); 353 return GvAVn(arr_gv); 354 } 355 return arr_gve ? GvAV(HeVAL(arr_gve)) : nullptr; 356} 357 358AV* get_dotSUBST_OP(pTHX_ HV* stash, bool create) 359{ 360 return get_dotARRAY(aTHX_ stash, dot_subst_op_key, create); 361} 362 363// elements of an operation interception descriptor: indexes into an AV 364enum { 365 intercept_op_code, 366 intercept_op_subref, 367 intercept_op_addarg, 368 intercept_op_reset, 369 intercept_op_catch, 370 intercept_op_last = intercept_op_catch 371}; 372 373AV* get_cur_dotSUBST_OP(pTHX) 374{ 375 return cur_lexical_import_ix > 0 ? get_dotSUBST_OP(aTHX_ (HV*)SvRV(AvARRAY(lexical_imports)[cur_lexical_import_ix]), false) : nullptr; 376} 377 378AV* merge_dotSUBST_OP(pTHX_ HV* stash, AV* dotSUBST_OP, AV* imp_dotSUBST_OP) 379{ 380 if (!dotSUBST_OP) { 381 dotSUBST_OP = get_dotSUBST_OP(aTHX_ stash, true); 382 const int e = int(AvFILLp(imp_dotSUBST_OP)); 383 for (int i = 0; i <= e; ++i) 384 av_push(dotSUBST_OP, SvREFCNT_inc_NN(AvARRAY(imp_dotSUBST_OP)[i])); 385 } else { 386 const int e = int(AvFILLp(imp_dotSUBST_OP)); 387 for (int i = 0; i <= e; ++i) { 388 AV* op_descr = (AV*)SvRV(AvARRAY(imp_dotSUBST_OP)[i]); 389 const int k = int(AvFILLp(dotSUBST_OP)); 390 int j; 391 for (j = 0; j <= k; ++j) 392 if (SvIVX(AvARRAY(op_descr)[intercept_op_code]) == SvIVX(AvARRAY((AV*)SvRV(AvARRAY(dotSUBST_OP)[j]))[intercept_op_code])) 393 break; 394 if (j > k) av_push(dotSUBST_OP, newRV((SV*)op_descr)); 395 } 396 } 397 return dotSUBST_OP; 398} 399 400int store_shadow_lex_lookup_stash(pTHX_ AV* dotIMPORT) 401{ 402 for (SV **lookp = AvARRAY(lexical_imports), ** const endp = lookp + AvFILLp(lexical_imports); ++lookp <= endp; ) { 403 HV* stash = (HV*)SvRV(*lookp); 404 if (HvNAME(stash)[0] == '-') { 405 if (equal_arrays(dotIMPORT, get_dotIMPORT(aTHX_ stash))) 406 return int(lookp - AvARRAY(lexical_imports)); 407 } 408 } 409 410 // must create a new shadow stash 411 HV* shadow_stash = gv_stashpv(form("--namespace-lookup-%d", ++shadow_stash_cnt), GV_ADD); 412 set_dotIMPORT(aTHX_ shadow_stash, dotIMPORT); 413 av_push(lexical_imports, newRV_noinc((SV*)shadow_stash)); 414 415 AV* dotSUBST_OP = nullptr; 416 for (SV **lookp = AvARRAY(dotIMPORT), ** const endp = lookp + AvFILLp(dotIMPORT); lookp <= endp; ++lookp) { 417 if (AV* imp_dotSUBST_OP = get_dotSUBST_OP(aTHX_ (HV*)SvRV(*lookp), false)) 418 dotSUBST_OP = merge_dotSUBST_OP(aTHX_ shadow_stash, dotSUBST_OP, imp_dotSUBST_OP); 419 } 420 return int(AvFILLp(lexical_imports)); 421} 422 423OP* switch_off_namespaces(pTHX) 424{ 425 reset_ptrs(aTHX_ nullptr); 426 if (PL_op->op_flags & OPf_SPECIAL) { 427 cur_lexical_import_ix = -1; 428 cur_lexical_flags = 0; 429 } 430 PL_op->op_ppaddr = &Perl_pp_null; 431 return NORMAL; 432} 433 434bool append_imp_stash(pTHX_ AV* import_av, HV* imp_stash) 435{ 436 if (find_stash_in_import_list(import_av, imp_stash)) 437 return false; 438 av_push(import_av, newRV((SV*)imp_stash)); 439 return true; 440} 441 442void remove_imp_stash(pTHX_ AV* dotLOOKUP, HV* imp_stash) 443{ 444 if (AvFILLp(dotLOOKUP) >= 0) { 445 for (SV **lookp=AvARRAY(dotLOOKUP), **endp=lookp+AvFILLp(dotLOOKUP); lookp<=endp; ++lookp) { 446 if ((HV*)SvRV(*lookp)==imp_stash) { 447 SvREFCNT_dec(*lookp); 448 if (lookp<endp) Move(lookp+1, lookp, endp-lookp, SV**); 449 *endp=PmEmptyArraySlot; 450 AvFILLp(dotLOOKUP)--; 451 break; 452 } 453 } 454 } 455} 456 457int merge_lexical_import_scopes(pTHX_ int lex_ix1, int lex_ix2) 458{ 459 if (lex_ix1 == lex_ix2 || lex_ix2 == 0) return lex_ix1; 460 if (lex_ix1 == 0) return lex_ix2; 461 462 HV* imp_stash1 = (HV*)SvRV(AvARRAY(lexical_imports)[lex_ix1]); 463 HV* imp_stash2 = (HV*)SvRV(AvARRAY(lexical_imports)[lex_ix2]); 464 AV* dot_import1 = get_dotIMPORT(aTHX_ imp_stash1); 465 AV* dot_import2 = get_dotIMPORT(aTHX_ imp_stash2); 466 const bool is_shadow1 = HvNAME(imp_stash1)[0] == '-'; 467 const bool is_shadow2 = HvNAME(imp_stash2)[0] == '-'; 468 469 // maybe one stash is already contained in another's import list? 470 if (!is_shadow2 && dot_import1 && find_stash_in_import_list(dot_import1, imp_stash2)) 471 return lex_ix1; 472 if (!is_shadow1 && dot_import2 && find_stash_in_import_list(dot_import2, imp_stash1)) 473 return lex_ix2; 474 475 // concatenate both import lists into a new one 476 AV* new_imports; 477 if (is_shadow1) { 478 new_imports = av_make(AvFILLp(dot_import1)+1, AvARRAY(dot_import1)); 479 } else { 480 new_imports = newAV(); 481 av_push(new_imports, newRV((SV*)imp_stash1)); 482 } 483 if (is_shadow2) { 484 SV **lookp2 = AvARRAY(dot_import2), ** const endp2 = lookp2 + AvFILLp(dot_import2); 485 if (is_shadow1) { 486 for (; lookp2 < endp2; ++lookp2) 487 append_imp_stash(aTHX_ new_imports, (HV*)SvRV(*lookp2)); 488 } else { 489 av_extend(new_imports, AvFILLp(dot_import2)+1); 490 for (; lookp2 < endp2; ++lookp2) 491 av_push(new_imports, newSVsv(*lookp2)); 492 } 493 } else { 494 av_push(new_imports, newRV((SV*)imp_stash2)); 495 } 496 497 lex_ix1 = store_shadow_lex_lookup_stash(aTHX_ new_imports); 498 SvREFCNT_dec(new_imports); 499 return lex_ix1; 500} 501 502// first -> .LOOKUP array 503// second -> pkgLOOKUP cache 504std::pair<AV*, HV*> get_dotLOOKUP(pTHX_ HV* stash); 505 506void append_lookup(pTHX_ HV* stash, AV* dotLOOKUP, AV* import_from, bool recurse) 507{ 508 SV **impp=AvARRAY(import_from), **endp; 509 if (impp) { 510 for (endp=impp+AvFILLp(import_from); impp<=endp; ++impp) { 511 HV* imp_stash=(HV*)SvRV(*impp); 512 if (imp_stash != stash && append_imp_stash(aTHX_ dotLOOKUP, imp_stash) && recurse) { 513 AV* imp_dotLOOKUP=get_dotLOOKUP(aTHX_ imp_stash).first; 514 if (imp_dotLOOKUP) append_lookup(aTHX_ stash, dotLOOKUP, imp_dotLOOKUP, false); 515 } 516 } 517 } 518} 519 520std::pair<AV*, HV*> get_dotLOOKUP(pTHX_ HV* stash) 521{ 522 AV* dotLOOKUP=nullptr; 523 HV* pkgLOOKUP=nullptr; 524 GV* lookup_gv=(GV*)HeVAL(hv_fetch_ent(stash, dot_lookup_key, true, SvSHARED_HASH(dot_lookup_key))); 525 if (SvTYPE(lookup_gv) != SVt_PVGV) { 526 gv_init_pvn(lookup_gv, stash, SvPVX(dot_lookup_key), SvCUR(dot_lookup_key), GV_ADDMULTI); 527 } else { 528 dotLOOKUP=GvAV(lookup_gv); 529 pkgLOOKUP=GvHV(lookup_gv); 530 } 531 if (!dotLOOKUP) { 532 char* st_name=HvNAME(stash); 533 I32 st_name_len=HvNAMELEN(stash); 534 AV* dotIMPORT; 535 HE* imp_gve; 536 537 if ( (imp_gve = hv_fetch_ent(stash, dot_import_key, false, SvSHARED_HASH(dot_import_key))) && 538 (dotIMPORT=GvAV(HeVAL(imp_gve))) ) { 539 dotLOOKUP = newAV(); 540 append_lookup(aTHX_ stash, dotLOOKUP, dotIMPORT, true); 541 542 for (int i = st_name_len-2; i > 0; --i) { 543 if (st_name[i] == ':' && st_name[i-1] == ':') { 544 if (HV* encl_stash = gv_stashpvn(st_name, --i, GV_NOADD_NOINIT)) { 545 if (append_imp_stash(aTHX_ dotLOOKUP, encl_stash)) { 546 if (hv_exists_ent(encl_stash, dot_import_key, SvSHARED_HASH(dot_import_key))) { 547 if (AV* encl_lookup = get_dotLOOKUP(aTHX_ encl_stash).first) { 548 append_lookup(aTHX_ stash, dotLOOKUP, encl_lookup, false); 549 break; // encl_stash::.LOOKUP certainly contains all enclosing packages 550 } 551 } 552 } else { 553 break; 554 } 555 } 556 } 557 } 558 559 GvAV(lookup_gv)=dotLOOKUP; 560 if (AvFILLp(dotLOOKUP)<0) dotLOOKUP=nullptr; 561 GvHV(lookup_gv)=pkgLOOKUP=newHV(); 562 } 563 } 564 565 return { dotLOOKUP, pkgLOOKUP }; 566} 567 568OP* pp_popmark_and_nextstate(pTHX) 569{ 570 (void)POPMARK; 571 return def_pp_NEXTSTATE(aTHX); 572} 573 574#ifdef USE_ITHREADS 575 576void pull_repaired_gv(pTHX_ OP* o) 577{ 578 SV* subst = cSVOPx_sv(o); 579 const PADOFFSET i = o->op_targ; 580 if (PAD_SV(i) != subst) { 581 SvREFCNT_dec(PAD_SV(i)); 582 PAD_SVl(i) = SvREFCNT_inc_simple_NN(subst); 583 } 584} 585 586OP* repaired_gv(pTHX) 587{ 588 pull_repaired_gv(aTHX_ OpSIBLING(PL_op)); 589 return Perl_pp_gv(aTHX); 590} 591 592OP* repaired_gvsv(pTHX) 593{ 594 pull_repaired_gv(aTHX_ OpSIBLING(PL_op)); 595 return Perl_pp_gvsv(aTHX); 596} 597 598OP* repaired_aelemefast(pTHX) 599{ 600 pull_repaired_gv(aTHX_ OpSIBLING(PL_op)); 601 return Perl_pp_aelemfast(aTHX); 602} 603 604OP* repaired_split(pTHX) 605{ 606 pull_repaired_gv(aTHX_ OpSIBLING(PL_op)); 607 return Perl_pp_split(aTHX); 608} 609 610#if PerlVersion >= 5220 611OP* repaired_multideref(pTHX) 612{ 613 OP* this_op=PL_op; 614 OP* o=this_op; 615 do { 616 o=OpSIBLING(o); 617 assert(o->op_type==OP_CONST && cSVOPo->op_sv); 618 pull_repaired_gv(aTHX_ o); 619 } while (o->op_next==this_op); 620 return Perl_pp_multideref(aTHX); 621} 622#endif 623 624void repair_gvop(pTHX_ SV* old_sv, SV* new_sv, PADOFFSET pad_ix) 625{ 626 CV* cv=get_cur_cv(aTHX); 627 if (CvCLONED(cv)) { 628 OP* this_op=PL_op; 629 OP* helper=newSVOP(OP_CONST, 0, new_sv); 630 helper->op_targ=pad_ix; 631 PmOpCopySibling(helper, this_op); 632 OpMORESIB_set(this_op, helper); 633 switch (this_op->op_type) { 634 case OP_GV: 635 this_op->op_ppaddr=&repaired_gv; 636 break; 637 case OP_GVSV: 638 this_op->op_ppaddr=&repaired_gvsv; 639 break; 640 case OP_AELEMFAST: 641 this_op->op_ppaddr=&repaired_aelemefast; 642 break; 643 case OP_SPLIT: 644 this_op->op_ppaddr=&repaired_split; 645 break; 646#if PerlVersion >= 5220 647 case OP_MULTIDEREF: 648 this_op->op_ppaddr=&repaired_multideref; 649 helper->op_next=this_op; 650 break; 651#endif 652 } 653 } else { 654 PADLIST* padlist=CvPADLIST(cv); 655 PAD** padstart=PadlistARRAY(padlist); 656 if (PL_comppad==padstart[CvDEPTH(cv)]) { 657 PADOFFSET max = PadlistMAX(padlist); 658#if defined(DEBUGGING) && PerlVersion >= 5180 659 PADNAMELIST* padnames = PadlistNAMES(padlist); 660 if ((I32)pad_ix <= PadnamelistMAX(padnames)) { 661#if PerlVersion < 5220 662 SV* empty_slot = PadnamelistARRAY(padnames)[pad_ix]; 663 if (empty_slot && SvTYPE(empty_slot)) 664#else 665 if (PadnameLEN(PadnamelistARRAY(padnames)[pad_ix]) != 0) 666#endif 667 Perl_croak(aTHX_ "namespaces::repair_gvop - internal error"); 668 } 669#endif 670 while (!PadlistARRAY(padlist)[max]) 671 max--; 672 for (PAD **pads=padstart+1, **epads=padstart+max; pads<=epads; ++pads) { 673 SvREFCNT_dec(old_sv); 674 if (pads < epads) SvREFCNT_inc_simple_void_NN(new_sv); // the last increment is made after the loop 675 AvARRAY(*pads)[pad_ix]=new_sv; 676 } 677 } else { 678 // working with another PAD: probably re-eval 679 SvREFCNT_dec(old_sv); 680 PAD_SVl(pad_ix)=new_sv; 681 } 682 } 683 if (SvTYPE(new_sv)==SVt_PVGV) { 684 GvIN_PAD_on(new_sv); 685 SvREFCNT_inc_simple_void_NN(new_sv); 686 } 687} 688 689void repair_gvop(pTHX_ SV* old_sv, SV* new_sv) 690{ 691 repair_gvop(aTHX_ old_sv, new_sv, cPADOP->op_padix); 692} 693 694void repair_splitop(pTHX_ SV* old_sv, SV* new_sv) 695{ 696 repair_gvop(aTHX_ old_sv, new_sv, cPMOPx(cUNOP->op_first)->op_pmreplrootu.op_pmtargetoff); 697} 698 699#if PerlVersion >= 5220 700void repair_multideref(pTHX_ SV* old_sv, SV* new_sv, UNOP_AUX_item* aux_item) 701{ 702 repair_gvop(aTHX_ old_sv, new_sv, aux_item->pad_offset); 703} 704#endif 705 706#else // !ITHREADS 707 708void repair_gvop(pTHX_ SV* old_sv, SV* new_sv) 709{ 710 SvREFCNT_dec(old_sv); 711 cSVOP->op_sv=SvREFCNT_inc_NN(new_sv); 712} 713 714void repair_splitop(pTHX_ SV* old_sv, SV* new_sv) 715{ 716 SvREFCNT_dec(old_sv); 717 cPMOPx(cUNOP->op_first)->op_pmreplrootu.op_pmtargetgv=(GV*)SvREFCNT_inc_NN(new_sv); 718} 719 720#if PerlVersion >= 5220 721void repair_multideref(pTHX_ SV* old_sv, SV* new_sv, UNOP_AUX_item* aux_item) 722{ 723 SvREFCNT_dec(old_sv); 724 aux_item->sv=SvREFCNT_inc_NN(new_sv); 725} 726#endif 727#endif // !ITHREADS 728 729#if PerlVersion >= 5220 730# define aMultiDerefItem_ aux_item, 731# define nullMultiDerefItem_ nullptr, 732# define pMultiDerefItem_ UNOP_AUX_item* aux_item, 733#else 734# define aMultiDerefItem_ 735# define nullMultiDerefItem_ 736# define pMultiDerefItem_ 737#endif 738 739void repair_pp_gv(pTHX_ pMultiDerefItem_ GV* old_gv, GV* new_gv) 740{ 741 switch (PL_op->op_type) { 742 case OP_SPLIT: 743 repair_splitop(aTHX_ (SV*)old_gv, (SV*)new_gv); 744 break; 745 case OP_GVSV: 746 case OP_AELEMFAST: 747 repair_gvop(aTHX_ (SV*)old_gv, (SV*)new_gv); 748 break; 749#if PerlVersion >= 5220 750 case OP_MULTIDEREF: 751 repair_multideref(aTHX_ (SV*)old_gv, (SV*)new_gv, aux_item); 752 break; 753#endif 754 default: 755 { 756 dSP; 757 repair_gvop(aTHX_ (SV*)old_gv, (SV*)new_gv); 758 SETs((SV*)new_gv); 759 } 760 } 761} 762 763GV* try_stored_lexical_gv(pTHX_ GV* var_gv, I32 type, I32 lex_imp_ix) 764{ 765 MAGIC* mg=mg_find((SV*)var_gv, PERL_MAGIC_ext); 766 GV **list_start, *imp_gv; 767 if (mg && (list_start=(GV**)mg->mg_ptr)) { 768 lex_imp_ix-=mg->mg_private; 769 if (lex_imp_ix>=0 && lex_imp_ix<mg->mg_len && (imp_gv=list_start[lex_imp_ix])) { 770 switch (type) { 771 case SVt_PV: 772 if (GvIMPORTED_SV(imp_gv)) return imp_gv; 773 break; 774 case SVt_PVAV: 775 if (GvIMPORTED_AV(imp_gv)) return imp_gv; 776 break; 777 case SVt_PVHV: 778 if (GvIMPORTED_HV(imp_gv)) return imp_gv; 779 break; 780 case SVt_PVCV: { 781 CV* cv=GvCV(imp_gv); 782 if (cv && is_well_defined_sub(cv)) return imp_gv; 783 }} 784 } 785 } 786 return nullptr; 787} 788 789void store_lexical_gv(pTHX_ GV* var_gv, GV* imp_gv, I32 lex_imp_ix) 790{ 791 MAGIC* mg = mg_find((SV*)var_gv, PERL_MAGIC_ext); 792 GV** list_start; 793 if (mg && (list_start = (GV**)mg->mg_ptr)) { 794 lex_imp_ix -= mg->mg_private; 795 if (lex_imp_ix < 0) { 796 Newxz(list_start, mg->mg_len - lex_imp_ix, GV*); 797 Copy(mg->mg_ptr, list_start, mg->mg_len, GV*); 798 Safefree(mg->mg_ptr); 799 mg->mg_ptr = (char*)list_start; 800 mg->mg_len -= lex_imp_ix; 801 list_start[0] = imp_gv; 802 mg->mg_private = U16(mg->mg_private + lex_imp_ix); 803 } else if (lex_imp_ix >= mg->mg_len) { 804 Renewc(mg->mg_ptr, lex_imp_ix+1, GV*, char); 805 list_start = (GV**)mg->mg_ptr; 806 Zero(list_start + mg->mg_len, lex_imp_ix - mg->mg_len, GV*); 807 list_start[lex_imp_ix] = imp_gv; 808 mg->mg_len = lex_imp_ix+1; 809 } else if (list_start[lex_imp_ix]) { 810 if (list_start[lex_imp_ix] != imp_gv) 811 Perl_croak(aTHX_ "ambiguous name resolution in package %.*s, lexical scope %d: conflict between %.*s::%.*s and %.*s::%.*s", 812 PmPrintHvNAME(GvSTASH(var_gv)), (int)(lex_imp_ix+mg->mg_private), 813 PmPrintHvNAME(GvSTASH(imp_gv)), PmPrintGvNAME(imp_gv), 814 PmPrintHvNAME(GvSTASH(list_start[lex_imp_ix])), PmPrintGvNAME(imp_gv)); 815 } else { 816 list_start[lex_imp_ix] = imp_gv; 817 } 818 } else { 819 if (!mg) mg = sv_magicext((SV*)var_gv, nullptr, PERL_MAGIC_ext, nullptr, nullptr, 1); 820 Newxz(list_start, 1, GV*); 821 mg->mg_ptr = (char*)list_start; 822 list_start[0] = imp_gv; 823 mg->mg_private = U16(lex_imp_ix); 824 } 825} 826 827void store_package_gv(pTHX_ GV* var_gv, GV* imp_gv) 828{ 829 MAGIC* mg=mg_find((SV*)var_gv, PERL_MAGIC_ext); 830 if (mg) { 831 if (mg->mg_obj) { 832 if ((GV*)mg->mg_obj != imp_gv) 833 Perl_croak(aTHX_ "ambiguous name resolution in package %.*s: conflict between %.*s::%.*s in and %.*s::%.*s", 834 PmPrintHvNAME(GvSTASH(var_gv)), 835 PmPrintHvNAME(GvSTASH(imp_gv)), PmPrintGvNAME(imp_gv), 836 PmPrintHvNAME(GvSTASH(mg->mg_obj)), PmPrintGvNAME(imp_gv)); 837 } else { 838 mg->mg_obj=(SV*)imp_gv; 839 } 840 } else { 841 mg=sv_magicext((SV*)var_gv, nullptr, PERL_MAGIC_ext, nullptr, nullptr, 1); 842 mg->mg_obj=(SV*)imp_gv; 843 } 844} 845 846// internal flags for symbol lookup methods 847enum { ignore_methods=1, ignore_undefined=2, 848 bad_filehandle_gv=4, bad_constant_gv=8, 849 dont_cache=16, dont_create_dummy_sub=32 }; 850 851GV* const ignored_gv=(GV*)(1UL); 852 853GV* test_imported_gv(pTHX_ GV* gv, I32 type, int flags) 854{ 855 switch (type) { 856 case SVt_PV: 857 return GvIMPORTED_SV(gv) ? gv : nullptr; 858 case SVt_PVAV: 859 return GvIMPORTED_AV(gv) ? gv : nullptr; 860 case SVt_PVHV: 861 return GvIMPORTED_HV(gv) ? gv : nullptr; 862 case SVt_PVCV: 863 if (CV* cv=GvCV(gv)) { 864 if ((flags & ignore_methods) && CvMETHOD(cv)) 865 // may not discover methods in object-less call 866 return ignored_gv; 867 if (!is_well_defined_sub(cv) && ((flags & ignore_undefined) || !GvASSUMECV(gv))) 868 return ignored_gv; 869 // For inherited static methods return the gv from the basis class! 870 return GvCVGEN(gv) ? CvGV(cv) : gv; 871 } 872 break; 873 } 874 return nullptr; 875} 876 877GV* try_stored_package_gv(pTHX_ GV* gv, I32 type, int flags, bool show_ignored=false) 878{ 879 MAGIC* mg=mg_find((SV*)gv, PERL_MAGIC_ext); 880 if (mg && (gv=(GV*)mg->mg_obj)) { 881 gv=test_imported_gv(aTHX_ gv, type, flags); 882 return gv==ignored_gv ? nullptr : gv; 883 } 884 return nullptr; 885} 886 887std::pair<GV*, GV*> 888lookup_name_in_stash(pTHX_ HV* stash, const char* name, STRLEN name_len, I32 type, 889 const int flags = ignore_undefined | ignore_methods) 890{ 891 if (GV** gvp = (GV**)hv_fetch(stash, name, I32(name_len), false)) { 892 GV* gv = *gvp; 893#if PerlVersion >= 5275 894 // TODO(later): this will spoil the constant inlining, should think about preserving some refs 895 if (SvROK(gv) && SvTYPE(SvRV(gv)) == type) 896 gv_init_pvn(gv, stash, name, name_len, GV_ADDMULTI); 897#endif 898 if (SvTYPE(gv) == SVt_PVGV) { 899 GV* imp_gv=try_stored_package_gv(aTHX_ gv, type, flags, true); 900 if (!imp_gv) 901 imp_gv=test_imported_gv(aTHX_ gv, type, flags); 902 if (imp_gv) 903 return { imp_gv == ignored_gv ? nullptr : imp_gv, nullptr }; 904 905 if ((flags & bad_filehandle_gv) && GvIOp(gv)) 906 return { nullptr, gv }; 907 } else if ((flags & bad_constant_gv) && SvROK(gv)) { 908 return { nullptr, gv }; 909 } 910 } 911 return { nullptr, nullptr }; 912} 913 914CV* create_dummy_sub(pTHX_ HV* stash, GV* gv) 915{ 916 CV* dummy_cv = (CV*)newSV_type(SVt_PVCV); 917 GvCV_set(gv, dummy_cv); 918 CvGV_set(dummy_cv, gv); 919 CvSTASH_set(dummy_cv, stash); 920 GvASSUMECV_on(gv); 921 return dummy_cv; 922} 923 924GV* lookup_name_in_list(pTHX_ HV* stash, GV* var_gv, const char* name, STRLEN name_len, I32 type, int flags) 925{ 926 AV* dotLOOKUP = get_dotLOOKUP(aTHX_ stash).first; 927 if (dotLOOKUP && AvFILLp(dotLOOKUP)>=0) { 928 for (SV **lookp = AvARRAY(dotLOOKUP), **endp = lookp+AvFILLp(dotLOOKUP); lookp <= endp; ++lookp) { 929 if (GV* imp_gv = lookup_name_in_stash(aTHX_ (HV*)SvRV(*lookp), name, name_len, type, flags).first) { 930 if (!(flags & dont_cache)) { 931 if (!var_gv) { 932 var_gv = *(GV**)hv_fetch(stash, name, I32(name_len), true); 933 if (SvTYPE(var_gv) != SVt_PVGV) 934 gv_init_pvn(var_gv, stash, name, name_len, GV_ADDMULTI); 935 } 936 store_package_gv(aTHX_ var_gv, imp_gv); 937 // the sub must immediately become visible to the parser 938 if (type == SVt_PVCV && !(flags & dont_create_dummy_sub) && !CvMETHOD(GvCV(imp_gv))) 939 create_dummy_sub(aTHX_ stash, var_gv); 940 } 941 return imp_gv; 942 } 943 } 944 } 945 return nullptr; 946} 947 948// performs only package-based lookup, no lexical context taken into account 949std::pair<GV*, GV*> 950lookup_var(pTHX_ HV* stash, const char* name, STRLEN name_len, I32 type, 951 int flags = ignore_undefined | ignore_methods) 952{ 953 auto result = lookup_name_in_stash(aTHX_ stash, name, name_len, type, flags); 954 if (!result.first && !result.second) { 955 flags &= ~(bad_filehandle_gv | bad_constant_gv); 956 flags |= ignore_undefined; 957 result.first = lookup_name_in_list(aTHX_ stash, nullptr, name, name_len, type, flags); 958 } 959 return result; 960} 961 962std::pair<GV*, GV*> 963lookup_sub_gv(pTHX_ HV* stash, const char* name, STRLEN name_len, int lex_imp_ix, int flags) 964{ 965 const char* colon = strrchr(name, ':'); 966 if (colon && --colon > name && *colon==':') { 967 // (at least partially) qualified: look for the package first 968 stash = namespace_lookup_class_autoload(aTHX_ stash, name, colon - name, lex_imp_ix); 969 if (!stash) 970 return { nullptr, nullptr }; 971 colon += 2; 972 name_len -= colon - name; 973 name = colon; 974 } 975 976 auto result = lookup_var(aTHX_ stash, name, name_len, SVt_PVCV, flags | ignore_methods); 977 978 if (!result.first && !result.second && !colon && lex_imp_ix) { 979 // unqualified and not found in the given package: look into the lexical scope 980 981 GV** local_gvp = (GV**)hv_fetch(stash, name, I32(name_len), !(flags & dont_cache)); 982 GV* local_gv = nullptr; 983 if (local_gvp) { 984 local_gv = *local_gvp; 985 if (SvTYPE(local_gv) != SVt_PVGV) 986 gv_init_pvn(local_gv, stash, name, name_len, GV_ADDMULTI); 987 988 result.first = try_stored_lexical_gv(aTHX_ local_gv, SVt_PVCV, lex_imp_ix); 989 } 990 if (!result.first) { 991 result = lookup_var(aTHX_ (HV*)SvRV(AvARRAY(lexical_imports)[lex_imp_ix]), name, name_len, SVt_PVCV, 992 (flags & ~(bad_filehandle_gv | bad_constant_gv)) | ignore_methods | dont_create_dummy_sub); 993 if (result.first && !(flags & dont_cache)) 994 store_lexical_gv(aTHX_ local_gv, result.first, lex_imp_ix); 995 } 996 997 if (result.first && !(flags & dont_cache)) { 998 // the sub must become visible to the parser 999 if (!(flags & dont_create_dummy_sub) && !GvCV(local_gv)) 1000 create_dummy_sub(aTHX_ stash, local_gv); 1001 result.first = local_gv; 1002 } 1003 } 1004 1005 return result; 1006} 1007 1008OP* enclosing_assign_op(I32 type, OP* o) 1009{ 1010 bool maybe_scalar_assignment = true; 1011 OP* o_next; 1012 while ((o_next = o->op_next)) { 1013 if (o_next->op_type == OP_GVSV) { 1014 maybe_scalar_assignment = false; 1015 o = o_next; 1016 continue; 1017 } 1018 if (o_next->op_type == OP_AASSIGN || 1019 (type == SVt_PV && maybe_scalar_assignment && 1020 (o_next->op_type == OP_SASSIGN 1021#if PerlVersion >= 5275 1022 // $a="...$b..."; is a separate operation since 5.27 1023 || o_next->op_type == OP_MULTICONCAT && (o_next->op_flags & OPf_STACKED) && !(o_next->op_private & OPpMULTICONCAT_APPEND) 1024#endif 1025 ))) 1026 return o_next; 1027 1028 if (o->op_type == OP_SPLIT) 1029 return o; 1030 1031 if (o_next->op_type == OP_GV) { 1032 o = o_next->op_next; 1033 if (o->op_type == OP_READLINE && (o->op_flags & OPf_STACKED)) 1034 return o; 1035 if (o->op_type == OP_RV2SV || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) { 1036 maybe_scalar_assignment = false; 1037 continue; 1038 } 1039 } 1040 break; 1041 } 1042 return nullptr; 1043} 1044 1045void lookup(pTHX_ pMultiDerefItem_ GV* var_gv, I32 type, OP** pnext_op, OP* access_op) 1046{ 1047 HV* stash = GvSTASH(var_gv); 1048 if (stash != PL_defstash && stash != PL_debstash) { 1049 const char* varname = GvNAME(var_gv); 1050 STRLEN varnamelen = GvNAMELEN(var_gv); 1051 int lex_imp_ix = 0; 1052 GV* imp_gv; 1053 1054 if (!pnext_op || CopSTASH_eq(PL_curcop, stash)) { 1055 // unqualified 1056 OP* assign_op; 1057 if (access_op && (assign_op = enclosing_assign_op(type, access_op))) { 1058 OPCODE after_assign = assign_op->op_next->op_type; 1059 if ((after_assign == OP_LEAVEEVAL || after_assign == OP_NEXTSTATE || after_assign == OP_DBSTATE) && 1060 (get_lex_flags(aTHX) & LexCtxAutodeclare)) { 1061 switch (type) { 1062 case SVt_PV: 1063 if (!GvSV(var_gv) || !SvTYPE(GvSV(var_gv))) { 1064 GvIMPORTED_SV_on(var_gv); 1065 return; 1066 } 1067 break; 1068 case SVt_PVAV: 1069 if (!GvAV(var_gv) || !AvARRAY(GvAV(var_gv))) { 1070 GvIMPORTED_AV_on(var_gv); 1071 return; 1072 } 1073 break; 1074 case SVt_PVHV: 1075 if (!GvHV(var_gv) || !HvARRAY(GvHV(var_gv))) { 1076 GvIMPORTED_HV_on(var_gv); 1077 return; 1078 } 1079 break; 1080 } 1081 } 1082 } 1083 1084 int lookup_flags = ignore_undefined | dont_create_dummy_sub; 1085 if (type == SVt_PVCV && pnext_op && (*pnext_op)->op_type == OP_ENTERSUB) 1086 lookup_flags |= ignore_methods; 1087 1088 if ((imp_gv = try_stored_package_gv(aTHX_ var_gv, type, lookup_flags))) { 1089 repair_pp_gv(aTHX_ aMultiDerefItem_ var_gv, imp_gv); 1090 return; 1091 } 1092 1093 lex_imp_ix = get_lex_imp_ix(aTHX); 1094 if (lex_imp_ix > 0 && (imp_gv = try_stored_lexical_gv(aTHX_ var_gv, type, lex_imp_ix))) { 1095 repair_pp_gv(aTHX_ aMultiDerefItem_ var_gv, imp_gv); 1096 return; 1097 } 1098 1099 if (type != SVt_PVCV || 1100 (GvFLAGS(var_gv) & (GVf_ASSUMECV | GVf_IMPORTED_CV)) != GVf_IMPORTED_CV) { 1101 1102 // first try: the package-scope lookup list 1103 if ((imp_gv = lookup_name_in_list(aTHX_ stash, var_gv, varname, varnamelen, type, lookup_flags))) { 1104 repair_pp_gv(aTHX_ aMultiDerefItem_ var_gv, imp_gv); 1105 return; 1106 } 1107 if (pnext_op && lex_imp_ix>0) { 1108 // second try: the lexical scope lookup list 1109 if ((imp_gv = lookup_var(aTHX_ (HV*)SvRV(AvARRAY(lexical_imports)[lex_imp_ix]), 1110 varname, varnamelen, type, lookup_flags).first)) { 1111 store_lexical_gv(aTHX_ var_gv, imp_gv, lex_imp_ix); 1112 repair_pp_gv(aTHX_ aMultiDerefItem_ var_gv, imp_gv); 1113 return; 1114 } 1115 } 1116 } 1117 1118 if (pnext_op) { 1119 // Nothing found: time to croak 1120 // For subs, pp_entersub will raise an exception with an appropriate message 1121 if (type != SVt_PVCV) 1122 *pnext_op = die("reference to an undeclared variable %c%.*s at %s line %d.\n", 1123 type==SVt_PV ? '$' : type==SVt_PVAV ? '@' : '%', 1124 (int)varnamelen, varname, CopFILE(PL_curcop), (int)CopLINE(PL_curcop)); 1125 } 1126 1127 } else { 1128 // full qualified, but undeclared 1129 // check for exceptions 1130 switch (type) { 1131 case SVt_PVAV: 1132 // allow to refer to the ISA array of a defined package 1133 if (varnamelen == 3 && varname[0] == 'I' && varname[1] == 'S' && varname[2] == 'A') 1134 return; 1135 1136 case SVt_PVHV: 1137 // allow to refer to the symbol table of a defined package 1138 if (varnamelen >= 3 && varname[varnamelen-2] == ':' && varname[varnamelen-1] == ':' 1139 && GvHV(var_gv) && HvNAME(GvHV(var_gv))) 1140 return; 1141 break; 1142 1143 case SVt_PVCV: 1144 // argument-dependent lookup 1145 if (stash == args_lookup_stash && pnext_op) { 1146 dSP; 1147 SV** args = PL_stack_base+TOPMARK; 1148 while (++args < SP) { 1149 SV* arg = *args; 1150 if (SvROK(arg) && (arg = SvRV(arg), SvOBJECT(arg)) && 1151 (imp_gv = lookup_var(aTHX_ SvSTASH(arg), varname, varnamelen, type, 1152 ignore_methods | ignore_undefined | dont_cache).first)) { 1153 SETs((SV*)imp_gv); 1154 PL_op->op_ppaddr = &intercept_pp_gv; 1155 return; 1156 } 1157 } 1158 } 1159 break; 1160 } 1161 1162 HV* cur_stash = CopSTASH(PL_curcop); 1163 lex_imp_ix = get_lex_imp_ix(aTHX); 1164 HV* other_stash = namespace_lookup_class_autoload(aTHX_ cur_stash, HvNAME(stash), HvNAMELEN(stash), lex_imp_ix); 1165 if (other_stash) { 1166 if (other_stash == stash) { 1167 MAGIC* mg = mg_find((SV*)var_gv, PERL_MAGIC_ext); 1168 if (mg && (imp_gv = (GV*)mg->mg_obj) && 1169 (imp_gv = test_imported_gv(aTHX_ imp_gv, type, ignore_undefined))) { 1170 repair_pp_gv(aTHX_ aMultiDerefItem_ var_gv, imp_gv); 1171 return; 1172 } 1173 } else if ((imp_gv = lookup_var(aTHX_ other_stash, varname, varnamelen, type, ignore_undefined).first)) { 1174 repair_pp_gv(aTHX_ aMultiDerefItem_ var_gv, imp_gv); 1175 return; 1176 } 1177 } 1178 1179 if (type != SVt_PVCV && 1180 (hv_exists_ent(stash, dot_import_key, SvSHARED_HASH(dot_import_key)) || 1181 is_dummy_pkg(aTHX_ stash))) { 1182 // complain now if the addressed package is compiled with namespace mode 1183 // and we are not looking for a subroutine, because pp_entersub will raise an exception with an appropriate message 1184 *pnext_op = die("reference to an undeclared variable %c%.*s::%.*s at %s line %d.\n", 1185 type == SVt_PV ? '$' : type == SVt_PVAV ? '@' : '%', 1186 PmPrintHvNAME(stash), (int)varnamelen, varname, CopFILE(PL_curcop), (int)CopLINE(PL_curcop)); 1187 } 1188 } 1189 } 1190} 1191 1192void resolve_scalar_gv(pTHX_ pMultiDerefItem_ GV* var_gv, OP** pnext_op, OP* access_op) 1193{ 1194 if (!GvIMPORTED_SV(var_gv)) { 1195 const char* name; 1196 if (GvNAMELEN(var_gv) == 8) { 1197 name = GvNAME(var_gv); 1198 if (*name == 'A' && !strncmp(name, "AUTOLOAD", 8) && GvCV(var_gv)) { 1199 // $AUTOLOAD must not be predeclared if there is sub AUTOLOAD too 1200 GvIMPORTED_SV_on(var_gv); 1201 return; 1202 } 1203 } else if (GvNAMELEN(var_gv) == 1 && PL_curstackinfo->si_type == PERLSI_SORT) { 1204 name = GvNAME(var_gv); 1205 if (*name == 'a' || *name == 'b') 1206 // sort sub placeholders must not be predeclared 1207 return; 1208 } 1209 lookup(aTHX_ aMultiDerefItem_ var_gv, SVt_PV, pnext_op, access_op); 1210 } 1211} 1212 1213void resolve_array_gv(pTHX_ pMultiDerefItem_ GV* var_gv, OP** pnext_op, OP* access_op) 1214{ 1215 if (!GvIMPORTED_AV(var_gv)) { 1216 const char* name; 1217 if (GvNAMELEN(var_gv) == 3) { 1218 name = GvNAME(var_gv); 1219 if (name[0] == 'I' && name[1] == 'S' && name[2] == 'A' && CopSTASH_eq(PL_curcop, GvSTASH(var_gv))) { 1220 // @ISA must not be predeclared 1221 GvIMPORTED_AV_on(var_gv); 1222 return; 1223 } 1224 } 1225 lookup(aTHX_ aMultiDerefItem_ var_gv, SVt_PVAV, pnext_op, access_op); 1226 } 1227} 1228 1229void resolve_hash_gv(pTHX_ pMultiDerefItem_ GV* var_gv, OP** pnext_op, OP* access_op) 1230{ 1231 if (!GvIMPORTED_HV(var_gv)) { 1232 const char* name = GvNAME(var_gv); 1233 STRLEN namelen = GvNAMELEN(var_gv); 1234 if (namelen > 2 && name[namelen-1] == ':' && name[namelen-2] == ':') { 1235 HV* stash = GvHV(var_gv); 1236 if (stash && HvNAME(stash)) { 1237 // nested package stashes must not be predeclared 1238 GvIMPORTED_HV_on(var_gv); 1239 return; 1240 } 1241 } 1242 lookup(aTHX_ aMultiDerefItem_ var_gv, SVt_PVHV, pnext_op, access_op); 1243 } 1244} 1245 1246OP* intercept_pp_gv(pTHX) 1247{ 1248 OP* next_op = def_pp_GV(aTHX); 1249 OP* orig_next_op = next_op; 1250 dSP; 1251 GV* var_gv = (GV*)TOPs; 1252 OP* this_op = PL_op; 1253 int next_op_type = next_op->op_type; 1254 if (next_op_type == OP_RV2GV 1255 && next_op->op_next->op_ppaddr == ops::local_ref) { 1256 // localizing via glob 1257 SV* right = SP[-1]; 1258 if (SvROK(right)) { 1259 switch (SvTYPE(SvRV(right))) { 1260 case SVt_PVAV: 1261 next_op_type = OP_RV2AV; 1262 break; 1263 case SVt_PVHV: 1264 next_op_type = OP_RV2HV; 1265 break; 1266 case SVt_PVCV: 1267 next_op_type = OP_RV2CV; 1268 break; 1269 default: 1270 break; 1271 } 1272 } 1273 } 1274 switch (next_op_type) { 1275 case OP_RV2SV: 1276 resolve_scalar_gv(aTHX_ nullMultiDerefItem_ var_gv, &next_op, next_op); 1277 if (next_op == orig_next_op && this_op->op_ppaddr == &intercept_pp_gv) // not died 1278 this_op->op_ppaddr = def_pp_GV; 1279 break; 1280 case OP_RV2AV: 1281 resolve_array_gv(aTHX_ nullMultiDerefItem_ var_gv, &next_op, next_op); 1282 if (next_op == orig_next_op && this_op->op_ppaddr == &intercept_pp_gv) // not died 1283 this_op->op_ppaddr = def_pp_GV; 1284 break; 1285 case OP_RV2HV: 1286 resolve_hash_gv(aTHX_ nullMultiDerefItem_ var_gv, &next_op, next_op); 1287 if (next_op == orig_next_op && this_op->op_ppaddr == &intercept_pp_gv) // not died 1288 this_op->op_ppaddr = def_pp_GV; 1289 break; 1290 case OP_RV2CV: 1291 case OP_ENTERSUB: 1292 this_op->op_ppaddr = def_pp_GV; // lookup() never dies on unknown CVs 1293#if PerlVersion >= 5220 1294 if (SvROK(var_gv)) break; 1295#endif 1296 if (CV* cv = GvCV(var_gv)) { 1297 if (is_well_defined_sub(cv)) 1298 break; 1299 if (next_op->op_type == OP_RV2CV && 1300 next_op->op_next->op_type != OP_REFGEN && 1301 next_op->op_next->op_type != OP_SREFGEN) 1302 break; 1303 } 1304 lookup(aTHX_ nullMultiDerefItem_ var_gv, SVt_PVCV, &next_op, nullptr); 1305 break; 1306 } 1307 return next_op; 1308} 1309 1310OP* intercept_pp_gvsv(pTHX) 1311{ 1312 GV* var_gv=cGVOP_gv; 1313 OP* this_op=PL_op; 1314 OP* next_op=this_op; 1315 resolve_scalar_gv(aTHX_ nullMultiDerefItem_ var_gv, &next_op, next_op); 1316 if (next_op == this_op && this_op->op_ppaddr == &intercept_pp_gvsv) // not died 1317 this_op->op_ppaddr=def_pp_GVSV; 1318 return next_op; 1319} 1320 1321OP* intercept_pp_aelemfast(pTHX) 1322{ 1323 OP* this_op=PL_op; 1324 OP* next_op=this_op; 1325 if (next_op->op_type != OP_AELEMFAST_LEX) 1326 resolve_array_gv(aTHX_ nullMultiDerefItem_ cGVOP_gv, &next_op, nullptr); 1327 if (next_op == this_op && this_op->op_ppaddr == &intercept_pp_aelemfast) // not died 1328 this_op->op_ppaddr=def_pp_AELEMFAST; 1329 return next_op; 1330} 1331 1332OP* intercept_pp_split(pTHX) 1333{ 1334 PMOP* pushre; 1335 GV* var_gv=nullptr; 1336 OP* this_op=PL_op; 1337 OP* next_op=this_op; 1338#if PerlVersion >= 5256 1339 if ((this_op->op_private & (OPpSPLIT_ASSIGN | OPpSPLIT_LEX)) == OPpSPLIT_ASSIGN 1340 && !(this_op->op_flags & OPf_STACKED)) { 1341 pushre=cPMOPx(this_op); 1342# ifdef USE_ITHREADS 1343 var_gv=(GV*)PAD_SVl(pushre->op_pmreplrootu.op_pmtargetoff); 1344# else 1345 var_gv=pushre->op_pmreplrootu.op_pmtargetgv; 1346# endif 1347 } 1348#else // PerlVersion <= 5256 1349 pushre=cPMOPx(cUNOP->op_first); 1350# ifdef USE_ITHREADS 1351 if (pushre->op_pmreplrootu.op_pmtargetoff) { 1352 var_gv=(GV*)PAD_SVl(pushre->op_pmreplrootu.op_pmtargetoff); 1353 } 1354# else 1355 if (pushre->op_pmreplrootu.op_pmtargetgv) { 1356 var_gv=pushre->op_pmreplrootu.op_pmtargetgv; 1357 } 1358# endif 1359#endif 1360 if (var_gv && !GvIMPORTED_AV(var_gv)) 1361 lookup(aTHX_ nullMultiDerefItem_ var_gv, SVt_PVAV, &next_op, next_op); 1362 if (next_op == this_op && this_op->op_ppaddr == &intercept_pp_split) // not died 1363 this_op->op_ppaddr=def_pp_SPLIT; 1364 return next_op; 1365} 1366 1367// Locate the NEXTSTATE op following the statement in the caller that calls the current sub. 1368std::pair<OP*, PERL_CONTEXT*> next_statement_in_caller(pTHX) 1369{ 1370 OP* op_next_state = nullptr; 1371 PERL_CONTEXT *cx_bottom = cxstack, *cx = cx_bottom + cxstack_ix; 1372 for (; cx > cx_bottom; --cx) { 1373 if (CxTYPE(cx) == CXt_SUB && !skip_debug_frame(aTHX_ cx)) { 1374 op_next_state = (OP*)cx->blk_oldcop; 1375 break; 1376 } 1377 } 1378 // op_next_state => NEXTSTATE op initiating the statement where the current sub is called. 1379 if (op_next_state) { 1380 while ((op_next_state = OpSIBLING(op_next_state)) && op_next_state->op_type != OP_NEXTSTATE && op_next_state->op_type != OP_DBSTATE) ; 1381 } 1382 return std::make_pair(op_next_state, cx); 1383} 1384 1385// Return to the next full statement following the call; assuming that the call is made from a `return' expression. 1386OP* pp_fall_off_to_nextstate(pTHX) 1387{ 1388 PERL_CONTEXT* cx; 1389 OP* op_next_state; 1390 std::tie(op_next_state, cx) = next_statement_in_caller(aTHX); 1391 OP* ret = def_pp_LEAVESUB(aTHX); 1392 if (op_next_state) { 1393 if (skip_debug_cx) { 1394 op_next_state->op_ppaddr = &pp_popmark_and_nextstate; 1395 cx->blk_sub.retop = op_next_state; 1396 } else { 1397 (void)POPMARK; // discard the MARK created for the return statement in the caller 1398 ret = op_next_state; 1399 } 1400 } 1401 return ret; 1402} 1403 1404void check_explicit_pkg(pTHX_ GV* gv) 1405{ 1406 HV* stash = GvSTASH(gv); 1407 if (stash && stash != PL_curstash && stash != PL_defstash && HvTOTALKEYS(stash) == 1) 1408 set_dotDUMMY_PKG(aTHX_ stash); 1409} 1410 1411void check_explicit_pkg_in_kid(pTHX_ OP* o) 1412{ 1413 if (o->op_flags & OPf_KIDS) { 1414 o=cUNOPo->op_first; 1415 if (o->op_type == OP_GV) 1416 check_explicit_pkg(aTHX_ cGVOPo_gv); 1417 } 1418} 1419 1420OP* intercept_ck_gv(pTHX_ OP* o) 1421{ 1422 o=def_ck_GV(aTHX_ o); 1423 check_explicit_pkg(aTHX_ cGVOPo_gv); 1424 return o; 1425} 1426 1427OP* intercept_ck_rv2sv(pTHX_ OP* o) 1428{ 1429 o=def_ck_RV2SV(aTHX_ o); 1430 check_explicit_pkg_in_kid(aTHX_ o); 1431 return o; 1432} 1433 1434OP* intercept_ck_rv2av(pTHX_ OP* o) 1435{ 1436 o=def_ck_RV2AV(aTHX_ o); 1437 check_explicit_pkg_in_kid(aTHX_ o); 1438 return o; 1439} 1440 1441OP* intercept_ck_rv2hv(pTHX_ OP* o) 1442{ 1443 o=def_ck_RV2HV(aTHX_ o); 1444 check_explicit_pkg_in_kid(aTHX_ o); 1445 return o; 1446} 1447 1448AV* find_intercepted_op_descriptor(pTHX_ int opcode) 1449{ 1450 AV* dotSUBST_OP = get_cur_dotSUBST_OP(aTHX); 1451 if (dotSUBST_OP) { 1452 for (SV **descrp = AvARRAY(dotSUBST_OP), **last = descrp+AvFILLp(dotSUBST_OP); descrp <= last; ++descrp) { 1453 AV* op_descr = (AV*)SvRV(*descrp); 1454 if (SvIVX(AvARRAY(op_descr)[intercept_op_code]) == opcode) 1455 return op_descr; 1456 } 1457 } 1458 return nullptr; 1459} 1460 1461OP* pp_assign_ro(pTHX) 1462{ 1463 OP* next=def_pp_SASSIGN(aTHX); 1464 dSP; 1465 SvREADONLY_on(TOPs); 1466 return next; 1467} 1468 1469OP* store_in_state_var(pTHX_ OP* what) 1470{ 1471 OP* store_op=newOP(OP_PADSV, (OPpPAD_STATE | OPpLVAL_INTRO) << 8); 1472 store_op->op_targ=pad_add_name_pvn("", 0, padadd_STATE | padadd_NO_DUP_CHECK, nullptr, nullptr); 1473 OP* o=newASSIGNOP(0, store_op, 0, what); 1474 // protect the assigned value from inadvertent changes 1475 // the assignment op is buried below a null op and a conditional op created automatically in newASSIGNOP 1476 OP* assign=OpSIBLING(cLOGOPx(cUNOPo->op_first)->op_first); 1477 assert(assign && assign->op_type == OP_SASSIGN); 1478 assign->op_ppaddr=&pp_assign_ro; 1479 return o; 1480} 1481 1482OP* construct_const_creation_optree(pTHX_ AV* op_descr, OP* o, bool cache_result) 1483{ 1484 SV* sub_ref = AvARRAY(op_descr)[intercept_op_subref]; 1485 SV* add_arg = AvARRAY(op_descr)[intercept_op_addarg]; 1486 OP* list_op = op_append_elem(OP_LIST, o, Perl_newSVOP(aTHX_ OP_CONST, 0, SvREFCNT_inc_simple_NN(sub_ref))); 1487 if (add_arg != PmEmptyArraySlot) 1488 op_prepend_elem(OP_LIST, Perl_newSVOP(aTHX_ OP_CONST, 0, SvREFCNT_inc_simple_NN(add_arg)), list_op); 1489 PL_check[OP_ENTERSUB] = def_ck_ENTERSUB; 1490 o = Perl_op_convert_list(aTHX_ OP_ENTERSUB, OPf_STACKED, list_op); 1491 PL_check[OP_ENTERSUB] = &intercept_ck_sub; 1492 if (cache_result) { 1493 o = store_in_state_var(aTHX_ o); 1494 assert(o->op_type == OP_NULL && cUNOPo->op_first->op_type == OP_ONCE && o->op_private == 1); 1495 o->op_private = 4; 1496 } 1497 return o; 1498} 1499 1500bool is_creating_constant(OP* o) 1501{ 1502 return o->op_type==OP_NULL && cUNOPo->op_first->op_type==OP_ONCE && o->op_private==4; 1503} 1504 1505SV* get_constant_creation_input(OP* o) 1506{ 1507 o = OpSIBLING(cLOGOPx(cUNOPo->op_first)->op_other); 1508 return cSVOPo->op_sv; 1509} 1510 1511const char* looks_like_bigint(SV* sv, const char* buf) 1512{ 1513 while (isSPACE(*buf)) ++buf; 1514 const bool negative = *buf == '-'; 1515 if (negative || *buf == '+') ++buf; 1516 if (!isDIGIT(*buf)) 1517 // slipped off the line end - no chance to reconstruct the number, 1518 // otherwise it's not an integral number and hence not interesting as well 1519 return nullptr; 1520 1521 // check for integer overflow as well 1522 if (SvIOK(sv) && (SvIVX(sv) == 0 || (SvIVX(sv) < 0) == negative)) 1523 return nullptr; 1524 1525 do ++buf; while (isDIGIT(*buf)); 1526 // no conversion for hexadecimal numbers and floating-point numbers 1527 return strchr(".eExX", *buf) ? nullptr : buf; 1528} 1529 1530OP* intercept_ck_const(pTHX_ OP* o) 1531{ 1532 if (PL_curcop == &PL_compiling && !PL_parser->lex_inwhat) { 1533 SV* sv = cSVOPo->op_sv; 1534 const char* buf=PL_parser->bufptr; 1535 const char* buf_end; 1536 if (buf && SvPOKp(sv) && buf[0] == 'p' && !strncmp(buf, "package ", 8)) { 1537 char* p=SvPVX(sv); 1538 if (p[0]=='_') { 1539 const STRLEN pl = SvCUR(sv); 1540 if (pl > 3 && p[1]==':' && p[2]==':') { 1541 // subpackage of the current package 1542 const STRLEN cur_pkg_len = SvCUR(PL_curstname); 1543 SvPV_set(sv, (char*)safemalloc(pl + cur_pkg_len)); 1544 SvCUR_set(sv, 0); 1545 SvLEN_set(sv, pl + cur_pkg_len); 1546 sv_setsv(sv, PL_curstname); 1547 sv_catpvn(sv, p+1, pl-1); 1548 safefree(p); 1549 } 1550 } 1551 HV* stash = gv_stashsv(sv, GV_ADD); 1552 if (stash != PL_defstash && stash != PL_debstash) { 1553 GV* imp_gv = get_dotIMPORT_GV(aTHX_ stash); 1554 SV* imp_sv = GvSV(imp_gv); 1555 if (imp_sv && SvIOKp(imp_sv)) { 1556 // the re-entered package already memorized its lexical import scope: must merge both together 1557 const int new_lex_ix = merge_lexical_import_scopes(aTHX_ int(SvIV(GvSV(imp_gv))), cur_lexical_import_ix); 1558 if (new_lex_ix != cur_lexical_import_ix) { 1559 SAVEINT(cur_lexical_import_ix); 1560 establish_lex_imp_ix(aTHX_ new_lex_ix, TRUE); 1561 } 1562 } 1563 } 1564 } 1565 else if (buf && buf == PL_parser->oldbufptr && (SvFLAGS(sv) & (SVf_IOK | SVf_NOK)) && (buf_end = looks_like_bigint(sv, buf)) != nullptr) { 1566 AV* op_descr = find_intercepted_op_descriptor(aTHX_ 'I' + ('N'<<8) + ('T'<<16)); 1567 if (op_descr) { 1568 SvREADONLY_off(sv); 1569 const STRLEN l = buf_end-buf; 1570 SvUPGRADE(sv, SVt_PV); 1571 SvGROW(sv, l+2); 1572 sv_setpvn(sv, buf, l); 1573 SvREADONLY_on(sv); 1574 return construct_const_creation_optree(aTHX_ op_descr, o, true); 1575 } 1576 } 1577 } 1578 return def_ck_CONST(aTHX_ o); 1579} 1580 1581OP* intercept_ck_divide(pTHX_ OP* o) 1582{ 1583 OP* a = cBINOPo->op_first; 1584 OP* b = OpSIBLING(a); 1585 if (( (a->op_type == OP_CONST && SvIOK(cSVOPx_sv(a))) || is_creating_constant(a) ) 1586 && 1587 ( (b->op_type == OP_CONST && SvIOK(cSVOPx_sv(b))) || is_creating_constant(b) )) { 1588 AV* op_descr = find_intercepted_op_descriptor(aTHX_ o->op_type); 1589 if (op_descr) { 1590 OP* new_op = construct_const_creation_optree(aTHX_ op_descr, op_prepend_elem(OP_LIST, a, b), true); 1591 clear_bit_flags(o->op_flags, OPf_KIDS); 1592 FreeOp(o); 1593 return new_op; 1594 } 1595 } 1596 return o; 1597} 1598 1599OP* intercept_ck_negate(pTHX_ OP* o) 1600{ 1601 OP* a = cUNOPo->op_first; 1602 if (is_creating_constant(a)) { 1603 SV* sv = get_constant_creation_input(a); 1604 SvREADONLY_off(sv); 1605 STRLEN l; 1606 char* str = SvPV(sv, l); 1607 SvCUR_set(sv, l+1); 1608 Move(str, str+1, l+1, char); 1609 *str = '-'; 1610 SvREADONLY_on(sv); 1611 clear_bit_flags(o->op_flags, OPf_KIDS); 1612 FreeOp(o); 1613 return a; 1614 } 1615 return o; 1616} 1617 1618OP* intercept_ck_anonlist(pTHX_ OP* o) 1619{ 1620 OP* a = cUNOPo->op_first; 1621 if (a->op_type == OP_ANONLIST && (a->op_flags & OPf_SPECIAL)) { 1622 AV* op_descr = find_intercepted_op_descriptor(aTHX_ o->op_type); 1623 if (op_descr) { 1624 OP* new_op = construct_const_creation_optree(aTHX_ op_descr, a, false); 1625 clear_bit_flags(o->op_flags, OPf_KIDS); 1626 FreeOp(o); 1627 o = new_op; 1628 } 1629 } 1630 return o; 1631} 1632 1633OP* pp_print_bool(pTHX) 1634{ 1635 dSP; 1636 SV** args = PL_stack_base+TOPMARK; 1637 while (++args <= SP) { 1638 if (is_boolean_value(aTHX_ *args)) { 1639 *args=get_boolean_string(*args); 1640 } 1641 } 1642 return def_pp_PRINT(aTHX); 1643} 1644 1645OP* intercept_ck_print(pTHX_ OP* o) 1646{ 1647 o = def_ck_PRINT(aTHX_ o); 1648 o->op_ppaddr = &pp_print_bool; 1649 return o; 1650} 1651 1652OP* intercept_ck_system(pTHX_ OP* o) 1653{ 1654 if (AV* op_descr = find_intercepted_op_descriptor(aTHX_ OP_SYSTEM)) { 1655 // convert system() to a subroutine call with the same arguments 1656 SV* sub_ref = AvARRAY(op_descr)[intercept_op_subref]; 1657 o->op_type = OP_LIST; 1658 o = op_append_elem(OP_LIST, o, Perl_newSVOP(aTHX_ OP_CONST, 0, SvREFCNT_inc_simple_NN(sub_ref))); 1659 PL_check[OP_ENTERSUB] = def_ck_ENTERSUB; 1660 o = Perl_op_convert_list(aTHX_ OP_ENTERSUB, OPf_STACKED, o); 1661 PL_check[OP_ENTERSUB] = &intercept_ck_sub; 1662 } else { 1663 o = def_ck_SYSTEM(aTHX_ o); 1664 } 1665 return o; 1666} 1667 1668OP* inject_switch_op(pTHX_ OP* o, int flags) 1669{ 1670 OP* sw_op=newOP(OP_CUSTOM, flags); 1671 sw_op->op_ppaddr=&switch_off_namespaces; 1672 cUNOPo->op_first=op_prepend_elem(OP_LINESEQ, sw_op, cUNOPo->op_first); 1673 return sw_op; 1674} 1675 1676OP* intercept_ck_leaveeval(pTHX_ OP* o) 1677{ 1678 inject_switch_op(aTHX_ o, OPf_SPECIAL); 1679 return def_ck_LEAVEEVAL(aTHX_ o); 1680} 1681 1682OP* intercept_pp_leavesub(pTHX) 1683{ 1684 catch_ptrs(aTHX_ active_begin); 1685 return def_pp_LEAVESUB(aTHX); 1686} 1687 1688MAGIC* fetch_explicit_typelist_magic(pTHX_ SV* args) 1689{ 1690 return mg_findext(args, PERL_MAGIC_ext, &explicit_typelist_vtbl); 1691} 1692 1693OP* fetch_sub_scope_type_param(pTHX) 1694{ 1695 dSP; 1696 MAGIC* mg=fetch_explicit_typelist_magic(aTHX_ (SV*)GvAV(PL_defgv)); 1697 assert(mg); 1698 AV* typelist=(AV*)SvRV(mg->mg_obj); 1699 assert(SvTYPE(typelist)==SVt_PVAV && PL_op->op_private <= AvFILLp(typelist)); 1700 XPUSHs(AvARRAY(typelist)[PL_op->op_private]); 1701 RETURN; 1702} 1703 1704OP* fetch_sub_scope_type_param_via_lex(pTHX) 1705{ 1706 dSP; 1707 SV* typelist_ref = PAD_SVl(PL_op->op_targ); 1708 assert(SvROK(typelist_ref)); 1709 AV* typelist = (AV*)SvRV(typelist_ref); 1710 assert(SvTYPE(typelist) == SVt_PVAV); 1711 // this is used in final typecheck routines, where some type parameters may be not deduced yet 1712 XPUSHs(*av_fetch(typelist, PL_op->op_private, TRUE)); 1713 RETURN; 1714} 1715 1716OP* pp_resolve_pkg(pTHX) 1717{ 1718 OP* o = PL_op; 1719 SV* pkg = cSVOPo_sv; 1720 GV* io_gv; 1721 IO* io_sv; 1722 1723 if (HV* stash = namespace_lookup_class_autoload(aTHX_ CopSTASH(PL_curcop), SvPVX(pkg), SvCUR(pkg), get_lex_imp_ix(aTHX))) { 1724 const STRLEN full_len = HvNAMELEN(stash); 1725 if (SvCUR(pkg) != full_len) { 1726 SvREFCNT_dec(pkg); 1727 pkg = newSVpvn_share(HvNAME(stash), I32(full_len), 0); 1728 *cSVOPx_svp(o) = pkg; 1729 } 1730 } else if (PL_op->op_private && 1731 // maybe a file handle method? 1732 (io_gv = gv_fetchsv(pkg, GV_NOADD_NOINIT, SVt_PVIO)) && 1733 (io_sv = GvIOp(io_gv)) && 1734 (IoIFP(io_sv) || IoOFP(io_sv))) { 1735 SvREFCNT_dec(pkg); 1736 pkg = newRV((SV*)io_gv); 1737 *cSVOPx_svp(o) = pkg; 1738 } else { 1739 DIE(aTHX_ "Package \"%.*s\" does not exist", (int)SvCUR(pkg), SvPVX(pkg)); 1740 } 1741 1742 dSP; 1743 XPUSHs(pkg); 1744 o->op_ppaddr = &Perl_pp_const; 1745 RETURN; 1746} 1747 1748OP* pp_retrieve_pkg(pTHX) 1749{ 1750 dSP; 1751 SV* sv=TOPs; 1752 if (SvROK(sv) && (sv=SvRV(sv), SvRMAGICAL(sv)) && (sv=retrieve_pkg(aTHX_ sv))) 1753 SETs(sv); 1754 else 1755 DIE(aTHX_ "non-type value substituted for a type parameter"); 1756 RETURN; 1757} 1758 1759OP* pp_instance_of(pTHX) 1760{ 1761 dSP; 1762 SV* sv=POPs; 1763 SV* pkg=TOPs; 1764 PUTBACK; 1765 HV* stash; 1766 if (SvPOK(pkg)) { 1767 stash=get_cached_stash(aTHX_ pkg); 1768 if (!stash) { 1769 DIE(aTHX_ "Package \"%.*s\" does not exist", (int)SvCUR(pkg), SvPVX(pkg)); 1770 } 1771 } else { 1772 DIE(aTHX_ "internal error in instanceof: package name is not a valid string"); 1773 } 1774 SV* obj; 1775 if (SvROK(sv) && (obj=SvRV(sv), SvOBJECT(obj) && SvSTASH(obj)==stash)) { 1776 SPAGAIN; 1777 SETs(&PL_sv_yes); 1778 } else { 1779 const I32 answer = sv_derived_from_pvn(sv, HvNAME(stash), HvNAMELEN(stash), 0); 1780 SPAGAIN; 1781 SETs(answer ? &PL_sv_yes : &PL_sv_no); 1782 } 1783 return NORMAL; 1784} 1785 1786int find_among_parameter_names(pTHX_ AV* param_names_av, const char* pkg_name, STRLEN pkg_name_len) 1787{ 1788 int name_ix = 0; 1789 for (SV** param_names = AvARRAY(param_names_av), ** const param_names_last = param_names+AvFILLp(param_names_av); 1790 param_names <= param_names_last; ++param_names, ++name_ix) 1791 if (pkg_name_len == SvCUR(*param_names) && !strncmp(pkg_name, SvPVX(*param_names), pkg_name_len)) 1792 return name_ix; 1793 return -1; 1794} 1795 1796OP* fetch_type_param_proto_pvn(pTHX_ const char* pkg_name, STRLEN pkg_name_len) 1797{ 1798 SV* hint_sv; 1799 GV* sub_type_params_gv = nullptr; 1800 if ((hint_sv=Perl_refcounted_he_fetch_sv(aTHX_ PL_compiling.cop_hints_hash, sub_type_params_key, 0, 0)) && 1801 SvIOK(hint_sv)) { 1802 sub_type_params_gv=(GV*)SvUVX(hint_sv); 1803 if (sub_type_params_gv != PL_defgv) { 1804 // it does not refer to @_ 1805 const int name_ix = find_among_parameter_names(aTHX_ type_param_names, pkg_name, pkg_name_len); 1806 if (name_ix >= 0) { 1807 OP* o; 1808 if (sub_type_params_gv) { 1809 if ((size_t)sub_type_params_gv <= 10) { 1810 // The package name found among the subroutine-local parameters. 1811 // At runtime, the prototypes will sit in an array referred by a lexical variable 1812 o=newOP(OP_CUSTOM, 0); 1813 o->op_ppaddr=&fetch_sub_scope_type_param_via_lex; 1814 o->op_targ=(size_t)sub_type_params_gv; 1815 } else { 1816 // The package name found among the placeholders. 1817 o = newGVOP(OP_AELEMFAST, 0, sub_type_params_gv); 1818 o->op_ppaddr = def_pp_AELEMFAST; 1819 } 1820 } else { 1821 // The package name found among the subroutine-local parameters. 1822 // At runtime, the prototypes will sit in an array magically attached to @_. 1823 o = newOP(OP_CUSTOM, 0); 1824 o->op_ppaddr = &fetch_sub_scope_type_param; 1825 } 1826 o->op_private = U8(name_ix); 1827 return o; 1828 } 1829 sub_type_params_gv = nullptr; 1830 } 1831 } 1832 if ((hint_sv = Perl_refcounted_he_fetch_sv(aTHX_ PL_compiling.cop_hints_hash, scope_type_params_key, 0, 0)) && 1833 SvIOK(hint_sv)) { 1834 GV* scope_type_params_gv = (GV*)SvUVX(hint_sv); 1835 const int name_ix = find_among_parameter_names(aTHX_ GvAV(scope_type_params_gv), pkg_name, pkg_name_len); 1836 if (name_ix >= 0) { 1837 // The package name found among the scope parameters. 1838 // At runtime, the prototypes will sit in the array attached to this glob, unless sub_type_params_gv == \*_. 1839 OP* o = newGVOP(OP_AELEMFAST, 0, sub_type_params_gv ? sub_type_params_gv : scope_type_params_gv); 1840 o->op_ppaddr = def_pp_AELEMFAST; 1841 o->op_private = U8(name_ix); 1842 // mark for modification in intercept_ck_leavesub 1843 if (!CvUNIQUE(PL_compcv) && !sub_type_params_gv) CvDEPTH(PL_compcv)=1; 1844 return o; 1845 } 1846 } 1847 return nullptr; 1848} 1849 1850OP* fetch_type_param_proto_sv(pTHX_ SV* pkg_name_sv) 1851{ 1852 return fetch_type_param_proto_pvn(aTHX_ SvPVX(pkg_name_sv), SvCUR(pkg_name_sv)); 1853} 1854 1855// recognize Type->method() and TypePlaceholder->method() 1856// they are not processed by keyword plugin 1857 1858OP* intercept_ck_sub(pTHX_ OP* o) 1859{ 1860 if (PL_curstash != PL_defstash && 1861 (o->op_flags & (OPf_STACKED | OPf_KIDS)) == (OPf_STACKED | OPf_KIDS)) { 1862 OP* pushmark = cUNOPo->op_first; 1863 if (pushmark->op_type == OP_PUSHMARK) { 1864 OP* const_op = OpSIBLING(pushmark); 1865 if (const_op && const_op->op_type == OP_CONST && (const_op->op_private & OPpCONST_BARE)) { 1866 OP* meth = cLISTOPo->op_last; 1867 if (meth->op_type == OP_METHOD_NAMED) { 1868 OP* fetch_proto = fetch_type_param_proto_sv(aTHX_ cSVOPx_sv(const_op)); 1869 if (fetch_proto) { 1870 // redirect the method call to the package represented by a type proto object 1871 OP* retrieve_pkg = PmNewCustomOP(UNOP, 0, fetch_proto); 1872 retrieve_pkg->op_ppaddr = &pp_retrieve_pkg; 1873#if PerlVersion >= 5220 1874 op_free(op_sibling_splice(o, pushmark, 1, retrieve_pkg)); 1875#else 1876 PmOpCopySibling(retrieve_pkg, const_op); 1877 OpMORESIB_set(pushmark, retrieve_pkg); 1878 op_free(const_op); 1879#endif 1880 } else { 1881 // The name is constant, maybe it's a file handle. It will be resolved at runtime. 1882 assert(cSVOPo_sv); 1883 const_op->op_type = OP_CUSTOM; 1884 const_op->op_ppaddr = &pp_resolve_pkg; 1885 } 1886 } 1887 } 1888 } 1889 } 1890 return def_ck_ENTERSUB(aTHX_ o); 1891} 1892 1893OP* intercept_ck_leavesub(pTHX_ OP* op) 1894{ 1895 CV* cv=PL_compcv; 1896 if (cv && SvTYPE(cv)==SVt_PVCV) { 1897 // it can be a BEGIN sub, prepare for capturing it befre execution 1898 PL_savebegin = 1; 1899 if (!CvSPECIAL(cv) && CvDEPTH(cv)) { 1900 // marked in fetch_type_param_proto_pvn : 1901 // construct a localizing assignment for the outer scope type array, 1902 // the list of concrete types is delivered by a sub attached to the glob holding the type array 1903 SV* hint_sv = Perl_refcounted_he_fetch_sv(aTHX_ PL_compiling.cop_hints_hash, scope_type_params_key, 0, 0); 1904 GV* scope_type_params_gv = (GV*)SvUVX(hint_sv); 1905 OP* o = cUNOPx(op)->op_first; // lineseq? 1906 if (!OpHAS_SIBLING(o)) o = cUNOPo->op_first; 1907 assert(o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE); 1908 OP* gvop1 = newGVOP(OP_GV, 0, scope_type_params_gv); 1909 gvop1->op_ppaddr = def_pp_GV; 1910 OP* gvop2 = newGVOP(OP_GV, 0, scope_type_params_gv); 1911 gvop2->op_ppaddr = def_pp_GV; 1912 PL_check[OP_ENTERSUB] = def_ck_ENTERSUB; 1913 OP* call_typelist_sub = Perl_op_convert_list(aTHX_ OP_ENTERSUB, 0, newLISTOP(OP_LIST, 0, gvop2, nullptr)); 1914 PL_check[OP_ENTERSUB] = intercept_ck_sub; 1915 OP* localize_op = newBINOP(OP_SASSIGN, OPf_STACKED, Perl_scalar(aTHX_ call_typelist_sub), Perl_scalar(aTHX_ gvop1)); 1916 localize_op->op_ppaddr = ops::local_ref; 1917 localize_op->op_flags = U8((localize_op->op_flags & ~OPf_WANT) | OPf_WANT_VOID); 1918 PmOpCopySibling(localize_op, o); 1919 OpMORESIB_set(o, localize_op); 1920 CvDEPTH(cv) = 0; 1921 } 1922 } 1923 return def_ck_LEAVESUB(aTHX_ op); 1924} 1925 1926OP* pp_bless_type_explicit_typelist(pTHX) 1927{ 1928 OP* next=def_pp_ANONLIST(aTHX); 1929 dSP; 1930 SV* list_ref=TOPs; 1931 AV* list=(AV*)SvRV(list_ref); 1932 sv_bless(list_ref, ExplicitTypelist_stash); 1933 for (SV** type_ptr=AvARRAY(list), **type_last=type_ptr+AvFILLp(list); type_ptr <= type_last; ++type_ptr) 1934 SvREADONLY_on(*type_ptr); 1935 return next; 1936} 1937 1938OP* start_type_op_subtree(pTHX_ const char* name, const char* name_end, bool& can_be_cached) 1939{ 1940 const STRLEN name_len = name_end - name; 1941 if ((name_len > 2 && name[0] == ':' && name[1] == ':') || 1942 (name_len > 6 && name[4] == ':' && !strncmp(name, "main::", 6))) { 1943 // absolute package name 1944 OP* const_op=newSVOP(OP_CONST, OPf_WANT_SCALAR, newSVpvn_share(name, I32(name_len), 0)); 1945 const_op->op_ppaddr=&Perl_pp_const; 1946 return newLISTOP(OP_LIST, 0, const_op, nullptr); 1947 } 1948 OP* result = fetch_type_param_proto_pvn(aTHX_ name, name_len); 1949 if (result) { 1950 can_be_cached = false; 1951 } else { 1952 OP* resolve_op = PmNewCustomOP(SVOP, OPf_WANT_SCALAR, newSVpvn(name, I32(name_len))); 1953 resolve_op->op_ppaddr = pp_resolve_pkg; 1954 resolve_op->op_private = 0; 1955 result = newLISTOP(OP_LIST, 0, resolve_op, nullptr); 1956 } 1957 return result; 1958} 1959 1960OP* finalize_type_op_subtree(pTHX_ OP* list_op, AnyString meth) 1961{ 1962 if (list_op->op_type == OP_LIST) { 1963 OP* meth_op = NewMETHOD_NAMED_OP(meth.ptr, I32(meth.len)); 1964 PL_check[OP_ENTERSUB] = def_ck_ENTERSUB; 1965 list_op = Perl_op_convert_list(aTHX_ OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, list_op, meth_op)); 1966 PL_check[OP_ENTERSUB] = &intercept_ck_sub; 1967 } 1968 return list_op; 1969} 1970 1971OP* read_pkg_name(pTHX_ bool& can_be_cached) 1972{ 1973 bool first_letter=true; 1974 char* b; 1975 for (b=PL_parser->bufptr; b < PL_parser->bufend; ++b) 1976 { 1977 if (first_letter ? isIDFIRST(*b) : isALNUM(*b)) { 1978 first_letter=false; 1979 continue; 1980 } 1981 if (*b==':' && b+2 < PL_parser->bufend && b[1]==':') { 1982 ++b; 1983 first_letter=true; 1984 continue; 1985 } 1986 if (first_letter) { 1987 report_parse_error("invalid package name starting at %s", PL_parser->bufptr); 1988 return nullptr; 1989 } 1990 break; 1991 } 1992 1993 OP* o=start_type_op_subtree(aTHX_ PL_parser->bufptr, b, can_be_cached); 1994 lex_read_to(b); 1995 return o; 1996} 1997 1998enum class how_read_spaces { optional, mandatory, optional_but_tell }; 1999 2000bool read_spaces(pTHX_ how_read_spaces how = how_read_spaces::optional) 2001{ 2002 if (how != how_read_spaces::optional) { 2003 const STRLEN oldpos = PL_parser->bufptr - PL_parser->linestart; 2004 lex_read_space(how == how_read_spaces::optional_but_tell ? LEX_KEEP_PREVIOUS : 0); 2005 if (PL_parser->bufptr == PL_parser->linestart + oldpos) { 2006 if (how == how_read_spaces::mandatory) 2007 report_parse_error("missing spaces"); 2008 return false; 2009 } 2010 } else { 2011 lex_read_space(0); 2012 } 2013 if (PL_parser->bufptr == PL_parser->bufend) { 2014 report_parse_error("premature end of file"); 2015 return false; 2016 } 2017 return true; 2018} 2019 2020/* Translate a string like "NAME1, NAME2<PARAM,...>, ... " 2021 * into an op sequence representing the expression NAME1->typeof, NAME2->typeof(PARAM->typeof,...), ... 2022 * recursively applying the transformation to each parameter. 2023 * When compiling a parameterized function or a method of a parameterized object type, 2024 * names occurring in the current parameter lists are replaced with direct references to the array holding them. 2025 * @param[in,out] outer_list_op a LISTOP to append the generated OPs to. On the topmost level it's nullptr 2026 * @param[out] can_be_cached set to false if at least one type parameter is inherited from the scope or is an interpolated variable 2027 * @return OP_LIST or a single type OP_CONST 2028 */ 2029OP* parse_type_expression(pTHX_ OP* outer_list_op, bool& can_be_cached) 2030{ 2031 while (true) { 2032 op_keeper<OP> o(aTHX_ nullptr); 2033 2034 char c = *PL_parser->bufptr; 2035 if (outer_list_op && (c == '$' || c == '@')) { 2036 // two adjacent closing angle brackets confuse the perl parser, it misinterprets them as a right shift operator 2037 char* right_angle_bracket = strchr(PL_parser->bufptr+1, '>'); 2038 if (right_angle_bracket) { 2039 if (right_angle_bracket[1] == '>') 2040 *right_angle_bracket = ';'; 2041 else 2042 right_angle_bracket=nullptr; 2043 } 2044 o = parse_arithexpr(0); 2045 if (right_angle_bracket) 2046 *right_angle_bracket = '>'; 2047 can_be_cached=false; 2048 } else if (!(o=read_pkg_name(aTHX_ can_be_cached))) { 2049 break; 2050 } 2051 if (!read_spaces(aTHX)) 2052 break; 2053 if (*PL_parser->bufptr == '<') { 2054 if (o->op_type != OP_LIST) { 2055 report_parse_error("variable types and placeholders can't be parameterized"); 2056 break; 2057 } 2058 lex_read_to(PL_parser->bufptr+1); 2059 if (!read_spaces(aTHX)) 2060 break; 2061 if (*PL_parser->bufptr == '>') { 2062 // empty brackets 2063 lex_read_to(PL_parser->bufptr+1); 2064 } else { 2065 // this will consume the trailing '>' 2066 if (!parse_type_expression(aTHX_ o, can_be_cached)) 2067 break; 2068 } 2069 o = finalize_type_op_subtree(aTHX_ o, "typeof"); 2070 } else if (outer_list_op) { 2071 o = finalize_type_op_subtree(aTHX_ o, "typeof"); 2072 } 2073 if (!outer_list_op) 2074 return o.release(); 2075 op_append_elem(OP_LIST, outer_list_op, o.release()); 2076 2077 c = *PL_parser->bufptr; 2078 if (c == ',' || c == '>') { 2079 lex_read_to(PL_parser->bufptr+1); 2080 if (!read_spaces(aTHX)) 2081 break; 2082 // end of parameter list 2083 if (c == '>') return outer_list_op; 2084 } else { 2085 report_parse_error("invalid type expression starting at %s", PL_parser->bufptr); 2086 break; 2087 } 2088 } 2089 2090 return nullptr; 2091} 2092 2093void strip_off_pushmark(pTHX_ OP* o) 2094{ 2095 assert(cLISTOPo->op_first->op_type == OP_PUSHMARK); 2096#if PerlVersion >= 5220 2097 op_free(op_sibling_splice(o, nullptr, 1, nullptr)); 2098#else 2099 OP* push_op=cLISTOPx(o)->op_first; 2100 OP* next_op=OpSIBLING(push_op); 2101 cLISTOPx(o)->op_first=next_op; 2102 op_free(push_op); 2103#endif 2104} 2105 2106int parse_typeof_kw(pTHX_ OP** op_ptr, AnyString meth_name) 2107{ 2108 if (!read_spaces(aTHX_ how_read_spaces::optional_but_tell) || 2109 *PL_parser->bufptr == '(') 2110 return KEYWORD_PLUGIN_DECLINE; 2111 2112 bool can_be_cached=!CvUNIQUE(PL_compcv); // don't cache in one-off subs like BEGIN 2113 op_keeper<OP> type_op(aTHX_ parse_type_expression(aTHX_ nullptr, can_be_cached)); 2114 if (type_op) { 2115 if (type_op->op_type == OP_LIST && read_spaces(aTHX) && *PL_parser->bufptr == '(') { 2116 // typeof GenericType(params) 2117 lex_read_to(PL_parser->bufptr+1); 2118 op_keeper<OP> expr(aTHX_ parse_listexpr(0)); 2119 if (read_spaces(aTHX) && *PL_parser->bufptr == ')') { 2120 lex_read_to(PL_parser->bufptr+1); 2121 if (expr->op_type == OP_LIST) 2122 strip_off_pushmark(aTHX_ expr); 2123 type_op=op_append_list(OP_LIST, type_op, expr.release()); 2124 can_be_cached=false; 2125 } else { 2126 // parse error in the argument list 2127 return KEYWORD_PLUGIN_DECLINE; 2128 } 2129 } 2130 type_op=finalize_type_op_subtree(aTHX_ type_op, meth_name); 2131 if (can_be_cached) 2132 type_op=store_in_state_var(aTHX_ type_op); 2133 *op_ptr=type_op.release(); 2134 return KEYWORD_PLUGIN_EXPR; 2135 } 2136 return KEYWORD_PLUGIN_DECLINE; 2137} 2138 2139int parse_instanceof_kw(pTHX_ OP** op_ptr) 2140{ 2141 if (!read_spaces(aTHX_ how_read_spaces::mandatory)) 2142 return KEYWORD_PLUGIN_DECLINE; 2143 2144 bool can_be_cached = !CvUNIQUE(PL_compcv); // don't cache in one-off subs like BEGIN 2145 op_keeper<OP> type_op(aTHX_ parse_type_expression(aTHX_ nullptr, can_be_cached)); 2146 if (type_op) { 2147 if (read_spaces(aTHX) && *PL_parser->bufptr == '(') { 2148 lex_read_to(PL_parser->bufptr+1); 2149 op_keeper<OP> expr(aTHX_ parse_termexpr(0)); 2150 if (read_spaces(aTHX) && *PL_parser->bufptr == ')') { 2151 lex_read_to(PL_parser->bufptr+1); 2152 if (type_op->op_type == OP_LIST) { 2153 // a single package or type name without parameters 2154 strip_off_pushmark(aTHX_ type_op); 2155 op_append_elem(OP_LIST, type_op, Perl_scalar(aTHX_ expr.release())); 2156 type_op->op_type = OP_CUSTOM; 2157 } else { 2158 // a type placeholder or a type expression with parameters 2159 if (can_be_cached) 2160 type_op = store_in_state_var(aTHX_ type_op); 2161 type_op = PmNewCustomOP(UNOP, 0, Perl_scalar(aTHX_ type_op)); 2162 type_op->op_ppaddr = &pp_retrieve_pkg; 2163 type_op = PmNewCustomOP(BINOP, OPf_STACKED, Perl_scalar(aTHX_ type_op), Perl_scalar(aTHX_ expr.release())); 2164 } 2165 type_op->op_ppaddr = &pp_instance_of; 2166 *op_ptr = type_op.release(); 2167 return KEYWORD_PLUGIN_EXPR; 2168 } 2169 } 2170 report_parse_error("expected a scalar expression enclosed in parentheses"); 2171 } 2172 return KEYWORD_PLUGIN_DECLINE; 2173} 2174 2175int parse_operation(pTHX_ Perl_ppaddr_t op_func, OP** op_ptr) 2176{ 2177 if (read_spaces(aTHX) && *PL_parser->bufptr == '(') { 2178 lex_read_to(PL_parser->bufptr+1); 2179 op_keeper<OP> expr(aTHX_ parse_termexpr(0)); 2180 if (read_spaces(aTHX) && *PL_parser->bufptr == ')') { 2181 lex_read_to(PL_parser->bufptr+1); 2182 OP* o = PmNewCustomOP(UNOP, 0, Perl_scalar(aTHX_ expr.release())); 2183 o->op_ppaddr = op_func; 2184 *op_ptr = o; 2185 return KEYWORD_PLUGIN_EXPR; 2186 } 2187 } 2188 report_parse_error("expected a scalar expression enclosed in parentheses"); 2189 return KEYWORD_PLUGIN_DECLINE; 2190} 2191 2192int parse_static_method_call(pTHX_ char* kw, STRLEN kw_len, OP** op_ptr) 2193{ 2194 // scan the first word after the keyword; it should be a type expression or a package name 2195 const char* b = PL_parser->bufptr; 2196 const SSize_t start_pos = b - PL_parser->linestart; 2197 while (++b < PL_parser->bufend) { 2198 if (!isALNUM(*b)) { 2199 if (b < PL_parser->bufend+2 && *b == ':' && b[1] == ':') { 2200 b+=2; 2201 if (!isIDFIRST(*b)) 2202 return KEYWORD_PLUGIN_DECLINE; 2203 } else { 2204 break; 2205 } 2206 } 2207 } 2208 const SSize_t end_pos = b - PL_parser->linestart; 2209 const SSize_t next_char_pos = skip_spaces(aTHX_ end_pos); 2210 if (next_char_pos < 0) 2211 return KEYWORD_PLUGIN_DECLINE; 2212 2213 switch (PL_parser->linestart[next_char_pos]) { 2214 case '<': 2215 if (PL_parser->linestart[next_char_pos+1] == '<' || 2216 PL_parser->linestart[next_char_pos+1] == '=') 2217 return KEYWORD_PLUGIN_DECLINE; 2218 // FALLTHROUGH 2219 case '(': 2220 case ')': 2221 case '}': 2222 case ']': 2223 case ',': 2224 case ';': 2225 // We can't check for sure that the first word is a type name, some types can be introduced 2226 // in the same module we are parsing right now. 2227 // Thus we check the opposite, whether the first name is a sub name or a file handle. 2228 // If not, we assume it as a type. 2229 { 2230 const char* first_name = PL_parser->linestart + start_pos; 2231 const I32 first_name_len = I32(end_pos - start_pos); 2232 if (!Perl_keyword(aTHX_ first_name, first_name_len, false)) { 2233 const auto gvs = lookup_sub_gv(aTHX_ PL_curstash, first_name, first_name_len, cur_lexical_import_ix, 2234 bad_filehandle_gv | bad_constant_gv | dont_cache | dont_create_dummy_sub); 2235 if (!gvs.first && !gvs.second) 2236 break; 2237 } 2238 } 2239 // FALLTHROUGH 2240 default: 2241 return KEYWORD_PLUGIN_DECLINE; 2242 } 2243 2244 bool can_be_cached=!CvUNIQUE(PL_compcv); // don't cache in one-off subs like BEGIN 2245 2246 // this must be created before any further parsing, because that overwrites the keyword buffer 2247 op_keeper<OP> meth_op(aTHX_ NewMETHOD_NAMED_OP(kw, I32(kw_len))); 2248 op_keeper<OP> type_op(aTHX_ parse_type_expression(aTHX_ nullptr, can_be_cached)); 2249 if (type_op) { 2250 op_keeper<OP> args(aTHX_ nullptr); 2251 if (read_spaces(aTHX) && *PL_parser->bufptr == '(') { 2252 // METHOD TYPE(args) 2253 lex_read_to(PL_parser->bufptr+1); 2254 if (read_spaces(aTHX) && *PL_parser->bufptr == ')') { 2255 // ignore an empty argument list 2256 lex_read_to(PL_parser->bufptr+1); 2257 } else { 2258 args = parse_listexpr(0); 2259 if (read_spaces(aTHX) && *PL_parser->bufptr == ')') { 2260 lex_read_to(PL_parser->bufptr+1); 2261 } else { 2262 // parse error in the argument list 2263 return KEYWORD_PLUGIN_DECLINE; 2264 } 2265 } 2266 } 2267 if (type_op->op_type == OP_LIST) { 2268 // accept a file descriptor in lieu of a package name 2269 assert(OpSIBLING(cLISTOPx((OP*)type_op)->op_first)->op_ppaddr == &pp_resolve_pkg); 2270 OpSIBLING(cLISTOPx((OP*)type_op)->op_first)->op_private=1; 2271 if (args) { 2272 if (args->op_type == OP_LIST) 2273 strip_off_pushmark(aTHX_ args); 2274 type_op=op_append_list(OP_LIST, type_op, args.release()); 2275 } 2276 } else { 2277 if (can_be_cached) 2278 type_op=store_in_state_var(aTHX_ type_op); 2279 type_op=PmNewCustomOP(UNOP, 0, type_op); 2280 type_op->op_ppaddr=&pp_retrieve_pkg; 2281 type_op=op_prepend_elem(OP_LIST, type_op, args.release()); 2282 } 2283 PL_check[OP_ENTERSUB]=def_ck_ENTERSUB; 2284 *op_ptr=Perl_op_convert_list(aTHX_ OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, type_op.release(), meth_op.release())); 2285 PL_check[OP_ENTERSUB]=&intercept_ck_sub; 2286 return KEYWORD_PLUGIN_EXPR; 2287 } 2288 2289 return KEYWORD_PLUGIN_DECLINE; 2290} 2291 2292 2293int parse_function_template_call(pTHX_ GV* func_gv, OP** op_ptr) 2294{ 2295 if (!read_spaces(aTHX)) return KEYWORD_PLUGIN_DECLINE; 2296 2297 op_keeper<OP> types(aTHX_ nullptr); 2298 if (*PL_parser->bufptr == '>') { 2299 // ignore an empty type parameter list 2300 lex_read_to(PL_parser->bufptr+1); 2301 } else { 2302 bool can_be_cached=!CvUNIQUE(PL_compcv); 2303 types=newLISTOP(OP_LIST, 0, nullptr, nullptr); 2304 if (!parse_type_expression(aTHX_ types, can_be_cached)) { 2305 return KEYWORD_PLUGIN_DECLINE; 2306 } 2307 types=newANONLIST(types); 2308 types->op_ppaddr=&pp_bless_type_explicit_typelist; 2309 if (can_be_cached) 2310 types=store_in_state_var(aTHX_ types); 2311 } 2312 2313 if (!read_spaces(aTHX)) 2314 return KEYWORD_PLUGIN_DECLINE; 2315 2316 op_keeper<OP> args(aTHX_ nullptr); 2317 if (*PL_parser->bufptr == '(') { 2318 // consume the arguments 2319 lex_read_to(PL_parser->bufptr+1); 2320 if (!read_spaces(aTHX)) 2321 return KEYWORD_PLUGIN_DECLINE; 2322 if (*PL_parser->bufptr != ')') { 2323 args=parse_listexpr(0); 2324 if (!args || !read_spaces(aTHX)) 2325 return KEYWORD_PLUGIN_DECLINE; 2326 } 2327 if (*PL_parser->bufptr == ')') { 2328 lex_read_to(PL_parser->bufptr+1); 2329 } else { 2330 report_parse_error("expected an argument list enclosed in parentheses"); 2331 return KEYWORD_PLUGIN_DECLINE; 2332 } 2333 } 2334 if (args) { 2335 if (types) 2336 args=op_prepend_elem(OP_LIST, types.release(), args); 2337 } else { 2338 args=newLISTOP(OP_LIST, 0, types.release(), nullptr); 2339 } 2340 2341 if (func_gv) { 2342 // non-qualified function name, the entire call processed here 2343 PL_check[OP_ENTERSUB]=def_ck_ENTERSUB; 2344 *op_ptr=Perl_op_convert_list(aTHX_ OP_ENTERSUB, OPf_STACKED, 2345 op_append_elem(OP_LIST, args.release(), newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, func_gv)))); 2346 PL_check[OP_ENTERSUB]=&intercept_ck_sub; 2347 } else { 2348 // (partially) qualified function name, already consumed by perl lexer 2349 *op_ptr=args.release(); 2350 } 2351 2352 return KEYWORD_PLUGIN_EXPR; 2353} 2354 2355 2356void set_import_flag(pTHX_ GV* gv, unsigned int imp_flag, bool allow_redeclare) 2357{ 2358 if (GvSTASH(gv) != CopSTASH(PL_curcop)) 2359 Perl_croak(aTHX_ "declaration of variable %c%.*s::%.*s in package %.*s", 2360 imp_flag==GVf_IMPORTED_SV ? '$' : imp_flag==GVf_IMPORTED_AV ? '@' : '%', PmPrintHvNAME(GvSTASH(gv)), PmPrintGvNAME(gv), PmPrintHvNAME(CopSTASH(PL_curcop))); 2361 if (!allow_redeclare && (GvFLAGS(gv) & imp_flag)) 2362 Perl_croak(aTHX_ "multiple declaration of variable %c%.*s", 2363 imp_flag==GVf_IMPORTED_SV ? '$' : imp_flag==GVf_IMPORTED_AV ? '@' : '%', PmPrintGvNAME(gv)); 2364 GvFLAGS(gv) |= imp_flag; 2365} 2366 2367OP* pp_declare_var(pTHX_ unsigned int imp_flag, unsigned int optype) 2368{ 2369 dSP; 2370 const bool allow_redeclare=get_lex_flags(aTHX) & LexCtxAllowReDeclare; 2371 set_import_flag(aTHX_ (GV*)TOPs, imp_flag, allow_redeclare || (PL_op->op_private & OPpLVAL_INTRO)); 2372 if ((PL_op->op_flags & OPf_WANT) == OPf_WANT_VOID) { 2373 POPs; 2374 PUTBACK; 2375 return NORMAL; 2376 } 2377 if (allow_redeclare) { // the script sub is going to be preserved, so that the op may be re-entered 2378 PL_op->op_ppaddr=PL_ppaddr[optype]; 2379 OP* gvop=cUNOP->op_first; 2380 gvop->op_next=gvop->op_next->op_next; // short-cut the guard op 2381 } 2382 return PL_ppaddr[optype](aTHX); 2383} 2384 2385OP* pp_declare_sv(pTHX) 2386{ 2387 clear_bit_flags(PL_op->op_private, OPpDEREF); 2388 return pp_declare_var(aTHX_ GVf_IMPORTED_SV, OP_RV2SV); 2389} 2390 2391OP* pp_declare_av(pTHX) 2392{ 2393 return pp_declare_var(aTHX_ GVf_IMPORTED_AV, OP_RV2AV); 2394} 2395 2396OP* pp_declare_hv(pTHX) 2397{ 2398 return pp_declare_var(aTHX_ GVf_IMPORTED_HV, OP_RV2HV); 2399} 2400 2401int clear_imported_flag(pTHX_ SV* sv, MAGIC* mg) 2402{ 2403 GV* gv = (GV*)mg->mg_obj; 2404 GvFLAGS(gv) &= ~mg->mg_len; 2405 return 0; 2406} 2407 2408const MGVTBL clear_imported_flag_vtab = { nullptr, nullptr, nullptr, nullptr, &clear_imported_flag }; 2409 2410OP* pp_unimport_guard(pTHX) 2411{ 2412 dSP; 2413 SV* gv = TOPs; 2414 const unsigned int imp_flag = PL_op->op_private; 2415 if (!(GvFLAGS(gv) & imp_flag)) { 2416 SV* guard = cSVOP_sv; 2417 sv_magicext(guard, gv, PERL_MAGIC_ext, &clear_imported_flag_vtab, nullptr, imp_flag); 2418 } 2419 return NORMAL; 2420} 2421 2422void parse_declare_var(pTHX_ OP* o, U8 imp_flag, OP* (*pp_func)(pTHX), bool make_void) 2423{ 2424 OP* gvop = cUNOPo->op_first; 2425 if (gvop->op_type != OP_GV) { 2426 report_parse_error("wrong use of declare; expecting plain package variable"); 2427 return; 2428 } 2429 if ((o->op_flags & OPf_MOD) && (o->op_private & OPpLVAL_INTRO) // declare local 2430 || (cur_lexical_flags & LexCtxAllowReDeclare)) { 2431 // create a dummy scalar whose destruction will clear the IMPORTED flag 2432 // the destruction takes place when the entire OP tree is destroyed, that is, 2433 // together with the top-level (anonymous) sub constructed for a script 2434 OP* guard_op = newSVOP(OP_CONST, 0, newSV_type(SVt_NULL)); 2435 guard_op->op_ppaddr = pp_unimport_guard; 2436 guard_op->op_private = imp_flag; 2437 PmOpCopySibling(guard_op, gvop); 2438 OpMORESIB_set(gvop, guard_op); 2439#if PerlVersion < 5220 2440 if (gvop->op_next == o) { 2441 // the op subtree is already threaded 2442 guard_op->op_next=o; 2443 gvop->op_next=guard_op; 2444 } 2445#endif 2446 } 2447 // prevent collapsing to GVSV 2448 if (imp_flag == GVf_IMPORTED_SV) 2449 o->op_private |= OPpDEREF; 2450 o->op_ppaddr = pp_func; 2451 gvop->op_ppaddr = def_pp_GV; 2452 if (make_void) { 2453 clear_bit_flags(o->op_flags, OPf_WANT); 2454 set_bit_flags(o->op_flags, OPf_WANT_VOID); 2455 o->op_type = OP_CUSTOM; 2456 } 2457} 2458 2459void parse_declare_elem(pTHX_ OP*& o, bool make_void, bool top_level); 2460 2461void parse_declare_list(pTHX_ OP* o, bool make_void) 2462{ 2463 OP* left; 2464 if (make_void) { 2465 o->op_ppaddr=PL_ppaddr[OP_NULL]; 2466 strip_off_pushmark(aTHX_ o); 2467 left=cLISTOPo->op_first; 2468 } else { 2469 // this is a list assignment, preserve PUSHMARK 2470 left=cLISTOPo->op_first; 2471 left=OpSIBLING(left); 2472 } 2473 do 2474 parse_declare_elem(aTHX_ left, make_void, false); 2475 while ((left=OpSIBLING(left))); 2476} 2477 2478void parse_declare_scalar_assign(pTHX_ OP* o, bool make_void) 2479{ 2480 OP* left; 2481 if (!make_void || !(o->op_flags & OPf_STACKED) || (o->op_private & OPpASSIGN_BACKWARDS) || 2482 (left=cBINOPo->op_last, left->op_type != OP_RV2SV)) { 2483 report_parse_error("wrong use of declare; expecting simple assignment to a scalar package variable"); 2484 return; 2485 } 2486 parse_declare_var(aTHX_ left, GVf_IMPORTED_SV, &pp_declare_sv, false); 2487} 2488 2489OP* pp_declare_av_in_split(pTHX_ unsigned int optype) 2490{ 2491 GV* gv= 2492# ifdef USE_ITHREADS 2493 (GV*)PAD_SVl(cPMOP->op_pmreplrootu.op_pmtargetoff); 2494# else 2495 cPMOP->op_pmreplrootu.op_pmtargetgv; 2496# endif 2497 const bool allow_redeclare=get_lex_flags(aTHX) & LexCtxAllowReDeclare; 2498 set_import_flag(aTHX_ gv, GVf_IMPORTED_AV, allow_redeclare); 2499 return PL_ppaddr[optype](aTHX); 2500} 2501 2502#if PerlVersion >= 5256 2503 2504OP* pp_split_declare_av(pTHX) 2505{ 2506 return pp_declare_av_in_split(aTHX_ OP_SPLIT); 2507} 2508 2509void parse_declare_split(pTHX_ OP* o, bool make_void) 2510{ 2511 if (!make_void || (o->op_private & (OPpSPLIT_ASSIGN | OPpSPLIT_LEX)) != OPpSPLIT_ASSIGN 2512 || (o->op_flags & OPf_STACKED)) { 2513 report_parse_error("wrong use of declare; expecting simple assignment to an array package variable"); 2514 return; 2515 } 2516 o->op_ppaddr=&pp_split_declare_av; 2517} 2518 2519#else // PerlVersion <= 5256 2520 2521OP* pp_pushre_declare_av(pTHX) 2522{ 2523 return pp_declare_av_in_split(aTHX_ OP_PUSHRE); 2524} 2525 2526void parse_declare_split(pTHX_ OP* o, bool make_void) 2527{ 2528 PMOP* pushre=cPMOPx(cUNOPo->op_first); 2529 assert(pushre->op_type == OP_PUSHRE); 2530 auto gv= 2531# ifdef USE_ITHREADS 2532 pushre->op_pmreplrootu.op_pmtargetoff; 2533# else 2534 pushre->op_pmreplrootu.op_pmtargetgv; 2535# endif 2536 if (!make_void || !gv) { 2537 report_parse_error("wrong use of declare; expecting simple assignment to an array package variable"); 2538 return; 2539 } 2540 pushre->op_ppaddr=&pp_pushre_declare_av; 2541} 2542#endif 2543 2544void parse_declare_list_assign(pTHX_ OP* o, bool make_void) 2545{ 2546 OP* left; 2547 if (!make_void || !(o->op_flags & OPf_STACKED) || 2548 !(left=cBINOPo->op_last, left->op_type == OP_LIST || left->op_type == OP_NULL && left->op_targ == OP_LIST)) { 2549 report_parse_error("wrong use of declare; expecting simple list assignment to one or more package variables"); 2550 return; 2551 } 2552 parse_declare_list(aTHX_ left, false); 2553} 2554 2555// export into the (fake) packages with partial names, so that the sub is found via qualified lookup 2556void propagate_sub(pTHX_ HV* stash, GV* cgv) 2557{ 2558 const char* cv_name = GvNAME(cgv); 2559 const I32 cv_namelen = GvNAMELEN(cgv); 2560 const char* pkg_name = HvNAME(stash); 2561 const char* colon = pkg_name + HvNAMELEN(stash)-1; 2562 for (int tail_len = 0; colon > pkg_name; --colon, ++tail_len) { 2563 if (colon[0] == ':' && colon[-1] == ':') { 2564 HV* dummy_stash = gv_stashpvn(colon+1, tail_len, GV_ADD); 2565 colon -= 2; tail_len += 2; 2566 2567 if (!is_dummy_pkg(aTHX_ dummy_stash, true)) continue; 2568 2569 GV* ngv = *(GV**)hv_fetch(dummy_stash, cv_name, cv_namelen, true); 2570 if (SvTYPE(ngv) != SVt_PVGV) 2571 gv_init_pvn(ngv, dummy_stash, cv_name, cv_namelen, GV_ADDMULTI); 2572 if (!GvCVu(ngv)) { 2573 GvCV_set(ngv, (CV*)SvREFCNT_inc_simple_NN(GvCV(cgv))); 2574 GvASSUMECV_on(ngv); 2575 } 2576 } 2577 } 2578} 2579 2580void parse_declare_sub(pTHX_ OP*& o) 2581{ 2582 if (!(o->op_private & OPpENTERSUB_AMPER) || (o->op_flags & OPf_PARENS)) { 2583 report_parse_error("wrong syntax of declare &sub"); 2584 return; 2585 } 2586 OP* argop = cUNOPo->op_first; 2587 if (argop->op_type == OP_NULL) 2588 argop = cLISTOPx(argop)->op_first; 2589 assert(argop->op_type == OP_PUSHMARK); 2590 OP* cvop = OpSIBLING(argop); 2591 assert(cvop && (cvop->op_type == OP_RV2CV || cvop->op_type == OP_NULL && cvop->op_targ == OP_RV2CV)); 2592 OP* gvop = cUNOPx(cvop)->op_first; 2593 GV* cgv = cGVOPx_gv(gvop); 2594 CV* cv = GvCV(cgv); 2595 if (!(cv && (is_well_defined_sub(cv) || GvASSUMECV(cgv)))) { 2596 HV* stash = PL_curstash; 2597 if (GvSTASH(cgv) != stash) { 2598 report_parse_error("declare &sub may only introduce subroutines in the current package"); 2599 return; 2600 } 2601 create_dummy_sub(aTHX_ stash, cgv); 2602 propagate_sub(aTHX_ stash, cgv); 2603 } 2604 SvREFCNT_inc_simple_void_NN(cgv); // protect against removal from stash in the next line 2605 op_free(o); 2606 SvREFCNT_dec(cgv); 2607 o = newOP(OP_NULL, 0); 2608} 2609 2610void parse_declare_elem(pTHX_ OP*& o, bool make_void, bool top_level) 2611{ 2612 switch (o->op_type) { 2613 case OP_RV2SV: 2614 // declare $a; 2615 parse_declare_var(aTHX_ o, GVf_IMPORTED_SV, &pp_declare_sv, make_void); 2616 break; 2617 case OP_RV2AV: 2618 // declare @a; 2619 parse_declare_var(aTHX_ o, GVf_IMPORTED_AV, &pp_declare_av, make_void); 2620 break; 2621 case OP_RV2HV: 2622 // declare %a; 2623 parse_declare_var(aTHX_ o, GVf_IMPORTED_HV, &pp_declare_hv, make_void); 2624 break; 2625 case OP_SASSIGN: 2626 // declare $a=1; 2627 parse_declare_scalar_assign(aTHX_ o, make_void); 2628 break; 2629 case OP_AASSIGN: 2630 // declare ($a, $b)=(1, 2); 2631 // declare @a=(1, 2); 2632 parse_declare_list_assign(aTHX_ o, make_void); 2633 break; 2634 case OP_LIST: 2635 // several variables at once: 2636 // declare $a, $b; 2637 // declare $a=1, $b=2; 2638 // declare local ($a, $b); 2639 parse_declare_list(aTHX_ o, make_void); 2640 break; 2641 case OP_SPLIT: 2642 // declare @a=split ...; 2643 parse_declare_split(aTHX_ o, make_void); 2644 break; 2645 case OP_ENTERSUB: 2646 // declare &a; 2647 if (make_void && top_level) 2648 parse_declare_sub(aTHX_ o); 2649 else 2650 report_parse_error("wrong use of declare &sub within an expression"); 2651 break; 2652 default: 2653 report_parse_error("wrong use of declare; expecting a variable list, an assignment, or a sub name"); 2654 break; 2655 } 2656} 2657 2658void set_lexical_flag(pTHX_ int flag, bool new_value) 2659{ 2660 if (new_value != ((cur_lexical_flags & flag) != 0)) { 2661 cur_lexical_flags ^= flag; 2662 set_lexical_scope_hint(aTHX); 2663 } 2664} 2665 2666bool parse_declare_flags(pTHX_ OP** op_ptr) 2667{ 2668 const SSize_t pos = skip_spaces(aTHX_ PL_parser->bufptr - PL_parser->linestart); 2669 if (pos < 0) 2670 return false; 2671 char* b = PL_parser->linestart + pos; 2672 const char sign = *b++; 2673 if (sign != '+' && sign != '-') 2674 return false; 2675 const bool value= sign=='+'; 2676 2677 const SSize_t rest_len = PL_parser->bufend - b; 2678 if (rest_len > 4 && !strncmp(b, "auto", 4)) { 2679 set_lexical_flag(aTHX_ LexCtxAutodeclare, value); 2680 lex_read_to(b+4); 2681 } else if (rest_len > 2 && !strncmp(b, "re", 2)) { 2682 set_lexical_flag(aTHX_ LexCtxAllowReDeclare, value); 2683 lex_read_to(b+2); 2684 } else { 2685 const char* word_end=b; 2686 while (word_end < PL_parser->bufend && isALNUM(*word_end)) ++word_end; 2687 if (word_end > b) 2688 report_parse_error("unrecognized flag %.*s in declare statement; expecting `declare [+-]{auto,re}'", (int)(word_end-b), b); 2689 else 2690 report_parse_error("invalid declare statement; expecting `declare [+-]{auto,re}'"); 2691 } 2692 *op_ptr = newOP(OP_NULL, 0); 2693 return true; 2694} 2695 2696int parse_declare_kw(pTHX_ OP** op_ptr) 2697{ 2698 if (parse_declare_flags(aTHX_ op_ptr)) 2699 return KEYWORD_PLUGIN_EXPR; 2700 2701 OP* stmt = parse_barestmt(0); 2702 if (!stmt) return KEYWORD_PLUGIN_DECLINE; 2703 parse_declare_elem(aTHX_ stmt, true, true); 2704 *op_ptr = stmt; 2705 if (stmt->op_type != OP_SASSIGN && stmt->op_type != OP_AASSIGN) 2706 stmt->op_type = OP_CUSTOM; // prevent complaints about unused variables in void context 2707 return KEYWORD_PLUGIN_STMT; 2708} 2709 2710int parse_boolean_const(pTHX_ SV* sv, OP** op_ptr) 2711{ 2712 *op_ptr = newSVOP(OP_CONST, OPf_WANT_SCALAR, SvREFCNT_inc_simple_NN(sv)); 2713 return KEYWORD_PLUGIN_EXPR; 2714} 2715 2716int keyword_func(pTHX_ char* kw, STRLEN kw_len, OP** op_ptr) 2717{ 2718 switch (kw_len) { 2719 case 1: 2720 if (kw[0] == 'T' && replaced_char_in_linebuffer != 0) { 2721 assert(PL_parser->bufptr > PL_parser->linestart); 2722 PL_parser->bufptr[-1] = '<'; 2723 PL_parser->bufptr[0] = replaced_char_in_linebuffer; 2724 replaced_char_in_linebuffer = 0; 2725 return parse_function_template_call(aTHX_ nullptr, op_ptr); 2726 } 2727 break; 2728 case 4: 2729 switch (kw[0]) { 2730 case 't': 2731 if (!strncmp(kw, "true", 4)) 2732 return parse_boolean_const(aTHX_ &PL_sv_yes, op_ptr); 2733 break; 2734 case 'w': 2735 if (!strncmp(kw, "weak", 4)) 2736 return parse_operation(aTHX_ &ops::make_weak, op_ptr); 2737 break; 2738 } 2739 break; 2740 case 5: 2741 switch (kw[0]) { 2742 case 'f': 2743 if (!strncmp(kw, "false", 5)) 2744 return parse_boolean_const(aTHX_ &PL_sv_no, op_ptr); 2745 break; 2746 case 'l': 2747 if (!strncmp(kw, "local", 5)) 2748 return parse_enhanced_local(aTHX_ op_ptr); 2749 break; 2750 } 2751 break; 2752 case 6: 2753 if (!strncmp(kw, "typeof", 6)) 2754 return parse_typeof_kw(aTHX_ op_ptr, "typeof"); 2755 break; 2756 case 7: 2757 switch (kw[3]) { 2758 case 'c': 2759 if (!strncmp(kw, "is_code", 7)) 2760 return parse_operation(aTHX_ &ops::is_code, op_ptr); 2761 break; 2762 case 'h': 2763 if (!strncmp(kw, "is_hash", 7)) 2764 return parse_operation(aTHX_ &ops::is_hash, op_ptr); 2765 break; 2766 case 'l': 2767 if (!strncmp(kw, "declare", 7)) 2768 return parse_declare_kw(aTHX_ op_ptr); 2769 break; 2770 } 2771 break; 2772 case 8: 2773 switch (kw[3]) { 2774 case 'a': 2775 if (!strncmp(kw, "is_array", 8)) 2776 return parse_operation(aTHX_ &ops::is_array, op_ptr); 2777 break; 2778 case 'f': 2779 if (!strncmp(kw, "is_float", 8)) 2780 return parse_operation(aTHX_ &ops::is_float, op_ptr); 2781 break; 2782 } 2783 break; 2784 case 9: 2785 switch (kw[3]) { 2786 case 'o': 2787 if (!strncmp(kw, "is_object", 9)) 2788 return parse_operation(aTHX_ &ops::is_object, op_ptr); 2789 break; 2790 case 's': 2791 if (!strncmp(kw, "is_string", 9)) 2792 return parse_operation(aTHX_ &ops::is_string, op_ptr); 2793 break; 2794 } 2795 break; 2796 case 10: 2797 switch (kw[5]) { 2798 case 'f': 2799 if (!strncmp(kw, "typeof_gen", 10)) 2800 return parse_typeof_kw(aTHX_ op_ptr, "typeof_gen"); 2801 break; 2802 case 'm': 2803 if (!strncmp(kw, "is_numeric", 10)) 2804 return parse_operation(aTHX_ &ops::is_numeric, op_ptr); 2805 break; 2806 case 'n': 2807 if (!strncmp(kw, "instanceof", 10)) 2808 return parse_instanceof_kw(aTHX_ op_ptr); 2809 break; 2810 case 'o': 2811 if (!strncmp(kw, "is_boolean", 10)) 2812 return parse_operation(aTHX_ &ops::is_boolean, op_ptr); 2813 break; 2814 case 'r': 2815 if (!strncmp(kw, "interrupts", 10)) 2816 return parse_interrupts_op(aTHX_ false, op_ptr); 2817 break; 2818 case 't': 2819 if (!strncmp(kw, "is_integer", 10)) 2820 return parse_operation(aTHX_ &ops::is_integer, op_ptr); 2821 break; 2822 case 'u': 2823 if (!strncmp(kw, "set_custom", 10)) 2824 return parse_set_custom(aTHX_ op_ptr); 2825 break; 2826 } 2827 break; 2828 case 12: 2829 switch (kw[3]) { 2830 case 'e': 2831 if (!strncmp(kw, "reset_custom", 12)) 2832 return parse_reset_custom(aTHX_ op_ptr); 2833 break; 2834 case 'l': 2835 if (!strncmp(kw, "is_like_hash", 12)) 2836 return parse_operation(aTHX_ &ops::is_like_hash, op_ptr); 2837 break; 2838 } 2839 break; 2840 case 13: 2841 switch (kw[3]) { 2842 case 'l': 2843 if (!strncmp(kw, "is_like_array", 13)) 2844 return parse_operation(aTHX_ &ops::is_like_array, op_ptr); 2845 break; 2846 case 's': 2847 if (!strncmp(kw, "is_scalar_ref", 13)) 2848 return parse_operation(aTHX_ &ops::is_scalar_ref, op_ptr); 2849 break; 2850 } 2851 break; 2852 case 15: 2853 if (!strncmp(kw, "is_constant_sub", 15)) 2854 return parse_operation(aTHX_ &ops::is_constant_sub, op_ptr); 2855 break; 2856 case 20: 2857 if (!strncmp(kw, "is_defined_and_false", 20)) 2858 return parse_operation(aTHX_ &ops::is_defined_and_false, op_ptr); 2859 break; 2860 } 2861 2862 if (Perl_keyword(aTHX_ kw, I32(kw_len), false)) 2863 return KEYWORD_PLUGIN_DECLINE; 2864 2865 // recognize static method calls: METHOD TYPE(...) or METHOD TYPE<EXPR>(...) 2866 2867 const SSize_t cur_pos = PL_parser->bufptr - PL_parser->linestart; 2868 const SSize_t after_space = skip_spaces(aTHX_ cur_pos); 2869 2870 if (after_space > cur_pos && isIDFIRST(PL_parser->linestart[after_space])) { 2871 // METHOD TYPE [ (args) ] ? 2872 lex_read_to(PL_parser->linestart + after_space); 2873 return parse_static_method_call(aTHX_ kw, kw_len, op_ptr); 2874 } 2875 2876 // recognize FUNC<TYPE EXPR>() and calls to imported functions not predeclared yet in the current package 2877 if (PL_parser->linestart[after_space] == '<' && 2878 PL_parser->linestart[after_space+1] != '<' && 2879 PL_parser->linestart[after_space+1] != '=') { 2880 if (GV* gv = lookup_sub_gv(aTHX_ PL_curstash, kw, kw_len, cur_lexical_import_ix, 2881 bad_filehandle_gv | bad_constant_gv | dont_create_dummy_sub).first) { 2882 lex_read_to(PL_parser->linestart + after_space+1); 2883 return parse_function_template_call(aTHX_ gv, op_ptr); 2884 } 2885 } 2886 2887 if (PL_parser->linestart[after_space] != '(') 2888 // let's try to import a subroutine with the given name; if there is some, the parser will handle it appropriately 2889 (void)lookup_sub_gv(aTHX_ PL_curstash, kw, kw_len, cur_lexical_import_ix, bad_filehandle_gv); 2890 2891 return KEYWORD_PLUGIN_DECLINE; 2892} 2893 2894OP* intercept_ck_rv2cv(pTHX_ OP* o) 2895{ 2896 OP* const_op = nullptr; 2897 if ((o->op_private & OPpMAY_RETURN_CONSTANT) 2898 && (o->op_flags & OPf_KIDS) 2899 && (const_op = cUNOPo->op_first, const_op->op_type == OP_CONST) 2900 && (const_op->op_private & OPpCONST_BARE)) { 2901 // looks like a call to a sub without & and arguments, but there still may be a parenthesis... 2902 2903 GV* cgv; 2904 SV* name_sv = cSVOPx_sv(const_op); 2905 STRLEN namelen; 2906 const char* name = SvPV(name_sv, namelen); 2907 // PL_parser->bufptr still points to the beginning of the package name while an internal 2908 // tokenizer variable has already advanced behind it. Therefore we can't let the line buffer grow 2909 // and look ahead beyond the line break. 2910 // In perl < 5.22, this function can be called twice, with bufptr pointing at the beginning and at the end of the name. 2911 char* after = PL_parser->bufptr + (PerlVersion >= 5220 || PL_parser->expect != 0 ? namelen : 0); 2912 for (;; ++after) { 2913 if (after == PL_parser->bufend) { 2914 after = nullptr; 2915 break; 2916 } 2917 if (!isSPACE(*after)) { 2918 break; 2919 } 2920 } 2921 if ((!after || after[0] != '(') && 2922 (cgv = lookup_sub_gv(aTHX_ PL_curstash, name, namelen, cur_lexical_import_ix, dont_create_dummy_sub).first)) { 2923 OP* gv_op = newGVOP(OP_GV, 0, cgv); 2924 PmOpCopySibling(gv_op, const_op); 2925 cUNOPo->op_first = gv_op; 2926 op_free(const_op); 2927 if (GvCV(cgv) && CvCONST(GvCV(cgv))) { 2928 // it's a named constant, already resolved 2929 gv_op->op_ppaddr = def_pp_GV; 2930 } else if (after && GvASSUMECV(cgv) && after[0] == '<' && after[1] != '<' && after[1] != '=') { 2931 // This is a function template with partial qualification: app_name::func_name 2932 // this 'T' will be presented to the keyword plugin 2933 *after = 'T'; 2934 replaced_char_in_linebuffer = after[1]; 2935 after[1] = ' '; 2936 } 2937 return o; 2938 } 2939 } 2940 return def_ck_RV2CV(aTHX_ o); 2941} 2942 2943OP* intercept_pp_entereval(pTHX) 2944{ 2945 const int lex_imp_ix = get_lex_imp_ix(aTHX); 2946 if (current_mode()) 2947 Perl_croak(aTHX_ "namespace mode internal error: compilation mode active during execution"); 2948 cur_lexical_import_ix = lex_imp_ix; 2949 catch_ptrs(aTHX_ nullptr); 2950 OP* next=def_pp_ENTEREVAL(aTHX); 2951 if (next && next->op_ppaddr != &switch_off_namespaces) { 2952 reset_ptrs(aTHX_ nullptr); 2953 cur_lexical_import_ix = -1; 2954 cur_lexical_flags = 0; 2955 } 2956 return next; 2957} 2958 2959OP* intercept_pp_regcomp(pTHX) 2960{ 2961 int lex_imp_ix = get_lex_imp_ix(aTHX); 2962 if (current_mode()) { 2963 if (SvPOK(ERRSV) && SvCUR(ERRSV) > 0) 2964 Perl_croak(aTHX_ "namespace mode internal error: compilation mode active during execution; pending exception is '%.*s'", (int)SvCUR(ERRSV), SvPVX(ERRSV)); 2965 else 2966 Perl_croak(aTHX_ "namespace mode internal error: compilation mode active during execution"); 2967 } 2968 cur_lexical_import_ix=lex_imp_ix; 2969 catch_ptrs(aTHX_ nullptr); 2970 OP* next=def_pp_REGCOMP(aTHX); 2971 reset_ptrs(aTHX_ nullptr); 2972 cur_lexical_import_ix=-1; 2973 cur_lexical_flags=0; 2974 assert(!next || next->op_ppaddr != &switch_off_namespaces); 2975 return next; 2976} 2977 2978#if PerlVersion >= 5220 2979OP* intercept_pp_multideref(pTHX) 2980{ 2981 OP* o=PL_op; 2982 OP* next_op=o; 2983 GV* var_gv=nullptr; 2984 2985 // The following voodoo is a stripped down code from pp_multideref. 2986 // It has to be aligned with the future development of that monstrous op. 2987 2988 UNOP_AUX_item* items = cUNOP_AUXo->op_aux; 2989 UV actions = items->uv; 2990 o->op_ppaddr=def_pp_MULTIDEREF; 2991 2992 while (true) { 2993 switch (actions & MDEREF_ACTION_MASK) { 2994 2995 case MDEREF_reload: 2996 actions = (++items)->uv; 2997 continue; 2998 2999 case MDEREF_AV_padav_aelem: /* $lex[...] */ 3000 case MDEREF_HV_padhv_helem: /* $lex{...} */ 3001 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */ 3002 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */ 3003 ++items; 3004 break; 3005 3006 case MDEREF_AV_gvav_aelem: /* $pkg[...] */ 3007 var_gv=(GV*)UNOP_AUX_item_sv(++items); 3008 resolve_array_gv(aTHX_ items, var_gv, &next_op, nullptr); 3009 if (next_op != o) return next_op; 3010 break; 3011 3012 case MDEREF_HV_gvhv_helem: /* $pkg{...} */ 3013 var_gv=(GV*)UNOP_AUX_item_sv(++items); 3014 resolve_hash_gv(aTHX_ items, var_gv, &next_op, nullptr); 3015 if (next_op != o) return next_op; 3016 break; 3017 3018 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */ 3019 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */ 3020 var_gv=(GV*)UNOP_AUX_item_sv(++items); 3021 resolve_scalar_gv(aTHX_ items, var_gv, &next_op, nullptr); 3022 if (next_op != o) return next_op; 3023 break; 3024 3025 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */ 3026 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */ 3027 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */ 3028 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */ 3029 break; 3030 3031 default: 3032 Perl_croak(aTHX_ "unknown MULTIDEREF action %d", (int)(actions & MDEREF_ACTION_MASK)); 3033 } 3034 3035 switch (actions & MDEREF_INDEX_MASK) { 3036 case MDEREF_INDEX_none: 3037 return next_op; 3038 case MDEREF_INDEX_const: 3039 case MDEREF_INDEX_padsv: 3040 ++items; 3041 break; 3042 case MDEREF_INDEX_gvsv: 3043 var_gv=(GV*)UNOP_AUX_item_sv(++items); 3044 resolve_scalar_gv(aTHX_ items, var_gv, &next_op, nullptr); 3045 if (next_op != o) return next_op; 3046 break; 3047 default: 3048 Perl_croak(aTHX_ "unknown MULTIDEREF index action %d", (int)(actions & MDEREF_INDEX_MASK)); 3049 } 3050 3051 if (actions & MDEREF_FLAG_last) break; 3052 actions >>= MDEREF_SHIFT; 3053 } 3054 return next_op; 3055} 3056#endif 3057 3058OP* leave_with_magic_lvalue(pTHX) 3059{ 3060 dSP; 3061 SV* retval = TOPs; 3062 U32 retval_flags = SvTEMP(retval) && SvREFCNT(retval)==1 ? SvMAGICAL(retval) : 0; 3063 if (retval_flags != 0) { 3064 SvMAGICAL_off(retval); 3065 OP* next_op = Perl_pp_leavesub(aTHX); 3066 SvFLAGS(retval) |= retval_flags; 3067 return next_op; 3068 } 3069 return Perl_pp_leavesub(aTHX); 3070} 3071 3072OP* pp_leave_with_magic_lvalue(pTHX) 3073{ 3074 if (cxstack[cxstack_ix].blk_gimme == G_SCALAR) 3075 return leave_with_magic_lvalue(aTHX); 3076 else 3077 return Perl_pp_leavesub(aTHX); 3078} 3079 3080OP* pp_leave_maybe_with_lvalue(pTHX) 3081{ 3082 if (cxstack[cxstack_ix].blk_gimme == G_SCALAR) { 3083 OP* flag_op = PL_op->op_next; 3084 SV* flag_sv = PAD_SVl(flag_op->op_targ); 3085 if (SvIOK(flag_sv) && SvIVX(flag_sv) != no_lvalue) { 3086 return SvIVX(flag_sv) == magic_lvalue ? leave_with_magic_lvalue(aTHX) : Perl_pp_leavesublv(aTHX); 3087 } 3088 } 3089 return Perl_pp_leavesub(aTHX); 3090} 3091 3092OP* intercept_pp_anoncode(pTHX) 3093{ 3094 OP* next_op = def_pp_ANONCODE(aTHX); 3095 if (next_op == PL_op->op_next) { // not died 3096 dSP; 3097 CV* sub = (CV*)TOPs; 3098 OP* leave = CvROOT(sub); 3099 OP* flag_op = leave->op_next; 3100 auto pad_list = CvPADLIST(sub); 3101 SV* flag_sv = PAD_BASE_SV(pad_list, flag_op->op_targ); 3102 if (SvIOK(flag_sv) && SvIVX(flag_sv) != 0) { 3103 CvFLAGS(sub) |= CVf_LVALUE | CVf_NODEBUG; 3104 } 3105 } 3106 return next_op; 3107} 3108 3109OP* intercept_ck_anoncode(pTHX_ OP* o) 3110{ 3111 SV* hint_sv = Perl_refcounted_he_fetch_sv(aTHX_ PL_compiling.cop_hints_hash, anon_lvalue_key, 0, 0); 3112 o = def_ck_ANONCODE(aTHX_ o); 3113 if (!hint_sv || hint_sv == &PL_sv_placeholder) { 3114 // left the scope 3115 PL_check[OP_ANONCODE] = def_ck_ANONCODE; 3116 return o; 3117 } 3118 CV* sub = (CV*)PAD_SVl(o->op_targ); 3119 OP* leave = CvROOT(sub); 3120 assert(leave->op_type == OP_LEAVESUB); 3121 if (SvIOK(hint_sv)) { 3122 // this sub or all its clones are always returning an lvalue 3123 CvFLAGS(sub) |= CVf_LVALUE | CVf_NODEBUG; 3124 leave->op_ppaddr = &pp_leave_with_magic_lvalue; 3125 } else { 3126 // the lvalue status depends on the outer context of the closure 3127 OP* start = CvSTART(sub); 3128 OP* flag_op = start->op_next; 3129 PADLIST* sub_padlist = CvPADLIST(sub); 3130 start = flag_op->op_next; 3131 3132 if (flag_op->op_type != OP_PADSV || !start || (start->op_type != OP_NEXTSTATE && start->op_type != OP_DBSTATE)) 3133 Perl_croak(aTHX_ "First op in an lvalue anon sub must be a single lex variable"); 3134 3135 PADNAME* flag_name = PadlistNAMESARRAY(sub_padlist)[flag_op->op_targ]; 3136 if (PadnameLEN(flag_name) != SvCUR(hint_sv) || strncmp(PadnamePV(flag_name), SvPVX(hint_sv), SvCUR(hint_sv))) 3137 Perl_croak(aTHX_ "found flag lexical variable %.*s while %.*s expected", 3138 (int)SvCUR(hint_sv), SvPVX(hint_sv), (int)PadnameLEN(flag_name), PadnamePV(flag_name)); 3139#if PerlVersion >= 5180 3140 if (!PadnameOUTER(flag_name)) 3141 Perl_croak(aTHX_ "flag lexical variable must be captured from outer scope"); 3142#endif 3143 3144 // the flag variable itself does not contribute to the result, can be short-cut 3145 CvSTART(sub) = start; 3146 leave->op_ppaddr = &pp_leave_maybe_with_lvalue; 3147 leave->op_next = flag_op; 3148 o->op_ppaddr = &intercept_pp_anoncode; 3149 } 3150 return o; 3151} 3152 3153void store_anon_lvalue_flag(pTHX_ SV* flag_sv) 3154{ 3155 MAGIC hint_mg; 3156 hint_mg.mg_len = HEf_SVKEY; 3157 hint_mg.mg_ptr = reinterpret_cast<char*>(anon_lvalue_key); 3158 Perl_magic_sethint(aTHX_ flag_sv, &hint_mg); 3159 PL_check[OP_ANONCODE] = &intercept_ck_anoncode; 3160} 3161 3162 3163HV* lookup_class_in_pkg(pTHX_ HV* stash, const char* class_name, const char* first_colon, const char* buf, size_t buflen) 3164{ 3165 GV** imp_class_gvp; 3166 3167 if (first_colon) { 3168 const char* class_name_part = class_name; 3169 const char* next_colon = first_colon; 3170 do { 3171 const char* next_name_part = next_colon+2; 3172 const size_t l = next_name_part - class_name_part; 3173 imp_class_gvp = (GV**)hv_fetch(stash, class_name_part, I32(l), false); 3174 if (!imp_class_gvp || SvTYPE(*imp_class_gvp) != SVt_PVGV || !(stash = GvHV(*imp_class_gvp))) 3175 return nullptr; 3176 buf += l; 3177 buflen -= l; 3178 class_name_part = next_name_part; 3179 } while ((next_colon = (const char*)memchr(class_name_part, ':', buflen-2))); 3180 } 3181 if ((imp_class_gvp = (GV**)hv_fetch(stash, buf, I32(buflen), false)) && SvTYPE(*imp_class_gvp) == SVt_PVGV) 3182 return GvHV(*imp_class_gvp); 3183 return nullptr; 3184} 3185 3186void switch_op_interception(pTHX_ AV* dotSUBST_OP, bool enable) 3187{ 3188 if (dotSUBST_OP) { 3189 const int method_index = intercept_op_reset+enable; 3190 for (SV **descrp = AvARRAY(dotSUBST_OP), ** const endp = descrp + AvFILLp(dotSUBST_OP); descrp <= endp; ++descrp) { 3191 AV* op_descr = (AV*)SvRV(*descrp); 3192 SV* method_sv = AvARRAY(op_descr)[method_index]; 3193 if (method_sv != PmEmptyArraySlot) 3194 PL_check[SvIVX(AvARRAY(op_descr)[intercept_op_code])] = (Perl_check_t)SvUVX(method_sv); 3195 } 3196 } 3197} 3198 3199void establish_lex_imp_ix(pTHX_ int new_ix, bool new_mode) 3200{ 3201 if (!current_mode()) { 3202 cur_lexical_import_ix = new_ix; 3203 catch_ptrs(aTHX_ nullptr); 3204 } else if (new_mode) { 3205 AV* old_dotSUBST_OP = get_cur_dotSUBST_OP(aTHX); 3206 switch_op_interception(aTHX_ old_dotSUBST_OP, false); 3207 cur_lexical_import_ix = new_ix; 3208 switch_op_interception(aTHX_ get_cur_dotSUBST_OP(aTHX), true); 3209 } else { 3210 reset_ptrs(aTHX_ nullptr); 3211 cur_lexical_import_ix = new_ix; 3212 } 3213 set_lexical_scope_hint(aTHX); 3214} 3215 3216OP* mark_dbstate(pTHX) 3217{ 3218 return def_pp_DBSTATE(aTHX); 3219} 3220 3221#if defined(POLYMAKE_GATHER_CODE_COVERAGE) 3222void store_cov_line(pTHX_ COP* cop, int cnt) 3223{ 3224 // skip "(eval NNN)" and anonymous filtered code 3225 const char* filename = CopFILE(cop); 3226 if (filename[0] != '(' && strncmp(filename, "/loader/0x", 10)) { 3227 const int srcline = CopLINE(cop); 3228 if (srcline == 0) { 3229 report_parse_error("source line=0 in source file %s", CopFILE(cop)); 3230 return; 3231 } 3232 AV* hits_av; 3233 SV* file_entry = *hv_fetch(cov_stats, filename, strlen(filename), true); 3234 if (SvROK(file_entry)) { 3235 hits_av = (AV*)SvRV(file_entry); 3236 } else { 3237 hits_av = newAV(); 3238 sv_upgrade(file_entry, SVt_RV); 3239 SvRV_set(file_entry, (SV*)hits_av); 3240 SvROK_on(file_entry); 3241 } 3242 SV* hitcnt = *av_fetch(hits_av, srcline-1, TRUE); 3243 if (SvIOK(hitcnt)) { 3244 SvIV_set(hitcnt, SvIVX(hitcnt)+cnt); 3245 } else { 3246 sv_setiv(hitcnt, cnt); 3247 } 3248 } 3249} 3250 3251void scan_op_tree(pTHX_ OP* o) 3252{ 3253 // recursively visit all OP nodes and announce all NEXTSTATEs because they carry the line numbers. 3254 while (o) { 3255 if (o->op_type == OP_NEXTSTATE) { 3256 store_cov_line(aTHX_ (COP*)o, 0); 3257 } else if (o->op_flags & OPf_KIDS) { 3258 scan_op_tree(aTHX_ cUNOPo->op_first); 3259 } 3260 o=OpSIBLING(o); 3261 } 3262} 3263 3264void intercept_peep(pTHX_ OP* o) 3265{ 3266 def_peep(aTHX_ o); 3267 scan_op_tree(aTHX_ o); 3268} 3269 3270OP* intercept_pp_nextstate(pTHX) 3271{ 3272 COP* o=(COP*)PL_op; 3273 store_cov_line(aTHX_ o, 1); 3274 return def_pp_NEXTSTATE(aTHX); 3275} 3276#endif 3277 3278void catch_ptrs(pTHX_ void* to_restore) 3279{ 3280 if (to_restore) { 3281 finish_undo(aTHX_ (ToRestore*)to_restore); 3282 } else { 3283 PL_hints &= ~HINT_STRICT_VARS; 3284 } 3285 3286 if (!to_restore || !current_mode()) { 3287 SV* beginav=(SV*)PL_beginav_save; 3288 SvRMAGICAL_on(beginav); 3289 3290 PL_ppaddr[OP_GV] =&intercept_pp_gv; 3291 PL_ppaddr[OP_GVSV] =&intercept_pp_gvsv; 3292 PL_ppaddr[OP_AELEMFAST]=&intercept_pp_aelemfast; 3293 PL_ppaddr[OP_SPLIT] =&intercept_pp_split; 3294 PL_ppaddr[OP_ENTEREVAL]=&intercept_pp_entereval; 3295 PL_ppaddr[OP_REGCOMP] =&intercept_pp_regcomp; 3296 PL_ppaddr[OP_DBSTATE] =&mark_dbstate; 3297#if PerlVersion >= 5220 3298 PL_ppaddr[OP_MULTIDEREF]=&intercept_pp_multideref; 3299#endif 3300 PL_check[OP_CONST] =&intercept_ck_const; 3301 PL_check[OP_ENTERSUB] =&intercept_ck_sub; 3302 PL_check[OP_LEAVESUB] =&intercept_ck_leavesub; 3303 PL_check[OP_LEAVEEVAL] =&intercept_ck_leaveeval; 3304 PL_check[OP_GV] =&intercept_ck_gv; 3305 PL_check[OP_RV2SV] =&intercept_ck_rv2sv; 3306 PL_check[OP_RV2AV] =&intercept_ck_rv2av; 3307 PL_check[OP_RV2HV] =&intercept_ck_rv2hv; 3308 PL_check[OP_RV2CV] =&intercept_ck_rv2cv; 3309 3310 PL_keyword_plugin = &keyword_func; 3311#if defined(POLYMAKE_GATHER_CODE_COVERAGE) 3312 if (cov_stats) { 3313 PL_peepp =&intercept_peep; 3314 PL_ppaddr[OP_NEXTSTATE]=&intercept_pp_nextstate; 3315 PL_perldb |= PERLDBf_NOOPT; 3316 } 3317#endif 3318 if (cur_lexical_import_ix > 0) 3319 switch_op_interception(aTHX_ get_cur_dotSUBST_OP(aTHX), true); 3320 if (AvFILLp(plugin_data) >= 0) { 3321 namespace_plugin_fun_ptr *pf=(namespace_plugin_fun_ptr*)SvPVX(plugin_code); 3322 for (SV **pl=AvARRAY(plugin_data), **ple=pl+AvFILLp(plugin_data); pl<=ple; ++pl, pf+=2) 3323 (*pf)(aTHX_ *pl); 3324 } 3325 } 3326} 3327 3328void reset_ptrs(pTHX_ void* to_restore) 3329{ 3330 if (to_restore) { 3331 finish_undo(aTHX_ (ToRestore*)to_restore); 3332 } else { 3333 PL_hints |= HINT_STRICT_VARS; 3334 } 3335 if (!to_restore || current_mode()) { 3336 SV* beginav=(SV*)PL_beginav_save; 3337 SvRMAGICAL_off(beginav); 3338 PL_savebegin=0; 3339 3340 PL_ppaddr[OP_GV] =def_pp_GV; 3341 PL_ppaddr[OP_GVSV] =def_pp_GVSV; 3342 PL_ppaddr[OP_AELEMFAST]=def_pp_AELEMFAST; 3343 PL_ppaddr[OP_SPLIT] =def_pp_SPLIT; 3344 PL_ppaddr[OP_ENTEREVAL]=def_pp_ENTEREVAL; 3345 PL_ppaddr[OP_REGCOMP] =def_pp_REGCOMP; 3346 PL_ppaddr[OP_DBSTATE] =def_pp_DBSTATE; 3347#if PerlVersion >= 5220 3348 PL_ppaddr[OP_MULTIDEREF]=def_pp_MULTIDEREF; 3349#endif 3350 PL_check[OP_CONST] =def_ck_CONST; 3351 PL_check[OP_ENTERSUB] =def_ck_ENTERSUB; 3352 PL_check[OP_LEAVESUB] =def_ck_LEAVESUB; 3353 PL_check[OP_LEAVEEVAL] =def_ck_LEAVEEVAL; 3354 PL_check[OP_GV] =def_ck_GV; 3355 PL_check[OP_RV2SV] =def_ck_RV2SV; 3356 PL_check[OP_RV2AV] =def_ck_RV2AV; 3357 PL_check[OP_RV2HV] =def_ck_RV2HV; 3358 PL_check[OP_RV2CV] =def_ck_RV2CV; 3359 PL_check[OP_ANONCODE] =def_ck_ANONCODE; 3360 3361 PL_keyword_plugin = def_kw_plugin; 3362#if defined(POLYMAKE_GATHER_CODE_COVERAGE) 3363 if (cov_stats) { 3364 PL_peepp =def_peep; 3365 PL_ppaddr[OP_NEXTSTATE]=def_pp_NEXTSTATE; 3366 PL_perldb &= ~PERLDBf_NOOPT; 3367 } 3368#endif 3369 if (cur_lexical_import_ix > 0) 3370 switch_op_interception(aTHX_ get_cur_dotSUBST_OP(aTHX), false); 3371 if (AvFILLp(plugin_data) >= 0) { 3372 namespace_plugin_fun_ptr *pf=(namespace_plugin_fun_ptr*)SvPVX(plugin_code); ++pf; 3373 for (SV **pl=AvARRAY(plugin_data), **ple=pl+AvFILLp(plugin_data); pl<=ple; ++pl, pf+=2) 3374 (*pf)(aTHX_ *pl); 3375 } 3376 } 3377} 3378 3379void catch_ptrs_when_no_error(pTHX_ void* to_restore) 3380{ 3381 if (!SvTRUE(ERRSV)) { 3382 catch_ptrs(aTHX_ to_restore); 3383 } else { 3384 cur_lexical_import_ix=-1; 3385 cur_lexical_flags=0; 3386 } 3387} 3388 3389// TRUE if executing a BEGIN { } block called from a scope enabled with namespace mode 3390bool imported_from_mode(pTHX) 3391{ 3392 bool answer=false; 3393 if (active_begin && active_begin->old_state) { 3394 for (PERL_CONTEXT *cx_bottom=cxstack, *cx=cx_bottom+cxstack_ix; cx > cx_bottom; --cx) { 3395 CV *beg_cv; 3396 if (CxTYPE(cx)==CXt_SUB && (beg_cv=cx->blk_sub.cv, CvSPECIAL(beg_cv))) { 3397 --cx; 3398 if (skip_debug_cx) { 3399 while ((CxTYPE(cx)==CXt_BLOCK && CopSTASH_eq(cx->blk_oldcop,PL_debstash)) || 3400 (CxTYPE(cx)==CXt_SUB && CvSTASH(cx->blk_sub.cv)==PL_debstash)) --cx; 3401 } 3402 if (CxTYPE(cx)==CXt_EVAL && beg_cv == active_begin->cv) { 3403 answer=true; 3404 } 3405 break; 3406 } 3407 } 3408 } 3409 return answer; 3410} 3411 3412OP* db_caller_scope(pTHX) 3413{ 3414 for (PERL_CONTEXT *cx_bottom=cxstack, *cx=cx_bottom+cxstack_ix; cx > cx_bottom; --cx) { 3415 if (CxTYPE(cx)==CXt_SUB) { 3416 COP* o=cx->blk_oldcop; 3417 if (o->op_ppaddr==&mark_dbstate) { 3418 dSP; 3419 SV* sv=TOPs; 3420 if (SvREADONLY(sv)) { sv=sv_mortalcopy(sv); SETs(sv); } 3421 sv_catpvf(sv, " use namespaces %d (); ", extract_lex_imp_ix(aTHX_ o)); 3422 } 3423 break; 3424 } 3425 } 3426 return NORMAL; 3427} 3428 3429} // end of anonymous namespace 3430 3431SV* namespace_try_lookup(pTHX_ HV* stash, SV* name, I32 type) 3432{ 3433 if (get_dotLOOKUP(aTHX_ stash).first) { 3434 STRLEN l; 3435 const char* n = SvPV(name, l); 3436 GV* gv = *(GV**)hv_fetch(stash, n, I32(l), true); 3437 if (SvTYPE(gv) != SVt_PVGV) 3438 gv_init_pvn(gv, stash, n, l, GV_ADDMULTI); 3439 lookup(aTHX_ nullMultiDerefItem_ gv, type, nullptr, nullptr); 3440 switch (type) { 3441 case SVt_PV: 3442 return GvSV(gv); 3443 case SVt_PVAV: 3444 return (SV*)GvAV(gv); 3445 case SVt_PVHV: 3446 return (SV*)GvHV(gv); 3447 case SVt_PVCV: 3448 return (SV*)GvCV(gv); 3449 case SVt_PVGV: 3450 return (SV*)gv; 3451 } 3452 } 3453 return nullptr; 3454} 3455 3456HV* namespace_lookup_class(pTHX_ HV* stash, const char* class_name, STRLEN class_namelen, int lex_imp_ix, bool override_negative_cache) 3457{ 3458 HV* imp_class = nullptr; 3459 HV* glob_class = nullptr; 3460 AV* dotLOOKUP; 3461 HV* pkgLOOKUP; 3462 std::tie(dotLOOKUP, pkgLOOKUP) = get_dotLOOKUP(aTHX_ stash); 3463 if (!pkgLOOKUP) 3464 return gv_stashpvn(class_name, I32(class_namelen), GV_NOADD_NOINIT); 3465 3466 SV* cached_stash = *hv_fetch(pkgLOOKUP, class_name, I32(class_namelen), true); 3467 if (SvROK(cached_stash)) 3468 return (HV*)SvRV(cached_stash); 3469 if (!override_negative_cache && SvIOK(cached_stash)) { 3470 return lex_imp_ix <= 0 ? nullptr 3471 : namespace_lookup_class(aTHX_ (HV*)SvRV(AvARRAY(lexical_imports)[lex_imp_ix]), class_name, class_namelen, -1); 3472 } 3473 3474 const char* first_colon = (const char*)memchr(class_name, ':', class_namelen); 3475 size_t l = class_namelen+2; 3476 char smallbuf[64]; 3477 char* buf; 3478 if (l < sizeof(smallbuf)) 3479 buf = smallbuf; 3480 else 3481 Newx(buf, l+1, char); 3482 Copy(class_name, buf, l-2, char); 3483 buf[l-2] = ':'; buf[l-1] = ':'; buf[l] = 0; 3484 3485 if (!(imp_class = lookup_class_in_pkg(aTHX_ stash, class_name, first_colon, buf, l)) && dotLOOKUP) { 3486 if (AvFILLp(dotLOOKUP) >= 0) { 3487 for (SV **lookp = AvARRAY(dotLOOKUP), **endp = lookp+AvFILLp(dotLOOKUP); lookp <= endp && 3488 !(imp_class = lookup_class_in_pkg(aTHX_ (HV*)SvRV(*lookp), class_name, first_colon, buf, l)); ++lookp) ; 3489 } 3490 } 3491 if (buf != smallbuf) Safefree(buf); 3492 3493 if (!imp_class && lex_imp_ix >= 0) { 3494 if (lex_imp_ix > 0) 3495 imp_class = namespace_lookup_class(aTHX_ (HV*)SvRV(AvARRAY(lexical_imports)[lex_imp_ix]), class_name, class_namelen, -1); 3496 if ((glob_class = gv_stashpvn(class_name, I32(class_namelen), GV_NOADD_NOINIT)) && is_dummy_pkg(aTHX_ glob_class, true)) 3497 glob_class = nullptr; 3498 if (imp_class) { 3499 if (!glob_class || glob_class != imp_class) { 3500 // lexical scope prevails over global lookup 3501 sv_setiv(cached_stash, 1); 3502 return imp_class; 3503 } 3504 } 3505 imp_class = glob_class; 3506 } 3507 3508 if (imp_class) { 3509 (void)SvUPGRADE(cached_stash, SVt_RV); 3510 SvRV_set(cached_stash, SvREFCNT_inc_simple_NN(imp_class)); 3511 SvROK_on(cached_stash); 3512 } else if (lex_imp_ix >= 0) { 3513 sv_setiv(cached_stash, 0); 3514 } 3515 3516 return imp_class; 3517} 3518 3519HV* namespace_lookup_class_autoload(pTHX_ HV* stash, const char* name, STRLEN name_len, int lex_imp_ix) 3520{ 3521 HV* result = namespace_lookup_class(aTHX_ stash, name, name_len, lex_imp_ix); 3522 if (!result) { 3523 if (GV* auto_lookup_gv=lookup_sub_gv(aTHX_ stash, ".AUTOLOOKUP", 11, lex_imp_ix, 3524 ignore_undefined | dont_cache | dont_create_dummy_sub).first) { 3525 bool found = false; 3526 dSP; 3527 PUSHMARK(SP); 3528 mXPUSHp(name, name_len); 3529 PUTBACK; 3530 if (call_sv((SV*)auto_lookup_gv, G_SCALAR | G_EVAL)) { 3531 SPAGAIN; 3532 SV* ret = POPs; 3533 found = SvTRUE(ret); 3534 PUTBACK; 3535 } 3536 if (found) 3537 result = namespace_lookup_class(aTHX_ stash, name, name_len, lex_imp_ix, true); 3538 } 3539 } 3540 return result; 3541} 3542 3543CV* namespace_lookup_sub(pTHX_ HV* stash, const char* name, STRLEN name_len, CV* lex_context_cv) 3544{ 3545 if (GV* gv=lookup_sub_gv(aTHX_ stash, name, name_len, lex_context_cv ? get_lex_imp_ix_from_cv(aTHX_ lex_context_cv) : 0, 3546 ignore_undefined | bad_filehandle_gv | dont_cache | dont_create_dummy_sub).first) { 3547 return GvCV(gv); 3548 } 3549 return nullptr; 3550} 3551 3552void namespace_register_plugin(pTHX_ namespace_plugin_fun_ptr enabler, namespace_plugin_fun_ptr disabler, SV *data) 3553{ 3554 namespace_plugin_fun_ptr *pf; 3555 STRLEN pl=SvCUR(plugin_code); 3556 SvGROW(plugin_code, pl+sizeof(namespace_plugin_fun_ptr)*2); 3557 pf=(namespace_plugin_fun_ptr*)(SvPVX(plugin_code)+pl); 3558 pf[0]=enabler; pf[1]=disabler; 3559 SvCUR_set(plugin_code,pl+sizeof(namespace_plugin_fun_ptr)*2); 3560 av_push(plugin_data, data); 3561} 3562 3563SV* namespace_create_explicit_typelist(pTHX_ int size) 3564{ 3565 dSP; 3566 SP -= size; 3567 AV* list=av_make(size, SP+1); 3568 SV* list_ref=newRV_noinc((SV*)list); 3569 sv_bless(list_ref, ExplicitTypelist_stash); 3570 PUTBACK; 3571 return list_ref; 3572} 3573 3574} } } 3575 3576using namespace pm::perl::glue; 3577 3578MODULE = namespaces PACKAGE = namespaces 3579 3580PROTOTYPES: DISABLE 3581 3582void import(...) 3583PPCODE: 3584{ 3585 AV* new_imports = nullptr; 3586 int i = 1; 3587 const char* n = nullptr; 3588 bool remove = false; 3589 int new_ix = 0, skip_frames = 0; 3590 STRLEN l; 3591 SV* arg; 3592 3593 if (items >= 1 && (arg = ST(1), SvIOK(arg))) { 3594 // special call from another import routine: skip that many stack frames 3595 skip_frames = int(SvIVX(arg)); 3596 ++i; 3597 } 3598 3599 if (cur_lexical_import_ix < 0) { 3600 // first call in this compilation unit: must prepare the restore destructor 3601 insert_undo(aTHX_ skip_frames); 3602 if (items == i) { 3603 // no lexical-scope lookup list specified 3604 establish_lex_imp_ix(aTHX_ 0, true); 3605 XSRETURN_EMPTY; 3606 } 3607 arg = ST(i); 3608 if (SvPOK(arg)) { 3609 n = SvPV(arg, l); 3610 if (l == 1 && (*n == '+' || *n == '-')) 3611 Perl_croak(aTHX_ "namespace lookup list cannot be modified in the very first 'use namespaces' call"); 3612 } 3613 3614 } else { 3615 if (items == i) { 3616 // reset to an empty lookup list 3617 establish_lex_imp_ix(aTHX_ 0, true); 3618 XSRETURN_EMPTY; 3619 } 3620 arg = ST(i); 3621 if (SvPOK(arg)) { 3622 n = SvPV(arg, l); 3623 if (l==1 && (*n == '+' || *n == '-')) { 3624 SV* cur_entry = AvARRAY(lexical_imports)[cur_lexical_import_ix]; 3625 if (items == 2) 3626 Perl_croak(aTHX_ "empty namespace lookup modification list"); 3627 3628 if (SvROK(cur_entry)) { 3629 HV* imp_stash = (HV*)SvRV(cur_entry); 3630 if (HvNAME(imp_stash)[0] == '-') { 3631 // already one of our shadow stashes 3632 AV* prev_import = get_dotIMPORT(aTHX_ imp_stash); 3633 new_imports = av_make(AvFILLp(prev_import)+1, AvARRAY(prev_import)); 3634 } else { 3635 // a regular stash 3636 new_imports = newAV(); 3637 av_push(new_imports, newRV((SV*)imp_stash)); 3638 } 3639 } 3640 remove = *n == '-'; 3641 ++i; 3642 } 3643 } 3644 } 3645 3646 if (!new_imports) new_imports = newAV(); 3647 3648 for (; i < items; ++i) { 3649 if (HV* imp_stash = gv_stashsv(ST(i), GV_NOADD_NOINIT)) { 3650 if (remove) 3651 remove_imp_stash(aTHX_ new_imports, imp_stash); 3652 else 3653 append_imp_stash(aTHX_ new_imports, imp_stash); 3654 } 3655 } 3656 3657 switch (AvFILLp(new_imports)) { 3658 case -1: 3659 // the lookup list became empty 3660 new_ix = 0; 3661 break; 3662 case 0: 3663 // exactly one stash to look up in 3664 new_ix = store_lex_lookup_stash(aTHX_ AvARRAY(new_imports)[0]); 3665 break; 3666 default: 3667 new_ix = store_shadow_lex_lookup_stash(aTHX_ new_imports); 3668 break; 3669 } 3670 SvREFCNT_dec(new_imports); 3671 establish_lex_imp_ix(aTHX_ new_ix, true); 3672} 3673 3674void unimport(...) 3675PPCODE: 3676{ 3677 if (!current_mode()) XSRETURN_EMPTY; 3678 if (items>1) Perl_croak(aTHX_ "'no namespaces' cannot have any arguments"); 3679 establish_lex_imp_ix(aTHX_ 0, false); 3680} 3681 3682void VERSION(SV* self, I32 ix) 3683PPCODE: 3684{ 3685 PERL_UNUSED_ARG(self); 3686 if (ix<0 || ix>AvFILLp(lexical_imports)) 3687 Perl_croak(aTHX_ "namespaces: lexical scope index %d out of range", (int)ix); 3688 establish_lex_imp_ix(aTHX_ ix, true); 3689} 3690 3691void memorize_lexical_scope() 3692PPCODE: 3693{ 3694 HE* imp_gve=hv_fetch_ent(CopSTASH(PL_curcop), dot_import_key, false, SvSHARED_HASH(dot_import_key)); 3695 if (imp_gve) { 3696 sv_setiv(GvSVn((GV*)HeVAL(imp_gve)), get_lex_imp_ix(aTHX)); 3697 } else { 3698 Perl_croak(aTHX_ "package %s was defined in a non-namespace environment", CopSTASHPV(PL_curcop)); 3699 } 3700} 3701 3702void tell_lexical_scope() 3703PPCODE: 3704{ 3705 dTARGET; 3706 XPUSHi(get_lex_imp_ix(aTHX)); 3707} 3708 3709void temp_disable(SV* stay_off_when_error) 3710CODE: 3711{ 3712 if (current_mode()) { 3713 reset_ptrs(aTHX_ nullptr); 3714 LEAVE; 3715 const auto restorer= SvTRUE(stay_off_when_error) ? &catch_ptrs_when_no_error : &catch_ptrs; 3716 SAVEDESTRUCTOR_X(restorer, nullptr); 3717 SAVEINT(cur_lexical_import_ix); 3718 SAVEINT(cur_lexical_flags); 3719 SAVEVPTR(PL_compcv); 3720 cur_lexical_import_ix=-1; 3721 cur_lexical_flags=0; 3722 PL_compcv=nullptr; // new OPs needed for code restructuring must not be allocated in the op-slabs of the current cv 3723 ENTER; 3724 } 3725} 3726 3727void is_active() 3728PPCODE: 3729{ 3730 dTARGET; 3731 PUSHi(current_mode()); 3732} 3733 3734void using(SV* dst, ...) 3735CODE: 3736{ 3737 HV* caller_stash = 3738 (SvCUR(dst) == 10 && !strncmp(SvPVX(dst), "namespaces", 10)) 3739 ? CopSTASH(PL_curcop) 3740 : gv_stashsv(dst, GV_ADD); 3741 AV* dotLOOKUP = nullptr; 3742 AV* dotIMPORT = nullptr; 3743 AV* dotSUBST_OP = nullptr; 3744 GV* av_gv; 3745 HE* av_gve = hv_fetch_ent(caller_stash, dot_lookup_key, false, SvSHARED_HASH(dot_lookup_key)); 3746 if (!(av_gve && (av_gv = (GV*)HeVAL(av_gve), SvTYPE(av_gv) == SVt_PVGV && (dotLOOKUP = GvAV(av_gv))))) 3747 dotIMPORT = get_dotIMPORT(aTHX_ caller_stash); 3748 3749 for (int i = 1; i < items; ++i) { 3750 HV* imp_stash = gv_stashsv(ST(i), GV_NOADD_NOINIT); 3751 if (!imp_stash) continue; 3752 if (imp_stash != caller_stash) { 3753 if (dotIMPORT) { 3754 av_push(dotIMPORT, newRV((SV*)imp_stash)); 3755 } else if (append_imp_stash(aTHX_ dotLOOKUP, imp_stash)) { 3756 AV* imp_dotLOOKUP = get_dotLOOKUP(aTHX_ imp_stash).first; 3757 if (imp_dotLOOKUP) 3758 append_lookup(aTHX_ caller_stash, dotLOOKUP, imp_dotLOOKUP, false); 3759 } 3760 if (AV* imp_dotSUBST_OP = get_dotSUBST_OP(aTHX_ imp_stash, false)) 3761 dotSUBST_OP = merge_dotSUBST_OP(aTHX_ caller_stash, dotSUBST_OP, imp_dotSUBST_OP); 3762 } 3763 } 3764 3765 if (dotSUBST_OP && cur_lexical_import_ix > 0 && (HV*)SvRV(AvARRAY(lexical_imports)[cur_lexical_import_ix]) == caller_stash) 3766 switch_op_interception(aTHX_ dotSUBST_OP, true); 3767} 3768 3769void lookup(SV* pkg, SV* item_name) 3770PPCODE: 3771{ 3772 STRLEN namelen; 3773 const char* name; 3774 HV* stash = nullptr; 3775 if (SvROK(pkg)) { 3776 stash = SvSTASH(SvRV(pkg)); 3777 } else if (SvPOK(pkg)) { 3778 stash = gv_stashsv(pkg, GV_NOADD_NOINIT); 3779 } else { 3780 croak_xs_usage(cv, "object || \"pkg\", \"item\""); 3781 } 3782 if (!SvPOK(item_name)) 3783 croak_xs_usage(cv, "object || \"pkg\", \"item\""); 3784 SV* result = &PL_sv_undef; 3785 if (stash) { 3786 I32 type=0; 3787 3788 name = SvPV(item_name, namelen); 3789 switch (name[0]) { 3790 case '$': 3791 type = SVt_PV, ++name, --namelen; break; 3792 case '@': 3793 type = SVt_PVAV, ++name, --namelen; break; 3794 case '%': 3795 type = SVt_PVHV, ++name, --namelen; break; 3796 case '&': 3797 type = SVt_PVCV, ++name, --namelen; break; 3798 default: 3799 if (isIDFIRST(name[0])) { 3800 type = SVt_PVCV; break; 3801 } else { 3802 Perl_croak(aTHX_ "namespaces::lookup internal error: unknown name type %c", name[0]); 3803 } 3804 } 3805 3806 GV* gv = lookup_var(aTHX_ stash, name, namelen, type, ignore_methods | ignore_undefined).first; 3807 if (gv) { 3808 SV* found = nullptr; 3809 switch (type) { 3810 case SVt_PV: 3811 found = GvSV(gv); 3812 break; 3813 case SVt_PVAV: 3814 found = (SV*)GvAV(gv); 3815 break; 3816 case SVt_PVHV: 3817 found = (SV*)GvHV(gv); 3818 break; 3819 case SVt_PVCV: 3820 found = (SV*)GvCV(gv); 3821 break; 3822 } 3823 if (found) 3824 result = sv_2mortal(newRV(found)); 3825 } 3826 } 3827 PUSHs(result); 3828} 3829 3830void lookup_sub(SV* pkg, SV* name_sv) 3831PPCODE: 3832{ 3833 HV* stash = nullptr; 3834 if (SvROK(pkg) && SvTYPE(SvRV(pkg)) == SVt_PVHV) 3835 stash = (HV*)SvRV(pkg); 3836 else if (SvPOK(pkg)) 3837 stash = gv_stashsv(pkg, GV_NOADD_NOINIT); 3838 else 3839 croak_xs_usage(cv, "\"pkg\", \"name\""); 3840 if (!SvPOK(name_sv)) 3841 croak_xs_usage(cv, "\"pkg\", \"name\""); 3842 CV* sub = nullptr; 3843 if (stash) { 3844 STRLEN name_len; 3845 const char* name = SvPV(name_sv, name_len); 3846 if (GV* sub_gv = lookup_sub_gv(aTHX_ stash, name, name_len, 0, ignore_undefined | bad_filehandle_gv | dont_create_dummy_sub).first) 3847 sub = GvCV(sub_gv); 3848 } 3849 SV* result = sub ? sv_2mortal(newRV((SV*)sub)) : &PL_sv_undef; 3850 PUSHs(result); 3851} 3852 3853void lookup_class(SV* pkg, SV* class_sv, ...) 3854PPCODE: 3855{ 3856 HV* class_stash; 3857 if (items > 3) croak_xs_usage(cv, "\"pkg\", \"class\" [, \"lex_scope_pkg\" ]"); 3858 3859 STRLEN classl; 3860 const char* classn = SvPV(class_sv, classl); 3861 HV* stash = gv_stashsv(pkg, GV_NOADD_NOINIT); 3862 if (stash) { 3863 HV* lex_ctx_stash; 3864 if (items == 3 && (pkg = ST(2), SvPOK(pkg))) { 3865 lex_ctx_stash = gv_stashsv(pkg, GV_NOADD_NOINIT); 3866 } else { 3867 lex_ctx_stash = stash; 3868 } 3869 HE* imp_gve = hv_fetch_ent(lex_ctx_stash, dot_import_key, false, SvSHARED_HASH(dot_import_key)); 3870 GV* imp_gv; 3871 I32 lex_ix = 0; 3872 if (imp_gve && (imp_gv = (GV*)HeVAL(imp_gve), SvIOKp(GvSVn(imp_gv)))) 3873 lex_ix = int(SvIVX(GvSV(imp_gv))); 3874 if ((class_stash = namespace_lookup_class_autoload(aTHX_ stash, classn, classl, lex_ix))) { 3875 dTARGET; 3876 PUSHp(HvNAME(class_stash), HvNAMELEN(class_stash)); 3877 XSRETURN(1); 3878 } 3879 } 3880 class_stash = gv_stashpvn(classn, I32(classl), GV_NOADD_NOINIT); 3881 if (class_stash && !is_dummy_pkg(aTHX_ class_stash)) { 3882 ST(0) = ST(items-1); 3883 XSRETURN(1); 3884 } 3885 XSRETURN_UNDEF; 3886} 3887 3888void lookup_class_in_caller_scope(SV* stash_ref, SV* class_sv) 3889PPCODE: 3890{ 3891 STRLEN classl; 3892 const char* classn = SvPV(class_sv, classl); 3893 HV* stash = (HV*)SvRV(stash_ref); 3894 HV* class_stash = namespace_lookup_class(aTHX_ stash, classn, classl, active_begin->cur_lex_imp); 3895 if (class_stash) { 3896 dTARGET; 3897 PUSHp(HvNAME(class_stash), HvNAMELEN(class_stash)); 3898 XSRETURN(1); 3899 } 3900 class_stash = gv_stashpvn(classn, I32(classl), GV_NOADD_NOINIT); 3901 if (class_stash && !is_dummy_pkg(aTHX_ class_stash)) { 3902 ST(0) = ST(1); 3903 XSRETURN(1); 3904 } 3905 XSRETURN_UNDEF; 3906} 3907 3908void declare_const_sub(SV* pkg, SV* name_sv) 3909PPCODE: 3910{ 3911 HV* stash; 3912 if (SvROK(pkg)) { 3913 stash = (HV*)SvRV(pkg); 3914 if (SvTYPE(stash) != SVt_PVHV) croak_xs_usage(cv, "\\stash, \"name\", const"); 3915 } else if (SvPOK(pkg)) { 3916 stash = gv_stashsv(pkg, GV_NOADD_NOINIT); 3917 if (!stash) Perl_croak(aTHX_ "package %.*s does not exist", (int)SvCUR(pkg), SvPVX(pkg)); 3918 } else { 3919 croak_xs_usage(cv, "\"pkg\", \"name\", const"); 3920 } 3921 STRLEN namelen; 3922 const char* name = SvPV(name_sv, namelen); 3923 GV* cgv = (GV*)*hv_fetch(stash, name, I32(namelen), true); 3924 if (SvOK(cgv)) { 3925 if (GvCV(cgv)) Perl_croak(aTHX_ "multiple definition of sub %.*s::%.*s", PmPrintHvNAME(stash), PmPrintGvNAME(cgv)); 3926 } else { 3927 gv_init_pvn(cgv, stash, name, namelen, GV_ADDMULTI); 3928 } 3929 CV* dummy_cv = create_dummy_sub(aTHX_ stash, cgv); 3930 // add a zero-arg prototype to avoid "mismatch" warnings 3931 static char empty[] = ""; 3932 SvPV_set(dummy_cv, empty); 3933 SvCUR_set(dummy_cv, 0); 3934 SvPOK_on(dummy_cv); 3935 propagate_sub(aTHX_ stash, cgv); 3936} 3937 3938void declare_var(SV* pkg, SV* var) 3939PPCODE: 3940{ 3941 STRLEN varnamelen; 3942 const char* varname=SvPV(var, varnamelen); 3943 HV* stash; 3944 if (SvROK(pkg)) { 3945 stash = (HV*)SvRV(pkg); 3946 if (SvTYPE(stash) != SVt_PVHV) croak_xs_usage(cv, "\\stash, \"[$@%%]varname\""); 3947 } else if (SvPOK(pkg)) { 3948 stash = gv_stashsv(pkg, GV_NOADD_NOINIT); 3949 if (!stash) Perl_croak(aTHX_ "package %.*s does not exist", (int)SvCUR(pkg), SvPVX(pkg)); 3950 } else { 3951 croak_xs_usage(cv, "\"pkg\", \"[$@%%]varname\""); 3952 } 3953 GV* gv = *(GV**)hv_fetch(stash, varname+1, I32(varnamelen-1), true); 3954 if (SvTYPE(gv) != SVt_PVGV) 3955 gv_init_pvn(gv, stash, varname+1, varnamelen-1, GV_ADDMULTI); 3956 SV* sv=nullptr; 3957 switch (varname[0]) { 3958 case '$': 3959 sv = GvSVn(gv); 3960 GvIMPORTED_SV_on(gv); 3961 break; 3962 case '@': 3963 sv = (SV*)GvAVn(gv); 3964 GvIMPORTED_AV_on(gv); 3965 break; 3966 case '%': 3967 sv = (SV*)GvHVn(gv); 3968 GvIMPORTED_HV_on(gv); 3969 break; 3970 default: 3971 Perl_croak(aTHX_ "unknown variable type '%c': one of [$@%%] expected", varname[0]); 3972 } 3973 if (GIMME_V != G_VOID) PUSHs(sv_2mortal(newRV(sv))); 3974} 3975 3976void intercept_operation(SV* pkg, SV* opname_sv, SV* subr, ...) 3977PPCODE: 3978{ 3979 HV* stash = SvPOK(pkg) ? gv_stashsv(pkg, GV_NOADD_NOINIT) : SvROK(pkg) ? (HV*)SvRV(pkg) : CopSTASH(PL_curcop); 3980 SV* add_arg = items == 4 ? ST(3) : nullptr; 3981 3982 if (!stash || SvTYPE(stash) != SVt_PVHV || items>4) 3983 croak_xs_usage(cv, "\"pkg\" | undef, \"op_sign\", \\&sub [, first_arg ]"); 3984 3985 AV* dotSUBST_OP=get_dotSUBST_OP(aTHX_ stash, true); 3986 STRLEN opname_len; 3987 const char* opname = SvPV(opname_sv, opname_len); 3988 switch (opname_len) { 3989 case 1: 3990 switch (*opname) { 3991 case '/': { 3992 if (!(SvROK(subr) && SvTYPE(SvRV(subr)) == SVt_PVCV)) 3993 Perl_croak(aTHX_ "subroutine reference expected"); 3994 AV* op_descr1 = newAV(); 3995 AV* op_descr2 = newAV(); 3996 SV* reset_sv = newSVuv((UV)PL_check[OP_DIVIDE]); 3997 SV* catch_sv = newSVuv((UV)&intercept_ck_divide); 3998 av_extend(op_descr1, intercept_op_last); 3999 av_extend(op_descr2, intercept_op_last); 4000 av_store(op_descr1, intercept_op_code, newSViv(OP_DIVIDE)); 4001 av_store(op_descr2, intercept_op_code, newSViv(OP_I_DIVIDE)); 4002 av_store(op_descr1, intercept_op_subref, SvREFCNT_inc_simple_NN(subr)); 4003 av_store(op_descr2, intercept_op_subref, SvREFCNT_inc_simple_NN(subr)); 4004 if (add_arg) { 4005 av_store(op_descr1, intercept_op_addarg, newSVsv(add_arg)); 4006 av_store(op_descr2, intercept_op_addarg, newSVsv(add_arg)); 4007 } 4008 av_store(op_descr1, intercept_op_reset, reset_sv); 4009 av_store(op_descr2, intercept_op_reset, SvREFCNT_inc_simple_NN(reset_sv)); 4010 av_store(op_descr1, intercept_op_catch, catch_sv); 4011 av_store(op_descr2, intercept_op_catch, SvREFCNT_inc_simple_NN(catch_sv)); 4012 av_push(dotSUBST_OP, newRV_noinc((SV*)op_descr1)); 4013 av_push(dotSUBST_OP, newRV_noinc((SV*)op_descr2)); 4014 XSRETURN_EMPTY; 4015 } 4016 case '~': { 4017 if (!(SvROK(subr) && SvTYPE(SvRV(subr)) == SVt_PVCV)) 4018 Perl_croak(aTHX_ "subroutine reference expected"); 4019 AV* op_descr = newAV(); 4020 SV* reset_sv = newSVuv((UV)PL_check[OP_COMPLEMENT]); 4021 SV* catch_sv = newSVuv((UV)&intercept_ck_anonlist); 4022 av_extend(op_descr, intercept_op_last); 4023 av_store(op_descr, intercept_op_code, newSViv(OP_COMPLEMENT)); 4024 av_store(op_descr, intercept_op_subref, SvREFCNT_inc_simple_NN(subr)); 4025 if (add_arg) 4026 av_store(op_descr, intercept_op_addarg, newSVsv(add_arg)); 4027 av_store(op_descr, intercept_op_reset, reset_sv); 4028 av_store(op_descr, intercept_op_catch, catch_sv); 4029 av_push(dotSUBST_OP, newRV_noinc((SV*)op_descr)); 4030 XSRETURN_EMPTY; 4031 } 4032 break; 4033 } 4034 case 3: 4035 if (!strncmp(opname, "INT", 3)) { 4036 if (!(SvROK(subr) && SvTYPE(SvRV(subr)) == SVt_PVCV)) 4037 Perl_croak(aTHX_ "subroutine reference expected"); 4038 AV* op_descr1 = newAV(); 4039 AV* op_descr2 = newAV(); 4040 SV* reset_negate_sv = newSVuv((UV)PL_check[OP_NEGATE]); 4041 SV* catch_negate_sv = newSVuv((UV)&intercept_ck_negate); 4042 av_extend(op_descr1, intercept_op_last); 4043 av_extend(op_descr2, intercept_op_last); 4044 av_store(op_descr1, intercept_op_code, newSViv('I' + ('N'<<8) + ('T'<<16))); 4045 av_store(op_descr2, intercept_op_code, newSViv(OP_NEGATE)); 4046 av_store(op_descr1, intercept_op_subref, SvREFCNT_inc_simple_NN(subr)); 4047 if (add_arg) 4048 av_store(op_descr1, intercept_op_addarg, newSVsv(add_arg)); 4049 av_store(op_descr2, intercept_op_reset, reset_negate_sv); 4050 av_store(op_descr2, intercept_op_catch, catch_negate_sv); 4051 av_push(dotSUBST_OP, newRV_noinc((SV*)op_descr1)); 4052 av_push(dotSUBST_OP, newRV_noinc((SV*)op_descr2)); 4053 XSRETURN_EMPTY; 4054 } 4055 break; 4056 case 5: 4057 if (!strncmp(opname, "print", 5)) { 4058 if (!(SvPOK(subr) && SvCUR(subr)==4 && !strncmp(SvPVX(subr), "bool", 4))) 4059 Perl_croak(aTHX_ "only 'bool' print option supported"); 4060 AV* op_descr = newAV(); 4061 SV* reset_sv = newSVuv((UV)def_ck_PRINT); 4062 SV* catch_sv = newSVuv((UV)&intercept_ck_print); 4063 av_extend(op_descr, intercept_op_last); 4064 av_store(op_descr, intercept_op_code, newSViv(OP_PRINT)); 4065 av_store(op_descr, intercept_op_reset, reset_sv); 4066 av_store(op_descr, intercept_op_catch, catch_sv); 4067 av_push(dotSUBST_OP, newRV_noinc((SV*)op_descr)); 4068 XSRETURN_EMPTY; 4069 } 4070 break; 4071 case 6: 4072 if (!strncmp(opname, "system", 6)) { 4073 if (!(SvROK(subr) && SvTYPE(SvRV(subr)) == SVt_PVCV)) 4074 Perl_croak(aTHX_ "subroutine reference expected"); 4075 AV* op_descr = newAV(); 4076 SV* reset_sv = newSVuv((UV)def_ck_SYSTEM); 4077 SV* catch_sv = newSVuv((UV)&intercept_ck_system); 4078 av_extend(op_descr, intercept_op_last); 4079 av_store(op_descr, intercept_op_code, newSViv(OP_SYSTEM)); 4080 av_store(op_descr, intercept_op_subref, SvREFCNT_inc_simple_NN(subr)); 4081 av_store(op_descr, intercept_op_reset, reset_sv); 4082 av_store(op_descr, intercept_op_catch, catch_sv); 4083 av_push(dotSUBST_OP, newRV_noinc((SV*)op_descr)); 4084 XSRETURN_EMPTY; 4085 } 4086 break; 4087 } 4088 Perl_croak(aTHX_ "unknown operation '%.*s'", (int)opname_len, opname); 4089} 4090 4091 4092void caller_scope() 4093PPCODE: 4094{ 4095 dTARGET; 4096 if (imported_from_mode(aTHX)) 4097 sv_setpvf(TARG, "use namespaces %d ();", active_begin->cur_lex_imp); 4098 else 4099 sv_setpvn(TARG, "no namespaces;", 14); 4100 XPUSHs(TARG); 4101} 4102 4103void fall_off_to_nextstate(SV* subr) 4104PPCODE: 4105{ 4106 SV* sub; 4107 if (SvROK(subr) && (sub = SvRV(subr), SvTYPE(sub) == SVt_PVCV) && !CvISXSUB(sub) && CvROOT(sub)->op_type == OP_LEAVESUB) { 4108 CvROOT(sub)->op_ppaddr = &pp_fall_off_to_nextstate; 4109 } else { 4110 croak_xs_usage(cv, "\\&sub"); 4111 } 4112} 4113 4114void skip_return() 4115PPCODE: 4116{ 4117 PERL_CONTEXT* cx; 4118 OP* op_next_state; 4119 std::tie(op_next_state, cx) = next_statement_in_caller(aTHX); 4120 if (op_next_state) { 4121 op_next_state->op_ppaddr = &pp_popmark_and_nextstate; 4122 cx->blk_sub.retop = op_next_state; 4123 } 4124} 4125 4126void store_explicit_typelist(SV* args_ref) 4127PPCODE: 4128{ 4129 AV* args = (AV*)SvRV(args_ref); 4130 MAGIC* mg = fetch_explicit_typelist_magic(aTHX_ (SV*)args); 4131 dTARGET; 4132 if (!mg) { 4133 SV* list_ref; 4134 AV* src_av; 4135 AV* dst_av = nullptr; 4136 I32 num_types = 0; 4137 if (AvFILLp(args) >= 0 && 4138 (list_ref = AvARRAY(args)[0], SvROK(list_ref)) && 4139 (src_av = (AV*)SvRV(list_ref), 4140 SvTYPE(src_av) == SVt_PVAV && SvSTASH(src_av) == ExplicitTypelist_stash)) { 4141 list_ref = av_shift(args); 4142 if (AvREAL(args)) SvREFCNT_dec(list_ref); // account for shift() 4143 num_types = I32(AvFILLp(src_av)+1); 4144 assert(num_types != 0); 4145 if (SvREADONLY(list_ref)) { 4146 // the type list constructed once; make a temporary copy, because it can be changed during type deduction 4147 dst_av = newAV(); 4148 av_fill(dst_av, num_types-1); 4149 SV** dst = AvARRAY(dst_av); 4150 for (SV **src = AvARRAY(src_av), **const src_end = src + num_types; src < src_end; ++src, ++dst) 4151 *dst = SvREFCNT_inc_simple_NN(*src); 4152 list_ref = newRV_noinc((SV*)dst_av); 4153 } 4154 } else { 4155 dst_av = newAV(); 4156 list_ref = newRV_noinc((SV*)dst_av); 4157 } 4158 mg = sv_magicext((SV*)args, list_ref, PERL_MAGIC_ext, &explicit_typelist_vtbl, nullptr, 0); 4159 if (dst_av) SvREFCNT_dec(list_ref); // list_ref is exclusively owned by MAGIC, but sv_magicext always bumps the refcounter 4160 mg->mg_private = U8(num_types); 4161 } 4162 PUSHi(mg->mg_private); 4163 if (GIMME_V == G_ARRAY) XPUSHs(mg->mg_obj); 4164} 4165 4166void fetch_explicit_typelist(SV* args_ref) 4167PPCODE: 4168{ 4169 MAGIC* mg = fetch_explicit_typelist_magic(aTHX_ SvRV(args_ref)); 4170 if (mg) { 4171 PUSHs(mg->mg_obj); 4172 if (GIMME_V == G_ARRAY) { 4173 dTARGET; 4174 XPUSHi(mg->mg_private); 4175 } 4176 } 4177} 4178 4179void collecting_coverage() 4180PPCODE: 4181{ 4182#if defined(POLYMAKE_GATHER_CODE_COVERAGE) 4183 if (cov_stats) 4184 XSRETURN_YES; 4185#endif 4186 XSRETURN_NO; 4187} 4188 4189void flush_coverage_stats() 4190PPCODE: 4191{ 4192#if defined(POLYMAKE_GATHER_CODE_COVERAGE) 4193 if (covfile) { 4194 HE* entry; 4195 hv_iterinit(cov_stats); 4196 while ((entry = hv_iternext(cov_stats))) { 4197 STRLEN srcfile_len; 4198 AV* hits_av=(AV*)SvRV(HeVAL(entry)); 4199 if (AvFILLp(hits_av) >= 0) { 4200 const char* srcfile=HePV(entry, srcfile_len); 4201 fwrite(srcfile, 1, srcfile_len, covfile); 4202 for (SV **hit=&AvARRAY(hits_av)[0], **hit_last=hit+AvFILLp(hits_av); 4203 hit <= hit_last; ++hit) { 4204 if ((PerlVersion < 5200 || *hit) && SvIOK(*hit)) { 4205 fprintf(covfile, " %d", (int)SvIVX(*hit)); 4206 } else { 4207 fwrite(" -", 1, 2, covfile); 4208 } 4209 } 4210 fputc('\n', covfile); 4211 } 4212 } 4213 fclose(covfile); 4214 } 4215#endif 4216} 4217 4218MODULE = namespaces PACKAGE = namespaces::AnonLvalue 4219 4220void import(SV* pkg, ...) 4221PPCODE: 4222{ 4223 if (items == 1) { 4224 store_anon_lvalue_flag(aTHX_ newSViv(1)); 4225 } else if (items == 2) { 4226 SV* varname = ST(1); 4227 if (SvPOK(varname) && SvCUR(varname) >= 2 || SvPVX(varname)[0] == '$') 4228 store_anon_lvalue_flag(aTHX_ varname); 4229 else 4230 croak_xs_usage(cv, "$varname"); 4231 } else { 4232 croak_xs_usage(cv, "[ $varname ]"); 4233 } 4234 PERL_UNUSED_ARG(pkg); 4235} 4236 4237MODULE = namespaces PACKAGE = namespaces::Params 4238 4239void import(...) 4240PPCODE: 4241{ 4242 AV* store_names_in = nullptr; 4243 int first_name = 0; 4244 SV* lead = ST(1); 4245 GV* list_gv = nullptr; 4246 4247 MAGIC hint_mg; 4248 hint_mg.mg_len = HEf_SVKEY; 4249 4250 if (items <= 1) 4251 croak_xs_usage(cv, "[ *glob | \\*glob ] 'PARAM1' ..."); 4252 4253 if (SvTYPE(lead) == SVt_PVGV) { 4254 // scope level 4255 list_gv = (GV*)lead; 4256 4257 if (items == 2) { 4258 // reopening an object scope 4259 if (!GvAV(list_gv)) XSRETURN_EMPTY; 4260 } else { 4261 // declaring a new type 4262 store_names_in = GvAVn(list_gv); 4263 GvIMPORTED_AV_on(list_gv); 4264 first_name = 2; 4265 } 4266 hint_mg.mg_ptr = (char*)scope_type_params_key; 4267 SvUVX(uv_hint) = (size_t)list_gv; 4268 Perl_magic_sethint(aTHX_ uv_hint, &hint_mg); 4269 4270 } else { 4271 // sub level 4272 if (SvROK(lead)) { 4273 // prototype objects stored in a persistent array or passed directly in @_ 4274 list_gv = (GV*)SvRV(lead); 4275 if (SvTYPE(list_gv) != SVt_PVGV || 4276 (items == 2) != (list_gv == PL_defgv)) 4277 croak_xs_usage(cv, "[ *glob | \\*glob ] 'PARAM1' ... or \\*_"); 4278 4279 if (items > 2) { 4280 store_names_in = type_param_names; 4281 first_name = 2; 4282 } 4283 } else { 4284 if (items > 2 && !SvOK(lead) && SvPADMY(lead)) { 4285 // prototype object array reference stored in a local variable 4286#if PerlVersion >= 5180 4287 CV* compiled_cv =PL_compcv; 4288 PADOFFSET my_var_padix = PL_comppad_name_fill; 4289#else 4290 // For BEGIN block a separate compcv was created 4291 CV* compiled_cv = PL_compcv->sv_any->xcv_outside; 4292 PADOFFSET my_var_padix = AvFILLp(AvARRAY(compiled_cv->sv_any->xcv_padlist)[0]); 4293#endif 4294 for (; my_var_padix > 0; --my_var_padix) { 4295 auto pad_list = CvPADLIST(compiled_cv); 4296 SV* my_var = PAD_BASE_SV(pad_list, my_var_padix); 4297 if (my_var == lead) { 4298 list_gv = reinterpret_cast<GV*>(my_var_padix); 4299 break; 4300 } 4301 } 4302 if (my_var_padix == 0) 4303 Perl_croak(aTHX_ "passed lexical variable not found in the current PAD"); 4304 first_name = 2; 4305 } else { 4306 // prototype objects MAGICally attached to @_ 4307 first_name = 1; 4308 } 4309 store_names_in = type_param_names; 4310 } 4311 hint_mg.mg_ptr = (char*)sub_type_params_key; 4312 SvUVX(uv_hint) = (size_t)list_gv; 4313 Perl_magic_sethint(aTHX_ uv_hint, &hint_mg); 4314 } 4315 if (store_names_in) { 4316 av_fill(store_names_in, items-first_name-1); 4317 for (SV** store_names_at = AvARRAY(store_names_in); first_name < items; ++store_names_at, ++first_name) 4318 *store_names_at = SvREFCNT_inc_simple_NN(ST(first_name)); 4319 } 4320} 4321 4322MODULE = namespaces PACKAGE = namespaces::BeginAV 4323 4324void PUSH(SV* avref, SV* sv) 4325PPCODE: 4326{ 4327 // This is called immediately before execution of the BEGIN subroutine. 4328 // Its task is to temporarily switch off the compilation mode unless this is the follow-up 'use namespaces' 4329 SV* beginav = SvRV(avref); 4330 CV* begin_cv = (CV*)sv; 4331 bool require_seen = false; 4332 OP* rootop = CvROOT(begin_cv); 4333 assert(beginav == (SV*)PL_beginav_save); 4334 assert(rootop->op_type == OP_LEAVESUB); 4335 OP* o = cUNOPx(rootop)->op_first; // lineseq? 4336 if (!OpHAS_SIBLING(o)) o = cUNOPo->op_first; 4337 while ((o = OpSIBLING(o))) { 4338 if (o->op_type == OP_REQUIRE) { 4339 o = cUNOPo->op_first; 4340 SV* filename = cSVOPo->op_sv; 4341 if (!filename) 4342 filename = PadARRAY((PadlistARRAY(CvPADLIST(begin_cv)))[1])[o->op_targ]; 4343 if (hv_exists_ent(special_imports, filename, 0)) { 4344 SvRMAGICAL_off(beginav); 4345 av_push((AV*)beginav, sv); 4346 SvRMAGICAL_on(beginav); 4347 return; 4348 } 4349 require_seen = true; 4350 break; 4351 } 4352 } 4353 ToRestore* to_restore = newToRestore(aTHX_ true); 4354 active_begin = to_restore; 4355 reset_ptrs(aTHX_ nullptr); 4356 rootop->op_ppaddr = &intercept_pp_leavesub; 4357 if (require_seen) { 4358 to_restore->cv = begin_cv; 4359 cur_lexical_import_ix = -1; 4360 cur_lexical_flags = 0; 4361 } 4362 av_push((AV*)beginav, sv); 4363} 4364 4365 4366BOOT: 4367{ 4368 lexical_imports = get_av("namespaces::LEXICAL_IMPORTS", TRUE); 4369 plugin_data = get_av("namespaces::PLUGINS", TRUE); 4370 plugin_code = get_sv("namespaces::PLUGINS", TRUE); 4371 sv_setpvn(plugin_code, "", 0); 4372 4373 ExplicitTypelist_stash = get_named_stash(aTHX_ "namespaces::ExplicitTypelist", GV_ADD); 4374 args_lookup_stash = get_named_stash(aTHX_ "args", GV_ADD); 4375 special_imports = get_hv("namespaces::special_imports", TRUE); 4376 4377 if (PL_DBgv) { 4378 // find the initialization of $usercontext in sub DB::DB and inject our code there 4379 const polymake::AnyString usercontext("usercontext"); 4380 for (OP* o = CvSTART(GvCV(PL_DBgv)); o; o = OpSIBLING(o)) { 4381 if (o->op_type == OP_SASSIGN) { 4382 OP* gvop = cBINOPo->op_last; 4383 if (gvop->op_type == OP_NULL) 4384 gvop = cUNOPx(gvop)->op_first; 4385 if (gvop->op_type == OP_GVSV) { 4386#ifdef USE_ITHREADS 4387 SV **saved_curpad = PL_curpad; 4388 PL_curpad = PadARRAY((PadlistARRAY(CvPADLIST(GvCV(PL_DBgv))))[1]); 4389#endif 4390 GV* gv = cGVOPx_gv(gvop); 4391#ifdef USE_ITHREADS 4392 PL_curpad = saved_curpad; 4393#endif 4394 if (size_t(GvNAMELEN(gv)) == usercontext.len && !strncmp(GvNAME(gv), usercontext.ptr, usercontext.len)) { 4395 o = cBINOPo->op_first; 4396 if (o->op_type == OP_CONCAT) { 4397 // perl <= 5.16 4398 OP* const_op = cBINOPo->op_first; 4399 OP* null_op = cBINOPo->op_last; 4400 if (null_op->op_type == OP_NULL) { 4401 null_op->op_ppaddr = &db_caller_scope; 4402 null_op->op_next = const_op->op_next; 4403 const_op->op_next = null_op; 4404 } 4405 } else if (o->op_type == OP_ENTERSUB) { 4406 // perl >= 5.18 4407 OP* null_op = cUNOPo->op_first; 4408 if (null_op->op_type == OP_NULL) { 4409 null_op->op_ppaddr = &db_caller_scope; 4410 null_op->op_next = o->op_next; 4411 o->op_next = null_op; 4412 } 4413 } 4414 break; 4415 } 4416 } 4417 } 4418 } 4419 CvNODEBUG_on(get_cv("namespaces::import", FALSE)); 4420 CvNODEBUG_on(get_cv("namespaces::unimport", FALSE)); 4421 CvNODEBUG_on(get_cv("namespaces::temp_disable", FALSE)); 4422 CvNODEBUG_on(get_cv("namespaces::intercept_operation", FALSE)); 4423 CvNODEBUG_on(get_cv("namespaces::caller_scope", FALSE)); 4424 CvNODEBUG_on(get_cv("namespaces::skip_return", FALSE)); 4425 CvNODEBUG_on(get_cv("namespaces::store_explicit_typelist", FALSE)); 4426 CvNODEBUG_on(get_cv("namespaces::fetch_explicit_typelist", FALSE)); 4427 CvNODEBUG_on(get_cv("namespaces::Params::import", FALSE)); 4428 CvNODEBUG_on(get_cv("namespaces::BeginAV::PUSH", FALSE)); 4429 } 4430 def_pp_GV = PL_ppaddr[OP_GV]; 4431 def_pp_GVSV = PL_ppaddr[OP_GVSV]; 4432 def_pp_AELEMFAST = PL_ppaddr[OP_AELEMFAST]; 4433 def_pp_PADAV = PL_ppaddr[OP_PADAV]; 4434 def_pp_SPLIT = PL_ppaddr[OP_SPLIT]; 4435 def_pp_LEAVESUB = PL_ppaddr[OP_LEAVESUB]; 4436 def_pp_ENTEREVAL = PL_ppaddr[OP_ENTEREVAL]; 4437 def_pp_REGCOMP = PL_ppaddr[OP_REGCOMP]; 4438 def_pp_NEXTSTATE = PL_ppaddr[OP_NEXTSTATE]; 4439 def_pp_DBSTATE = PL_ppaddr[OP_DBSTATE]; 4440 def_pp_ANONLIST = PL_ppaddr[OP_ANONLIST]; 4441 def_pp_ANONCODE = PL_ppaddr[OP_ANONCODE]; 4442 def_pp_SASSIGN = PL_ppaddr[OP_SASSIGN]; 4443 def_pp_PRINT = PL_ppaddr[OP_PRINT]; 4444#if PerlVersion >= 5220 4445 def_pp_MULTIDEREF = PL_ppaddr[OP_MULTIDEREF]; 4446#endif 4447 def_ck_CONST = PL_check[OP_CONST]; 4448 def_ck_ENTERSUB = PL_check[OP_ENTERSUB]; 4449 def_ck_LEAVESUB = PL_check[OP_LEAVESUB]; 4450 def_ck_LEAVEEVAL = PL_check[OP_LEAVEEVAL]; 4451 def_ck_GV = PL_check[OP_GV]; 4452 def_ck_RV2SV = PL_check[OP_RV2SV]; 4453 def_ck_RV2AV = PL_check[OP_RV2AV]; 4454 def_ck_RV2HV = PL_check[OP_RV2HV]; 4455 def_ck_RV2CV = PL_check[OP_RV2CV]; 4456 def_ck_ANONCODE = PL_check[OP_ANONCODE]; 4457 def_ck_PRINT = PL_check[OP_PRINT]; 4458 def_ck_SYSTEM = PL_check[OP_SYSTEM]; 4459 def_kw_plugin = PL_keyword_plugin; 4460 4461 pm::perl::ops::init_globals(aTHX); 4462 4463 if (!PL_beginav_save) 4464 PL_beginav_save = newAV(); 4465 4466 SV* beginav = (SV*)PL_beginav_save; 4467 HV* beginav_stash = get_named_stash(aTHX_ "namespaces::BeginAV", GV_ADD); 4468 SV* beginav_ref = sv_2mortal(newRV(beginav)); 4469 sv_bless(beginav_ref, beginav_stash); 4470 sv_magicext(beginav, nullptr, PERL_MAGIC_tied, nullptr, nullptr, 0); 4471 SvMAGICAL_off(beginav); 4472#if defined(POLYMAKE_GATHER_CODE_COVERAGE) 4473 if (const char* covfilename = getenv("POLYMAKE_COVERAGE_FILE")) { 4474 const char* open_mode = "w"; 4475 if (covfilename[0] == '+') { 4476 open_mode = "a"; 4477 ++covfilename; 4478 } 4479 covfile = fopen(covfilename, open_mode); 4480 if (!covfile) 4481 Perl_croak(aTHX_ "can't create coverage file %s: %s\n", covfilename, Strerror(errno)); 4482 def_peep = PL_peepp; 4483 cov_stats = newHV(); 4484 Perl_av_create_and_push(aTHX_ &PL_endav, SvREFCNT_inc(get_cv("namespaces::flush_coverage_stats", FALSE))); 4485 } 4486#endif 4487 dot_lookup_key = newSVpvn_share(".LOOKUP",7,0); 4488 dot_import_key = newSVpvn_share(".IMPORT",7,0); 4489 dot_dummy_pkg_key = newSVpvn_share(".DUMMY_PKG",10,0); 4490 dot_subst_op_key = newSVpvn_share(".SUBST_OP",9,0); 4491 lex_imp_key = newSVpvn_share("lex_imp",7,0); 4492 sub_type_params_key = newSVpvn_share("sub_typp",8,0); 4493 scope_type_params_key = newSVpvn_share("scp_typp",8,0); 4494 anon_lvalue_key = newSVpvn_share("anonlval",8,0); 4495 type_param_names = newAV(); 4496 iv_hint = newSViv(0); 4497 uv_hint = newSVuv(0); 4498} 4499 4500=pod 4501// Local Variables: 4502// mode:C++ 4503// c-basic-offset:3 4504// indent-tabs-mode:nil 4505// End: 4506=cut 4507