mathoms.c

   1 /*    mathoms.c
   2  *
   3  *    Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010,
   4  *    2011, 2012 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *  Anything that Hobbits had no immediate use for, but were unwilling to
  13  *  throw away, they called a mathom.  Their dwellings were apt to become
  14  *  rather crowded with mathoms, and many of the presents that passed from
  15  *  hand to hand were of that sort.
  16  *
  17  *     [p.5 of _The Lord of the Rings_: "Prologue"]
  18  */
  19
  20
  21
  22 /*
  23  * This file contains mathoms, various binary artifacts from previous
  24  * versions of Perl.  For binary or source compatibility reasons, though,
  25  * we cannot completely remove them from the core code.
  26  *
  27  * SMP - Oct. 24, 2005
  28  *
  29  * The compilation of this file can be suppressed; see INSTALL
  30  *
  31  */
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_MATHOMS_C
  35 #include "perl.h"
  36
  37 #ifdef NO_MATHOMS
  38 /* ..." warning: ISO C forbids an empty source file"
  39    So make sure we have something in here by processing the headers anyway.
  40  */
  41 #else
  42
  43 /* Not all of these have prototypes elsewhere, so do this to get
  44  * non-mangled names.
  45  */
  46 START_EXTERN_C
  47
  48 PERL_CALLCONV OP * Perl_ref(pTHX_ OP *o, I32 type);
  49 PERL_CALLCONV void Perl_sv_unref(pTHX_ SV *sv);
  50 PERL_CALLCONV void Perl_sv_taint(pTHX_ SV *sv);
  51 PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV *sv);
  52 PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV *sv);
  53 PERL_CALLCONV NV Perl_sv_2nv(pTHX_ SV *sv);
  54 PERL_CALLCONV char * Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp);
  55 PERL_CALLCONV char * Perl_sv_2pv_nolen(pTHX_ SV *sv);
  56 PERL_CALLCONV char * Perl_sv_2pvbyte_nolen(pTHX_ SV *sv);
  57 PERL_CALLCONV char * Perl_sv_2pvutf8_nolen(pTHX_ SV *sv);
  58 PERL_CALLCONV void Perl_sv_force_normal(pTHX_ SV *sv);
  59 PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr);
  60 PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen);
  61 PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len);
  62 PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr);
  63 PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv);
  64 PERL_CALLCONV char * Perl_sv_pv(pTHX_ SV *sv);
  65 PERL_CALLCONV char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp);
  66 PERL_CALLCONV char * Perl_sv_pvbyte(pTHX_ SV *sv);
  67 PERL_CALLCONV char * Perl_sv_pvutf8(pTHX_ SV *sv);
  68 PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ SV *sv);
  69 PERL_CALLCONV NV Perl_huge(void);
  70 PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
  71 PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
  72 PERL_CALLCONV GV * Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name);
  73 PERL_CALLCONV HE * Perl_hv_iternext(pTHX_ HV *hv);
  74 PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how);
  75 PERL_CALLCONV bool Perl_do_open(pTHX_ GV *gv, const char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp);
  76 PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV *really, SV **mark, SV **sp);
  77 PERL_CALLCONV U8 * Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv);
  78 PERL_CALLCONV bool Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep);
  79 PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv);
  80 PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len);
  81 PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len);
  82 PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...);
  83 PERL_CALLCONV int Perl_printf_nocontext(const char *format, ...);
  84 PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg);
  85 PERL_CALLCONV AV * Perl_newAV(pTHX);
  86 PERL_CALLCONV HV * Perl_newHV(pTHX);
  87 PERL_CALLCONV IO * Perl_newIO(pTHX);
  88 PERL_CALLCONV I32 Perl_my_stat(pTHX);
  89 PERL_CALLCONV I32 Perl_my_lstat(pTHX);
  90 PERL_CALLCONV I32 Perl_sv_eq(pTHX_ SV *sv1, SV *sv2);
  91 PERL_CALLCONV char * Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp);
  92 PERL_CALLCONV bool Perl_sv_2bool(pTHX_ SV *const sv);
  93 PERL_CALLCONV CV * Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block);
  94 PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
  95 PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
  96 PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
  97 PERL_CALLCONV UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
  98 PERL_CALLCONV SV *Perl_sv_mortalcopy(pTHX_ SV *const oldstr);
  99
 100 /* ref() is now a macro using Perl_doref;
 101  * this version provided for binary compatibility only.
 102  */
 103 OP *
 104 Perl_ref(pTHX_ OP *o, I32 type)
 105 {
 106     return doref(o, type, TRUE);
 107 }
 108
 109 /*
 110 =for apidoc sv_unref
 111
 112 Unsets the RV status of the SV, and decrements the reference count of
 113 whatever was being referenced by the RV.  This can almost be thought of
 114 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
 115 being zero.  See C<SvROK_off>.
 116
 117 =cut
 118 */
 119
 120 void
 121 Perl_sv_unref(pTHX_ SV *sv)
 122 {
 123     PERL_ARGS_ASSERT_SV_UNREF;
 124
 125     sv_unref_flags(sv, 0);
 126 }
 127
 128 /*
 129 =for apidoc sv_taint
 130
 131 Taint an SV.  Use C<SvTAINTED_on> instead.
 132
 133 =cut
 134 */
 135
 136 void
 137 Perl_sv_taint(pTHX_ SV *sv)
 138 {
 139     PERL_ARGS_ASSERT_SV_TAINT;
 140
 141     sv_magic((sv), NULL, PERL_MAGIC_taint, NULL, 0);
 142 }
 143
 144 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
 145  * this function provided for binary compatibility only
 146  */
 147
 148 IV
 149 Perl_sv_2iv(pTHX_ SV *sv)
 150 {
 151     PERL_ARGS_ASSERT_SV_2IV;
 152
 153     return sv_2iv_flags(sv, SV_GMAGIC);
 154 }
 155
 156 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
 157  * this function provided for binary compatibility only
 158  */
 159
 160 UV
 161 Perl_sv_2uv(pTHX_ SV *sv)
 162 {
 163     PERL_ARGS_ASSERT_SV_2UV;
 164
 165     return sv_2uv_flags(sv, SV_GMAGIC);
 166 }
 167
 168 /* sv_2nv() is now a macro using Perl_sv_2nv_flags();
 169  * this function provided for binary compatibility only
 170  */
 171
 172 NV
 173 Perl_sv_2nv(pTHX_ SV *sv)
 174 {
 175     return sv_2nv_flags(sv, SV_GMAGIC);
 176 }
 177
 178
 179 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
 180  * this function provided for binary compatibility only
 181  */
 182
 183 char *
 184 Perl_sv_2pv(pTHX_ SV *sv, STRLEN *lp)
 185 {
 186     PERL_ARGS_ASSERT_SV_2PV;
 187
 188     return sv_2pv_flags(sv, lp, SV_GMAGIC);
 189 }
 190
 191 /*
 192 =for apidoc sv_2pv_nolen
 193
 194 Like C<sv_2pv()>, but doesn't return the length too.  You should usually
 195 use the macro wrapper C<SvPV_nolen(sv)> instead.
 196
 197 =cut
 198 */
 199
 200 char *
 201 Perl_sv_2pv_nolen(pTHX_ SV *sv)
 202 {
 203     PERL_ARGS_ASSERT_SV_2PV_NOLEN;
 204     return sv_2pv(sv, NULL);
 205 }
 206
 207 /*
 208 =for apidoc sv_2pvbyte_nolen
 209
 210 Return a pointer to the byte-encoded representation of the SV.
 211 May cause the SV to be downgraded from UTF-8 as a side-effect.
 212
 213 Usually accessed via the C<SvPVbyte_nolen> macro.
 214
 215 =cut
 216 */
 217
 218 char *
 219 Perl_sv_2pvbyte_nolen(pTHX_ SV *sv)
 220 {
 221     PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN;
 222
 223     return sv_2pvbyte(sv, NULL);
 224 }
 225
 226 /*
 227 =for apidoc sv_2pvutf8_nolen
 228
 229 Return a pointer to the UTF-8-encoded representation of the SV.
 230 May cause the SV to be upgraded to UTF-8 as a side-effect.
 231
 232 Usually accessed via the C<SvPVutf8_nolen> macro.
 233
 234 =cut
 235 */
 236
 237 char *
 238 Perl_sv_2pvutf8_nolen(pTHX_ SV *sv)
 239 {
 240     PERL_ARGS_ASSERT_SV_2PVUTF8_NOLEN;
 241
 242     return sv_2pvutf8(sv, NULL);
 243 }
 244
 245 /*
 246 =for apidoc sv_force_normal
 247
 248 Undo various types of fakery on an SV: if the PV is a shared string, make
 249 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
 250 an xpvmg.  See also C<sv_force_normal_flags>.
 251
 252 =cut
 253 */
 254
 255 void
 256 Perl_sv_force_normal(pTHX_ SV *sv)
 257 {
 258     PERL_ARGS_ASSERT_SV_FORCE_NORMAL;
 259
 260     sv_force_normal_flags(sv, 0);
 261 }
 262
 263 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
 264  * this function provided for binary compatibility only
 265  */
 266
 267 void
 268 Perl_sv_setsv(pTHX_ SV *dstr, SV *sstr)
 269 {
 270     PERL_ARGS_ASSERT_SV_SETSV;
 271
 272     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
 273 }
 274
 275 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
 276  * this function provided for binary compatibility only
 277  */
 278
 279 void
 280 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
 281 {
 282     PERL_ARGS_ASSERT_SV_CATPVN;
 283
 284     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
 285 }
 286
 287 /*
 288 =for apidoc sv_catpvn_mg
 289
 290 Like C<sv_catpvn>, but also handles 'set' magic.
 291
 292 =cut
 293 */
 294
 295 void
 296 Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len)
 297 {
 298     PERL_ARGS_ASSERT_SV_CATPVN_MG;
 299
 300     sv_catpvn_flags(sv,ptr,len,SV_GMAGIC|SV_SMAGIC);
 301 }
 302
 303 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
 304  * this function provided for binary compatibility only
 305  */
 306
 307 void
 308 Perl_sv_catsv(pTHX_ SV *dstr, SV *sstr)
 309 {
 310     PERL_ARGS_ASSERT_SV_CATSV;
 311
 312     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
 313 }
 314
 315 /*
 316 =for apidoc sv_catsv_mg
 317
 318 Like C<sv_catsv>, but also handles 'set' magic.
 319
 320 =cut
 321 */
 322
 323 void
 324 Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *ssv)
 325 {
 326     PERL_ARGS_ASSERT_SV_CATSV_MG;
 327
 328     sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC);
 329 }
 330
 331 /*
 332 =for apidoc sv_iv
 333
 334 A private implementation of the C<SvIVx> macro for compilers which can't
 335 cope with complex macro expressions.  Always use the macro instead.
 336
 337 =cut
 338 */
 339
 340 IV
 341 Perl_sv_iv(pTHX_ SV *sv)
 342 {
 343     PERL_ARGS_ASSERT_SV_IV;
 344
 345     if (SvIOK(sv)) {
 346         if (SvIsUV(sv))
 347             return (IV)SvUVX(sv);
 348         return SvIVX(sv);
 349     }
 350     return sv_2iv(sv);
 351 }
 352
 353 /*
 354 =for apidoc sv_uv
 355
 356 A private implementation of the C<SvUVx> macro for compilers which can't
 357 cope with complex macro expressions.  Always use the macro instead.
 358
 359 =cut
 360 */
 361
 362 UV
 363 Perl_sv_uv(pTHX_ SV *sv)
 364 {
 365     PERL_ARGS_ASSERT_SV_UV;
 366
 367     if (SvIOK(sv)) {
 368         if (SvIsUV(sv))
 369             return SvUVX(sv);
 370         return (UV)SvIVX(sv);
 371     }
 372     return sv_2uv(sv);
 373 }
 374
 375 /*
 376 =for apidoc sv_nv
 377
 378 A private implementation of the C<SvNVx> macro for compilers which can't
 379 cope with complex macro expressions.  Always use the macro instead.
 380
 381 =cut
 382 */
 383
 384 NV
 385 Perl_sv_nv(pTHX_ SV *sv)
 386 {
 387     PERL_ARGS_ASSERT_SV_NV;
 388
 389     if (SvNOK(sv))
 390         return SvNVX(sv);
 391     return sv_2nv(sv);
 392 }
 393
 394 /*
 395 =for apidoc sv_pv
 396
 397 Use the C<SvPV_nolen> macro instead
 398
 399 =for apidoc sv_pvn
 400
 401 A private implementation of the C<SvPV> macro for compilers which can't
 402 cope with complex macro expressions.  Always use the macro instead.
 403
 404 =cut
 405 */
 406
 407 char *
 408 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
 409 {
 410     PERL_ARGS_ASSERT_SV_PVN;
 411
 412     if (SvPOK(sv)) {
 413         *lp = SvCUR(sv);
 414         return SvPVX(sv);
 415     }
 416     return sv_2pv(sv, lp);
 417 }
 418
 419
 420 char *
 421 Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp)
 422 {
 423     PERL_ARGS_ASSERT_SV_PVN_NOMG;
 424
 425     if (SvPOK(sv)) {
 426         *lp = SvCUR(sv);
 427         return SvPVX(sv);
 428     }
 429     return sv_2pv_flags(sv, lp, 0);
 430 }
 431
 432 /* sv_pv() is now a macro using SvPV_nolen();
 433  * this function provided for binary compatibility only
 434  */
 435
 436 char *
 437 Perl_sv_pv(pTHX_ SV *sv)
 438 {
 439     PERL_ARGS_ASSERT_SV_PV;
 440
 441     if (SvPOK(sv))
 442         return SvPVX(sv);
 443
 444     return sv_2pv(sv, NULL);
 445 }
 446
 447 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
 448  * this function provided for binary compatibility only
 449  */
 450
 451 char *
 452 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 453 {
 454     PERL_ARGS_ASSERT_SV_PVN_FORCE;
 455
 456     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
 457 }
 458
 459 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
 460  * this function provided for binary compatibility only
 461  */
 462
 463 char *
 464 Perl_sv_pvbyte(pTHX_ SV *sv)
 465 {
 466     PERL_ARGS_ASSERT_SV_PVBYTE;
 467
 468     sv_utf8_downgrade(sv, FALSE);
 469     return sv_pv(sv);
 470 }
 471
 472 /*
 473 =for apidoc sv_pvbyte
 474
 475 Use C<SvPVbyte_nolen> instead.
 476
 477 =for apidoc sv_pvbyten
 478
 479 A private implementation of the C<SvPVbyte> macro for compilers
 480 which can't cope with complex macro expressions.  Always use the macro
 481 instead.
 482
 483 =cut
 484 */
 485
 486 char *
 487 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
 488 {
 489     PERL_ARGS_ASSERT_SV_PVBYTEN;
 490
 491     sv_utf8_downgrade(sv, FALSE);
 492     return sv_pvn(sv,lp);
 493 }
 494
 495 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
 496  * this function provided for binary compatibility only
 497  */
 498
 499 char *
 500 Perl_sv_pvutf8(pTHX_ SV *sv)
 501 {
 502     PERL_ARGS_ASSERT_SV_PVUTF8;
 503
 504     sv_utf8_upgrade(sv);
 505     return sv_pv(sv);
 506 }
 507
 508 /*
 509 =for apidoc sv_pvutf8
 510
 511 Use the C<SvPVutf8_nolen> macro instead
 512
 513 =for apidoc sv_pvutf8n
 514
 515 A private implementation of the C<SvPVutf8> macro for compilers
 516 which can't cope with complex macro expressions.  Always use the macro
 517 instead.
 518
 519 =cut
 520 */
 521
 522 char *
 523 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
 524 {
 525     PERL_ARGS_ASSERT_SV_PVUTF8N;
 526
 527     sv_utf8_upgrade(sv);
 528     return sv_pvn(sv,lp);
 529 }
 530
 531 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
 532  * this function provided for binary compatibility only
 533  */
 534
 535 STRLEN
 536 Perl_sv_utf8_upgrade(pTHX_ SV *sv)
 537 {
 538     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE;
 539
 540     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
 541 }
 542
 543 int
 544 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
 545 {
 546     dTHXs;
 547     int ret = 0;
 548     va_list(arglist);
 549
 550     /* Easier to special case this here than in embed.pl. (Look at what it
 551        generates for proto.h) */
 552 #ifdef PERL_IMPLICIT_CONTEXT
 553     PERL_ARGS_ASSERT_FPRINTF_NOCONTEXT;
 554 #endif
 555
 556     va_start(arglist, format);
 557     ret = PerlIO_vprintf(stream, format, arglist);
 558     va_end(arglist);
 559     return ret;
 560 }
 561
 562 int
 563 Perl_printf_nocontext(const char *format, ...)
 564 {
 565     dTHX;
 566     va_list(arglist);
 567     int ret = 0;
 568
 569 #ifdef PERL_IMPLICIT_CONTEXT
 570     PERL_ARGS_ASSERT_PRINTF_NOCONTEXT;
 571 #endif
 572
 573     va_start(arglist, format);
 574     ret = PerlIO_vprintf(PerlIO_stdout(), format, arglist);
 575     va_end(arglist);
 576     return ret;
 577 }
 578
 579 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 580 /*
 581  * This hack is to force load of "huge" support from libm.a
 582  * So it is in perl for (say) POSIX to use.
 583  * Needed for SunOS with Sun's 'acc' for example.
 584  */
 585 NV
 586 Perl_huge(void)
 587 {
 588 #  if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
 589     return HUGE_VALL;
 590 #  else
 591     return HUGE_VAL;
 592 #  endif
 593 }
 594 #endif
 595
 596 /* compatibility with versions <= 5.003. */
 597 void
 598 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
 599 {
 600     PERL_ARGS_ASSERT_GV_FULLNAME;
 601
 602     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 603 }
 604
 605 /* compatibility with versions <= 5.003. */
 606 void
 607 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
 608 {
 609     PERL_ARGS_ASSERT_GV_EFULLNAME;
 610
 611     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 612 }
 613
 614 void
 615 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 616 {
 617     PERL_ARGS_ASSERT_GV_FULLNAME3;
 618
 619     gv_fullname4(sv, gv, prefix, TRUE);
 620 }
 621
 622 void
 623 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 624 {
 625     PERL_ARGS_ASSERT_GV_EFULLNAME3;
 626
 627     gv_efullname4(sv, gv, prefix, TRUE);
 628 }
 629
 630 /*
 631 =for apidoc gv_fetchmethod
 632
 633 See L</gv_fetchmethod_autoload>.
 634
 635 =cut
 636 */
 637
 638 GV *
 639 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 640 {
 641     PERL_ARGS_ASSERT_GV_FETCHMETHOD;
 642
 643     return gv_fetchmethod_autoload(stash, name, TRUE);
 644 }
 645
 646 HE *
 647 Perl_hv_iternext(pTHX_ HV *hv)
 648 {
 649     PERL_ARGS_ASSERT_HV_ITERNEXT;
 650
 651     return hv_iternext_flags(hv, 0);
 652 }
 653
 654 void
 655 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
 656 {
 657     PERL_ARGS_ASSERT_HV_MAGIC;
 658
 659     sv_magic(MUTABLE_SV(hv), MUTABLE_SV(gv), how, NULL, 0);
 660 }
 661
 662 bool
 663 Perl_do_open(pTHX_ GV *gv, const char *name, I32 len, int as_raw,
 664              int rawmode, int rawperm, PerlIO *supplied_fp)
 665 {
 666     PERL_ARGS_ASSERT_DO_OPEN;
 667
 668     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 669                     supplied_fp, (SV **) NULL, 0);
 670 }
 671
 672 bool
 673 Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len, int
 674 as_raw,
 675               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
 676               I32 num_svs)
 677 {
 678     PERL_ARGS_ASSERT_DO_OPEN9;
 679
 680     PERL_UNUSED_ARG(num_svs);
 681     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 682                     supplied_fp, &svs, 1);
 683 }
 684
 685 int
 686 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 687 {
 688  /* The old body of this is now in non-LAYER part of perlio.c
 689   * This is a stub for any XS code which might have been calling it.
 690   */
 691  const char *name = ":raw";
 692
 693  PERL_ARGS_ASSERT_DO_BINMODE;
 694
 695 #ifdef PERLIO_USING_CRLF
 696  if (!(mode & O_BINARY))
 697      name = ":crlf";
 698 #endif
 699  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 700 }
 701
 702 #ifndef OS2
 703 bool
 704 Perl_do_aexec(pTHX_ SV *really, SV **mark, SV **sp)
 705 {
 706     PERL_ARGS_ASSERT_DO_AEXEC;
 707
 708     return do_aexec5(really, mark, sp, 0, 0);
 709 }
 710 #endif
 711
 712 /* Backwards compatibility. */
 713 int
 714 Perl_init_i18nl14n(pTHX_ int printwarn)
 715 {
 716     return init_i18nl10n(printwarn);
 717 }
 718
 719 bool
 720 Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
 721 {
 722     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC;
 723
 724     return is_utf8_string_loclen(s, len, ep, 0);
 725 }
 726
 727 /*
 728 =for apidoc sv_nolocking
 729
 730 Dummy routine which "locks" an SV when there is no locking module present.
 731 Exists to avoid test for a NULL function pointer and because it could
 732 potentially warn under some level of strict-ness.
 733
 734 "Superseded" by sv_nosharing().
 735
 736 =cut
 737 */
 738
 739 void
 740 Perl_sv_nolocking(pTHX_ SV *sv)
 741 {
 742     PERL_UNUSED_CONTEXT;
 743     PERL_UNUSED_ARG(sv);
 744 }
 745
 746
 747 /*
 748 =for apidoc sv_nounlocking
 749
 750 Dummy routine which "unlocks" an SV when there is no locking module present.
 751 Exists to avoid test for a NULL function pointer and because it could
 752 potentially warn under some level of strict-ness.
 753
 754 "Superseded" by sv_nosharing().
 755
 756 =cut
 757 */
 758
 759 void
 760 Perl_sv_nounlocking(pTHX_ SV *sv)
 761 {
 762     PERL_UNUSED_CONTEXT;
 763     PERL_UNUSED_ARG(sv);
 764 }
 765
 766 void
 767 Perl_save_long(pTHX_ long int *longp)
 768 {
 769     dVAR;
 770
 771     PERL_ARGS_ASSERT_SAVE_LONG;
 772
 773     SSCHECK(3);
 774     SSPUSHLONG(*longp);
 775     SSPUSHPTR(longp);
 776     SSPUSHUV(SAVEt_LONG);
 777 }
 778
 779 void
 780 Perl_save_iv(pTHX_ IV *ivp)
 781 {
 782     dVAR;
 783
 784     PERL_ARGS_ASSERT_SAVE_IV;
 785
 786     SSCHECK(3);
 787     SSPUSHIV(*ivp);
 788     SSPUSHPTR(ivp);
 789     SSPUSHUV(SAVEt_IV);
 790 }
 791
 792 void
 793 Perl_save_nogv(pTHX_ GV *gv)
 794 {
 795     dVAR;
 796
 797     PERL_ARGS_ASSERT_SAVE_NOGV;
 798
 799     SSCHECK(2);
 800     SSPUSHPTR(gv);
 801     SSPUSHUV(SAVEt_NSTAB);
 802 }
 803
 804 void
 805 Perl_save_list(pTHX_ SV **sarg, I32 maxsarg)
 806 {
 807     dVAR;
 808     I32 i;
 809
 810     PERL_ARGS_ASSERT_SAVE_LIST;
 811
 812     for (i = 1; i <= maxsarg; i++) {
 813         SV *sv;
 814         SvGETMAGIC(sarg[i]);
 815         sv = newSV(0);
 816         sv_setsv_nomg(sv,sarg[i]);
 817         SSCHECK(3);
 818         SSPUSHPTR(sarg[i]);             /* remember the pointer */
 819         SSPUSHPTR(sv);                  /* remember the value */
 820         SSPUSHUV(SAVEt_ITEM);
 821     }
 822 }
 823
 824 /*
 825 =for apidoc sv_usepvn_mg
 826
 827 Like C<sv_usepvn>, but also handles 'set' magic.
 828
 829 =cut
 830 */
 831
 832 void
 833 Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len)
 834 {
 835     PERL_ARGS_ASSERT_SV_USEPVN_MG;
 836
 837     sv_usepvn_flags(sv,ptr,len, SV_SMAGIC);
 838 }
 839
 840 /*
 841 =for apidoc sv_usepvn
 842
 843 Tells an SV to use C<ptr> to find its string value.  Implemented by
 844 calling C<sv_usepvn_flags> with C<flags> of 0, hence does not handle 'set'
 845 magic.  See C<sv_usepvn_flags>.
 846
 847 =cut
 848 */
 849
 850 void
 851 Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
 852 {
 853     PERL_ARGS_ASSERT_SV_USEPVN;
 854
 855     sv_usepvn_flags(sv,ptr,len, 0);
 856 }
 857
 858 /*
 859 =for apidoc unpack_str
 860
 861 The engine implementing unpack() Perl function.  Note: parameters strbeg,
 862 new_s and ocnt are not used.  This call should not be used, use
 863 unpackstring instead.
 864
 865 =cut */
 866
 867 I32
 868 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s,
 869                 const char *strbeg, const char *strend, char **new_s, I32 ocnt,
 870                 U32 flags)
 871 {
 872     PERL_ARGS_ASSERT_UNPACK_STR;
 873
 874     PERL_UNUSED_ARG(strbeg);
 875     PERL_UNUSED_ARG(new_s);
 876     PERL_UNUSED_ARG(ocnt);
 877
 878     return unpackstring(pat, patend, s, strend, flags);
 879 }
 880
 881 /*
 882 =for apidoc pack_cat
 883
 884 The engine implementing pack() Perl function.  Note: parameters
 885 next_in_list and flags are not used.  This call should not be used; use
 886 packlist instead.
 887
 888 =cut
 889 */
 890
 891 void
 892 Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
 893 {
 894     PERL_ARGS_ASSERT_PACK_CAT;
 895
 896     PERL_UNUSED_ARG(next_in_list);
 897     PERL_UNUSED_ARG(flags);
 898
 899     packlist(cat, pat, patend, beglist, endlist);
 900 }
 901
 902 HE *
 903 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
 904 {
 905   return (HE *)hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
 906 }
 907
 908 bool
 909 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 910 {
 911     PERL_ARGS_ASSERT_HV_EXISTS_ENT;
 912
 913     return hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
 914         ? TRUE : FALSE;
 915 }
 916
 917 HE *
 918 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash)
 919 {
 920     PERL_ARGS_ASSERT_HV_FETCH_ENT;
 921
 922     return (HE *)hv_common(hv, keysv, NULL, 0, 0,
 923                      (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
 924 }
 925
 926 SV *
 927 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 928 {
 929     PERL_ARGS_ASSERT_HV_DELETE_ENT;
 930
 931     return MUTABLE_SV(hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL,
 932                                 hash));
 933 }
 934
 935 SV**
 936 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash,
 937                     int flags)
 938 {
 939     return (SV**) hv_common(hv, NULL, key, klen, flags,
 940                             (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
 941 }
 942
 943 SV**
 944 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
 945 {
 946     STRLEN klen;
 947     int flags;
 948
 949     if (klen_i32 < 0) {
 950         klen = -klen_i32;
 951         flags = HVhek_UTF8;
 952     } else {
 953         klen = klen_i32;
 954         flags = 0;
 955     }
 956     return (SV **) hv_common(hv, NULL, key, klen, flags,
 957                              (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
 958 }
 959
 960 bool
 961 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
 962 {
 963     STRLEN klen;
 964     int flags;
 965
 966     PERL_ARGS_ASSERT_HV_EXISTS;
 967
 968     if (klen_i32 < 0) {
 969         klen = -klen_i32;
 970         flags = HVhek_UTF8;
 971     } else {
 972         klen = klen_i32;
 973         flags = 0;
 974     }
 975     return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
 976         ? TRUE : FALSE;
 977 }
 978
 979 SV**
 980 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
 981 {
 982     STRLEN klen;
 983     int flags;
 984
 985     PERL_ARGS_ASSERT_HV_FETCH;
 986
 987     if (klen_i32 < 0) {
 988         klen = -klen_i32;
 989         flags = HVhek_UTF8;
 990     } else {
 991         klen = klen_i32;
 992         flags = 0;
 993     }
 994     return (SV **) hv_common(hv, NULL, key, klen, flags,
 995                              lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE)
 996                              : HV_FETCH_JUST_SV, NULL, 0);
 997 }
 998
 999 SV *
1000 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
1001 {
1002     STRLEN klen;
1003     int k_flags;
1004
1005     PERL_ARGS_ASSERT_HV_DELETE;
1006
1007     if (klen_i32 < 0) {
1008         klen = -klen_i32;
1009         k_flags = HVhek_UTF8;
1010     } else {
1011         klen = klen_i32;
1012         k_flags = 0;
1013     }
1014     return MUTABLE_SV(hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE,
1015                                 NULL, 0));
1016 }
1017
1018 /* Functions after here were made mathoms post 5.10.0 but pre 5.8.9 */
1019
1020 AV *
1021 Perl_newAV(pTHX)
1022 {
1023     return MUTABLE_AV(newSV_type(SVt_PVAV));
1024     /* sv_upgrade does AvREAL_only():
1025     AvALLOC(av) = 0;
1026     AvARRAY(av) = NULL;
1027     AvMAX(av) = AvFILLp(av) = -1; */
1028 }
1029
1030 HV *
1031 Perl_newHV(pTHX)
1032 {
1033     HV * const hv = MUTABLE_HV(newSV_type(SVt_PVHV));
1034     assert(!SvOK(hv));
1035
1036     return hv;
1037 }
1038
1039 void
1040 Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len,
1041               const char *const little, const STRLEN littlelen)
1042 {
1043     PERL_ARGS_ASSERT_SV_INSERT;
1044     sv_insert_flags(bigstr, offset, len, little, littlelen, SV_GMAGIC);
1045 }
1046
1047 void
1048 Perl_save_freesv(pTHX_ SV *sv)
1049 {
1050     dVAR;
1051     save_freesv(sv);
1052 }
1053
1054 void
1055 Perl_save_mortalizesv(pTHX_ SV *sv)
1056 {
1057     dVAR;
1058
1059     PERL_ARGS_ASSERT_SAVE_MORTALIZESV;
1060
1061     save_mortalizesv(sv);
1062 }
1063
1064 void
1065 Perl_save_freeop(pTHX_ OP *o)
1066 {
1067     dVAR;
1068     save_freeop(o);
1069 }
1070
1071 void
1072 Perl_save_freepv(pTHX_ char *pv)
1073 {
1074     dVAR;
1075     save_freepv(pv);
1076 }
1077
1078 void
1079 Perl_save_op(pTHX)
1080 {
1081     dVAR;
1082     save_op();
1083 }
1084
1085 #ifdef PERL_DONT_CREATE_GVSV
1086 GV *
1087 Perl_gv_SVadd(pTHX_ GV *gv)
1088 {
1089     return gv_SVadd(gv);
1090 }
1091 #endif
1092
1093 GV *
1094 Perl_gv_AVadd(pTHX_ GV *gv)
1095 {
1096     return gv_AVadd(gv);
1097 }
1098
1099 GV *
1100 Perl_gv_HVadd(pTHX_ GV *gv)
1101 {
1102     return gv_HVadd(gv);
1103 }
1104
1105 GV *
1106 Perl_gv_IOadd(pTHX_ GV *gv)
1107 {
1108     return gv_IOadd(gv);
1109 }
1110
1111 IO *
1112 Perl_newIO(pTHX)
1113 {
1114     return MUTABLE_IO(newSV_type(SVt_PVIO));
1115 }
1116
1117 I32
1118 Perl_my_stat(pTHX)
1119 {
1120     return my_stat_flags(SV_GMAGIC);
1121 }
1122
1123 I32
1124 Perl_my_lstat(pTHX)
1125 {
1126     return my_lstat_flags(SV_GMAGIC);
1127 }
1128
1129 I32
1130 Perl_sv_eq(pTHX_ SV *sv1, SV *sv2)
1131 {
1132     return sv_eq_flags(sv1, sv2, SV_GMAGIC);
1133 }
1134
1135 #ifdef USE_LOCALE_COLLATE
1136 char *
1137 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
1138 {
1139     return sv_collxfrm_flags(sv, nxp, SV_GMAGIC);
1140 }
1141 #endif
1142
1143 bool
1144 Perl_sv_2bool(pTHX_ SV *const sv)
1145 {
1146     return sv_2bool_flags(sv, SV_GMAGIC);
1147 }
1148
1149
1150 /*
1151 =for apidoc custom_op_name
1152 Return the name for a given custom op.  This was once used by the OP_NAME
1153 macro, but is no longer: it has only been kept for compatibility, and
1154 should not be used.
1155
1156 =for apidoc custom_op_desc
1157 Return the description of a given custom op.  This was once used by the
1158 OP_DESC macro, but is no longer: it has only been kept for
1159 compatibility, and should not be used.
1160
1161 =cut
1162 */
1163
1164 const char*
1165 Perl_custom_op_name(pTHX_ const OP* o)
1166 {
1167     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
1168     return XopENTRYCUSTOM(o, xop_name);
1169 }
1170
1171 const char*
1172 Perl_custom_op_desc(pTHX_ const OP* o)
1173 {
1174     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
1175     return XopENTRYCUSTOM(o, xop_desc);
1176 }
1177
1178 CV *
1179 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
1180 {
1181     return newATTRSUB(floor, o, proto, NULL, block);
1182 }
1183
1184 UV
1185 Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1186 {
1187     PERL_ARGS_ASSERT_TO_UTF8_FOLD;
1188
1189     return _to_utf8_fold_flags(p, ustrp, lenp, FOLD_FLAGS_FULL);
1190 }
1191
1192 UV
1193 Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1194 {
1195     PERL_ARGS_ASSERT_TO_UTF8_LOWER;
1196
1197     return _to_utf8_lower_flags(p, ustrp, lenp, FALSE);
1198 }
1199
1200 UV
1201 Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1202 {
1203     PERL_ARGS_ASSERT_TO_UTF8_TITLE;
1204
1205     return _to_utf8_title_flags(p, ustrp, lenp, FALSE);
1206 }
1207
1208 UV
1209 Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1210 {
1211     PERL_ARGS_ASSERT_TO_UTF8_UPPER;
1212
1213     return _to_utf8_upper_flags(p, ustrp, lenp, FALSE);
1214 }
1215
1216 SV *
1217 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
1218 {
1219     return Perl_sv_mortalcopy_flags(aTHX_ oldstr, SV_GMAGIC);
1220 }
1221
1222 UV      /* Made into a function, so can be deprecated */
1223 NATIVE_TO_NEED(const UV enc, const UV ch)
1224 {
1225     PERL_UNUSED_ARG(enc);
1226     return ch;
1227 }
1228
1229 UV      /* Made into a function, so can be deprecated */
1230 ASCII_TO_NEED(const UV enc, const UV ch)
1231 {
1232     PERL_UNUSED_ARG(enc);
1233     return ch;
1234 }
1235
1236 bool      /* Made into a function, so can be deprecated */
1237 Perl_isIDFIRST_lazy(pTHX_ const char* p)
1238 {
1239     PERL_ARGS_ASSERT_ISIDFIRST_LAZY;
1240
1241     return isIDFIRST_lazy_if(p,1);
1242 }
1243
1244 bool      /* Made into a function, so can be deprecated */
1245 Perl_isALNUM_lazy(pTHX_ const char* p)
1246 {
1247     PERL_ARGS_ASSERT_ISALNUM_LAZY;
1248
1249     return isALNUM_lazy_if(p,1);
1250 }
1251
1252 bool
1253 Perl_is_uni_alnum(pTHX_ UV c)
1254 {
1255     return isWORDCHAR_uni(c);
1256 }
1257
1258 bool
1259 Perl_is_uni_alnumc(pTHX_ UV c)
1260 {
1261     return isALNUM_uni(c);
1262 }
1263
1264 bool
1265 Perl_is_uni_alpha(pTHX_ UV c)
1266 {
1267     return isALPHA_uni(c);
1268 }
1269
1270 bool
1271 Perl_is_uni_ascii(pTHX_ UV c)
1272 {
1273     return isASCII_uni(c);
1274 }
1275
1276 bool
1277 Perl_is_uni_blank(pTHX_ UV c)
1278 {
1279     return isBLANK_uni(c);
1280 }
1281
1282 bool
1283 Perl_is_uni_space(pTHX_ UV c)
1284 {
1285     return isSPACE_uni(c);
1286 }
1287
1288 bool
1289 Perl_is_uni_digit(pTHX_ UV c)
1290 {
1291     return isDIGIT_uni(c);
1292 }
1293
1294 bool
1295 Perl_is_uni_upper(pTHX_ UV c)
1296 {
1297     return isUPPER_uni(c);
1298 }
1299
1300 bool
1301 Perl_is_uni_lower(pTHX_ UV c)
1302 {
1303     return isLOWER_uni(c);
1304 }
1305
1306 bool
1307 Perl_is_uni_cntrl(pTHX_ UV c)
1308 {
1309     return isCNTRL_L1(c);
1310 }
1311
1312 bool
1313 Perl_is_uni_graph(pTHX_ UV c)
1314 {
1315     return isGRAPH_uni(c);
1316 }
1317
1318 bool
1319 Perl_is_uni_print(pTHX_ UV c)
1320 {
1321     return isPRINT_uni(c);
1322 }
1323
1324 bool
1325 Perl_is_uni_punct(pTHX_ UV c)
1326 {
1327     return isPUNCT_uni(c);
1328 }
1329
1330 bool
1331 Perl_is_uni_xdigit(pTHX_ UV c)
1332 {
1333     return isXDIGIT_uni(c);
1334 }
1335
1336 bool
1337 Perl_is_uni_alnum_lc(pTHX_ UV c)
1338 {
1339     return isWORDCHAR_LC_uvchr(c);
1340 }
1341
1342 bool
1343 Perl_is_uni_alnumc_lc(pTHX_ UV c)
1344 {
1345     return isALPHANUMERIC_LC_uvchr(c);
1346 }
1347
1348 bool
1349 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1350 {
1351     /* XXX Should probably be something that resolves to the old IDFIRST, but
1352      * this function is deprecated, so not bothering */
1353     return isIDFIRST_LC_uvchr(c);
1354 }
1355
1356 bool
1357 Perl_is_uni_alpha_lc(pTHX_ UV c)
1358 {
1359     return isALPHA_LC_uvchr(c);
1360 }
1361
1362 bool
1363 Perl_is_uni_ascii_lc(pTHX_ UV c)
1364 {
1365     return isASCII_LC_uvchr(c);
1366 }
1367
1368 bool
1369 Perl_is_uni_blank_lc(pTHX_ UV c)
1370 {
1371     return isBLANK_LC_uvchr(c);
1372 }
1373
1374 bool
1375 Perl_is_uni_space_lc(pTHX_ UV c)
1376 {
1377     return isSPACE_LC_uvchr(c);
1378 }
1379
1380 bool
1381 Perl_is_uni_digit_lc(pTHX_ UV c)
1382 {
1383     return isDIGIT_LC_uvchr(c);
1384 }
1385
1386 bool
1387 Perl_is_uni_idfirst(pTHX_ UV c)
1388 {
1389     U8 tmpbuf[UTF8_MAXBYTES+1];
1390     uvchr_to_utf8(tmpbuf, c);
1391     return _is_utf8_idstart(tmpbuf);
1392 }
1393
1394 bool
1395 Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
1396 {
1397     dVAR;
1398
1399     PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1400
1401     return _is_utf8_idstart(p);
1402 }
1403
1404 bool
1405 Perl_is_utf8_xidfirst(pTHX_ const U8 *p) /* The naming is historical. */
1406 {
1407     dVAR;
1408
1409     PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST;
1410
1411     return _is_utf8_xidstart(p);
1412 }
1413
1414 bool
1415 Perl_is_utf8_idcont(pTHX_ const U8 *p)
1416 {
1417     dVAR;
1418
1419     PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1420
1421     return _is_utf8_idcont(p);
1422 }
1423
1424 bool
1425 Perl_is_utf8_xidcont(pTHX_ const U8 *p)
1426 {
1427     dVAR;
1428
1429     PERL_ARGS_ASSERT_IS_UTF8_XIDCONT;
1430
1431     return _is_utf8_xidcont(p);
1432 }
1433
1434 bool
1435 Perl_is_uni_upper_lc(pTHX_ UV c)
1436 {
1437     return isUPPER_LC_uvchr(c);
1438 }
1439
1440 bool
1441 Perl_is_uni_lower_lc(pTHX_ UV c)
1442 {
1443     return isLOWER_LC_uvchr(c);
1444 }
1445
1446 bool
1447 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1448 {
1449     return isCNTRL_LC_uvchr(c);
1450 }
1451
1452 bool
1453 Perl_is_uni_graph_lc(pTHX_ UV c)
1454 {
1455     return isGRAPH_LC_uvchr(c);
1456 }
1457
1458 bool
1459 Perl_is_uni_print_lc(pTHX_ UV c)
1460 {
1461     return isPRINT_LC_uvchr(c);
1462 }
1463
1464 bool
1465 Perl_is_uni_punct_lc(pTHX_ UV c)
1466 {
1467     return isPUNCT_LC_uvchr(c);
1468 }
1469
1470 bool
1471 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1472 {
1473     return isXDIGIT_LC_uvchr(c);
1474 }
1475
1476 U32
1477 Perl_to_uni_upper_lc(pTHX_ U32 c)
1478 {
1479     /* XXX returns only the first character -- do not use XXX */
1480     /* XXX no locale support yet */
1481     STRLEN len;
1482     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1483     return (U32)to_uni_upper(c, tmpbuf, &len);
1484 }
1485
1486 U32
1487 Perl_to_uni_title_lc(pTHX_ U32 c)
1488 {
1489     /* XXX returns only the first character XXX -- do not use XXX */
1490     /* XXX no locale support yet */
1491     STRLEN len;
1492     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1493     return (U32)to_uni_title(c, tmpbuf, &len);
1494 }
1495
1496 U32
1497 Perl_to_uni_lower_lc(pTHX_ U32 c)
1498 {
1499     /* XXX returns only the first character -- do not use XXX */
1500     /* XXX no locale support yet */
1501     STRLEN len;
1502     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1503     return (U32)to_uni_lower(c, tmpbuf, &len);
1504 }
1505
1506 bool
1507 Perl_is_utf8_alnum(pTHX_ const U8 *p)
1508 {
1509     dVAR;
1510
1511     PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1512
1513     /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1514      * descendant of isalnum(3), in other words, it doesn't
1515      * contain the '_'. --jhi */
1516     return isWORDCHAR_utf8(p);
1517 }
1518
1519 bool
1520 Perl_is_utf8_alnumc(pTHX_ const U8 *p)
1521 {
1522     dVAR;
1523
1524     PERL_ARGS_ASSERT_IS_UTF8_ALNUMC;
1525
1526     return isALPHANUMERIC_utf8(p);
1527 }
1528
1529 bool
1530 Perl_is_utf8_alpha(pTHX_ const U8 *p)
1531 {
1532     dVAR;
1533
1534     PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1535
1536     return isALPHA_utf8(p);
1537 }
1538
1539 bool
1540 Perl_is_utf8_ascii(pTHX_ const U8 *p)
1541 {
1542     dVAR;
1543
1544     PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1545
1546     return isASCII_utf8(p);
1547 }
1548
1549 bool
1550 Perl_is_utf8_blank(pTHX_ const U8 *p)
1551 {
1552     dVAR;
1553
1554     PERL_ARGS_ASSERT_IS_UTF8_BLANK;
1555
1556     return isBLANK_utf8(p);
1557 }
1558
1559 bool
1560 Perl_is_utf8_space(pTHX_ const U8 *p)
1561 {
1562     dVAR;
1563
1564     PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1565
1566     return isSPACE_utf8(p);
1567 }
1568
1569 bool
1570 Perl_is_utf8_perl_space(pTHX_ const U8 *p)
1571 {
1572     dVAR;
1573
1574     PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
1575
1576     /* Only true if is an ASCII space-like character, and ASCII is invariant
1577      * under utf8, so can just use the macro */
1578     return isSPACE_A(*p);
1579 }
1580
1581 bool
1582 Perl_is_utf8_perl_word(pTHX_ const U8 *p)
1583 {
1584     dVAR;
1585
1586     PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
1587
1588     /* Only true if is an ASCII word character, and ASCII is invariant
1589      * under utf8, so can just use the macro */
1590     return isWORDCHAR_A(*p);
1591 }
1592
1593 bool
1594 Perl_is_utf8_digit(pTHX_ const U8 *p)
1595 {
1596     dVAR;
1597
1598     PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1599
1600     return isDIGIT_utf8(p);
1601 }
1602
1603 bool
1604 Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
1605 {
1606     dVAR;
1607
1608     PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
1609
1610     /* Only true if is an ASCII digit character, and ASCII is invariant
1611      * under utf8, so can just use the macro */
1612     return isDIGIT_A(*p);
1613 }
1614
1615 bool
1616 Perl_is_utf8_upper(pTHX_ const U8 *p)
1617 {
1618     dVAR;
1619
1620     PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1621
1622     return isUPPER_utf8(p);
1623 }
1624
1625 bool
1626 Perl_is_utf8_lower(pTHX_ const U8 *p)
1627 {
1628     dVAR;
1629
1630     PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1631
1632     return isLOWER_utf8(p);
1633 }
1634
1635 bool
1636 Perl_is_utf8_cntrl(pTHX_ const U8 *p)
1637 {
1638     dVAR;
1639
1640     PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1641
1642     return isCNTRL_utf8(p);
1643 }
1644
1645 bool
1646 Perl_is_utf8_graph(pTHX_ const U8 *p)
1647 {
1648     dVAR;
1649
1650     PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1651
1652     return isGRAPH_utf8(p);
1653 }
1654
1655 bool
1656 Perl_is_utf8_print(pTHX_ const U8 *p)
1657 {
1658     dVAR;
1659
1660     PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1661
1662     return isPRINT_utf8(p);
1663 }
1664
1665 bool
1666 Perl_is_utf8_punct(pTHX_ const U8 *p)
1667 {
1668     dVAR;
1669
1670     PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1671
1672     return isPUNCT_utf8(p);
1673 }
1674
1675 bool
1676 Perl_is_utf8_xdigit(pTHX_ const U8 *p)
1677 {
1678     dVAR;
1679
1680     PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1681
1682     return isXDIGIT_utf8(p);
1683 }
1684
1685 bool
1686 Perl_is_utf8_mark(pTHX_ const U8 *p)
1687 {
1688     dVAR;
1689
1690     PERL_ARGS_ASSERT_IS_UTF8_MARK;
1691
1692     return _is_utf8_mark(p);
1693 }
1694
1695 /*
1696 =for apidoc is_utf8_char
1697
1698 Tests if some arbitrary number of bytes begins in a valid UTF-8
1699 character.  Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
1700 character is a valid UTF-8 character.  The actual number of bytes in the UTF-8
1701 character will be returned if it is valid, otherwise 0.
1702
1703 This function is deprecated due to the possibility that malformed input could
1704 cause reading beyond the end of the input buffer.  Use L</isUTF8_CHAR>
1705 instead.
1706
1707 =cut */
1708
1709 STRLEN
1710 Perl_is_utf8_char(const U8 *s)
1711 {
1712     PERL_ARGS_ASSERT_IS_UTF8_CHAR;
1713
1714     /* Assumes we have enough space, which is why this is deprecated */
1715     return isUTF8_CHAR(s, s + UTF8SKIP(s));
1716 }
1717
1718 /* DEPRECATED!
1719  * Like L</utf8_to_uvuni_buf>(), but should only be called when it is known that
1720  * there are no malformations in the input UTF-8 string C<s>.  Surrogates,
1721  * non-character code points, and non-Unicode code points are allowed */
1722
1723 UV
1724 Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
1725 {
1726     PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI;
1727
1728     return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen));
1729 }
1730
1731 /*
1732 =for apidoc utf8_to_uvchr
1733
1734 Returns the native code point of the first character in the string C<s>
1735 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
1736 length, in bytes, of that character.
1737
1738 Some, but not all, UTF-8 malformations are detected, and in fact, some
1739 malformed input could cause reading beyond the end of the input buffer, which
1740 is why this function is deprecated.  Use L</utf8_to_uvchr_buf> instead.
1741
1742 If C<s> points to one of the detected malformations, and UTF8 warnings are
1743 enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
1744 NULL) to -1.  If those warnings are off, the computed value if well-defined (or
1745 the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
1746 is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
1747 next possible position in C<s> that could begin a non-malformed character.
1748 See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
1749
1750 =cut
1751 */
1752
1753 UV
1754 Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
1755 {
1756     PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
1757
1758     return utf8_to_uvchr_buf(s, s + UTF8_MAXBYTES, retlen);
1759 }
1760
1761 /*
1762 =for apidoc utf8_to_uvuni
1763
1764 Returns the Unicode code point of the first character in the string C<s>
1765 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
1766 length, in bytes, of that character.
1767
1768 Some, but not all, UTF-8 malformations are detected, and in fact, some
1769 malformed input could cause reading beyond the end of the input buffer, which
1770 is one reason why this function is deprecated.  The other is that only in
1771 extremely limited circumstances should the Unicode versus native code point be
1772 of any interest to you.  See L</utf8_to_uvuni_buf> for alternatives.
1773
1774 If C<s> points to one of the detected malformations, and UTF8 warnings are
1775 enabled, zero is returned and C<*retlen> is set (if C<retlen> doesn't point to
1776 NULL) to -1.  If those warnings are off, the computed value if well-defined (or
1777 the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
1778 is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
1779 next possible position in C<s> that could begin a non-malformed character.
1780 See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
1781
1782 =cut
1783 */
1784
1785 UV
1786 Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
1787 {
1788     PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
1789
1790     return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen));
1791 }
1792
1793 END_EXTERN_C
1794
1795 #endif /* NO_MATHOMS */
1796
1797 /*
1798  * Local variables:
1799  * c-indentation-style: bsd
1800  * c-basic-offset: 4
1801  * indent-tabs-mode: nil
1802  * End:
1803  *
1804  * ex: set ts=8 sts=4 sw=4 et:
1805  */