mathoms.c

   1 /*    mathoms.c
   2  *
   3  *    Copyright (C) 2005, by Larry Wall and others
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "Anything that Hobbits had no immediate use for, but were unwilling to
  12  * throw away, they called a mathom. Their dwellings were apt to become
  13  * rather crowded with mathoms, and many of the presents that passed from
  14  * hand to hand were of that sort."
  15  */
  16
  17 /*
  18  * This file contains mathoms, various binary artifacts from previous
  19  * versions of Perl.  For binary or source compatibility reasons, though,
  20  * we cannot completely remove them from the core code.
  21  *
  22  * SMP - Oct. 24, 2005
  23  *
  24  */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_MATHOMS_C
  28 #include "perl.h"
  29
  30 /* ref() is now a macro using Perl_doref;
  31  * this version provided for binary compatibility only.
  32  */
  33 OP *
  34 Perl_ref(pTHX_ OP *o, I32 type)
  35 {
  36     return doref(o, type, TRUE);
  37 }
  38
  39 /*
  40 =for apidoc sv_unref
  41
  42 Unsets the RV status of the SV, and decrements the reference count of
  43 whatever was being referenced by the RV.  This can almost be thought of
  44 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
  45 being zero.  See C<SvROK_off>.
  46
  47 =cut
  48 */
  49
  50 void
  51 Perl_sv_unref(pTHX_ SV *sv)
  52 {
  53     sv_unref_flags(sv, 0);
  54 }
  55
  56 /*
  57 =for apidoc sv_taint
  58
  59 Taint an SV. Use C<SvTAINTED_on> instead.
  60 =cut
  61 */
  62
  63 void
  64 Perl_sv_taint(pTHX_ SV *sv)
  65 {
  66     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
  67 }
  68
  69 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
  70  * this function provided for binary compatibility only
  71  */
  72
  73 IV
  74 Perl_sv_2iv(pTHX_ register SV *sv)
  75 {
  76     return sv_2iv_flags(sv, SV_GMAGIC);
  77 }
  78
  79 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
  80  * this function provided for binary compatibility only
  81  */
  82
  83 UV
  84 Perl_sv_2uv(pTHX_ register SV *sv)
  85 {
  86     return sv_2uv_flags(sv, SV_GMAGIC);
  87 }
  88
  89 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
  90  * this function provided for binary compatibility only
  91  */
  92
  93 char *
  94 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
  95 {
  96     return sv_2pv_flags(sv, lp, SV_GMAGIC);
  97 }
  98
  99 /*
 100 =for apidoc sv_2pv_nolen
 101
 102 Like C<sv_2pv()>, but doesn't return the length too. You should usually
 103 use the macro wrapper C<SvPV_nolen(sv)> instead.
 104 =cut
 105 */
 106
 107 char *
 108 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
 109 {
 110     return sv_2pv(sv, 0);
 111 }
 112
 113 /*
 114 =for apidoc sv_2pvbyte_nolen
 115
 116 Return a pointer to the byte-encoded representation of the SV.
 117 May cause the SV to be downgraded from UTF-8 as a side-effect.
 118
 119 Usually accessed via the C<SvPVbyte_nolen> macro.
 120
 121 =cut
 122 */
 123
 124 char *
 125 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
 126 {
 127     return sv_2pvbyte(sv, 0);
 128 }
 129
 130 /*
 131 =for apidoc sv_2pvutf8_nolen
 132
 133 Return a pointer to the UTF-8-encoded representation of the SV.
 134 May cause the SV to be upgraded to UTF-8 as a side-effect.
 135
 136 Usually accessed via the C<SvPVutf8_nolen> macro.
 137
 138 =cut
 139 */
 140
 141 char *
 142 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
 143 {
 144     return sv_2pvutf8(sv, 0);
 145 }
 146
 147 /*
 148 =for apidoc sv_force_normal
 149
 150 Undo various types of fakery on an SV: if the PV is a shared string, make
 151 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
 152 an xpvmg. See also C<sv_force_normal_flags>.
 153
 154 =cut
 155 */
 156
 157 void
 158 Perl_sv_force_normal(pTHX_ register SV *sv)
 159 {
 160     sv_force_normal_flags(sv, 0);
 161 }
 162
 163 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
 164  * this function provided for binary compatibility only
 165  */
 166
 167 void
 168 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 169 {
 170     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
 171 }
 172
 173 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
 174  * this function provided for binary compatibility only
 175  */
 176
 177 void
 178 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
 179 {
 180     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
 181 }
 182
 183 /*
 184 =for apidoc sv_catpvn_mg
 185
 186 Like C<sv_catpvn>, but also handles 'set' magic.
 187
 188 =cut
 189 */
 190
 191 void
 192 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
 193 {
 194     sv_catpvn_flags(sv,ptr,len,SV_GMAGIC|SV_SMAGIC);
 195 }
 196
 197 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
 198  * this function provided for binary compatibility only
 199  */
 200
 201 void
 202 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
 203 {
 204     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
 205 }
 206
 207 /*
 208 =for apidoc sv_catsv_mg
 209
 210 Like C<sv_catsv>, but also handles 'set' magic.
 211
 212 =cut
 213 */
 214
 215 void
 216 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
 217 {
 218     sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC);
 219 }
 220
 221 /*
 222 =for apidoc sv_iv
 223
 224 A private implementation of the C<SvIVx> macro for compilers which can't
 225 cope with complex macro expressions. Always use the macro instead.
 226
 227 =cut
 228 */
 229
 230 IV
 231 Perl_sv_iv(pTHX_ register SV *sv)
 232 {
 233     if (SvIOK(sv)) {
 234         if (SvIsUV(sv))
 235             return (IV)SvUVX(sv);
 236         return SvIVX(sv);
 237     }
 238     return sv_2iv(sv);
 239 }
 240
 241 /*
 242 =for apidoc sv_uv
 243
 244 A private implementation of the C<SvUVx> macro for compilers which can't
 245 cope with complex macro expressions. Always use the macro instead.
 246
 247 =cut
 248 */
 249
 250 UV
 251 Perl_sv_uv(pTHX_ register SV *sv)
 252 {
 253     if (SvIOK(sv)) {
 254         if (SvIsUV(sv))
 255             return SvUVX(sv);
 256         return (UV)SvIVX(sv);
 257     }
 258     return sv_2uv(sv);
 259 }
 260
 261 /*
 262 =for apidoc sv_nv
 263
 264 A private implementation of the C<SvNVx> macro for compilers which can't
 265 cope with complex macro expressions. Always use the macro instead.
 266
 267 =cut
 268 */
 269
 270 NV
 271 Perl_sv_nv(pTHX_ register SV *sv)
 272 {
 273     if (SvNOK(sv))
 274         return SvNVX(sv);
 275     return sv_2nv(sv);
 276 }
 277
 278 /*
 279 =for apidoc sv_pv
 280
 281 Use the C<SvPV_nolen> macro instead
 282
 283 =for apidoc sv_pvn
 284
 285 A private implementation of the C<SvPV> macro for compilers which can't
 286 cope with complex macro expressions. Always use the macro instead.
 287
 288 =cut
 289 */
 290
 291 char *
 292 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
 293 {
 294     if (SvPOK(sv)) {
 295         *lp = SvCUR(sv);
 296         return SvPVX(sv);
 297     }
 298     return sv_2pv(sv, lp);
 299 }
 300
 301
 302 char *
 303 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
 304 {
 305     if (SvPOK(sv)) {
 306         *lp = SvCUR(sv);
 307         return SvPVX(sv);
 308     }
 309     return sv_2pv_flags(sv, lp, 0);
 310 }
 311
 312 /* sv_pv() is now a macro using SvPV_nolen();
 313  * this function provided for binary compatibility only
 314  */
 315
 316 char *
 317 Perl_sv_pv(pTHX_ SV *sv)
 318 {
 319     if (SvPOK(sv))
 320         return SvPVX(sv);
 321
 322     return sv_2pv(sv, 0);
 323 }
 324
 325 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
 326  * this function provided for binary compatibility only
 327  */
 328
 329 char *
 330 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 331 {
 332     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
 333 }
 334
 335 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
 336  * this function provided for binary compatibility only
 337  */
 338
 339 char *
 340 Perl_sv_pvbyte(pTHX_ SV *sv)
 341 {
 342     sv_utf8_downgrade(sv,0);
 343     return sv_pv(sv);
 344 }
 345
 346 /*
 347 =for apidoc sv_pvbyte
 348
 349 Use C<SvPVbyte_nolen> instead.
 350
 351 =for apidoc sv_pvbyten
 352
 353 A private implementation of the C<SvPVbyte> macro for compilers
 354 which can't cope with complex macro expressions. Always use the macro
 355 instead.
 356
 357 =cut
 358 */
 359
 360 char *
 361 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
 362 {
 363     sv_utf8_downgrade(sv,0);
 364     return sv_pvn(sv,lp);
 365 }
 366
 367 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
 368  * this function provided for binary compatibility only
 369  */
 370
 371 char *
 372 Perl_sv_pvutf8(pTHX_ SV *sv)
 373 {
 374     sv_utf8_upgrade(sv);
 375     return sv_pv(sv);
 376 }
 377
 378 /*
 379 =for apidoc sv_pvutf8
 380
 381 Use the C<SvPVutf8_nolen> macro instead
 382
 383 =for apidoc sv_pvutf8n
 384
 385 A private implementation of the C<SvPVutf8> macro for compilers
 386 which can't cope with complex macro expressions. Always use the macro
 387 instead.
 388
 389 =cut
 390 */
 391
 392 char *
 393 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
 394 {
 395     sv_utf8_upgrade(sv);
 396     return sv_pvn(sv,lp);
 397 }
 398
 399 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
 400  * this function provided for binary compatibility only
 401  */
 402
 403 STRLEN
 404 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 405 {
 406     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
 407 }
 408
 409 /*
 410 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
 411
 412 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
 413 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
 414 bytes available. The return value is the pointer to the byte after the
 415 end of the new character. In other words,
 416
 417     d = uvchr_to_utf8(d, uv);
 418
 419 is the recommended wide native character-aware way of saying
 420
 421     *(d++) = uv;
 422
 423 =cut
 424 */
 425
 426 /* On ASCII machines this is normally a macro but we want a
 427    real function in case XS code wants it
 428 */
 429 #undef Perl_uvchr_to_utf8
 430 U8 *
 431 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
 432 {
 433     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
 434 }
 435
 436
 437 /*
 438 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32
 439 flags
 440
 441 Returns the native character value of the first character in the string
 442 C<s>
 443 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 444 length, in bytes, of that character.
 445
 446 Allows length and flags to be passed to low level routine.
 447
 448 =cut
 449 */
 450 /* On ASCII machines this is normally a macro but we want
 451    a real function in case XS code wants it
 452 */
 453 #undef Perl_utf8n_to_uvchr
 454 UV
 455 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
 456 U32 flags)
 457 {
 458     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
 459     return UNI_TO_NATIVE(uv);
 460 }
 461 int
 462 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
 463 {
 464     dTHXs;
 465     va_list(arglist);
 466     va_start(arglist, format);
 467     return PerlIO_vprintf(stream, format, arglist);
 468 }
 469
 470 int
 471 Perl_printf_nocontext(const char *format, ...)
 472 {
 473     dTHX;
 474     va_list(arglist);
 475     va_start(arglist, format);
 476     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
 477 }
 478
 479 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 480 /*
 481  * This hack is to force load of "huge" support from libm.a
 482  * So it is in perl for (say) POSIX to use.
 483  * Needed for SunOS with Sun's 'acc' for example.
 484  */
 485 NV
 486 Perl_huge(void)
 487 {
 488 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
 489     return HUGE_VALL;
 490 #   endif
 491     return HUGE_VAL;
 492 }
 493 #endif
 494
 495 #ifndef USE_SFIO
 496 int
 497 perlsio_binmode(FILE *fp, int iotype, int mode)
 498 {
 499     /*
 500      * This used to be contents of do_binmode in doio.c
 501      */
 502 #ifdef DOSISH
 503 #  if defined(atarist) || defined(__MINT__)
 504     if (!fflush(fp)) {
 505         if (mode & O_BINARY)
 506             ((FILE *) fp)->_flag |= _IOBIN;
 507         else
 508             ((FILE *) fp)->_flag &= ~_IOBIN;
 509         return 1;
 510     }
 511     return 0;
 512 #  else
 513     dTHX;
 514 #ifdef NETWARE
 515     if (PerlLIO_setmode(fp, mode) != -1) {
 516 #else
 517     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
 518 #endif
 519 #    if defined(WIN32) && defined(__BORLANDC__)
 520         /*
 521          * The translation mode of the stream is maintained independent
 522 of
 523          * the translation mode of the fd in the Borland RTL (heavy
 524          * digging through their runtime sources reveal).  User has to
 525 set
 526          * the mode explicitly for the stream (though they don't
 527 document
 528          * this anywhere). GSAR 97-5-24
 529          */
 530         fseek(fp, 0L, 0);
 531         if (mode & O_BINARY)
 532             fp->flags |= _F_BIN;
 533         else
 534             fp->flags &= ~_F_BIN;
 535 #    endif
 536         return 1;
 537     }
 538     else
 539         return 0;
 540 #  endif
 541 #else
 542 #  if defined(USEMYBINMODE)
 543     dTHX;
 544     if (my_binmode(fp, iotype, mode) != FALSE)
 545         return 1;
 546     else
 547         return 0;
 548 #  else
 549     PERL_UNUSED_ARG(fp);
 550     PERL_UNUSED_ARG(iotype);
 551     PERL_UNUSED_ARG(mode);
 552     return 1;
 553 #  endif
 554 #endif
 555 }
 556 #endif /* sfio */
 557
 558 /* compatibility with versions <= 5.003. */
 559 void
 560 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
 561 {
 562     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 563 }
 564
 565 /* compatibility with versions <= 5.003. */
 566 void
 567 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
 568 {
 569     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 570 }
 571
 572 void
 573 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 574 {
 575     gv_fullname4(sv, gv, prefix, TRUE);
 576 }
 577
 578 void
 579 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 580 {
 581     gv_efullname4(sv, gv, prefix, TRUE);
 582 }
 583
 584 /*
 585 =for apidoc gv_fetchmethod
 586
 587 See L<gv_fetchmethod_autoload>.
 588
 589 =cut
 590 */
 591
 592 GV *
 593 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 594 {
 595     return gv_fetchmethod_autoload(stash, name, TRUE);
 596 }
 597
 598 HE *
 599 Perl_hv_iternext(pTHX_ HV *hv)
 600 {
 601     return hv_iternext_flags(hv, 0);
 602 }
 603
 604 AV *
 605 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
 606 {
 607     register SV** ary;
 608     register AV * const av = (AV*)NEWSV(9,0);
 609
 610     sv_upgrade((SV *)av, SVt_PVAV);
 611     Newx(ary,size+1,SV*);
 612     AvALLOC(av) = ary;
 613     Copy(strp,ary,size,SV*);
 614     AvREIFY_only(av);
 615     SvPV_set(av, (char*)ary);
 616     AvFILLp(av) = size - 1;
 617     AvMAX(av) = size - 1;
 618     while (size--) {
 619         assert (*strp);
 620         SvTEMP_off(*strp);
 621         strp++;
 622     }
 623     return av;
 624 }
 625
 626 bool
 627 Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
 628              int rawmode, int rawperm, PerlIO *supplied_fp)
 629 {
 630     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 631                     supplied_fp, (SV **) NULL, 0);
 632 }
 633
 634 bool
 635 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
 636 as_raw,
 637               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
 638               I32 num_svs)
 639 {
 640     PERL_UNUSED_ARG(num_svs);
 641     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 642                     supplied_fp, &svs, 1);
 643 }
 644
 645 int
 646 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 647 {
 648  /* The old body of this is now in non-LAYER part of perlio.c
 649   * This is a stub for any XS code which might have been calling it.
 650   */
 651  const char *name = ":raw";
 652 #ifdef PERLIO_USING_CRLF
 653  if (!(mode & O_BINARY))
 654      name = ":crlf";
 655 #endif
 656  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 657 }
 658
 659 #ifndef OS2
 660 bool
 661 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
 662 {
 663     return do_aexec5(really, mark, sp, 0, 0);
 664 }
 665 #endif
 666
 667 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
 668 bool
 669 Perl_do_exec(pTHX_ const char *cmd)
 670 {
 671     return do_exec3(cmd,0,0);
 672 }
 673 #endif
 674
 675 #ifdef HAS_PIPE
 676 void
 677 Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
 678 {
 679     register IO *rstio;
 680     register IO *wstio;
 681     int fd[2];
 682
 683     if (!rgv)
 684         goto badexit;
 685     if (!wgv)
 686         goto badexit;
 687
 688     rstio = GvIOn(rgv);
 689     wstio = GvIOn(wgv);
 690
 691     if (IoIFP(rstio))
 692         do_close(rgv,FALSE);
 693     if (IoIFP(wstio))
 694         do_close(wgv,FALSE);
 695
 696     if (PerlProc_pipe(fd) < 0)
 697         goto badexit;
 698     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
 699     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
 700     IoOFP(rstio) = IoIFP(rstio);
 701     IoIFP(wstio) = IoOFP(wstio);
 702     IoTYPE(rstio) = IoTYPE_RDONLY;
 703     IoTYPE(wstio) = IoTYPE_WRONLY;
 704     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 705         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 706         else PerlLIO_close(fd[0]);
 707         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 708         else PerlLIO_close(fd[1]);
 709         goto badexit;
 710     }
 711
 712     sv_setsv(sv,&PL_sv_yes);
 713     return;
 714
 715 badexit:
 716     sv_setsv(sv,&PL_sv_undef);
 717     return;
 718 }
 719 #endif
 720
 721 /*
 722  * Local variables:
 723  * c-indentation-style: bsd
 724  * c-basic-offset: 4
 725  * indent-tabs-mode: t
 726  * End:
 727  *
 728  * ex: set ts=8 sts=4 sw=4 noet:
 729  */