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