This patch with tests resolves CPAN RT #40727. The issue is an infi-
[perl.git] / mathoms.c
1 /*    mathoms.c
2  *
3  *    Copyright (C) 2005, 2006, 2007, 2008 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  *     [p.5 of _The Lord of the Rings_: "Prologue"]
17  */
18
19
20
21 /* 
22  * This file contains mathoms, various binary artifacts from previous
23  * versions of Perl.  For binary or source compatibility reasons, though,
24  * we cannot completely remove them from the core code.  
25  *
26  * SMP - Oct. 24, 2005
27  *
28  */
29
30 #include "EXTERN.h"
31 #define PERL_IN_MATHOMS_C
32 #include "perl.h"
33
34 #ifdef NO_MATHOMS
35 /* ..." warning: ISO C forbids an empty source file"
36    So make sure we have something in here by processing the headers anyway.
37  */
38 #else
39
40 PERL_CALLCONV OP * Perl_ref(pTHX_ OP *o, I32 type);
41 PERL_CALLCONV void Perl_sv_unref(pTHX_ SV *sv);
42 PERL_CALLCONV void Perl_sv_taint(pTHX_ SV *sv);
43 PERL_CALLCONV IV Perl_sv_2iv(pTHX_ register SV *sv);
44 PERL_CALLCONV UV Perl_sv_2uv(pTHX_ register SV *sv);
45 PERL_CALLCONV NV Perl_sv_2nv(pTHX_ register SV *sv);
46 PERL_CALLCONV char * Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp);
47 PERL_CALLCONV char * Perl_sv_2pv_nolen(pTHX_ register SV *sv);
48 PERL_CALLCONV char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv);
49 PERL_CALLCONV char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv);
50 PERL_CALLCONV void Perl_sv_force_normal(pTHX_ register SV *sv);
51 PERL_CALLCONV void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr);
52 PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen);
53 PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len);
54 PERL_CALLCONV void Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr);
55 PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv);
56 PERL_CALLCONV char * Perl_sv_pv(pTHX_ SV *sv);
57 PERL_CALLCONV char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp);
58 PERL_CALLCONV char * Perl_sv_pvbyte(pTHX_ SV *sv);
59 PERL_CALLCONV char * Perl_sv_pvutf8(pTHX_ SV *sv);
60 PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv);
61 PERL_CALLCONV NV Perl_huge(void);
62 PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
63 PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix);
64 PERL_CALLCONV GV * Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name);
65 PERL_CALLCONV HE * Perl_hv_iternext(pTHX_ HV *hv);
66 PERL_CALLCONV void Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how);
67 PERL_CALLCONV bool Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp);
68 PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp);
69 PERL_CALLCONV bool Perl_do_exec(pTHX_ const char *cmd);
70 PERL_CALLCONV U8 * Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv);
71 PERL_CALLCONV bool Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep);
72 PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *sv);
73 PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len);
74 PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len);
75 PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...);
76 PERL_CALLCONV int Perl_printf_nocontext(const char *format, ...);
77 PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg);
78 PERL_CALLCONV AV * Perl_newAV(pTHX);
79 PERL_CALLCONV HV * Perl_newHV(pTHX);
80 PERL_CALLCONV IO * Perl_newIO(pTHX);
81 PERL_CALLCONV I32 Perl_my_stat(pTHX);
82 PERL_CALLCONV I32 Perl_my_lstat(pTHX);
83 PERL_CALLCONV I32 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2);
84 PERL_CALLCONV char * Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp);
85 PERL_CALLCONV bool Perl_sv_2bool(pTHX_ register SV *const sv);
86
87 /* ref() is now a macro using Perl_doref;
88  * this version provided for binary compatibility only.
89  */
90 OP *
91 Perl_ref(pTHX_ OP *o, I32 type)
92 {
93     return doref(o, type, TRUE);
94 }
95
96 /*
97 =for apidoc sv_unref
98
99 Unsets the RV status of the SV, and decrements the reference count of
100 whatever was being referenced by the RV.  This can almost be thought of
101 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
102 being zero.  See C<SvROK_off>.
103
104 =cut
105 */
106
107 void
108 Perl_sv_unref(pTHX_ SV *sv)
109 {
110     PERL_ARGS_ASSERT_SV_UNREF;
111
112     sv_unref_flags(sv, 0);
113 }
114
115 /*
116 =for apidoc sv_taint
117
118 Taint an SV. Use C<SvTAINTED_on> instead.
119 =cut
120 */
121
122 void
123 Perl_sv_taint(pTHX_ SV *sv)
124 {
125     PERL_ARGS_ASSERT_SV_TAINT;
126
127     sv_magic((sv), NULL, PERL_MAGIC_taint, NULL, 0);
128 }
129
130 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
131  * this function provided for binary compatibility only
132  */
133
134 IV
135 Perl_sv_2iv(pTHX_ register SV *sv)
136 {
137     return sv_2iv_flags(sv, SV_GMAGIC);
138 }
139
140 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
141  * this function provided for binary compatibility only
142  */
143
144 UV
145 Perl_sv_2uv(pTHX_ register SV *sv)
146 {
147     return sv_2uv_flags(sv, SV_GMAGIC);
148 }
149
150 /* sv_2nv() is now a macro using Perl_sv_2nv_flags();
151  * this function provided for binary compatibility only
152  */
153
154 NV
155 Perl_sv_2nv(pTHX_ register SV *sv)
156 {
157     return sv_2nv_flags(sv, SV_GMAGIC);
158 }
159
160
161 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
162  * this function provided for binary compatibility only
163  */
164
165 char *
166 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
167 {
168     return sv_2pv_flags(sv, lp, SV_GMAGIC);
169 }
170
171 /*
172 =for apidoc sv_2pv_nolen
173
174 Like C<sv_2pv()>, but doesn't return the length too. You should usually
175 use the macro wrapper C<SvPV_nolen(sv)> instead.
176 =cut
177 */
178
179 char *
180 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
181 {
182     PERL_ARGS_ASSERT_SV_2PV_NOLEN;
183     return sv_2pv(sv, NULL);
184 }
185
186 /*
187 =for apidoc sv_2pvbyte_nolen
188
189 Return a pointer to the byte-encoded representation of the SV.
190 May cause the SV to be downgraded from UTF-8 as a side-effect.
191
192 Usually accessed via the C<SvPVbyte_nolen> macro.
193
194 =cut
195 */
196
197 char *
198 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
199 {
200     PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN;
201
202     return sv_2pvbyte(sv, NULL);
203 }
204
205 /*
206 =for apidoc sv_2pvutf8_nolen
207
208 Return a pointer to the UTF-8-encoded representation of the SV.
209 May cause the SV to be upgraded to UTF-8 as a side-effect.
210
211 Usually accessed via the C<SvPVutf8_nolen> macro.
212
213 =cut
214 */
215
216 char *
217 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
218 {
219     PERL_ARGS_ASSERT_SV_2PVUTF8_NOLEN;
220
221     return sv_2pvutf8(sv, NULL);
222 }
223
224 /*
225 =for apidoc sv_force_normal
226
227 Undo various types of fakery on an SV: if the PV is a shared string, make
228 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
229 an xpvmg. See also C<sv_force_normal_flags>.
230
231 =cut
232 */
233
234 void
235 Perl_sv_force_normal(pTHX_ register SV *sv)
236 {
237     PERL_ARGS_ASSERT_SV_FORCE_NORMAL;
238
239     sv_force_normal_flags(sv, 0);
240 }
241
242 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
243  * this function provided for binary compatibility only
244  */
245
246 void
247 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
248 {
249     PERL_ARGS_ASSERT_SV_SETSV;
250
251     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
252 }
253
254 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
255  * this function provided for binary compatibility only
256  */
257
258 void
259 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
260 {
261     PERL_ARGS_ASSERT_SV_CATPVN;
262
263     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
264 }
265
266 /*
267 =for apidoc sv_catpvn_mg
268
269 Like C<sv_catpvn>, but also handles 'set' magic.
270
271 =cut
272 */
273
274 void
275 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
276 {
277     PERL_ARGS_ASSERT_SV_CATPVN_MG;
278
279     sv_catpvn_flags(sv,ptr,len,SV_GMAGIC|SV_SMAGIC);
280 }
281
282 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
283  * this function provided for binary compatibility only
284  */
285
286 void
287 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
288 {
289     PERL_ARGS_ASSERT_SV_CATSV;
290
291     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
292 }
293
294 /*
295 =for apidoc sv_catsv_mg
296
297 Like C<sv_catsv>, but also handles 'set' magic.
298
299 =cut
300 */
301
302 void
303 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
304 {
305     PERL_ARGS_ASSERT_SV_CATSV_MG;
306
307     sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC);
308 }
309
310 /*
311 =for apidoc sv_iv
312
313 A private implementation of the C<SvIVx> macro for compilers which can't
314 cope with complex macro expressions. Always use the macro instead.
315
316 =cut
317 */
318
319 IV
320 Perl_sv_iv(pTHX_ register SV *sv)
321 {
322     PERL_ARGS_ASSERT_SV_IV;
323
324     if (SvIOK(sv)) {
325         if (SvIsUV(sv))
326             return (IV)SvUVX(sv);
327         return SvIVX(sv);
328     }
329     return sv_2iv(sv);
330 }
331
332 /*
333 =for apidoc sv_uv
334
335 A private implementation of the C<SvUVx> macro for compilers which can't
336 cope with complex macro expressions. Always use the macro instead.
337
338 =cut
339 */
340
341 UV
342 Perl_sv_uv(pTHX_ register SV *sv)
343 {
344     PERL_ARGS_ASSERT_SV_UV;
345
346     if (SvIOK(sv)) {
347         if (SvIsUV(sv))
348             return SvUVX(sv);
349         return (UV)SvIVX(sv);
350     }
351     return sv_2uv(sv);
352 }
353
354 /*
355 =for apidoc sv_nv
356
357 A private implementation of the C<SvNVx> macro for compilers which can't
358 cope with complex macro expressions. Always use the macro instead.
359
360 =cut
361 */
362
363 NV
364 Perl_sv_nv(pTHX_ register SV *sv)
365 {
366     PERL_ARGS_ASSERT_SV_NV;
367
368     if (SvNOK(sv))
369         return SvNVX(sv);
370     return sv_2nv(sv);
371 }
372
373 /*
374 =for apidoc sv_pv
375
376 Use the C<SvPV_nolen> macro instead
377
378 =for apidoc sv_pvn
379
380 A private implementation of the C<SvPV> macro for compilers which can't
381 cope with complex macro expressions. Always use the macro instead.
382
383 =cut
384 */
385
386 char *
387 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
388 {
389     PERL_ARGS_ASSERT_SV_PVN;
390
391     if (SvPOK(sv)) {
392         *lp = SvCUR(sv);
393         return SvPVX(sv);
394     }
395     return sv_2pv(sv, lp);
396 }
397
398
399 char *
400 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
401 {
402     PERL_ARGS_ASSERT_SV_PVN_NOMG;
403
404     if (SvPOK(sv)) {
405         *lp = SvCUR(sv);
406         return SvPVX(sv);
407     }
408     return sv_2pv_flags(sv, lp, 0);
409 }
410
411 /* sv_pv() is now a macro using SvPV_nolen();
412  * this function provided for binary compatibility only
413  */
414
415 char *
416 Perl_sv_pv(pTHX_ SV *sv)
417 {
418     PERL_ARGS_ASSERT_SV_PV;
419
420     if (SvPOK(sv))
421         return SvPVX(sv);
422
423     return sv_2pv(sv, NULL);
424 }
425
426 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
427  * this function provided for binary compatibility only
428  */
429
430 char *
431 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
432 {
433     PERL_ARGS_ASSERT_SV_PVN_FORCE;
434
435     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
436 }
437
438 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
439  * this function provided for binary compatibility only
440  */
441
442 char *
443 Perl_sv_pvbyte(pTHX_ SV *sv)
444 {
445     PERL_ARGS_ASSERT_SV_PVBYTE;
446
447     sv_utf8_downgrade(sv, FALSE);
448     return sv_pv(sv);
449 }
450
451 /*
452 =for apidoc sv_pvbyte
453
454 Use C<SvPVbyte_nolen> instead.
455
456 =for apidoc sv_pvbyten
457
458 A private implementation of the C<SvPVbyte> macro for compilers
459 which can't cope with complex macro expressions. Always use the macro
460 instead.
461
462 =cut
463 */
464
465 char *
466 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
467 {
468     PERL_ARGS_ASSERT_SV_PVBYTEN;
469
470     sv_utf8_downgrade(sv, FALSE);
471     return sv_pvn(sv,lp);
472 }
473
474 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
475  * this function provided for binary compatibility only
476  */
477
478 char *
479 Perl_sv_pvutf8(pTHX_ SV *sv)
480 {
481     PERL_ARGS_ASSERT_SV_PVUTF8;
482
483     sv_utf8_upgrade(sv);
484     return sv_pv(sv);
485 }
486
487 /*
488 =for apidoc sv_pvutf8
489
490 Use the C<SvPVutf8_nolen> macro instead
491
492 =for apidoc sv_pvutf8n
493
494 A private implementation of the C<SvPVutf8> macro for compilers
495 which can't cope with complex macro expressions. Always use the macro
496 instead.
497
498 =cut
499 */
500
501 char *
502 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
503 {
504     PERL_ARGS_ASSERT_SV_PVUTF8N;
505
506     sv_utf8_upgrade(sv);
507     return sv_pvn(sv,lp);
508 }
509
510 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
511  * this function provided for binary compatibility only
512  */
513
514 STRLEN
515 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
516 {
517     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE;
518
519     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
520 }
521
522 int
523 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
524 {
525     dTHXs;
526     va_list(arglist);
527
528     /* Easier to special case this here than in embed.pl. (Look at what it
529        generates for proto.h) */
530 #ifdef PERL_IMPLICIT_CONTEXT
531     PERL_ARGS_ASSERT_FPRINTF_NOCONTEXT;
532 #endif
533
534     va_start(arglist, format);
535     return PerlIO_vprintf(stream, format, arglist);
536 }
537
538 int
539 Perl_printf_nocontext(const char *format, ...)
540 {
541     dTHX;
542     va_list(arglist);
543
544 #ifdef PERL_IMPLICIT_CONTEXT
545     PERL_ARGS_ASSERT_PRINTF_NOCONTEXT;
546 #endif
547
548     va_start(arglist, format);
549     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
550 }
551
552 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
553 /*
554  * This hack is to force load of "huge" support from libm.a
555  * So it is in perl for (say) POSIX to use.
556  * Needed for SunOS with Sun's 'acc' for example.
557  */
558 NV
559 Perl_huge(void)
560 {
561 #  if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
562     return HUGE_VALL;
563 #  else
564     return HUGE_VAL;
565 #  endif
566 }
567 #endif
568
569 /* compatibility with versions <= 5.003. */
570 void
571 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
572 {
573     PERL_ARGS_ASSERT_GV_FULLNAME;
574
575     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
576 }
577
578 /* compatibility with versions <= 5.003. */
579 void
580 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
581 {
582     PERL_ARGS_ASSERT_GV_EFULLNAME;
583
584     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
585 }
586
587 void
588 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
589 {
590     PERL_ARGS_ASSERT_GV_FULLNAME3;
591
592     gv_fullname4(sv, gv, prefix, TRUE);
593 }
594
595 void
596 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
597 {
598     PERL_ARGS_ASSERT_GV_EFULLNAME3;
599
600     gv_efullname4(sv, gv, prefix, TRUE);
601 }
602
603 /*
604 =for apidoc gv_fetchmethod
605
606 See L<gv_fetchmethod_autoload>.
607
608 =cut
609 */
610
611 GV *
612 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
613 {
614     PERL_ARGS_ASSERT_GV_FETCHMETHOD;
615
616     return gv_fetchmethod_autoload(stash, name, TRUE);
617 }
618
619 HE *
620 Perl_hv_iternext(pTHX_ HV *hv)
621 {
622     PERL_ARGS_ASSERT_HV_ITERNEXT;
623
624     return hv_iternext_flags(hv, 0);
625 }
626
627 void
628 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
629 {
630     PERL_ARGS_ASSERT_HV_MAGIC;
631
632     sv_magic(MUTABLE_SV(hv), MUTABLE_SV(gv), how, NULL, 0);
633 }
634
635 bool
636 Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
637              int rawmode, int rawperm, PerlIO *supplied_fp)
638 {
639     PERL_ARGS_ASSERT_DO_OPEN;
640
641     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
642                     supplied_fp, (SV **) NULL, 0);
643 }
644
645 bool
646 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int 
647 as_raw,
648               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
649               I32 num_svs)
650 {
651     PERL_ARGS_ASSERT_DO_OPEN9;
652
653     PERL_UNUSED_ARG(num_svs);
654     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
655                     supplied_fp, &svs, 1);
656 }
657
658 int
659 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
660 {
661  /* The old body of this is now in non-LAYER part of perlio.c
662   * This is a stub for any XS code which might have been calling it.
663   */
664  const char *name = ":raw";
665
666  PERL_ARGS_ASSERT_DO_BINMODE;
667
668 #ifdef PERLIO_USING_CRLF
669  if (!(mode & O_BINARY))
670      name = ":crlf";
671 #endif
672  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
673 }
674
675 #ifndef OS2
676 bool
677 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
678 {
679     PERL_ARGS_ASSERT_DO_AEXEC;
680
681     return do_aexec5(really, mark, sp, 0, 0);
682 }
683 #endif
684
685 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
686 bool
687 Perl_do_exec(pTHX_ const char *cmd)
688 {
689     PERL_ARGS_ASSERT_DO_EXEC;
690
691     return do_exec3(cmd,0,0);
692 }
693 #endif
694
695 /* Backwards compatibility. */
696 int
697 Perl_init_i18nl14n(pTHX_ int printwarn)
698 {
699     return init_i18nl10n(printwarn);
700 }
701
702 PP(pp_padany)
703 {
704     DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
705 }
706
707 PP(pp_mapstart)
708 {
709     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
710 }
711
712 /* These ops all have the same body as pp_null.  */
713 PP(pp_scalar)
714 {
715     dVAR;
716     return NORMAL;
717 }
718
719 PP(pp_regcmaybe)
720 {
721     dVAR;
722     return NORMAL;
723 }
724
725 PP(pp_lineseq)
726 {
727     dVAR;
728     return NORMAL;
729 }
730
731 PP(pp_scope)
732 {
733     dVAR;
734     return NORMAL;
735 }
736
737 /* Ops that are calls to do_kv.  */
738 PP(pp_values)
739 {
740     return do_kv();
741 }
742
743 PP(pp_keys)
744 {
745     return do_kv();
746 }
747
748 /* Ops that are simply calls to other ops.  */
749 PP(pp_dump)
750 {
751     return pp_goto();
752     /*NOTREACHED*/
753 }
754
755 PP(pp_dofile)
756 {
757     return pp_require();
758 }
759
760 PP(pp_dbmclose)
761 {
762     return pp_untie();
763 }
764
765 PP(pp_read)
766 {
767     return pp_sysread();
768 }
769
770 PP(pp_recv)
771 {
772     return pp_sysread();
773 }
774
775 PP(pp_seek)
776 {
777     return pp_sysseek();
778 }
779
780 PP(pp_fcntl)
781 {
782     return pp_ioctl();
783 }
784
785 PP(pp_gsockopt)
786 {
787     return pp_ssockopt();
788 }
789
790 PP(pp_getsockname)
791 {
792     return pp_getpeername();
793 }
794
795 PP(pp_lstat)
796 {
797     return pp_stat();
798 }
799
800 PP(pp_fteowned)
801 {
802     return pp_ftrowned();
803 }
804
805 PP(pp_ftbinary)
806 {
807     return pp_fttext();
808 }
809
810 PP(pp_localtime)
811 {
812     return pp_gmtime();
813 }
814
815 PP(pp_shmget)
816 {
817     return pp_semget();
818 }
819
820 PP(pp_shmctl)
821 {
822     return pp_semctl();
823 }
824
825 PP(pp_shmread)
826 {
827     return pp_shmwrite();
828 }
829
830 PP(pp_msgget)
831 {
832     return pp_semget();
833 }
834
835 PP(pp_msgctl)
836 {
837     return pp_semctl();
838 }
839
840 PP(pp_ghbyname)
841 {
842     return pp_ghostent();
843 }
844
845 PP(pp_ghbyaddr)
846 {
847     return pp_ghostent();
848 }
849
850 PP(pp_gnbyname)
851 {
852     return pp_gnetent();
853 }
854
855 PP(pp_gnbyaddr)
856 {
857     return pp_gnetent();
858 }
859
860 PP(pp_gpbyname)
861 {
862     return pp_gprotoent();
863 }
864
865 PP(pp_gpbynumber)
866 {
867     return pp_gprotoent();
868 }
869
870 PP(pp_gsbyname)
871 {
872     return pp_gservent();
873 }
874
875 PP(pp_gsbyport)
876 {
877     return pp_gservent();
878 }
879
880 PP(pp_gpwnam)
881 {
882     return pp_gpwent();
883 }
884
885 PP(pp_gpwuid)
886 {
887     return pp_gpwent();
888 }
889
890 PP(pp_ggrnam)
891 {
892     return pp_ggrent();
893 }
894
895 PP(pp_ggrgid)
896 {
897     return pp_ggrent();
898 }
899
900 PP(pp_ftsize)
901 {
902     return pp_ftis();
903 }
904
905 PP(pp_ftmtime)
906 {
907     return pp_ftis();
908 }
909
910 PP(pp_ftatime)
911 {
912     return pp_ftis();
913 }
914
915 PP(pp_ftctime)
916 {
917     return pp_ftis();
918 }
919
920 PP(pp_ftzero)
921 {
922     return pp_ftrowned();
923 }
924
925 PP(pp_ftsock)
926 {
927     return pp_ftrowned();
928 }
929
930 PP(pp_ftchr)
931 {
932     return pp_ftrowned();
933 }
934
935 PP(pp_ftblk)
936 {
937     return pp_ftrowned();
938 }
939
940 PP(pp_ftfile)
941 {
942     return pp_ftrowned();
943 }
944
945 PP(pp_ftdir)
946 {
947     return pp_ftrowned();
948 }
949
950 PP(pp_ftpipe)
951 {
952     return pp_ftrowned();
953 }
954
955 PP(pp_ftsuid)
956 {
957     return pp_ftrowned();
958 }
959
960 PP(pp_ftsgid)
961 {
962     return pp_ftrowned();
963 }
964
965 PP(pp_ftsvtx)
966 {
967     return pp_ftrowned();
968 }
969
970 PP(pp_unlink)
971 {
972     return pp_chown();
973 }
974
975 PP(pp_chmod)
976 {
977     return pp_chown();
978 }
979
980 PP(pp_utime)
981 {
982     return pp_chown();
983 }
984
985 PP(pp_kill)
986 {
987     return pp_chown();
988 }
989
990 PP(pp_symlink)
991 {
992     return pp_link();
993 }
994
995 PP(pp_ftrwrite)
996 {
997     return pp_ftrread();
998 }
999
1000 PP(pp_ftrexec)
1001 {
1002     return pp_ftrread();
1003 }
1004
1005 PP(pp_fteread)
1006 {
1007     return pp_ftrread();
1008 }
1009
1010 PP(pp_ftewrite)
1011 {
1012     return pp_ftrread();
1013 }
1014
1015 PP(pp_fteexec)
1016 {
1017     return pp_ftrread();
1018 }
1019
1020 PP(pp_msgsnd)
1021 {
1022     return pp_shmwrite();
1023 }
1024
1025 PP(pp_msgrcv)
1026 {
1027     return pp_shmwrite();
1028 }
1029
1030 PP(pp_syswrite)
1031 {
1032     return pp_send();
1033 }
1034
1035 PP(pp_semop)
1036 {
1037     return pp_shmwrite();
1038 }
1039
1040 PP(pp_dor)
1041 {
1042     return pp_defined();
1043 }
1044
1045 PP(pp_andassign)
1046 {
1047     return pp_and();
1048 }
1049
1050 PP(pp_orassign)
1051 {
1052     return pp_or();
1053 }
1054
1055 PP(pp_dorassign)
1056 {
1057     return pp_defined();
1058
1059
1060 PP(pp_lcfirst)
1061 {
1062     return pp_ucfirst();
1063 }
1064
1065 PP(pp_slt)
1066 {
1067     return pp_sle();
1068 }
1069
1070 PP(pp_sgt)
1071 {
1072     return pp_sle();
1073 }
1074
1075 PP(pp_sge)
1076 {
1077     return pp_sle();
1078 }
1079
1080 PP(pp_rindex)
1081 {
1082     return pp_index();
1083 }
1084
1085 PP(pp_hex)
1086 {
1087     return pp_oct();
1088 }
1089
1090 PP(pp_pop)
1091 {
1092     return pp_shift();
1093 }
1094
1095 PP(pp_cos)
1096 {
1097     return pp_sin();
1098 }
1099
1100 PP(pp_exp)
1101 {
1102     return pp_sin();
1103 }
1104
1105 PP(pp_log)
1106 {
1107     return pp_sin();
1108 }
1109
1110 PP(pp_sqrt)
1111 {
1112     return pp_sin();
1113 }
1114
1115 PP(pp_bit_xor)
1116 {
1117     return pp_bit_or();
1118 }
1119
1120 PP(pp_rv2hv)
1121 {
1122     return Perl_pp_rv2av(aTHX);
1123 }
1124
1125 U8 *
1126 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
1127 {
1128     PERL_ARGS_ASSERT_UVUNI_TO_UTF8;
1129
1130     return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
1131 }
1132
1133 bool
1134 Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
1135 {
1136     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOC;
1137
1138     return is_utf8_string_loclen(s, len, ep, 0);
1139 }
1140
1141 /*
1142 =for apidoc sv_nolocking
1143
1144 Dummy routine which "locks" an SV when there is no locking module present.
1145 Exists to avoid test for a NULL function pointer and because it could
1146 potentially warn under some level of strict-ness.
1147
1148 "Superseded" by sv_nosharing().
1149
1150 =cut
1151 */
1152
1153 void
1154 Perl_sv_nolocking(pTHX_ SV *sv)
1155 {
1156     PERL_UNUSED_CONTEXT;
1157     PERL_UNUSED_ARG(sv);
1158 }
1159
1160
1161 /*
1162 =for apidoc sv_nounlocking
1163
1164 Dummy routine which "unlocks" an SV when there is no locking module present.
1165 Exists to avoid test for a NULL function pointer and because it could
1166 potentially warn under some level of strict-ness.
1167
1168 "Superseded" by sv_nosharing().
1169
1170 =cut
1171 */
1172
1173 void
1174 Perl_sv_nounlocking(pTHX_ SV *sv)
1175 {
1176     PERL_UNUSED_CONTEXT;
1177     PERL_UNUSED_ARG(sv);
1178 }
1179
1180 void
1181 Perl_save_long(pTHX_ long int *longp)
1182 {
1183     dVAR;
1184
1185     PERL_ARGS_ASSERT_SAVE_LONG;
1186
1187     SSCHECK(3);
1188     SSPUSHLONG(*longp);
1189     SSPUSHPTR(longp);
1190     SSPUSHUV(SAVEt_LONG);
1191 }
1192
1193 void
1194 Perl_save_iv(pTHX_ IV *ivp)
1195 {
1196     dVAR;
1197
1198     PERL_ARGS_ASSERT_SAVE_IV;
1199
1200     SSCHECK(3);
1201     SSPUSHIV(*ivp);
1202     SSPUSHPTR(ivp);
1203     SSPUSHUV(SAVEt_IV);
1204 }
1205
1206 void
1207 Perl_save_nogv(pTHX_ GV *gv)
1208 {
1209     dVAR;
1210
1211     PERL_ARGS_ASSERT_SAVE_NOGV;
1212
1213     SSCHECK(2);
1214     SSPUSHPTR(gv);
1215     SSPUSHUV(SAVEt_NSTAB);
1216 }
1217
1218 void
1219 Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
1220 {
1221     dVAR;
1222     register I32 i;
1223
1224     PERL_ARGS_ASSERT_SAVE_LIST;
1225
1226     for (i = 1; i <= maxsarg; i++) {
1227         register SV * const sv = newSV(0);
1228         sv_setsv(sv,sarg[i]);
1229         SSCHECK(3);
1230         SSPUSHPTR(sarg[i]);             /* remember the pointer */
1231         SSPUSHPTR(sv);                  /* remember the value */
1232         SSPUSHUV(SAVEt_ITEM);
1233     }
1234 }
1235
1236 /*
1237 =for apidoc sv_usepvn_mg
1238
1239 Like C<sv_usepvn>, but also handles 'set' magic.
1240
1241 =cut
1242 */
1243
1244 void
1245 Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len)
1246 {
1247     PERL_ARGS_ASSERT_SV_USEPVN_MG;
1248
1249     sv_usepvn_flags(sv,ptr,len, SV_SMAGIC);
1250 }
1251
1252 /*
1253 =for apidoc sv_usepvn
1254
1255 Tells an SV to use C<ptr> to find its string value. Implemented by
1256 calling C<sv_usepvn_flags> with C<flags> of 0, hence does not handle 'set'
1257 magic. See C<sv_usepvn_flags>.
1258
1259 =cut
1260 */
1261
1262 void
1263 Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
1264 {
1265     PERL_ARGS_ASSERT_SV_USEPVN;
1266
1267     sv_usepvn_flags(sv,ptr,len, 0);
1268 }
1269
1270 /*
1271 =for apidoc unpack_str
1272
1273 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
1274 and ocnt are not used. This call should not be used, use unpackstring instead.
1275
1276 =cut */
1277
1278 I32
1279 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s,
1280                 const char *strbeg, const char *strend, char **new_s, I32 ocnt,
1281                 U32 flags)
1282 {
1283     PERL_ARGS_ASSERT_UNPACK_STR;
1284
1285     PERL_UNUSED_ARG(strbeg);
1286     PERL_UNUSED_ARG(new_s);
1287     PERL_UNUSED_ARG(ocnt);
1288
1289     return unpackstring(pat, patend, s, strend, flags);
1290 }
1291
1292 /*
1293 =for apidoc pack_cat
1294
1295 The engine implementing pack() Perl function. Note: parameters next_in_list and
1296 flags are not used. This call should not be used; use packlist instead.
1297
1298 =cut
1299 */
1300
1301 void
1302 Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1303 {
1304     PERL_ARGS_ASSERT_PACK_CAT;
1305
1306     PERL_UNUSED_ARG(next_in_list);
1307     PERL_UNUSED_ARG(flags);
1308
1309     packlist(cat, pat, patend, beglist, endlist);
1310 }
1311
1312 HE *
1313 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
1314 {
1315   return (HE *)hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
1316 }
1317
1318 bool
1319 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1320 {
1321     PERL_ARGS_ASSERT_HV_EXISTS_ENT;
1322
1323     return hv_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
1324         ? TRUE : FALSE;
1325 }
1326
1327 HE *
1328 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash)
1329 {
1330     PERL_ARGS_ASSERT_HV_FETCH_ENT;
1331
1332     return (HE *)hv_common(hv, keysv, NULL, 0, 0, 
1333                      (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
1334 }
1335
1336 SV *
1337 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1338 {
1339     PERL_ARGS_ASSERT_HV_DELETE_ENT;
1340
1341     return MUTABLE_SV(hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL,
1342                                 hash));
1343 }
1344
1345 SV**
1346 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash,
1347                     int flags)
1348 {
1349     return (SV**) hv_common(hv, NULL, key, klen, flags,
1350                             (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
1351 }
1352
1353 SV**
1354 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
1355 {
1356     STRLEN klen;
1357     int flags;
1358
1359     if (klen_i32 < 0) {
1360         klen = -klen_i32;
1361         flags = HVhek_UTF8;
1362     } else {
1363         klen = klen_i32;
1364         flags = 0;
1365     }
1366     return (SV **) hv_common(hv, NULL, key, klen, flags,
1367                              (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
1368 }
1369
1370 bool
1371 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
1372 {
1373     STRLEN klen;
1374     int flags;
1375
1376     PERL_ARGS_ASSERT_HV_EXISTS;
1377
1378     if (klen_i32 < 0) {
1379         klen = -klen_i32;
1380         flags = HVhek_UTF8;
1381     } else {
1382         klen = klen_i32;
1383         flags = 0;
1384     }
1385     return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
1386         ? TRUE : FALSE;
1387 }
1388
1389 SV**
1390 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
1391 {
1392     STRLEN klen;
1393     int flags;
1394
1395     PERL_ARGS_ASSERT_HV_FETCH;
1396
1397     if (klen_i32 < 0) {
1398         klen = -klen_i32;
1399         flags = HVhek_UTF8;
1400     } else {
1401         klen = klen_i32;
1402         flags = 0;
1403     }
1404     return (SV **) hv_common(hv, NULL, key, klen, flags,
1405                              lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE)
1406                              : HV_FETCH_JUST_SV, NULL, 0);
1407 }
1408
1409 SV *
1410 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
1411 {
1412     STRLEN klen;
1413     int k_flags;
1414
1415     PERL_ARGS_ASSERT_HV_DELETE;
1416
1417     if (klen_i32 < 0) {
1418         klen = -klen_i32;
1419         k_flags = HVhek_UTF8;
1420     } else {
1421         klen = klen_i32;
1422         k_flags = 0;
1423     }
1424     return MUTABLE_SV(hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE,
1425                                 NULL, 0));
1426 }
1427
1428 /* Functions after here were made mathoms post 5.10.0 but pre 5.8.9 */
1429
1430 AV *
1431 Perl_newAV(pTHX)
1432 {
1433     return MUTABLE_AV(newSV_type(SVt_PVAV));
1434     /* sv_upgrade does AvREAL_only():
1435     AvALLOC(av) = 0;
1436     AvARRAY(av) = NULL;
1437     AvMAX(av) = AvFILLp(av) = -1; */
1438 }
1439
1440 HV *
1441 Perl_newHV(pTHX)
1442 {
1443     HV * const hv = MUTABLE_HV(newSV_type(SVt_PVHV));
1444     assert(!SvOK(hv));
1445
1446     return hv;
1447 }
1448
1449 void
1450 Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, 
1451               const char *const little, const STRLEN littlelen)
1452 {
1453     PERL_ARGS_ASSERT_SV_INSERT;
1454     sv_insert_flags(bigstr, offset, len, little, littlelen, SV_GMAGIC);
1455 }
1456
1457 void
1458 Perl_save_freesv(pTHX_ SV *sv)
1459 {
1460     dVAR;
1461     save_freesv(sv);
1462 }
1463
1464 void
1465 Perl_save_mortalizesv(pTHX_ SV *sv)
1466 {
1467     dVAR;
1468
1469     PERL_ARGS_ASSERT_SAVE_MORTALIZESV;
1470
1471     save_mortalizesv(sv);
1472 }
1473
1474 void
1475 Perl_save_freeop(pTHX_ OP *o)
1476 {
1477     dVAR;
1478     save_freeop(o);
1479 }
1480
1481 void
1482 Perl_save_freepv(pTHX_ char *pv)
1483 {
1484     dVAR;
1485     save_freepv(pv);
1486 }
1487
1488 void
1489 Perl_save_op(pTHX)
1490 {
1491     dVAR;
1492     save_op();
1493 }
1494
1495 #ifdef PERL_DONT_CREATE_GVSV
1496 GV *
1497 Perl_gv_SVadd(pTHX_ GV *gv)
1498 {
1499     return gv_SVadd(gv);
1500 }
1501 #endif
1502
1503 GV *
1504 Perl_gv_AVadd(pTHX_ GV *gv)
1505 {
1506     return gv_AVadd(gv);
1507 }
1508
1509 GV *
1510 Perl_gv_HVadd(pTHX_ register GV *gv)
1511 {
1512     return gv_HVadd(gv);
1513 }
1514
1515 GV *
1516 Perl_gv_IOadd(pTHX_ register GV *gv)
1517 {
1518     return gv_IOadd(gv);
1519 }
1520
1521 IO *
1522 Perl_newIO(pTHX)
1523 {
1524     return MUTABLE_IO(newSV_type(SVt_PVIO));
1525 }
1526
1527 I32
1528 Perl_my_stat(pTHX)
1529 {
1530     return my_stat_flags(SV_GMAGIC);
1531 }
1532
1533 I32
1534 Perl_my_lstat(pTHX)
1535 {
1536     return my_lstat_flags(SV_GMAGIC);
1537 }
1538
1539 I32
1540 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
1541 {
1542     return sv_eq_flags(sv1, sv2, SV_GMAGIC);
1543 }
1544
1545 char *
1546 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
1547 {
1548     return sv_collxfrm_flags(sv, nxp, SV_GMAGIC);
1549 }
1550
1551 bool
1552 Perl_sv_2bool(pTHX_ register SV *const sv)
1553 {
1554     return sv_2bool_flags(sv, SV_GMAGIC);
1555 }
1556
1557 #endif /* NO_MATHOMS */
1558
1559 /*
1560  * Local variables:
1561  * c-indentation-style: bsd
1562  * c-basic-offset: 4
1563  * indent-tabs-mode: t
1564  * End:
1565  *
1566  * ex: set ts=8 sts=4 sw=4 noet:
1567  */