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 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
 184  * this function provided for binary compatibility only
 185  */
 186
 187 void
 188 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
 189 {
 190     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
 191 }
 192
 193 /*
 194 =for apidoc sv_iv
 195
 196 A private implementation of the C<SvIVx> macro for compilers which can't
 197 cope with complex macro expressions. Always use the macro instead.
 198
 199 =cut
 200 */
 201
 202 IV
 203 Perl_sv_iv(pTHX_ register SV *sv)
 204 {
 205     if (SvIOK(sv)) {
 206         if (SvIsUV(sv))
 207             return (IV)SvUVX(sv);
 208         return SvIVX(sv);
 209     }
 210     return sv_2iv(sv);
 211 }
 212
 213 /*
 214 =for apidoc sv_uv
 215
 216 A private implementation of the C<SvUVx> macro for compilers which can't
 217 cope with complex macro expressions. Always use the macro instead.
 218
 219 =cut
 220 */
 221
 222 UV
 223 Perl_sv_uv(pTHX_ register SV *sv)
 224 {
 225     if (SvIOK(sv)) {
 226         if (SvIsUV(sv))
 227             return SvUVX(sv);
 228         return (UV)SvIVX(sv);
 229     }
 230     return sv_2uv(sv);
 231 }
 232
 233 /*
 234 =for apidoc sv_nv
 235
 236 A private implementation of the C<SvNVx> macro for compilers which can't
 237 cope with complex macro expressions. Always use the macro instead.
 238
 239 =cut
 240 */
 241
 242 NV
 243 Perl_sv_nv(pTHX_ register SV *sv)
 244 {
 245     if (SvNOK(sv))
 246         return SvNVX(sv);
 247     return sv_2nv(sv);
 248 }
 249
 250 /*
 251 =for apidoc sv_pv
 252
 253 Use the C<SvPV_nolen> macro instead
 254
 255 =for apidoc sv_pvn
 256
 257 A private implementation of the C<SvPV> macro for compilers which can't
 258 cope with complex macro expressions. Always use the macro instead.
 259
 260 =cut
 261 */
 262
 263 char *
 264 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
 265 {
 266     if (SvPOK(sv)) {
 267         *lp = SvCUR(sv);
 268         return SvPVX(sv);
 269     }
 270     return sv_2pv(sv, lp);
 271 }
 272
 273
 274 char *
 275 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
 276 {
 277     if (SvPOK(sv)) {
 278         *lp = SvCUR(sv);
 279         return SvPVX(sv);
 280     }
 281     return sv_2pv_flags(sv, lp, 0);
 282 }
 283
 284 /* sv_pv() is now a macro using SvPV_nolen();
 285  * this function provided for binary compatibility only
 286  */
 287
 288 char *
 289 Perl_sv_pv(pTHX_ SV *sv)
 290 {
 291     if (SvPOK(sv))
 292         return SvPVX(sv);
 293
 294     return sv_2pv(sv, 0);
 295 }
 296
 297 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
 298  * this function provided for binary compatibility only
 299  */
 300
 301 char *
 302 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 303 {
 304     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
 305 }
 306
 307 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
 308  * this function provided for binary compatibility only
 309  */
 310
 311 char *
 312 Perl_sv_pvbyte(pTHX_ SV *sv)
 313 {
 314     sv_utf8_downgrade(sv,0);
 315     return sv_pv(sv);
 316 }
 317
 318 /*
 319 =for apidoc sv_pvbyte
 320
 321 Use C<SvPVbyte_nolen> instead.
 322
 323 =for apidoc sv_pvbyten
 324
 325 A private implementation of the C<SvPVbyte> macro for compilers
 326 which can't cope with complex macro expressions. Always use the macro
 327 instead.
 328
 329 =cut
 330 */
 331
 332 char *
 333 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
 334 {
 335     sv_utf8_downgrade(sv,0);
 336     return sv_pvn(sv,lp);
 337 }
 338
 339 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
 340  * this function provided for binary compatibility only
 341  */
 342
 343 char *
 344 Perl_sv_pvutf8(pTHX_ SV *sv)
 345 {
 346     sv_utf8_upgrade(sv);
 347     return sv_pv(sv);
 348 }
 349
 350 /*
 351 =for apidoc sv_pvutf8
 352
 353 Use the C<SvPVutf8_nolen> macro instead
 354
 355 =for apidoc sv_pvutf8n
 356
 357 A private implementation of the C<SvPVutf8> macro for compilers
 358 which can't cope with complex macro expressions. Always use the macro
 359 instead.
 360
 361 =cut
 362 */
 363
 364 char *
 365 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
 366 {
 367     sv_utf8_upgrade(sv);
 368     return sv_pvn(sv,lp);
 369 }
 370
 371 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
 372  * this function provided for binary compatibility only
 373  */
 374
 375 STRLEN
 376 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 377 {
 378     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
 379 }
 380
 381 /*
 382 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
 383
 384 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
 385 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
 386 bytes available. The return value is the pointer to the byte after the
 387 end of the new character. In other words,
 388
 389     d = uvchr_to_utf8(d, uv);
 390
 391 is the recommended wide native character-aware way of saying
 392
 393     *(d++) = uv;
 394
 395 =cut
 396 */
 397
 398 /* On ASCII machines this is normally a macro but we want a
 399    real function in case XS code wants it
 400 */
 401 #undef Perl_uvchr_to_utf8
 402 U8 *
 403 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
 404 {
 405     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
 406 }
 407
 408
 409 /*
 410 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32
 411 flags
 412
 413 Returns the native character value of the first character in the string
 414 C<s>
 415 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 416 length, in bytes, of that character.
 417
 418 Allows length and flags to be passed to low level routine.
 419
 420 =cut
 421 */
 422 /* On ASCII machines this is normally a macro but we want
 423    a real function in case XS code wants it
 424 */
 425 #undef Perl_utf8n_to_uvchr
 426 UV
 427 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
 428 U32 flags)
 429 {
 430     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
 431     return UNI_TO_NATIVE(uv);
 432 }
 433 int
 434 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
 435 {
 436     dTHXs;
 437     va_list(arglist);
 438     va_start(arglist, format);
 439     return PerlIO_vprintf(stream, format, arglist);
 440 }
 441
 442 int
 443 Perl_printf_nocontext(const char *format, ...)
 444 {
 445     dTHX;
 446     va_list(arglist);
 447     va_start(arglist, format);
 448     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
 449 }
 450
 451 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 452 /*
 453  * This hack is to force load of "huge" support from libm.a
 454  * So it is in perl for (say) POSIX to use.
 455  * Needed for SunOS with Sun's 'acc' for example.
 456  */
 457 NV
 458 Perl_huge(void)
 459 {
 460 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
 461     return HUGE_VALL;
 462 #   endif
 463     return HUGE_VAL;
 464 }
 465 #endif
 466
 467 #ifndef USE_SFIO
 468 int
 469 perlsio_binmode(FILE *fp, int iotype, int mode)
 470 {
 471     /*
 472      * This used to be contents of do_binmode in doio.c
 473      */
 474 #ifdef DOSISH
 475 #  if defined(atarist) || defined(__MINT__)
 476     if (!fflush(fp)) {
 477         if (mode & O_BINARY)
 478             ((FILE *) fp)->_flag |= _IOBIN;
 479         else
 480             ((FILE *) fp)->_flag &= ~_IOBIN;
 481         return 1;
 482     }
 483     return 0;
 484 #  else
 485     dTHX;
 486 #ifdef NETWARE
 487     if (PerlLIO_setmode(fp, mode) != -1) {
 488 #else
 489     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
 490 #endif
 491 #    if defined(WIN32) && defined(__BORLANDC__)
 492         /*
 493          * The translation mode of the stream is maintained independent
 494 of
 495          * the translation mode of the fd in the Borland RTL (heavy
 496          * digging through their runtime sources reveal).  User has to
 497 set
 498          * the mode explicitly for the stream (though they don't
 499 document
 500          * this anywhere). GSAR 97-5-24
 501          */
 502         fseek(fp, 0L, 0);
 503         if (mode & O_BINARY)
 504             fp->flags |= _F_BIN;
 505         else
 506             fp->flags &= ~_F_BIN;
 507 #    endif
 508         return 1;
 509     }
 510     else
 511         return 0;
 512 #  endif
 513 #else
 514 #  if defined(USEMYBINMODE)
 515     dTHX;
 516     if (my_binmode(fp, iotype, mode) != FALSE)
 517         return 1;
 518     else
 519         return 0;
 520 #  else
 521     PERL_UNUSED_ARG(fp);
 522     PERL_UNUSED_ARG(iotype);
 523     PERL_UNUSED_ARG(mode);
 524     return 1;
 525 #  endif
 526 #endif
 527 }
 528 #endif /* sfio */
 529
 530 /* compatibility with versions <= 5.003. */
 531 void
 532 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
 533 {
 534     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 535 }
 536
 537 /* compatibility with versions <= 5.003. */
 538 void
 539 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
 540 {
 541     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 542 }
 543
 544 void
 545 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 546 {
 547     gv_fullname4(sv, gv, prefix, TRUE);
 548 }
 549
 550 void
 551 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 552 {
 553     gv_efullname4(sv, gv, prefix, TRUE);
 554 }
 555
 556 AV *
 557 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
 558 {
 559     register SV** ary;
 560     register AV * const av = (AV*)NEWSV(9,0);
 561
 562     sv_upgrade((SV *)av, SVt_PVAV);
 563     Newx(ary,size+1,SV*);
 564     AvALLOC(av) = ary;
 565     Copy(strp,ary,size,SV*);
 566     AvREIFY_only(av);
 567     SvPV_set(av, (char*)ary);
 568     AvFILLp(av) = size - 1;
 569     AvMAX(av) = size - 1;
 570     while (size--) {
 571         assert (*strp);
 572         SvTEMP_off(*strp);
 573         strp++;
 574     }
 575     return av;
 576 }
 577
 578 bool
 579 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
 580 as_raw,
 581               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
 582               I32 num_svs)
 583 {
 584     PERL_UNUSED_ARG(num_svs);
 585     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 586                     supplied_fp, &svs, 1);
 587 }
 588
 589 int
 590 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 591 {
 592  /* The old body of this is now in non-LAYER part of perlio.c
 593   * This is a stub for any XS code which might have been calling it.
 594   */
 595  const char *name = ":raw";
 596 #ifdef PERLIO_USING_CRLF
 597  if (!(mode & O_BINARY))
 598      name = ":crlf";
 599 #endif
 600  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 601 }
 602
 603
 604 /*
 605  * Local variables:
 606  * c-indentation-style: bsd
 607  * c-basic-offset: 4
 608  * indent-tabs-mode: t
 609  * End:
 610  *
 611  * ex: set ts=8 sts=4 sw=4 noet:
 612  */