mathoms.c

   1 /*    mathoms.c
   2  *
   3  *    Copyright (C) 2005, 2006, 2007, 2007, by Larry Wall and others
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "Anything that Hobbits had no immediate use for, but were unwilling to
  12  * throw away, they called a mathom. Their dwellings were apt to become
  13  * rather crowded with mathoms, and many of the presents that passed from
  14  * hand to hand were of that sort."
  15  */
  16
  17 #ifndef NO_MATHOMS
  18
  19 /*
  20  * This file contains mathoms, various binary artifacts from previous
  21  * versions of Perl.  For binary or source compatibility reasons, though,
  22  * we cannot completely remove them from the core code.
  23  *
  24  * SMP - Oct. 24, 2005
  25  *
  26  */
  27
  28 #include "EXTERN.h"
  29 #define PERL_IN_MATHOMS_C
  30 #include "perl.h"
  31
  32 PERL_CALLCONV OP * Perl_ref(pTHX_ OP *o, I32 type);
  33 PERL_CALLCONV void Perl_sv_unref(pTHX_ SV *sv);
  34 PERL_CALLCONV void Perl_sv_taint(pTHX_ SV *sv);
  35 PERL_CALLCONV IV Perl_sv_2iv(pTHX_ register SV *sv);
  36 PERL_CALLCONV UV Perl_sv_2uv(pTHX_ register SV *sv);
  37 PERL_CALLCONV char * Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp);
  38 PERL_CALLCONV char * Perl_sv_2pv_nolen(pTHX_ register SV *sv);
  39 PERL_CALLCONV char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv);
  40 PERL_CALLCONV char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv);
  41 PERL_CALLCONV void Perl_sv_force_normal(pTHX_ register SV *sv);
  42 PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr);
  43 PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen);
  44 PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len);
  45 PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr);
  46 PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv);
  47 PERL_CALLCONV char * Perl_sv_pv(pTHX_ SV *sv);
  48 PERL_CALLCONV char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp);
  49 PERL_CALLCONV char * Perl_sv_pvbyte(pTHX_ SV *sv);
  50 PERL_CALLCONV char * Perl_sv_pvutf8(pTHX_ SV *sv);
  51 PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv);
  52 PERL_CALLCONV NV Perl_huge(void);
  53 PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
  54 PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
  55 PERL_CALLCONV GV * Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name);
  56 PERL_CALLCONV HE * Perl_hv_iternext(pTHX_ HV *hv);
  57 PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how);
  58 PERL_CALLCONV bool Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp);
  59 PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp);
  60 PERL_CALLCONV bool Perl_do_exec(pTHX_ const char *cmd);
  61 PERL_CALLCONV U8 * Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv);
  62 PERL_CALLCONV bool Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep);
  63 PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv);
  64 PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len);
  65 PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len);
  66 PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...);
  67 PERL_CALLCONV int Perl_printf_nocontext(const char *format, ...);
  68 PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg);
  69 PERL_CALLCONV AV * Perl_newAV(pTHX);
  70 PERL_CALLCONV HV * Perl_newHV(pTHX);
  71
  72 /* ref() is now a macro using Perl_doref;
  73  * this version provided for binary compatibility only.
  74  */
  75 OP *
  76 Perl_ref(pTHX_ OP *o, I32 type)
  77 {
  78     return doref(o, type, TRUE);
  79 }
  80
  81 /*
  82 =for apidoc sv_unref
  83
  84 Unsets the RV status of the SV, and decrements the reference count of
  85 whatever was being referenced by the RV.  This can almost be thought of
  86 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
  87 being zero.  See C<SvROK_off>.
  88
  89 =cut
  90 */
  91
  92 void
  93 Perl_sv_unref(pTHX_ SV *sv)
  94 {
  95     PERL_ARGS_ASSERT_SV_UNREF;
  96
  97     sv_unref_flags(sv, 0);
  98 }
  99
 100 /*
 101 =for apidoc sv_taint
 102
 103 Taint an SV. Use C<SvTAINTED_on> instead.
 104 =cut
 105 */
 106
 107 void
 108 Perl_sv_taint(pTHX_ SV *sv)
 109 {
 110     PERL_ARGS_ASSERT_SV_TAINT;
 111
 112     sv_magic((sv), NULL, PERL_MAGIC_taint, NULL, 0);
 113 }
 114
 115 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
 116  * this function provided for binary compatibility only
 117  */
 118
 119 IV
 120 Perl_sv_2iv(pTHX_ register SV *sv)
 121 {
 122     return sv_2iv_flags(sv, SV_GMAGIC);
 123 }
 124
 125 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
 126  * this function provided for binary compatibility only
 127  */
 128
 129 UV
 130 Perl_sv_2uv(pTHX_ register SV *sv)
 131 {
 132     return sv_2uv_flags(sv, SV_GMAGIC);
 133 }
 134
 135 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
 136  * this function provided for binary compatibility only
 137  */
 138
 139 char *
 140 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
 141 {
 142     return sv_2pv_flags(sv, lp, SV_GMAGIC);
 143 }
 144
 145 /*
 146 =for apidoc sv_2pv_nolen
 147
 148 Like C<sv_2pv()>, but doesn't return the length too. You should usually
 149 use the macro wrapper C<SvPV_nolen(sv)> instead.
 150 =cut
 151 */
 152
 153 char *
 154 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
 155 {
 156     return sv_2pv(sv, NULL);
 157 }
 158
 159 /*
 160 =for apidoc sv_2pvbyte_nolen
 161
 162 Return a pointer to the byte-encoded representation of the SV.
 163 May cause the SV to be downgraded from UTF-8 as a side-effect.
 164
 165 Usually accessed via the C<SvPVbyte_nolen> macro.
 166
 167 =cut
 168 */
 169
 170 char *
 171 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
 172 {
 173     PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN;
 174
 175     return sv_2pvbyte(sv, NULL);
 176 }
 177
 178 /*
 179 =for apidoc sv_2pvutf8_nolen
 180
 181 Return a pointer to the UTF-8-encoded representation of the SV.
 182 May cause the SV to be upgraded to UTF-8 as a side-effect.
 183
 184 Usually accessed via the C<SvPVutf8_nolen> macro.
 185
 186 =cut
 187 */
 188
 189 char *
 190 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
 191 {
 192     PERL_ARGS_ASSERT_SV_2PVUTF8_NOLEN;
 193
 194     return sv_2pvutf8(sv, NULL);
 195 }
 196
 197 /*
 198 =for apidoc sv_force_normal
 199
 200 Undo various types of fakery on an SV: if the PV is a shared string, make
 201 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
 202 an xpvmg. See also C<sv_force_normal_flags>.
 203
 204 =cut
 205 */
 206
 207 void
 208 Perl_sv_force_normal(pTHX_ register SV *sv)
 209 {
 210     PERL_ARGS_ASSERT_SV_FORCE_NORMAL;
 211
 212     sv_force_normal_flags(sv, 0);
 213 }
 214
 215 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
 216  * this function provided for binary compatibility only
 217  */
 218
 219 void
 220 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 221 {
 222     PERL_ARGS_ASSERT_SV_SETSV;
 223
 224     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
 225 }
 226
 227 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
 228  * this function provided for binary compatibility only
 229  */
 230
 231 void
 232 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
 233 {
 234     PERL_ARGS_ASSERT_SV_CATPVN;
 235
 236     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
 237 }
 238
 239 /*
 240 =for apidoc sv_catpvn_mg
 241
 242 Like C<sv_catpvn>, but also handles 'set' magic.
 243
 244 =cut
 245 */
 246
 247 void
 248 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
 249 {
 250     PERL_ARGS_ASSERT_SV_CATPVN_MG;
 251
 252     sv_catpvn_flags(sv,ptr,len,SV_GMAGIC|SV_SMAGIC);
 253 }
 254
 255 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
 256  * this function provided for binary compatibility only
 257  */
 258
 259 void
 260 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
 261 {
 262     PERL_ARGS_ASSERT_SV_CATSV;
 263
 264     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
 265 }
 266
 267 /*
 268 =for apidoc sv_catsv_mg
 269
 270 Like C<sv_catsv>, but also handles 'set' magic.
 271
 272 =cut
 273 */
 274
 275 void
 276 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
 277 {
 278     PERL_ARGS_ASSERT_SV_CATSV_MG;
 279
 280     sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC);
 281 }
 282
 283 /*
 284 =for apidoc sv_iv
 285
 286 A private implementation of the C<SvIVx> macro for compilers which can't
 287 cope with complex macro expressions. Always use the macro instead.
 288
 289 =cut
 290 */
 291
 292 IV
 293 Perl_sv_iv(pTHX_ register SV *sv)
 294 {
 295     PERL_ARGS_ASSERT_SV_IV;
 296
 297     if (SvIOK(sv)) {
 298         if (SvIsUV(sv))
 299             return (IV)SvUVX(sv);
 300         return SvIVX(sv);
 301     }
 302     return sv_2iv(sv);
 303 }
 304
 305 /*
 306 =for apidoc sv_uv
 307
 308 A private implementation of the C<SvUVx> macro for compilers which can't
 309 cope with complex macro expressions. Always use the macro instead.
 310
 311 =cut
 312 */
 313
 314 UV
 315 Perl_sv_uv(pTHX_ register SV *sv)
 316 {
 317     PERL_ARGS_ASSERT_SV_UV;
 318
 319     if (SvIOK(sv)) {
 320         if (SvIsUV(sv))
 321             return SvUVX(sv);
 322         return (UV)SvIVX(sv);
 323     }
 324     return sv_2uv(sv);
 325 }
 326
 327 /*
 328 =for apidoc sv_nv
 329
 330 A private implementation of the C<SvNVx> macro for compilers which can't
 331 cope with complex macro expressions. Always use the macro instead.
 332
 333 =cut
 334 */
 335
 336 NV
 337 Perl_sv_nv(pTHX_ register SV *sv)
 338 {
 339     PERL_ARGS_ASSERT_SV_NV;
 340
 341     if (SvNOK(sv))
 342         return SvNVX(sv);
 343     return sv_2nv(sv);
 344 }
 345
 346 /*
 347 =for apidoc sv_pv
 348
 349 Use the C<SvPV_nolen> macro instead
 350
 351 =for apidoc sv_pvn
 352
 353 A private implementation of the C<SvPV> macro for compilers which can't
 354 cope with complex macro expressions. Always use the macro instead.
 355
 356 =cut
 357 */
 358
 359 char *
 360 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
 361 {
 362     PERL_ARGS_ASSERT_SV_PVN;
 363
 364     if (SvPOK(sv)) {
 365         *lp = SvCUR(sv);
 366         return SvPVX(sv);
 367     }
 368     return sv_2pv(sv, lp);
 369 }
 370
 371
 372 char *
 373 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
 374 {
 375     PERL_ARGS_ASSERT_SV_PVN_NOMG;
 376
 377     if (SvPOK(sv)) {
 378         *lp = SvCUR(sv);
 379         return SvPVX(sv);
 380     }
 381     return sv_2pv_flags(sv, lp, 0);
 382 }
 383
 384 /* sv_pv() is now a macro using SvPV_nolen();
 385  * this function provided for binary compatibility only
 386  */
 387
 388 char *
 389 Perl_sv_pv(pTHX_ SV *sv)
 390 {
 391     PERL_ARGS_ASSERT_SV_PV;
 392
 393     if (SvPOK(sv))
 394         return SvPVX(sv);
 395
 396     return sv_2pv(sv, NULL);
 397 }
 398
 399 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
 400  * this function provided for binary compatibility only
 401  */
 402
 403 char *
 404 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 405 {
 406     PERL_ARGS_ASSERT_SV_PVN_FORCE;
 407
 408     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
 409 }
 410
 411 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
 412  * this function provided for binary compatibility only
 413  */
 414
 415 char *
 416 Perl_sv_pvbyte(pTHX_ SV *sv)
 417 {
 418     PERL_ARGS_ASSERT_SV_PVBYTE;
 419
 420     sv_utf8_downgrade(sv, FALSE);
 421     return sv_pv(sv);
 422 }
 423
 424 /*
 425 =for apidoc sv_pvbyte
 426
 427 Use C<SvPVbyte_nolen> instead.
 428
 429 =for apidoc sv_pvbyten
 430
 431 A private implementation of the C<SvPVbyte> macro for compilers
 432 which can't cope with complex macro expressions. Always use the macro
 433 instead.
 434
 435 =cut
 436 */
 437
 438 char *
 439 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
 440 {
 441     PERL_ARGS_ASSERT_SV_PVBYTEN;
 442
 443     sv_utf8_downgrade(sv, FALSE);
 444     return sv_pvn(sv,lp);
 445 }
 446
 447 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
 448  * this function provided for binary compatibility only
 449  */
 450
 451 char *
 452 Perl_sv_pvutf8(pTHX_ SV *sv)
 453 {
 454     PERL_ARGS_ASSERT_SV_PVUTF8;
 455
 456     sv_utf8_upgrade(sv);
 457     return sv_pv(sv);
 458 }
 459
 460 /*
 461 =for apidoc sv_pvutf8
 462
 463 Use the C<SvPVutf8_nolen> macro instead
 464
 465 =for apidoc sv_pvutf8n
 466
 467 A private implementation of the C<SvPVutf8> macro for compilers
 468 which can't cope with complex macro expressions. Always use the macro
 469 instead.
 470
 471 =cut
 472 */
 473
 474 char *
 475 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
 476 {
 477     PERL_ARGS_ASSERT_SV_PVUTF8N;
 478
 479     sv_utf8_upgrade(sv);
 480     return sv_pvn(sv,lp);
 481 }
 482
 483 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
 484  * this function provided for binary compatibility only
 485  */
 486
 487 STRLEN
 488 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 489 {
 490     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE;
 491
 492     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
 493 }
 494
 495 int
 496 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
 497 {
 498     dTHXs;
 499     va_list(arglist);
 500
 501     /* Easier to special case this here than in embed.pl. (Look at what it
 502        generates for proto.h) */
 503 #ifdef PERL_IMPLICIT_CONTEXT
 504     PERL_ARGS_ASSERT_FPRINTF_NOCONTEXT;
 505 #endif
 506
 507     va_start(arglist, format);
 508     return PerlIO_vprintf(stream, format, arglist);
 509 }
 510
 511 int
 512 Perl_printf_nocontext(const char *format, ...)
 513 {
 514     dTHX;
 515     va_list(arglist);
 516
 517 #ifdef PERL_IMPLICIT_CONTEXT
 518     PERL_ARGS_ASSERT_PRINTF_NOCONTEXT;
 519 #endif
 520
 521     va_start(arglist, format);
 522     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
 523 }
 524
 525 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 526 /*
 527  * This hack is to force load of "huge" support from libm.a
 528  * So it is in perl for (say) POSIX to use.
 529  * Needed for SunOS with Sun's 'acc' for example.
 530  */
 531 NV
 532 Perl_huge(void)
 533 {
 534 #  if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
 535     return HUGE_VALL;
 536 #  else
 537     return HUGE_VAL;
 538 #  endif
 539 }
 540 #endif
 541
 542 /* compatibility with versions <= 5.003. */
 543 void
 544 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
 545 {
 546     PERL_ARGS_ASSERT_GV_FULLNAME;
 547
 548     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 549 }
 550
 551 /* compatibility with versions <= 5.003. */
 552 void
 553 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
 554 {
 555     PERL_ARGS_ASSERT_GV_EFULLNAME;
 556
 557     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 558 }
 559
 560 void
 561 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 562 {
 563     PERL_ARGS_ASSERT_GV_FULLNAME3;
 564
 565     gv_fullname4(sv, gv, prefix, TRUE);
 566 }
 567
 568 void
 569 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 570 {
 571     PERL_ARGS_ASSERT_GV_EFULLNAME3;
 572
 573     gv_efullname4(sv, gv, prefix, TRUE);
 574 }
 575
 576 /*
 577 =for apidoc gv_fetchmethod
 578
 579 See L<gv_fetchmethod_autoload>.
 580
 581 =cut
 582 */
 583
 584 GV *
 585 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 586 {
 587     PERL_ARGS_ASSERT_GV_FETCHMETHOD;
 588
 589     return gv_fetchmethod_autoload(stash, name, TRUE);
 590 }
 591
 592 HE *
 593 Perl_hv_iternext(pTHX_ HV *hv)
 594 {
 595     PERL_ARGS_ASSERT_HV_ITERNEXT;
 596
 597     return hv_iternext_flags(hv, 0);
 598 }
 599
 600 void
 601 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
 602 {
 603     PERL_ARGS_ASSERT_HV_MAGIC;
 604
 605     sv_magic((SV*)hv, (SV*)gv, how, NULL, 0);
 606 }
 607
 608 AV *
 609 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
 610 {
 611     register SV** ary;
 612     register AV * const av = (AV*)newSV_type(SVt_PVAV);
 613
 614     PERL_ARGS_ASSERT_AV_FAKE;
 615
 616     Newx(ary,size+1,SV*);
 617     AvALLOC(av) = ary;
 618     Copy(strp,ary,size,SV*);
 619     AvREIFY_only(av);
 620     AvARRAY(av) = ary;
 621     AvFILLp(av) = size - 1;
 622     AvMAX(av) = size - 1;
 623     while (size--) {
 624         assert (*strp);
 625         SvTEMP_off(*strp);
 626         strp++;
 627     }
 628     return av;
 629 }
 630
 631 bool
 632 Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
 633              int rawmode, int rawperm, PerlIO *supplied_fp)
 634 {
 635     PERL_ARGS_ASSERT_DO_OPEN;
 636
 637     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 638                     supplied_fp, (SV **) NULL, 0);
 639 }
 640
 641 bool
 642 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
 643 as_raw,
 644               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
 645               I32 num_svs)
 646 {
 647     PERL_ARGS_ASSERT_DO_OPEN9;
 648
 649     PERL_UNUSED_ARG(num_svs);
 650     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 651                     supplied_fp, &svs, 1);
 652 }
 653
 654 int
 655 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 656 {
 657  /* The old body of this is now in non-LAYER part of perlio.c
 658   * This is a stub for any XS code which might have been calling it.
 659   */
 660  const char *name = ":raw";
 661
 662  PERL_ARGS_ASSERT_DO_BINMODE;
 663
 664 #ifdef PERLIO_USING_CRLF
 665  if (!(mode & O_BINARY))
 666      name = ":crlf";
 667 #endif
 668  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 669 }
 670
 671 #ifndef OS2
 672 bool
 673 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
 674 {
 675     PERL_ARGS_ASSERT_DO_AEXEC;
 676
 677     return do_aexec5(really, mark, sp, 0, 0);
 678 }
 679 #endif
 680
 681 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
 682 bool
 683 Perl_do_exec(pTHX_ const char *cmd)
 684 {
 685     PERL_ARGS_ASSERT_DO_EXEC;
 686
 687     return do_exec3(cmd,0,0);
 688 }
 689 #endif
 690
 691 /* Backwards compatibility. */
 692 int
 693 Perl_init_i18nl14n(pTHX_ int printwarn)
 694 {
 695     return init_i18nl10n(printwarn);
 696 }
 697
 698 OP *
 699 Perl_oopsCV(pTHX_ OP *o)
 700 {
 701     PERL_ARGS_ASSERT_OOPSCV;
 702
 703     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
 704     /* STUB */
 705     PERL_UNUSED_ARG(o);
 706     NORETURN_FUNCTION_END;
 707 }
 708
 709 PP(pp_padany)
 710 {
 711     DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
 712 }
 713
 714 PP(pp_mapstart)
 715 {
 716     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
 717 }
 718
 719 /* These ops all have the same body as pp_null.  */
 720 PP(pp_scalar)
 721 {
 722     dVAR;
 723     return NORMAL;
 724 }
 725
 726 PP(pp_regcmaybe)
 727 {
 728     dVAR;
 729     return NORMAL;
 730 }
 731
 732 PP(pp_lineseq)
 733 {
 734     dVAR;
 735     return NORMAL;
 736 }
 737
 738 PP(pp_scope)
 739 {
 740     dVAR;
 741     return NORMAL;
 742 }
 743
 744 /* Ops that are calls to do_kv.  */
 745 PP(pp_values)
 746 {
 747     return do_kv();
 748 }
 749
 750 PP(pp_keys)
 751 {
 752     return do_kv();
 753 }
 754
 755 /* Ops that are simply calls to other ops.  */
 756 PP(pp_dump)
 757 {
 758     return pp_goto();
 759     /*NOTREACHED*/
 760 }
 761
 762 PP(pp_dofile)
 763 {
 764     return pp_require();
 765 }
 766
 767 PP(pp_dbmclose)
 768 {
 769     return pp_untie();
 770 }
 771
 772 PP(pp_read)
 773 {
 774     return pp_sysread();
 775 }
 776
 777 PP(pp_recv)
 778 {
 779     return pp_sysread();
 780 }
 781
 782 PP(pp_seek)
 783 {
 784     return pp_sysseek();
 785 }
 786
 787 PP(pp_fcntl)
 788 {
 789     return pp_ioctl();
 790 }
 791
 792 PP(pp_gsockopt)
 793 {
 794     return pp_ssockopt();
 795 }
 796
 797 PP(pp_getsockname)
 798 {
 799     return pp_getpeername();
 800 }
 801
 802 PP(pp_lstat)
 803 {
 804     return pp_stat();
 805 }
 806
 807 PP(pp_fteowned)
 808 {
 809     return pp_ftrowned();
 810 }
 811
 812 PP(pp_ftbinary)
 813 {
 814     return pp_fttext();
 815 }
 816
 817 PP(pp_localtime)
 818 {
 819     return pp_gmtime();
 820 }
 821
 822 PP(pp_shmget)
 823 {
 824     return pp_semget();
 825 }
 826
 827 PP(pp_shmctl)
 828 {
 829     return pp_semctl();
 830 }
 831
 832 PP(pp_shmread)
 833 {
 834     return pp_shmwrite();
 835 }
 836
 837 PP(pp_msgget)
 838 {
 839     return pp_semget();
 840 }
 841
 842 PP(pp_msgctl)
 843 {
 844     return pp_semctl();
 845 }
 846
 847 PP(pp_ghbyname)
 848 {
 849     return pp_ghostent();
 850 }
 851
 852 PP(pp_ghbyaddr)
 853 {
 854     return pp_ghostent();
 855 }
 856
 857 PP(pp_gnbyname)
 858 {
 859     return pp_gnetent();
 860 }
 861
 862 PP(pp_gnbyaddr)
 863 {
 864     return pp_gnetent();
 865 }
 866
 867 PP(pp_gpbyname)
 868 {
 869     return pp_gprotoent();
 870 }
 871
 872 PP(pp_gpbynumber)
 873 {
 874     return pp_gprotoent();
 875 }
 876
 877 PP(pp_gsbyname)
 878 {
 879     return pp_gservent();
 880 }
 881
 882 PP(pp_gsbyport)
 883 {
 884     return pp_gservent();
 885 }
 886
 887 PP(pp_gpwnam)
 888 {
 889     return pp_gpwent();
 890 }
 891
 892 PP(pp_gpwuid)
 893 {
 894     return pp_gpwent();
 895 }
 896
 897 PP(pp_ggrnam)
 898 {
 899     return pp_ggrent();
 900 }
 901
 902 PP(pp_ggrgid)
 903 {
 904     return pp_ggrent();
 905 }
 906
 907 PP(pp_ftsize)
 908 {
 909     return pp_ftis();
 910 }
 911
 912 PP(pp_ftmtime)
 913 {
 914     return pp_ftis();
 915 }
 916
 917 PP(pp_ftatime)
 918 {
 919     return pp_ftis();
 920 }
 921
 922 PP(pp_ftctime)
 923 {
 924     return pp_ftis();
 925 }
 926
 927 PP(pp_ftzero)
 928 {
 929     return pp_ftrowned();
 930 }
 931
 932 PP(pp_ftsock)
 933 {
 934     return pp_ftrowned();
 935 }
 936
 937 PP(pp_ftchr)
 938 {
 939     return pp_ftrowned();
 940 }
 941
 942 PP(pp_ftblk)
 943 {
 944     return pp_ftrowned();
 945 }
 946
 947 PP(pp_ftfile)
 948 {
 949     return pp_ftrowned();
 950 }
 951
 952 PP(pp_ftdir)
 953 {
 954     return pp_ftrowned();
 955 }
 956
 957 PP(pp_ftpipe)
 958 {
 959     return pp_ftrowned();
 960 }
 961
 962 PP(pp_ftsuid)
 963 {
 964     return pp_ftrowned();
 965 }
 966
 967 PP(pp_ftsgid)
 968 {
 969     return pp_ftrowned();
 970 }
 971
 972 PP(pp_ftsvtx)
 973 {
 974     return pp_ftrowned();
 975 }
 976
 977 PP(pp_unlink)
 978 {
 979     return pp_chown();
 980 }
 981
 982 PP(pp_chmod)
 983 {
 984     return pp_chown();
 985 }
 986
 987 PP(pp_utime)
 988 {
 989     return pp_chown();
 990 }
 991
 992 PP(pp_kill)
 993 {
 994     return pp_chown();
 995 }
 996
 997 PP(pp_symlink)
 998 {
 999     return pp_link();
1000 }
1001
1002 PP(pp_ftrwrite)
1003 {
1004     return pp_ftrread();
1005 }
1006
1007 PP(pp_ftrexec)
1008 {
1009     return pp_ftrread();
1010 }
1011
1012 PP(pp_fteread)
1013 {
1014     return pp_ftrread();
1015 }
1016
1017 PP(pp_ftewrite)
1018 {
1019     return pp_ftrread();
1020 }
1021
1022 PP(pp_fteexec)
1023 {
1024     return pp_ftrread();
1025 }
1026
1027 PP(pp_msgsnd)
1028 {
1029     return pp_shmwrite();
1030 }
1031
1032 PP(pp_msgrcv)
1033 {
1034     return pp_shmwrite();
1035 }
1036
1037 PP(pp_syswrite)
1038 {
1039     return pp_send();
1040 }
1041
1042 PP(pp_semop)
1043 {
1044     return pp_shmwrite();
1045 }
1046
1047 PP(pp_dor)
1048 {
1049     return pp_defined();
1050 }
1051
1052 PP(pp_andassign)
1053 {
1054     return pp_and();
1055 }
1056
1057 PP(pp_orassign)
1058 {
1059     return pp_or();
1060 }
1061
1062 PP(pp_dorassign)
1063 {
1064     return pp_defined();
1065 }
1066
1067 PP(pp_lcfirst)
1068 {
1069     return pp_ucfirst();
1070 }
1071
1072 PP(pp_slt)
1073 {
1074     return pp_sle();
1075 }
1076
1077 PP(pp_sgt)
1078 {
1079     return pp_sle();
1080 }
1081
1082 PP(pp_sge)
1083 {
1084     return pp_sle();
1085 }
1086
1087 PP(pp_rindex)
1088 {
1089     return pp_index();
1090 }
1091
1092 PP(pp_hex)
1093 {
1094     return pp_oct();
1095 }
1096
1097 PP(pp_pop)
1098 {
1099     return pp_shift();
1100 }
1101
1102 PP(pp_cos)
1103 {
1104     return pp_sin();
1105 }
1106
1107 PP(pp_exp)
1108 {
1109     return pp_sin();
1110 }
1111
1112 PP(pp_log)
1113 {
1114     return pp_sin();
1115 }
1116
1117 PP(pp_sqrt)
1118 {
1119     return pp_sin();
1120 }
1121
1122 PP(pp_bit_xor)
1123 {
1124     return pp_bit_or();
1125 }
1126
1127 PP(pp_rv2hv)
1128 {
1129     return Perl_pp_rv2av(aTHX);
1130 }
1131
1132 U8 *
1133 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
1134 {
1135     PERL_ARGS_ASSERT_UVUNI_TO_UTF8;
1136
1137     return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
1138 }
1139
1140 bool
1141 Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
1142 {
1143     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC;
1144
1145     return is_utf8_string_loclen(s, len, ep, 0);
1146 }
1147
1148 /*
1149 =for apidoc sv_nolocking
1150
1151 Dummy routine which "locks" an SV when there is no locking module present.
1152 Exists to avoid test for a NULL function pointer and because it could
1153 potentially warn under some level of strict-ness.
1154
1155 "Superseded" by sv_nosharing().
1156
1157 =cut
1158 */
1159
1160 void
1161 Perl_sv_nolocking(pTHX_ SV *sv)
1162 {
1163     PERL_UNUSED_CONTEXT;
1164     PERL_UNUSED_ARG(sv);
1165 }
1166
1167
1168 /*
1169 =for apidoc sv_nounlocking
1170
1171 Dummy routine which "unlocks" an SV when there is no locking module present.
1172 Exists to avoid test for a NULL function pointer and because it could
1173 potentially warn under some level of strict-ness.
1174
1175 "Superseded" by sv_nosharing().
1176
1177 =cut
1178 */
1179
1180 void
1181 Perl_sv_nounlocking(pTHX_ SV *sv)
1182 {
1183     PERL_UNUSED_CONTEXT;
1184     PERL_UNUSED_ARG(sv);
1185 }
1186
1187 void
1188 Perl_save_long(pTHX_ long int *longp)
1189 {
1190     dVAR;
1191
1192     PERL_ARGS_ASSERT_SAVE_LONG;
1193
1194     SSCHECK(3);
1195     SSPUSHLONG(*longp);
1196     SSPUSHPTR(longp);
1197     SSPUSHINT(SAVEt_LONG);
1198 }
1199
1200 void
1201 Perl_save_iv(pTHX_ IV *ivp)
1202 {
1203     dVAR;
1204
1205     PERL_ARGS_ASSERT_SAVE_IV;
1206
1207     SSCHECK(3);
1208     SSPUSHIV(*ivp);
1209     SSPUSHPTR(ivp);
1210     SSPUSHINT(SAVEt_IV);
1211 }
1212
1213 void
1214 Perl_save_nogv(pTHX_ GV *gv)
1215 {
1216     dVAR;
1217
1218     PERL_ARGS_ASSERT_SAVE_NOGV;
1219
1220     SSCHECK(2);
1221     SSPUSHPTR(gv);
1222     SSPUSHINT(SAVEt_NSTAB);
1223 }
1224
1225 void
1226 Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
1227 {
1228     dVAR;
1229     register I32 i;
1230
1231     PERL_ARGS_ASSERT_SAVE_LIST;
1232
1233     for (i = 1; i <= maxsarg; i++) {
1234         register SV * const sv = newSV(0);
1235         sv_setsv(sv,sarg[i]);
1236         SSCHECK(3);
1237         SSPUSHPTR(sarg[i]);             /* remember the pointer */
1238         SSPUSHPTR(sv);                  /* remember the value */
1239         SSPUSHINT(SAVEt_ITEM);
1240     }
1241 }
1242
1243 /*
1244 =for apidoc sv_usepvn_mg
1245
1246 Like C<sv_usepvn>, but also handles 'set' magic.
1247
1248 =cut
1249 */
1250
1251 void
1252 Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len)
1253 {
1254     PERL_ARGS_ASSERT_SV_USEPVN_MG;
1255
1256     sv_usepvn_flags(sv,ptr,len, SV_SMAGIC);
1257 }
1258
1259 /*
1260 =for apidoc sv_usepvn
1261
1262 Tells an SV to use C<ptr> to find its string value. Implemented by
1263 calling C<sv_usepvn_flags> with C<flags> of 0, hence does not handle 'set'
1264 magic. See C<sv_usepvn_flags>.
1265
1266 =cut
1267 */
1268
1269 void
1270 Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
1271 {
1272     PERL_ARGS_ASSERT_SV_USEPVN;
1273
1274     sv_usepvn_flags(sv,ptr,len, 0);
1275 }
1276
1277 void
1278 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
1279 {
1280     PERL_ARGS_ASSERT_CV_CKPROTO;
1281
1282     cv_ckproto_len(cv, gv, p, p ? strlen(p) : 0);
1283 }
1284
1285 /*
1286 =for apidoc unpack_str
1287
1288 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
1289 and ocnt are not used. This call should not be used, use unpackstring instead.
1290
1291 =cut */
1292
1293 I32
1294 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s,
1295                 const char *strbeg, const char *strend, char **new_s, I32 ocnt,
1296                 U32 flags)
1297 {
1298     PERL_ARGS_ASSERT_UNPACK_STR;
1299
1300     PERL_UNUSED_ARG(strbeg);
1301     PERL_UNUSED_ARG(new_s);
1302     PERL_UNUSED_ARG(ocnt);
1303
1304     return unpackstring(pat, patend, s, strend, flags);
1305 }
1306
1307 /*
1308 =for apidoc pack_cat
1309
1310 The engine implementing pack() Perl function. Note: parameters next_in_list and
1311 flags are not used. This call should not be used; use packlist instead.
1312
1313 =cut
1314 */
1315
1316 void
1317 Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1318 {
1319     PERL_ARGS_ASSERT_PACK_CAT;
1320
1321     PERL_UNUSED_ARG(next_in_list);
1322     PERL_UNUSED_ARG(flags);
1323
1324     packlist(cat, pat, patend, beglist, endlist);
1325 }
1326
1327 HE *
1328 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
1329 {
1330   return (HE *)hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
1331 }
1332
1333 bool
1334 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1335 {
1336     PERL_ARGS_ASSERT_HV_EXISTS_ENT;
1337
1338     return hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
1339         ? TRUE : FALSE;
1340 }
1341
1342 HE *
1343 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash)
1344 {
1345     PERL_ARGS_ASSERT_HV_FETCH_ENT;
1346
1347     return (HE *)hv_common(hv, keysv, NULL, 0, 0,
1348                      (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
1349 }
1350
1351 SV *
1352 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1353 {
1354     PERL_ARGS_ASSERT_HV_DELETE_ENT;
1355
1356     return (SV *) hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL,
1357                             hash);
1358 }
1359
1360 SV**
1361 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash,
1362                     int flags)
1363 {
1364     return (SV**) hv_common(hv, NULL, key, klen, flags,
1365                             (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
1366 }
1367
1368 SV**
1369 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
1370 {
1371     STRLEN klen;
1372     int flags;
1373
1374     if (klen_i32 < 0) {
1375         klen = -klen_i32;
1376         flags = HVhek_UTF8;
1377     } else {
1378         klen = klen_i32;
1379         flags = 0;
1380     }
1381     return (SV **) hv_common(hv, NULL, key, klen, flags,
1382                              (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
1383 }
1384
1385 bool
1386 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
1387 {
1388     STRLEN klen;
1389     int flags;
1390
1391     PERL_ARGS_ASSERT_HV_EXISTS;
1392
1393     if (klen_i32 < 0) {
1394         klen = -klen_i32;
1395         flags = HVhek_UTF8;
1396     } else {
1397         klen = klen_i32;
1398         flags = 0;
1399     }
1400     return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
1401         ? TRUE : FALSE;
1402 }
1403
1404 SV**
1405 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
1406 {
1407     STRLEN klen;
1408     int flags;
1409
1410     PERL_ARGS_ASSERT_HV_FETCH;
1411
1412     if (klen_i32 < 0) {
1413         klen = -klen_i32;
1414         flags = HVhek_UTF8;
1415     } else {
1416         klen = klen_i32;
1417         flags = 0;
1418     }
1419     return (SV **) hv_common(hv, NULL, key, klen, flags,
1420                              lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE)
1421                              : HV_FETCH_JUST_SV, NULL, 0);
1422 }
1423
1424 SV *
1425 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
1426 {
1427     STRLEN klen;
1428     int k_flags;
1429
1430     PERL_ARGS_ASSERT_HV_DELETE;
1431
1432     if (klen_i32 < 0) {
1433         klen = -klen_i32;
1434         k_flags = HVhek_UTF8;
1435     } else {
1436         klen = klen_i32;
1437         k_flags = 0;
1438     }
1439     return (SV *) hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE,
1440                             NULL, 0);
1441 }
1442
1443 /* Functions after here were made mathoms post 5.10.0 but pre 5.8.9 */
1444
1445 AV *
1446 Perl_newAV(pTHX)
1447 {
1448     return (AV*)newSV_type(SVt_PVAV);
1449     /* sv_upgrade does AvREAL_only():
1450     AvALLOC(av) = 0;
1451     AvARRAY(av) = NULL;
1452     AvMAX(av) = AvFILLp(av) = -1; */
1453 }
1454
1455 HV *
1456 Perl_newHV(pTHX)
1457 {
1458     HV * const hv = (HV*)newSV_type(SVt_PVHV);
1459     assert(!SvOK(hv));
1460
1461     return hv;
1462 }
1463
1464 void
1465 Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len,
1466               const char *const little, const STRLEN littlelen)
1467 {
1468     PERL_ARGS_ASSERT_SV_INSERT;
1469     sv_insert_flags(bigstr, offset, len, little, littlelen, SV_GMAGIC);
1470 }
1471
1472 #endif /* NO_MATHOMS */
1473
1474 /*
1475  * Local variables:
1476  * c-indentation-style: bsd
1477  * c-basic-offset: 4
1478  * indent-tabs-mode: t
1479  * End:
1480  *
1481  * ex: set ts=8 sts=4 sw=4 noet:
1482  */