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 /* sv_pv() is now a macro using SvPV_nolen();
 146  * this function provided for binary compatibility only
 147  */
 148
 149 char *
 150 Perl_sv_pv(pTHX_ SV *sv)
 151 {
 152     if (SvPOK(sv))
 153         return SvPVX(sv);
 154
 155     return sv_2pv(sv, 0);
 156 }
 157
 158 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
 159  * this function provided for binary compatibility only
 160  */
 161
 162 char *
 163 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 164 {
 165     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
 166 }
 167
 168 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
 169  * this function provided for binary compatibility only
 170  */
 171
 172 char *
 173 Perl_sv_pvbyte(pTHX_ SV *sv)
 174 {
 175     sv_utf8_downgrade(sv,0);
 176     return sv_pv(sv);
 177 }
 178
 179 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
 180  * this function provided for binary compatibility only
 181  */
 182
 183 char *
 184 Perl_sv_pvutf8(pTHX_ SV *sv)
 185 {
 186     sv_utf8_upgrade(sv);
 187     return sv_pv(sv);
 188 }
 189
 190 /*
 191 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
 192
 193 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
 194 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
 195 bytes available. The return value is the pointer to the byte after the
 196 end of the new character. In other words,
 197
 198     d = uvchr_to_utf8(d, uv);
 199
 200 is the recommended wide native character-aware way of saying
 201
 202     *(d++) = uv;
 203
 204 =cut
 205 */
 206
 207 /* On ASCII machines this is normally a macro but we want a
 208    real function in case XS code wants it
 209 */
 210 #undef Perl_uvchr_to_utf8
 211 U8 *
 212 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
 213 {
 214     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
 215 }
 216
 217
 218 /*
 219 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32
 220 flags
 221
 222 Returns the native character value of the first character in the string
 223 C<s>
 224 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 225 length, in bytes, of that character.
 226
 227 Allows length and flags to be passed to low level routine.
 228
 229 =cut
 230 */
 231 /* On ASCII machines this is normally a macro but we want
 232    a real function in case XS code wants it
 233 */
 234 #undef Perl_utf8n_to_uvchr
 235 UV
 236 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
 237 U32 flags)
 238 {
 239     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
 240     return UNI_TO_NATIVE(uv);
 241 }
 242 int
 243 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
 244 {
 245     dTHXs;
 246     va_list(arglist);
 247     va_start(arglist, format);
 248     return PerlIO_vprintf(stream, format, arglist);
 249 }
 250
 251 int
 252 Perl_printf_nocontext(const char *format, ...)
 253 {
 254     dTHX;
 255     va_list(arglist);
 256     va_start(arglist, format);
 257     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
 258 }
 259
 260 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 261 /*
 262  * This hack is to force load of "huge" support from libm.a
 263  * So it is in perl for (say) POSIX to use.
 264  * Needed for SunOS with Sun's 'acc' for example.
 265  */
 266 NV
 267 Perl_huge(void)
 268 {
 269 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
 270     return HUGE_VALL;
 271 #   endif
 272     return HUGE_VAL;
 273 }
 274 #endif
 275
 276 #ifndef USE_SFIO
 277 int
 278 perlsio_binmode(FILE *fp, int iotype, int mode)
 279 {
 280     /*
 281      * This used to be contents of do_binmode in doio.c
 282      */
 283 #ifdef DOSISH
 284 #  if defined(atarist) || defined(__MINT__)
 285     if (!fflush(fp)) {
 286         if (mode & O_BINARY)
 287             ((FILE *) fp)->_flag |= _IOBIN;
 288         else
 289             ((FILE *) fp)->_flag &= ~_IOBIN;
 290         return 1;
 291     }
 292     return 0;
 293 #  else
 294     dTHX;
 295 #ifdef NETWARE
 296     if (PerlLIO_setmode(fp, mode) != -1) {
 297 #else
 298     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
 299 #endif
 300 #    if defined(WIN32) && defined(__BORLANDC__)
 301         /*
 302          * The translation mode of the stream is maintained independent
 303 of
 304          * the translation mode of the fd in the Borland RTL (heavy
 305          * digging through their runtime sources reveal).  User has to
 306 set
 307          * the mode explicitly for the stream (though they don't
 308 document
 309          * this anywhere). GSAR 97-5-24
 310          */
 311         fseek(fp, 0L, 0);
 312         if (mode & O_BINARY)
 313             fp->flags |= _F_BIN;
 314         else
 315             fp->flags &= ~_F_BIN;
 316 #    endif
 317         return 1;
 318     }
 319     else
 320         return 0;
 321 #  endif
 322 #else
 323 #  if defined(USEMYBINMODE)
 324     dTHX;
 325     if (my_binmode(fp, iotype, mode) != FALSE)
 326         return 1;
 327     else
 328         return 0;
 329 #  else
 330     PERL_UNUSED_ARG(fp);
 331     PERL_UNUSED_ARG(iotype);
 332     PERL_UNUSED_ARG(mode);
 333     return 1;
 334 #  endif
 335 #endif
 336 }
 337 #endif /* sfio */
 338
 339 /* compatibility with versions <= 5.003. */
 340 void
 341 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
 342 {
 343     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 344 }
 345
 346 /* compatibility with versions <= 5.003. */
 347 void
 348 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
 349 {
 350     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 351 }
 352
 353 void
 354 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 355 {
 356     gv_fullname4(sv, gv, prefix, TRUE);
 357 }
 358
 359 void
 360 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 361 {
 362     gv_efullname4(sv, gv, prefix, TRUE);
 363 }
 364
 365 AV *
 366 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
 367 {
 368     register SV** ary;
 369     register AV * const av = (AV*)NEWSV(9,0);
 370
 371     sv_upgrade((SV *)av, SVt_PVAV);
 372     Newx(ary,size+1,SV*);
 373     AvALLOC(av) = ary;
 374     Copy(strp,ary,size,SV*);
 375     AvREIFY_only(av);
 376     SvPV_set(av, (char*)ary);
 377     AvFILLp(av) = size - 1;
 378     AvMAX(av) = size - 1;
 379     while (size--) {
 380         assert (*strp);
 381         SvTEMP_off(*strp);
 382         strp++;
 383     }
 384     return av;
 385 }
 386
 387 bool
 388 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
 389 as_raw,
 390               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
 391               I32 num_svs)
 392 {
 393     PERL_UNUSED_ARG(num_svs);
 394     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 395                     supplied_fp, &svs, 1);
 396 }
 397
 398 int
 399 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 400 {
 401  /* The old body of this is now in non-LAYER part of perlio.c
 402   * This is a stub for any XS code which might have been calling it.
 403   */
 404  const char *name = ":raw";
 405 #ifdef PERLIO_USING_CRLF
 406  if (!(mode & O_BINARY))
 407      name = ":crlf";
 408 #endif
 409  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 410 }
 411
 412
 413 /*
 414  * Local variables:
 415  * c-indentation-style: bsd
 416  * c-basic-offset: 4
 417  * indent-tabs-mode: t
 418  * End:
 419  *
 420  * ex: set ts=8 sts=4 sw=4 noet:
 421  */