mathoms.c

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