3 * Copyright (C) 2005, 2006, by Larry Wall and others
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.
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."
20 * This file contains mathoms, various binary artifacts from previous
21 * versions of Perl. For binary or source compatibility reasons, though,
22 * we cannot completely remove them from the core code.
29 #define PERL_IN_MATHOMS_C
32 OP * Perl_ref(pTHX_ OP *o, I32 type);
33 void Perl_sv_unref(pTHX_ SV *sv);
34 void Perl_sv_taint(pTHX_ SV *sv);
35 IV Perl_sv_2iv(pTHX_ register SV *sv);
36 UV Perl_sv_2uv(pTHX_ register SV *sv);
37 char * Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp);
38 char * Perl_sv_2pv_nolen(pTHX_ register SV *sv);
39 char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv);
40 char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv);
41 void Perl_sv_force_normal(pTHX_ register SV *sv);
42 void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr);
43 void Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen);
44 void Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len);
45 void Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr);
46 void Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv);
47 char * Perl_sv_pv(pTHX_ SV *sv);
48 char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp);
49 char * Perl_sv_pvbyte(pTHX_ SV *sv);
50 char * Perl_sv_pvutf8(pTHX_ SV *sv);
51 STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv);
53 void Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
54 void Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
55 GV * Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name);
56 HE * Perl_hv_iternext(pTHX_ HV *hv);
57 void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how);
58 bool Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
59 int rawmode, int rawperm, PerlIO *supplied_fp);
60 bool Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp);
61 bool Perl_do_exec(pTHX_ const char *cmd);
62 U8 * Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv);
63 bool Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep);
64 void Perl_sv_nolocking(pTHX_ SV *sv);
65 void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len);
66 void Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len);
69 /* ref() is now a macro using Perl_doref;
70 * this version provided for binary compatibility only.
73 Perl_ref(pTHX_ OP *o, I32 type)
75 return doref(o, type, TRUE);
81 Unsets the RV status of the SV, and decrements the reference count of
82 whatever was being referenced by the RV. This can almost be thought of
83 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
84 being zero. See C<SvROK_off>.
90 Perl_sv_unref(pTHX_ SV *sv)
92 sv_unref_flags(sv, 0);
98 Taint an SV. Use C<SvTAINTED_on> instead.
103 Perl_sv_taint(pTHX_ SV *sv)
105 sv_magic((sv), NULL, PERL_MAGIC_taint, NULL, 0);
108 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
109 * this function provided for binary compatibility only
113 Perl_sv_2iv(pTHX_ register SV *sv)
115 return sv_2iv_flags(sv, SV_GMAGIC);
118 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
119 * this function provided for binary compatibility only
123 Perl_sv_2uv(pTHX_ register SV *sv)
125 return sv_2uv_flags(sv, SV_GMAGIC);
128 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
129 * this function provided for binary compatibility only
133 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
135 return sv_2pv_flags(sv, lp, SV_GMAGIC);
139 =for apidoc sv_2pv_nolen
141 Like C<sv_2pv()>, but doesn't return the length too. You should usually
142 use the macro wrapper C<SvPV_nolen(sv)> instead.
147 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
149 return sv_2pv(sv, NULL);
153 =for apidoc sv_2pvbyte_nolen
155 Return a pointer to the byte-encoded representation of the SV.
156 May cause the SV to be downgraded from UTF-8 as a side-effect.
158 Usually accessed via the C<SvPVbyte_nolen> macro.
164 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
166 return sv_2pvbyte(sv, NULL);
170 =for apidoc sv_2pvutf8_nolen
172 Return a pointer to the UTF-8-encoded representation of the SV.
173 May cause the SV to be upgraded to UTF-8 as a side-effect.
175 Usually accessed via the C<SvPVutf8_nolen> macro.
181 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
183 return sv_2pvutf8(sv, NULL);
187 =for apidoc sv_force_normal
189 Undo various types of fakery on an SV: if the PV is a shared string, make
190 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
191 an xpvmg. See also C<sv_force_normal_flags>.
197 Perl_sv_force_normal(pTHX_ register SV *sv)
199 sv_force_normal_flags(sv, 0);
202 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
203 * this function provided for binary compatibility only
207 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
209 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
212 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
213 * this function provided for binary compatibility only
217 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
219 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
223 =for apidoc sv_catpvn_mg
225 Like C<sv_catpvn>, but also handles 'set' magic.
231 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
233 sv_catpvn_flags(sv,ptr,len,SV_GMAGIC|SV_SMAGIC);
236 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
237 * this function provided for binary compatibility only
241 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
243 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
247 =for apidoc sv_catsv_mg
249 Like C<sv_catsv>, but also handles 'set' magic.
255 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
257 sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC);
263 A private implementation of the C<SvIVx> macro for compilers which can't
264 cope with complex macro expressions. Always use the macro instead.
270 Perl_sv_iv(pTHX_ register SV *sv)
274 return (IV)SvUVX(sv);
283 A private implementation of the C<SvUVx> macro for compilers which can't
284 cope with complex macro expressions. Always use the macro instead.
290 Perl_sv_uv(pTHX_ register SV *sv)
295 return (UV)SvIVX(sv);
303 A private implementation of the C<SvNVx> macro for compilers which can't
304 cope with complex macro expressions. Always use the macro instead.
310 Perl_sv_nv(pTHX_ register SV *sv)
320 Use the C<SvPV_nolen> macro instead
324 A private implementation of the C<SvPV> macro for compilers which can't
325 cope with complex macro expressions. Always use the macro instead.
331 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
337 return sv_2pv(sv, lp);
342 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
348 return sv_2pv_flags(sv, lp, 0);
351 /* sv_pv() is now a macro using SvPV_nolen();
352 * this function provided for binary compatibility only
356 Perl_sv_pv(pTHX_ SV *sv)
361 return sv_2pv(sv, NULL);
364 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
365 * this function provided for binary compatibility only
369 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
371 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
374 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
375 * this function provided for binary compatibility only
379 Perl_sv_pvbyte(pTHX_ SV *sv)
381 sv_utf8_downgrade(sv, FALSE);
386 =for apidoc sv_pvbyte
388 Use C<SvPVbyte_nolen> instead.
390 =for apidoc sv_pvbyten
392 A private implementation of the C<SvPVbyte> macro for compilers
393 which can't cope with complex macro expressions. Always use the macro
400 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
402 sv_utf8_downgrade(sv, FALSE);
403 return sv_pvn(sv,lp);
406 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
407 * this function provided for binary compatibility only
411 Perl_sv_pvutf8(pTHX_ SV *sv)
418 =for apidoc sv_pvutf8
420 Use the C<SvPVutf8_nolen> macro instead
422 =for apidoc sv_pvutf8n
424 A private implementation of the C<SvPVutf8> macro for compilers
425 which can't cope with complex macro expressions. Always use the macro
432 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
435 return sv_pvn(sv,lp);
438 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
439 * this function provided for binary compatibility only
443 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
445 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
449 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
453 va_start(arglist, format);
454 return PerlIO_vprintf(stream, format, arglist);
458 Perl_printf_nocontext(const char *format, ...)
462 va_start(arglist, format);
463 return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
466 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
468 * This hack is to force load of "huge" support from libm.a
469 * So it is in perl for (say) POSIX to use.
470 * Needed for SunOS with Sun's 'acc' for example.
475 # if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
483 /* compatibility with versions <= 5.003. */
485 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
487 gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
490 /* compatibility with versions <= 5.003. */
492 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
494 gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
498 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
500 gv_fullname4(sv, gv, prefix, TRUE);
504 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
506 gv_efullname4(sv, gv, prefix, TRUE);
510 =for apidoc gv_fetchmethod
512 See L<gv_fetchmethod_autoload>.
518 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
520 return gv_fetchmethod_autoload(stash, name, TRUE);
524 Perl_hv_iternext(pTHX_ HV *hv)
526 return hv_iternext_flags(hv, 0);
530 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
532 sv_magic((SV*)hv, (SV*)gv, how, NULL, 0);
535 #if 0 /* use the macro from hv.h instead */
538 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
540 return HEK_KEY(share_hek(sv, len, hash));
546 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
549 register AV * const av = (AV*)newSV(0);
551 sv_upgrade((SV *)av, SVt_PVAV);
552 Newx(ary,size+1,SV*);
554 Copy(strp,ary,size,SV*);
556 SvPV_set(av, (char*)ary);
557 AvFILLp(av) = size - 1;
558 AvMAX(av) = size - 1;
568 Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
569 int rawmode, int rawperm, PerlIO *supplied_fp)
571 return do_openn(gv, name, len, as_raw, rawmode, rawperm,
572 supplied_fp, (SV **) NULL, 0);
576 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
578 int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
581 PERL_UNUSED_ARG(num_svs);
582 return do_openn(gv, name, len, as_raw, rawmode, rawperm,
583 supplied_fp, &svs, 1);
587 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
589 /* The old body of this is now in non-LAYER part of perlio.c
590 * This is a stub for any XS code which might have been calling it.
592 const char *name = ":raw";
593 #ifdef PERLIO_USING_CRLF
594 if (!(mode & O_BINARY))
597 return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
602 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
604 return do_aexec5(really, mark, sp, 0, 0);
608 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
610 Perl_do_exec(pTHX_ const char *cmd)
612 return do_exec3(cmd,0,0);
618 Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
638 if (PerlProc_pipe(fd) < 0)
640 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
641 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
642 IoOFP(rstio) = IoIFP(rstio);
643 IoIFP(wstio) = IoOFP(wstio);
644 IoTYPE(rstio) = IoTYPE_RDONLY;
645 IoTYPE(wstio) = IoTYPE_WRONLY;
646 if (!IoIFP(rstio) || !IoOFP(wstio)) {
647 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
648 else PerlLIO_close(fd[0]);
649 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
650 else PerlLIO_close(fd[1]);
654 sv_setsv(sv,&PL_sv_yes);
658 sv_setsv(sv,&PL_sv_undef);
663 /* Backwards compatibility. */
665 Perl_init_i18nl14n(pTHX_ int printwarn)
667 return init_i18nl10n(printwarn);
670 /* XXX kept for BINCOMPAT only */
672 Perl_save_hints(pTHX)
674 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
679 Perl_ck_retarget(pTHX_ OP *o)
681 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
688 Perl_oopsCV(pTHX_ OP *o)
690 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
693 NORETURN_FUNCTION_END;
698 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
703 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
708 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
711 /* These ops all have the same body as pp_null. */
736 /* Ops that are calls to do_kv. */
747 /* Ops that are simply calls to other ops. */
786 return pp_ssockopt();
791 return pp_getpeername();
801 return pp_ftrowned();
826 return pp_shmwrite();
841 return pp_ghostent();
846 return pp_ghostent();
861 return pp_gprotoent();
866 return pp_gprotoent();
871 return pp_gservent();
876 return pp_gservent();
921 return pp_ftrowned();
926 return pp_ftrowned();
931 return pp_ftrowned();
936 return pp_ftrowned();
941 return pp_ftrowned();
946 return pp_ftrowned();
951 return pp_ftrowned();
956 return pp_ftrowned();
961 return pp_ftrowned();
966 return pp_ftrowned();
1001 return pp_ftrread();
1006 return pp_ftrread();
1011 return pp_ftrread();
1016 return pp_ftrread();
1021 return pp_shmwrite();
1026 return pp_shmwrite();
1036 return pp_shmwrite();
1041 return pp_defined();
1056 return pp_defined();
1061 return pp_ucfirst();
1120 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
1122 return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
1126 Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
1128 return is_utf8_string_loclen(s, len, ep, 0);
1132 =for apidoc sv_nolocking
1134 Dummy routine which "locks" an SV when there is no locking module present.
1135 Exists to avoid test for a NULL function pointer and because it could
1136 potentially warn under some level of strict-ness.
1138 "Superseded" by sv_nosharing().
1144 Perl_sv_nolocking(pTHX_ SV *sv)
1146 PERL_UNUSED_CONTEXT;
1147 PERL_UNUSED_ARG(sv);
1152 =for apidoc sv_nounlocking
1154 Dummy routine which "unlocks" an SV when there is no locking module present.
1155 Exists to avoid test for a NULL function pointer and because it could
1156 potentially warn under some level of strict-ness.
1158 "Superseded" by sv_nosharing().
1164 Perl_sv_nounlocking(pTHX_ SV *sv)
1166 PERL_UNUSED_CONTEXT;
1167 PERL_UNUSED_ARG(sv);
1171 Perl_save_long(pTHX_ long int *longp)
1177 SSPUSHINT(SAVEt_LONG);
1181 Perl_save_I16(pTHX_ I16 *intp)
1187 SSPUSHINT(SAVEt_I16);
1191 Perl_save_I8(pTHX_ I8 *bytep)
1197 SSPUSHINT(SAVEt_I8);
1201 Perl_save_iv(pTHX_ IV *ivp)
1207 SSPUSHINT(SAVEt_IV);
1211 Perl_save_nogv(pTHX_ GV *gv)
1216 SSPUSHINT(SAVEt_NSTAB);
1220 Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
1225 for (i = 1; i <= maxsarg; i++) {
1226 register SV * const sv = newSV(0);
1227 sv_setsv(sv,sarg[i]);
1229 SSPUSHPTR(sarg[i]); /* remember the pointer */
1230 SSPUSHPTR(sv); /* remember the value */
1231 SSPUSHINT(SAVEt_ITEM);
1236 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
1242 SSPUSHINT(SAVEt_DESTRUCTOR);
1247 =for apidoc sv_usepvn_mg
1249 Like C<sv_usepvn>, but also handles 'set' magic.
1255 Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len)
1257 sv_usepvn_flags(sv,ptr,len, SV_SMAGIC);
1261 =for apidoc sv_usepvn
1263 Tells an SV to use C<ptr> to find its string value. Implemented by
1264 calling C<sv_usepvn_flags> with C<flags> of 0, hence does not handle 'set'
1265 magic. See C<sv_usepvn_flags>.
1271 Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
1273 sv_usepvn_flags(sv,ptr,len, 0);
1277 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
1279 cv_ckproto_len(cv, gv, p, p ? strlen(p) : 0);
1283 =for apidoc unpack_str
1285 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
1286 and ocnt are not used. This call should not be used, use unpackstring instead.
1291 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s,
1292 const char *strbeg, const char *strend, char **new_s, I32 ocnt,
1295 PERL_UNUSED_ARG(strbeg);
1296 PERL_UNUSED_ARG(new_s);
1297 PERL_UNUSED_ARG(ocnt);
1299 return unpackstring(pat, patend, s, strend, flags);
1303 =for apidoc pack_cat
1305 The engine implementing pack() Perl function. Note: parameters next_in_list and
1306 flags are not used. This call should not be used; use packlist instead.
1312 Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1314 PERL_UNUSED_ARG(next_in_list);
1315 PERL_UNUSED_ARG(flags);
1317 packlist(cat, pat, patend, beglist, endlist);
1319 #endif /* NO_MATHOMS */
1323 * c-indentation-style: bsd
1325 * indent-tabs-mode: t
1328 * ex: set ts=8 sts=4 sw=4 noet: