Context Navigation

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

Visit:

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

Line
1	/* pp.c
2	*
3	* Copyright (c) 1991-1997, 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	#include "perl.h"
17
18	/*
19	* The compiler on Concurrent CX/UX systems has a subtle bug which only
20	* seems to show up when compiling pp.c - it generates the wrong double
21	* precision constant value for (double)UV_MAX when used inline in the body
22	* of the code below, so this makes a static variable up front (which the
23	* compiler seems to get correct) and uses it in place of UV_MAX below.
24	*/
25	#ifdef CXUX_BROKEN_CONSTANT_CONVERT
26	static double UV_MAX_cxux = ((double)UV_MAX);
27	#endif
28
29	/*
30	* Types used in bitwise operations.
31	*
32	* Normally we'd just use IV and UV. However, some hardware and
33	* software combinations (e.g. Alpha and current OSF/1) don't have a
34	* floating-point type to use for NV that has adequate bits to fully
35	* hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
36	*
37	* It just so happens that "int" is the right size almost everywhere.
38	*/
39	typedef int IBW;
40	typedef unsigned UBW;
41
42	/*
43	* Mask used after bitwise operations.
44	*
45	* There is at least one realm (Cray word machines) that doesn't
46	* have an integral type (except char) small enough to be represented
47	* in a double without loss; that is, it has no 32-bit type.
48	*/
49	#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
50	# define BW_BITS 32
51	# define BW_MASK ((1 << BW_BITS) - 1)
52	# define BW_SIGN (1 << (BW_BITS - 1))
53	# define BWi(i) (((i) & BW_SIGN) ? ((i) \| ~BW_MASK) : ((i) & BW_MASK))
54	# define BWu(u) ((u) & BW_MASK)
55	#else
56	# define BWi(i) (i)
57	# define BWu(u) (u)
58	#endif
59
60	/*
61	* Offset for integer pack/unpack.
62	*
63	* On architectures where I16 and I32 aren't really 16 and 32 bits,
64	* which for now are all Crays, pack and unpack have to play games.
65	*/
66
67	/*
68	* These values are required for portability of pack() output.
69	* If they're not right on your machine, then pack() and unpack()
70	* wouldn't work right anyway; you'll need to apply the Cray hack.
71	* (I'd like to check them with #if, but you can't use sizeof() in
72	* the preprocessor.)
73	*/
74	#define SIZE16 2
75	#define SIZE32 4
76
77	#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
78	# if BYTEORDER == 0x12345678
79	# define OFF16(p) (char*)(p)
80	# define OFF32(p) (char*)(p)
81	# else
82	# if BYTEORDER == 0x87654321
83	# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
84	# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
85	# else
86	}}}} bad cray byte order
87	# endif
88	# endif
89	# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
90	# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
91	# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
92	# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
93	#else
94	# define COPY16(s,p) Copy(s, p, SIZE16, char)
95	# define COPY32(s,p) Copy(s, p, SIZE32, char)
96	# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
97	# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
98	#endif
99
100	static void doencodes _((SV* sv, char* s, I32 len));
101	static SV* refto _((SV* sv));
102	static U32 seed _((void));
103
104	static bool srand_called = FALSE;
105
106	/* variations on pp_null */
107
108	PP(pp_stub)
109	{
110	dSP;
111	if (GIMME_V == G_SCALAR)
112	XPUSHs(&sv_undef);
113	RETURN;
114	}
115
116	PP(pp_scalar)
117	{
118	return NORMAL;
119	}
120
121	/* Pushy stuff. */
122
123	PP(pp_padav)
124	{
125	dSP; dTARGET;
126	if (op->op_private & OPpLVAL_INTRO)
127	SAVECLEARSV(curpad[op->op_targ]);
128	EXTEND(SP, 1);
129	if (op->op_flags & OPf_REF) {
130	PUSHs(TARG);
131	RETURN;
132	}
133	if (GIMME == G_ARRAY) {
134	I32 maxarg = AvFILL((AV*)TARG) + 1;
135	EXTEND(SP, maxarg);
136	Copy(AvARRAY((AV)TARG), SP+1, maxarg, SV);
137	SP += maxarg;
138	}
139	else {
140	SV* sv = sv_newmortal();
141	I32 maxarg = AvFILL((AV*)TARG) + 1;
142	sv_setiv(sv, maxarg);
143	PUSHs(sv);
144	}
145	RETURN;
146	}
147
148	PP(pp_padhv)
149	{
150	dSP; dTARGET;
151	I32 gimme;
152
153	XPUSHs(TARG);
154	if (op->op_private & OPpLVAL_INTRO)
155	SAVECLEARSV(curpad[op->op_targ]);
156	if (op->op_flags & OPf_REF)
157	RETURN;
158	gimme = GIMME_V;
159	if (gimme == G_ARRAY) {
160	RETURNOP(do_kv(ARGS));
161	}
162	else if (gimme == G_SCALAR) {
163	SV* sv = sv_newmortal();
164	if (HvFILL((HV*)TARG))
165	sv_setpvf(sv, "%ld/%ld",
166	(long)HvFILL((HV)TARG), (long)HvMAX((HV)TARG) + 1);
167	else
168	sv_setiv(sv, 0);
169	SETs(sv);
170	}
171	RETURN;
172	}
173
174	PP(pp_padany)
175	{
176	DIE("NOT IMPL LINE %d",__LINE__);
177	}
178
179	/* Translations. */
180
181	PP(pp_rv2gv)
182	{
183	dSP; dTOPss;
184
185	if (SvROK(sv)) {
186	wasref:
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	} else if (SvTYPE(sv) != SVt_PVGV)
195	DIE("Not a GLOB reference");
196	}
197	else {
198	if (SvTYPE(sv) != SVt_PVGV) {
199	char *sym;
200
201	if (SvGMAGICAL(sv)) {
202	mg_get(sv);
203	if (SvROK(sv))
204	goto wasref;
205	}
206	if (!SvOK(sv)) {
207	if (op->op_flags & OPf_REF \|\|
208	op->op_private & HINT_STRICT_REFS)
209	DIE(no_usym, "a symbol");
210	if (dowarn)
211	warn(warn_uninit);
212	RETSETUNDEF;
213	}
214	sym = SvPV(sv, na);
215	if (op->op_private & HINT_STRICT_REFS)
216	DIE(no_symref, sym, "a symbol");
217	sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
218	}
219	}
220	if (op->op_private & OPpLVAL_INTRO)
221	save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL));
222	SETs(sv);
223	RETURN;
224	}
225
226	PP(pp_rv2sv)
227	{
228	dSP; dTOPss;
229
230	if (SvROK(sv)) {
231	wasref:
232	sv = SvRV(sv);
233	switch (SvTYPE(sv)) {
234	case SVt_PVAV:
235	case SVt_PVHV:
236	case SVt_PVCV:
237	DIE("Not a SCALAR reference");
238	}
239	}
240	else {
241	GV gv = (GV)sv;
242	char *sym;
243
244	if (SvTYPE(gv) != SVt_PVGV) {
245	if (SvGMAGICAL(sv)) {
246	mg_get(sv);
247	if (SvROK(sv))
248	goto wasref;
249	}
250	if (!SvOK(sv)) {
251	if (op->op_flags & OPf_REF \|\|
252	op->op_private & HINT_STRICT_REFS)
253	DIE(no_usym, "a SCALAR");
254	if (dowarn)
255	warn(warn_uninit);
256	RETSETUNDEF;
257	}
258	sym = SvPV(sv, na);
259	if (op->op_private & HINT_STRICT_REFS)
260	DIE(no_symref, sym, "a SCALAR");
261	gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
262	}
263	sv = GvSV(gv);
264	}
265	if (op->op_flags & OPf_MOD) {
266	if (op->op_private & OPpLVAL_INTRO)
267	sv = save_scalar((GV*)TOPs);
268	else if (op->op_private & OPpDEREF)
269	vivify_ref(sv, op->op_private & OPpDEREF);
270	}
271	SETs(sv);
272	RETURN;
273	}
274
275	PP(pp_av2arylen)
276	{
277	dSP;
278	AV av = (AV)TOPs;
279	SV *sv = AvARYLEN(av);
280	if (!sv) {
281	AvARYLEN(av) = sv = NEWSV(0,0);
282	sv_upgrade(sv, SVt_IV);
283	sv_magic(sv, (SV*)av, '#', Nullch, 0);
284	}
285	SETs(sv);
286	RETURN;
287	}
288
289	PP(pp_pos)
290	{
291	dSP; dTARGET; dPOPss;
292
293	if (op->op_flags & OPf_MOD) {
294	if (SvTYPE(TARG) < SVt_PVLV) {
295	sv_upgrade(TARG, SVt_PVLV);
296	sv_magic(TARG, Nullsv, '.', Nullch, 0);
297	}
298
299	LvTYPE(TARG) = '.';
300	LvTARG(TARG) = sv;
301	PUSHs(TARG); /* no SvSETMAGIC */
302	RETURN;
303	}
304	else {
305	MAGIC* mg;
306
307	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
308	mg = mg_find(sv, 'g');
309	if (mg && mg->mg_len >= 0) {
310	PUSHi(mg->mg_len + curcop->cop_arybase);
311	RETURN;
312	}
313	}
314	RETPUSHUNDEF;
315	}
316	}
317
318	PP(pp_rv2cv)
319	{
320	dSP;
321	GV *gv;
322	HV *stash;
323
324	/* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
325	/* (But not in defined().) */
326	CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL));
327	if (cv) {
328	if (CvCLONE(cv))
329	cv = (CV)sv_2mortal((SV)cv_clone(cv));
330	}
331	else
332	cv = (CV*)&sv_undef;
333	SETs((SV*)cv);
334	RETURN;
335	}
336
337	PP(pp_prototype)
338	{
339	dSP;
340	CV *cv;
341	HV *stash;
342	GV *gv;
343	SV *ret;
344
345	ret = &sv_undef;
346	cv = sv_2cv(TOPs, &stash, &gv, FALSE);
347	if (cv && SvPOK(cv))
348	ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
349	SETs(ret);
350	RETURN;
351	}
352
353	PP(pp_anoncode)
354	{
355	dSP;
356	CV* cv = (CV*)curpad[op->op_targ];
357	if (CvCLONE(cv))
358	cv = (CV)sv_2mortal((SV)cv_clone(cv));
359	EXTEND(SP,1);
360	PUSHs((SV*)cv);
361	RETURN;
362	}
363
364	PP(pp_srefgen)
365	{
366	dSP;
367	SP = refto(SP);
368	RETURN;
369	}
370
371	PP(pp_refgen)
372	{
373	dSP; dMARK;
374	if (GIMME != G_ARRAY) {
375	MARK[1] = *SP;
376	SP = MARK + 1;
377	}
378	EXTEND_MORTAL(SP - MARK);
379	while (++MARK <= SP)
380	MARK = refto(MARK);
381	RETURN;
382	}
383
384	static SV*
385	refto(sv)
386	SV* sv;
387	{
388	SV* rv;
389
390	if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
391	if (LvTARGLEN(sv))
392	vivify_defelem(sv);
393	if (!(sv = LvTARG(sv)))
394	sv = &sv_undef;
395	}
396	else if (SvPADTMP(sv))
397	sv = newSVsv(sv);
398	else {
399	SvTEMP_off(sv);
400	(void)SvREFCNT_inc(sv);
401	}
402	rv = sv_newmortal();
403	sv_upgrade(rv, SVt_RV);
404	SvRV(rv) = sv;
405	SvROK_on(rv);
406	return rv;
407	}
408
409	PP(pp_ref)
410	{
411	dSP; dTARGET;
412	SV *sv;
413	char *pv;
414
415	sv = POPs;
416
417	if (sv && SvGMAGICAL(sv))
418	mg_get(sv);
419
420	if (!sv \|\| !SvROK(sv))
421	RETPUSHNO;
422
423	sv = SvRV(sv);
424	pv = sv_reftype(sv,TRUE);
425	PUSHp(pv, strlen(pv));
426	RETURN;
427	}
428
429	PP(pp_bless)
430	{
431	dSP;
432	HV *stash;
433
434	if (MAXARG == 1)
435	stash = curcop->cop_stash;
436	else
437	stash = gv_stashsv(POPs, TRUE);
438
439	(void)sv_bless(TOPs, stash);
440	RETURN;
441	}
442
443	PP(pp_gelem)
444	{
445	GV *gv;
446	SV *sv;
447	SV *ref;
448	char *elem;
449	dSP;
450
451	sv = POPs;
452	elem = SvPV(sv, na);
453	gv = (GV*)POPs;
454	ref = Nullsv;
455	sv = Nullsv;
456	switch (elem ? *elem : '\0')
457	{
458	case 'A':
459	if (strEQ(elem, "ARRAY"))
460	ref = (SV*)GvAV(gv);
461	break;
462	case 'C':
463	if (strEQ(elem, "CODE"))
464	ref = (SV*)GvCVu(gv);
465	break;
466	case 'F':
467	if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
468	ref = (SV*)GvIOp(gv);
469	break;
470	case 'G':
471	if (strEQ(elem, "GLOB"))
472	ref = (SV*)gv;
473	break;
474	case 'H':
475	if (strEQ(elem, "HASH"))
476	ref = (SV*)GvHV(gv);
477	break;
478	case 'I':
479	if (strEQ(elem, "IO"))
480	ref = (SV*)GvIOp(gv);
481	break;
482	case 'N':
483	if (strEQ(elem, "NAME"))
484	sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
485	break;
486	case 'P':
487	if (strEQ(elem, "PACKAGE"))
488	sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
489	break;
490	case 'S':
491	if (strEQ(elem, "SCALAR"))
492	ref = GvSV(gv);
493	break;
494	}
495	if (ref)
496	sv = newRV(ref);
497	if (sv)
498	sv_2mortal(sv);
499	else
500	sv = &sv_undef;
501	XPUSHs(sv);
502	RETURN;
503	}
504
505	/* Pattern matching */
506
507	PP(pp_study)
508	{
509	dSP; dPOPss;
510	register unsigned char *s;
511	register I32 pos;
512	register I32 ch;
513	register I32 *sfirst;
514	register I32 *snext;
515	STRLEN len;
516
517	if (sv == lastscream) {
518	if (SvSCREAM(sv))
519	RETPUSHYES;
520	}
521	else {
522	if (lastscream) {
523	SvSCREAM_off(lastscream);
524	SvREFCNT_dec(lastscream);
525	}
526	lastscream = SvREFCNT_inc(sv);
527	}
528
529	s = (unsigned char*)(SvPV(sv, len));
530	pos = len;
531	if (pos <= 0)
532	RETPUSHNO;
533	if (pos > maxscream) {
534	if (maxscream < 0) {
535	maxscream = pos + 80;
536	New(301, screamfirst, 256, I32);
537	New(302, screamnext, maxscream, I32);
538	}
539	else {
540	maxscream = pos + pos / 4;
541	Renew(screamnext, maxscream, I32);
542	}
543	}
544
545	sfirst = screamfirst;
546	snext = screamnext;
547
548	if (!sfirst \|\| !snext)
549	DIE("do_study: out of memory");
550
551	for (ch = 256; ch; --ch)
552	*sfirst++ = -1;
553	sfirst -= 256;
554
555	while (--pos >= 0) {
556	ch = s[pos];
557	if (sfirst[ch] >= 0)
558	snext[pos] = sfirst[ch] - pos;
559	else
560	snext[pos] = -pos;
561	sfirst[ch] = pos;
562	}
563
564	SvSCREAM_on(sv);
565	sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
566	RETPUSHYES;
567	}
568
569	PP(pp_trans)
570	{
571	dSP; dTARG;
572	SV *sv;
573
574	if (op->op_flags & OPf_STACKED)
575	sv = POPs;
576	else {
577	sv = GvSV(defgv);
578	EXTEND(SP,1);
579	}
580	TARG = sv_newmortal();
581	PUSHi(do_trans(sv, op));
582	RETURN;
583	}
584
585	/* Lvalue operators. */
586
587	PP(pp_schop)
588	{
589	dSP; dTARGET;
590	do_chop(TARG, TOPs);
591	SETTARG;
592	RETURN;
593	}
594
595	PP(pp_chop)
596	{
597	dSP; dMARK; dTARGET;
598	while (SP > MARK)
599	do_chop(TARG, POPs);
600	PUSHTARG;
601	RETURN;
602	}
603
604	PP(pp_schomp)
605	{
606	dSP; dTARGET;
607	SETi(do_chomp(TOPs));
608	RETURN;
609	}
610
611	PP(pp_chomp)
612	{
613	dSP; dMARK; dTARGET;
614	register I32 count = 0;
615
616	while (SP > MARK)
617	count += do_chomp(POPs);
618	PUSHi(count);
619	RETURN;
620	}
621
622	PP(pp_defined)
623	{
624	dSP;
625	register SV* sv;
626
627	sv = POPs;
628	if (!sv \|\| !SvANY(sv))
629	RETPUSHNO;
630	switch (SvTYPE(sv)) {
631	case SVt_PVAV:
632	if (AvMAX(sv) >= 0 \|\| SvGMAGICAL(sv))
633	RETPUSHYES;
634	break;
635	case SVt_PVHV:
636	if (HvARRAY(sv) \|\| SvGMAGICAL(sv))
637	RETPUSHYES;
638	break;
639	case SVt_PVCV:
640	if (CvROOT(sv) \|\| CvXSUB(sv))
641	RETPUSHYES;
642	break;
643	default:
644	if (SvGMAGICAL(sv))
645	mg_get(sv);
646	if (SvOK(sv))
647	RETPUSHYES;
648	}
649	RETPUSHNO;
650	}
651
652	PP(pp_undef)
653	{
654	dSP;
655	SV *sv;
656
657	if (!op->op_private) {
658	EXTEND(SP, 1);
659	RETPUSHUNDEF;
660	}
661
662	sv = POPs;
663	if (!sv)
664	RETPUSHUNDEF;
665
666	if (SvTHINKFIRST(sv)) {
667	if (SvREADONLY(sv))
668	RETPUSHUNDEF;
669	if (SvROK(sv))
670	sv_unref(sv);
671	}
672
673	switch (SvTYPE(sv)) {
674	case SVt_NULL:
675	break;
676	case SVt_PVAV:
677	av_undef((AV*)sv);
678	break;
679	case SVt_PVHV:
680	hv_undef((HV*)sv);
681	break;
682	case SVt_PVCV:
683	if (cv_const_sv((CV*)sv))
684	warn("Constant subroutine %s undefined",
685	CvANON((CV)sv) ? "(anonymous)" : GvENAME(CvGV((CV)sv)));
686	/* FALL THROUGH */
687	case SVt_PVFM:
688	{ GV* gv = (GV)SvREFCNT_inc(CvGV((CV)sv));
689	cv_undef((CV*)sv);
690	CvGV((CV)sv) = gv; } / let user-undef'd sub keep its identity */
691	break;
692	case SVt_PVGV:
693	if (SvFAKE(sv))
694	sv_setsv(sv, &sv_undef);
695	break;
696	default:
697	if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
698	(void)SvOOK_off(sv);
699	Safefree(SvPVX(sv));
700	SvPV_set(sv, Nullch);
701	SvLEN_set(sv, 0);
702	}
703	(void)SvOK_off(sv);
704	SvSETMAGIC(sv);
705	}
706
707	RETPUSHUNDEF;
708	}
709
710	PP(pp_predec)
711	{
712	dSP;
713	if (SvREADONLY(TOPs) \|\| SvTYPE(TOPs) > SVt_PVLV)
714	croak(no_modify);
715	if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
716	SvIVX(TOPs) != IV_MIN)
717	{
718	--SvIVX(TOPs);
719	SvFLAGS(TOPs) &= ~(SVp_NOK\|SVp_POK);
720	}
721	else
722	sv_dec(TOPs);
723	SvSETMAGIC(TOPs);
724	return NORMAL;
725	}
726
727	PP(pp_postinc)
728	{
729	dSP; dTARGET;
730	if (SvREADONLY(TOPs) \|\| SvTYPE(TOPs) > SVt_PVLV)
731	croak(no_modify);
732	sv_setsv(TARG, TOPs);
733	if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
734	SvIVX(TOPs) != IV_MAX)
735	{
736	++SvIVX(TOPs);
737	SvFLAGS(TOPs) &= ~(SVp_NOK\|SVp_POK);
738	}
739	else
740	sv_inc(TOPs);
741	SvSETMAGIC(TOPs);
742	if (!SvOK(TARG))
743	sv_setiv(TARG, 0);
744	SETs(TARG);
745	return NORMAL;
746	}
747
748	PP(pp_postdec)
749	{
750	dSP; dTARGET;
751	if(SvREADONLY(TOPs) \|\| SvTYPE(TOPs) > SVt_PVLV)
752	croak(no_modify);
753	sv_setsv(TARG, TOPs);
754	if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
755	SvIVX(TOPs) != IV_MIN)
756	{
757	--SvIVX(TOPs);
758	SvFLAGS(TOPs) &= ~(SVp_NOK\|SVp_POK);
759	}
760	else
761	sv_dec(TOPs);
762	SvSETMAGIC(TOPs);
763	SETs(TARG);
764	return NORMAL;
765	}
766
767	/* Ordinary operators. */
768
769	PP(pp_pow)
770	{
771	dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
772	{
773	dPOPTOPnnrl;
774	SETn( pow( left, right) );
775	RETURN;
776	}
777	}
778
779	PP(pp_multiply)
780	{
781	dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
782	{
783	dPOPTOPnnrl;
784	SETn( left * right );
785	RETURN;
786	}
787	}
788
789	PP(pp_divide)
790	{
791	dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
792	{
793	dPOPPOPnnrl;
794	double value;
795	if (right == 0.0)
796	DIE("Illegal division by zero");
797	#ifdef SLOPPYDIVIDE
798	/* insure that 20./5. == 4. */
799	{
800	IV k;
801	if ((double)I_V(left) == left &&
802	(double)I_V(right) == right &&
803	(k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
804	value = k;
805	} else {
806	value = left / right;
807	}
808	}
809	#else
810	value = left / right;
811	#endif
812	PUSHn( value );
813	RETURN;
814	}
815	}
816
817	PP(pp_modulo)
818	{
819	dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
820	{
821	UV left;
822	UV right;
823	bool left_neg;
824	bool right_neg;
825	UV ans;
826
827	if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
828	IV i = SvIVX(POPs);
829	right = (right_neg = (i < 0)) ? -i : i;
830	}
831	else {
832	double n = POPn;
833	right = U_V((right_neg = (n < 0)) ? -n : n);
834	}
835
836	if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
837	IV i = SvIVX(POPs);
838	left = (left_neg = (i < 0)) ? -i : i;
839	}
840	else {
841	double n = POPn;
842	left = U_V((left_neg = (n < 0)) ? -n : n);
843	}
844
845	if (!right)
846	DIE("Illegal modulus zero");
847
848	ans = left % right;
849	if ((left_neg != right_neg) && ans)
850	ans = right - ans;
851	if (right_neg) {
852	/* XXX may warn: unary minus operator applied to unsigned type */
853	/* could change -foo to be (~foo)+1 instead */
854	if (ans <= -(UV)IV_MAX)
855	sv_setiv(TARG, (IV) -ans);
856	else
857	sv_setnv(TARG, -(double)ans);
858	}
859	else
860	sv_setuv(TARG, ans);
861	PUSHTARG;
862	RETURN;
863	}
864	}
865
866	PP(pp_repeat)
867	{
868	dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
869	{
870	register I32 count = POPi;
871	if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
872	dMARK;
873	I32 items = SP - MARK;
874	I32 max;
875
876	max = items * count;
877	MEXTEND(MARK, max);
878	if (count > 1) {
879	while (SP > MARK) {
880	if (*SP)
881	SvTEMP_off((*SP));
882	SP--;
883	}
884	MARK++;
885	repeatcpy((char)(MARK + items), (char)MARK,
886	items * sizeof(SV*), count - 1);
887	SP += max;
888	}
889	else if (count <= 0)
890	SP -= items;
891	}
892	else { /* Note: mark already snarfed by pp_list */
893	SV *tmpstr;
894	STRLEN len;
895
896	tmpstr = POPs;
897	if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
898	if (SvREADONLY(tmpstr) && curcop != &compiling)
899	DIE("Can't x= to readonly value");
900	if (SvROK(tmpstr))
901	sv_unref(tmpstr);
902	}
903	SvSetSV(TARG, tmpstr);
904	SvPV_force(TARG, len);
905	if (count != 1) {
906	if (count < 1)
907	SvCUR_set(TARG, 0);
908	else {
909	SvGROW(TARG, (count * len) + 1);
910	repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
911	SvCUR(TARG) *= count;
912	}
913	*SvEND(TARG) = '\0';
914	}
915	(void)SvPOK_only(TARG);
916	PUSHTARG;
917	}
918	RETURN;
919	}
920	}
921
922	PP(pp_subtract)
923	{
924	dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
925	{
926	dPOPTOPnnrl_ul;
927	SETn( left - right );
928	RETURN;
929	}
930	}
931
932	PP(pp_left_shift)
933	{
934	dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
935	{
936	IBW shift = POPi;
937	if (op->op_private & HINT_INTEGER) {
938	IBW i = TOPi;
939	i = BWi(i) << shift;
940	SETi(BWi(i));
941	}
942	else {
943	UBW u = TOPu;
944	u <<= shift;
945	SETu(BWu(u));
946	}
947	RETURN;
948	}
949	}
950
951	PP(pp_right_shift)
952	{
953	dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
954	{
955	IBW shift = POPi;
956	if (op->op_private & HINT_INTEGER) {
957	IBW i = TOPi;
958	i = BWi(i) >> shift;
959	SETi(BWi(i));
960	}
961	else {
962	UBW u = TOPu;
963	u >>= shift;
964	SETu(BWu(u));
965	}
966	RETURN;
967	}
968	}
969
970	PP(pp_lt)
971	{
972	dSP; tryAMAGICbinSET(lt,0);
973	{
974	dPOPnv;
975	SETs(boolSV(TOPn < value));
976	RETURN;
977	}
978	}
979
980	PP(pp_gt)
981	{
982	dSP; tryAMAGICbinSET(gt,0);
983	{
984	dPOPnv;
985	SETs(boolSV(TOPn > value));
986	RETURN;
987	}
988	}
989
990	PP(pp_le)
991	{
992	dSP; tryAMAGICbinSET(le,0);
993	{
994	dPOPnv;
995	SETs(boolSV(TOPn <= value));
996	RETURN;
997	}
998	}
999
1000	PP(pp_ge)
1001	{
1002	dSP; tryAMAGICbinSET(ge,0);
1003	{
1004	dPOPnv;
1005	SETs(boolSV(TOPn >= value));
1006	RETURN;
1007	}
1008	}
1009
1010	PP(pp_ne)
1011	{
1012	dSP; tryAMAGICbinSET(ne,0);
1013	{
1014	dPOPnv;
1015	SETs(boolSV(TOPn != value));
1016	RETURN;
1017	}
1018	}
1019
1020	PP(pp_ncmp)
1021	{
1022	dSP; dTARGET; tryAMAGICbin(ncmp,0);
1023	{
1024	dPOPTOPnnrl;
1025	I32 value;
1026
1027	if (left == right)
1028	value = 0;
1029	else if (left < right)
1030	value = -1;
1031	else if (left > right)
1032	value = 1;
1033	else {
1034	SETs(&sv_undef);
1035	RETURN;
1036	}
1037	SETi(value);
1038	RETURN;
1039	}
1040	}
1041
1042	PP(pp_slt)
1043	{
1044	dSP; tryAMAGICbinSET(slt,0);
1045	{
1046	dPOPTOPssrl;
1047	int cmp = ((op->op_private & OPpLOCALE)
1048	? sv_cmp_locale(left, right)
1049	: sv_cmp(left, right));
1050	SETs(boolSV(cmp < 0));
1051	RETURN;
1052	}
1053	}
1054
1055	PP(pp_sgt)
1056	{
1057	dSP; tryAMAGICbinSET(sgt,0);
1058	{
1059	dPOPTOPssrl;
1060	int cmp = ((op->op_private & OPpLOCALE)
1061	? sv_cmp_locale(left, right)
1062	: sv_cmp(left, right));
1063	SETs(boolSV(cmp > 0));
1064	RETURN;
1065	}
1066	}
1067
1068	PP(pp_sle)
1069	{
1070	dSP; tryAMAGICbinSET(sle,0);
1071	{
1072	dPOPTOPssrl;
1073	int cmp = ((op->op_private & OPpLOCALE)
1074	? sv_cmp_locale(left, right)
1075	: sv_cmp(left, right));
1076	SETs(boolSV(cmp <= 0));
1077	RETURN;
1078	}
1079	}
1080
1081	PP(pp_sge)
1082	{
1083	dSP; tryAMAGICbinSET(sge,0);
1084	{
1085	dPOPTOPssrl;
1086	int cmp = ((op->op_private & OPpLOCALE)
1087	? sv_cmp_locale(left, right)
1088	: sv_cmp(left, right));
1089	SETs(boolSV(cmp >= 0));
1090	RETURN;
1091	}
1092	}
1093
1094	PP(pp_seq)
1095	{
1096	dSP; tryAMAGICbinSET(seq,0);
1097	{
1098	dPOPTOPssrl;
1099	SETs(boolSV(sv_eq(left, right)));
1100	RETURN;
1101	}
1102	}
1103
1104	PP(pp_sne)
1105	{
1106	dSP; tryAMAGICbinSET(sne,0);
1107	{
1108	dPOPTOPssrl;
1109	SETs(boolSV(!sv_eq(left, right)));
1110	RETURN;
1111	}
1112	}
1113
1114	PP(pp_scmp)
1115	{
1116	dSP; dTARGET; tryAMAGICbin(scmp,0);
1117	{
1118	dPOPTOPssrl;
1119	int cmp = ((op->op_private & OPpLOCALE)
1120	? sv_cmp_locale(left, right)
1121	: sv_cmp(left, right));
1122	SETi( cmp );
1123	RETURN;
1124	}
1125	}
1126
1127	PP(pp_bit_and)
1128	{
1129	dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1130	{
1131	dPOPTOPssrl;
1132	if (SvNIOKp(left) \|\| SvNIOKp(right)) {
1133	if (op->op_private & HINT_INTEGER) {
1134	IBW value = SvIV(left) & SvIV(right);
1135	SETi(BWi(value));
1136	}
1137	else {
1138	UBW value = SvUV(left) & SvUV(right);
1139	SETu(BWu(value));
1140	}
1141	}
1142	else {
1143	do_vop(op->op_type, TARG, left, right);
1144	SETTARG;
1145	}
1146	RETURN;
1147	}
1148	}
1149
1150	PP(pp_bit_xor)
1151	{
1152	dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1153	{
1154	dPOPTOPssrl;
1155	if (SvNIOKp(left) \|\| SvNIOKp(right)) {
1156	if (op->op_private & HINT_INTEGER) {
1157	IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1158	SETi(BWi(value));
1159	}
1160	else {
1161	UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1162	SETu(BWu(value));
1163	}
1164	}
1165	else {
1166	do_vop(op->op_type, TARG, left, right);
1167	SETTARG;
1168	}
1169	RETURN;
1170	}
1171	}
1172
1173	PP(pp_bit_or)
1174	{
1175	dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1176	{
1177	dPOPTOPssrl;
1178	if (SvNIOKp(left) \|\| SvNIOKp(right)) {
1179	if (op->op_private & HINT_INTEGER) {
1180	IBW value = (USE_LEFT(left) ? SvIV(left) : 0) \| SvIV(right);
1181	SETi(BWi(value));
1182	}
1183	else {
1184	UBW value = (USE_LEFT(left) ? SvUV(left) : 0) \| SvUV(right);
1185	SETu(BWu(value));
1186	}
1187	}
1188	else {
1189	do_vop(op->op_type, TARG, left, right);
1190	SETTARG;
1191	}
1192	RETURN;
1193	}
1194	}
1195
1196	PP(pp_negate)
1197	{
1198	dSP; dTARGET; tryAMAGICun(neg);
1199	{
1200	dTOPss;
1201	if (SvGMAGICAL(sv))
1202	mg_get(sv);
1203	if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1204	SETi(-SvIVX(sv));
1205	else if (SvNIOKp(sv))
1206	SETn(-SvNV(sv));
1207	else if (SvPOKp(sv)) {
1208	STRLEN len;
1209	char *s = SvPV(sv, len);
1210	if (isIDFIRST(*s)) {
1211	sv_setpvn(TARG, "-", 1);
1212	sv_catsv(TARG, sv);
1213	}
1214	else if (s == '+' \|\| s == '-') {
1215	sv_setsv(TARG, sv);
1216	SvPV_force(TARG, len) = s == '-' ? '+' : '-';
1217	}
1218	else
1219	sv_setnv(TARG, -SvNV(sv));
1220	SETTARG;
1221	}
1222	else
1223	SETn(-SvNV(sv));
1224	}
1225	RETURN;
1226	}
1227
1228	PP(pp_not)
1229	{
1230	#ifdef OVERLOAD
1231	dSP; tryAMAGICunSET(not);
1232	#endif /* OVERLOAD */
1233	stack_sp = boolSV(!SvTRUE(stack_sp));
1234	return NORMAL;
1235	}
1236
1237	PP(pp_complement)
1238	{
1239	dSP; dTARGET; tryAMAGICun(compl);
1240	{
1241	dTOPss;
1242	if (SvNIOKp(sv)) {
1243	if (op->op_private & HINT_INTEGER) {
1244	IBW value = ~SvIV(sv);
1245	SETi(BWi(value));
1246	}
1247	else {
1248	UBW value = ~SvUV(sv);
1249	SETu(BWu(value));
1250	}
1251	}
1252	else {
1253	register char *tmps;
1254	register long *tmpl;
1255	register I32 anum;
1256	STRLEN len;
1257
1258	SvSetSV(TARG, sv);
1259	tmps = SvPV_force(TARG, len);
1260	anum = len;
1261	#ifdef LIBERAL
1262	for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1263	tmps = ~tmps;
1264	tmpl = (long*)tmps;
1265	for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1266	tmpl = ~tmpl;
1267	tmps = (char*)tmpl;
1268	#endif
1269	for ( ; anum > 0; anum--, tmps++)
1270	tmps = ~tmps;
1271
1272	SETs(TARG);
1273	}
1274	RETURN;
1275	}
1276	}
1277
1278	/* integer versions of some of the above */
1279
1280	PP(pp_i_multiply)
1281	{
1282	dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1283	{
1284	dPOPTOPiirl;
1285	SETi( left * right );
1286	RETURN;
1287	}
1288	}
1289
1290	PP(pp_i_divide)
1291	{
1292	dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1293	{
1294	dPOPiv;
1295	if (value == 0)
1296	DIE("Illegal division by zero");
1297	value = POPi / value;
1298	PUSHi( value );
1299	RETURN;
1300	}
1301	}
1302
1303	PP(pp_i_modulo)
1304	{
1305	dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
1306	{
1307	dPOPTOPiirl;
1308	if (!right)
1309	DIE("Illegal modulus zero");
1310	SETi( left % right );
1311	RETURN;
1312	}
1313	}
1314
1315	PP(pp_i_add)
1316	{
1317	dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1318	{
1319	dPOPTOPiirl;
1320	SETi( left + right );
1321	RETURN;
1322	}
1323	}
1324
1325	PP(pp_i_subtract)
1326	{
1327	dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1328	{
1329	dPOPTOPiirl;
1330	SETi( left - right );
1331	RETURN;
1332	}
1333	}
1334
1335	PP(pp_i_lt)
1336	{
1337	dSP; tryAMAGICbinSET(lt,0);
1338	{
1339	dPOPTOPiirl;
1340	SETs(boolSV(left < right));
1341	RETURN;
1342	}
1343	}
1344
1345	PP(pp_i_gt)
1346	{
1347	dSP; tryAMAGICbinSET(gt,0);
1348	{
1349	dPOPTOPiirl;
1350	SETs(boolSV(left > right));
1351	RETURN;
1352	}
1353	}
1354
1355	PP(pp_i_le)
1356	{
1357	dSP; tryAMAGICbinSET(le,0);
1358	{
1359	dPOPTOPiirl;
1360	SETs(boolSV(left <= right));
1361	RETURN;
1362	}
1363	}
1364
1365	PP(pp_i_ge)
1366	{
1367	dSP; tryAMAGICbinSET(ge,0);
1368	{
1369	dPOPTOPiirl;
1370	SETs(boolSV(left >= right));
1371	RETURN;
1372	}
1373	}
1374
1375	PP(pp_i_eq)
1376	{
1377	dSP; tryAMAGICbinSET(eq,0);
1378	{
1379	dPOPTOPiirl;
1380	SETs(boolSV(left == right));
1381	RETURN;
1382	}
1383	}
1384
1385	PP(pp_i_ne)
1386	{
1387	dSP; tryAMAGICbinSET(ne,0);
1388	{
1389	dPOPTOPiirl;
1390	SETs(boolSV(left != right));
1391	RETURN;
1392	}
1393	}
1394
1395	PP(pp_i_ncmp)
1396	{
1397	dSP; dTARGET; tryAMAGICbin(ncmp,0);
1398	{
1399	dPOPTOPiirl;
1400	I32 value;
1401
1402	if (left > right)
1403	value = 1;
1404	else if (left < right)
1405	value = -1;
1406	else
1407	value = 0;
1408	SETi(value);
1409	RETURN;
1410	}
1411	}
1412
1413	PP(pp_i_negate)
1414	{
1415	dSP; dTARGET; tryAMAGICun(neg);
1416	SETi(-TOPi);
1417	RETURN;
1418	}
1419
1420	/* High falutin' math. */
1421
1422	PP(pp_atan2)
1423	{
1424	dSP; dTARGET; tryAMAGICbin(atan2,0);
1425	{
1426	dPOPTOPnnrl;
1427	SETn(atan2(left, right));
1428	RETURN;
1429	}
1430	}
1431
1432	PP(pp_sin)
1433	{
1434	dSP; dTARGET; tryAMAGICun(sin);
1435	{
1436	double value;
1437	value = POPn;
1438	value = sin(value);
1439	XPUSHn(value);
1440	RETURN;
1441	}
1442	}
1443
1444	PP(pp_cos)
1445	{
1446	dSP; dTARGET; tryAMAGICun(cos);
1447	{
1448	double value;
1449	value = POPn;
1450	value = cos(value);
1451	XPUSHn(value);
1452	RETURN;
1453	}
1454	}
1455
1456	PP(pp_rand)
1457	{
1458	dSP; dTARGET;
1459	double value;
1460	if (MAXARG < 1)
1461	value = 1.0;
1462	else
1463	value = POPn;
1464	if (value == 0.0)
1465	value = 1.0;
1466	if (!srand_called) {
1467	(void)srand((unsigned)seed());
1468	srand_called = TRUE;
1469	}
1470	#if RANDBITS == 31
1471	value = rand() * value / 2147483648.0;
1472	#else
1473	#if RANDBITS == 16
1474	value = rand() * value / 65536.0;
1475	#else
1476	#if RANDBITS == 15
1477	value = rand() * value / 32768.0;
1478	#else
1479	value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1480	#endif
1481	#endif
1482	#endif
1483	XPUSHn(value);
1484	RETURN;
1485	}
1486
1487	PP(pp_srand)
1488	{
1489	dSP;
1490	UV anum;
1491	if (MAXARG < 1)
1492	anum = seed();
1493	else
1494	anum = POPu;
1495	(void)srand((unsigned)anum);
1496	srand_called = TRUE;
1497	EXTEND(SP, 1);
1498	RETPUSHYES;
1499	}
1500
1501	static U32
1502	seed()
1503	{
1504	/*
1505	* This is really just a quick hack which grabs various garbage
1506	* values. It really should be a real hash algorithm which
1507	* spreads the effect of every input bit onto every output bit,
1508	* if someone who knows about such tings would bother to write it.
1509	* Might be a good idea to add that function to CORE as well.
1510	* No numbers below come from careful analysis or anyting here,
1511	* except they are primes and SEED_C1 > 1E6 to get a full-width
1512	* value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1513	* probably be bigger too.
1514	*/
1515	#if RANDBITS > 16
1516	# define SEED_C1 1000003
1517	#define SEED_C4 73819
1518	#else
1519	# define SEED_C1 25747
1520	#define SEED_C4 20639
1521	#endif
1522	#define SEED_C2 3
1523	#define SEED_C3 269
1524	#define SEED_C5 26107
1525
1526	U32 u;
1527	#ifdef VMS
1528	# include <starlet.h>
1529	/* when[] = (low 32 bits, high 32 bits) of time since epoch
1530	* in 100-ns units, typically incremented ever 10 ms. */
1531	unsigned int when[2];
1532	_ckvmssts(sys$gettim(when));
1533	u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1534	#else
1535	# ifdef HAS_GETTIMEOFDAY
1536	struct timeval when;
1537	gettimeofday(&when,(struct timezone *) 0);
1538	u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1539	# else
1540	Time_t when;
1541	(void)time(&when);
1542	u = (U32)SEED_C1 * when;
1543	# endif
1544	#endif
1545	u += SEED_C3 * (U32)getpid();
1546	u += SEED_C4 * (U32)(UV)stack_sp;
1547	#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1548	u += SEED_C5 * (U32)(UV)&when;
1549	#endif
1550	return u;
1551	}
1552
1553	PP(pp_exp)
1554	{
1555	dSP; dTARGET; tryAMAGICun(exp);
1556	{
1557	double value;
1558	value = POPn;
1559	value = exp(value);
1560	XPUSHn(value);
1561	RETURN;
1562	}
1563	}
1564
1565	PP(pp_log)
1566	{
1567	dSP; dTARGET; tryAMAGICun(log);
1568	{
1569	double value;
1570	value = POPn;
1571	if (value <= 0.0) {
1572	SET_NUMERIC_STANDARD();
1573	DIE("Can't take log of %g", value);
1574	}
1575	value = log(value);
1576	XPUSHn(value);
1577	RETURN;
1578	}
1579	}
1580
1581	PP(pp_sqrt)
1582	{
1583	dSP; dTARGET; tryAMAGICun(sqrt);
1584	{
1585	double value;
1586	value = POPn;
1587	if (value < 0.0) {
1588	SET_NUMERIC_STANDARD();
1589	DIE("Can't take sqrt of %g", value);
1590	}
1591	value = sqrt(value);
1592	XPUSHn(value);
1593	RETURN;
1594	}
1595	}
1596
1597	PP(pp_int)
1598	{
1599	dSP; dTARGET;
1600	{
1601	double value = TOPn;
1602	IV iv;
1603
1604	if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1605	iv = SvIVX(TOPs);
1606	SETi(iv);
1607	}
1608	else {
1609	if (value >= 0.0)
1610	(void)modf(value, &value);
1611	else {
1612	(void)modf(-value, &value);
1613	value = -value;
1614	}
1615	iv = I_V(value);
1616	if (iv == value)
1617	SETi(iv);
1618	else
1619	SETn(value);
1620	}
1621	}
1622	RETURN;
1623	}
1624
1625	PP(pp_abs)
1626	{
1627	dSP; dTARGET; tryAMAGICun(abs);
1628	{
1629	double value = TOPn;
1630	IV iv;
1631
1632	if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1633	(iv = SvIVX(TOPs)) != IV_MIN) {
1634	if (iv < 0)
1635	iv = -iv;
1636	SETi(iv);
1637	}
1638	else {
1639	if (value < 0.0)
1640	value = -value;
1641	SETn(value);
1642	}
1643	}
1644	RETURN;
1645	}
1646
1647	PP(pp_hex)
1648	{
1649	dSP; dTARGET;
1650	char *tmps;
1651	I32 argtype;
1652
1653	tmps = POPp;
1654	XPUSHu(scan_hex(tmps, 99, &argtype));
1655	RETURN;
1656	}
1657
1658	PP(pp_oct)
1659	{
1660	dSP; dTARGET;
1661	UV value;
1662	I32 argtype;
1663	char *tmps;
1664
1665	tmps = POPp;
1666	while (tmps && isSPACE(tmps))
1667	tmps++;
1668	if (*tmps == '0')
1669	tmps++;
1670	if (*tmps == 'x')
1671	value = scan_hex(++tmps, 99, &argtype);
1672	else
1673	value = scan_oct(tmps, 99, &argtype);
1674	XPUSHu(value);
1675	RETURN;
1676	}
1677
1678	/* String stuff. */
1679
1680	PP(pp_length)
1681	{
1682	dSP; dTARGET;
1683	SETi( sv_len(TOPs) );
1684	RETURN;
1685	}
1686
1687	PP(pp_substr)
1688	{
1689	dSP; dTARGET;
1690	SV *sv;
1691	I32 len;
1692	STRLEN curlen;
1693	I32 pos;
1694	I32 rem;
1695	I32 fail;
1696	I32 lvalue = op->op_flags & OPf_MOD;
1697	char *tmps;
1698	I32 arybase = curcop->cop_arybase;
1699
1700	if (MAXARG > 2)
1701	len = POPi;
1702	pos = POPi;
1703	sv = POPs;
1704	tmps = SvPV(sv, curlen);
1705	if (pos >= arybase) {
1706	pos -= arybase;
1707	rem = curlen-pos;
1708	fail = rem;
1709	if (MAXARG > 2) {
1710	if (len < 0) {
1711	rem += len;
1712	if (rem < 0)
1713	rem = 0;
1714	}
1715	else if (rem > len)
1716	rem = len;
1717	}
1718	}
1719	else {
1720	pos += curlen;
1721	if (MAXARG < 3)
1722	rem = curlen;
1723	else if (len >= 0) {
1724	rem = pos+len;
1725	if (rem > (I32)curlen)
1726	rem = curlen;
1727	}
1728	else {
1729	rem = curlen+len;
1730	if (rem < pos)
1731	rem = pos;
1732	}
1733	if (pos < 0)
1734	pos = 0;
1735	fail = rem;
1736	rem -= pos;
1737	}
1738	if (fail < 0) {
1739	if (dowarn \|\| lvalue)
1740	warn("substr outside of string");
1741	RETPUSHUNDEF;
1742	}
1743	else {
1744	tmps += pos;
1745	sv_setpvn(TARG, tmps, rem);
1746	if (lvalue) { /* it's an lvalue! */
1747	if (!SvGMAGICAL(sv)) {
1748	if (SvROK(sv)) {
1749	SvPV_force(sv,na);
1750	if (dowarn)
1751	warn("Attempt to use reference as lvalue in substr");
1752	}
1753	if (SvOK(sv)) /* is it defined ? */
1754	(void)SvPOK_only(sv);
1755	else
1756	sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1757	}
1758
1759	if (SvTYPE(TARG) < SVt_PVLV) {
1760	sv_upgrade(TARG, SVt_PVLV);
1761	sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1762	}
1763
1764	LvTYPE(TARG) = 'x';
1765	LvTARG(TARG) = sv;
1766	LvTARGOFF(TARG) = pos;
1767	LvTARGLEN(TARG) = rem;
1768	}
1769	}
1770	PUSHs(TARG); /* avoid SvSETMAGIC here */
1771	RETURN;
1772	}
1773
1774	PP(pp_vec)
1775	{
1776	dSP; dTARGET;
1777	register I32 size = POPi;
1778	register I32 offset = POPi;
1779	register SV *src = POPs;
1780	I32 lvalue = op->op_flags & OPf_MOD;
1781	STRLEN srclen;
1782	unsigned char s = (unsigned char)SvPV(src, srclen);
1783	unsigned long retnum;
1784	I32 len;
1785
1786	offset = size; / turn into bit offset */
1787	len = (offset + size + 7) / 8;
1788	if (offset < 0 \|\| size < 1)
1789	retnum = 0;
1790	else {
1791	if (lvalue) { /* it's an lvalue! */
1792	if (SvTYPE(TARG) < SVt_PVLV) {
1793	sv_upgrade(TARG, SVt_PVLV);
1794	sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1795	}
1796
1797	LvTYPE(TARG) = 'v';
1798	LvTARG(TARG) = src;
1799	LvTARGOFF(TARG) = offset;
1800	LvTARGLEN(TARG) = size;
1801	}
1802	if (len > srclen) {
1803	if (size <= 8)
1804	retnum = 0;
1805	else {
1806	offset >>= 3;
1807	if (size == 16) {
1808	if (offset >= srclen)
1809	retnum = 0;
1810	else
1811	retnum = (unsigned long) s[offset] << 8;
1812	}
1813	else if (size == 32) {
1814	if (offset >= srclen)
1815	retnum = 0;
1816	else if (offset + 1 >= srclen)
1817	retnum = (unsigned long) s[offset] << 24;
1818	else if (offset + 2 >= srclen)
1819	retnum = ((unsigned long) s[offset] << 24) +
1820	((unsigned long) s[offset + 1] << 16);
1821	else
1822	retnum = ((unsigned long) s[offset] << 24) +
1823	((unsigned long) s[offset + 1] << 16) +
1824	(s[offset + 2] << 8);
1825	}
1826	}
1827	}
1828	else if (size < 8)
1829	retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1830	else {
1831	offset >>= 3;
1832	if (size == 8)
1833	retnum = s[offset];
1834	else if (size == 16)
1835	retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1836	else if (size == 32)
1837	retnum = ((unsigned long) s[offset] << 24) +
1838	((unsigned long) s[offset + 1] << 16) +
1839	(s[offset + 2] << 8) + s[offset+3];
1840	}
1841	}
1842
1843	sv_setiv(TARG, (IV)retnum);
1844	PUSHs(TARG);
1845	RETURN;
1846	}
1847
1848	PP(pp_index)
1849	{
1850	dSP; dTARGET;
1851	SV *big;
1852	SV *little;
1853	I32 offset;
1854	I32 retval;
1855	char *tmps;
1856	char *tmps2;
1857	STRLEN biglen;
1858	I32 arybase = curcop->cop_arybase;
1859
1860	if (MAXARG < 3)
1861	offset = 0;
1862	else
1863	offset = POPi - arybase;
1864	little = POPs;
1865	big = POPs;
1866	tmps = SvPV(big, biglen);
1867	if (offset < 0)
1868	offset = 0;
1869	else if (offset > biglen)
1870	offset = biglen;
1871	if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
1872	(unsigned char*)tmps + biglen, little)))
1873	retval = -1 + arybase;
1874	else
1875	retval = tmps2 - tmps + arybase;
1876	PUSHi(retval);
1877	RETURN;
1878	}
1879
1880	PP(pp_rindex)
1881	{
1882	dSP; dTARGET;
1883	SV *big;
1884	SV *little;
1885	STRLEN blen;
1886	STRLEN llen;
1887	SV *offstr;
1888	I32 offset;
1889	I32 retval;
1890	char *tmps;
1891	char *tmps2;
1892	I32 arybase = curcop->cop_arybase;
1893
1894	if (MAXARG >= 3)
1895	offstr = POPs;
1896	little = POPs;
1897	big = POPs;
1898	tmps2 = SvPV(little, llen);
1899	tmps = SvPV(big, blen);
1900	if (MAXARG < 3)
1901	offset = blen;
1902	else
1903	offset = SvIV(offstr) - arybase + llen;
1904	if (offset < 0)
1905	offset = 0;
1906	else if (offset > blen)
1907	offset = blen;
1908	if (!(tmps2 = rninstr(tmps, tmps + offset,
1909	tmps2, tmps2 + llen)))
1910	retval = -1 + arybase;
1911	else
1912	retval = tmps2 - tmps + arybase;
1913	PUSHi(retval);
1914	RETURN;
1915	}
1916
1917	PP(pp_sprintf)
1918	{
1919	dSP; dMARK; dORIGMARK; dTARGET;
1920	#ifdef USE_LOCALE_NUMERIC
1921	if (op->op_private & OPpLOCALE)
1922	SET_NUMERIC_LOCAL();
1923	else
1924	SET_NUMERIC_STANDARD();
1925	#endif
1926	do_sprintf(TARG, SP-MARK, MARK+1);
1927	TAINT_IF(SvTAINTED(TARG));
1928	SP = ORIGMARK;
1929	PUSHTARG;
1930	RETURN;
1931	}
1932
1933	PP(pp_ord)
1934	{
1935	dSP; dTARGET;
1936	I32 value;
1937	char *tmps;
1938
1939	#ifndef I286
1940	tmps = POPp;
1941	value = (I32) (*tmps & 255);
1942	#else
1943	I32 anum;
1944	tmps = POPp;
1945	anum = (I32) *tmps;
1946	value = (I32) (anum & 255);
1947	#endif
1948	XPUSHi(value);
1949	RETURN;
1950	}
1951
1952	PP(pp_chr)
1953	{
1954	dSP; dTARGET;
1955	char *tmps;
1956
1957	(void)SvUPGRADE(TARG,SVt_PV);
1958	SvGROW(TARG,2);
1959	SvCUR_set(TARG, 1);
1960	tmps = SvPVX(TARG);
1961	*tmps++ = POPi;
1962	*tmps = '\0';
1963	(void)SvPOK_only(TARG);
1964	XPUSHs(TARG);
1965	RETURN;
1966	}
1967
1968	PP(pp_crypt)
1969	{
1970	dSP; dTARGET; dPOPTOPssrl;
1971	#ifdef HAS_CRYPT
1972	char *tmps = SvPV(left, na);
1973	#ifdef FCRYPT
1974	sv_setpv(TARG, fcrypt(tmps, SvPV(right, na)));
1975	#else
1976	sv_setpv(TARG, crypt(tmps, SvPV(right, na)));
1977	#endif
1978	#else
1979	DIE(
1980	"The crypt() function is unimplemented due to excessive paranoia.");
1981	#endif
1982	SETs(TARG);
1983	RETURN;
1984	}
1985
1986	PP(pp_ucfirst)
1987	{
1988	dSP;
1989	SV *sv = TOPs;
1990	register char *s;
1991
1992	if (!SvPADTMP(sv)) {
1993	dTARGET;
1994	sv_setsv(TARG, sv);
1995	sv = TARG;
1996	SETs(sv);
1997	}
1998	s = SvPV_force(sv, na);
1999	if (*s) {
2000	if (op->op_private & OPpLOCALE) {
2001	TAINT;
2002	SvTAINTED_on(sv);
2003	s = toUPPER_LC(s);
2004	}
2005	else
2006	s = toUPPER(s);
2007	}
2008
2009	RETURN;
2010	}
2011
2012	PP(pp_lcfirst)
2013	{
2014	dSP;
2015	SV *sv = TOPs;
2016	register char *s;
2017
2018	if (!SvPADTMP(sv)) {
2019	dTARGET;
2020	sv_setsv(TARG, sv);
2021	sv = TARG;
2022	SETs(sv);
2023	}
2024	s = SvPV_force(sv, na);
2025	if (*s) {
2026	if (op->op_private & OPpLOCALE) {
2027	TAINT;
2028	SvTAINTED_on(sv);
2029	s = toLOWER_LC(s);
2030	}
2031	else
2032	s = toLOWER(s);
2033	}
2034
2035	SETs(sv);
2036	RETURN;
2037	}
2038
2039	PP(pp_uc)
2040	{
2041	dSP;
2042	SV *sv = TOPs;
2043	register char *s;
2044	STRLEN len;
2045
2046	if (!SvPADTMP(sv)) {
2047	dTARGET;
2048	sv_setsv(TARG, sv);
2049	sv = TARG;
2050	SETs(sv);
2051	}
2052
2053	s = SvPV_force(sv, len);
2054	if (len) {
2055	register char *send = s + len;
2056
2057	if (op->op_private & OPpLOCALE) {
2058	TAINT;
2059	SvTAINTED_on(sv);
2060	for (; s < send; s++)
2061	s = toUPPER_LC(s);
2062	}
2063	else {
2064	for (; s < send; s++)
2065	s = toUPPER(s);
2066	}
2067	}
2068	RETURN;
2069	}
2070
2071	PP(pp_lc)
2072	{
2073	dSP;
2074	SV *sv = TOPs;
2075	register char *s;
2076	STRLEN len;
2077
2078	if (!SvPADTMP(sv)) {
2079	dTARGET;
2080	sv_setsv(TARG, sv);
2081	sv = TARG;
2082	SETs(sv);
2083	}
2084
2085	s = SvPV_force(sv, len);
2086	if (len) {
2087	register char *send = s + len;
2088
2089	if (op->op_private & OPpLOCALE) {
2090	TAINT;
2091	SvTAINTED_on(sv);
2092	for (; s < send; s++)
2093	s = toLOWER_LC(s);
2094	}
2095	else {
2096	for (; s < send; s++)
2097	s = toLOWER(s);
2098	}
2099	}
2100	RETURN;
2101	}
2102
2103	PP(pp_quotemeta)
2104	{
2105	dSP; dTARGET;
2106	SV *sv = TOPs;
2107	STRLEN len;
2108	register char *s = SvPV(sv,len);
2109	register char *d;
2110
2111	if (len) {
2112	(void)SvUPGRADE(TARG, SVt_PV);
2113	SvGROW(TARG, (len * 2) + 1);
2114	d = SvPVX(TARG);
2115	while (len--) {
2116	if (!isALNUM(*s))
2117	*d++ = '\\';
2118	d++ = s++;
2119	}
2120	*d = '\0';
2121	SvCUR_set(TARG, d - SvPVX(TARG));
2122	(void)SvPOK_only(TARG);
2123	}
2124	else
2125	sv_setpvn(TARG, s, len);
2126	SETs(TARG);
2127	RETURN;
2128	}
2129
2130	/* Arrays. */
2131
2132	PP(pp_aslice)
2133	{
2134	dSP; dMARK; dORIGMARK;
2135	register SV** svp;
2136	register AV* av = (AV*)POPs;
2137	register I32 lval = op->op_flags & OPf_MOD;
2138	I32 arybase = curcop->cop_arybase;
2139	I32 elem;
2140
2141	if (SvTYPE(av) == SVt_PVAV) {
2142	if (lval && op->op_private & OPpLVAL_INTRO) {
2143	I32 max = -1;
2144	for (svp = mark + 1; svp <= sp; svp++) {
2145	elem = SvIVx(*svp);
2146	if (elem > max)
2147	max = elem;
2148	}
2149	if (max > AvMAX(av))
2150	av_extend(av, max);
2151	}
2152	while (++MARK <= SP) {
2153	elem = SvIVx(*MARK);
2154
2155	if (elem > 0)
2156	elem -= arybase;
2157	svp = av_fetch(av, elem, lval);
2158	if (lval) {
2159	if (!svp \|\| *svp == &sv_undef)
2160	DIE(no_aelem, elem);
2161	if (op->op_private & OPpLVAL_INTRO)
2162	save_svref(svp);
2163	}
2164	MARK = svp ? svp : &sv_undef;
2165	}
2166	}
2167	if (GIMME != G_ARRAY) {
2168	MARK = ORIGMARK;
2169	++MARK = SP;
2170	SP = MARK;
2171	}
2172	RETURN;
2173	}
2174
2175	/* Associative arrays. */
2176
2177	PP(pp_each)
2178	{
2179	dSP; dTARGET;
2180	HV hash = (HV)POPs;
2181	HE *entry;
2182	I32 gimme = GIMME_V;
2183
2184	PUTBACK;
2185	entry = hv_iternext(hash); /* might clobber stack_sp */
2186	SPAGAIN;
2187
2188	EXTEND(SP, 2);
2189	if (entry) {
2190	PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2191	if (gimme == G_ARRAY) {
2192	PUTBACK;
2193	sv_setsv(TARG, hv_iterval(hash, entry)); /* might hit stack_sp */
2194	SPAGAIN;
2195	PUSHs(TARG);
2196	}
2197	}
2198	else if (gimme == G_SCALAR)
2199	RETPUSHUNDEF;
2200
2201	RETURN;
2202	}
2203
2204	PP(pp_values)
2205	{
2206	return do_kv(ARGS);
2207	}
2208
2209	PP(pp_keys)
2210	{
2211	return do_kv(ARGS);
2212	}
2213
2214	PP(pp_delete)
2215	{
2216	dSP;
2217	I32 gimme = GIMME_V;
2218	I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2219	SV *sv;
2220	HV *hv;
2221
2222	if (op->op_private & OPpSLICE) {
2223	dMARK; dORIGMARK;
2224	hv = (HV*)POPs;
2225	if (SvTYPE(hv) != SVt_PVHV)
2226	DIE("Not a HASH reference");
2227	while (++MARK <= SP) {
2228	sv = hv_delete_ent(hv, *MARK, discard, 0);
2229	*MARK = sv ? sv : &sv_undef;
2230	}
2231	if (discard)
2232	SP = ORIGMARK;
2233	else if (gimme == G_SCALAR) {
2234	MARK = ORIGMARK;
2235	++MARK = SP;
2236	SP = MARK;
2237	}
2238	}
2239	else {
2240	SV *keysv = POPs;
2241	hv = (HV*)POPs;
2242	if (SvTYPE(hv) != SVt_PVHV)
2243	DIE("Not a HASH reference");
2244	sv = hv_delete_ent(hv, keysv, discard, 0);
2245	if (!sv)
2246	sv = &sv_undef;
2247	if (!discard)
2248	PUSHs(sv);
2249	}
2250	RETURN;
2251	}
2252
2253	PP(pp_exists)
2254	{
2255	dSP;
2256	SV *tmpsv = POPs;
2257	HV hv = (HV)POPs;
2258	STRLEN len;
2259	if (SvTYPE(hv) != SVt_PVHV) {
2260	DIE("Not a HASH reference");
2261	}
2262	if (hv_exists_ent(hv, tmpsv, 0))
2263	RETPUSHYES;
2264	RETPUSHNO;
2265	}
2266
2267	PP(pp_hslice)
2268	{
2269	dSP; dMARK; dORIGMARK;
2270	register HE *he;
2271	register HV hv = (HV)POPs;
2272	register I32 lval = op->op_flags & OPf_MOD;
2273
2274	if (SvTYPE(hv) == SVt_PVHV) {
2275	while (++MARK <= SP) {
2276	SV keysv = MARK;
2277
2278	he = hv_fetch_ent(hv, keysv, lval, 0);
2279	if (lval) {
2280	if (!he \|\| HeVAL(he) == &sv_undef)
2281	DIE(no_helem, SvPV(keysv, na));
2282	if (op->op_private & OPpLVAL_INTRO)
2283	save_svref(&HeVAL(he));
2284	}
2285	*MARK = he ? HeVAL(he) : &sv_undef;
2286	}
2287	}
2288	if (GIMME != G_ARRAY) {
2289	MARK = ORIGMARK;
2290	++MARK = SP;
2291	SP = MARK;
2292	}
2293	RETURN;
2294	}
2295
2296	/* List operators. */
2297
2298	PP(pp_list)
2299	{
2300	dSP; dMARK;
2301	if (GIMME != G_ARRAY) {
2302	if (++MARK <= SP)
2303	MARK = SP; /* unwanted list, return last item */
2304	else
2305	*MARK = &sv_undef;
2306	SP = MARK;
2307	}
2308	RETURN;
2309	}
2310
2311	PP(pp_lslice)
2312	{
2313	dSP;
2314	SV **lastrelem = stack_sp;
2315	SV **lastlelem = stack_base + POPMARK;
2316	SV **firstlelem = stack_base + POPMARK + 1;
2317	register SV **firstrelem = lastlelem + 1;
2318	I32 arybase = curcop->cop_arybase;
2319	I32 lval = op->op_flags & OPf_MOD;
2320	I32 is_something_there = lval;
2321
2322	register I32 max = lastrelem - lastlelem;
2323	register SV **lelem;
2324	register I32 ix;
2325
2326	if (GIMME != G_ARRAY) {
2327	ix = SvIVx(*lastlelem);
2328	if (ix < 0)
2329	ix += max;
2330	else
2331	ix -= arybase;
2332	if (ix < 0 \|\| ix >= max)
2333	*firstlelem = &sv_undef;
2334	else
2335	*firstlelem = firstrelem[ix];
2336	SP = firstlelem;
2337	RETURN;
2338	}
2339
2340	if (max == 0) {
2341	SP = firstlelem - 1;
2342	RETURN;
2343	}
2344
2345	for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2346	ix = SvIVx(*lelem);
2347	if (ix < 0) {
2348	ix += max;
2349	if (ix < 0)
2350	*lelem = &sv_undef;
2351	else if (!(*lelem = firstrelem[ix]))
2352	*lelem = &sv_undef;
2353	}
2354	else {
2355	ix -= arybase;
2356	if (ix >= max \|\| !(*lelem = firstrelem[ix]))
2357	*lelem = &sv_undef;
2358	}
2359	if (!is_something_there && (SvOK(lelem) \|\| SvGMAGICAL(lelem)))
2360	is_something_there = TRUE;
2361	}
2362	if (is_something_there)
2363	SP = lastlelem;
2364	else
2365	SP = firstlelem - 1;
2366	RETURN;
2367	}
2368
2369	PP(pp_anonlist)
2370	{
2371	dSP; dMARK; dORIGMARK;
2372	I32 items = SP - MARK;
2373	SV av = sv_2mortal((SV)av_make(items, MARK+1));
2374	SP = ORIGMARK; /* av_make() might realloc stack_sp */
2375	XPUSHs(av);
2376	RETURN;
2377	}
2378
2379	PP(pp_anonhash)
2380	{
2381	dSP; dMARK; dORIGMARK;
2382	HV* hv = (HV)sv_2mortal((SV)newHV());
2383
2384	while (MARK < SP) {
2385	SV* key = *++MARK;
2386	SV *val = NEWSV(46, 0);
2387	if (MARK < SP)
2388	sv_setsv(val, *++MARK);
2389	else if (dowarn)
2390	warn("Odd number of elements in hash list");
2391	(void)hv_store_ent(hv,key,val,0);
2392	}
2393	SP = ORIGMARK;
2394	XPUSHs((SV*)hv);
2395	RETURN;
2396	}
2397
2398	PP(pp_splice)
2399	{
2400	dSP; dMARK; dORIGMARK;
2401	register AV ary = (AV)*++MARK;
2402	register SV **src;
2403	register SV **dst;
2404	register I32 i;
2405	register I32 offset;
2406	register I32 length;
2407	I32 newlen;
2408	I32 after;
2409	I32 diff;
2410	SV **tmparyval = 0;
2411
2412	SP++;
2413
2414	if (++MARK < SP) {
2415	offset = i = SvIVx(*MARK);
2416	if (offset < 0)
2417	offset += AvFILL(ary) + 1;
2418	else
2419	offset -= curcop->cop_arybase;
2420	if (offset < 0)
2421	DIE(no_aelem, i);
2422	if (++MARK < SP) {
2423	length = SvIVx(*MARK++);
2424	if (length < 0)
2425	length = 0;
2426	}
2427	else
2428	length = AvMAX(ary) + 1; /* close enough to infinity */
2429	}
2430	else {
2431	offset = 0;
2432	length = AvMAX(ary) + 1;
2433	}
2434	if (offset > AvFILL(ary) + 1)
2435	offset = AvFILL(ary) + 1;
2436	after = AvFILL(ary) + 1 - (offset + length);
2437	if (after < 0) { /* not that much array */
2438	length += after; /* offset+length now in array */
2439	after = 0;
2440	if (!AvALLOC(ary))
2441	av_extend(ary, 0);
2442	}
2443
2444	/* At this point, MARK .. SP-1 is our new LIST */
2445
2446	newlen = SP - MARK;
2447	diff = newlen - length;
2448	if (newlen && !AvREAL(ary)) {
2449	if (AvREIFY(ary))
2450	av_reify(ary);
2451	else
2452	assert(AvREAL(ary)); /* would leak, so croak */
2453	}
2454
2455	if (diff < 0) { /* shrinking the area */
2456	if (newlen) {
2457	New(451, tmparyval, newlen, SV); / so remember insertion */
2458	Copy(MARK, tmparyval, newlen, SV*);
2459	}
2460
2461	MARK = ORIGMARK + 1;
2462	if (GIMME == G_ARRAY) { /* copy return vals to stack */
2463	MEXTEND(MARK, length);
2464	Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2465	if (AvREAL(ary)) {
2466	EXTEND_MORTAL(length);
2467	for (i = length, dst = MARK; i; i--) {
2468	if (!SvIMMORTAL(*dst))
2469	sv_2mortal(dst); / free them eventualy */
2470	dst++;
2471	}
2472	}
2473	MARK += length - 1;
2474	}
2475	else {
2476	*MARK = AvARRAY(ary)[offset+length-1];
2477	if (AvREAL(ary)) {
2478	if (!SvIMMORTAL(*MARK))
2479	sv_2mortal(*MARK);
2480	for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2481	SvREFCNT_dec(dst++); / free them now */
2482	}
2483	}
2484	AvFILL(ary) += diff;
2485
2486	/* pull up or down? */
2487
2488	if (offset < after) { /* easier to pull up */
2489	if (offset) { /* esp. if nothing to pull */
2490	src = &AvARRAY(ary)[offset-1];
2491	dst = src - diff; /* diff is negative */
2492	for (i = offset; i > 0; i--) /* can't trust Copy */
2493	dst-- = src--;
2494	}
2495	dst = AvARRAY(ary);
2496	SvPVX(ary) = (char)(AvARRAY(ary) - diff); / diff is negative */
2497	AvMAX(ary) += diff;
2498	}
2499	else {
2500	if (after) { /* anything to pull down? */
2501	src = AvARRAY(ary) + offset + length;
2502	dst = src + diff; /* diff is negative */
2503	Move(src, dst, after, SV*);
2504	}
2505	dst = &AvARRAY(ary)[AvFILL(ary)+1];
2506	/* avoid later double free */
2507	}
2508	i = -diff;
2509	while (i)
2510	dst[--i] = &sv_undef;
2511
2512	if (newlen) {
2513	for (src = tmparyval, dst = AvARRAY(ary) + offset;
2514	newlen; newlen--) {
2515	*dst = NEWSV(46, 0);
2516	sv_setsv(dst++, src++);
2517	}
2518	Safefree(tmparyval);
2519	}
2520	}
2521	else { /* no, expanding (or same) */
2522	if (length) {
2523	New(452, tmparyval, length, SV); / so remember deletion */
2524	Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2525	}
2526
2527	if (diff > 0) { /* expanding */
2528
2529	/* push up or down? */
2530
2531	if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2532	if (offset) {
2533	src = AvARRAY(ary);
2534	dst = src - diff;
2535	Move(src, dst, offset, SV*);
2536	}
2537	SvPVX(ary) = (char)(AvARRAY(ary) - diff);/ diff is positive */
2538	AvMAX(ary) += diff;
2539	AvFILL(ary) += diff;
2540	}
2541	else {
2542	if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */
2543	av_extend(ary, AvFILL(ary) + diff);
2544	AvFILL(ary) += diff;
2545
2546	if (after) {
2547	dst = AvARRAY(ary) + AvFILL(ary);
2548	src = dst - diff;
2549	for (i = after; i; i--) {
2550	dst-- = src--;
2551	}
2552	}
2553	}
2554	}
2555
2556	for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2557	*dst = NEWSV(46, 0);
2558	sv_setsv(dst++, src++);
2559	}
2560	MARK = ORIGMARK + 1;
2561	if (GIMME == G_ARRAY) { /* copy return vals to stack */
2562	if (length) {
2563	Copy(tmparyval, MARK, length, SV*);
2564	if (AvREAL(ary)) {
2565	EXTEND_MORTAL(length);
2566	for (i = length, dst = MARK; i; i--) {
2567	if (!SvIMMORTAL(*dst))
2568	sv_2mortal(dst); / free them eventualy */
2569	dst++;
2570	}
2571	}
2572	Safefree(tmparyval);
2573	}
2574	MARK += length - 1;
2575	}
2576	else if (length--) {
2577	*MARK = tmparyval[length];
2578	if (AvREAL(ary)) {
2579	if (!SvIMMORTAL(*MARK))
2580	sv_2mortal(*MARK);
2581	while (length-- > 0)
2582	SvREFCNT_dec(tmparyval[length]);
2583	}
2584	Safefree(tmparyval);
2585	}
2586	else
2587	*MARK = &sv_undef;
2588	}
2589	SP = MARK;
2590	RETURN;
2591	}
2592
2593	PP(pp_push)
2594	{
2595	dSP; dMARK; dORIGMARK; dTARGET;
2596	register AV ary = (AV)*++MARK;
2597	register SV *sv = &sv_undef;
2598
2599	for (++MARK; MARK <= SP; MARK++) {
2600	sv = NEWSV(51, 0);
2601	if (*MARK)
2602	sv_setsv(sv, *MARK);
2603	av_push(ary, sv);
2604	}
2605	SP = ORIGMARK;
2606	PUSHi( AvFILL(ary) + 1 );
2607	RETURN;
2608	}
2609
2610	PP(pp_pop)
2611	{
2612	dSP;
2613	AV av = (AV)POPs;
2614	SV *sv = av_pop(av);
2615	if (!SvIMMORTAL(sv) && AvREAL(av))
2616	(void)sv_2mortal(sv);
2617	PUSHs(sv);
2618	RETURN;
2619	}
2620
2621	PP(pp_shift)
2622	{
2623	dSP;
2624	AV av = (AV)POPs;
2625	SV *sv = av_shift(av);
2626	EXTEND(SP, 1);
2627	if (!sv)
2628	RETPUSHUNDEF;
2629	if (!SvIMMORTAL(sv) && AvREAL(av))
2630	(void)sv_2mortal(sv);
2631	PUSHs(sv);
2632	RETURN;
2633	}
2634
2635	PP(pp_unshift)
2636	{
2637	dSP; dMARK; dORIGMARK; dTARGET;
2638	register AV ary = (AV)*++MARK;
2639	register SV *sv;
2640	register I32 i = 0;
2641
2642	av_unshift(ary, SP - MARK);
2643	while (MARK < SP) {
2644	sv = NEWSV(27, 0);
2645	sv_setsv(sv, *++MARK);
2646	(void)av_store(ary, i++, sv);
2647	}
2648
2649	SP = ORIGMARK;
2650	PUSHi( AvFILL(ary) + 1 );
2651	RETURN;
2652	}
2653
2654	PP(pp_reverse)
2655	{
2656	dSP; dMARK;
2657	register SV *tmp;
2658	SV **oldsp = SP;
2659
2660	if (GIMME == G_ARRAY) {
2661	MARK++;
2662	while (MARK < SP) {
2663	tmp = *MARK;
2664	MARK++ = SP;
2665	*SP-- = tmp;
2666	}
2667	SP = oldsp;
2668	}
2669	else {
2670	register char *up;
2671	register char *down;
2672	register I32 tmp;
2673	dTARGET;
2674	STRLEN len;
2675
2676	if (SP - MARK > 1)
2677	do_join(TARG, &sv_no, MARK, SP);
2678	else
2679	sv_setsv(TARG, (SP > MARK) ? *SP : GvSV(defgv));
2680	up = SvPV_force(TARG, len);
2681	if (len > 1) {
2682	down = SvPVX(TARG) + len - 1;
2683	while (down > up) {
2684	tmp = *up;
2685	up++ = down;
2686	*down-- = tmp;
2687	}
2688	(void)SvPOK_only(TARG);
2689	}
2690	SP = MARK + 1;
2691	SETTARG;
2692	}
2693	RETURN;
2694	}
2695
2696	static SV *
2697	mul128(sv, m)
2698	SV *sv;
2699	U8 m;
2700	{
2701	STRLEN len;
2702	char *s = SvPV(sv, len);
2703	char *t;
2704	U32 i = 0;
2705
2706	if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
2707	SV *new = newSVpv("0000000000", 10);
2708
2709	sv_catsv(new, sv);
2710	SvREFCNT_dec(sv); /* free old sv */
2711	sv = new;
2712	s = SvPV(sv, len);
2713	}
2714	t = s + len - 1;
2715	while (!t) / trailing '\0'? */
2716	t--;
2717	while (t > s) {
2718	i = ((*t - '0') << 7) + m;
2719	*(t--) = '0' + (i % 10);
2720	m = i / 10;
2721	}
2722	return (sv);
2723	}
2724
2725	/* Explosives and implosives. */
2726
2727	PP(pp_unpack)
2728	{
2729	dSP;
2730	dPOPPOPssrl;
2731	SV **oldsp = sp;
2732	I32 gimme = GIMME_V;
2733	SV *sv;
2734	STRLEN llen;
2735	STRLEN rlen;
2736	register char *pat = SvPV(left, llen);
2737	register char *s = SvPV(right, rlen);
2738	char *strend = s + rlen;
2739	char *strbeg = s;
2740	register char *patend = pat + llen;
2741	I32 datumtype;
2742	register I32 len;
2743	register I32 bits;
2744
2745	/* These must not be in registers: */
2746	I16 ashort;
2747	int aint;
2748	I32 along;
2749	#ifdef HAS_QUAD
2750	Quad_t aquad;
2751	#endif
2752	U16 aushort;
2753	unsigned int auint;
2754	U32 aulong;
2755	#ifdef HAS_QUAD
2756	unsigned Quad_t auquad;
2757	#endif
2758	char *aptr;
2759	float afloat;
2760	double adouble;
2761	I32 checksum = 0;
2762	register U32 culong;
2763	double cdouble;
2764	static char* bitcount = 0;
2765	int commas = 0;
2766
2767	if (gimme != G_ARRAY) { /* arrange to do first one only */
2768	/SUPPRESS 530/
2769	for (patend = pat; !isALPHA(patend) \|\| patend == 'x'; patend++) ;
2770	if (strchr("aAbBhHP", patend) \|\| pat == '%') {
2771	patend++;
2772	while (isDIGIT(patend) \|\| patend == '*')
2773	patend++;
2774	}
2775	else
2776	patend++;
2777	}
2778	while (pat < patend) {
2779	reparse:
2780	datumtype = *pat++ & 0xFF;
2781	if (isSPACE(datumtype))
2782	continue;
2783	if (pat >= patend)
2784	len = 1;
2785	else if (pat == '') {
2786	len = strend - strbeg; /* long enough */
2787	pat++;
2788	}
2789	else if (isDIGIT(*pat)) {
2790	len = *pat++ - '0';
2791	while (isDIGIT(*pat))
2792	len = (len * 10) + (*pat++ - '0');
2793	}
2794	else
2795	len = (datumtype != '@');
2796	switch(datumtype) {
2797	default:
2798	croak("Invalid type in unpack: '%c'", (int)datumtype);
2799	case ',': /* grandfather in commas but with a warning */
2800	if (commas++ == 0 && dowarn)
2801	warn("Invalid type in unpack: '%c'", (int)datumtype);
2802	break;
2803	case '%':
2804	if (len == 1 && pat[-1] != '1')
2805	len = 16;
2806	checksum = len;
2807	culong = 0;
2808	cdouble = 0;
2809	if (pat < patend)
2810	goto reparse;
2811	break;
2812	case '@':
2813	if (len > strend - strbeg)
2814	DIE("@ outside of string");
2815	s = strbeg + len;
2816	break;
2817	case 'X':
2818	if (len > s - strbeg)
2819	DIE("X outside of string");
2820	s -= len;
2821	break;
2822	case 'x':
2823	if (len > strend - s)
2824	DIE("x outside of string");
2825	s += len;
2826	break;
2827	case 'A':
2828	case 'a':
2829	if (len > strend - s)
2830	len = strend - s;
2831	if (checksum)
2832	goto uchar_checksum;
2833	sv = NEWSV(35, len);
2834	sv_setpvn(sv, s, len);
2835	s += len;
2836	if (datumtype == 'A') {
2837	aptr = s; /* borrow register */
2838	s = SvPVX(sv) + len - 1;
2839	while (s >= SvPVX(sv) && (!s \|\| isSPACE(s)))
2840	s--;
2841	*++s = '\0';
2842	SvCUR_set(sv, s - SvPVX(sv));
2843	s = aptr; /* unborrow register */
2844	}
2845	XPUSHs(sv_2mortal(sv));
2846	break;
2847	case 'B':
2848	case 'b':
2849	if (pat[-1] == '' \|\| len > (strend - s) 8)
2850	len = (strend - s) * 8;
2851	if (checksum) {
2852	if (!bitcount) {
2853	Newz(601, bitcount, 256, char);
2854	for (bits = 1; bits < 256; bits++) {
2855	if (bits & 1) bitcount[bits]++;
2856	if (bits & 2) bitcount[bits]++;
2857	if (bits & 4) bitcount[bits]++;
2858	if (bits & 8) bitcount[bits]++;
2859	if (bits & 16) bitcount[bits]++;
2860	if (bits & 32) bitcount[bits]++;
2861	if (bits & 64) bitcount[bits]++;
2862	if (bits & 128) bitcount[bits]++;
2863	}
2864	}
2865	while (len >= 8) {
2866	culong += bitcount[(unsigned char)s++];
2867	len -= 8;
2868	}
2869	if (len) {
2870	bits = *s;
2871	if (datumtype == 'b') {
2872	while (len-- > 0) {
2873	if (bits & 1) culong++;
2874	bits >>= 1;
2875	}
2876	}
2877	else {
2878	while (len-- > 0) {
2879	if (bits & 128) culong++;
2880	bits <<= 1;
2881	}
2882	}
2883	}
2884	break;
2885	}
2886	sv = NEWSV(35, len + 1);
2887	SvCUR_set(sv, len);
2888	SvPOK_on(sv);
2889	aptr = pat; /* borrow register */
2890	pat = SvPVX(sv);
2891	if (datumtype == 'b') {
2892	aint = len;
2893	for (len = 0; len < aint; len++) {
2894	if (len & 7) /SUPPRESS 595/
2895	bits >>= 1;
2896	else
2897	bits = *s++;
2898	*pat++ = '0' + (bits & 1);
2899	}
2900	}
2901	else {
2902	aint = len;
2903	for (len = 0; len < aint; len++) {
2904	if (len & 7)
2905	bits <<= 1;
2906	else
2907	bits = *s++;
2908	*pat++ = '0' + ((bits & 128) != 0);
2909	}
2910	}
2911	*pat = '\0';
2912	pat = aptr; /* unborrow register */
2913	XPUSHs(sv_2mortal(sv));
2914	break;
2915	case 'H':
2916	case 'h':
2917	if (pat[-1] == '' \|\| len > (strend - s) 2)
2918	len = (strend - s) * 2;
2919	sv = NEWSV(35, len + 1);
2920	SvCUR_set(sv, len);
2921	SvPOK_on(sv);
2922	aptr = pat; /* borrow register */
2923	pat = SvPVX(sv);
2924	if (datumtype == 'h') {
2925	aint = len;
2926	for (len = 0; len < aint; len++) {
2927	if (len & 1)
2928	bits >>= 4;
2929	else
2930	bits = *s++;
2931	*pat++ = hexdigit[bits & 15];
2932	}
2933	}
2934	else {
2935	aint = len;
2936	for (len = 0; len < aint; len++) {
2937	if (len & 1)
2938	bits <<= 4;
2939	else
2940	bits = *s++;
2941	*pat++ = hexdigit[(bits >> 4) & 15];
2942	}
2943	}
2944	*pat = '\0';
2945	pat = aptr; /* unborrow register */
2946	XPUSHs(sv_2mortal(sv));
2947	break;
2948	case 'c':
2949	if (len > strend - s)
2950	len = strend - s;
2951	if (checksum) {
2952	while (len-- > 0) {
2953	aint = *s++;
2954	if (aint >= 128) /* fake up signed chars */
2955	aint -= 256;
2956	culong += aint;
2957	}
2958	}
2959	else {
2960	EXTEND(SP, len);
2961	EXTEND_MORTAL(len);
2962	while (len-- > 0) {
2963	aint = *s++;
2964	if (aint >= 128) /* fake up signed chars */
2965	aint -= 256;
2966	sv = NEWSV(36, 0);
2967	sv_setiv(sv, (IV)aint);
2968	PUSHs(sv_2mortal(sv));
2969	}
2970	}
2971	break;
2972	case 'C':
2973	if (len > strend - s)
2974	len = strend - s;
2975	if (checksum) {
2976	uchar_checksum:
2977	while (len-- > 0) {
2978	auint = *s++ & 255;
2979	culong += auint;
2980	}
2981	}
2982	else {
2983	EXTEND(SP, len);
2984	EXTEND_MORTAL(len);
2985	while (len-- > 0) {
2986	auint = *s++ & 255;
2987	sv = NEWSV(37, 0);
2988	sv_setiv(sv, (IV)auint);
2989	PUSHs(sv_2mortal(sv));
2990	}
2991	}
2992	break;
2993	case 's':
2994	along = (strend - s) / SIZE16;
2995	if (len > along)
2996	len = along;
2997	if (checksum) {
2998	while (len-- > 0) {
2999	COPY16(s, &ashort);
3000	s += SIZE16;
3001	culong += ashort;
3002	}
3003	}
3004	else {
3005	EXTEND(SP, len);
3006	EXTEND_MORTAL(len);
3007	while (len-- > 0) {
3008	COPY16(s, &ashort);
3009	s += SIZE16;
3010	sv = NEWSV(38, 0);
3011	sv_setiv(sv, (IV)ashort);
3012	PUSHs(sv_2mortal(sv));
3013	}
3014	}
3015	break;
3016	case 'v':
3017	case 'n':
3018	case 'S':
3019	along = (strend - s) / SIZE16;
3020	if (len > along)
3021	len = along;
3022	if (checksum) {
3023	while (len-- > 0) {
3024	COPY16(s, &aushort);
3025	s += SIZE16;
3026	#ifdef HAS_NTOHS
3027	if (datumtype == 'n')
3028	aushort = ntohs(aushort);
3029	#endif
3030	#ifdef HAS_VTOHS
3031	if (datumtype == 'v')
3032	aushort = vtohs(aushort);
3033	#endif
3034	culong += aushort;
3035	}
3036	}
3037	else {
3038	EXTEND(SP, len);
3039	EXTEND_MORTAL(len);
3040	while (len-- > 0) {
3041	COPY16(s, &aushort);
3042	s += SIZE16;
3043	sv = NEWSV(39, 0);
3044	#ifdef HAS_NTOHS
3045	if (datumtype == 'n')
3046	aushort = ntohs(aushort);
3047	#endif
3048	#ifdef HAS_VTOHS
3049	if (datumtype == 'v')
3050	aushort = vtohs(aushort);
3051	#endif
3052	sv_setiv(sv, (IV)aushort);
3053	PUSHs(sv_2mortal(sv));
3054	}
3055	}
3056	break;
3057	case 'i':
3058	along = (strend - s) / sizeof(int);
3059	if (len > along)
3060	len = along;
3061	if (checksum) {
3062	while (len-- > 0) {
3063	Copy(s, &aint, 1, int);
3064	s += sizeof(int);
3065	if (checksum > 32)
3066	cdouble += (double)aint;
3067	else
3068	culong += aint;
3069	}
3070	}
3071	else {
3072	EXTEND(SP, len);
3073	EXTEND_MORTAL(len);
3074	while (len-- > 0) {
3075	Copy(s, &aint, 1, int);
3076	s += sizeof(int);
3077	sv = NEWSV(40, 0);
3078	sv_setiv(sv, (IV)aint);
3079	PUSHs(sv_2mortal(sv));
3080	}
3081	}
3082	break;
3083	case 'I':
3084	along = (strend - s) / sizeof(unsigned int);
3085	if (len > along)
3086	len = along;
3087	if (checksum) {
3088	while (len-- > 0) {
3089	Copy(s, &auint, 1, unsigned int);
3090	s += sizeof(unsigned int);
3091	if (checksum > 32)
3092	cdouble += (double)auint;
3093	else
3094	culong += auint;
3095	}
3096	}
3097	else {
3098	EXTEND(SP, len);
3099	EXTEND_MORTAL(len);
3100	while (len-- > 0) {
3101	Copy(s, &auint, 1, unsigned int);
3102	s += sizeof(unsigned int);
3103	sv = NEWSV(41, 0);
3104	sv_setuv(sv, (UV)auint);
3105	PUSHs(sv_2mortal(sv));
3106	}
3107	}
3108	break;
3109	case 'l':
3110	along = (strend - s) / SIZE32;
3111	if (len > along)
3112	len = along;
3113	if (checksum) {
3114	while (len-- > 0) {
3115	COPY32(s, &along);
3116	s += SIZE32;
3117	if (checksum > 32)
3118	cdouble += (double)along;
3119	else
3120	culong += along;
3121	}
3122	}
3123	else {
3124	EXTEND(SP, len);
3125	EXTEND_MORTAL(len);
3126	while (len-- > 0) {
3127	COPY32(s, &along);
3128	s += SIZE32;
3129	sv = NEWSV(42, 0);
3130	sv_setiv(sv, (IV)along);
3131	PUSHs(sv_2mortal(sv));
3132	}
3133	}
3134	break;
3135	case 'V':
3136	case 'N':
3137	case 'L':
3138	along = (strend - s) / SIZE32;
3139	if (len > along)
3140	len = along;
3141	if (checksum) {
3142	while (len-- > 0) {
3143	COPY32(s, &aulong);
3144	s += SIZE32;
3145	#ifdef HAS_NTOHL
3146	if (datumtype == 'N')
3147	aulong = ntohl(aulong);
3148	#endif
3149	#ifdef HAS_VTOHL
3150	if (datumtype == 'V')
3151	aulong = vtohl(aulong);
3152	#endif
3153	if (checksum > 32)
3154	cdouble += (double)aulong;
3155	else
3156	culong += aulong;
3157	}
3158	}
3159	else {
3160	EXTEND(SP, len);
3161	EXTEND_MORTAL(len);
3162	while (len-- > 0) {
3163	COPY32(s, &aulong);
3164	s += SIZE32;
3165	#ifdef HAS_NTOHL
3166	if (datumtype == 'N')
3167	aulong = ntohl(aulong);
3168	#endif
3169	#ifdef HAS_VTOHL
3170	if (datumtype == 'V')
3171	aulong = vtohl(aulong);
3172	#endif
3173	sv = NEWSV(43, 0);
3174	sv_setuv(sv, (UV)aulong);
3175	PUSHs(sv_2mortal(sv));
3176	}
3177	}
3178	break;
3179	case 'p':
3180	along = (strend - s) / sizeof(char*);
3181	if (len > along)
3182	len = along;
3183	EXTEND(SP, len);
3184	EXTEND_MORTAL(len);
3185	while (len-- > 0) {
3186	if (sizeof(char*) > strend - s)
3187	break;
3188	else {
3189	Copy(s, &aptr, 1, char*);
3190	s += sizeof(char*);
3191	}
3192	sv = NEWSV(44, 0);
3193	if (aptr)
3194	sv_setpv(sv, aptr);
3195	PUSHs(sv_2mortal(sv));
3196	}
3197	break;
3198	case 'w':
3199	EXTEND(SP, len);
3200	EXTEND_MORTAL(len);
3201	{
3202	UV auv = 0;
3203	U32 bytes = 0;
3204
3205	while ((len > 0) && (s < strend)) {
3206	auv = (auv << 7) \| (*s & 0x7f);
3207	if (!(*s++ & 0x80)) {
3208	bytes = 0;
3209	sv = NEWSV(40, 0);
3210	sv_setuv(sv, auv);
3211	PUSHs(sv_2mortal(sv));
3212	len--;
3213	auv = 0;
3214	}
3215	else if (++bytes >= sizeof(UV)) { /* promote to string */
3216	char *t;
3217
3218	sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3219	while (s < strend) {
3220	sv = mul128(sv, *s & 0x7f);
3221	if (!(*s++ & 0x80)) {
3222	bytes = 0;
3223	break;
3224	}
3225	}
3226	t = SvPV(sv, na);
3227	while (*t == '0')
3228	t++;
3229	sv_chop(sv, t);
3230	PUSHs(sv_2mortal(sv));
3231	len--;
3232	auv = 0;
3233	}
3234	}
3235	if ((s >= strend) && bytes)
3236	croak("Unterminated compressed integer");
3237	}
3238	break;
3239	case 'P':
3240	EXTEND(SP, 1);
3241	if (sizeof(char*) > strend - s)
3242	break;
3243	else {
3244	Copy(s, &aptr, 1, char*);
3245	s += sizeof(char*);
3246	}
3247	sv = NEWSV(44, 0);
3248	if (aptr)
3249	sv_setpvn(sv, aptr, len);
3250	PUSHs(sv_2mortal(sv));
3251	break;
3252	#ifdef HAS_QUAD
3253	case 'q':
3254	EXTEND(SP, len);
3255	EXTEND_MORTAL(len);
3256	while (len-- > 0) {
3257	if (s + sizeof(Quad_t) > strend)
3258	aquad = 0;
3259	else {
3260	Copy(s, &aquad, 1, Quad_t);
3261	s += sizeof(Quad_t);
3262	}
3263	sv = NEWSV(42, 0);
3264	if (aquad >= IV_MIN && aquad <= IV_MAX)
3265	sv_setiv(sv, (IV)aquad);
3266	else
3267	sv_setnv(sv, (double)aquad);
3268	PUSHs(sv_2mortal(sv));
3269	}
3270	break;
3271	case 'Q':
3272	EXTEND(SP, len);
3273	EXTEND_MORTAL(len);
3274	while (len-- > 0) {
3275	if (s + sizeof(unsigned Quad_t) > strend)
3276	auquad = 0;
3277	else {
3278	Copy(s, &auquad, 1, unsigned Quad_t);
3279	s += sizeof(unsigned Quad_t);
3280	}
3281	sv = NEWSV(43, 0);
3282	if (aquad <= UV_MAX)
3283	sv_setuv(sv, (UV)auquad);
3284	else
3285	sv_setnv(sv, (double)auquad);
3286	PUSHs(sv_2mortal(sv));
3287	}
3288	break;
3289	#endif
3290	/* float and double added gnb@melba.bby.oz.au 22/11/89 */
3291	case 'f':
3292	case 'F':
3293	along = (strend - s) / sizeof(float);
3294	if (len > along)
3295	len = along;
3296	if (checksum) {
3297	while (len-- > 0) {
3298	Copy(s, &afloat, 1, float);
3299	s += sizeof(float);
3300	cdouble += afloat;
3301	}
3302	}
3303	else {
3304	EXTEND(SP, len);
3305	EXTEND_MORTAL(len);
3306	while (len-- > 0) {
3307	Copy(s, &afloat, 1, float);
3308	s += sizeof(float);
3309	sv = NEWSV(47, 0);
3310	sv_setnv(sv, (double)afloat);
3311	PUSHs(sv_2mortal(sv));
3312	}
3313	}
3314	break;
3315	case 'd':
3316	case 'D':
3317	along = (strend - s) / sizeof(double);
3318	if (len > along)
3319	len = along;
3320	if (checksum) {
3321	while (len-- > 0) {
3322	Copy(s, &adouble, 1, double);
3323	s += sizeof(double);
3324	cdouble += adouble;
3325	}
3326	}
3327	else {
3328	EXTEND(SP, len);
3329	EXTEND_MORTAL(len);
3330	while (len-- > 0) {
3331	Copy(s, &adouble, 1, double);
3332	s += sizeof(double);
3333	sv = NEWSV(48, 0);
3334	sv_setnv(sv, (double)adouble);
3335	PUSHs(sv_2mortal(sv));
3336	}
3337	}
3338	break;
3339	case 'u':
3340	along = (strend - s) * 3 / 4;
3341	sv = NEWSV(42, along);
3342	if (along)
3343	SvPOK_on(sv);
3344	while (s < strend && s > ' ' && s < 'a') {
3345	I32 a, b, c, d;
3346	char hunk[4];
3347
3348	hunk[3] = '\0';
3349	len = (*s++ - ' ') & 077;
3350	while (len > 0) {
3351	if (s < strend && *s >= ' ')
3352	a = (*s++ - ' ') & 077;
3353	else
3354	a = 0;
3355	if (s < strend && *s >= ' ')
3356	b = (*s++ - ' ') & 077;
3357	else
3358	b = 0;
3359	if (s < strend && *s >= ' ')
3360	c = (*s++ - ' ') & 077;
3361	else
3362	c = 0;
3363	if (s < strend && *s >= ' ')
3364	d = (*s++ - ' ') & 077;
3365	else
3366	d = 0;
3367	hunk[0] = a << 2 \| b >> 4;
3368	hunk[1] = b << 4 \| c >> 2;
3369	hunk[2] = c << 6 \| d;
3370	sv_catpvn(sv, hunk, len > 3 ? 3 : len);
3371	len -= 3;
3372	}
3373	if (*s == '\n')
3374	s++;
3375	else if (s[1] == '\n') /* possible checksum byte */
3376	s += 2;
3377	}
3378	XPUSHs(sv_2mortal(sv));
3379	break;
3380	}
3381	if (checksum) {
3382	sv = NEWSV(42, 0);
3383	if (strchr("fFdD", datumtype) \|\|
3384	(checksum > 32 && strchr("iIlLN", datumtype)) ) {
3385	double trouble;
3386
3387	adouble = 1.0;
3388	while (checksum >= 16) {
3389	checksum -= 16;
3390	adouble *= 65536.0;
3391	}
3392	while (checksum >= 4) {
3393	checksum -= 4;
3394	adouble *= 16.0;
3395	}
3396	while (checksum--)
3397	adouble *= 2.0;
3398	along = (1 << checksum) - 1;
3399	while (cdouble < 0.0)
3400	cdouble += adouble;
3401	cdouble = modf(cdouble / adouble, &trouble) * adouble;
3402	sv_setnv(sv, cdouble);
3403	}
3404	else {
3405	if (checksum < 32) {
3406	aulong = (1 << checksum) - 1;
3407	culong &= aulong;
3408	}
3409	sv_setuv(sv, (UV)culong);
3410	}
3411	XPUSHs(sv_2mortal(sv));
3412	checksum = 0;
3413	}
3414	}
3415	if (sp == oldsp && gimme == G_SCALAR)
3416	PUSHs(&sv_undef);
3417	RETURN;
3418	}
3419
3420	static void
3421	doencodes(sv, s, len)
3422	register SV *sv;
3423	register char *s;
3424	register I32 len;
3425	{
3426	char hunk[5];
3427
3428	*hunk = len + ' ';
3429	sv_catpvn(sv, hunk, 1);
3430	hunk[4] = '\0';
3431	while (len > 0) {
3432	hunk[0] = ' ' + (077 & (*s >> 2));
3433	hunk[1] = ' ' + (077 & ((*s << 4) & 060 \| (s[1] >> 4) & 017));
3434	hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 \| (s[2] >> 6) & 03));
3435	hunk[3] = ' ' + (077 & (s[2] & 077));
3436	sv_catpvn(sv, hunk, 4);
3437	s += 3;
3438	len -= 3;
3439	}
3440	for (s = SvPVX(sv); *s; s++) {
3441	if (*s == ' ')
3442	*s = '`';
3443	}
3444	sv_catpvn(sv, "\n", 1);
3445	}
3446
3447	static SV *
3448	is_an_int(s, l)
3449	char *s;
3450	STRLEN l;
3451	{
3452	SV *result = newSVpv("", l);
3453	char result_c = SvPV(result, na); / convenience */
3454	char *out = result_c;
3455	bool skip = 1;
3456	bool ignore = 0;
3457
3458	while (*s) {
3459	switch (*s) {
3460	case ' ':
3461	break;
3462	case '+':
3463	if (!skip) {
3464	SvREFCNT_dec(result);
3465	return (NULL);
3466	}
3467	break;
3468	case '0':
3469	case '1':
3470	case '2':
3471	case '3':
3472	case '4':
3473	case '5':
3474	case '6':
3475	case '7':
3476	case '8':
3477	case '9':
3478	skip = 0;
3479	if (!ignore) {
3480	(out++) = s;
3481	}
3482	break;
3483	case '.':
3484	ignore = 1;
3485	break;
3486	default:
3487	SvREFCNT_dec(result);
3488	return (NULL);
3489	}
3490	s++;
3491	}
3492	*(out++) = '\0';
3493	SvCUR_set(result, out - result_c);
3494	return (result);
3495	}
3496
3497	static int
3498	div128(pnum, done)
3499	SV pnum; / must be '\0' terminated */
3500	bool *done;
3501	{
3502	STRLEN len;
3503	char *s = SvPV(pnum, len);
3504	int m = 0;
3505	int r = 0;
3506	char *t = s;
3507
3508	*done = 1;
3509	while (*t) {
3510	int i;
3511
3512	i = m * 10 + (*t - '0');
3513	m = i & 0x7F;
3514	r = (i >> 7); /* r < 10 */
3515	if (r) {
3516	*done = 0;
3517	}
3518	*(t++) = '0' + r;
3519	}
3520	*(t++) = '\0';
3521	SvCUR_set(pnum, (STRLEN) (t - s));
3522	return (m);
3523	}
3524
3525
3526	PP(pp_pack)
3527	{
3528	dSP; dMARK; dORIGMARK; dTARGET;
3529	register SV *cat = TARG;
3530	register I32 items;
3531	STRLEN fromlen;
3532	register char pat = SvPVx(++MARK, fromlen);
3533	register char *patend = pat + fromlen;
3534	register I32 len;
3535	I32 datumtype;
3536	SV *fromstr;
3537	/SUPPRESS 442/
3538	static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3539	static char *space10 = " ";
3540
3541	/* These must not be in registers: */
3542	char achar;
3543	I16 ashort;
3544	int aint;
3545	unsigned int auint;
3546	I32 along;
3547	U32 aulong;
3548	#ifdef HAS_QUAD
3549	Quad_t aquad;
3550	unsigned Quad_t auquad;
3551	#endif
3552	char *aptr;
3553	float afloat;
3554	double adouble;
3555	int commas = 0;
3556
3557	items = SP - MARK;
3558	MARK++;
3559	sv_setpvn(cat, "", 0);
3560	while (pat < patend) {
3561	#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
3562	datumtype = *pat++ & 0xFF;
3563	if (isSPACE(datumtype))
3564	continue;
3565	if (pat == '') {
3566	len = strchr("@Xxu", datumtype) ? 0 : items;
3567	pat++;
3568	}
3569	else if (isDIGIT(*pat)) {
3570	len = *pat++ - '0';
3571	while (isDIGIT(*pat))
3572	len = (len * 10) + (*pat++ - '0');
3573	}
3574	else
3575	len = 1;
3576	switch(datumtype) {
3577	default:
3578	croak("Invalid type in pack: '%c'", (int)datumtype);
3579	case ',': /* grandfather in commas but with a warning */
3580	if (commas++ == 0 && dowarn)
3581	warn("Invalid type in pack: '%c'", (int)datumtype);
3582	break;
3583	case '%':
3584	DIE("%% may only be used in unpack");
3585	case '@':
3586	len -= SvCUR(cat);
3587	if (len > 0)
3588	goto grow;
3589	len = -len;
3590	if (len > 0)
3591	goto shrink;
3592	break;
3593	case 'X':
3594	shrink:
3595	if (SvCUR(cat) < len)
3596	DIE("X outside of string");
3597	SvCUR(cat) -= len;
3598	*SvEND(cat) = '\0';
3599	break;
3600	case 'x':
3601	grow:
3602	while (len >= 10) {
3603	sv_catpvn(cat, null10, 10);
3604	len -= 10;
3605	}
3606	sv_catpvn(cat, null10, len);
3607	break;
3608	case 'A':
3609	case 'a':
3610	fromstr = NEXTFROM;
3611	aptr = SvPV(fromstr, fromlen);
3612	if (pat[-1] == '*')
3613	len = fromlen;
3614	if (fromlen > len)
3615	sv_catpvn(cat, aptr, len);
3616	else {
3617	sv_catpvn(cat, aptr, fromlen);
3618	len -= fromlen;
3619	if (datumtype == 'A') {
3620	while (len >= 10) {
3621	sv_catpvn(cat, space10, 10);
3622	len -= 10;
3623	}
3624	sv_catpvn(cat, space10, len);
3625	}
3626	else {
3627	while (len >= 10) {
3628	sv_catpvn(cat, null10, 10);
3629	len -= 10;
3630	}
3631	sv_catpvn(cat, null10, len);
3632	}
3633	}
3634	break;
3635	case 'B':
3636	case 'b':
3637	{
3638	char *savepat = pat;
3639	I32 saveitems;
3640
3641	fromstr = NEXTFROM;
3642	saveitems = items;
3643	aptr = SvPV(fromstr, fromlen);
3644	if (pat[-1] == '*')
3645	len = fromlen;
3646	pat = aptr;
3647	aint = SvCUR(cat);
3648	SvCUR(cat) += (len+7)/8;
3649	SvGROW(cat, SvCUR(cat) + 1);
3650	aptr = SvPVX(cat) + aint;
3651	if (len > fromlen)
3652	len = fromlen;
3653	aint = len;
3654	items = 0;
3655	if (datumtype == 'B') {
3656	for (len = 0; len++ < aint;) {
3657	items \|= *pat++ & 1;
3658	if (len & 7)
3659	items <<= 1;
3660	else {
3661	*aptr++ = items & 0xff;
3662	items = 0;
3663	}
3664	}
3665	}
3666	else {
3667	for (len = 0; len++ < aint;) {
3668	if (*pat++ & 1)
3669	items \|= 128;
3670	if (len & 7)
3671	items >>= 1;
3672	else {
3673	*aptr++ = items & 0xff;
3674	items = 0;
3675	}
3676	}
3677	}
3678	if (aint & 7) {
3679	if (datumtype == 'B')
3680	items <<= 7 - (aint & 7);
3681	else
3682	items >>= 7 - (aint & 7);
3683	*aptr++ = items & 0xff;
3684	}
3685	pat = SvPVX(cat) + SvCUR(cat);
3686	while (aptr <= pat)
3687	*aptr++ = '\0';
3688
3689	pat = savepat;
3690	items = saveitems;
3691	}
3692	break;
3693	case 'H':
3694	case 'h':
3695	{
3696	char *savepat = pat;
3697	I32 saveitems;
3698
3699	fromstr = NEXTFROM;
3700	saveitems = items;
3701	aptr = SvPV(fromstr, fromlen);
3702	if (pat[-1] == '*')
3703	len = fromlen;
3704	pat = aptr;
3705	aint = SvCUR(cat);
3706	SvCUR(cat) += (len+1)/2;
3707	SvGROW(cat, SvCUR(cat) + 1);
3708	aptr = SvPVX(cat) + aint;
3709	if (len > fromlen)
3710	len = fromlen;
3711	aint = len;
3712	items = 0;
3713	if (datumtype == 'H') {
3714	for (len = 0; len++ < aint;) {
3715	if (isALPHA(*pat))
3716	items \|= ((*pat++ & 15) + 9) & 15;
3717	else
3718	items \|= *pat++ & 15;
3719	if (len & 1)
3720	items <<= 4;
3721	else {
3722	*aptr++ = items & 0xff;
3723	items = 0;
3724	}
3725	}
3726	}
3727	else {
3728	for (len = 0; len++ < aint;) {
3729	if (isALPHA(*pat))
3730	items \|= (((*pat++ & 15) + 9) & 15) << 4;
3731	else
3732	items \|= (*pat++ & 15) << 4;
3733	if (len & 1)
3734	items >>= 4;
3735	else {
3736	*aptr++ = items & 0xff;
3737	items = 0;
3738	}
3739	}
3740	}
3741	if (aint & 1)
3742	*aptr++ = items & 0xff;
3743	pat = SvPVX(cat) + SvCUR(cat);
3744	while (aptr <= pat)
3745	*aptr++ = '\0';
3746
3747	pat = savepat;
3748	items = saveitems;
3749	}
3750	break;
3751	case 'C':
3752	case 'c':
3753	while (len-- > 0) {
3754	fromstr = NEXTFROM;
3755	aint = SvIV(fromstr);
3756	achar = aint;
3757	sv_catpvn(cat, &achar, sizeof(char));
3758	}
3759	break;
3760	/* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
3761	case 'f':
3762	case 'F':
3763	while (len-- > 0) {
3764	fromstr = NEXTFROM;
3765	afloat = (float)SvNV(fromstr);
3766	sv_catpvn(cat, (char *)&afloat, sizeof (float));
3767	}
3768	break;
3769	case 'd':
3770	case 'D':
3771	while (len-- > 0) {
3772	fromstr = NEXTFROM;
3773	adouble = (double)SvNV(fromstr);
3774	sv_catpvn(cat, (char *)&adouble, sizeof (double));
3775	}
3776	break;
3777	case 'n':
3778	while (len-- > 0) {
3779	fromstr = NEXTFROM;
3780	ashort = (I16)SvIV(fromstr);
3781	#ifdef HAS_HTONS
3782	ashort = htons(ashort);
3783	#endif
3784	CAT16(cat, &ashort);
3785	}
3786	break;
3787	case 'v':
3788	while (len-- > 0) {
3789	fromstr = NEXTFROM;
3790	ashort = (I16)SvIV(fromstr);
3791	#ifdef HAS_HTOVS
3792	ashort = htovs(ashort);
3793	#endif
3794	CAT16(cat, &ashort);
3795	}
3796	break;
3797	case 'S':
3798	case 's':
3799	while (len-- > 0) {
3800	fromstr = NEXTFROM;
3801	ashort = (I16)SvIV(fromstr);
3802	CAT16(cat, &ashort);
3803	}
3804	break;
3805	case 'I':
3806	while (len-- > 0) {
3807	fromstr = NEXTFROM;
3808	auint = SvUV(fromstr);
3809	sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3810	}
3811	break;
3812	case 'w':
3813	while (len-- > 0) {
3814	fromstr = NEXTFROM;
3815	adouble = floor(SvNV(fromstr));
3816
3817	if (adouble < 0)
3818	croak("Cannot compress negative numbers");
3819
3820	if (
3821	#ifdef BW_BITS
3822	adouble <= BW_MASK
3823	#else
3824	#ifdef CXUX_BROKEN_CONSTANT_CONVERT
3825	adouble <= UV_MAX_cxux
3826	#else
3827	adouble <= UV_MAX
3828	#endif
3829	#endif
3830	)
3831	{
3832	char buf[1 + sizeof(UV)];
3833	char *in = buf + sizeof(buf);
3834	UV auv = U_V(adouble);;
3835
3836	do {
3837	*--in = (auv & 0x7f) \| 0x80;
3838	auv >>= 7;
3839	} while (auv);
3840	buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3841	sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
3842	}
3843	else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
3844	char from, result, *in;
3845	SV *norm;
3846	STRLEN len;
3847	bool done;
3848
3849	/* Copy string and check for compliance */
3850	from = SvPV(fromstr, len);
3851	if ((norm = is_an_int(from, len)) == NULL)
3852	croak("can compress only unsigned integer");
3853
3854	New('w', result, len, char);
3855	in = result + len;
3856	done = FALSE;
3857	while (!done)
3858	*--in = div128(norm, &done) \| 0x80;
3859	result[len - 1] &= 0x7F; /* clear continue bit */
3860	sv_catpvn(cat, in, (result + len) - in);
3861	Safefree(result);
3862	SvREFCNT_dec(norm); /* free norm */
3863	}
3864	else if (SvNOKp(fromstr)) {
3865	char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
3866	char *in = buf + sizeof(buf);
3867
3868	do {
3869	double next = floor(adouble / 128);
3870	--in = (unsigned char)(adouble - (next 128)) \| 0x80;
3871	if (--in < buf) /* this cannot happen ;-) */
3872	croak ("Cannot compress integer");
3873	adouble = next;
3874	} while (adouble > 0);
3875	buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3876	sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
3877	}
3878	else
3879	croak("Cannot compress non integer");
3880	}
3881	break;
3882	case 'i':
3883	while (len-- > 0) {
3884	fromstr = NEXTFROM;
3885	aint = SvIV(fromstr);
3886	sv_catpvn(cat, (char*)&aint, sizeof(int));
3887	}
3888	break;
3889	case 'N':
3890	while (len-- > 0) {
3891	fromstr = NEXTFROM;
3892	aulong = SvUV(fromstr);
3893	#ifdef HAS_HTONL
3894	aulong = htonl(aulong);
3895	#endif
3896	CAT32(cat, &aulong);
3897	}
3898	break;
3899	case 'V':
3900	while (len-- > 0) {
3901	fromstr = NEXTFROM;
3902	aulong = SvUV(fromstr);
3903	#ifdef HAS_HTOVL
3904	aulong = htovl(aulong);
3905	#endif
3906	CAT32(cat, &aulong);
3907	}
3908	break;
3909	case 'L':
3910	while (len-- > 0) {
3911	fromstr = NEXTFROM;
3912	aulong = SvUV(fromstr);
3913	CAT32(cat, &aulong);
3914	}
3915	break;
3916	case 'l':
3917	while (len-- > 0) {
3918	fromstr = NEXTFROM;
3919	along = SvIV(fromstr);
3920	CAT32(cat, &along);
3921	}
3922	break;
3923	#ifdef HAS_QUAD
3924	case 'Q':
3925	while (len-- > 0) {
3926	fromstr = NEXTFROM;
3927	auquad = (unsigned Quad_t)SvIV(fromstr);
3928	sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
3929	}
3930	break;
3931	case 'q':
3932	while (len-- > 0) {
3933	fromstr = NEXTFROM;
3934	aquad = (Quad_t)SvIV(fromstr);
3935	sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
3936	}
3937	break;
3938	#endif /* HAS_QUAD */
3939	case 'P':
3940	len = 1; /* assume SV is correct length */
3941	/* FALL THROUGH */
3942	case 'p':
3943	while (len-- > 0) {
3944	fromstr = NEXTFROM;
3945	if (fromstr == &sv_undef)
3946	aptr = NULL;
3947	else {
3948	/* XXX better yet, could spirit away the string to
3949	* a safe spot and hang on to it until the result
3950	* of pack() (and all copies of the result) are
3951	* gone.
3952	*/
3953	if (dowarn && (SvTEMP(fromstr) \|\| SvPADTMP(fromstr)))
3954	warn("Attempt to pack pointer to temporary value");
3955	if (SvPOK(fromstr) \|\| SvNIOK(fromstr))
3956	aptr = SvPV(fromstr,na);
3957	else
3958	aptr = SvPV_force(fromstr,na);
3959	}
3960	sv_catpvn(cat, (char)&aptr, sizeof(char));
3961	}
3962	break;
3963	case 'u':
3964	fromstr = NEXTFROM;
3965	aptr = SvPV(fromstr, fromlen);
3966	SvGROW(cat, fromlen * 4 / 3);
3967	if (len <= 1)
3968	len = 45;
3969	else
3970	len = len / 3 * 3;
3971	while (fromlen > 0) {
3972	I32 todo;
3973
3974	if (fromlen > len)
3975	todo = len;
3976	else
3977	todo = fromlen;
3978	doencodes(cat, aptr, todo);
3979	fromlen -= todo;
3980	aptr += todo;
3981	}
3982	break;
3983	}
3984	}
3985	SvSETMAGIC(cat);
3986	SP = ORIGMARK;
3987	PUSHs(cat);
3988	RETURN;
3989	}
3990	#undef NEXTFROM
3991
3992	PP(pp_split)
3993	{
3994	dSP; dTARG;
3995	AV *ary;
3996	register I32 limit = POPi; /* note, negative is forever */
3997	SV *sv = POPs;
3998	STRLEN len;
3999	register char *s = SvPV(sv, len);
4000	char *strend = s + len;
4001	register PMOP *pm;
4002	register REGEXP *rx;
4003	register SV *dstr;
4004	register char *m;
4005	I32 iters = 0;
4006	I32 maxiters = (strend - s) + 10;
4007	I32 i;
4008	char *orig;
4009	I32 origlimit = limit;
4010	I32 realarray = 0;
4011	I32 base;
4012	AV *oldstack = curstack;
4013	I32 gimme = GIMME_V;
4014	I32 oldsave = savestack_ix;
4015
4016	#ifdef DEBUGGING
4017	Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4018	#else
4019	pm = (PMOP*)POPs;
4020	#endif
4021	if (!pm \|\| !s)
4022	DIE("panic: do_split");
4023	rx = pm->op_pmregexp;
4024
4025	TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4026	(pm->op_pmflags & (PMf_WHITE \| PMf_SKIPWHITE)));
4027
4028	if (pm->op_pmreplroot)
4029	ary = GvAVn((GV*)pm->op_pmreplroot);
4030	else if (gimme != G_ARRAY)
4031	ary = GvAVn(defgv);
4032	else
4033	ary = Nullav;
4034	if (ary && (gimme != G_ARRAY \|\| (pm->op_pmflags & PMf_ONCE))) {
4035	realarray = 1;
4036	if (!AvREAL(ary)) {
4037	AvREAL_on(ary);
4038	for (i = AvFILL(ary); i >= 0; i--)
4039	AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */
4040	}
4041	av_extend(ary,0);
4042	av_clear(ary);
4043	/* temporarily switch stacks */
4044	SWITCHSTACK(curstack, ary);
4045	}
4046	base = SP - stack_base;
4047	orig = s;
4048	if (pm->op_pmflags & PMf_SKIPWHITE) {
4049	if (pm->op_pmflags & PMf_LOCALE) {
4050	while (isSPACE_LC(*s))
4051	s++;
4052	}
4053	else {
4054	while (isSPACE(*s))
4055	s++;
4056	}
4057	}
4058	if (pm->op_pmflags & (PMf_MULTILINE\|PMf_SINGLELINE)) {
4059	SAVEINT(multiline);
4060	multiline = pm->op_pmflags & PMf_MULTILINE;
4061	}
4062
4063	if (!limit)
4064	limit = maxiters + 2;
4065	if (pm->op_pmflags & PMf_WHITE) {
4066	while (--limit) {
4067	m = s;
4068	while (m < strend &&
4069	!((pm->op_pmflags & PMf_LOCALE)
4070	? isSPACE_LC(m) : isSPACE(m)))
4071	++m;
4072	if (m >= strend)
4073	break;
4074
4075	dstr = NEWSV(30, m-s);
4076	sv_setpvn(dstr, s, m-s);
4077	if (!realarray)
4078	sv_2mortal(dstr);
4079	XPUSHs(dstr);
4080
4081	s = m + 1;
4082	while (s < strend &&
4083	((pm->op_pmflags & PMf_LOCALE)
4084	? isSPACE_LC(s) : isSPACE(s)))
4085	++s;
4086	}
4087	}
4088	else if (strEQ("^", rx->precomp)) {
4089	while (--limit) {
4090	/SUPPRESS 530/
4091	for (m = s; m < strend && *m != '\n'; m++) ;
4092	m++;
4093	if (m >= strend)
4094	break;
4095	dstr = NEWSV(30, m-s);
4096	sv_setpvn(dstr, s, m-s);
4097	if (!realarray)
4098	sv_2mortal(dstr);
4099	XPUSHs(dstr);
4100	s = m;
4101	}
4102	}
4103	else if (pm->op_pmshort && !rx->nparens) {
4104	i = SvCUR(pm->op_pmshort);
4105	if (i == 1) {
4106	i = *SvPVX(pm->op_pmshort);
4107	while (--limit) {
4108	/SUPPRESS 530/
4109	for (m = s; m < strend && *m != i; m++) ;
4110	if (m >= strend)
4111	break;
4112	dstr = NEWSV(30, m-s);
4113	sv_setpvn(dstr, s, m-s);
4114	if (!realarray)
4115	sv_2mortal(dstr);
4116	XPUSHs(dstr);
4117	s = m + 1;
4118	}
4119	}
4120	else {
4121	#ifndef lint
4122	while (s < strend && --limit &&
4123	(m=fbm_instr((unsigned char)s, (unsigned char)strend,
4124	pm->op_pmshort)) )
4125	#endif
4126	{
4127	dstr = NEWSV(31, m-s);
4128	sv_setpvn(dstr, s, m-s);
4129	if (!realarray)
4130	sv_2mortal(dstr);
4131	XPUSHs(dstr);
4132	s = m + i;
4133	}
4134	}
4135	}
4136	else {
4137	maxiters += (strend - s) * rx->nparens;
4138	while (s < strend && --limit &&
4139	pregexec(rx, s, strend, orig, 1, Nullsv, TRUE))
4140	{
4141	TAINT_IF(rx->exec_tainted);
4142	if (rx->subbase
4143	&& rx->subbase != orig) {
4144	m = s;
4145	s = orig;
4146	orig = rx->subbase;
4147	s = orig + (m - s);
4148	strend = s + (strend - m);
4149	}
4150	m = rx->startp[0];
4151	dstr = NEWSV(32, m-s);
4152	sv_setpvn(dstr, s, m-s);
4153	if (!realarray)
4154	sv_2mortal(dstr);
4155	XPUSHs(dstr);
4156	if (rx->nparens) {
4157	for (i = 1; i <= rx->nparens; i++) {
4158	s = rx->startp[i];
4159	m = rx->endp[i];
4160	if (m && s) {
4161	dstr = NEWSV(33, m-s);
4162	sv_setpvn(dstr, s, m-s);
4163	}
4164	else
4165	dstr = NEWSV(33, 0);
4166	if (!realarray)
4167	sv_2mortal(dstr);
4168	XPUSHs(dstr);
4169	}
4170	}
4171	s = rx->endp[0];
4172	}
4173	}
4174	LEAVE_SCOPE(oldsave);
4175	iters = (SP - stack_base) - base;
4176	if (iters > maxiters)
4177	DIE("Split loop");
4178
4179	/* keep field after final delim? */
4180	if (s < strend \|\| (iters && origlimit)) {
4181	dstr = NEWSV(34, strend-s);
4182	sv_setpvn(dstr, s, strend-s);
4183	if (!realarray)
4184	sv_2mortal(dstr);
4185	XPUSHs(dstr);
4186	iters++;
4187	}
4188	else if (!origlimit) {
4189	while (iters > 0 && (!TOPs \|\| !SvANY(TOPs) \|\| SvCUR(TOPs) == 0))
4190	iters--, SP--;
4191	}
4192	if (realarray) {
4193	SWITCHSTACK(ary, oldstack);
4194	if (SvSMAGICAL(ary)) {
4195	PUTBACK;
4196	mg_set((SV*)ary);
4197	SPAGAIN;
4198	}
4199	if (gimme == G_ARRAY) {
4200	EXTEND(SP, iters);
4201	Copy(AvARRAY(ary), SP + 1, iters, SV*);
4202	SP += iters;
4203	RETURN;
4204	}
4205	}
4206	else {
4207	if (gimme == G_ARRAY)
4208	RETURN;
4209	}
4210	if (iters \|\| !pm->op_pmreplroot) {
4211	GETTARGET;
4212	PUSHi(iters);
4213	RETURN;
4214	}
4215	RETPUSHUNDEF;
4216	}
4217

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

Download in other formats: