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 bool
 611 Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
 612              int rawmode, int rawperm, PerlIO *supplied_fp)
 613 {
 614     PERL_ARGS_ASSERT_DO_OPEN;
 615
 616     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 617                     supplied_fp, (SV **) NULL, 0);
 618 }
 619
 620 bool
 621 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
 622 as_raw,
 623               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
 624               I32 num_svs)
 625 {
 626     PERL_ARGS_ASSERT_DO_OPEN9;
 627
 628     PERL_UNUSED_ARG(num_svs);
 629     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 630                     supplied_fp, &svs, 1);
 631 }
 632
 633 int
 634 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 635 {
 636  /* The old body of this is now in non-LAYER part of perlio.c
 637   * This is a stub for any XS code which might have been calling it.
 638   */
 639  const char *name = ":raw";
 640
 641  PERL_ARGS_ASSERT_DO_BINMODE;
 642
 643 #ifdef PERLIO_USING_CRLF
 644  if (!(mode & O_BINARY))
 645      name = ":crlf";
 646 #endif
 647  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 648 }
 649
 650 #ifndef OS2
 651 bool
 652 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
 653 {
 654     PERL_ARGS_ASSERT_DO_AEXEC;
 655
 656     return do_aexec5(really, mark, sp, 0, 0);
 657 }
 658 #endif
 659
 660 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
 661 bool
 662 Perl_do_exec(pTHX_ const char *cmd)
 663 {
 664     PERL_ARGS_ASSERT_DO_EXEC;
 665
 666     return do_exec3(cmd,0,0);
 667 }
 668 #endif
 669
 670 /* Backwards compatibility. */
 671 int
 672 Perl_init_i18nl14n(pTHX_ int printwarn)
 673 {
 674     return init_i18nl10n(printwarn);
 675 }
 676
 677 PP(pp_padany)
 678 {
 679     DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
 680 }
 681
 682 PP(pp_mapstart)
 683 {
 684     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
 685 }
 686
 687 /* These ops all have the same body as pp_null.  */
 688 PP(pp_scalar)
 689 {
 690     dVAR;
 691     return NORMAL;
 692 }
 693
 694 PP(pp_regcmaybe)
 695 {
 696     dVAR;
 697     return NORMAL;
 698 }
 699
 700 PP(pp_lineseq)
 701 {
 702     dVAR;
 703     return NORMAL;
 704 }
 705
 706 PP(pp_scope)
 707 {
 708     dVAR;
 709     return NORMAL;
 710 }
 711
 712 /* Ops that are calls to do_kv.  */
 713 PP(pp_values)
 714 {
 715     return do_kv();
 716 }
 717
 718 PP(pp_keys)
 719 {
 720     return do_kv();
 721 }
 722
 723 /* Ops that are simply calls to other ops.  */
 724 PP(pp_dump)
 725 {
 726     return pp_goto();
 727     /*NOTREACHED*/
 728 }
 729
 730 PP(pp_dofile)
 731 {
 732     return pp_require();
 733 }
 734
 735 PP(pp_dbmclose)
 736 {
 737     return pp_untie();
 738 }
 739
 740 PP(pp_read)
 741 {
 742     return pp_sysread();
 743 }
 744
 745 PP(pp_recv)
 746 {
 747     return pp_sysread();
 748 }
 749
 750 PP(pp_seek)
 751 {
 752     return pp_sysseek();
 753 }
 754
 755 PP(pp_fcntl)
 756 {
 757     return pp_ioctl();
 758 }
 759
 760 PP(pp_gsockopt)
 761 {
 762     return pp_ssockopt();
 763 }
 764
 765 PP(pp_getsockname)
 766 {
 767     return pp_getpeername();
 768 }
 769
 770 PP(pp_lstat)
 771 {
 772     return pp_stat();
 773 }
 774
 775 PP(pp_fteowned)
 776 {
 777     return pp_ftrowned();
 778 }
 779
 780 PP(pp_ftbinary)
 781 {
 782     return pp_fttext();
 783 }
 784
 785 PP(pp_localtime)
 786 {
 787     return pp_gmtime();
 788 }
 789
 790 PP(pp_shmget)
 791 {
 792     return pp_semget();
 793 }
 794
 795 PP(pp_shmctl)
 796 {
 797     return pp_semctl();
 798 }
 799
 800 PP(pp_shmread)
 801 {
 802     return pp_shmwrite();
 803 }
 804
 805 PP(pp_msgget)
 806 {
 807     return pp_semget();
 808 }
 809
 810 PP(pp_msgctl)
 811 {
 812     return pp_semctl();
 813 }
 814
 815 PP(pp_ghbyname)
 816 {
 817     return pp_ghostent();
 818 }
 819
 820 PP(pp_ghbyaddr)
 821 {
 822     return pp_ghostent();
 823 }
 824
 825 PP(pp_gnbyname)
 826 {
 827     return pp_gnetent();
 828 }
 829
 830 PP(pp_gnbyaddr)
 831 {
 832     return pp_gnetent();
 833 }
 834
 835 PP(pp_gpbyname)
 836 {
 837     return pp_gprotoent();
 838 }
 839
 840 PP(pp_gpbynumber)
 841 {
 842     return pp_gprotoent();
 843 }
 844
 845 PP(pp_gsbyname)
 846 {
 847     return pp_gservent();
 848 }
 849
 850 PP(pp_gsbyport)
 851 {
 852     return pp_gservent();
 853 }
 854
 855 PP(pp_gpwnam)
 856 {
 857     return pp_gpwent();
 858 }
 859
 860 PP(pp_gpwuid)
 861 {
 862     return pp_gpwent();
 863 }
 864
 865 PP(pp_ggrnam)
 866 {
 867     return pp_ggrent();
 868 }
 869
 870 PP(pp_ggrgid)
 871 {
 872     return pp_ggrent();
 873 }
 874
 875 PP(pp_ftsize)
 876 {
 877     return pp_ftis();
 878 }
 879
 880 PP(pp_ftmtime)
 881 {
 882     return pp_ftis();
 883 }
 884
 885 PP(pp_ftatime)
 886 {
 887     return pp_ftis();
 888 }
 889
 890 PP(pp_ftctime)
 891 {
 892     return pp_ftis();
 893 }
 894
 895 PP(pp_ftzero)
 896 {
 897     return pp_ftrowned();
 898 }
 899
 900 PP(pp_ftsock)
 901 {
 902     return pp_ftrowned();
 903 }
 904
 905 PP(pp_ftchr)
 906 {
 907     return pp_ftrowned();
 908 }
 909
 910 PP(pp_ftblk)
 911 {
 912     return pp_ftrowned();
 913 }
 914
 915 PP(pp_ftfile)
 916 {
 917     return pp_ftrowned();
 918 }
 919
 920 PP(pp_ftdir)
 921 {
 922     return pp_ftrowned();
 923 }
 924
 925 PP(pp_ftpipe)
 926 {
 927     return pp_ftrowned();
 928 }
 929
 930 PP(pp_ftsuid)
 931 {
 932     return pp_ftrowned();
 933 }
 934
 935 PP(pp_ftsgid)
 936 {
 937     return pp_ftrowned();
 938 }
 939
 940 PP(pp_ftsvtx)
 941 {
 942     return pp_ftrowned();
 943 }
 944
 945 PP(pp_unlink)
 946 {
 947     return pp_chown();
 948 }
 949
 950 PP(pp_chmod)
 951 {
 952     return pp_chown();
 953 }
 954
 955 PP(pp_utime)
 956 {
 957     return pp_chown();
 958 }
 959
 960 PP(pp_kill)
 961 {
 962     return pp_chown();
 963 }
 964
 965 PP(pp_symlink)
 966 {
 967     return pp_link();
 968 }
 969
 970 PP(pp_ftrwrite)
 971 {
 972     return pp_ftrread();
 973 }
 974
 975 PP(pp_ftrexec)
 976 {
 977     return pp_ftrread();
 978 }
 979
 980 PP(pp_fteread)
 981 {
 982     return pp_ftrread();
 983 }
 984
 985 PP(pp_ftewrite)
 986 {
 987     return pp_ftrread();
 988 }
 989
 990 PP(pp_fteexec)
 991 {
 992     return pp_ftrread();
 993 }
 994
 995 PP(pp_msgsnd)
 996 {
 997     return pp_shmwrite();
 998 }
 999
1000 PP(pp_msgrcv)
1001 {
1002     return pp_shmwrite();
1003 }
1004
1005 PP(pp_syswrite)
1006 {
1007     return pp_send();
1008 }
1009
1010 PP(pp_semop)
1011 {
1012     return pp_shmwrite();
1013 }
1014
1015 PP(pp_dor)
1016 {
1017     return pp_defined();
1018 }
1019
1020 PP(pp_andassign)
1021 {
1022     return pp_and();
1023 }
1024
1025 PP(pp_orassign)
1026 {
1027     return pp_or();
1028 }
1029
1030 PP(pp_dorassign)
1031 {
1032     return pp_defined();
1033 }
1034
1035 PP(pp_lcfirst)
1036 {
1037     return pp_ucfirst();
1038 }
1039
1040 PP(pp_slt)
1041 {
1042     return pp_sle();
1043 }
1044
1045 PP(pp_sgt)
1046 {
1047     return pp_sle();
1048 }
1049
1050 PP(pp_sge)
1051 {
1052     return pp_sle();
1053 }
1054
1055 PP(pp_rindex)
1056 {
1057     return pp_index();
1058 }
1059
1060 PP(pp_hex)
1061 {
1062     return pp_oct();
1063 }
1064
1065 PP(pp_pop)
1066 {
1067     return pp_shift();
1068 }
1069
1070 PP(pp_cos)
1071 {
1072     return pp_sin();
1073 }
1074
1075 PP(pp_exp)
1076 {
1077     return pp_sin();
1078 }
1079
1080 PP(pp_log)
1081 {
1082     return pp_sin();
1083 }
1084
1085 PP(pp_sqrt)
1086 {
1087     return pp_sin();
1088 }
1089
1090 PP(pp_bit_xor)
1091 {
1092     return pp_bit_or();
1093 }
1094
1095 PP(pp_rv2hv)
1096 {
1097     return Perl_pp_rv2av(aTHX);
1098 }
1099
1100 U8 *
1101 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
1102 {
1103     PERL_ARGS_ASSERT_UVUNI_TO_UTF8;
1104
1105     return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
1106 }
1107
1108 bool
1109 Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
1110 {
1111     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC;
1112
1113     return is_utf8_string_loclen(s, len, ep, 0);
1114 }
1115
1116 /*
1117 =for apidoc sv_nolocking
1118
1119 Dummy routine which "locks" an SV when there is no locking module present.
1120 Exists to avoid test for a NULL function pointer and because it could
1121 potentially warn under some level of strict-ness.
1122
1123 "Superseded" by sv_nosharing().
1124
1125 =cut
1126 */
1127
1128 void
1129 Perl_sv_nolocking(pTHX_ SV *sv)
1130 {
1131     PERL_UNUSED_CONTEXT;
1132     PERL_UNUSED_ARG(sv);
1133 }
1134
1135
1136 /*
1137 =for apidoc sv_nounlocking
1138
1139 Dummy routine which "unlocks" an SV when there is no locking module present.
1140 Exists to avoid test for a NULL function pointer and because it could
1141 potentially warn under some level of strict-ness.
1142
1143 "Superseded" by sv_nosharing().
1144
1145 =cut
1146 */
1147
1148 void
1149 Perl_sv_nounlocking(pTHX_ SV *sv)
1150 {
1151     PERL_UNUSED_CONTEXT;
1152     PERL_UNUSED_ARG(sv);
1153 }
1154
1155 void
1156 Perl_save_long(pTHX_ long int *longp)
1157 {
1158     dVAR;
1159
1160     PERL_ARGS_ASSERT_SAVE_LONG;
1161
1162     SSCHECK(3);
1163     SSPUSHLONG(*longp);
1164     SSPUSHPTR(longp);
1165     SSPUSHINT(SAVEt_LONG);
1166 }
1167
1168 void
1169 Perl_save_iv(pTHX_ IV *ivp)
1170 {
1171     dVAR;
1172
1173     PERL_ARGS_ASSERT_SAVE_IV;
1174
1175     SSCHECK(3);
1176     SSPUSHIV(*ivp);
1177     SSPUSHPTR(ivp);
1178     SSPUSHINT(SAVEt_IV);
1179 }
1180
1181 void
1182 Perl_save_nogv(pTHX_ GV *gv)
1183 {
1184     dVAR;
1185
1186     PERL_ARGS_ASSERT_SAVE_NOGV;
1187
1188     SSCHECK(2);
1189     SSPUSHPTR(gv);
1190     SSPUSHINT(SAVEt_NSTAB);
1191 }
1192
1193 void
1194 Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
1195 {
1196     dVAR;
1197     register I32 i;
1198
1199     PERL_ARGS_ASSERT_SAVE_LIST;
1200
1201     for (i = 1; i <= maxsarg; i++) {
1202         register SV * const sv = newSV(0);
1203         sv_setsv(sv,sarg[i]);
1204         SSCHECK(3);
1205         SSPUSHPTR(sarg[i]);             /* remember the pointer */
1206         SSPUSHPTR(sv);                  /* remember the value */
1207         SSPUSHINT(SAVEt_ITEM);
1208     }
1209 }
1210
1211 /*
1212 =for apidoc sv_usepvn_mg
1213
1214 Like C<sv_usepvn>, but also handles 'set' magic.
1215
1216 =cut
1217 */
1218
1219 void
1220 Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len)
1221 {
1222     PERL_ARGS_ASSERT_SV_USEPVN_MG;
1223
1224     sv_usepvn_flags(sv,ptr,len, SV_SMAGIC);
1225 }
1226
1227 /*
1228 =for apidoc sv_usepvn
1229
1230 Tells an SV to use C<ptr> to find its string value. Implemented by
1231 calling C<sv_usepvn_flags> with C<flags> of 0, hence does not handle 'set'
1232 magic. See C<sv_usepvn_flags>.
1233
1234 =cut
1235 */
1236
1237 void
1238 Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
1239 {
1240     PERL_ARGS_ASSERT_SV_USEPVN;
1241
1242     sv_usepvn_flags(sv,ptr,len, 0);
1243 }
1244
1245 /*
1246 =for apidoc unpack_str
1247
1248 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
1249 and ocnt are not used. This call should not be used, use unpackstring instead.
1250
1251 =cut */
1252
1253 I32
1254 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s,
1255                 const char *strbeg, const char *strend, char **new_s, I32 ocnt,
1256                 U32 flags)
1257 {
1258     PERL_ARGS_ASSERT_UNPACK_STR;
1259
1260     PERL_UNUSED_ARG(strbeg);
1261     PERL_UNUSED_ARG(new_s);
1262     PERL_UNUSED_ARG(ocnt);
1263
1264     return unpackstring(pat, patend, s, strend, flags);
1265 }
1266
1267 /*
1268 =for apidoc pack_cat
1269
1270 The engine implementing pack() Perl function. Note: parameters next_in_list and
1271 flags are not used. This call should not be used; use packlist instead.
1272
1273 =cut
1274 */
1275
1276 void
1277 Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1278 {
1279     PERL_ARGS_ASSERT_PACK_CAT;
1280
1281     PERL_UNUSED_ARG(next_in_list);
1282     PERL_UNUSED_ARG(flags);
1283
1284     packlist(cat, pat, patend, beglist, endlist);
1285 }
1286
1287 HE *
1288 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
1289 {
1290   return (HE *)hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
1291 }
1292
1293 bool
1294 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1295 {
1296     PERL_ARGS_ASSERT_HV_EXISTS_ENT;
1297
1298     return hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
1299         ? TRUE : FALSE;
1300 }
1301
1302 HE *
1303 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash)
1304 {
1305     PERL_ARGS_ASSERT_HV_FETCH_ENT;
1306
1307     return (HE *)hv_common(hv, keysv, NULL, 0, 0,
1308                      (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
1309 }
1310
1311 SV *
1312 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1313 {
1314     PERL_ARGS_ASSERT_HV_DELETE_ENT;
1315
1316     return MUTABLE_SV(hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL,
1317                                 hash));
1318 }
1319
1320 SV**
1321 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash,
1322                     int flags)
1323 {
1324     return (SV**) hv_common(hv, NULL, key, klen, flags,
1325                             (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
1326 }
1327
1328 SV**
1329 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
1330 {
1331     STRLEN klen;
1332     int flags;
1333
1334     if (klen_i32 < 0) {
1335         klen = -klen_i32;
1336         flags = HVhek_UTF8;
1337     } else {
1338         klen = klen_i32;
1339         flags = 0;
1340     }
1341     return (SV **) hv_common(hv, NULL, key, klen, flags,
1342                              (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
1343 }
1344
1345 bool
1346 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
1347 {
1348     STRLEN klen;
1349     int flags;
1350
1351     PERL_ARGS_ASSERT_HV_EXISTS;
1352
1353     if (klen_i32 < 0) {
1354         klen = -klen_i32;
1355         flags = HVhek_UTF8;
1356     } else {
1357         klen = klen_i32;
1358         flags = 0;
1359     }
1360     return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
1361         ? TRUE : FALSE;
1362 }
1363
1364 SV**
1365 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
1366 {
1367     STRLEN klen;
1368     int flags;
1369
1370     PERL_ARGS_ASSERT_HV_FETCH;
1371
1372     if (klen_i32 < 0) {
1373         klen = -klen_i32;
1374         flags = HVhek_UTF8;
1375     } else {
1376         klen = klen_i32;
1377         flags = 0;
1378     }
1379     return (SV **) hv_common(hv, NULL, key, klen, flags,
1380                              lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE)
1381                              : HV_FETCH_JUST_SV, NULL, 0);
1382 }
1383
1384 SV *
1385 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
1386 {
1387     STRLEN klen;
1388     int k_flags;
1389
1390     PERL_ARGS_ASSERT_HV_DELETE;
1391
1392     if (klen_i32 < 0) {
1393         klen = -klen_i32;
1394         k_flags = HVhek_UTF8;
1395     } else {
1396         klen = klen_i32;
1397         k_flags = 0;
1398     }
1399     return MUTABLE_SV(hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE,
1400                                 NULL, 0));
1401 }
1402
1403 /* Functions after here were made mathoms post 5.10.0 but pre 5.8.9 */
1404
1405 AV *
1406 Perl_newAV(pTHX)
1407 {
1408     return MUTABLE_AV(newSV_type(SVt_PVAV));
1409     /* sv_upgrade does AvREAL_only():
1410     AvALLOC(av) = 0;
1411     AvARRAY(av) = NULL;
1412     AvMAX(av) = AvFILLp(av) = -1; */
1413 }
1414
1415 HV *
1416 Perl_newHV(pTHX)
1417 {
1418     HV * const hv = MUTABLE_HV(newSV_type(SVt_PVHV));
1419     assert(!SvOK(hv));
1420
1421     return hv;
1422 }
1423
1424 void
1425 Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len,
1426               const char *const little, const STRLEN littlelen)
1427 {
1428     PERL_ARGS_ASSERT_SV_INSERT;
1429     sv_insert_flags(bigstr, offset, len, little, littlelen, SV_GMAGIC);
1430 }
1431
1432 void
1433 Perl_save_freesv(pTHX_ SV *sv)
1434 {
1435     dVAR;
1436     save_freesv(sv);
1437 }
1438
1439 void
1440 Perl_save_mortalizesv(pTHX_ SV *sv)
1441 {
1442     dVAR;
1443
1444     PERL_ARGS_ASSERT_SAVE_MORTALIZESV;
1445
1446     save_mortalizesv(sv);
1447 }
1448
1449 void
1450 Perl_save_freeop(pTHX_ OP *o)
1451 {
1452     dVAR;
1453     save_freeop(o);
1454 }
1455
1456 void
1457 Perl_save_freepv(pTHX_ char *pv)
1458 {
1459     dVAR;
1460     save_freepv(pv);
1461 }
1462
1463 void
1464 Perl_save_op(pTHX)
1465 {
1466     dVAR;
1467     save_op();
1468 }
1469
1470 #endif /* NO_MATHOMS */
1471
1472 /*
1473  * Local variables:
1474  * c-indentation-style: bsd
1475  * c-basic-offset: 4
1476  * indent-tabs-mode: t
1477  * End:
1478  *
1479  * ex: set ts=8 sts=4 sw=4 noet:
1480  */