Context Navigation

source: trunk/third/perl/pp.c @ 14545

Visit:

Revision 14545, 104.2 KB checked in by ghudson, 25 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.

Line
1	/* pp.c
2	*
3	* Copyright (c) 1991-2000, Larry Wall
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	* "It's a big house this, and very peculiar. Always a bit more to discover,
12	* and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
13	*/
14
15	#include "EXTERN.h"
16	#define PERL_IN_PP_C
17	#include "perl.h"
18
19	/*
20	* The compiler on Concurrent CX/UX systems has a subtle bug which only
21	* seems to show up when compiling pp.c - it generates the wrong double
22	* precision constant value for (double)UV_MAX when used inline in the body
23	* of the code below, so this makes a static variable up front (which the
24	* compiler seems to get correct) and uses it in place of UV_MAX below.
25	*/
26	#ifdef CXUX_BROKEN_CONSTANT_CONVERT
27	static double UV_MAX_cxux = ((double)UV_MAX);
28	#endif
29
30	/*
31	* Offset for integer pack/unpack.
32	*
33	* On architectures where I16 and I32 aren't really 16 and 32 bits,
34	* which for now are all Crays, pack and unpack have to play games.
35	*/
36
37	/*
38	* These values are required for portability of pack() output.
39	* If they're not right on your machine, then pack() and unpack()
40	* wouldn't work right anyway; you'll need to apply the Cray hack.
41	* (I'd like to check them with #if, but you can't use sizeof() in
42	* the preprocessor.) --???
43	*/
44	/*
45	The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46	defines are now in config.h. --Andy Dougherty April 1998
47	*/
48	#define SIZE16 2
49	#define SIZE32 4
50
51	/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
52	--jhi Feb 1999 */
53
54	#if SHORTSIZE != SIZE16 \|\| LONGSIZE != SIZE32
55	# define PERL_NATINT_PACK
56	#endif
57
58	#if LONGSIZE > 4 && defined(_CRAY)
59	# if BYTEORDER == 0x12345678
60	# define OFF16(p) (char*)(p)
61	# define OFF32(p) (char*)(p)
62	# else
63	# if BYTEORDER == 0x87654321
64	# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65	# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
66	# else
67	}}}} bad cray byte order
68	# endif
69	# endif
70	# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71	# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72	# define COPYNN(s,p,n) ((p) = 0, Copy(s, (char )(p), n, char))
73	# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74	# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
75	#else
76	# define COPY16(s,p) Copy(s, p, SIZE16, char)
77	# define COPY32(s,p) Copy(s, p, SIZE32, char)
78	# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79	# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80	# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
81	#endif
82
83	/* variations on pp_null */
84
85	#ifdef I_UNISTD
86	#include <unistd.h>
87	#endif
88
89	/* XXX I can't imagine anyone who doesn't have this actually _needs_
90	it, since pid_t is an integral type.
91	--AD 2/20/1998
92	*/
93	#ifdef NEED_GETPID_PROTO
94	extern Pid_t getpid (void);
95	#endif
96
97	PP(pp_stub)
98	{
99	djSP;
100	if (GIMME_V == G_SCALAR)
101	XPUSHs(&PL_sv_undef);
102	RETURN;
103	}
104
105	PP(pp_scalar)
106	{
107	return NORMAL;
108	}
109
110	/* Pushy stuff. */
111
112	PP(pp_padav)
113	{
114	djSP; dTARGET;
115	if (PL_op->op_private & OPpLVAL_INTRO)
116	SAVECLEARSV(PL_curpad[PL_op->op_targ]);
117	EXTEND(SP, 1);
118	if (PL_op->op_flags & OPf_REF) {
119	PUSHs(TARG);
120	RETURN;
121	}
122	if (GIMME == G_ARRAY) {
123	I32 maxarg = AvFILL((AV*)TARG) + 1;
124	EXTEND(SP, maxarg);
125	if (SvMAGICAL(TARG)) {
126	U32 i;
127	for (i=0; i < maxarg; i++) {
128	SV *svp = av_fetch((AV)TARG, i, FALSE);
129	SP[i+1] = (svp) ? *svp : &PL_sv_undef;
130	}
131	}
132	else {
133	Copy(AvARRAY((AV)TARG), SP+1, maxarg, SV);
134	}
135	SP += maxarg;
136	}
137	else {
138	SV* sv = sv_newmortal();
139	I32 maxarg = AvFILL((AV*)TARG) + 1;
140	sv_setiv(sv, maxarg);
141	PUSHs(sv);
142	}
143	RETURN;
144	}
145
146	PP(pp_padhv)
147	{
148	djSP; dTARGET;
149	I32 gimme;
150
151	XPUSHs(TARG);
152	if (PL_op->op_private & OPpLVAL_INTRO)
153	SAVECLEARSV(PL_curpad[PL_op->op_targ]);
154	if (PL_op->op_flags & OPf_REF)
155	RETURN;
156	gimme = GIMME_V;
157	if (gimme == G_ARRAY) {
158	RETURNOP(do_kv());
159	}
160	else if (gimme == G_SCALAR) {
161	SV* sv = sv_newmortal();
162	if (HvFILL((HV*)TARG))
163	Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
164	(long)HvFILL((HV)TARG), (long)HvMAX((HV)TARG) + 1);
165	else
166	sv_setiv(sv, 0);
167	SETs(sv);
168	}
169	RETURN;
170	}
171
172	PP(pp_padany)
173	{
174	DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
175	}
176
177	/* Translations. */
178
179	PP(pp_rv2gv)
180	{
181	djSP; dTOPss;
182
183	if (SvROK(sv)) {
184	wasref:
185	tryAMAGICunDEREF(to_gv);
186
187	sv = SvRV(sv);
188	if (SvTYPE(sv) == SVt_PVIO) {
189	GV gv = (GV) sv_newmortal();
190	gv_init(gv, 0, "", 0, 0);
191	GvIOp(gv) = (IO *)sv;
192	(void)SvREFCNT_inc(sv);
193	sv = (SV*) gv;
194	}
195	else if (SvTYPE(sv) != SVt_PVGV)
196	DIE(aTHX_ "Not a GLOB reference");
197	}
198	else {
199	if (SvTYPE(sv) != SVt_PVGV) {
200	char *sym;
201	STRLEN n_a;
202
203	if (SvGMAGICAL(sv)) {
204	mg_get(sv);
205	if (SvROK(sv))
206	goto wasref;
207	}
208	if (!SvOK(sv) && sv != &PL_sv_undef) {
209	/* If this is a 'my' scalar and flag is set then vivify
210	* NI-S 1999/05/07
211	*/
212	if (PL_op->op_private & OPpDEREF) {
213	char *name;
214	GV *gv;
215	if (cUNOP->op_targ) {
216	STRLEN len;
217	SV *namesv = PL_curpad[cUNOP->op_targ];
218	name = SvPV(namesv, len);
219	gv = (GV*)NEWSV(0,0);
220	gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
221	}
222	else {
223	name = CopSTASHPV(PL_curcop);
224	gv = newGVgen(name);
225	}
226	sv_upgrade(sv, SVt_RV);
227	SvRV(sv) = (SV*)gv;
228	SvROK_on(sv);
229	SvSETMAGIC(sv);
230	goto wasref;
231	}
232	if (PL_op->op_flags & OPf_REF \|\|
233	PL_op->op_private & HINT_STRICT_REFS)
234	DIE(aTHX_ PL_no_usym, "a symbol");
235	if (ckWARN(WARN_UNINITIALIZED))
236	report_uninit();
237	RETSETUNDEF;
238	}
239	sym = SvPV(sv, n_a);
240	if ((PL_op->op_flags & OPf_SPECIAL) &&
241	!(PL_op->op_flags & OPf_MOD))
242	{
243	sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
244	if (!sv)
245	RETSETUNDEF;
246	}
247	else {
248	if (PL_op->op_private & HINT_STRICT_REFS)
249	DIE(aTHX_ PL_no_symref, sym, "a symbol");
250	sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
251	}
252	}
253	}
254	if (PL_op->op_private & OPpLVAL_INTRO)
255	save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
256	SETs(sv);
257	RETURN;
258	}
259
260	PP(pp_rv2sv)
261	{
262	djSP; dTOPss;
263
264	if (SvROK(sv)) {
265	wasref:
266	tryAMAGICunDEREF(to_sv);
267
268	sv = SvRV(sv);
269	switch (SvTYPE(sv)) {
270	case SVt_PVAV:
271	case SVt_PVHV:
272	case SVt_PVCV:
273	DIE(aTHX_ "Not a SCALAR reference");
274	}
275	}
276	else {
277	GV gv = (GV)sv;
278	char *sym;
279	STRLEN n_a;
280
281	if (SvTYPE(gv) != SVt_PVGV) {
282	if (SvGMAGICAL(sv)) {
283	mg_get(sv);
284	if (SvROK(sv))
285	goto wasref;
286	}
287	if (!SvOK(sv)) {
288	if (PL_op->op_flags & OPf_REF \|\|
289	PL_op->op_private & HINT_STRICT_REFS)
290	DIE(aTHX_ PL_no_usym, "a SCALAR");
291	if (ckWARN(WARN_UNINITIALIZED))
292	report_uninit();
293	RETSETUNDEF;
294	}
295	sym = SvPV(sv, n_a);
296	if ((PL_op->op_flags & OPf_SPECIAL) &&
297	!(PL_op->op_flags & OPf_MOD))
298	{
299	gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
300	if (!gv)
301	RETSETUNDEF;
302	}
303	else {
304	if (PL_op->op_private & HINT_STRICT_REFS)
305	DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
306	gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
307	}
308	}
309	sv = GvSV(gv);
310	}
311	if (PL_op->op_flags & OPf_MOD) {
312	if (PL_op->op_private & OPpLVAL_INTRO)
313	sv = save_scalar((GV*)TOPs);
314	else if (PL_op->op_private & OPpDEREF)
315	vivify_ref(sv, PL_op->op_private & OPpDEREF);
316	}
317	SETs(sv);
318	RETURN;
319	}
320
321	PP(pp_av2arylen)
322	{
323	djSP;
324	AV av = (AV)TOPs;
325	SV *sv = AvARYLEN(av);
326	if (!sv) {
327	AvARYLEN(av) = sv = NEWSV(0,0);
328	sv_upgrade(sv, SVt_IV);
329	sv_magic(sv, (SV*)av, '#', Nullch, 0);
330	}
331	SETs(sv);
332	RETURN;
333	}
334
335	PP(pp_pos)
336	{
337	djSP; dTARGET; dPOPss;
338
339	if (PL_op->op_flags & OPf_MOD) {
340	if (SvTYPE(TARG) < SVt_PVLV) {
341	sv_upgrade(TARG, SVt_PVLV);
342	sv_magic(TARG, Nullsv, '.', Nullch, 0);
343	}
344
345	LvTYPE(TARG) = '.';
346	if (LvTARG(TARG) != sv) {
347	if (LvTARG(TARG))
348	SvREFCNT_dec(LvTARG(TARG));
349	LvTARG(TARG) = SvREFCNT_inc(sv);
350	}
351	PUSHs(TARG); /* no SvSETMAGIC */
352	RETURN;
353	}
354	else {
355	MAGIC* mg;
356
357	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
358	mg = mg_find(sv, 'g');
359	if (mg && mg->mg_len >= 0) {
360	I32 i = mg->mg_len;
361	if (DO_UTF8(sv))
362	sv_pos_b2u(sv, &i);
363	PUSHi(i + PL_curcop->cop_arybase);
364	RETURN;
365	}
366	}
367	RETPUSHUNDEF;
368	}
369	}
370
371	PP(pp_rv2cv)
372	{
373	djSP;
374	GV *gv;
375	HV *stash;
376
377	/* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
378	/* (But not in defined().) */
379	CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
380	if (cv) {
381	if (CvCLONE(cv))
382	cv = (CV)sv_2mortal((SV)cv_clone(cv));
383	if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
384	DIE(aTHX_ "Can't modify non-lvalue subroutine call");
385	}
386	else
387	cv = (CV*)&PL_sv_undef;
388	SETs((SV*)cv);
389	RETURN;
390	}
391
392	PP(pp_prototype)
393	{
394	djSP;
395	CV *cv;
396	HV *stash;
397	GV *gv;
398	SV *ret;
399
400	ret = &PL_sv_undef;
401	if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
402	char *s = SvPVX(TOPs);
403	if (strnEQ(s, "CORE::", 6)) {
404	int code;
405
406	code = keyword(s + 6, SvCUR(TOPs) - 6);
407	if (code < 0) { /* Overridable. */
408	#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
409	int i = 0, n = 0, seen_question = 0;
410	I32 oa;
411	char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
412
413	while (i < MAXO) { /* The slow way. */
414	if (strEQ(s + 6, PL_op_name[i])
415	\|\| strEQ(s + 6, PL_op_desc[i]))
416	{
417	goto found;
418	}
419	i++;
420	}
421	goto nonesuch; /* Should not happen... */
422	found:
423	oa = PL_opargs[i] >> OASHIFT;
424	while (oa) {
425	if (oa & OA_OPTIONAL) {
426	seen_question = 1;
427	str[n++] = ';';
428	}
429	else if (n && str[0] == ';' && seen_question)
430	goto set; /* XXXX system, exec */
431	if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
432	&& (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
433	str[n++] = '\\';
434	}
435	/* What to do with R ((un)tie, tied, (sys)read, recv)? */
436	str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
437	oa = oa >> 4;
438	}
439	str[n++] = '\0';
440	ret = sv_2mortal(newSVpvn(str, n - 1));
441	}
442	else if (code) /* Non-Overridable */
443	goto set;
444	else { /* None such */
445	nonesuch:
446	DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
447	}
448	}
449	}
450	cv = sv_2cv(TOPs, &stash, &gv, FALSE);
451	if (cv && SvPOK(cv))
452	ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
453	set:
454	SETs(ret);
455	RETURN;
456	}
457
458	PP(pp_anoncode)
459	{
460	djSP;
461	CV* cv = (CV*)PL_curpad[PL_op->op_targ];
462	if (CvCLONE(cv))
463	cv = (CV)sv_2mortal((SV)cv_clone(cv));
464	EXTEND(SP,1);
465	PUSHs((SV*)cv);
466	RETURN;
467	}
468
469	PP(pp_srefgen)
470	{
471	djSP;
472	SP = refto(SP);
473	RETURN;
474	}
475
476	PP(pp_refgen)
477	{
478	djSP; dMARK;
479	if (GIMME != G_ARRAY) {
480	if (++MARK <= SP)
481	MARK = SP;
482	else
483	*MARK = &PL_sv_undef;
484	MARK = refto(MARK);
485	SP = MARK;
486	RETURN;
487	}
488	EXTEND_MORTAL(SP - MARK);
489	while (++MARK <= SP)
490	MARK = refto(MARK);
491	RETURN;
492	}
493
494	STATIC SV*
495	S_refto(pTHX_ SV *sv)
496	{
497	SV* rv;
498
499	if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
500	if (LvTARGLEN(sv))
501	vivify_defelem(sv);
502	if (!(sv = LvTARG(sv)))
503	sv = &PL_sv_undef;
504	else
505	(void)SvREFCNT_inc(sv);
506	}
507	else if (SvTYPE(sv) == SVt_PVAV) {
508	if (!AvREAL((AV)sv) && AvREIFY((AV)sv))
509	av_reify((AV*)sv);
510	SvTEMP_off(sv);
511	(void)SvREFCNT_inc(sv);
512	}
513	else if (SvPADTMP(sv))
514	sv = newSVsv(sv);
515	else {
516	SvTEMP_off(sv);
517	(void)SvREFCNT_inc(sv);
518	}
519	rv = sv_newmortal();
520	sv_upgrade(rv, SVt_RV);
521	SvRV(rv) = sv;
522	SvROK_on(rv);
523	return rv;
524	}
525
526	PP(pp_ref)
527	{
528	djSP; dTARGET;
529	SV *sv;
530	char *pv;
531
532	sv = POPs;
533
534	if (sv && SvGMAGICAL(sv))
535	mg_get(sv);
536
537	if (!sv \|\| !SvROK(sv))
538	RETPUSHNO;
539
540	sv = SvRV(sv);
541	pv = sv_reftype(sv,TRUE);
542	PUSHp(pv, strlen(pv));
543	RETURN;
544	}
545
546	PP(pp_bless)
547	{
548	djSP;
549	HV *stash;
550
551	if (MAXARG == 1)
552	stash = CopSTASH(PL_curcop);
553	else {
554	SV *ssv = POPs;
555	STRLEN len;
556	char *ptr = SvPV(ssv,len);
557	if (ckWARN(WARN_MISC) && len == 0)
558	Perl_warner(aTHX_ WARN_MISC,
559	"Explicit blessing to '' (assuming package main)");
560	stash = gv_stashpvn(ptr, len, TRUE);
561	}
562
563	(void)sv_bless(TOPs, stash);
564	RETURN;
565	}
566
567	PP(pp_gelem)
568	{
569	GV *gv;
570	SV *sv;
571	SV *tmpRef;
572	char *elem;
573	djSP;
574	STRLEN n_a;
575
576	sv = POPs;
577	elem = SvPV(sv, n_a);
578	gv = (GV*)POPs;
579	tmpRef = Nullsv;
580	sv = Nullsv;
581	switch (elem ? *elem : '\0')
582	{
583	case 'A':
584	if (strEQ(elem, "ARRAY"))
585	tmpRef = (SV*)GvAV(gv);
586	break;
587	case 'C':
588	if (strEQ(elem, "CODE"))
589	tmpRef = (SV*)GvCVu(gv);
590	break;
591	case 'F':
592	if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
593	tmpRef = (SV*)GvIOp(gv);
594	break;
595	case 'G':
596	if (strEQ(elem, "GLOB"))
597	tmpRef = (SV*)gv;
598	break;
599	case 'H':
600	if (strEQ(elem, "HASH"))
601	tmpRef = (SV*)GvHV(gv);
602	break;
603	case 'I':
604	if (strEQ(elem, "IO"))
605	tmpRef = (SV*)GvIOp(gv);
606	break;
607	case 'N':
608	if (strEQ(elem, "NAME"))
609	sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
610	break;
611	case 'P':
612	if (strEQ(elem, "PACKAGE"))
613	sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
614	break;
615	case 'S':
616	if (strEQ(elem, "SCALAR"))
617	tmpRef = GvSV(gv);
618	break;
619	}
620	if (tmpRef)
621	sv = newRV(tmpRef);
622	if (sv)
623	sv_2mortal(sv);
624	else
625	sv = &PL_sv_undef;
626	XPUSHs(sv);
627	RETURN;
628	}
629
630	/* Pattern matching */
631
632	PP(pp_study)
633	{
634	djSP; dPOPss;
635	register unsigned char *s;
636	register I32 pos;
637	register I32 ch;
638	register I32 *sfirst;
639	register I32 *snext;
640	STRLEN len;
641
642	if (sv == PL_lastscream) {
643	if (SvSCREAM(sv))
644	RETPUSHYES;
645	}
646	else {
647	if (PL_lastscream) {
648	SvSCREAM_off(PL_lastscream);
649	SvREFCNT_dec(PL_lastscream);
650	}
651	PL_lastscream = SvREFCNT_inc(sv);
652	}
653
654	s = (unsigned char*)(SvPV(sv, len));
655	pos = len;
656	if (pos <= 0)
657	RETPUSHNO;
658	if (pos > PL_maxscream) {
659	if (PL_maxscream < 0) {
660	PL_maxscream = pos + 80;
661	New(301, PL_screamfirst, 256, I32);
662	New(302, PL_screamnext, PL_maxscream, I32);
663	}
664	else {
665	PL_maxscream = pos + pos / 4;
666	Renew(PL_screamnext, PL_maxscream, I32);
667	}
668	}
669
670	sfirst = PL_screamfirst;
671	snext = PL_screamnext;
672
673	if (!sfirst \|\| !snext)
674	DIE(aTHX_ "do_study: out of memory");
675
676	for (ch = 256; ch; --ch)
677	*sfirst++ = -1;
678	sfirst -= 256;
679
680	while (--pos >= 0) {
681	ch = s[pos];
682	if (sfirst[ch] >= 0)
683	snext[pos] = sfirst[ch] - pos;
684	else
685	snext[pos] = -pos;
686	sfirst[ch] = pos;
687	}
688
689	SvSCREAM_on(sv);
690	sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
691	RETPUSHYES;
692	}
693
694	PP(pp_trans)
695	{
696	djSP; dTARG;
697	SV *sv;
698
699	if (PL_op->op_flags & OPf_STACKED)
700	sv = POPs;
701	else {
702	sv = DEFSV;
703	EXTEND(SP,1);
704	}
705	TARG = sv_newmortal();
706	PUSHi(do_trans(sv));
707	RETURN;
708	}
709
710	/* Lvalue operators. */
711
712	PP(pp_schop)
713	{
714	djSP; dTARGET;
715	do_chop(TARG, TOPs);
716	SETTARG;
717	RETURN;
718	}
719
720	PP(pp_chop)
721	{
722	djSP; dMARK; dTARGET;
723	while (SP > MARK)
724	do_chop(TARG, POPs);
725	PUSHTARG;
726	RETURN;
727	}
728
729	PP(pp_schomp)
730	{
731	djSP; dTARGET;
732	SETi(do_chomp(TOPs));
733	RETURN;
734	}
735
736	PP(pp_chomp)
737	{
738	djSP; dMARK; dTARGET;
739	register I32 count = 0;
740
741	while (SP > MARK)
742	count += do_chomp(POPs);
743	PUSHi(count);
744	RETURN;
745	}
746
747	PP(pp_defined)
748	{
749	djSP;
750	register SV* sv;
751
752	sv = POPs;
753	if (!sv \|\| !SvANY(sv))
754	RETPUSHNO;
755	switch (SvTYPE(sv)) {
756	case SVt_PVAV:
757	if (AvMAX(sv) >= 0 \|\| SvGMAGICAL(sv) \|\| (SvRMAGICAL(sv) && mg_find(sv,'P')))
758	RETPUSHYES;
759	break;
760	case SVt_PVHV:
761	if (HvARRAY(sv) \|\| SvGMAGICAL(sv) \|\| (SvRMAGICAL(sv) && mg_find(sv,'P')))
762	RETPUSHYES;
763	break;
764	case SVt_PVCV:
765	if (CvROOT(sv) \|\| CvXSUB(sv))
766	RETPUSHYES;
767	break;
768	default:
769	if (SvGMAGICAL(sv))
770	mg_get(sv);
771	if (SvOK(sv))
772	RETPUSHYES;
773	}
774	RETPUSHNO;
775	}
776
777	PP(pp_undef)
778	{
779	djSP;
780	SV *sv;
781
782	if (!PL_op->op_private) {
783	EXTEND(SP, 1);
784	RETPUSHUNDEF;
785	}
786
787	sv = POPs;
788	if (!sv)
789	RETPUSHUNDEF;
790
791	if (SvTHINKFIRST(sv))
792	sv_force_normal(sv);
793
794	switch (SvTYPE(sv)) {
795	case SVt_NULL:
796	break;
797	case SVt_PVAV:
798	av_undef((AV*)sv);
799	break;
800	case SVt_PVHV:
801	hv_undef((HV*)sv);
802	break;
803	case SVt_PVCV:
804	if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
805	Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
806	CvANON((CV)sv) ? "(anonymous)" : GvENAME(CvGV((CV)sv)));
807	/* FALL THROUGH */
808	case SVt_PVFM:
809	{
810	/* let user-undef'd sub keep its identity */
811	GV* gv = (GV)SvREFCNT_inc(CvGV((CV)sv));
812	cv_undef((CV*)sv);
813	CvGV((CV*)sv) = gv;
814	}
815	break;
816	case SVt_PVGV:
817	if (SvFAKE(sv))
818	SvSetMagicSV(sv, &PL_sv_undef);
819	else {
820	GP *gp;
821	gp_free((GV*)sv);
822	Newz(602, gp, 1, GP);
823	GvGP(sv) = gp_ref(gp);
824	GvSV(sv) = NEWSV(72,0);
825	GvLINE(sv) = CopLINE(PL_curcop);
826	GvEGV(sv) = (GV*)sv;
827	GvMULTI_on(sv);
828	}
829	break;
830	default:
831	if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
832	(void)SvOOK_off(sv);
833	Safefree(SvPVX(sv));
834	SvPV_set(sv, Nullch);
835	SvLEN_set(sv, 0);
836	}
837	(void)SvOK_off(sv);
838	SvSETMAGIC(sv);
839	}
840
841	RETPUSHUNDEF;
842	}
843
844	PP(pp_predec)
845	{
846	djSP;
847	if (SvREADONLY(TOPs) \|\| SvTYPE(TOPs) > SVt_PVLV)
848	DIE(aTHX_ PL_no_modify);
849	if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
850	SvIVX(TOPs) != IV_MIN)
851	{
852	--SvIVX(TOPs);
853	SvFLAGS(TOPs) &= ~(SVp_NOK\|SVp_POK);
854	}
855	else
856	sv_dec(TOPs);
857	SvSETMAGIC(TOPs);
858	return NORMAL;
859	}
860
861	PP(pp_postinc)
862	{
863	djSP; dTARGET;
864	if (SvREADONLY(TOPs) \|\| SvTYPE(TOPs) > SVt_PVLV)
865	DIE(aTHX_ PL_no_modify);
866	sv_setsv(TARG, TOPs);
867	if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
868	SvIVX(TOPs) != IV_MAX)
869	{
870	++SvIVX(TOPs);
871	SvFLAGS(TOPs) &= ~(SVp_NOK\|SVp_POK);
872	}
873	else
874	sv_inc(TOPs);
875	SvSETMAGIC(TOPs);
876	if (!SvOK(TARG))
877	sv_setiv(TARG, 0);
878	SETs(TARG);
879	return NORMAL;
880	}
881
882	PP(pp_postdec)
883	{
884	djSP; dTARGET;
885	if (SvREADONLY(TOPs) \|\| SvTYPE(TOPs) > SVt_PVLV)
886	DIE(aTHX_ PL_no_modify);
887	sv_setsv(TARG, TOPs);
888	if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
889	SvIVX(TOPs) != IV_MIN)
890	{
891	--SvIVX(TOPs);
892	SvFLAGS(TOPs) &= ~(SVp_NOK\|SVp_POK);
893	}
894	else
895	sv_dec(TOPs);
896	SvSETMAGIC(TOPs);
897	SETs(TARG);
898	return NORMAL;
899	}
900
901	/* Ordinary operators. */
902
903	PP(pp_pow)
904	{
905	djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
906	{
907	dPOPTOPnnrl;
908	SETn( Perl_pow( left, right) );
909	RETURN;
910	}
911	}
912
913	PP(pp_multiply)
914	{
915	djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
916	{
917	dPOPTOPnnrl;
918	SETn( left * right );
919	RETURN;
920	}
921	}
922
923	PP(pp_divide)
924	{
925	djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
926	{
927	dPOPPOPnnrl;
928	NV value;
929	if (right == 0.0)
930	DIE(aTHX_ "Illegal division by zero");
931	#ifdef SLOPPYDIVIDE
932	/* insure that 20./5. == 4. */
933	{
934	IV k;
935	if ((NV)I_V(left) == left &&
936	(NV)I_V(right) == right &&
937	(k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
938	value = k;
939	}
940	else {
941	value = left / right;
942	}
943	}
944	#else
945	value = left / right;
946	#endif
947	PUSHn( value );
948	RETURN;
949	}
950	}
951
952	PP(pp_modulo)
953	{
954	djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
955	{
956	UV left;
957	UV right;
958	bool left_neg;
959	bool right_neg;
960	bool use_double = 0;
961	NV dright;
962	NV dleft;
963
964	if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
965	IV i = SvIVX(POPs);
966	right = (right_neg = (i < 0)) ? -i : i;
967	}
968	else {
969	dright = POPn;
970	use_double = 1;
971	right_neg = dright < 0;
972	if (right_neg)
973	dright = -dright;
974	}
975
976	if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
977	IV i = SvIVX(POPs);
978	left = (left_neg = (i < 0)) ? -i : i;
979	}
980	else {
981	dleft = POPn;
982	if (!use_double) {
983	use_double = 1;
984	dright = right;
985	}
986	left_neg = dleft < 0;
987	if (left_neg)
988	dleft = -dleft;
989	}
990
991	if (use_double) {
992	NV dans;
993
994	#if 1
995	/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
996	# if CASTFLAGS & 2
997	# define CAST_D2UV(d) U_V(d)
998	# else
999	# define CAST_D2UV(d) ((UV)(d))
1000	# endif
1001	/* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1002	* or, in other words, precision of UV more than of NV.
1003	* But in fact the approach below turned out to be an
1004	* optimization - floor() may be slow */
1005	if (dright <= UV_MAX && dleft <= UV_MAX) {
1006	right = CAST_D2UV(dright);
1007	left = CAST_D2UV(dleft);
1008	goto do_uv;
1009	}
1010	#endif
1011
1012	/* Backward-compatibility clause: */
1013	dright = Perl_floor(dright + 0.5);
1014	dleft = Perl_floor(dleft + 0.5);
1015
1016	if (!dright)
1017	DIE(aTHX_ "Illegal modulus zero");
1018
1019	dans = Perl_fmod(dleft, dright);
1020	if ((left_neg != right_neg) && dans)
1021	dans = dright - dans;
1022	if (right_neg)
1023	dans = -dans;
1024	sv_setnv(TARG, dans);
1025	}
1026	else {
1027	UV ans;
1028
1029	do_uv:
1030	if (!right)
1031	DIE(aTHX_ "Illegal modulus zero");
1032
1033	ans = left % right;
1034	if ((left_neg != right_neg) && ans)
1035	ans = right - ans;
1036	if (right_neg) {
1037	/* XXX may warn: unary minus operator applied to unsigned type */
1038	/* could change -foo to be (~foo)+1 instead */
1039	if (ans <= ~((UV)IV_MAX)+1)
1040	sv_setiv(TARG, ~ans+1);
1041	else
1042	sv_setnv(TARG, -(NV)ans);
1043	}
1044	else
1045	sv_setuv(TARG, ans);
1046	}
1047	PUSHTARG;
1048	RETURN;
1049	}
1050	}
1051
1052	PP(pp_repeat)
1053	{
1054	djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1055	{
1056	register I32 count = POPi;
1057	if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1058	dMARK;
1059	I32 items = SP - MARK;
1060	I32 max;
1061
1062	max = items * count;
1063	MEXTEND(MARK, max);
1064	if (count > 1) {
1065	while (SP > MARK) {
1066	if (*SP)
1067	SvTEMP_off((*SP));
1068	SP--;
1069	}
1070	MARK++;
1071	repeatcpy((char)(MARK + items), (char)MARK,
1072	items * sizeof(SV*), count - 1);
1073	SP += max;
1074	}
1075	else if (count <= 0)
1076	SP -= items;
1077	}
1078	else { /* Note: mark already snarfed by pp_list */
1079	SV *tmpstr;
1080	STRLEN len;
1081
1082	tmpstr = POPs;
1083	SvSetSV(TARG, tmpstr);
1084	SvPV_force(TARG, len);
1085	if (count != 1) {
1086	if (count < 1)
1087	SvCUR_set(TARG, 0);
1088	else {
1089	SvGROW(TARG, (count * len) + 1);
1090	repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1091	SvCUR(TARG) *= count;
1092	}
1093	*SvEND(TARG) = '\0';
1094	}
1095	(void)SvPOK_only(TARG);
1096	PUSHTARG;
1097	}
1098	RETURN;
1099	}
1100	}
1101
1102	PP(pp_subtract)
1103	{
1104	djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1105	{
1106	dPOPTOPnnrl_ul;
1107	SETn( left - right );
1108	RETURN;
1109	}
1110	}
1111
1112	PP(pp_left_shift)
1113	{
1114	djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1115	{
1116	IV shift = POPi;
1117	if (PL_op->op_private & HINT_INTEGER) {
1118	IV i = TOPi;
1119	SETi(i << shift);
1120	}
1121	else {
1122	UV u = TOPu;
1123	SETu(u << shift);
1124	}
1125	RETURN;
1126	}
1127	}
1128
1129	PP(pp_right_shift)
1130	{
1131	djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1132	{
1133	IV shift = POPi;
1134	if (PL_op->op_private & HINT_INTEGER) {
1135	IV i = TOPi;
1136	SETi(i >> shift);
1137	}
1138	else {
1139	UV u = TOPu;
1140	SETu(u >> shift);
1141	}
1142	RETURN;
1143	}
1144	}
1145
1146	PP(pp_lt)
1147	{
1148	djSP; tryAMAGICbinSET(lt,0);
1149	{
1150	dPOPnv;
1151	SETs(boolSV(TOPn < value));
1152	RETURN;
1153	}
1154	}
1155
1156	PP(pp_gt)
1157	{
1158	djSP; tryAMAGICbinSET(gt,0);
1159	{
1160	dPOPnv;
1161	SETs(boolSV(TOPn > value));
1162	RETURN;
1163	}
1164	}
1165
1166	PP(pp_le)
1167	{
1168	djSP; tryAMAGICbinSET(le,0);
1169	{
1170	dPOPnv;
1171	SETs(boolSV(TOPn <= value));
1172	RETURN;
1173	}
1174	}
1175
1176	PP(pp_ge)
1177	{
1178	djSP; tryAMAGICbinSET(ge,0);
1179	{
1180	dPOPnv;
1181	SETs(boolSV(TOPn >= value));
1182	RETURN;
1183	}
1184	}
1185
1186	PP(pp_ne)
1187	{
1188	djSP; tryAMAGICbinSET(ne,0);
1189	{
1190	dPOPnv;
1191	SETs(boolSV(TOPn != value));
1192	RETURN;
1193	}
1194	}
1195
1196	PP(pp_ncmp)
1197	{
1198	djSP; dTARGET; tryAMAGICbin(ncmp,0);
1199	{
1200	dPOPTOPnnrl;
1201	I32 value;
1202	#ifdef __osf__ /* XXX Configure probe for isnan and isnanl needed XXX */
1203	#if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
1204	#define Perl_isnan isnanl
1205	#else
1206	#define Perl_isnan isnan
1207	#endif
1208	#endif
1209
1210	#ifdef __osf__ /* XXX fix in 5.6.1 --jhi */
1211	if (Perl_isnan(left) \|\| Perl_isnan(right)) {
1212	SETs(&PL_sv_undef);
1213	RETURN;
1214	}
1215	value = (left > right) - (left < right);
1216	#else
1217	if (left == right)
1218	value = 0;
1219	else if (left < right)
1220	value = -1;
1221	else if (left > right)
1222	value = 1;
1223	else {
1224	SETs(&PL_sv_undef);
1225	RETURN;
1226	}
1227	#endif
1228	SETi(value);
1229	RETURN;
1230	}
1231	}
1232
1233	PP(pp_slt)
1234	{
1235	djSP; tryAMAGICbinSET(slt,0);
1236	{
1237	dPOPTOPssrl;
1238	int cmp = ((PL_op->op_private & OPpLOCALE)
1239	? sv_cmp_locale(left, right)
1240	: sv_cmp(left, right));
1241	SETs(boolSV(cmp < 0));
1242	RETURN;
1243	}
1244	}
1245
1246	PP(pp_sgt)
1247	{
1248	djSP; tryAMAGICbinSET(sgt,0);
1249	{
1250	dPOPTOPssrl;
1251	int cmp = ((PL_op->op_private & OPpLOCALE)
1252	? sv_cmp_locale(left, right)
1253	: sv_cmp(left, right));
1254	SETs(boolSV(cmp > 0));
1255	RETURN;
1256	}
1257	}
1258
1259	PP(pp_sle)
1260	{
1261	djSP; tryAMAGICbinSET(sle,0);
1262	{
1263	dPOPTOPssrl;
1264	int cmp = ((PL_op->op_private & OPpLOCALE)
1265	? sv_cmp_locale(left, right)
1266	: sv_cmp(left, right));
1267	SETs(boolSV(cmp <= 0));
1268	RETURN;
1269	}
1270	}
1271
1272	PP(pp_sge)
1273	{
1274	djSP; tryAMAGICbinSET(sge,0);
1275	{
1276	dPOPTOPssrl;
1277	int cmp = ((PL_op->op_private & OPpLOCALE)
1278	? sv_cmp_locale(left, right)
1279	: sv_cmp(left, right));
1280	SETs(boolSV(cmp >= 0));
1281	RETURN;
1282	}
1283	}
1284
1285	PP(pp_seq)
1286	{
1287	djSP; tryAMAGICbinSET(seq,0);
1288	{
1289	dPOPTOPssrl;
1290	SETs(boolSV(sv_eq(left, right)));
1291	RETURN;
1292	}
1293	}
1294
1295	PP(pp_sne)
1296	{
1297	djSP; tryAMAGICbinSET(sne,0);
1298	{
1299	dPOPTOPssrl;
1300	SETs(boolSV(!sv_eq(left, right)));
1301	RETURN;
1302	}
1303	}
1304
1305	PP(pp_scmp)
1306	{
1307	djSP; dTARGET; tryAMAGICbin(scmp,0);
1308	{
1309	dPOPTOPssrl;
1310	int cmp = ((PL_op->op_private & OPpLOCALE)
1311	? sv_cmp_locale(left, right)
1312	: sv_cmp(left, right));
1313	SETi( cmp );
1314	RETURN;
1315	}
1316	}
1317
1318	PP(pp_bit_and)
1319	{
1320	djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1321	{
1322	dPOPTOPssrl;
1323	if (SvNIOKp(left) \|\| SvNIOKp(right)) {
1324	if (PL_op->op_private & HINT_INTEGER) {
1325	IV i = SvIV(left) & SvIV(right);
1326	SETi(i);
1327	}
1328	else {
1329	UV u = SvUV(left) & SvUV(right);
1330	SETu(u);
1331	}
1332	}
1333	else {
1334	do_vop(PL_op->op_type, TARG, left, right);
1335	SETTARG;
1336	}
1337	RETURN;
1338	}
1339	}
1340
1341	PP(pp_bit_xor)
1342	{
1343	djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1344	{
1345	dPOPTOPssrl;
1346	if (SvNIOKp(left) \|\| SvNIOKp(right)) {
1347	if (PL_op->op_private & HINT_INTEGER) {
1348	IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1349	SETi(i);
1350	}
1351	else {
1352	UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1353	SETu(u);
1354	}
1355	}
1356	else {
1357	do_vop(PL_op->op_type, TARG, left, right);
1358	SETTARG;
1359	}
1360	RETURN;
1361	}
1362	}
1363
1364	PP(pp_bit_or)
1365	{
1366	djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1367	{
1368	dPOPTOPssrl;
1369	if (SvNIOKp(left) \|\| SvNIOKp(right)) {
1370	if (PL_op->op_private & HINT_INTEGER) {
1371	IV i = (USE_LEFT(left) ? SvIV(left) : 0) \| SvIV(right);
1372	SETi(i);
1373	}
1374	else {
1375	UV u = (USE_LEFT(left) ? SvUV(left) : 0) \| SvUV(right);
1376	SETu(u);
1377	}
1378	}
1379	else {
1380	do_vop(PL_op->op_type, TARG, left, right);
1381	SETTARG;
1382	}
1383	RETURN;
1384	}
1385	}
1386
1387	PP(pp_negate)
1388	{
1389	djSP; dTARGET; tryAMAGICun(neg);
1390	{
1391	dTOPss;
1392	if (SvGMAGICAL(sv))
1393	mg_get(sv);
1394	if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1395	if (SvIsUV(sv)) {
1396	if (SvIVX(sv) == IV_MIN) {
1397	SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1398	RETURN;
1399	}
1400	else if (SvUVX(sv) <= IV_MAX) {
1401	SETi(-SvIVX(sv));
1402	RETURN;
1403	}
1404	}
1405	else if (SvIVX(sv) != IV_MIN) {
1406	SETi(-SvIVX(sv));
1407	RETURN;
1408	}
1409	}
1410	if (SvNIOKp(sv))
1411	SETn(-SvNV(sv));
1412	else if (SvPOKp(sv)) {
1413	STRLEN len;
1414	char *s = SvPV(sv, len);
1415	if (isIDFIRST(*s)) {
1416	sv_setpvn(TARG, "-", 1);
1417	sv_catsv(TARG, sv);
1418	}
1419	else if (s == '+' \|\| s == '-') {
1420	sv_setsv(TARG, sv);
1421	SvPV_force(TARG, len) = s == '-' ? '+' : '-';
1422	}
1423	else if (DO_UTF8(sv) && (U8)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1424	sv_setpvn(TARG, "-", 1);
1425	sv_catsv(TARG, sv);
1426	}
1427	else
1428	sv_setnv(TARG, -SvNV(sv));
1429	SETTARG;
1430	}
1431	else
1432	SETn(-SvNV(sv));
1433	}
1434	RETURN;
1435	}
1436
1437	PP(pp_not)
1438	{
1439	djSP; tryAMAGICunSET(not);
1440	PL_stack_sp = boolSV(!SvTRUE(PL_stack_sp));
1441	return NORMAL;
1442	}
1443
1444	PP(pp_complement)
1445	{
1446	djSP; dTARGET; tryAMAGICun(compl);
1447	{
1448	dTOPss;
1449	if (SvNIOKp(sv)) {
1450	if (PL_op->op_private & HINT_INTEGER) {
1451	IV i = ~SvIV(sv);
1452	SETi(i);
1453	}
1454	else {
1455	UV u = ~SvUV(sv);
1456	SETu(u);
1457	}
1458	}
1459	else {
1460	register char *tmps;
1461	register long *tmpl;
1462	register I32 anum;
1463	STRLEN len;
1464
1465	SvSetSV(TARG, sv);
1466	tmps = SvPV_force(TARG, len);
1467	anum = len;
1468	#ifdef LIBERAL
1469	for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1470	tmps = ~tmps;
1471	tmpl = (long*)tmps;
1472	for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1473	tmpl = ~tmpl;
1474	tmps = (char*)tmpl;
1475	#endif
1476	for ( ; anum > 0; anum--, tmps++)
1477	tmps = ~tmps;
1478
1479	SETs(TARG);
1480	}
1481	RETURN;
1482	}
1483	}
1484
1485	/* integer versions of some of the above */
1486
1487	PP(pp_i_multiply)
1488	{
1489	djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1490	{
1491	dPOPTOPiirl;
1492	SETi( left * right );
1493	RETURN;
1494	}
1495	}
1496
1497	PP(pp_i_divide)
1498	{
1499	djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1500	{
1501	dPOPiv;
1502	if (value == 0)
1503	DIE(aTHX_ "Illegal division by zero");
1504	value = POPi / value;
1505	PUSHi( value );
1506	RETURN;
1507	}
1508	}
1509
1510	PP(pp_i_modulo)
1511	{
1512	djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1513	{
1514	dPOPTOPiirl;
1515	if (!right)
1516	DIE(aTHX_ "Illegal modulus zero");
1517	SETi( left % right );
1518	RETURN;
1519	}
1520	}
1521
1522	PP(pp_i_add)
1523	{
1524	djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1525	{
1526	dPOPTOPiirl;
1527	SETi( left + right );
1528	RETURN;
1529	}
1530	}
1531
1532	PP(pp_i_subtract)
1533	{
1534	djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1535	{
1536	dPOPTOPiirl;
1537	SETi( left - right );
1538	RETURN;
1539	}
1540	}
1541
1542	PP(pp_i_lt)
1543	{
1544	djSP; tryAMAGICbinSET(lt,0);
1545	{
1546	dPOPTOPiirl;
1547	SETs(boolSV(left < right));
1548	RETURN;
1549	}
1550	}
1551
1552	PP(pp_i_gt)
1553	{
1554	djSP; tryAMAGICbinSET(gt,0);
1555	{
1556	dPOPTOPiirl;
1557	SETs(boolSV(left > right));
1558	RETURN;
1559	}
1560	}
1561
1562	PP(pp_i_le)
1563	{
1564	djSP; tryAMAGICbinSET(le,0);
1565	{
1566	dPOPTOPiirl;
1567	SETs(boolSV(left <= right));
1568	RETURN;
1569	}
1570	}
1571
1572	PP(pp_i_ge)
1573	{
1574	djSP; tryAMAGICbinSET(ge,0);
1575	{
1576	dPOPTOPiirl;
1577	SETs(boolSV(left >= right));
1578	RETURN;
1579	}
1580	}
1581
1582	PP(pp_i_eq)
1583	{
1584	djSP; tryAMAGICbinSET(eq,0);
1585	{
1586	dPOPTOPiirl;
1587	SETs(boolSV(left == right));
1588	RETURN;
1589	}
1590	}
1591
1592	PP(pp_i_ne)
1593	{
1594	djSP; tryAMAGICbinSET(ne,0);
1595	{
1596	dPOPTOPiirl;
1597	SETs(boolSV(left != right));
1598	RETURN;
1599	}
1600	}
1601
1602	PP(pp_i_ncmp)
1603	{
1604	djSP; dTARGET; tryAMAGICbin(ncmp,0);
1605	{
1606	dPOPTOPiirl;
1607	I32 value;
1608
1609	if (left > right)
1610	value = 1;
1611	else if (left < right)
1612	value = -1;
1613	else
1614	value = 0;
1615	SETi(value);
1616	RETURN;
1617	}
1618	}
1619
1620	PP(pp_i_negate)
1621	{
1622	djSP; dTARGET; tryAMAGICun(neg);
1623	SETi(-TOPi);
1624	RETURN;
1625	}
1626
1627	/* High falutin' math. */
1628
1629	PP(pp_atan2)
1630	{
1631	djSP; dTARGET; tryAMAGICbin(atan2,0);
1632	{
1633	dPOPTOPnnrl;
1634	SETn(Perl_atan2(left, right));
1635	RETURN;
1636	}
1637	}
1638
1639	PP(pp_sin)
1640	{
1641	djSP; dTARGET; tryAMAGICun(sin);
1642	{
1643	NV value;
1644	value = POPn;
1645	value = Perl_sin(value);
1646	XPUSHn(value);
1647	RETURN;
1648	}
1649	}
1650
1651	PP(pp_cos)
1652	{
1653	djSP; dTARGET; tryAMAGICun(cos);
1654	{
1655	NV value;
1656	value = POPn;
1657	value = Perl_cos(value);
1658	XPUSHn(value);
1659	RETURN;
1660	}
1661	}
1662
1663	/* Support Configure command-line overrides for rand() functions.
1664	After 5.005, perhaps we should replace this by Configure support
1665	for drand48(), random(), or rand(). For 5.005, though, maintain
1666	compatibility by calling rand() but allow the user to override it.
1667	See INSTALL for details. --Andy Dougherty 15 July 1998
1668	*/
1669	/* Now it's after 5.005, and Configure supports drand48() and random(),
1670	in addition to rand(). So the overrides should not be needed any more.
1671	--Jarkko Hietaniemi 27 September 1998
1672	*/
1673
1674	#ifndef HAS_DRAND48_PROTO
1675	extern double drand48 (void);
1676	#endif
1677
1678	PP(pp_rand)
1679	{
1680	djSP; dTARGET;
1681	NV value;
1682	if (MAXARG < 1)
1683	value = 1.0;
1684	else
1685	value = POPn;
1686	if (value == 0.0)
1687	value = 1.0;
1688	if (!PL_srand_called) {
1689	(void)seedDrand01((Rand_seed_t)seed());
1690	PL_srand_called = TRUE;
1691	}
1692	value *= Drand01();
1693	XPUSHn(value);
1694	RETURN;
1695	}
1696
1697	PP(pp_srand)
1698	{
1699	djSP;
1700	UV anum;
1701	if (MAXARG < 1)
1702	anum = seed();
1703	else
1704	anum = POPu;
1705	(void)seedDrand01((Rand_seed_t)anum);
1706	PL_srand_called = TRUE;
1707	EXTEND(SP, 1);
1708	RETPUSHYES;
1709	}
1710
1711	STATIC U32
1712	S_seed(pTHX)
1713	{
1714	/*
1715	* This is really just a quick hack which grabs various garbage
1716	* values. It really should be a real hash algorithm which
1717	* spreads the effect of every input bit onto every output bit,
1718	* if someone who knows about such things would bother to write it.
1719	* Might be a good idea to add that function to CORE as well.
1720	* No numbers below come from careful analysis or anything here,
1721	* except they are primes and SEED_C1 > 1E6 to get a full-width
1722	* value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1723	* probably be bigger too.
1724	*/
1725	#if RANDBITS > 16
1726	# define SEED_C1 1000003
1727	#define SEED_C4 73819
1728	#else
1729	# define SEED_C1 25747
1730	#define SEED_C4 20639
1731	#endif
1732	#define SEED_C2 3
1733	#define SEED_C3 269
1734	#define SEED_C5 26107
1735
1736	dTHR;
1737	#ifndef PERL_NO_DEV_RANDOM
1738	int fd;
1739	#endif
1740	U32 u;
1741	#ifdef VMS
1742	# include <starlet.h>
1743	/* when[] = (low 32 bits, high 32 bits) of time since epoch
1744	* in 100-ns units, typically incremented ever 10 ms. */
1745	unsigned int when[2];
1746	#else
1747	# ifdef HAS_GETTIMEOFDAY
1748	struct timeval when;
1749	# else
1750	Time_t when;
1751	# endif
1752	#endif
1753
1754	/* This test is an escape hatch, this symbol isn't set by Configure. */
1755	#ifndef PERL_NO_DEV_RANDOM
1756	#ifndef PERL_RANDOM_DEVICE
1757	/* /dev/random isn't used by default because reads from it will block
1758	* if there isn't enough entropy available. You can compile with
1759	* PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1760	* is enough real entropy to fill the seed. */
1761	# define PERL_RANDOM_DEVICE "/dev/urandom"
1762	#endif
1763	fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1764	if (fd != -1) {
1765	if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1766	u = 0;
1767	PerlLIO_close(fd);
1768	if (u)
1769	return u;
1770	}
1771	#endif
1772
1773	#ifdef VMS
1774	_ckvmssts(sys$gettim(when));
1775	u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1776	#else
1777	# ifdef HAS_GETTIMEOFDAY
1778	gettimeofday(&when,(struct timezone *) 0);
1779	u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1780	# else
1781	(void)time(&when);
1782	u = (U32)SEED_C1 * when;
1783	# endif
1784	#endif
1785	u += SEED_C3 * (U32)PerlProc_getpid();
1786	u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1787	#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1788	u += SEED_C5 * (U32)PTR2UV(&when);
1789	#endif
1790	return u;
1791	}
1792
1793	PP(pp_exp)
1794	{
1795	djSP; dTARGET; tryAMAGICun(exp);
1796	{
1797	NV value;
1798	value = POPn;
1799	value = Perl_exp(value);
1800	XPUSHn(value);
1801	RETURN;
1802	}
1803	}
1804
1805	PP(pp_log)
1806	{
1807	djSP; dTARGET; tryAMAGICun(log);
1808	{
1809	NV value;
1810	value = POPn;
1811	if (value <= 0.0) {
1812	RESTORE_NUMERIC_STANDARD();
1813	DIE(aTHX_ "Can't take log of %g", value);
1814	}
1815	value = Perl_log(value);
1816	XPUSHn(value);
1817	RETURN;
1818	}
1819	}
1820
1821	PP(pp_sqrt)
1822	{
1823	djSP; dTARGET; tryAMAGICun(sqrt);
1824	{
1825	NV value;
1826	value = POPn;
1827	if (value < 0.0) {
1828	RESTORE_NUMERIC_STANDARD();
1829	DIE(aTHX_ "Can't take sqrt of %g", value);
1830	}
1831	value = Perl_sqrt(value);
1832	XPUSHn(value);
1833	RETURN;
1834	}
1835	}
1836
1837	PP(pp_int)
1838	{
1839	djSP; dTARGET;
1840	{
1841	NV value = TOPn;
1842	IV iv;
1843
1844	if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1845	iv = SvIVX(TOPs);
1846	SETi(iv);
1847	}
1848	else {
1849	if (value >= 0.0)
1850	(void)Perl_modf(value, &value);
1851	else {
1852	(void)Perl_modf(-value, &value);
1853	value = -value;
1854	}
1855	iv = I_V(value);
1856	if (iv == value)
1857	SETi(iv);
1858	else
1859	SETn(value);
1860	}
1861	}
1862	RETURN;
1863	}
1864
1865	PP(pp_abs)
1866	{
1867	djSP; dTARGET; tryAMAGICun(abs);
1868	{
1869	NV value = TOPn;
1870	IV iv;
1871
1872	if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1873	(iv = SvIVX(TOPs)) != IV_MIN) {
1874	if (iv < 0)
1875	iv = -iv;
1876	SETi(iv);
1877	}
1878	else {
1879	if (value < 0.0)
1880	value = -value;
1881	SETn(value);
1882	}
1883	}
1884	RETURN;
1885	}
1886
1887	PP(pp_hex)
1888	{
1889	djSP; dTARGET;
1890	char *tmps;
1891	I32 argtype;
1892	STRLEN n_a;
1893
1894	tmps = POPpx;
1895	XPUSHn(scan_hex(tmps, 99, &argtype));
1896	RETURN;
1897	}
1898
1899	PP(pp_oct)
1900	{
1901	djSP; dTARGET;
1902	NV value;
1903	I32 argtype;
1904	char *tmps;
1905	STRLEN n_a;
1906
1907	tmps = POPpx;
1908	while (tmps && isSPACE(tmps))
1909	tmps++;
1910	if (*tmps == '0')
1911	tmps++;
1912	if (*tmps == 'x')
1913	value = scan_hex(++tmps, 99, &argtype);
1914	else if (*tmps == 'b')
1915	value = scan_bin(++tmps, 99, &argtype);
1916	else
1917	value = scan_oct(tmps, 99, &argtype);
1918	XPUSHn(value);
1919	RETURN;
1920	}
1921
1922	/* String stuff. */
1923
1924	PP(pp_length)
1925	{
1926	djSP; dTARGET;
1927	SV *sv = TOPs;
1928
1929	if (DO_UTF8(sv))
1930	SETi(sv_len_utf8(sv));
1931	else
1932	SETi(sv_len(sv));
1933	RETURN;
1934	}
1935
1936	PP(pp_substr)
1937	{
1938	djSP; dTARGET;
1939	SV *sv;
1940	I32 len;
1941	STRLEN curlen;
1942	STRLEN utfcurlen;
1943	I32 pos;
1944	I32 rem;
1945	I32 fail;
1946	I32 lvalue = PL_op->op_flags & OPf_MOD;
1947	char *tmps;
1948	I32 arybase = PL_curcop->cop_arybase;
1949	char *repl = 0;
1950	STRLEN repl_len;
1951
1952	SvTAINTED_off(TARG); /* decontaminate */
1953	SvUTF8_off(TARG); /* decontaminate */
1954	if (MAXARG > 2) {
1955	if (MAXARG > 3) {
1956	sv = POPs;
1957	repl = SvPV(sv, repl_len);
1958	}
1959	len = POPi;
1960	}
1961	pos = POPi;
1962	sv = POPs;
1963	PUTBACK;
1964	tmps = SvPV(sv, curlen);
1965	if (DO_UTF8(sv)) {
1966	utfcurlen = sv_len_utf8(sv);
1967	if (utfcurlen == curlen)
1968	utfcurlen = 0;
1969	else
1970	curlen = utfcurlen;
1971	}
1972	else
1973	utfcurlen = 0;
1974
1975	if (pos >= arybase) {
1976	pos -= arybase;
1977	rem = curlen-pos;
1978	fail = rem;
1979	if (MAXARG > 2) {
1980	if (len < 0) {
1981	rem += len;
1982	if (rem < 0)
1983	rem = 0;
1984	}
1985	else if (rem > len)
1986	rem = len;
1987	}
1988	}
1989	else {
1990	pos += curlen;
1991	if (MAXARG < 3)
1992	rem = curlen;
1993	else if (len >= 0) {
1994	rem = pos+len;
1995	if (rem > (I32)curlen)
1996	rem = curlen;
1997	}
1998	else {
1999	rem = curlen+len;
2000	if (rem < pos)
2001	rem = pos;
2002	}
2003	if (pos < 0)
2004	pos = 0;
2005	fail = rem;
2006	rem -= pos;
2007	}
2008	if (fail < 0) {
2009	if (lvalue \|\| repl)
2010	Perl_croak(aTHX_ "substr outside of string");
2011	if (ckWARN(WARN_SUBSTR))
2012	Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2013	RETPUSHUNDEF;
2014	}
2015	else {
2016	if (utfcurlen) {
2017	sv_pos_u2b(sv, &pos, &rem);
2018	SvUTF8_on(TARG);
2019	}
2020	tmps += pos;
2021	sv_setpvn(TARG, tmps, rem);
2022	if (repl)
2023	sv_insert(sv, pos, rem, repl, repl_len);
2024	else if (lvalue) { /* it's an lvalue! */
2025	if (!SvGMAGICAL(sv)) {
2026	if (SvROK(sv)) {
2027	STRLEN n_a;
2028	SvPV_force(sv,n_a);
2029	if (ckWARN(WARN_SUBSTR))
2030	Perl_warner(aTHX_ WARN_SUBSTR,
2031	"Attempt to use reference as lvalue in substr");
2032	}
2033	if (SvOK(sv)) /* is it defined ? */
2034	(void)SvPOK_only(sv);
2035	else
2036	sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2037	}
2038
2039	if (SvTYPE(TARG) < SVt_PVLV) {
2040	sv_upgrade(TARG, SVt_PVLV);
2041	sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2042	}
2043
2044	LvTYPE(TARG) = 'x';
2045	if (LvTARG(TARG) != sv) {
2046	if (LvTARG(TARG))
2047	SvREFCNT_dec(LvTARG(TARG));
2048	LvTARG(TARG) = SvREFCNT_inc(sv);
2049	}
2050	LvTARGOFF(TARG) = pos;
2051	LvTARGLEN(TARG) = rem;
2052	}
2053	}
2054	SPAGAIN;
2055	PUSHs(TARG); /* avoid SvSETMAGIC here */
2056	RETURN;
2057	}
2058
2059	PP(pp_vec)
2060	{
2061	djSP; dTARGET;
2062	register I32 size = POPi;
2063	register I32 offset = POPi;
2064	register SV *src = POPs;
2065	I32 lvalue = PL_op->op_flags & OPf_MOD;
2066
2067	SvTAINTED_off(TARG); /* decontaminate */
2068	if (lvalue) { /* it's an lvalue! */
2069	if (SvTYPE(TARG) < SVt_PVLV) {
2070	sv_upgrade(TARG, SVt_PVLV);
2071	sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2072	}
2073	LvTYPE(TARG) = 'v';
2074	if (LvTARG(TARG) != src) {
2075	if (LvTARG(TARG))
2076	SvREFCNT_dec(LvTARG(TARG));
2077	LvTARG(TARG) = SvREFCNT_inc(src);
2078	}
2079	LvTARGOFF(TARG) = offset;
2080	LvTARGLEN(TARG) = size;
2081	}
2082
2083	sv_setuv(TARG, do_vecget(src, offset, size));
2084	PUSHs(TARG);
2085	RETURN;
2086	}
2087
2088	PP(pp_index)
2089	{
2090	djSP; dTARGET;
2091	SV *big;
2092	SV *little;
2093	I32 offset;
2094	I32 retval;
2095	char *tmps;
2096	char *tmps2;
2097	STRLEN biglen;
2098	I32 arybase = PL_curcop->cop_arybase;
2099
2100	if (MAXARG < 3)
2101	offset = 0;
2102	else
2103	offset = POPi - arybase;
2104	little = POPs;
2105	big = POPs;
2106	tmps = SvPV(big, biglen);
2107	if (offset > 0 && DO_UTF8(big))
2108	sv_pos_u2b(big, &offset, 0);
2109	if (offset < 0)
2110	offset = 0;
2111	else if (offset > biglen)
2112	offset = biglen;
2113	if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2114	(unsigned char*)tmps + biglen, little, 0)))
2115	retval = -1;
2116	else
2117	retval = tmps2 - tmps;
2118	if (retval > 0 && DO_UTF8(big))
2119	sv_pos_b2u(big, &retval);
2120	PUSHi(retval + arybase);
2121	RETURN;
2122	}
2123
2124	PP(pp_rindex)
2125	{
2126	djSP; dTARGET;
2127	SV *big;
2128	SV *little;
2129	STRLEN blen;
2130	STRLEN llen;
2131	I32 offset;
2132	I32 retval;
2133	char *tmps;
2134	char *tmps2;
2135	I32 arybase = PL_curcop->cop_arybase;
2136
2137	if (MAXARG >= 3)
2138	offset = POPi;
2139	little = POPs;
2140	big = POPs;
2141	tmps2 = SvPV(little, llen);
2142	tmps = SvPV(big, blen);
2143	if (MAXARG < 3)
2144	offset = blen;
2145	else {
2146	if (offset > 0 && DO_UTF8(big))
2147	sv_pos_u2b(big, &offset, 0);
2148	offset = offset - arybase + llen;
2149	}
2150	if (offset < 0)
2151	offset = 0;
2152	else if (offset > blen)
2153	offset = blen;
2154	if (!(tmps2 = rninstr(tmps, tmps + offset,
2155	tmps2, tmps2 + llen)))
2156	retval = -1;
2157	else
2158	retval = tmps2 - tmps;
2159	if (retval > 0 && DO_UTF8(big))
2160	sv_pos_b2u(big, &retval);
2161	PUSHi(retval + arybase);
2162	RETURN;
2163	}
2164
2165	PP(pp_sprintf)
2166	{
2167	djSP; dMARK; dORIGMARK; dTARGET;
2168	do_sprintf(TARG, SP-MARK, MARK+1);
2169	TAINT_IF(SvTAINTED(TARG));
2170	SP = ORIGMARK;
2171	PUSHTARG;
2172	RETURN;
2173	}
2174
2175	PP(pp_ord)
2176	{
2177	djSP; dTARGET;
2178	UV value;
2179	STRLEN n_a;
2180	SV *tmpsv = POPs;
2181	U8 tmps = (U8)SvPVx(tmpsv,n_a);
2182	I32 retlen;
2183
2184	if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2185	value = utf8_to_uv(tmps, &retlen);
2186	else
2187	value = (UV)(*tmps & 255);
2188	XPUSHu(value);
2189	RETURN;
2190	}
2191
2192	PP(pp_chr)
2193	{
2194	djSP; dTARGET;
2195	char *tmps;
2196	U32 value = POPu;
2197
2198	(void)SvUPGRADE(TARG,SVt_PV);
2199
2200	if (value > 255 && !IN_BYTE) {
2201	SvGROW(TARG, UTF8_MAXLEN+1);
2202	tmps = SvPVX(TARG);
2203	tmps = (char)uv_to_utf8((U8)tmps, (UV)value);
2204	SvCUR_set(TARG, tmps - SvPVX(TARG));
2205	*tmps = '\0';
2206	(void)SvPOK_only(TARG);
2207	SvUTF8_on(TARG);
2208	XPUSHs(TARG);
2209	RETURN;
2210	}
2211
2212	SvGROW(TARG,2);
2213	SvCUR_set(TARG, 1);
2214	tmps = SvPVX(TARG);
2215	*tmps++ = value;
2216	*tmps = '\0';
2217	SvUTF8_off(TARG); /* decontaminate */
2218	(void)SvPOK_only(TARG);
2219	XPUSHs(TARG);
2220	RETURN;
2221	}
2222
2223	PP(pp_crypt)
2224	{
2225	djSP; dTARGET; dPOPTOPssrl;
2226	STRLEN n_a;
2227	#ifdef HAS_CRYPT
2228	char *tmps = SvPV(left, n_a);
2229	#ifdef FCRYPT
2230	sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2231	#else
2232	sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2233	#endif
2234	#else
2235	DIE(aTHX_
2236	"The crypt() function is unimplemented due to excessive paranoia.");
2237	#endif
2238	SETs(TARG);
2239	RETURN;
2240	}
2241
2242	PP(pp_ucfirst)
2243	{
2244	djSP;
2245	SV *sv = TOPs;
2246	register U8 *s;
2247	STRLEN slen;
2248
2249	if (DO_UTF8(sv) && (s = (U8)SvPV(sv, slen)) && slen && (s & 0xc0) == 0xc0) {
2250	I32 ulen;
2251	U8 tmpbuf[UTF8_MAXLEN];
2252	U8 *tend;
2253	UV uv = utf8_to_uv(s, &ulen);
2254
2255	if (PL_op->op_private & OPpLOCALE) {
2256	TAINT;
2257	SvTAINTED_on(sv);
2258	uv = toTITLE_LC_uni(uv);
2259	}
2260	else
2261	uv = toTITLE_utf8(s);
2262
2263	tend = uv_to_utf8(tmpbuf, uv);
2264
2265	if (!SvPADTMP(sv) \|\| tend - tmpbuf != ulen \|\| SvREADONLY(sv)) {
2266	dTARGET;
2267	sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2268	sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2269	SvUTF8_on(TARG);
2270	SETs(TARG);
2271	}
2272	else {
2273	s = (U8*)SvPV_force(sv, slen);
2274	Copy(tmpbuf, s, ulen, U8);
2275	}
2276	}
2277	else {
2278	if (!SvPADTMP(sv) \|\| SvREADONLY(sv)) {
2279	dTARGET;
2280	SvUTF8_off(TARG); /* decontaminate */
2281	sv_setsv(TARG, sv);
2282	sv = TARG;
2283	SETs(sv);
2284	}
2285	s = (U8*)SvPV_force(sv, slen);
2286	if (*s) {
2287	if (PL_op->op_private & OPpLOCALE) {
2288	TAINT;
2289	SvTAINTED_on(sv);
2290	s = toUPPER_LC(s);
2291	}
2292	else
2293	s = toUPPER(s);
2294	}
2295	}
2296	if (SvSMAGICAL(sv))
2297	mg_set(sv);
2298	RETURN;
2299	}
2300
2301	PP(pp_lcfirst)
2302	{
2303	djSP;
2304	SV *sv = TOPs;
2305	register U8 *s;
2306	STRLEN slen;
2307
2308	if (DO_UTF8(sv) && (s = (U8)SvPV(sv, slen)) && slen && (s & 0xc0) == 0xc0) {
2309	I32 ulen;
2310	U8 tmpbuf[UTF8_MAXLEN];
2311	U8 *tend;
2312	UV uv = utf8_to_uv(s, &ulen);
2313
2314	if (PL_op->op_private & OPpLOCALE) {
2315	TAINT;
2316	SvTAINTED_on(sv);
2317	uv = toLOWER_LC_uni(uv);
2318	}
2319	else
2320	uv = toLOWER_utf8(s);
2321
2322	tend = uv_to_utf8(tmpbuf, uv);
2323
2324	if (!SvPADTMP(sv) \|\| tend - tmpbuf != ulen \|\| SvREADONLY(sv)) {
2325	dTARGET;
2326	sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2327	sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2328	SvUTF8_on(TARG);
2329	SETs(TARG);
2330	}
2331	else {
2332	s = (U8*)SvPV_force(sv, slen);
2333	Copy(tmpbuf, s, ulen, U8);
2334	}
2335	}
2336	else {
2337	if (!SvPADTMP(sv) \|\| SvREADONLY(sv)) {
2338	dTARGET;
2339	SvUTF8_off(TARG); /* decontaminate */
2340	sv_setsv(TARG, sv);
2341	sv = TARG;
2342	SETs(sv);
2343	}
2344	s = (U8*)SvPV_force(sv, slen);
2345	if (*s) {
2346	if (PL_op->op_private & OPpLOCALE) {
2347	TAINT;
2348	SvTAINTED_on(sv);
2349	s = toLOWER_LC(s);
2350	}
2351	else
2352	s = toLOWER(s);
2353	}
2354	}
2355	if (SvSMAGICAL(sv))
2356	mg_set(sv);
2357	RETURN;
2358	}
2359
2360	PP(pp_uc)
2361	{
2362	djSP;
2363	SV *sv = TOPs;
2364	register U8 *s;
2365	STRLEN len;
2366
2367	if (DO_UTF8(sv)) {
2368	dTARGET;
2369	I32 ulen;
2370	register U8 *d;
2371	U8 *send;
2372
2373	s = (U8*)SvPV(sv,len);
2374	if (!len) {
2375	SvUTF8_off(TARG); /* decontaminate */
2376	sv_setpvn(TARG, "", 0);
2377	SETs(TARG);
2378	}
2379	else {
2380	(void)SvUPGRADE(TARG, SVt_PV);
2381	SvGROW(TARG, (len * 2) + 1);
2382	(void)SvPOK_only(TARG);
2383	d = (U8*)SvPVX(TARG);
2384	send = s + len;
2385	if (PL_op->op_private & OPpLOCALE) {
2386	TAINT;
2387	SvTAINTED_on(TARG);
2388	while (s < send) {
2389	d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2390	s += ulen;
2391	}
2392	}
2393	else {
2394	while (s < send) {
2395	d = uv_to_utf8(d, toUPPER_utf8( s ));
2396	s += UTF8SKIP(s);
2397	}
2398	}
2399	*d = '\0';
2400	SvUTF8_on(TARG);
2401	SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2402	SETs(TARG);
2403	}
2404	}
2405	else {
2406	if (!SvPADTMP(sv) \|\| SvREADONLY(sv)) {
2407	dTARGET;
2408	SvUTF8_off(TARG); /* decontaminate */
2409	sv_setsv(TARG, sv);
2410	sv = TARG;
2411	SETs(sv);
2412	}
2413	s = (U8*)SvPV_force(sv, len);
2414	if (len) {
2415	register U8 *send = s + len;
2416
2417	if (PL_op->op_private & OPpLOCALE) {
2418	TAINT;
2419	SvTAINTED_on(sv);
2420	for (; s < send; s++)
2421	s = toUPPER_LC(s);
2422	}
2423	else {
2424	for (; s < send; s++)
2425	s = toUPPER(s);
2426	}
2427	}
2428	}
2429	if (SvSMAGICAL(sv))
2430	mg_set(sv);
2431	RETURN;
2432	}
2433
2434	PP(pp_lc)
2435	{
2436	djSP;
2437	SV *sv = TOPs;
2438	register U8 *s;
2439	STRLEN len;
2440
2441	if (DO_UTF8(sv)) {
2442	dTARGET;
2443	I32 ulen;
2444	register U8 *d;
2445	U8 *send;
2446
2447	s = (U8*)SvPV(sv,len);
2448	if (!len) {
2449	SvUTF8_off(TARG); /* decontaminate */
2450	sv_setpvn(TARG, "", 0);
2451	SETs(TARG);
2452	}
2453	else {
2454	(void)SvUPGRADE(TARG, SVt_PV);
2455	SvGROW(TARG, (len * 2) + 1);
2456	(void)SvPOK_only(TARG);
2457	d = (U8*)SvPVX(TARG);
2458	send = s + len;
2459	if (PL_op->op_private & OPpLOCALE) {
2460	TAINT;
2461	SvTAINTED_on(TARG);
2462	while (s < send) {
2463	d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2464	s += ulen;
2465	}
2466	}
2467	else {
2468	while (s < send) {
2469	d = uv_to_utf8(d, toLOWER_utf8(s));
2470	s += UTF8SKIP(s);
2471	}
2472	}
2473	*d = '\0';
2474	SvUTF8_on(TARG);
2475	SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2476	SETs(TARG);
2477	}
2478	}
2479	else {
2480	if (!SvPADTMP(sv) \|\| SvREADONLY(sv)) {
2481	dTARGET;
2482	SvUTF8_off(TARG); /* decontaminate */
2483	sv_setsv(TARG, sv);
2484	sv = TARG;
2485	SETs(sv);
2486	}
2487
2488	s = (U8*)SvPV_force(sv, len);
2489	if (len) {
2490	register U8 *send = s + len;
2491
2492	if (PL_op->op_private & OPpLOCALE) {
2493	TAINT;
2494	SvTAINTED_on(sv);
2495	for (; s < send; s++)
2496	s = toLOWER_LC(s);
2497	}
2498	else {
2499	for (; s < send; s++)
2500	s = toLOWER(s);
2501	}
2502	}
2503	}
2504	if (SvSMAGICAL(sv))
2505	mg_set(sv);
2506	RETURN;
2507	}
2508
2509	PP(pp_quotemeta)
2510	{
2511	djSP; dTARGET;
2512	SV *sv = TOPs;
2513	STRLEN len;
2514	register char *s = SvPV(sv,len);
2515	register char *d;
2516
2517	SvUTF8_off(TARG); /* decontaminate */
2518	if (len) {
2519	(void)SvUPGRADE(TARG, SVt_PV);
2520	SvGROW(TARG, (len * 2) + 1);
2521	d = SvPVX(TARG);
2522	if (DO_UTF8(sv)) {
2523	while (len) {
2524	if (*s & 0x80) {
2525	STRLEN ulen = UTF8SKIP(s);
2526	if (ulen > len)
2527	ulen = len;
2528	len -= ulen;
2529	while (ulen--)
2530	d++ = s++;
2531	}
2532	else {
2533	if (!isALNUM(*s))
2534	*d++ = '\\';
2535	d++ = s++;
2536	len--;
2537	}
2538	}
2539	SvUTF8_on(TARG);
2540	}
2541	else {
2542	while (len--) {
2543	if (!isALNUM(*s))
2544	*d++ = '\\';
2545	d++ = s++;
2546	}
2547	}
2548	*d = '\0';
2549	SvCUR_set(TARG, d - SvPVX(TARG));
2550	(void)SvPOK_only(TARG);
2551	}
2552	else
2553	sv_setpvn(TARG, s, len);
2554	SETs(TARG);
2555	if (SvSMAGICAL(TARG))
2556	mg_set(TARG);
2557	RETURN;
2558	}
2559
2560	/* Arrays. */
2561
2562	PP(pp_aslice)
2563	{
2564	djSP; dMARK; dORIGMARK;
2565	register SV** svp;
2566	register AV* av = (AV*)POPs;
2567	register I32 lval = PL_op->op_flags & OPf_MOD;
2568	I32 arybase = PL_curcop->cop_arybase;
2569	I32 elem;
2570
2571	if (SvTYPE(av) == SVt_PVAV) {
2572	if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2573	I32 max = -1;
2574	for (svp = MARK + 1; svp <= SP; svp++) {
2575	elem = SvIVx(*svp);
2576	if (elem > max)
2577	max = elem;
2578	}
2579	if (max > AvMAX(av))
2580	av_extend(av, max);
2581	}
2582	while (++MARK <= SP) {
2583	elem = SvIVx(*MARK);
2584
2585	if (elem > 0)
2586	elem -= arybase;
2587	svp = av_fetch(av, elem, lval);
2588	if (lval) {
2589	if (!svp \|\| *svp == &PL_sv_undef)
2590	DIE(aTHX_ PL_no_aelem, elem);
2591	if (PL_op->op_private & OPpLVAL_INTRO)
2592	save_aelem(av, elem, svp);
2593	}
2594	MARK = svp ? svp : &PL_sv_undef;
2595	}
2596	}
2597	if (GIMME != G_ARRAY) {
2598	MARK = ORIGMARK;
2599	++MARK = SP;
2600	SP = MARK;
2601	}
2602	RETURN;
2603	}
2604
2605	/* Associative arrays. */
2606
2607	PP(pp_each)
2608	{
2609	djSP;
2610	HV hash = (HV)POPs;
2611	HE *entry;
2612	I32 gimme = GIMME_V;
2613	I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2614
2615	PUTBACK;
2616	/* might clobber stack_sp */
2617	entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2618	SPAGAIN;
2619
2620	EXTEND(SP, 2);
2621	if (entry) {
2622	PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2623	if (gimme == G_ARRAY) {
2624	SV *val;
2625	PUTBACK;
2626	/* might clobber stack_sp */
2627	val = realhv ?
2628	hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2629	SPAGAIN;
2630	PUSHs(val);
2631	}
2632	}
2633	else if (gimme == G_SCALAR)
2634	RETPUSHUNDEF;
2635
2636	RETURN;
2637	}
2638
2639	PP(pp_values)
2640	{
2641	return do_kv();
2642	}
2643
2644	PP(pp_keys)
2645	{
2646	return do_kv();
2647	}
2648
2649	PP(pp_delete)
2650	{
2651	djSP;
2652	I32 gimme = GIMME_V;
2653	I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2654	SV *sv;
2655	HV *hv;
2656
2657	if (PL_op->op_private & OPpSLICE) {
2658	dMARK; dORIGMARK;
2659	U32 hvtype;
2660	hv = (HV*)POPs;
2661	hvtype = SvTYPE(hv);
2662	if (hvtype == SVt_PVHV) { /* hash element */
2663	while (++MARK <= SP) {
2664	sv = hv_delete_ent(hv, *MARK, discard, 0);
2665	*MARK = sv ? sv : &PL_sv_undef;
2666	}
2667	}
2668	else if (hvtype == SVt_PVAV) {
2669	if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2670	while (++MARK <= SP) {
2671	sv = av_delete((AV)hv, SvIV(MARK), discard);
2672	*MARK = sv ? sv : &PL_sv_undef;
2673	}
2674	}
2675	else { /* pseudo-hash element */
2676	while (++MARK <= SP) {
2677	sv = avhv_delete_ent((AV)hv, MARK, discard, 0);
2678	*MARK = sv ? sv : &PL_sv_undef;
2679	}
2680	}
2681	}
2682	else
2683	DIE(aTHX_ "Not a HASH reference");
2684	if (discard)
2685	SP = ORIGMARK;
2686	else if (gimme == G_SCALAR) {
2687	MARK = ORIGMARK;
2688	++MARK = SP;
2689	SP = MARK;
2690	}
2691	}
2692	else {
2693	SV *keysv = POPs;
2694	hv = (HV*)POPs;
2695	if (SvTYPE(hv) == SVt_PVHV)
2696	sv = hv_delete_ent(hv, keysv, discard, 0);
2697	else if (SvTYPE(hv) == SVt_PVAV) {
2698	if (PL_op->op_flags & OPf_SPECIAL)
2699	sv = av_delete((AV*)hv, SvIV(keysv), discard);
2700	else
2701	sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2702	}
2703	else
2704	DIE(aTHX_ "Not a HASH reference");
2705	if (!sv)
2706	sv = &PL_sv_undef;
2707	if (!discard)
2708	PUSHs(sv);
2709	}
2710	RETURN;
2711	}
2712
2713	PP(pp_exists)
2714	{
2715	djSP;
2716	SV *tmpsv;
2717	HV *hv;
2718
2719	if (PL_op->op_private & OPpEXISTS_SUB) {
2720	GV *gv;
2721	CV *cv;
2722	SV *sv = POPs;
2723	cv = sv_2cv(sv, &hv, &gv, FALSE);
2724	if (cv)
2725	RETPUSHYES;
2726	if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2727	RETPUSHYES;
2728	RETPUSHNO;
2729	}
2730	tmpsv = POPs;
2731	hv = (HV*)POPs;
2732	if (SvTYPE(hv) == SVt_PVHV) {
2733	if (hv_exists_ent(hv, tmpsv, 0))
2734	RETPUSHYES;
2735	}
2736	else if (SvTYPE(hv) == SVt_PVAV) {
2737	if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2738	if (av_exists((AV*)hv, SvIV(tmpsv)))
2739	RETPUSHYES;
2740	}
2741	else if (avhv_exists_ent((AV)hv, tmpsv, 0)) / pseudo-hash element */
2742	RETPUSHYES;
2743	}
2744	else {
2745	DIE(aTHX_ "Not a HASH reference");
2746	}
2747	RETPUSHNO;
2748	}
2749
2750	PP(pp_hslice)
2751	{
2752	djSP; dMARK; dORIGMARK;
2753	register HV hv = (HV)POPs;
2754	register I32 lval = PL_op->op_flags & OPf_MOD;
2755	I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2756
2757	if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2758	DIE(aTHX_ "Can't localize pseudo-hash element");
2759
2760	if (realhv \|\| SvTYPE(hv) == SVt_PVAV) {
2761	while (++MARK <= SP) {
2762	SV keysv = MARK;
2763	SV **svp;
2764	if (realhv) {
2765	HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2766	svp = he ? &HeVAL(he) : 0;
2767	}
2768	else {
2769	svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2770	}
2771	if (lval) {
2772	if (!svp \|\| *svp == &PL_sv_undef) {
2773	STRLEN n_a;
2774	DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2775	}
2776	if (PL_op->op_private & OPpLVAL_INTRO)
2777	save_helem(hv, keysv, svp);
2778	}
2779	MARK = svp ? svp : &PL_sv_undef;
2780	}
2781	}
2782	if (GIMME != G_ARRAY) {
2783	MARK = ORIGMARK;
2784	++MARK = SP;
2785	SP = MARK;
2786	}
2787	RETURN;
2788	}
2789
2790	/* List operators. */
2791
2792	PP(pp_list)
2793	{
2794	djSP; dMARK;
2795	if (GIMME != G_ARRAY) {
2796	if (++MARK <= SP)
2797	MARK = SP; /* unwanted list, return last item */
2798	else
2799	*MARK = &PL_sv_undef;
2800	SP = MARK;
2801	}
2802	RETURN;
2803	}
2804
2805	PP(pp_lslice)
2806	{
2807	djSP;
2808	SV **lastrelem = PL_stack_sp;
2809	SV **lastlelem = PL_stack_base + POPMARK;
2810	SV **firstlelem = PL_stack_base + POPMARK + 1;
2811	register SV **firstrelem = lastlelem + 1;
2812	I32 arybase = PL_curcop->cop_arybase;
2813	I32 lval = PL_op->op_flags & OPf_MOD;
2814	I32 is_something_there = lval;
2815
2816	register I32 max = lastrelem - lastlelem;
2817	register SV **lelem;
2818	register I32 ix;
2819
2820	if (GIMME != G_ARRAY) {
2821	ix = SvIVx(*lastlelem);
2822	if (ix < 0)
2823	ix += max;
2824	else
2825	ix -= arybase;
2826	if (ix < 0 \|\| ix >= max)
2827	*firstlelem = &PL_sv_undef;
2828	else
2829	*firstlelem = firstrelem[ix];
2830	SP = firstlelem;
2831	RETURN;
2832	}
2833
2834	if (max == 0) {
2835	SP = firstlelem - 1;
2836	RETURN;
2837	}
2838
2839	for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2840	ix = SvIVx(*lelem);
2841	if (ix < 0)
2842	ix += max;
2843	else
2844	ix -= arybase;
2845	if (ix < 0 \|\| ix >= max)
2846	*lelem = &PL_sv_undef;
2847	else {
2848	is_something_there = TRUE;
2849	if (!(*lelem = firstrelem[ix]))
2850	*lelem = &PL_sv_undef;
2851	}
2852	}
2853	if (is_something_there)
2854	SP = lastlelem;
2855	else
2856	SP = firstlelem - 1;
2857	RETURN;
2858	}
2859
2860	PP(pp_anonlist)
2861	{
2862	djSP; dMARK; dORIGMARK;
2863	I32 items = SP - MARK;
2864	SV av = sv_2mortal((SV)av_make(items, MARK+1));
2865	SP = ORIGMARK; /* av_make() might realloc stack_sp */
2866	XPUSHs(av);
2867	RETURN;
2868	}
2869
2870	PP(pp_anonhash)
2871	{
2872	djSP; dMARK; dORIGMARK;
2873	HV* hv = (HV)sv_2mortal((SV)newHV());
2874
2875	while (MARK < SP) {
2876	SV* key = *++MARK;
2877	SV *val = NEWSV(46, 0);
2878	if (MARK < SP)
2879	sv_setsv(val, *++MARK);
2880	else if (ckWARN(WARN_MISC))
2881	Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2882	(void)hv_store_ent(hv,key,val,0);
2883	}
2884	SP = ORIGMARK;
2885	XPUSHs((SV*)hv);
2886	RETURN;
2887	}
2888
2889	PP(pp_splice)
2890	{
2891	djSP; dMARK; dORIGMARK;
2892	register AV ary = (AV)*++MARK;
2893	register SV **src;
2894	register SV **dst;
2895	register I32 i;
2896	register I32 offset;
2897	register I32 length;
2898	I32 newlen;
2899	I32 after;
2900	I32 diff;
2901	SV **tmparyval = 0;
2902	MAGIC *mg;
2903
2904	if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2905	MARK-- = SvTIED_obj((SV)ary, mg);
2906	PUSHMARK(MARK);
2907	PUTBACK;
2908	ENTER;
2909	call_method("SPLICE",GIMME_V);
2910	LEAVE;
2911	SPAGAIN;
2912	RETURN;
2913	}
2914
2915	SP++;
2916
2917	if (++MARK < SP) {
2918	offset = i = SvIVx(*MARK);
2919	if (offset < 0)
2920	offset += AvFILLp(ary) + 1;
2921	else
2922	offset -= PL_curcop->cop_arybase;
2923	if (offset < 0)
2924	DIE(aTHX_ PL_no_aelem, i);
2925	if (++MARK < SP) {
2926	length = SvIVx(*MARK++);
2927	if (length < 0) {
2928	length += AvFILLp(ary) - offset + 1;
2929	if (length < 0)
2930	length = 0;
2931	}
2932	}
2933	else
2934	length = AvMAX(ary) + 1; /* close enough to infinity */
2935	}
2936	else {
2937	offset = 0;
2938	length = AvMAX(ary) + 1;
2939	}
2940	if (offset > AvFILLp(ary) + 1)
2941	offset = AvFILLp(ary) + 1;
2942	after = AvFILLp(ary) + 1 - (offset + length);
2943	if (after < 0) { /* not that much array */
2944	length += after; /* offset+length now in array */
2945	after = 0;
2946	if (!AvALLOC(ary))
2947	av_extend(ary, 0);
2948	}
2949
2950	/* At this point, MARK .. SP-1 is our new LIST */
2951
2952	newlen = SP - MARK;
2953	diff = newlen - length;
2954	if (newlen && !AvREAL(ary) && AvREIFY(ary))
2955	av_reify(ary);
2956
2957	if (diff < 0) { /* shrinking the area */
2958	if (newlen) {
2959	New(451, tmparyval, newlen, SV); / so remember insertion */
2960	Copy(MARK, tmparyval, newlen, SV*);
2961	}
2962
2963	MARK = ORIGMARK + 1;
2964	if (GIMME == G_ARRAY) { /* copy return vals to stack */
2965	MEXTEND(MARK, length);
2966	Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2967	if (AvREAL(ary)) {
2968	EXTEND_MORTAL(length);
2969	for (i = length, dst = MARK; i; i--) {
2970	sv_2mortal(dst); / free them eventualy */
2971	dst++;
2972	}
2973	}
2974	MARK += length - 1;
2975	}
2976	else {
2977	*MARK = AvARRAY(ary)[offset+length-1];
2978	if (AvREAL(ary)) {
2979	sv_2mortal(*MARK);
2980	for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2981	SvREFCNT_dec(dst++); / free them now */
2982	}
2983	}
2984	AvFILLp(ary) += diff;
2985
2986	/* pull up or down? */
2987
2988	if (offset < after) { /* easier to pull up */
2989	if (offset) { /* esp. if nothing to pull */
2990	src = &AvARRAY(ary)[offset-1];
2991	dst = src - diff; /* diff is negative */
2992	for (i = offset; i > 0; i--) /* can't trust Copy */
2993	dst-- = src--;
2994	}
2995	dst = AvARRAY(ary);
2996	SvPVX(ary) = (char)(AvARRAY(ary) - diff); / diff is negative */
2997	AvMAX(ary) += diff;
2998	}
2999	else {
3000	if (after) { /* anything to pull down? */
3001	src = AvARRAY(ary) + offset + length;
3002	dst = src + diff; /* diff is negative */
3003	Move(src, dst, after, SV*);
3004	}
3005	dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3006	/* avoid later double free */
3007	}
3008	i = -diff;
3009	while (i)
3010	dst[--i] = &PL_sv_undef;
3011
3012	if (newlen) {
3013	for (src = tmparyval, dst = AvARRAY(ary) + offset;
3014	newlen; newlen--) {
3015	*dst = NEWSV(46, 0);
3016	sv_setsv(dst++, src++);
3017	}
3018	Safefree(tmparyval);
3019	}
3020	}
3021	else { /* no, expanding (or same) */
3022	if (length) {
3023	New(452, tmparyval, length, SV); / so remember deletion */
3024	Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3025	}
3026
3027	if (diff > 0) { /* expanding */
3028
3029	/* push up or down? */
3030
3031	if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3032	if (offset) {
3033	src = AvARRAY(ary);
3034	dst = src - diff;
3035	Move(src, dst, offset, SV*);
3036	}
3037	SvPVX(ary) = (char)(AvARRAY(ary) - diff);/ diff is positive */
3038	AvMAX(ary) += diff;
3039	AvFILLp(ary) += diff;
3040	}
3041	else {
3042	if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3043	av_extend(ary, AvFILLp(ary) + diff);
3044	AvFILLp(ary) += diff;
3045
3046	if (after) {
3047	dst = AvARRAY(ary) + AvFILLp(ary);
3048	src = dst - diff;
3049	for (i = after; i; i--) {
3050	dst-- = src--;
3051	}
3052	}
3053	}
3054	}
3055
3056	for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3057	*dst = NEWSV(46, 0);
3058	sv_setsv(dst++, src++);
3059	}
3060	MARK = ORIGMARK + 1;
3061	if (GIMME == G_ARRAY) { /* copy return vals to stack */
3062	if (length) {
3063	Copy(tmparyval, MARK, length, SV*);
3064	if (AvREAL(ary)) {
3065	EXTEND_MORTAL(length);
3066	for (i = length, dst = MARK; i; i--) {
3067	sv_2mortal(dst); / free them eventualy */
3068	dst++;
3069	}
3070	}
3071	Safefree(tmparyval);
3072	}
3073	MARK += length - 1;
3074	}
3075	else if (length--) {
3076	*MARK = tmparyval[length];
3077	if (AvREAL(ary)) {
3078	sv_2mortal(*MARK);
3079	while (length-- > 0)
3080	SvREFCNT_dec(tmparyval[length]);
3081	}
3082	Safefree(tmparyval);
3083	}
3084	else
3085	*MARK = &PL_sv_undef;
3086	}
3087	SP = MARK;
3088	RETURN;
3089	}
3090
3091	PP(pp_push)
3092	{
3093	djSP; dMARK; dORIGMARK; dTARGET;
3094	register AV ary = (AV)*++MARK;
3095	register SV *sv = &PL_sv_undef;
3096	MAGIC *mg;
3097
3098	if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3099	MARK-- = SvTIED_obj((SV)ary, mg);
3100	PUSHMARK(MARK);
3101	PUTBACK;
3102	ENTER;
3103	call_method("PUSH",G_SCALAR\|G_DISCARD);
3104	LEAVE;
3105	SPAGAIN;
3106	}
3107	else {
3108	/* Why no pre-extend of ary here ? */
3109	for (++MARK; MARK <= SP; MARK++) {
3110	sv = NEWSV(51, 0);
3111	if (*MARK)
3112	sv_setsv(sv, *MARK);
3113	av_push(ary, sv);
3114	}
3115	}
3116	SP = ORIGMARK;
3117	PUSHi( AvFILL(ary) + 1 );
3118	RETURN;
3119	}
3120
3121	PP(pp_pop)
3122	{
3123	djSP;
3124	AV av = (AV)POPs;
3125	SV *sv = av_pop(av);
3126	if (AvREAL(av))
3127	(void)sv_2mortal(sv);
3128	PUSHs(sv);
3129	RETURN;
3130	}
3131
3132	PP(pp_shift)
3133	{
3134	djSP;
3135	AV av = (AV)POPs;
3136	SV *sv = av_shift(av);
3137	EXTEND(SP, 1);
3138	if (!sv)
3139	RETPUSHUNDEF;
3140	if (AvREAL(av))
3141	(void)sv_2mortal(sv);
3142	PUSHs(sv);
3143	RETURN;
3144	}
3145
3146	PP(pp_unshift)
3147	{
3148	djSP; dMARK; dORIGMARK; dTARGET;
3149	register AV ary = (AV)*++MARK;
3150	register SV *sv;
3151	register I32 i = 0;
3152	MAGIC *mg;
3153
3154	if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3155	MARK-- = SvTIED_obj((SV)ary, mg);
3156	PUSHMARK(MARK);
3157	PUTBACK;
3158	ENTER;
3159	call_method("UNSHIFT",G_SCALAR\|G_DISCARD);
3160	LEAVE;
3161	SPAGAIN;
3162	}
3163	else {
3164	av_unshift(ary, SP - MARK);
3165	while (MARK < SP) {
3166	sv = NEWSV(27, 0);
3167	sv_setsv(sv, *++MARK);
3168	(void)av_store(ary, i++, sv);
3169	}
3170	}
3171	SP = ORIGMARK;
3172	PUSHi( AvFILL(ary) + 1 );
3173	RETURN;
3174	}
3175
3176	PP(pp_reverse)
3177	{
3178	djSP; dMARK;
3179	register SV *tmp;
3180	SV **oldsp = SP;
3181
3182	if (GIMME == G_ARRAY) {
3183	MARK++;
3184	while (MARK < SP) {
3185	tmp = *MARK;
3186	MARK++ = SP;
3187	*SP-- = tmp;
3188	}
3189	/* safe as long as stack cannot get extended in the above */
3190	SP = oldsp;
3191	}
3192	else {
3193	register char *up;
3194	register char *down;
3195	register I32 tmp;
3196	dTARGET;
3197	STRLEN len;
3198
3199	SvUTF8_off(TARG); /* decontaminate */
3200	if (SP - MARK > 1)
3201	do_join(TARG, &PL_sv_no, MARK, SP);
3202	else
3203	sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3204	up = SvPV_force(TARG, len);
3205	if (len > 1) {
3206	if (DO_UTF8(TARG)) { /* first reverse each character */
3207	U8* s = (U8*)SvPVX(TARG);
3208	U8* send = (U8*)(s + len);
3209	while (s < send) {
3210	if (*s < 0x80) {
3211	s++;
3212	continue;
3213	}
3214	else {
3215	up = (char*)s;
3216	s += UTF8SKIP(s);
3217	down = (char*)(s - 1);
3218	if (s > send \|\| !((*down & 0xc0) == 0x80)) {
3219	if (ckWARN_d(WARN_UTF8))
3220	Perl_warner(aTHX_ WARN_UTF8,
3221	"Malformed UTF-8 character");
3222	break;
3223	}
3224	while (down > up) {
3225	tmp = *up;
3226	up++ = down;
3227	*down-- = tmp;
3228	}
3229	}
3230	}
3231	up = SvPVX(TARG);
3232	}
3233	down = SvPVX(TARG) + len - 1;
3234	while (down > up) {
3235	tmp = *up;
3236	up++ = down;
3237	*down-- = tmp;
3238	}
3239	(void)SvPOK_only(TARG);
3240	}
3241	SP = MARK + 1;
3242	SETTARG;
3243	}
3244	RETURN;
3245	}
3246
3247	STATIC SV *
3248	S_mul128(pTHX_ SV *sv, U8 m)
3249	{
3250	STRLEN len;
3251	char *s = SvPV(sv, len);
3252	char *t;
3253	U32 i = 0;
3254
3255	if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3256	SV *tmpNew = newSVpvn("0000000000", 10);
3257
3258	sv_catsv(tmpNew, sv);
3259	SvREFCNT_dec(sv); /* free old sv */
3260	sv = tmpNew;
3261	s = SvPV(sv, len);
3262	}
3263	t = s + len - 1;
3264	while (!t) / trailing '\0'? */
3265	t--;
3266	while (t > s) {
3267	i = ((*t - '0') << 7) + m;
3268	*(t--) = '0' + (i % 10);
3269	m = i / 10;
3270	}
3271	return (sv);
3272	}
3273
3274	/* Explosives and implosives. */
3275
3276	#if 'I' == 73 && 'J' == 74
3277	/* On an ASCII/ISO kind of system */
3278	#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3279	#else
3280	/*
3281	Some other sort of character set - use memchr() so we don't match
3282	the null byte.
3283	*/
3284	#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) \|\| (ch) == ' ')
3285	#endif
3286
3287	PP(pp_unpack)
3288	{
3289	djSP;
3290	dPOPPOPssrl;
3291	I32 start_sp_offset = SP - PL_stack_base;
3292	I32 gimme = GIMME_V;
3293	SV *sv;
3294	STRLEN llen;
3295	STRLEN rlen;
3296	register char *pat = SvPV(left, llen);
3297	register char *s = SvPV(right, rlen);
3298	char *strend = s + rlen;
3299	char *strbeg = s;
3300	register char *patend = pat + llen;
3301	I32 datumtype;
3302	register I32 len;
3303	register I32 bits;
3304	register char *str;
3305
3306	/* These must not be in registers: */
3307	I16 ashort;
3308	int aint;
3309	I32 along;
3310	#ifdef HAS_QUAD
3311	Quad_t aquad;
3312	#endif
3313	U16 aushort;
3314	unsigned int auint;
3315	U32 aulong;
3316	#ifdef HAS_QUAD
3317	Uquad_t auquad;
3318	#endif
3319	char *aptr;
3320	float afloat;
3321	double adouble;
3322	I32 checksum = 0;
3323	register U32 culong;
3324	NV cdouble;
3325	int commas = 0;
3326	int star;
3327	#ifdef PERL_NATINT_PACK
3328	int natint; /* native integer */
3329	int unatint; /* unsigned native integer */
3330	#endif
3331
3332	if (gimme != G_ARRAY) { /* arrange to do first one only */
3333	/SUPPRESS 530/
3334	for (patend = pat; !isALPHA(patend) \|\| patend == 'x'; patend++) ;
3335	if (strchr("aAZbBhHP", patend) \|\| pat == '%') {
3336	patend++;
3337	while (isDIGIT(patend) \|\| patend == '*')
3338	patend++;
3339	}
3340	else
3341	patend++;
3342	}
3343	while (pat < patend) {
3344	reparse:
3345	datumtype = *pat++ & 0xFF;
3346	#ifdef PERL_NATINT_PACK
3347	natint = 0;
3348	#endif
3349	if (isSPACE(datumtype))
3350	continue;
3351	if (datumtype == '#') {
3352	while (pat < patend && *pat != '\n')
3353	pat++;
3354	continue;
3355	}
3356	if (*pat == '!') {
3357	char *natstr = "sSiIlL";
3358
3359	if (strchr(natstr, datumtype)) {
3360	#ifdef PERL_NATINT_PACK
3361	natint = 1;
3362	#endif
3363	pat++;
3364	}
3365	else
3366	DIE(aTHX_ "'!' allowed only after types %s", natstr);
3367	}
3368	star = 0;
3369	if (pat >= patend)
3370	len = 1;
3371	else if (pat == '') {
3372	len = strend - strbeg; /* long enough */
3373	pat++;
3374	star = 1;
3375	}
3376	else if (isDIGIT(*pat)) {
3377	len = *pat++ - '0';
3378	while (isDIGIT(*pat)) {
3379	len = (len * 10) + (*pat++ - '0');
3380	if (len < 0)
3381	DIE(aTHX_ "Repeat count in unpack overflows");
3382	}
3383	}
3384	else
3385	len = (datumtype != '@');
3386	redo_switch:
3387	switch(datumtype) {
3388	default:
3389	DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3390	case ',': /* grandfather in commas but with a warning */
3391	if (commas++ == 0 && ckWARN(WARN_UNPACK))
3392	Perl_warner(aTHX_ WARN_UNPACK,
3393	"Invalid type in unpack: '%c'", (int)datumtype);
3394	break;
3395	case '%':
3396	if (len == 1 && pat[-1] != '1')
3397	len = 16;
3398	checksum = len;
3399	culong = 0;
3400	cdouble = 0;
3401	if (pat < patend)
3402	goto reparse;
3403	break;
3404	case '@':
3405	if (len > strend - strbeg)
3406	DIE(aTHX_ "@ outside of string");
3407	s = strbeg + len;
3408	break;
3409	case 'X':
3410	if (len > s - strbeg)
3411	DIE(aTHX_ "X outside of string");
3412	s -= len;
3413	break;
3414	case 'x':
3415	if (len > strend - s)
3416	DIE(aTHX_ "x outside of string");
3417	s += len;
3418	break;
3419	case '/':
3420	if (start_sp_offset >= SP - PL_stack_base)
3421	DIE(aTHX_ "/ must follow a numeric type");
3422	datumtype = *pat++;
3423	if (pat == '')
3424	pat++; /* ignore '' for compatibility with pack /
3425	if (isDIGIT(*pat))
3426	DIE(aTHX_ "/ cannot take a count" );
3427	len = POPi;
3428	star = 0;
3429	goto redo_switch;
3430	case 'A':
3431	case 'Z':
3432	case 'a':
3433	if (len > strend - s)
3434	len = strend - s;
3435	if (checksum)
3436	goto uchar_checksum;
3437	sv = NEWSV(35, len);
3438	sv_setpvn(sv, s, len);
3439	s += len;
3440	if (datumtype == 'A' \|\| datumtype == 'Z') {
3441	aptr = s; /* borrow register */
3442	if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3443	s = SvPVX(sv);
3444	while (*s)
3445	s++;
3446	}
3447	else { /* 'A' strips both nulls and spaces */
3448	s = SvPVX(sv) + len - 1;
3449	while (s >= SvPVX(sv) && (!s \|\| isSPACE(s)))
3450	s--;
3451	*++s = '\0';
3452	}
3453	SvCUR_set(sv, s - SvPVX(sv));
3454	s = aptr; /* unborrow register */
3455	}
3456	XPUSHs(sv_2mortal(sv));
3457	break;
3458	case 'B':
3459	case 'b':
3460	if (star \|\| len > (strend - s) * 8)
3461	len = (strend - s) * 8;
3462	if (checksum) {
3463	if (!PL_bitcount) {
3464	Newz(601, PL_bitcount, 256, char);
3465	for (bits = 1; bits < 256; bits++) {
3466	if (bits & 1) PL_bitcount[bits]++;
3467	if (bits & 2) PL_bitcount[bits]++;
3468	if (bits & 4) PL_bitcount[bits]++;
3469	if (bits & 8) PL_bitcount[bits]++;
3470	if (bits & 16) PL_bitcount[bits]++;
3471	if (bits & 32) PL_bitcount[bits]++;
3472	if (bits & 64) PL_bitcount[bits]++;
3473	if (bits & 128) PL_bitcount[bits]++;
3474	}
3475	}
3476	while (len >= 8) {
3477	culong += PL_bitcount[(unsigned char)s++];
3478	len -= 8;
3479	}
3480	if (len) {
3481	bits = *s;
3482	if (datumtype == 'b') {
3483	while (len-- > 0) {
3484	if (bits & 1) culong++;
3485	bits >>= 1;
3486	}
3487	}
3488	else {
3489	while (len-- > 0) {
3490	if (bits & 128) culong++;
3491	bits <<= 1;
3492	}
3493	}
3494	}
3495	break;
3496	}
3497	sv = NEWSV(35, len + 1);
3498	SvCUR_set(sv, len);
3499	SvPOK_on(sv);
3500	str = SvPVX(sv);
3501	if (datumtype == 'b') {
3502	aint = len;
3503	for (len = 0; len < aint; len++) {
3504	if (len & 7) /SUPPRESS 595/
3505	bits >>= 1;
3506	else
3507	bits = *s++;
3508	*str++ = '0' + (bits & 1);
3509	}
3510	}
3511	else {
3512	aint = len;
3513	for (len = 0; len < aint; len++) {
3514	if (len & 7)
3515	bits <<= 1;
3516	else
3517	bits = *s++;
3518	*str++ = '0' + ((bits & 128) != 0);
3519	}
3520	}
3521	*str = '\0';
3522	XPUSHs(sv_2mortal(sv));
3523	break;
3524	case 'H':
3525	case 'h':
3526	if (star \|\| len > (strend - s) * 2)
3527	len = (strend - s) * 2;
3528	sv = NEWSV(35, len + 1);
3529	SvCUR_set(sv, len);
3530	SvPOK_on(sv);
3531	str = SvPVX(sv);
3532	if (datumtype == 'h') {
3533	aint = len;
3534	for (len = 0; len < aint; len++) {
3535	if (len & 1)
3536	bits >>= 4;
3537	else
3538	bits = *s++;
3539	*str++ = PL_hexdigit[bits & 15];
3540	}
3541	}
3542	else {
3543	aint = len;
3544	for (len = 0; len < aint; len++) {
3545	if (len & 1)
3546	bits <<= 4;
3547	else
3548	bits = *s++;
3549	*str++ = PL_hexdigit[(bits >> 4) & 15];
3550	}
3551	}
3552	*str = '\0';
3553	XPUSHs(sv_2mortal(sv));
3554	break;
3555	case 'c':
3556	if (len > strend - s)
3557	len = strend - s;
3558	if (checksum) {
3559	while (len-- > 0) {
3560	aint = *s++;
3561	if (aint >= 128) /* fake up signed chars */
3562	aint -= 256;
3563	culong += aint;
3564	}
3565	}
3566	else {
3567	EXTEND(SP, len);
3568	EXTEND_MORTAL(len);
3569	while (len-- > 0) {
3570	aint = *s++;
3571	if (aint >= 128) /* fake up signed chars */
3572	aint -= 256;
3573	sv = NEWSV(36, 0);
3574	sv_setiv(sv, (IV)aint);
3575	PUSHs(sv_2mortal(sv));
3576	}
3577	}
3578	break;
3579	case 'C':
3580	if (len > strend - s)
3581	len = strend - s;
3582	if (checksum) {
3583	uchar_checksum:
3584	while (len-- > 0) {
3585	auint = *s++ & 255;
3586	culong += auint;
3587	}
3588	}
3589	else {
3590	EXTEND(SP, len);
3591	EXTEND_MORTAL(len);
3592	while (len-- > 0) {
3593	auint = *s++ & 255;
3594	sv = NEWSV(37, 0);
3595	sv_setiv(sv, (IV)auint);
3596	PUSHs(sv_2mortal(sv));
3597	}
3598	}
3599	break;
3600	case 'U':
3601	if (len > strend - s)
3602	len = strend - s;
3603	if (checksum) {
3604	while (len-- > 0 && s < strend) {
3605	auint = utf8_to_uv((U8*)s, &along);
3606	s += along;
3607	if (checksum > 32)
3608	cdouble += (NV)auint;
3609	else
3610	culong += auint;
3611	}
3612	}
3613	else {
3614	EXTEND(SP, len);
3615	EXTEND_MORTAL(len);
3616	while (len-- > 0 && s < strend) {
3617	auint = utf8_to_uv((U8*)s, &along);
3618	s += along;
3619	sv = NEWSV(37, 0);
3620	sv_setuv(sv, (UV)auint);
3621	PUSHs(sv_2mortal(sv));
3622	}
3623	}
3624	break;
3625	case 's':
3626	#if SHORTSIZE == SIZE16
3627	along = (strend - s) / SIZE16;
3628	#else
3629	along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3630	#endif
3631	if (len > along)
3632	len = along;
3633	if (checksum) {
3634	#if SHORTSIZE != SIZE16
3635	if (natint) {
3636	short ashort;
3637	while (len-- > 0) {
3638	COPYNN(s, &ashort, sizeof(short));
3639	s += sizeof(short);
3640	culong += ashort;
3641
3642	}
3643	}
3644	else
3645	#endif
3646	{
3647	while (len-- > 0) {
3648	COPY16(s, &ashort);
3649	#if SHORTSIZE > SIZE16
3650	if (ashort > 32767)
3651	ashort -= 65536;
3652	#endif
3653	s += SIZE16;
3654	culong += ashort;
3655	}
3656	}
3657	}
3658	else {
3659	EXTEND(SP, len);
3660	EXTEND_MORTAL(len);
3661	#if SHORTSIZE != SIZE16
3662	if (natint) {
3663	short ashort;
3664	while (len-- > 0) {
3665	COPYNN(s, &ashort, sizeof(short));
3666	s += sizeof(short);
3667	sv = NEWSV(38, 0);
3668	sv_setiv(sv, (IV)ashort);
3669	PUSHs(sv_2mortal(sv));
3670	}
3671	}
3672	else
3673	#endif
3674	{
3675	while (len-- > 0) {
3676	COPY16(s, &ashort);
3677	#if SHORTSIZE > SIZE16
3678	if (ashort > 32767)
3679	ashort -= 65536;
3680	#endif
3681	s += SIZE16;
3682	sv = NEWSV(38, 0);
3683	sv_setiv(sv, (IV)ashort);
3684	PUSHs(sv_2mortal(sv));
3685	}
3686	}
3687	}
3688	break;
3689	case 'v':
3690	case 'n':
3691	case 'S':
3692	#if SHORTSIZE == SIZE16
3693	along = (strend - s) / SIZE16;
3694	#else
3695	unatint = natint && datumtype == 'S';
3696	along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3697	#endif
3698	if (len > along)
3699	len = along;
3700	if (checksum) {
3701	#if SHORTSIZE != SIZE16
3702	if (unatint) {
3703	unsigned short aushort;
3704	while (len-- > 0) {
3705	COPYNN(s, &aushort, sizeof(unsigned short));
3706	s += sizeof(unsigned short);
3707	culong += aushort;
3708	}
3709	}
3710	else
3711	#endif
3712	{
3713	while (len-- > 0) {
3714	COPY16(s, &aushort);
3715	s += SIZE16;
3716	#ifdef HAS_NTOHS
3717	if (datumtype == 'n')
3718	aushort = PerlSock_ntohs(aushort);
3719	#endif
3720	#ifdef HAS_VTOHS
3721	if (datumtype == 'v')
3722	aushort = vtohs(aushort);
3723	#endif
3724	culong += aushort;
3725	}
3726	}
3727	}
3728	else {
3729	EXTEND(SP, len);
3730	EXTEND_MORTAL(len);
3731	#if SHORTSIZE != SIZE16
3732	if (unatint) {
3733	unsigned short aushort;
3734	while (len-- > 0) {
3735	COPYNN(s, &aushort, sizeof(unsigned short));
3736	s += sizeof(unsigned short);
3737	sv = NEWSV(39, 0);
3738	sv_setiv(sv, (UV)aushort);
3739	PUSHs(sv_2mortal(sv));
3740	}
3741	}
3742	else
3743	#endif
3744	{
3745	while (len-- > 0) {
3746	COPY16(s, &aushort);
3747	s += SIZE16;
3748	sv = NEWSV(39, 0);
3749	#ifdef HAS_NTOHS
3750	if (datumtype == 'n')
3751	aushort = PerlSock_ntohs(aushort);
3752	#endif
3753	#ifdef HAS_VTOHS
3754	if (datumtype == 'v')
3755	aushort = vtohs(aushort);
3756	#endif
3757	sv_setiv(sv, (UV)aushort);
3758	PUSHs(sv_2mortal(sv));
3759	}
3760	}
3761	}
3762	break;
3763	case 'i':
3764	along = (strend - s) / sizeof(int);
3765	if (len > along)
3766	len = along;
3767	if (checksum) {
3768	while (len-- > 0) {
3769	Copy(s, &aint, 1, int);
3770	s += sizeof(int);
3771	if (checksum > 32)
3772	cdouble += (NV)aint;
3773	else
3774	culong += aint;
3775	}
3776	}
3777	else {
3778	EXTEND(SP, len);
3779	EXTEND_MORTAL(len);
3780	while (len-- > 0) {
3781	Copy(s, &aint, 1, int);
3782	s += sizeof(int);
3783	sv = NEWSV(40, 0);
3784	#ifdef __osf__
3785	/* Without the dummy below unpack("i", pack("i",-1))
3786	* return 0xFFffFFff instead of -1 for Digital Unix V4.0
3787	* cc with optimization turned on.
3788	*
3789	* The bug was detected in
3790	* DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3791	* with optimization (-O4) turned on.
3792	* DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3793	* does not have this problem even with -O4.
3794	*
3795	* This bug was reported as DECC_BUGS 1431
3796	* and tracked internally as GEM_BUGS 7775.
3797	*
3798	* The bug is fixed in
3799	* Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3800	* UNIX V4.0F support: DEC C V5.9-006 or later
3801	* UNIX V4.0E support: DEC C V5.8-011 or later
3802	* and also in DTK.
3803	*
3804	* See also few lines later for the same bug.
3805	*/
3806	(aint) ?
3807	sv_setiv(sv, (IV)aint) :
3808	#endif
3809	sv_setiv(sv, (IV)aint);
3810	PUSHs(sv_2mortal(sv));
3811	}
3812	}
3813	break;
3814	case 'I':
3815	along = (strend - s) / sizeof(unsigned int);
3816	if (len > along)
3817	len = along;
3818	if (checksum) {
3819	while (len-- > 0) {
3820	Copy(s, &auint, 1, unsigned int);
3821	s += sizeof(unsigned int);
3822	if (checksum > 32)
3823	cdouble += (NV)auint;
3824	else
3825	culong += auint;
3826	}
3827	}
3828	else {
3829	EXTEND(SP, len);
3830	EXTEND_MORTAL(len);
3831	while (len-- > 0) {
3832	Copy(s, &auint, 1, unsigned int);
3833	s += sizeof(unsigned int);
3834	sv = NEWSV(41, 0);
3835	#ifdef __osf__
3836	/* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3837	* returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3838	* See details few lines earlier. */
3839	(auint) ?
3840	sv_setuv(sv, (UV)auint) :
3841	#endif
3842	sv_setuv(sv, (UV)auint);
3843	PUSHs(sv_2mortal(sv));
3844	}
3845	}
3846	break;
3847	case 'l':
3848	#if LONGSIZE == SIZE32
3849	along = (strend - s) / SIZE32;
3850	#else
3851	along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3852	#endif
3853	if (len > along)
3854	len = along;
3855	if (checksum) {
3856	#if LONGSIZE != SIZE32
3857	if (natint) {
3858	long along;
3859	while (len-- > 0) {
3860	COPYNN(s, &along, sizeof(long));
3861	s += sizeof(long);
3862	if (checksum > 32)
3863	cdouble += (NV)along;
3864	else
3865	culong += along;
3866	}
3867	}
3868	else
3869	#endif
3870	{
3871	while (len-- > 0) {
3872	COPY32(s, &along);
3873	#if LONGSIZE > SIZE32
3874	if (along > 2147483647)
3875	along -= 4294967296;
3876	#endif
3877	s += SIZE32;
3878	if (checksum > 32)
3879	cdouble += (NV)along;
3880	else
3881	culong += along;
3882	}
3883	}
3884	}
3885	else {
3886	EXTEND(SP, len);
3887	EXTEND_MORTAL(len);
3888	#if LONGSIZE != SIZE32
3889	if (natint) {
3890	long along;
3891	while (len-- > 0) {
3892	COPYNN(s, &along, sizeof(long));
3893	s += sizeof(long);
3894	sv = NEWSV(42, 0);
3895	sv_setiv(sv, (IV)along);
3896	PUSHs(sv_2mortal(sv));
3897	}
3898	}
3899	else
3900	#endif
3901	{
3902	while (len-- > 0) {
3903	COPY32(s, &along);
3904	#if LONGSIZE > SIZE32
3905	if (along > 2147483647)
3906	along -= 4294967296;
3907	#endif
3908	s += SIZE32;
3909	sv = NEWSV(42, 0);
3910	sv_setiv(sv, (IV)along);
3911	PUSHs(sv_2mortal(sv));
3912	}
3913	}
3914	}
3915	break;
3916	case 'V':
3917	case 'N':
3918	case 'L':
3919	#if LONGSIZE == SIZE32
3920	along = (strend - s) / SIZE32;
3921	#else
3922	unatint = natint && datumtype == 'L';
3923	along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3924	#endif
3925	if (len > along)
3926	len = along;
3927	if (checksum) {
3928	#if LONGSIZE != SIZE32
3929	if (unatint) {
3930	unsigned long aulong;
3931	while (len-- > 0) {
3932	COPYNN(s, &aulong, sizeof(unsigned long));
3933	s += sizeof(unsigned long);
3934	if (checksum > 32)
3935	cdouble += (NV)aulong;
3936	else
3937	culong += aulong;
3938	}
3939	}
3940	else
3941	#endif
3942	{
3943	while (len-- > 0) {
3944	COPY32(s, &aulong);
3945	s += SIZE32;
3946	#ifdef HAS_NTOHL
3947	if (datumtype == 'N')
3948	aulong = PerlSock_ntohl(aulong);
3949	#endif
3950	#ifdef HAS_VTOHL
3951	if (datumtype == 'V')
3952	aulong = vtohl(aulong);
3953	#endif
3954	if (checksum > 32)
3955	cdouble += (NV)aulong;
3956	else
3957	culong += aulong;
3958	}
3959	}
3960	}
3961	else {
3962	EXTEND(SP, len);
3963	EXTEND_MORTAL(len);
3964	#if LONGSIZE != SIZE32
3965	if (unatint) {
3966	unsigned long aulong;
3967	while (len-- > 0) {
3968	COPYNN(s, &aulong, sizeof(unsigned long));
3969	s += sizeof(unsigned long);
3970	sv = NEWSV(43, 0);
3971	sv_setuv(sv, (UV)aulong);
3972	PUSHs(sv_2mortal(sv));
3973	}
3974	}
3975	else
3976	#endif
3977	{
3978	while (len-- > 0) {
3979	COPY32(s, &aulong);
3980	s += SIZE32;
3981	#ifdef HAS_NTOHL
3982	if (datumtype == 'N')
3983	aulong = PerlSock_ntohl(aulong);
3984	#endif
3985	#ifdef HAS_VTOHL
3986	if (datumtype == 'V')
3987	aulong = vtohl(aulong);
3988	#endif
3989	sv = NEWSV(43, 0);
3990	sv_setuv(sv, (UV)aulong);
3991	PUSHs(sv_2mortal(sv));
3992	}
3993	}
3994	}
3995	break;
3996	case 'p':
3997	along = (strend - s) / sizeof(char*);
3998	if (len > along)
3999	len = along;
4000	EXTEND(SP, len);
4001	EXTEND_MORTAL(len);
4002	while (len-- > 0) {
4003	if (sizeof(char*) > strend - s)
4004	break;
4005	else {
4006	Copy(s, &aptr, 1, char*);
4007	s += sizeof(char*);
4008	}
4009	sv = NEWSV(44, 0);
4010	if (aptr)
4011	sv_setpv(sv, aptr);
4012	PUSHs(sv_2mortal(sv));
4013	}
4014	break;
4015	case 'w':
4016	EXTEND(SP, len);
4017	EXTEND_MORTAL(len);
4018	{
4019	UV auv = 0;
4020	U32 bytes = 0;
4021
4022	while ((len > 0) && (s < strend)) {
4023	auv = (auv << 7) \| (*s & 0x7f);
4024	if (!(*s++ & 0x80)) {
4025	bytes = 0;
4026	sv = NEWSV(40, 0);
4027	sv_setuv(sv, auv);
4028	PUSHs(sv_2mortal(sv));
4029	len--;
4030	auv = 0;
4031	}
4032	else if (++bytes >= sizeof(UV)) { /* promote to string */
4033	char *t;
4034	STRLEN n_a;
4035
4036	sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4037	while (s < strend) {
4038	sv = mul128(sv, *s & 0x7f);
4039	if (!(*s++ & 0x80)) {
4040	bytes = 0;
4041	break;
4042	}
4043	}
4044	t = SvPV(sv, n_a);
4045	while (*t == '0')
4046	t++;
4047	sv_chop(sv, t);
4048	PUSHs(sv_2mortal(sv));
4049	len--;
4050	auv = 0;
4051	}
4052	}
4053	if ((s >= strend) && bytes)
4054	DIE(aTHX_ "Unterminated compressed integer");
4055	}
4056	break;
4057	case 'P':
4058	EXTEND(SP, 1);
4059	if (sizeof(char*) > strend - s)
4060	break;
4061	else {
4062	Copy(s, &aptr, 1, char*);
4063	s += sizeof(char*);
4064	}
4065	sv = NEWSV(44, 0);
4066	if (aptr)
4067	sv_setpvn(sv, aptr, len);
4068	PUSHs(sv_2mortal(sv));
4069	break;
4070	#ifdef HAS_QUAD
4071	case 'q':
4072	along = (strend - s) / sizeof(Quad_t);
4073	if (len > along)
4074	len = along;
4075	EXTEND(SP, len);
4076	EXTEND_MORTAL(len);
4077	while (len-- > 0) {
4078	if (s + sizeof(Quad_t) > strend)
4079	aquad = 0;
4080	else {
4081	Copy(s, &aquad, 1, Quad_t);
4082	s += sizeof(Quad_t);
4083	}
4084	sv = NEWSV(42, 0);
4085	if (aquad >= IV_MIN && aquad <= IV_MAX)
4086	sv_setiv(sv, (IV)aquad);
4087	else
4088	sv_setnv(sv, (NV)aquad);
4089	PUSHs(sv_2mortal(sv));
4090	}
4091	break;
4092	case 'Q':
4093	along = (strend - s) / sizeof(Quad_t);
4094	if (len > along)
4095	len = along;
4096	EXTEND(SP, len);
4097	EXTEND_MORTAL(len);
4098	while (len-- > 0) {
4099	if (s + sizeof(Uquad_t) > strend)
4100	auquad = 0;
4101	else {
4102	Copy(s, &auquad, 1, Uquad_t);
4103	s += sizeof(Uquad_t);
4104	}
4105	sv = NEWSV(43, 0);
4106	if (auquad <= UV_MAX)
4107	sv_setuv(sv, (UV)auquad);
4108	else
4109	sv_setnv(sv, (NV)auquad);
4110	PUSHs(sv_2mortal(sv));
4111	}
4112	break;
4113	#endif
4114	/* float and double added gnb@melba.bby.oz.au 22/11/89 */
4115	case 'f':
4116	case 'F':
4117	along = (strend - s) / sizeof(float);
4118	if (len > along)
4119	len = along;
4120	if (checksum) {
4121	while (len-- > 0) {
4122	Copy(s, &afloat, 1, float);
4123	s += sizeof(float);
4124	cdouble += afloat;
4125	}
4126	}
4127	else {
4128	EXTEND(SP, len);
4129	EXTEND_MORTAL(len);
4130	while (len-- > 0) {
4131	Copy(s, &afloat, 1, float);
4132	s += sizeof(float);
4133	sv = NEWSV(47, 0);
4134	sv_setnv(sv, (NV)afloat);
4135	PUSHs(sv_2mortal(sv));
4136	}
4137	}
4138	break;
4139	case 'd':
4140	case 'D':
4141	along = (strend - s) / sizeof(double);
4142	if (len > along)
4143	len = along;
4144	if (checksum) {
4145	while (len-- > 0) {
4146	Copy(s, &adouble, 1, double);
4147	s += sizeof(double);
4148	cdouble += adouble;
4149	}
4150	}
4151	else {
4152	EXTEND(SP, len);
4153	EXTEND_MORTAL(len);
4154	while (len-- > 0) {
4155	Copy(s, &adouble, 1, double);
4156	s += sizeof(double);
4157	sv = NEWSV(48, 0);
4158	sv_setnv(sv, (NV)adouble);
4159	PUSHs(sv_2mortal(sv));
4160	}
4161	}
4162	break;
4163	case 'u':
4164	/* MKS:
4165	* Initialise the decode mapping. By using a table driven
4166	* algorithm, the code will be character-set independent
4167	* (and just as fast as doing character arithmetic)
4168	*/
4169	if (PL_uudmap['M'] == 0) {
4170	int i;
4171
4172	for (i = 0; i < sizeof(PL_uuemap); i += 1)
4173	PL_uudmap[(U8)PL_uuemap[i]] = i;
4174	/*
4175	* Because ' ' and '`' map to the same value,
4176	* we need to decode them both the same.
4177	*/
4178	PL_uudmap[' '] = 0;
4179	}
4180
4181	along = (strend - s) * 3 / 4;
4182	sv = NEWSV(42, along);
4183	if (along)
4184	SvPOK_on(sv);
4185	while (s < strend && s > ' ' && ISUUCHAR(s)) {
4186	I32 a, b, c, d;
4187	char hunk[4];
4188
4189	hunk[3] = '\0';
4190	len = PL_uudmap[(U8)s++] & 077;
4191	while (len > 0) {
4192	if (s < strend && ISUUCHAR(*s))
4193	a = PL_uudmap[(U8)s++] & 077;
4194	else
4195	a = 0;
4196	if (s < strend && ISUUCHAR(*s))
4197	b = PL_uudmap[(U8)s++] & 077;
4198	else
4199	b = 0;
4200	if (s < strend && ISUUCHAR(*s))
4201	c = PL_uudmap[(U8)s++] & 077;
4202	else
4203	c = 0;
4204	if (s < strend && ISUUCHAR(*s))
4205	d = PL_uudmap[(U8)s++] & 077;
4206	else
4207	d = 0;
4208	hunk[0] = (a << 2) \| (b >> 4);
4209	hunk[1] = (b << 4) \| (c >> 2);
4210	hunk[2] = (c << 6) \| d;
4211	sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4212	len -= 3;
4213	}
4214	if (*s == '\n')
4215	s++;
4216	else if (s[1] == '\n') /* possible checksum byte */
4217	s += 2;
4218	}
4219	XPUSHs(sv_2mortal(sv));
4220	break;
4221	}
4222	if (checksum) {
4223	sv = NEWSV(42, 0);
4224	if (strchr("fFdD", datumtype) \|\|
4225	(checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4226	NV trouble;
4227
4228	adouble = 1.0;
4229	while (checksum >= 16) {
4230	checksum -= 16;
4231	adouble *= 65536.0;
4232	}
4233	while (checksum >= 4) {
4234	checksum -= 4;
4235	adouble *= 16.0;
4236	}
4237	while (checksum--)
4238	adouble *= 2.0;
4239	along = (1 << checksum) - 1;
4240	while (cdouble < 0.0)
4241	cdouble += adouble;
4242	cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4243	sv_setnv(sv, cdouble);
4244	}
4245	else {
4246	if (checksum < 32) {
4247	aulong = (1 << checksum) - 1;
4248	culong &= aulong;
4249	}
4250	sv_setuv(sv, (UV)culong);
4251	}
4252	XPUSHs(sv_2mortal(sv));
4253	checksum = 0;
4254	}
4255	}
4256	if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4257	PUSHs(&PL_sv_undef);
4258	RETURN;
4259	}
4260
4261	STATIC void
4262	S_doencodes(pTHX_ register SV sv, register char s, register I32 len)
4263	{
4264	char hunk[5];
4265
4266	*hunk = PL_uuemap[len];
4267	sv_catpvn(sv, hunk, 1);
4268	hunk[4] = '\0';
4269	while (len > 2) {
4270	hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4271	hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) \| ((s[1] >> 4) & 017)))];
4272	hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) \| ((s[2] >> 6) & 03)))];
4273	hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4274	sv_catpvn(sv, hunk, 4);
4275	s += 3;
4276	len -= 3;
4277	}
4278	if (len > 0) {
4279	char r = (len > 1 ? s[1] : '\0');
4280	hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4281	hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) \| ((r >> 4) & 017)))];
4282	hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4283	hunk[3] = PL_uuemap[0];
4284	sv_catpvn(sv, hunk, 4);
4285	}
4286	sv_catpvn(sv, "\n", 1);
4287	}
4288
4289	STATIC SV *
4290	S_is_an_int(pTHX_ char *s, STRLEN l)
4291	{
4292	STRLEN n_a;
4293	SV *result = newSVpvn(s, l);
4294	char result_c = SvPV(result, n_a); / convenience */
4295	char *out = result_c;
4296	bool skip = 1;
4297	bool ignore = 0;
4298
4299	while (*s) {
4300	switch (*s) {
4301	case ' ':
4302	break;
4303	case '+':
4304	if (!skip) {
4305	SvREFCNT_dec(result);
4306	return (NULL);
4307	}
4308	break;
4309	case '0':
4310	case '1':
4311	case '2':
4312	case '3':
4313	case '4':
4314	case '5':
4315	case '6':
4316	case '7':
4317	case '8':
4318	case '9':
4319	skip = 0;
4320	if (!ignore) {
4321	(out++) = s;
4322	}
4323	break;
4324	case '.':
4325	ignore = 1;
4326	break;
4327	default:
4328	SvREFCNT_dec(result);
4329	return (NULL);
4330	}
4331	s++;
4332	}
4333	*(out++) = '\0';
4334	SvCUR_set(result, out - result_c);
4335	return (result);
4336	}
4337
4338	/* pnum must be '\0' terminated */
4339	STATIC int
4340	S_div128(pTHX_ SV pnum, bool done)
4341	{
4342	STRLEN len;
4343	char *s = SvPV(pnum, len);
4344	int m = 0;
4345	int r = 0;
4346	char *t = s;
4347
4348	*done = 1;
4349	while (*t) {
4350	int i;
4351
4352	i = m * 10 + (*t - '0');
4353	m = i & 0x7F;
4354	r = (i >> 7); /* r < 10 */
4355	if (r) {
4356	*done = 0;
4357	}
4358	*(t++) = '0' + r;
4359	}
4360	*(t++) = '\0';
4361	SvCUR_set(pnum, (STRLEN) (t - s));
4362	return (m);
4363	}
4364
4365
4366	PP(pp_pack)
4367	{
4368	djSP; dMARK; dORIGMARK; dTARGET;
4369	register SV *cat = TARG;
4370	register I32 items;
4371	STRLEN fromlen;
4372	register char pat = SvPVx(++MARK, fromlen);
4373	register char *patend = pat + fromlen;
4374	register I32 len;
4375	I32 datumtype;
4376	SV *fromstr;
4377	/SUPPRESS 442/
4378	static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4379	static char *space10 = " ";
4380
4381	/* These must not be in registers: */
4382	char achar;
4383	I16 ashort;
4384	int aint;
4385	unsigned int auint;
4386	I32 along;
4387	U32 aulong;
4388	#ifdef HAS_QUAD
4389	Quad_t aquad;
4390	Uquad_t auquad;
4391	#endif
4392	char *aptr;
4393	float afloat;
4394	double adouble;
4395	int commas = 0;
4396	#ifdef PERL_NATINT_PACK
4397	int natint; /* native integer */
4398	#endif
4399
4400	items = SP - MARK;
4401	MARK++;
4402	sv_setpvn(cat, "", 0);
4403	while (pat < patend) {
4404	SV *lengthcode = Nullsv;
4405	#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4406	datumtype = *pat++ & 0xFF;
4407	#ifdef PERL_NATINT_PACK
4408	natint = 0;
4409	#endif
4410	if (isSPACE(datumtype))
4411	continue;
4412	if (datumtype == '#') {
4413	while (pat < patend && *pat != '\n')
4414	pat++;
4415	continue;
4416	}
4417	if (*pat == '!') {
4418	char *natstr = "sSiIlL";
4419
4420	if (strchr(natstr, datumtype)) {
4421	#ifdef PERL_NATINT_PACK
4422	natint = 1;
4423	#endif
4424	pat++;
4425	}
4426	else
4427	DIE(aTHX_ "'!' allowed only after types %s", natstr);
4428	}
4429	if (pat == '') {
4430	len = strchr("@Xxu", datumtype) ? 0 : items;
4431	pat++;
4432	}
4433	else if (isDIGIT(*pat)) {
4434	len = *pat++ - '0';
4435	while (isDIGIT(*pat)) {
4436	len = (len * 10) + (*pat++ - '0');
4437	if (len < 0)
4438	DIE(aTHX_ "Repeat count in pack overflows");
4439	}
4440	}
4441	else
4442	len = 1;
4443	if (*pat == '/') {
4444	++pat;
4445	if ((pat != 'a' && pat != 'A' && pat != 'Z') \|\| pat[1] != '')
4446	DIE(aTHX_ "/ must be followed by a, A or Z*");
4447	lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4448	? *MARK : &PL_sv_no)));
4449	}
4450	switch(datumtype) {
4451	default:
4452	DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4453	case ',': /* grandfather in commas but with a warning */
4454	if (commas++ == 0 && ckWARN(WARN_PACK))
4455	Perl_warner(aTHX_ WARN_PACK,
4456	"Invalid type in pack: '%c'", (int)datumtype);
4457	break;
4458	case '%':
4459	DIE(aTHX_ "%% may only be used in unpack");
4460	case '@':
4461	len -= SvCUR(cat);
4462	if (len > 0)
4463	goto grow;
4464	len = -len;
4465	if (len > 0)
4466	goto shrink;
4467	break;
4468	case 'X':
4469	shrink:
4470	if (SvCUR(cat) < len)
4471	DIE(aTHX_ "X outside of string");
4472	SvCUR(cat) -= len;
4473	*SvEND(cat) = '\0';
4474	break;
4475	case 'x':
4476	grow:
4477	while (len >= 10) {
4478	sv_catpvn(cat, null10, 10);
4479	len -= 10;
4480	}
4481	sv_catpvn(cat, null10, len);
4482	break;
4483	case 'A':
4484	case 'Z':
4485	case 'a':
4486	fromstr = NEXTFROM;
4487	aptr = SvPV(fromstr, fromlen);
4488	if (pat[-1] == '*') {
4489	len = fromlen;
4490	if (datumtype == 'Z')
4491	++len;
4492	}
4493	if (fromlen >= len) {
4494	sv_catpvn(cat, aptr, len);
4495	if (datumtype == 'Z')
4496	*(SvEND(cat)-1) = '\0';
4497	}
4498	else {
4499	sv_catpvn(cat, aptr, fromlen);
4500	len -= fromlen;
4501	if (datumtype == 'A') {
4502	while (len >= 10) {
4503	sv_catpvn(cat, space10, 10);
4504	len -= 10;
4505	}
4506	sv_catpvn(cat, space10, len);
4507	}
4508	else {
4509	while (len >= 10) {
4510	sv_catpvn(cat, null10, 10);
4511	len -= 10;
4512	}
4513	sv_catpvn(cat, null10, len);
4514	}
4515	}
4516	break;
4517	case 'B':
4518	case 'b':
4519	{
4520	register char *str;
4521	I32 saveitems;
4522
4523	fromstr = NEXTFROM;
4524	saveitems = items;
4525	str = SvPV(fromstr, fromlen);
4526	if (pat[-1] == '*')
4527	len = fromlen;
4528	aint = SvCUR(cat);
4529	SvCUR(cat) += (len+7)/8;
4530	SvGROW(cat, SvCUR(cat) + 1);
4531	aptr = SvPVX(cat) + aint;
4532	if (len > fromlen)
4533	len = fromlen;
4534	aint = len;
4535	items = 0;
4536	if (datumtype == 'B') {
4537	for (len = 0; len++ < aint;) {
4538	items \|= *str++ & 1;
4539	if (len & 7)
4540	items <<= 1;
4541	else {
4542	*aptr++ = items & 0xff;
4543	items = 0;
4544	}
4545	}
4546	}
4547	else {
4548	for (len = 0; len++ < aint;) {
4549	if (*str++ & 1)
4550	items \|= 128;
4551	if (len & 7)
4552	items >>= 1;
4553	else {
4554	*aptr++ = items & 0xff;
4555	items = 0;
4556	}
4557	}
4558	}
4559	if (aint & 7) {
4560	if (datumtype == 'B')
4561	items <<= 7 - (aint & 7);
4562	else
4563	items >>= 7 - (aint & 7);
4564	*aptr++ = items & 0xff;
4565	}
4566	str = SvPVX(cat) + SvCUR(cat);
4567	while (aptr <= str)
4568	*aptr++ = '\0';
4569
4570	items = saveitems;
4571	}
4572	break;
4573	case 'H':
4574	case 'h':
4575	{
4576	register char *str;
4577	I32 saveitems;
4578
4579	fromstr = NEXTFROM;
4580	saveitems = items;
4581	str = SvPV(fromstr, fromlen);
4582	if (pat[-1] == '*')
4583	len = fromlen;
4584	aint = SvCUR(cat);
4585	SvCUR(cat) += (len+1)/2;
4586	SvGROW(cat, SvCUR(cat) + 1);
4587	aptr = SvPVX(cat) + aint;
4588	if (len > fromlen)
4589	len = fromlen;
4590	aint = len;
4591	items = 0;
4592	if (datumtype == 'H') {
4593	for (len = 0; len++ < aint;) {
4594	if (isALPHA(*str))
4595	items \|= ((*str++ & 15) + 9) & 15;
4596	else
4597	items \|= *str++ & 15;
4598	if (len & 1)
4599	items <<= 4;
4600	else {
4601	*aptr++ = items & 0xff;
4602	items = 0;
4603	}
4604	}
4605	}
4606	else {
4607	for (len = 0; len++ < aint;) {
4608	if (isALPHA(*str))
4609	items \|= (((*str++ & 15) + 9) & 15) << 4;
4610	else
4611	items \|= (*str++ & 15) << 4;
4612	if (len & 1)
4613	items >>= 4;
4614	else {
4615	*aptr++ = items & 0xff;
4616	items = 0;
4617	}
4618	}
4619	}
4620	if (aint & 1)
4621	*aptr++ = items & 0xff;
4622	str = SvPVX(cat) + SvCUR(cat);
4623	while (aptr <= str)
4624	*aptr++ = '\0';
4625
4626	items = saveitems;
4627	}
4628	break;
4629	case 'C':
4630	case 'c':
4631	while (len-- > 0) {
4632	fromstr = NEXTFROM;
4633	aint = SvIV(fromstr);
4634	achar = aint;
4635	sv_catpvn(cat, &achar, sizeof(char));
4636	}
4637	break;
4638	case 'U':
4639	while (len-- > 0) {
4640	fromstr = NEXTFROM;
4641	auint = SvUV(fromstr);
4642	SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4643	SvCUR_set(cat, (char)uv_to_utf8((U8)SvEND(cat),auint)
4644	- SvPVX(cat));
4645	}
4646	*SvEND(cat) = '\0';
4647	break;
4648	/* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4649	case 'f':
4650	case 'F':
4651	while (len-- > 0) {
4652	fromstr = NEXTFROM;
4653	afloat = (float)SvNV(fromstr);
4654	sv_catpvn(cat, (char *)&afloat, sizeof (float));
4655	}
4656	break;
4657	case 'd':
4658	case 'D':
4659	while (len-- > 0) {
4660	fromstr = NEXTFROM;
4661	adouble = (double)SvNV(fromstr);
4662	sv_catpvn(cat, (char *)&adouble, sizeof (double));
4663	}
4664	break;
4665	case 'n':
4666	while (len-- > 0) {
4667	fromstr = NEXTFROM;
4668	ashort = (I16)SvIV(fromstr);
4669	#ifdef HAS_HTONS
4670	ashort = PerlSock_htons(ashort);
4671	#endif
4672	CAT16(cat, &ashort);
4673	}
4674	break;
4675	case 'v':
4676	while (len-- > 0) {
4677	fromstr = NEXTFROM;
4678	ashort = (I16)SvIV(fromstr);
4679	#ifdef HAS_HTOVS
4680	ashort = htovs(ashort);
4681	#endif
4682	CAT16(cat, &ashort);
4683	}
4684	break;
4685	case 'S':
4686	#if SHORTSIZE != SIZE16
4687	if (natint) {
4688	unsigned short aushort;
4689
4690	while (len-- > 0) {
4691	fromstr = NEXTFROM;
4692	aushort = SvUV(fromstr);
4693	sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4694	}
4695	}
4696	else
4697	#endif
4698	{
4699	U16 aushort;
4700
4701	while (len-- > 0) {
4702	fromstr = NEXTFROM;
4703	aushort = (U16)SvUV(fromstr);
4704	CAT16(cat, &aushort);
4705	}
4706
4707	}
4708	break;
4709	case 's':
4710	#if SHORTSIZE != SIZE16
4711	if (natint) {
4712	short ashort;
4713
4714	while (len-- > 0) {
4715	fromstr = NEXTFROM;
4716	ashort = SvIV(fromstr);
4717	sv_catpvn(cat, (char *)&ashort, sizeof(short));
4718	}
4719	}
4720	else
4721	#endif
4722	{
4723	while (len-- > 0) {
4724	fromstr = NEXTFROM;
4725	ashort = (I16)SvIV(fromstr);
4726	CAT16(cat, &ashort);
4727	}
4728	}
4729	break;
4730	case 'I':
4731	while (len-- > 0) {
4732	fromstr = NEXTFROM;
4733	auint = SvUV(fromstr);
4734	sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4735	}
4736	break;
4737	case 'w':
4738	while (len-- > 0) {
4739	fromstr = NEXTFROM;
4740	adouble = Perl_floor(SvNV(fromstr));
4741
4742	if (adouble < 0)
4743	DIE(aTHX_ "Cannot compress negative numbers");
4744
4745	if (
4746	#ifdef CXUX_BROKEN_CONSTANT_CONVERT
4747	adouble <= UV_MAX_cxux
4748	#else
4749	adouble <= UV_MAX
4750	#endif
4751	)
4752	{
4753	char buf[1 + sizeof(UV)];
4754	char *in = buf + sizeof(buf);
4755	UV auv = U_V(adouble);
4756
4757	do {
4758	*--in = (auv & 0x7f) \| 0x80;
4759	auv >>= 7;
4760	} while (auv);
4761	buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4762	sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4763	}
4764	else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4765	char from, result, *in;
4766	SV *norm;
4767	STRLEN len;
4768	bool done;
4769
4770	/* Copy string and check for compliance */
4771	from = SvPV(fromstr, len);
4772	if ((norm = is_an_int(from, len)) == NULL)
4773	DIE(aTHX_ "can compress only unsigned integer");
4774
4775	New('w', result, len, char);
4776	in = result + len;
4777	done = FALSE;
4778	while (!done)
4779	*--in = div128(norm, &done) \| 0x80;
4780	result[len - 1] &= 0x7F; /* clear continue bit */
4781	sv_catpvn(cat, in, (result + len) - in);
4782	Safefree(result);
4783	SvREFCNT_dec(norm); /* free norm */
4784	}
4785	else if (SvNOKp(fromstr)) {
4786	char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4787	char *in = buf + sizeof(buf);
4788
4789	do {
4790	double next = floor(adouble / 128);
4791	--in = (unsigned char)(adouble - (next 128)) \| 0x80;
4792	if (--in < buf) /* this cannot happen ;-) */
4793	DIE(aTHX_ "Cannot compress integer");
4794	adouble = next;
4795	} while (adouble > 0);
4796	buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4797	sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4798	}
4799	else
4800	DIE(aTHX_ "Cannot compress non integer");
4801	}
4802	break;
4803	case 'i':
4804	while (len-- > 0) {
4805	fromstr = NEXTFROM;
4806	aint = SvIV(fromstr);
4807	sv_catpvn(cat, (char*)&aint, sizeof(int));
4808	}
4809	break;
4810	case 'N':
4811	while (len-- > 0) {
4812	fromstr = NEXTFROM;
4813	aulong = SvUV(fromstr);
4814	#ifdef HAS_HTONL
4815	aulong = PerlSock_htonl(aulong);
4816	#endif
4817	CAT32(cat, &aulong);
4818	}
4819	break;
4820	case 'V':
4821	while (len-- > 0) {
4822	fromstr = NEXTFROM;
4823	aulong = SvUV(fromstr);
4824	#ifdef HAS_HTOVL
4825	aulong = htovl(aulong);
4826	#endif
4827	CAT32(cat, &aulong);
4828	}
4829	break;
4830	case 'L':
4831	#if LONGSIZE != SIZE32
4832	if (natint) {
4833	unsigned long aulong;
4834
4835	while (len-- > 0) {
4836	fromstr = NEXTFROM;
4837	aulong = SvUV(fromstr);
4838	sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4839	}
4840	}
4841	else
4842	#endif
4843	{
4844	while (len-- > 0) {
4845	fromstr = NEXTFROM;
4846	aulong = SvUV(fromstr);
4847	CAT32(cat, &aulong);
4848	}
4849	}
4850	break;
4851	case 'l':
4852	#if LONGSIZE != SIZE32
4853	if (natint) {
4854	long along;
4855
4856	while (len-- > 0) {
4857	fromstr = NEXTFROM;
4858	along = SvIV(fromstr);
4859	sv_catpvn(cat, (char *)&along, sizeof(long));
4860	}
4861	}
4862	else
4863	#endif
4864	{
4865	while (len-- > 0) {
4866	fromstr = NEXTFROM;
4867	along = SvIV(fromstr);
4868	CAT32(cat, &along);
4869	}
4870	}
4871	break;
4872	#ifdef HAS_QUAD
4873	case 'Q':
4874	while (len-- > 0) {
4875	fromstr = NEXTFROM;
4876	auquad = (Uquad_t)SvUV(fromstr);
4877	sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4878	}
4879	break;
4880	case 'q':
4881	while (len-- > 0) {
4882	fromstr = NEXTFROM;
4883	aquad = (Quad_t)SvIV(fromstr);
4884	sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4885	}
4886	break;
4887	#endif
4888	case 'P':
4889	len = 1; /* assume SV is correct length */
4890	/* FALL THROUGH */
4891	case 'p':
4892	while (len-- > 0) {
4893	fromstr = NEXTFROM;
4894	if (fromstr == &PL_sv_undef)
4895	aptr = NULL;
4896	else {
4897	STRLEN n_a;
4898	/* XXX better yet, could spirit away the string to
4899	* a safe spot and hang on to it until the result
4900	* of pack() (and all copies of the result) are
4901	* gone.
4902	*/
4903	if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4904	\|\| (SvPADTMP(fromstr)
4905	&& !SvREADONLY(fromstr))))
4906	{
4907	Perl_warner(aTHX_ WARN_PACK,
4908	"Attempt to pack pointer to temporary value");
4909	}
4910	if (SvPOK(fromstr) \|\| SvNIOK(fromstr))
4911	aptr = SvPV(fromstr,n_a);
4912	else
4913	aptr = SvPV_force(fromstr,n_a);
4914	}
4915	sv_catpvn(cat, (char)&aptr, sizeof(char));
4916	}
4917	break;
4918	case 'u':
4919	fromstr = NEXTFROM;
4920	aptr = SvPV(fromstr, fromlen);
4921	SvGROW(cat, fromlen * 4 / 3);
4922	if (len <= 1)
4923	len = 45;
4924	else
4925	len = len / 3 * 3;
4926	while (fromlen > 0) {
4927	I32 todo;
4928
4929	if (fromlen > len)
4930	todo = len;
4931	else
4932	todo = fromlen;
4933	doencodes(cat, aptr, todo);
4934	fromlen -= todo;
4935	aptr += todo;
4936	}
4937	break;
4938	}
4939	}
4940	SvSETMAGIC(cat);
4941	SP = ORIGMARK;
4942	PUSHs(cat);
4943	RETURN;
4944	}
4945	#undef NEXTFROM
4946
4947
4948	PP(pp_split)
4949	{
4950	djSP; dTARG;
4951	AV *ary;
4952	register I32 limit = POPi; /* note, negative is forever */
4953	SV *sv = POPs;
4954	STRLEN len;
4955	register char *s = SvPV(sv, len);
4956	char *strend = s + len;
4957	register PMOP *pm;
4958	register REGEXP *rx;
4959	register SV *dstr;
4960	register char *m;
4961	I32 iters = 0;
4962	I32 maxiters = (strend - s) + 10;
4963	I32 i;
4964	char *orig;
4965	I32 origlimit = limit;
4966	I32 realarray = 0;
4967	I32 base;
4968	AV *oldstack = PL_curstack;
4969	I32 gimme = GIMME_V;
4970	I32 oldsave = PL_savestack_ix;
4971	I32 make_mortal = 1;
4972	MAGIC mg = (MAGIC ) NULL;
4973
4974	#ifdef DEBUGGING
4975	Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4976	#else
4977	pm = (PMOP*)POPs;
4978	#endif
4979	if (!pm \|\| !s)
4980	DIE(aTHX_ "panic: do_split");
4981	rx = pm->op_pmregexp;
4982
4983	TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4984	(pm->op_pmflags & (PMf_WHITE \| PMf_SKIPWHITE)));
4985
4986	if (pm->op_pmreplroot) {
4987	#ifdef USE_ITHREADS
4988	ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4989	#else
4990	ary = GvAVn((GV*)pm->op_pmreplroot);
4991	#endif
4992	}
4993	else if (gimme != G_ARRAY)
4994	#ifdef USE_THREADS
4995	ary = (AV*)PL_curpad[0];
4996	#else
4997	ary = GvAVn(PL_defgv);
4998	#endif /* USE_THREADS */
4999	else
5000	ary = Nullav;
5001	if (ary && (gimme != G_ARRAY \|\| (pm->op_pmflags & PMf_ONCE))) {
5002	realarray = 1;
5003	PUTBACK;
5004	av_extend(ary,0);
5005	av_clear(ary);
5006	SPAGAIN;
5007	if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5008	PUSHMARK(SP);
5009	XPUSHs(SvTIED_obj((SV*)ary, mg));
5010	}
5011	else {
5012	if (!AvREAL(ary)) {
5013	AvREAL_on(ary);
5014	AvREIFY_off(ary);
5015	for (i = AvFILLp(ary); i >= 0; i--)
5016	AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5017	}
5018	/* temporarily switch stacks */
5019	SWITCHSTACK(PL_curstack, ary);
5020	make_mortal = 0;
5021	}
5022	}
5023	base = SP - PL_stack_base;
5024	orig = s;
5025	if (pm->op_pmflags & PMf_SKIPWHITE) {
5026	if (pm->op_pmflags & PMf_LOCALE) {
5027	while (isSPACE_LC(*s))
5028	s++;
5029	}
5030	else {
5031	while (isSPACE(*s))
5032	s++;
5033	}
5034	}
5035	if (pm->op_pmflags & (PMf_MULTILINE\|PMf_SINGLELINE)) {
5036	SAVEINT(PL_multiline);
5037	PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5038	}
5039
5040	if (!limit)
5041	limit = maxiters + 2;
5042	if (pm->op_pmflags & PMf_WHITE) {
5043	while (--limit) {
5044	m = s;
5045	while (m < strend &&
5046	!((pm->op_pmflags & PMf_LOCALE)
5047	? isSPACE_LC(m) : isSPACE(m)))
5048	++m;
5049	if (m >= strend)
5050	break;
5051
5052	dstr = NEWSV(30, m-s);
5053	sv_setpvn(dstr, s, m-s);
5054	if (make_mortal)
5055	sv_2mortal(dstr);
5056	XPUSHs(dstr);
5057
5058	s = m + 1;
5059	while (s < strend &&
5060	((pm->op_pmflags & PMf_LOCALE)
5061	? isSPACE_LC(s) : isSPACE(s)))
5062	++s;
5063	}
5064	}
5065	else if (strEQ("^", rx->precomp)) {
5066	while (--limit) {
5067	/SUPPRESS 530/
5068	for (m = s; m < strend && *m != '\n'; m++) ;
5069	m++;
5070	if (m >= strend)
5071	break;
5072	dstr = NEWSV(30, m-s);
5073	sv_setpvn(dstr, s, m-s);
5074	if (make_mortal)
5075	sv_2mortal(dstr);
5076	XPUSHs(dstr);
5077	s = m;
5078	}
5079	}
5080	else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5081	&& (rx->reganch & ROPT_CHECK_ALL)
5082	&& !(rx->reganch & ROPT_ANCH)) {
5083	int tail = (rx->reganch & RE_INTUIT_TAIL);
5084	SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5085	char c;
5086
5087	len = rx->minlen;
5088	if (len == 1 && !tail) {
5089	c = *SvPV(csv,len);
5090	while (--limit) {
5091	/SUPPRESS 530/
5092	for (m = s; m < strend && *m != c; m++) ;
5093	if (m >= strend)
5094	break;
5095	dstr = NEWSV(30, m-s);
5096	sv_setpvn(dstr, s, m-s);
5097	if (make_mortal)
5098	sv_2mortal(dstr);
5099	XPUSHs(dstr);
5100	s = m + 1;
5101	}
5102	}
5103	else {
5104	#ifndef lint
5105	while (s < strend && --limit &&
5106	(m = fbm_instr((unsigned char)s, (unsigned char)strend,
5107	csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5108	#endif
5109	{
5110	dstr = NEWSV(31, m-s);
5111	sv_setpvn(dstr, s, m-s);
5112	if (make_mortal)
5113	sv_2mortal(dstr);
5114	XPUSHs(dstr);
5115	s = m + len; /* Fake \n at the end */
5116	}
5117	}
5118	}
5119	else {
5120	maxiters += (strend - s) * rx->nparens;
5121	while (s < strend && --limit
5122	/* && (!rx->check_substr
5123	\|\| ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5124	0, NULL))))
5125	*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5126	1 /* minend */, sv, NULL, 0))
5127	{
5128	TAINT_IF(RX_MATCH_TAINTED(rx));
5129	if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5130	m = s;
5131	s = orig;
5132	orig = rx->subbeg;
5133	s = orig + (m - s);
5134	strend = s + (strend - m);
5135	}
5136	m = rx->startp[0] + orig;
5137	dstr = NEWSV(32, m-s);
5138	sv_setpvn(dstr, s, m-s);
5139	if (make_mortal)
5140	sv_2mortal(dstr);
5141	XPUSHs(dstr);
5142	if (rx->nparens) {
5143	for (i = 1; i <= rx->nparens; i++) {
5144	s = rx->startp[i] + orig;
5145	m = rx->endp[i] + orig;
5146	if (m && s) {
5147	dstr = NEWSV(33, m-s);
5148	sv_setpvn(dstr, s, m-s);
5149	}
5150	else
5151	dstr = NEWSV(33, 0);
5152	if (make_mortal)
5153	sv_2mortal(dstr);
5154	XPUSHs(dstr);
5155	}
5156	}
5157	s = rx->endp[0] + orig;
5158	}
5159	}
5160
5161	LEAVE_SCOPE(oldsave);
5162	iters = (SP - PL_stack_base) - base;
5163	if (iters > maxiters)
5164	DIE(aTHX_ "Split loop");
5165
5166	/* keep field after final delim? */
5167	if (s < strend \|\| (iters && origlimit)) {
5168	dstr = NEWSV(34, strend-s);
5169	sv_setpvn(dstr, s, strend-s);
5170	if (make_mortal)
5171	sv_2mortal(dstr);
5172	XPUSHs(dstr);
5173	iters++;
5174	}
5175	else if (!origlimit) {
5176	while (iters > 0 && (!TOPs \|\| !SvANY(TOPs) \|\| SvCUR(TOPs) == 0))
5177	iters--, SP--;
5178	}
5179
5180	if (realarray) {
5181	if (!mg) {
5182	SWITCHSTACK(ary, oldstack);
5183	if (SvSMAGICAL(ary)) {
5184	PUTBACK;
5185	mg_set((SV*)ary);
5186	SPAGAIN;
5187	}
5188	if (gimme == G_ARRAY) {
5189	EXTEND(SP, iters);
5190	Copy(AvARRAY(ary), SP + 1, iters, SV*);
5191	SP += iters;
5192	RETURN;
5193	}
5194	}
5195	else {
5196	PUTBACK;
5197	ENTER;
5198	call_method("PUSH",G_SCALAR\|G_DISCARD);
5199	LEAVE;
5200	SPAGAIN;
5201	if (gimme == G_ARRAY) {
5202	/* EXTEND should not be needed - we just popped them */
5203	EXTEND(SP, iters);
5204	for (i=0; i < iters; i++) {
5205	SV **svp = av_fetch(ary, i, FALSE);
5206	PUSHs((svp) ? *svp : &PL_sv_undef);
5207	}
5208	RETURN;
5209	}
5210	}
5211	}
5212	else {
5213	if (gimme == G_ARRAY)
5214	RETURN;
5215	}
5216	if (iters \|\| !pm->op_pmreplroot) {
5217	GETTARGET;
5218	PUSHi(iters);
5219	RETURN;
5220	}
5221	RETPUSHUNDEF;
5222	}
5223
5224	#ifdef USE_THREADS
5225	void
5226	Perl_unlock_condpair(pTHX_ void *svv)
5227	{
5228	dTHR;
5229	MAGIC mg = mg_find((SV)svv, 'm');
5230
5231	if (!mg)
5232	Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5233	MUTEX_LOCK(MgMUTEXP(mg));
5234	if (MgOWNER(mg) != thr)
5235	Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5236	MgOWNER(mg) = 0;
5237	COND_SIGNAL(MgOWNERCONDP(mg));
5238	DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5239	PTR2UV(thr), PTR2UV(svv));)
5240	MUTEX_UNLOCK(MgMUTEXP(mg));
5241	}
5242	#endif /* USE_THREADS */
5243
5244	PP(pp_lock)
5245	{
5246	djSP;
5247	dTOPss;
5248	SV *retsv = sv;
5249	#ifdef USE_THREADS
5250	MAGIC *mg;
5251
5252	if (SvROK(sv))
5253	sv = SvRV(sv);
5254
5255	mg = condpair_magic(sv);
5256	MUTEX_LOCK(MgMUTEXP(mg));
5257	if (MgOWNER(mg) == thr)
5258	MUTEX_UNLOCK(MgMUTEXP(mg));
5259	else {
5260	while (MgOWNER(mg))
5261	COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5262	MgOWNER(mg) = thr;
5263	DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5264	PTR2UV(thr), PTR2UV(sv));)
5265	MUTEX_UNLOCK(MgMUTEXP(mg));
5266	SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5267	}
5268	#endif /* USE_THREADS */
5269	if (SvTYPE(retsv) == SVt_PVAV \|\| SvTYPE(retsv) == SVt_PVHV
5270	\|\| SvTYPE(retsv) == SVt_PVCV) {
5271	retsv = refto(retsv);
5272	}
5273	SETs(retsv);
5274	RETURN;
5275	}
5276
5277	PP(pp_threadsv)
5278	{
5279	#ifdef USE_THREADS
5280	djSP;
5281	EXTEND(SP, 1);
5282	if (PL_op->op_private & OPpLVAL_INTRO)
5283	PUSHs(*save_threadsv(PL_op->op_targ));
5284	else
5285	PUSHs(THREADSV(PL_op->op_targ));
5286	RETURN;
5287	#else
5288	DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5289	#endif /* USE_THREADS */
5290	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: