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
  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 #ifdef NO_MATHOMS
  35 /* ..." warning: ISO C forbids an empty source file"
  36    So make sure we have something in here by processing the headers anyway.
  37  */
  38 #else
  39
  40 PERL_CALLCONV OP * Perl_ref(pTHX_ OP *o, I32 type);
  41 PERL_CALLCONV void Perl_sv_unref(pTHX_ SV *sv);
  42 PERL_CALLCONV void Perl_sv_taint(pTHX_ SV *sv);
  43 PERL_CALLCONV IV Perl_sv_2iv(pTHX_ register SV *sv);
  44 PERL_CALLCONV UV Perl_sv_2uv(pTHX_ register SV *sv);
  45 PERL_CALLCONV NV Perl_sv_2nv(pTHX_ register SV *sv);
  46 PERL_CALLCONV char * Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp);
  47 PERL_CALLCONV char * Perl_sv_2pv_nolen(pTHX_ register SV *sv);
  48 PERL_CALLCONV char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv);
  49 PERL_CALLCONV char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv);
  50 PERL_CALLCONV void Perl_sv_force_normal(pTHX_ register SV *sv);
  51 PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr);
  52 PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen);
  53 PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len);
  54 PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr);
  55 PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv);
  56 PERL_CALLCONV char * Perl_sv_pv(pTHX_ SV *sv);
  57 PERL_CALLCONV char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp);
  58 PERL_CALLCONV char * Perl_sv_pvbyte(pTHX_ SV *sv);
  59 PERL_CALLCONV char * Perl_sv_pvutf8(pTHX_ SV *sv);
  60 PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv);
  61 PERL_CALLCONV NV Perl_huge(void);
  62 PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
  63 PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
  64 PERL_CALLCONV GV * Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name);
  65 PERL_CALLCONV HE * Perl_hv_iternext(pTHX_ HV *hv);
  66 PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how);
  67 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);
  68 PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp);
  69 PERL_CALLCONV U8 * Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv);
  70 PERL_CALLCONV bool Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep);
  71 PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv);
  72 PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len);
  73 PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len);
  74 PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...);
  75 PERL_CALLCONV int Perl_printf_nocontext(const char *format, ...);
  76 PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg);
  77 PERL_CALLCONV AV * Perl_newAV(pTHX);
  78 PERL_CALLCONV HV * Perl_newHV(pTHX);
  79 PERL_CALLCONV IO * Perl_newIO(pTHX);
  80 PERL_CALLCONV I32 Perl_my_stat(pTHX);
  81 PERL_CALLCONV I32 Perl_my_lstat(pTHX);
  82 PERL_CALLCONV I32 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2);
  83 PERL_CALLCONV char * Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp);
  84 PERL_CALLCONV bool Perl_sv_2bool(pTHX_ register SV *const sv);
  85 PERL_CALLCONV CV * Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block);
  86
  87 /* ref() is now a macro using Perl_doref;
  88  * this version provided for binary compatibility only.
  89  */
  90 OP *
  91 Perl_ref(pTHX_ OP *o, I32 type)
  92 {
  93     return doref(o, type, TRUE);
  94 }
  95
  96 /*
  97 =for apidoc sv_unref
  98
  99 Unsets the RV status of the SV, and decrements the reference count of
 100 whatever was being referenced by the RV.  This can almost be thought of
 101 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
 102 being zero.  See C<SvROK_off>.
 103
 104 =cut
 105 */
 106
 107 void
 108 Perl_sv_unref(pTHX_ SV *sv)
 109 {
 110     PERL_ARGS_ASSERT_SV_UNREF;
 111
 112     sv_unref_flags(sv, 0);
 113 }
 114
 115 /*
 116 =for apidoc sv_taint
 117
 118 Taint an SV. Use C<SvTAINTED_on> instead.
 119
 120 =cut
 121 */
 122
 123 void
 124 Perl_sv_taint(pTHX_ SV *sv)
 125 {
 126     PERL_ARGS_ASSERT_SV_TAINT;
 127
 128     sv_magic((sv), NULL, PERL_MAGIC_taint, NULL, 0);
 129 }
 130
 131 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
 132  * this function provided for binary compatibility only
 133  */
 134
 135 IV
 136 Perl_sv_2iv(pTHX_ register SV *sv)
 137 {
 138     return sv_2iv_flags(sv, SV_GMAGIC);
 139 }
 140
 141 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
 142  * this function provided for binary compatibility only
 143  */
 144
 145 UV
 146 Perl_sv_2uv(pTHX_ register SV *sv)
 147 {
 148     return sv_2uv_flags(sv, SV_GMAGIC);
 149 }
 150
 151 /* sv_2nv() is now a macro using Perl_sv_2nv_flags();
 152  * this function provided for binary compatibility only
 153  */
 154
 155 NV
 156 Perl_sv_2nv(pTHX_ register SV *sv)
 157 {
 158     return sv_2nv_flags(sv, SV_GMAGIC);
 159 }
 160
 161
 162 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
 163  * this function provided for binary compatibility only
 164  */
 165
 166 char *
 167 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
 168 {
 169     return sv_2pv_flags(sv, lp, SV_GMAGIC);
 170 }
 171
 172 /*
 173 =for apidoc sv_2pv_nolen
 174
 175 Like C<sv_2pv()>, but doesn't return the length too. You should usually
 176 use the macro wrapper C<SvPV_nolen(sv)> instead.
 177
 178 =cut
 179 */
 180
 181 char *
 182 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
 183 {
 184     PERL_ARGS_ASSERT_SV_2PV_NOLEN;
 185     return sv_2pv(sv, NULL);
 186 }
 187
 188 /*
 189 =for apidoc sv_2pvbyte_nolen
 190
 191 Return a pointer to the byte-encoded representation of the SV.
 192 May cause the SV to be downgraded from UTF-8 as a side-effect.
 193
 194 Usually accessed via the C<SvPVbyte_nolen> macro.
 195
 196 =cut
 197 */
 198
 199 char *
 200 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
 201 {
 202     PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN;
 203
 204     return sv_2pvbyte(sv, NULL);
 205 }
 206
 207 /*
 208 =for apidoc sv_2pvutf8_nolen
 209
 210 Return a pointer to the UTF-8-encoded representation of the SV.
 211 May cause the SV to be upgraded to UTF-8 as a side-effect.
 212
 213 Usually accessed via the C<SvPVutf8_nolen> macro.
 214
 215 =cut
 216 */
 217
 218 char *
 219 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
 220 {
 221     PERL_ARGS_ASSERT_SV_2PVUTF8_NOLEN;
 222
 223     return sv_2pvutf8(sv, NULL);
 224 }
 225
 226 /*
 227 =for apidoc sv_force_normal
 228
 229 Undo various types of fakery on an SV: if the PV is a shared string, make
 230 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
 231 an xpvmg. See also C<sv_force_normal_flags>.
 232
 233 =cut
 234 */
 235
 236 void
 237 Perl_sv_force_normal(pTHX_ register SV *sv)
 238 {
 239     PERL_ARGS_ASSERT_SV_FORCE_NORMAL;
 240
 241     sv_force_normal_flags(sv, 0);
 242 }
 243
 244 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
 245  * this function provided for binary compatibility only
 246  */
 247
 248 void
 249 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 250 {
 251     PERL_ARGS_ASSERT_SV_SETSV;
 252
 253     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
 254 }
 255
 256 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
 257  * this function provided for binary compatibility only
 258  */
 259
 260 void
 261 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
 262 {
 263     PERL_ARGS_ASSERT_SV_CATPVN;
 264
 265     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
 266 }
 267
 268 /*
 269 =for apidoc sv_catpvn_mg
 270
 271 Like C<sv_catpvn>, but also handles 'set' magic.
 272
 273 =cut
 274 */
 275
 276 void
 277 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
 278 {
 279     PERL_ARGS_ASSERT_SV_CATPVN_MG;
 280
 281     sv_catpvn_flags(sv,ptr,len,SV_GMAGIC|SV_SMAGIC);
 282 }
 283
 284 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
 285  * this function provided for binary compatibility only
 286  */
 287
 288 void
 289 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
 290 {
 291     PERL_ARGS_ASSERT_SV_CATSV;
 292
 293     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
 294 }
 295
 296 /*
 297 =for apidoc sv_catsv_mg
 298
 299 Like C<sv_catsv>, but also handles 'set' magic.
 300
 301 =cut
 302 */
 303
 304 void
 305 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
 306 {
 307     PERL_ARGS_ASSERT_SV_CATSV_MG;
 308
 309     sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC);
 310 }
 311
 312 /*
 313 =for apidoc sv_iv
 314
 315 A private implementation of the C<SvIVx> macro for compilers which can't
 316 cope with complex macro expressions. Always use the macro instead.
 317
 318 =cut
 319 */
 320
 321 IV
 322 Perl_sv_iv(pTHX_ register SV *sv)
 323 {
 324     PERL_ARGS_ASSERT_SV_IV;
 325
 326     if (SvIOK(sv)) {
 327         if (SvIsUV(sv))
 328             return (IV)SvUVX(sv);
 329         return SvIVX(sv);
 330     }
 331     return sv_2iv(sv);
 332 }
 333
 334 /*
 335 =for apidoc sv_uv
 336
 337 A private implementation of the C<SvUVx> macro for compilers which can't
 338 cope with complex macro expressions. Always use the macro instead.
 339
 340 =cut
 341 */
 342
 343 UV
 344 Perl_sv_uv(pTHX_ register SV *sv)
 345 {
 346     PERL_ARGS_ASSERT_SV_UV;
 347
 348     if (SvIOK(sv)) {
 349         if (SvIsUV(sv))
 350             return SvUVX(sv);
 351         return (UV)SvIVX(sv);
 352     }
 353     return sv_2uv(sv);
 354 }
 355
 356 /*
 357 =for apidoc sv_nv
 358
 359 A private implementation of the C<SvNVx> macro for compilers which can't
 360 cope with complex macro expressions. Always use the macro instead.
 361
 362 =cut
 363 */
 364
 365 NV
 366 Perl_sv_nv(pTHX_ register SV *sv)
 367 {
 368     PERL_ARGS_ASSERT_SV_NV;
 369
 370     if (SvNOK(sv))
 371         return SvNVX(sv);
 372     return sv_2nv(sv);
 373 }
 374
 375 /*
 376 =for apidoc sv_pv
 377
 378 Use the C<SvPV_nolen> macro instead
 379
 380 =for apidoc sv_pvn
 381
 382 A private implementation of the C<SvPV> macro for compilers which can't
 383 cope with complex macro expressions. Always use the macro instead.
 384
 385 =cut
 386 */
 387
 388 char *
 389 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
 390 {
 391     PERL_ARGS_ASSERT_SV_PVN;
 392
 393     if (SvPOK(sv)) {
 394         *lp = SvCUR(sv);
 395         return SvPVX(sv);
 396     }
 397     return sv_2pv(sv, lp);
 398 }
 399
 400
 401 char *
 402 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
 403 {
 404     PERL_ARGS_ASSERT_SV_PVN_NOMG;
 405
 406     if (SvPOK(sv)) {
 407         *lp = SvCUR(sv);
 408         return SvPVX(sv);
 409     }
 410     return sv_2pv_flags(sv, lp, 0);
 411 }
 412
 413 /* sv_pv() is now a macro using SvPV_nolen();
 414  * this function provided for binary compatibility only
 415  */
 416
 417 char *
 418 Perl_sv_pv(pTHX_ SV *sv)
 419 {
 420     PERL_ARGS_ASSERT_SV_PV;
 421
 422     if (SvPOK(sv))
 423         return SvPVX(sv);
 424
 425     return sv_2pv(sv, NULL);
 426 }
 427
 428 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
 429  * this function provided for binary compatibility only
 430  */
 431
 432 char *
 433 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 434 {
 435     PERL_ARGS_ASSERT_SV_PVN_FORCE;
 436
 437     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
 438 }
 439
 440 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
 441  * this function provided for binary compatibility only
 442  */
 443
 444 char *
 445 Perl_sv_pvbyte(pTHX_ SV *sv)
 446 {
 447     PERL_ARGS_ASSERT_SV_PVBYTE;
 448
 449     sv_utf8_downgrade(sv, FALSE);
 450     return sv_pv(sv);
 451 }
 452
 453 /*
 454 =for apidoc sv_pvbyte
 455
 456 Use C<SvPVbyte_nolen> instead.
 457
 458 =for apidoc sv_pvbyten
 459
 460 A private implementation of the C<SvPVbyte> macro for compilers
 461 which can't cope with complex macro expressions. Always use the macro
 462 instead.
 463
 464 =cut
 465 */
 466
 467 char *
 468 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
 469 {
 470     PERL_ARGS_ASSERT_SV_PVBYTEN;
 471
 472     sv_utf8_downgrade(sv, FALSE);
 473     return sv_pvn(sv,lp);
 474 }
 475
 476 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
 477  * this function provided for binary compatibility only
 478  */
 479
 480 char *
 481 Perl_sv_pvutf8(pTHX_ SV *sv)
 482 {
 483     PERL_ARGS_ASSERT_SV_PVUTF8;
 484
 485     sv_utf8_upgrade(sv);
 486     return sv_pv(sv);
 487 }
 488
 489 /*
 490 =for apidoc sv_pvutf8
 491
 492 Use the C<SvPVutf8_nolen> macro instead
 493
 494 =for apidoc sv_pvutf8n
 495
 496 A private implementation of the C<SvPVutf8> macro for compilers
 497 which can't cope with complex macro expressions. Always use the macro
 498 instead.
 499
 500 =cut
 501 */
 502
 503 char *
 504 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
 505 {
 506     PERL_ARGS_ASSERT_SV_PVUTF8N;
 507
 508     sv_utf8_upgrade(sv);
 509     return sv_pvn(sv,lp);
 510 }
 511
 512 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
 513  * this function provided for binary compatibility only
 514  */
 515
 516 STRLEN
 517 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 518 {
 519     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE;
 520
 521     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
 522 }
 523
 524 int
 525 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
 526 {
 527     dTHXs;
 528     va_list(arglist);
 529
 530     /* Easier to special case this here than in embed.pl. (Look at what it
 531        generates for proto.h) */
 532 #ifdef PERL_IMPLICIT_CONTEXT
 533     PERL_ARGS_ASSERT_FPRINTF_NOCONTEXT;
 534 #endif
 535
 536     va_start(arglist, format);
 537     return PerlIO_vprintf(stream, format, arglist);
 538 }
 539
 540 int
 541 Perl_printf_nocontext(const char *format, ...)
 542 {
 543     dTHX;
 544     va_list(arglist);
 545
 546 #ifdef PERL_IMPLICIT_CONTEXT
 547     PERL_ARGS_ASSERT_PRINTF_NOCONTEXT;
 548 #endif
 549
 550     va_start(arglist, format);
 551     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
 552 }
 553
 554 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 555 /*
 556  * This hack is to force load of "huge" support from libm.a
 557  * So it is in perl for (say) POSIX to use.
 558  * Needed for SunOS with Sun's 'acc' for example.
 559  */
 560 NV
 561 Perl_huge(void)
 562 {
 563 #  if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
 564     return HUGE_VALL;
 565 #  else
 566     return HUGE_VAL;
 567 #  endif
 568 }
 569 #endif
 570
 571 /* compatibility with versions <= 5.003. */
 572 void
 573 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
 574 {
 575     PERL_ARGS_ASSERT_GV_FULLNAME;
 576
 577     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 578 }
 579
 580 /* compatibility with versions <= 5.003. */
 581 void
 582 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
 583 {
 584     PERL_ARGS_ASSERT_GV_EFULLNAME;
 585
 586     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 587 }
 588
 589 void
 590 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 591 {
 592     PERL_ARGS_ASSERT_GV_FULLNAME3;
 593
 594     gv_fullname4(sv, gv, prefix, TRUE);
 595 }
 596
 597 void
 598 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 599 {
 600     PERL_ARGS_ASSERT_GV_EFULLNAME3;
 601
 602     gv_efullname4(sv, gv, prefix, TRUE);
 603 }
 604
 605 /*
 606 =for apidoc gv_fetchmethod
 607
 608 See L</gv_fetchmethod_autoload>.
 609
 610 =cut
 611 */
 612
 613 GV *
 614 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 615 {
 616     PERL_ARGS_ASSERT_GV_FETCHMETHOD;
 617
 618     return gv_fetchmethod_autoload(stash, name, TRUE);
 619 }
 620
 621 HE *
 622 Perl_hv_iternext(pTHX_ HV *hv)
 623 {
 624     PERL_ARGS_ASSERT_HV_ITERNEXT;
 625
 626     return hv_iternext_flags(hv, 0);
 627 }
 628
 629 void
 630 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
 631 {
 632     PERL_ARGS_ASSERT_HV_MAGIC;
 633
 634     sv_magic(MUTABLE_SV(hv), MUTABLE_SV(gv), how, NULL, 0);
 635 }
 636
 637 bool
 638 Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
 639              int rawmode, int rawperm, PerlIO *supplied_fp)
 640 {
 641     PERL_ARGS_ASSERT_DO_OPEN;
 642
 643     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 644                     supplied_fp, (SV **) NULL, 0);
 645 }
 646
 647 bool
 648 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
 649 as_raw,
 650               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
 651               I32 num_svs)
 652 {
 653     PERL_ARGS_ASSERT_DO_OPEN9;
 654
 655     PERL_UNUSED_ARG(num_svs);
 656     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 657                     supplied_fp, &svs, 1);
 658 }
 659
 660 int
 661 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 662 {
 663  /* The old body of this is now in non-LAYER part of perlio.c
 664   * This is a stub for any XS code which might have been calling it.
 665   */
 666  const char *name = ":raw";
 667
 668  PERL_ARGS_ASSERT_DO_BINMODE;
 669
 670 #ifdef PERLIO_USING_CRLF
 671  if (!(mode & O_BINARY))
 672      name = ":crlf";
 673 #endif
 674  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 675 }
 676
 677 #ifndef OS2
 678 bool
 679 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
 680 {
 681     PERL_ARGS_ASSERT_DO_AEXEC;
 682
 683     return do_aexec5(really, mark, sp, 0, 0);
 684 }
 685 #endif
 686
 687 /* Backwards compatibility. */
 688 int
 689 Perl_init_i18nl14n(pTHX_ int printwarn)
 690 {
 691     return init_i18nl10n(printwarn);
 692 }
 693
 694 U8 *
 695 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
 696 {
 697     PERL_ARGS_ASSERT_UVUNI_TO_UTF8;
 698
 699     return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
 700 }
 701
 702 bool
 703 Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
 704 {
 705     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC;
 706
 707     return is_utf8_string_loclen(s, len, ep, 0);
 708 }
 709
 710 /*
 711 =for apidoc sv_nolocking
 712
 713 Dummy routine which "locks" an SV when there is no locking module present.
 714 Exists to avoid test for a NULL function pointer and because it could
 715 potentially warn under some level of strict-ness.
 716
 717 "Superseded" by sv_nosharing().
 718
 719 =cut
 720 */
 721
 722 void
 723 Perl_sv_nolocking(pTHX_ SV *sv)
 724 {
 725     PERL_UNUSED_CONTEXT;
 726     PERL_UNUSED_ARG(sv);
 727 }
 728
 729
 730 /*
 731 =for apidoc sv_nounlocking
 732
 733 Dummy routine which "unlocks" an SV when there is no locking module present.
 734 Exists to avoid test for a NULL function pointer and because it could
 735 potentially warn under some level of strict-ness.
 736
 737 "Superseded" by sv_nosharing().
 738
 739 =cut
 740 */
 741
 742 void
 743 Perl_sv_nounlocking(pTHX_ SV *sv)
 744 {
 745     PERL_UNUSED_CONTEXT;
 746     PERL_UNUSED_ARG(sv);
 747 }
 748
 749 void
 750 Perl_save_long(pTHX_ long int *longp)
 751 {
 752     dVAR;
 753
 754     PERL_ARGS_ASSERT_SAVE_LONG;
 755
 756     SSCHECK(3);
 757     SSPUSHLONG(*longp);
 758     SSPUSHPTR(longp);
 759     SSPUSHUV(SAVEt_LONG);
 760 }
 761
 762 void
 763 Perl_save_iv(pTHX_ IV *ivp)
 764 {
 765     dVAR;
 766
 767     PERL_ARGS_ASSERT_SAVE_IV;
 768
 769     SSCHECK(3);
 770     SSPUSHIV(*ivp);
 771     SSPUSHPTR(ivp);
 772     SSPUSHUV(SAVEt_IV);
 773 }
 774
 775 void
 776 Perl_save_nogv(pTHX_ GV *gv)
 777 {
 778     dVAR;
 779
 780     PERL_ARGS_ASSERT_SAVE_NOGV;
 781
 782     SSCHECK(2);
 783     SSPUSHPTR(gv);
 784     SSPUSHUV(SAVEt_NSTAB);
 785 }
 786
 787 void
 788 Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
 789 {
 790     dVAR;
 791     register I32 i;
 792
 793     PERL_ARGS_ASSERT_SAVE_LIST;
 794
 795     for (i = 1; i <= maxsarg; i++) {
 796         register SV * const sv = newSV(0);
 797         sv_setsv(sv,sarg[i]);
 798         SSCHECK(3);
 799         SSPUSHPTR(sarg[i]);             /* remember the pointer */
 800         SSPUSHPTR(sv);                  /* remember the value */
 801         SSPUSHUV(SAVEt_ITEM);
 802     }
 803 }
 804
 805 /*
 806 =for apidoc sv_usepvn_mg
 807
 808 Like C<sv_usepvn>, but also handles 'set' magic.
 809
 810 =cut
 811 */
 812
 813 void
 814 Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len)
 815 {
 816     PERL_ARGS_ASSERT_SV_USEPVN_MG;
 817
 818     sv_usepvn_flags(sv,ptr,len, SV_SMAGIC);
 819 }
 820
 821 /*
 822 =for apidoc sv_usepvn
 823
 824 Tells an SV to use C<ptr> to find its string value. Implemented by
 825 calling C<sv_usepvn_flags> with C<flags> of 0, hence does not handle 'set'
 826 magic. See C<sv_usepvn_flags>.
 827
 828 =cut
 829 */
 830
 831 void
 832 Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
 833 {
 834     PERL_ARGS_ASSERT_SV_USEPVN;
 835
 836     sv_usepvn_flags(sv,ptr,len, 0);
 837 }
 838
 839 /*
 840 =for apidoc unpack_str
 841
 842 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
 843 and ocnt are not used. This call should not be used, use unpackstring instead.
 844
 845 =cut */
 846
 847 I32
 848 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s,
 849                 const char *strbeg, const char *strend, char **new_s, I32 ocnt,
 850                 U32 flags)
 851 {
 852     PERL_ARGS_ASSERT_UNPACK_STR;
 853
 854     PERL_UNUSED_ARG(strbeg);
 855     PERL_UNUSED_ARG(new_s);
 856     PERL_UNUSED_ARG(ocnt);
 857
 858     return unpackstring(pat, patend, s, strend, flags);
 859 }
 860
 861 /*
 862 =for apidoc pack_cat
 863
 864 The engine implementing pack() Perl function. Note: parameters next_in_list and
 865 flags are not used. This call should not be used; use packlist instead.
 866
 867 =cut
 868 */
 869
 870 void
 871 Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
 872 {
 873     PERL_ARGS_ASSERT_PACK_CAT;
 874
 875     PERL_UNUSED_ARG(next_in_list);
 876     PERL_UNUSED_ARG(flags);
 877
 878     packlist(cat, pat, patend, beglist, endlist);
 879 }
 880
 881 HE *
 882 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
 883 {
 884   return (HE *)hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
 885 }
 886
 887 bool
 888 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 889 {
 890     PERL_ARGS_ASSERT_HV_EXISTS_ENT;
 891
 892     return hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
 893         ? TRUE : FALSE;
 894 }
 895
 896 HE *
 897 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash)
 898 {
 899     PERL_ARGS_ASSERT_HV_FETCH_ENT;
 900
 901     return (HE *)hv_common(hv, keysv, NULL, 0, 0,
 902                      (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
 903 }
 904
 905 SV *
 906 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 907 {
 908     PERL_ARGS_ASSERT_HV_DELETE_ENT;
 909
 910     return MUTABLE_SV(hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL,
 911                                 hash));
 912 }
 913
 914 SV**
 915 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash,
 916                     int flags)
 917 {
 918     return (SV**) hv_common(hv, NULL, key, klen, flags,
 919                             (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
 920 }
 921
 922 SV**
 923 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
 924 {
 925     STRLEN klen;
 926     int flags;
 927
 928     if (klen_i32 < 0) {
 929         klen = -klen_i32;
 930         flags = HVhek_UTF8;
 931     } else {
 932         klen = klen_i32;
 933         flags = 0;
 934     }
 935     return (SV **) hv_common(hv, NULL, key, klen, flags,
 936                              (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
 937 }
 938
 939 bool
 940 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
 941 {
 942     STRLEN klen;
 943     int flags;
 944
 945     PERL_ARGS_ASSERT_HV_EXISTS;
 946
 947     if (klen_i32 < 0) {
 948         klen = -klen_i32;
 949         flags = HVhek_UTF8;
 950     } else {
 951         klen = klen_i32;
 952         flags = 0;
 953     }
 954     return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
 955         ? TRUE : FALSE;
 956 }
 957
 958 SV**
 959 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
 960 {
 961     STRLEN klen;
 962     int flags;
 963
 964     PERL_ARGS_ASSERT_HV_FETCH;
 965
 966     if (klen_i32 < 0) {
 967         klen = -klen_i32;
 968         flags = HVhek_UTF8;
 969     } else {
 970         klen = klen_i32;
 971         flags = 0;
 972     }
 973     return (SV **) hv_common(hv, NULL, key, klen, flags,
 974                              lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE)
 975                              : HV_FETCH_JUST_SV, NULL, 0);
 976 }
 977
 978 SV *
 979 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
 980 {
 981     STRLEN klen;
 982     int k_flags;
 983
 984     PERL_ARGS_ASSERT_HV_DELETE;
 985
 986     if (klen_i32 < 0) {
 987         klen = -klen_i32;
 988         k_flags = HVhek_UTF8;
 989     } else {
 990         klen = klen_i32;
 991         k_flags = 0;
 992     }
 993     return MUTABLE_SV(hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE,
 994                                 NULL, 0));
 995 }
 996
 997 /* Functions after here were made mathoms post 5.10.0 but pre 5.8.9 */
 998
 999 AV *
1000 Perl_newAV(pTHX)
1001 {
1002     return MUTABLE_AV(newSV_type(SVt_PVAV));
1003     /* sv_upgrade does AvREAL_only():
1004     AvALLOC(av) = 0;
1005     AvARRAY(av) = NULL;
1006     AvMAX(av) = AvFILLp(av) = -1; */
1007 }
1008
1009 HV *
1010 Perl_newHV(pTHX)
1011 {
1012     HV * const hv = MUTABLE_HV(newSV_type(SVt_PVHV));
1013     assert(!SvOK(hv));
1014
1015     return hv;
1016 }
1017
1018 void
1019 Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len,
1020               const char *const little, const STRLEN littlelen)
1021 {
1022     PERL_ARGS_ASSERT_SV_INSERT;
1023     sv_insert_flags(bigstr, offset, len, little, littlelen, SV_GMAGIC);
1024 }
1025
1026 void
1027 Perl_save_freesv(pTHX_ SV *sv)
1028 {
1029     dVAR;
1030     save_freesv(sv);
1031 }
1032
1033 void
1034 Perl_save_mortalizesv(pTHX_ SV *sv)
1035 {
1036     dVAR;
1037
1038     PERL_ARGS_ASSERT_SAVE_MORTALIZESV;
1039
1040     save_mortalizesv(sv);
1041 }
1042
1043 void
1044 Perl_save_freeop(pTHX_ OP *o)
1045 {
1046     dVAR;
1047     save_freeop(o);
1048 }
1049
1050 void
1051 Perl_save_freepv(pTHX_ char *pv)
1052 {
1053     dVAR;
1054     save_freepv(pv);
1055 }
1056
1057 void
1058 Perl_save_op(pTHX)
1059 {
1060     dVAR;
1061     save_op();
1062 }
1063
1064 #ifdef PERL_DONT_CREATE_GVSV
1065 GV *
1066 Perl_gv_SVadd(pTHX_ GV *gv)
1067 {
1068     return gv_SVadd(gv);
1069 }
1070 #endif
1071
1072 GV *
1073 Perl_gv_AVadd(pTHX_ GV *gv)
1074 {
1075     return gv_AVadd(gv);
1076 }
1077
1078 GV *
1079 Perl_gv_HVadd(pTHX_ register GV *gv)
1080 {
1081     return gv_HVadd(gv);
1082 }
1083
1084 GV *
1085 Perl_gv_IOadd(pTHX_ register GV *gv)
1086 {
1087     return gv_IOadd(gv);
1088 }
1089
1090 IO *
1091 Perl_newIO(pTHX)
1092 {
1093     return MUTABLE_IO(newSV_type(SVt_PVIO));
1094 }
1095
1096 I32
1097 Perl_my_stat(pTHX)
1098 {
1099     return my_stat_flags(SV_GMAGIC);
1100 }
1101
1102 I32
1103 Perl_my_lstat(pTHX)
1104 {
1105     return my_lstat_flags(SV_GMAGIC);
1106 }
1107
1108 I32
1109 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
1110 {
1111     return sv_eq_flags(sv1, sv2, SV_GMAGIC);
1112 }
1113
1114 #ifdef USE_LOCALE_COLLATE
1115 char *
1116 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
1117 {
1118     return sv_collxfrm_flags(sv, nxp, SV_GMAGIC);
1119 }
1120 #endif
1121
1122 bool
1123 Perl_sv_2bool(pTHX_ register SV *const sv)
1124 {
1125     return sv_2bool_flags(sv, SV_GMAGIC);
1126 }
1127
1128
1129 /*
1130 =for apidoc custom_op_name
1131 Return the name for a given custom op. This was once used by the OP_NAME
1132 macro, but is no longer: it has only been kept for compatibility, and
1133 should not be used.
1134
1135 =for apidoc custom_op_desc
1136 Return the description of a given custom op. This was once used by the
1137 OP_DESC macro, but is no longer: it has only been kept for
1138 compatibility, and should not be used.
1139
1140 =cut
1141 */
1142
1143 const char*
1144 Perl_custom_op_name(pTHX_ const OP* o)
1145 {
1146     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
1147     return XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_name);
1148 }
1149
1150 const char*
1151 Perl_custom_op_desc(pTHX_ const OP* o)
1152 {
1153     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
1154     return XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_desc);
1155 }
1156
1157 CV *
1158 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
1159 {
1160     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
1161 }
1162 #endif /* NO_MATHOMS */
1163
1164 /*
1165  * Local variables:
1166  * c-indentation-style: bsd
1167  * c-basic-offset: 4
1168  * indent-tabs-mode: t
1169  * End:
1170  *
1171  * ex: set ts=8 sts=4 sw=4 noet:
1172  */