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