1*0Sstevel@tonic-gate /* pp.c
2*0Sstevel@tonic-gate *
3*0Sstevel@tonic-gate * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4*0Sstevel@tonic-gate * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
5*0Sstevel@tonic-gate *
6*0Sstevel@tonic-gate * You may distribute under the terms of either the GNU General Public
7*0Sstevel@tonic-gate * License or the Artistic License, as specified in the README file.
8*0Sstevel@tonic-gate *
9*0Sstevel@tonic-gate */
10*0Sstevel@tonic-gate
11*0Sstevel@tonic-gate /*
12*0Sstevel@tonic-gate * "It's a big house this, and very peculiar. Always a bit more to discover,
13*0Sstevel@tonic-gate * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
14*0Sstevel@tonic-gate */
15*0Sstevel@tonic-gate
16*0Sstevel@tonic-gate #include "EXTERN.h"
17*0Sstevel@tonic-gate #define PERL_IN_PP_C
18*0Sstevel@tonic-gate #include "perl.h"
19*0Sstevel@tonic-gate #include "keywords.h"
20*0Sstevel@tonic-gate
21*0Sstevel@tonic-gate #include "reentr.h"
22*0Sstevel@tonic-gate
23*0Sstevel@tonic-gate /* XXX I can't imagine anyone who doesn't have this actually _needs_
24*0Sstevel@tonic-gate it, since pid_t is an integral type.
25*0Sstevel@tonic-gate --AD 2/20/1998
26*0Sstevel@tonic-gate */
27*0Sstevel@tonic-gate #ifdef NEED_GETPID_PROTO
28*0Sstevel@tonic-gate extern Pid_t getpid (void);
29*0Sstevel@tonic-gate #endif
30*0Sstevel@tonic-gate
31*0Sstevel@tonic-gate /* variations on pp_null */
32*0Sstevel@tonic-gate
PP(pp_stub)33*0Sstevel@tonic-gate PP(pp_stub)
34*0Sstevel@tonic-gate {
35*0Sstevel@tonic-gate dSP;
36*0Sstevel@tonic-gate if (GIMME_V == G_SCALAR)
37*0Sstevel@tonic-gate XPUSHs(&PL_sv_undef);
38*0Sstevel@tonic-gate RETURN;
39*0Sstevel@tonic-gate }
40*0Sstevel@tonic-gate
PP(pp_scalar)41*0Sstevel@tonic-gate PP(pp_scalar)
42*0Sstevel@tonic-gate {
43*0Sstevel@tonic-gate return NORMAL;
44*0Sstevel@tonic-gate }
45*0Sstevel@tonic-gate
46*0Sstevel@tonic-gate /* Pushy stuff. */
47*0Sstevel@tonic-gate
PP(pp_padav)48*0Sstevel@tonic-gate PP(pp_padav)
49*0Sstevel@tonic-gate {
50*0Sstevel@tonic-gate dSP; dTARGET;
51*0Sstevel@tonic-gate I32 gimme;
52*0Sstevel@tonic-gate if (PL_op->op_private & OPpLVAL_INTRO)
53*0Sstevel@tonic-gate SAVECLEARSV(PAD_SVl(PL_op->op_targ));
54*0Sstevel@tonic-gate EXTEND(SP, 1);
55*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_REF) {
56*0Sstevel@tonic-gate PUSHs(TARG);
57*0Sstevel@tonic-gate RETURN;
58*0Sstevel@tonic-gate } else if (LVRET) {
59*0Sstevel@tonic-gate if (GIMME == G_SCALAR)
60*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
61*0Sstevel@tonic-gate PUSHs(TARG);
62*0Sstevel@tonic-gate RETURN;
63*0Sstevel@tonic-gate }
64*0Sstevel@tonic-gate gimme = GIMME_V;
65*0Sstevel@tonic-gate if (gimme == G_ARRAY) {
66*0Sstevel@tonic-gate I32 maxarg = AvFILL((AV*)TARG) + 1;
67*0Sstevel@tonic-gate EXTEND(SP, maxarg);
68*0Sstevel@tonic-gate if (SvMAGICAL(TARG)) {
69*0Sstevel@tonic-gate U32 i;
70*0Sstevel@tonic-gate for (i=0; i < (U32)maxarg; i++) {
71*0Sstevel@tonic-gate SV **svp = av_fetch((AV*)TARG, i, FALSE);
72*0Sstevel@tonic-gate SP[i+1] = (svp) ? *svp : &PL_sv_undef;
73*0Sstevel@tonic-gate }
74*0Sstevel@tonic-gate }
75*0Sstevel@tonic-gate else {
76*0Sstevel@tonic-gate Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
77*0Sstevel@tonic-gate }
78*0Sstevel@tonic-gate SP += maxarg;
79*0Sstevel@tonic-gate }
80*0Sstevel@tonic-gate else if (gimme == G_SCALAR) {
81*0Sstevel@tonic-gate SV* sv = sv_newmortal();
82*0Sstevel@tonic-gate I32 maxarg = AvFILL((AV*)TARG) + 1;
83*0Sstevel@tonic-gate sv_setiv(sv, maxarg);
84*0Sstevel@tonic-gate PUSHs(sv);
85*0Sstevel@tonic-gate }
86*0Sstevel@tonic-gate RETURN;
87*0Sstevel@tonic-gate }
88*0Sstevel@tonic-gate
PP(pp_padhv)89*0Sstevel@tonic-gate PP(pp_padhv)
90*0Sstevel@tonic-gate {
91*0Sstevel@tonic-gate dSP; dTARGET;
92*0Sstevel@tonic-gate I32 gimme;
93*0Sstevel@tonic-gate
94*0Sstevel@tonic-gate XPUSHs(TARG);
95*0Sstevel@tonic-gate if (PL_op->op_private & OPpLVAL_INTRO)
96*0Sstevel@tonic-gate SAVECLEARSV(PAD_SVl(PL_op->op_targ));
97*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_REF)
98*0Sstevel@tonic-gate RETURN;
99*0Sstevel@tonic-gate else if (LVRET) {
100*0Sstevel@tonic-gate if (GIMME == G_SCALAR)
101*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
102*0Sstevel@tonic-gate RETURN;
103*0Sstevel@tonic-gate }
104*0Sstevel@tonic-gate gimme = GIMME_V;
105*0Sstevel@tonic-gate if (gimme == G_ARRAY) {
106*0Sstevel@tonic-gate RETURNOP(do_kv());
107*0Sstevel@tonic-gate }
108*0Sstevel@tonic-gate else if (gimme == G_SCALAR) {
109*0Sstevel@tonic-gate SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
110*0Sstevel@tonic-gate SETs(sv);
111*0Sstevel@tonic-gate }
112*0Sstevel@tonic-gate RETURN;
113*0Sstevel@tonic-gate }
114*0Sstevel@tonic-gate
PP(pp_padany)115*0Sstevel@tonic-gate PP(pp_padany)
116*0Sstevel@tonic-gate {
117*0Sstevel@tonic-gate DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
118*0Sstevel@tonic-gate }
119*0Sstevel@tonic-gate
120*0Sstevel@tonic-gate /* Translations. */
121*0Sstevel@tonic-gate
PP(pp_rv2gv)122*0Sstevel@tonic-gate PP(pp_rv2gv)
123*0Sstevel@tonic-gate {
124*0Sstevel@tonic-gate dSP; dTOPss;
125*0Sstevel@tonic-gate
126*0Sstevel@tonic-gate if (SvROK(sv)) {
127*0Sstevel@tonic-gate wasref:
128*0Sstevel@tonic-gate tryAMAGICunDEREF(to_gv);
129*0Sstevel@tonic-gate
130*0Sstevel@tonic-gate sv = SvRV(sv);
131*0Sstevel@tonic-gate if (SvTYPE(sv) == SVt_PVIO) {
132*0Sstevel@tonic-gate GV *gv = (GV*) sv_newmortal();
133*0Sstevel@tonic-gate gv_init(gv, 0, "", 0, 0);
134*0Sstevel@tonic-gate GvIOp(gv) = (IO *)sv;
135*0Sstevel@tonic-gate (void)SvREFCNT_inc(sv);
136*0Sstevel@tonic-gate sv = (SV*) gv;
137*0Sstevel@tonic-gate }
138*0Sstevel@tonic-gate else if (SvTYPE(sv) != SVt_PVGV)
139*0Sstevel@tonic-gate DIE(aTHX_ "Not a GLOB reference");
140*0Sstevel@tonic-gate }
141*0Sstevel@tonic-gate else {
142*0Sstevel@tonic-gate if (SvTYPE(sv) != SVt_PVGV) {
143*0Sstevel@tonic-gate char *sym;
144*0Sstevel@tonic-gate STRLEN len;
145*0Sstevel@tonic-gate
146*0Sstevel@tonic-gate if (SvGMAGICAL(sv)) {
147*0Sstevel@tonic-gate mg_get(sv);
148*0Sstevel@tonic-gate if (SvROK(sv))
149*0Sstevel@tonic-gate goto wasref;
150*0Sstevel@tonic-gate }
151*0Sstevel@tonic-gate if (!SvOK(sv) && sv != &PL_sv_undef) {
152*0Sstevel@tonic-gate /* If this is a 'my' scalar and flag is set then vivify
153*0Sstevel@tonic-gate * NI-S 1999/05/07
154*0Sstevel@tonic-gate */
155*0Sstevel@tonic-gate if (PL_op->op_private & OPpDEREF) {
156*0Sstevel@tonic-gate char *name;
157*0Sstevel@tonic-gate GV *gv;
158*0Sstevel@tonic-gate if (cUNOP->op_targ) {
159*0Sstevel@tonic-gate STRLEN len;
160*0Sstevel@tonic-gate SV *namesv = PAD_SV(cUNOP->op_targ);
161*0Sstevel@tonic-gate name = SvPV(namesv, len);
162*0Sstevel@tonic-gate gv = (GV*)NEWSV(0,0);
163*0Sstevel@tonic-gate gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
164*0Sstevel@tonic-gate }
165*0Sstevel@tonic-gate else {
166*0Sstevel@tonic-gate name = CopSTASHPV(PL_curcop);
167*0Sstevel@tonic-gate gv = newGVgen(name);
168*0Sstevel@tonic-gate }
169*0Sstevel@tonic-gate if (SvTYPE(sv) < SVt_RV)
170*0Sstevel@tonic-gate sv_upgrade(sv, SVt_RV);
171*0Sstevel@tonic-gate if (SvPVX(sv)) {
172*0Sstevel@tonic-gate (void)SvOOK_off(sv); /* backoff */
173*0Sstevel@tonic-gate if (SvLEN(sv))
174*0Sstevel@tonic-gate Safefree(SvPVX(sv));
175*0Sstevel@tonic-gate SvLEN(sv)=SvCUR(sv)=0;
176*0Sstevel@tonic-gate }
177*0Sstevel@tonic-gate SvRV(sv) = (SV*)gv;
178*0Sstevel@tonic-gate SvROK_on(sv);
179*0Sstevel@tonic-gate SvSETMAGIC(sv);
180*0Sstevel@tonic-gate goto wasref;
181*0Sstevel@tonic-gate }
182*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_REF ||
183*0Sstevel@tonic-gate PL_op->op_private & HINT_STRICT_REFS)
184*0Sstevel@tonic-gate DIE(aTHX_ PL_no_usym, "a symbol");
185*0Sstevel@tonic-gate if (ckWARN(WARN_UNINITIALIZED))
186*0Sstevel@tonic-gate report_uninit();
187*0Sstevel@tonic-gate RETSETUNDEF;
188*0Sstevel@tonic-gate }
189*0Sstevel@tonic-gate sym = SvPV(sv,len);
190*0Sstevel@tonic-gate if ((PL_op->op_flags & OPf_SPECIAL) &&
191*0Sstevel@tonic-gate !(PL_op->op_flags & OPf_MOD))
192*0Sstevel@tonic-gate {
193*0Sstevel@tonic-gate sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
194*0Sstevel@tonic-gate if (!sv
195*0Sstevel@tonic-gate && (!is_gv_magical(sym,len,0)
196*0Sstevel@tonic-gate || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
197*0Sstevel@tonic-gate {
198*0Sstevel@tonic-gate RETSETUNDEF;
199*0Sstevel@tonic-gate }
200*0Sstevel@tonic-gate }
201*0Sstevel@tonic-gate else {
202*0Sstevel@tonic-gate if (PL_op->op_private & HINT_STRICT_REFS)
203*0Sstevel@tonic-gate DIE(aTHX_ PL_no_symref, sym, "a symbol");
204*0Sstevel@tonic-gate sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
205*0Sstevel@tonic-gate }
206*0Sstevel@tonic-gate }
207*0Sstevel@tonic-gate }
208*0Sstevel@tonic-gate if (PL_op->op_private & OPpLVAL_INTRO)
209*0Sstevel@tonic-gate save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
210*0Sstevel@tonic-gate SETs(sv);
211*0Sstevel@tonic-gate RETURN;
212*0Sstevel@tonic-gate }
213*0Sstevel@tonic-gate
PP(pp_rv2sv)214*0Sstevel@tonic-gate PP(pp_rv2sv)
215*0Sstevel@tonic-gate {
216*0Sstevel@tonic-gate GV *gv = Nullgv;
217*0Sstevel@tonic-gate dSP; dTOPss;
218*0Sstevel@tonic-gate
219*0Sstevel@tonic-gate if (SvROK(sv)) {
220*0Sstevel@tonic-gate wasref:
221*0Sstevel@tonic-gate tryAMAGICunDEREF(to_sv);
222*0Sstevel@tonic-gate
223*0Sstevel@tonic-gate sv = SvRV(sv);
224*0Sstevel@tonic-gate switch (SvTYPE(sv)) {
225*0Sstevel@tonic-gate case SVt_PVAV:
226*0Sstevel@tonic-gate case SVt_PVHV:
227*0Sstevel@tonic-gate case SVt_PVCV:
228*0Sstevel@tonic-gate DIE(aTHX_ "Not a SCALAR reference");
229*0Sstevel@tonic-gate }
230*0Sstevel@tonic-gate }
231*0Sstevel@tonic-gate else {
232*0Sstevel@tonic-gate char *sym;
233*0Sstevel@tonic-gate STRLEN len;
234*0Sstevel@tonic-gate gv = (GV*)sv;
235*0Sstevel@tonic-gate
236*0Sstevel@tonic-gate if (SvTYPE(gv) != SVt_PVGV) {
237*0Sstevel@tonic-gate if (SvGMAGICAL(sv)) {
238*0Sstevel@tonic-gate mg_get(sv);
239*0Sstevel@tonic-gate if (SvROK(sv))
240*0Sstevel@tonic-gate goto wasref;
241*0Sstevel@tonic-gate }
242*0Sstevel@tonic-gate if (!SvOK(sv)) {
243*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_REF ||
244*0Sstevel@tonic-gate PL_op->op_private & HINT_STRICT_REFS)
245*0Sstevel@tonic-gate DIE(aTHX_ PL_no_usym, "a SCALAR");
246*0Sstevel@tonic-gate if (ckWARN(WARN_UNINITIALIZED))
247*0Sstevel@tonic-gate report_uninit();
248*0Sstevel@tonic-gate RETSETUNDEF;
249*0Sstevel@tonic-gate }
250*0Sstevel@tonic-gate sym = SvPV(sv, len);
251*0Sstevel@tonic-gate if ((PL_op->op_flags & OPf_SPECIAL) &&
252*0Sstevel@tonic-gate !(PL_op->op_flags & OPf_MOD))
253*0Sstevel@tonic-gate {
254*0Sstevel@tonic-gate gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
255*0Sstevel@tonic-gate if (!gv
256*0Sstevel@tonic-gate && (!is_gv_magical(sym,len,0)
257*0Sstevel@tonic-gate || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
258*0Sstevel@tonic-gate {
259*0Sstevel@tonic-gate RETSETUNDEF;
260*0Sstevel@tonic-gate }
261*0Sstevel@tonic-gate }
262*0Sstevel@tonic-gate else {
263*0Sstevel@tonic-gate if (PL_op->op_private & HINT_STRICT_REFS)
264*0Sstevel@tonic-gate DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
265*0Sstevel@tonic-gate gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
266*0Sstevel@tonic-gate }
267*0Sstevel@tonic-gate }
268*0Sstevel@tonic-gate sv = GvSV(gv);
269*0Sstevel@tonic-gate }
270*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_MOD) {
271*0Sstevel@tonic-gate if (PL_op->op_private & OPpLVAL_INTRO) {
272*0Sstevel@tonic-gate if (cUNOP->op_first->op_type == OP_NULL)
273*0Sstevel@tonic-gate sv = save_scalar((GV*)TOPs);
274*0Sstevel@tonic-gate else if (gv)
275*0Sstevel@tonic-gate sv = save_scalar(gv);
276*0Sstevel@tonic-gate else
277*0Sstevel@tonic-gate Perl_croak(aTHX_ PL_no_localize_ref);
278*0Sstevel@tonic-gate }
279*0Sstevel@tonic-gate else if (PL_op->op_private & OPpDEREF)
280*0Sstevel@tonic-gate vivify_ref(sv, PL_op->op_private & OPpDEREF);
281*0Sstevel@tonic-gate }
282*0Sstevel@tonic-gate SETs(sv);
283*0Sstevel@tonic-gate RETURN;
284*0Sstevel@tonic-gate }
285*0Sstevel@tonic-gate
PP(pp_av2arylen)286*0Sstevel@tonic-gate PP(pp_av2arylen)
287*0Sstevel@tonic-gate {
288*0Sstevel@tonic-gate dSP;
289*0Sstevel@tonic-gate AV *av = (AV*)TOPs;
290*0Sstevel@tonic-gate SV *sv = AvARYLEN(av);
291*0Sstevel@tonic-gate if (!sv) {
292*0Sstevel@tonic-gate AvARYLEN(av) = sv = NEWSV(0,0);
293*0Sstevel@tonic-gate sv_upgrade(sv, SVt_IV);
294*0Sstevel@tonic-gate sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
295*0Sstevel@tonic-gate }
296*0Sstevel@tonic-gate SETs(sv);
297*0Sstevel@tonic-gate RETURN;
298*0Sstevel@tonic-gate }
299*0Sstevel@tonic-gate
PP(pp_pos)300*0Sstevel@tonic-gate PP(pp_pos)
301*0Sstevel@tonic-gate {
302*0Sstevel@tonic-gate dSP; dTARGET; dPOPss;
303*0Sstevel@tonic-gate
304*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_MOD || LVRET) {
305*0Sstevel@tonic-gate if (SvTYPE(TARG) < SVt_PVLV) {
306*0Sstevel@tonic-gate sv_upgrade(TARG, SVt_PVLV);
307*0Sstevel@tonic-gate sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
308*0Sstevel@tonic-gate }
309*0Sstevel@tonic-gate
310*0Sstevel@tonic-gate LvTYPE(TARG) = '.';
311*0Sstevel@tonic-gate if (LvTARG(TARG) != sv) {
312*0Sstevel@tonic-gate if (LvTARG(TARG))
313*0Sstevel@tonic-gate SvREFCNT_dec(LvTARG(TARG));
314*0Sstevel@tonic-gate LvTARG(TARG) = SvREFCNT_inc(sv);
315*0Sstevel@tonic-gate }
316*0Sstevel@tonic-gate PUSHs(TARG); /* no SvSETMAGIC */
317*0Sstevel@tonic-gate RETURN;
318*0Sstevel@tonic-gate }
319*0Sstevel@tonic-gate else {
320*0Sstevel@tonic-gate MAGIC* mg;
321*0Sstevel@tonic-gate
322*0Sstevel@tonic-gate if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
323*0Sstevel@tonic-gate mg = mg_find(sv, PERL_MAGIC_regex_global);
324*0Sstevel@tonic-gate if (mg && mg->mg_len >= 0) {
325*0Sstevel@tonic-gate I32 i = mg->mg_len;
326*0Sstevel@tonic-gate if (DO_UTF8(sv))
327*0Sstevel@tonic-gate sv_pos_b2u(sv, &i);
328*0Sstevel@tonic-gate PUSHi(i + PL_curcop->cop_arybase);
329*0Sstevel@tonic-gate RETURN;
330*0Sstevel@tonic-gate }
331*0Sstevel@tonic-gate }
332*0Sstevel@tonic-gate RETPUSHUNDEF;
333*0Sstevel@tonic-gate }
334*0Sstevel@tonic-gate }
335*0Sstevel@tonic-gate
PP(pp_rv2cv)336*0Sstevel@tonic-gate PP(pp_rv2cv)
337*0Sstevel@tonic-gate {
338*0Sstevel@tonic-gate dSP;
339*0Sstevel@tonic-gate GV *gv;
340*0Sstevel@tonic-gate HV *stash;
341*0Sstevel@tonic-gate
342*0Sstevel@tonic-gate /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
343*0Sstevel@tonic-gate /* (But not in defined().) */
344*0Sstevel@tonic-gate CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
345*0Sstevel@tonic-gate if (cv) {
346*0Sstevel@tonic-gate if (CvCLONE(cv))
347*0Sstevel@tonic-gate cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
348*0Sstevel@tonic-gate if ((PL_op->op_private & OPpLVAL_INTRO)) {
349*0Sstevel@tonic-gate if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
350*0Sstevel@tonic-gate cv = GvCV(gv);
351*0Sstevel@tonic-gate if (!CvLVALUE(cv))
352*0Sstevel@tonic-gate DIE(aTHX_ "Can't modify non-lvalue subroutine call");
353*0Sstevel@tonic-gate }
354*0Sstevel@tonic-gate }
355*0Sstevel@tonic-gate else
356*0Sstevel@tonic-gate cv = (CV*)&PL_sv_undef;
357*0Sstevel@tonic-gate SETs((SV*)cv);
358*0Sstevel@tonic-gate RETURN;
359*0Sstevel@tonic-gate }
360*0Sstevel@tonic-gate
PP(pp_prototype)361*0Sstevel@tonic-gate PP(pp_prototype)
362*0Sstevel@tonic-gate {
363*0Sstevel@tonic-gate dSP;
364*0Sstevel@tonic-gate CV *cv;
365*0Sstevel@tonic-gate HV *stash;
366*0Sstevel@tonic-gate GV *gv;
367*0Sstevel@tonic-gate SV *ret;
368*0Sstevel@tonic-gate
369*0Sstevel@tonic-gate ret = &PL_sv_undef;
370*0Sstevel@tonic-gate if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
371*0Sstevel@tonic-gate char *s = SvPVX(TOPs);
372*0Sstevel@tonic-gate if (strnEQ(s, "CORE::", 6)) {
373*0Sstevel@tonic-gate int code;
374*0Sstevel@tonic-gate
375*0Sstevel@tonic-gate code = keyword(s + 6, SvCUR(TOPs) - 6);
376*0Sstevel@tonic-gate if (code < 0) { /* Overridable. */
377*0Sstevel@tonic-gate #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
378*0Sstevel@tonic-gate int i = 0, n = 0, seen_question = 0;
379*0Sstevel@tonic-gate I32 oa;
380*0Sstevel@tonic-gate char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
381*0Sstevel@tonic-gate
382*0Sstevel@tonic-gate if (code == -KEY_chop || code == -KEY_chomp)
383*0Sstevel@tonic-gate goto set;
384*0Sstevel@tonic-gate while (i < MAXO) { /* The slow way. */
385*0Sstevel@tonic-gate if (strEQ(s + 6, PL_op_name[i])
386*0Sstevel@tonic-gate || strEQ(s + 6, PL_op_desc[i]))
387*0Sstevel@tonic-gate {
388*0Sstevel@tonic-gate goto found;
389*0Sstevel@tonic-gate }
390*0Sstevel@tonic-gate i++;
391*0Sstevel@tonic-gate }
392*0Sstevel@tonic-gate goto nonesuch; /* Should not happen... */
393*0Sstevel@tonic-gate found:
394*0Sstevel@tonic-gate oa = PL_opargs[i] >> OASHIFT;
395*0Sstevel@tonic-gate while (oa) {
396*0Sstevel@tonic-gate if (oa & OA_OPTIONAL && !seen_question) {
397*0Sstevel@tonic-gate seen_question = 1;
398*0Sstevel@tonic-gate str[n++] = ';';
399*0Sstevel@tonic-gate }
400*0Sstevel@tonic-gate else if (n && str[0] == ';' && seen_question)
401*0Sstevel@tonic-gate goto set; /* XXXX system, exec */
402*0Sstevel@tonic-gate if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
403*0Sstevel@tonic-gate && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
404*0Sstevel@tonic-gate /* But globs are already references (kinda) */
405*0Sstevel@tonic-gate && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
406*0Sstevel@tonic-gate ) {
407*0Sstevel@tonic-gate str[n++] = '\\';
408*0Sstevel@tonic-gate }
409*0Sstevel@tonic-gate str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
410*0Sstevel@tonic-gate oa = oa >> 4;
411*0Sstevel@tonic-gate }
412*0Sstevel@tonic-gate str[n++] = '\0';
413*0Sstevel@tonic-gate ret = sv_2mortal(newSVpvn(str, n - 1));
414*0Sstevel@tonic-gate }
415*0Sstevel@tonic-gate else if (code) /* Non-Overridable */
416*0Sstevel@tonic-gate goto set;
417*0Sstevel@tonic-gate else { /* None such */
418*0Sstevel@tonic-gate nonesuch:
419*0Sstevel@tonic-gate DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
420*0Sstevel@tonic-gate }
421*0Sstevel@tonic-gate }
422*0Sstevel@tonic-gate }
423*0Sstevel@tonic-gate cv = sv_2cv(TOPs, &stash, &gv, FALSE);
424*0Sstevel@tonic-gate if (cv && SvPOK(cv))
425*0Sstevel@tonic-gate ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
426*0Sstevel@tonic-gate set:
427*0Sstevel@tonic-gate SETs(ret);
428*0Sstevel@tonic-gate RETURN;
429*0Sstevel@tonic-gate }
430*0Sstevel@tonic-gate
PP(pp_anoncode)431*0Sstevel@tonic-gate PP(pp_anoncode)
432*0Sstevel@tonic-gate {
433*0Sstevel@tonic-gate dSP;
434*0Sstevel@tonic-gate CV* cv = (CV*)PAD_SV(PL_op->op_targ);
435*0Sstevel@tonic-gate if (CvCLONE(cv))
436*0Sstevel@tonic-gate cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
437*0Sstevel@tonic-gate EXTEND(SP,1);
438*0Sstevel@tonic-gate PUSHs((SV*)cv);
439*0Sstevel@tonic-gate RETURN;
440*0Sstevel@tonic-gate }
441*0Sstevel@tonic-gate
PP(pp_srefgen)442*0Sstevel@tonic-gate PP(pp_srefgen)
443*0Sstevel@tonic-gate {
444*0Sstevel@tonic-gate dSP;
445*0Sstevel@tonic-gate *SP = refto(*SP);
446*0Sstevel@tonic-gate RETURN;
447*0Sstevel@tonic-gate }
448*0Sstevel@tonic-gate
PP(pp_refgen)449*0Sstevel@tonic-gate PP(pp_refgen)
450*0Sstevel@tonic-gate {
451*0Sstevel@tonic-gate dSP; dMARK;
452*0Sstevel@tonic-gate if (GIMME != G_ARRAY) {
453*0Sstevel@tonic-gate if (++MARK <= SP)
454*0Sstevel@tonic-gate *MARK = *SP;
455*0Sstevel@tonic-gate else
456*0Sstevel@tonic-gate *MARK = &PL_sv_undef;
457*0Sstevel@tonic-gate *MARK = refto(*MARK);
458*0Sstevel@tonic-gate SP = MARK;
459*0Sstevel@tonic-gate RETURN;
460*0Sstevel@tonic-gate }
461*0Sstevel@tonic-gate EXTEND_MORTAL(SP - MARK);
462*0Sstevel@tonic-gate while (++MARK <= SP)
463*0Sstevel@tonic-gate *MARK = refto(*MARK);
464*0Sstevel@tonic-gate RETURN;
465*0Sstevel@tonic-gate }
466*0Sstevel@tonic-gate
467*0Sstevel@tonic-gate STATIC SV*
S_refto(pTHX_ SV * sv)468*0Sstevel@tonic-gate S_refto(pTHX_ SV *sv)
469*0Sstevel@tonic-gate {
470*0Sstevel@tonic-gate SV* rv;
471*0Sstevel@tonic-gate
472*0Sstevel@tonic-gate if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
473*0Sstevel@tonic-gate if (LvTARGLEN(sv))
474*0Sstevel@tonic-gate vivify_defelem(sv);
475*0Sstevel@tonic-gate if (!(sv = LvTARG(sv)))
476*0Sstevel@tonic-gate sv = &PL_sv_undef;
477*0Sstevel@tonic-gate else
478*0Sstevel@tonic-gate (void)SvREFCNT_inc(sv);
479*0Sstevel@tonic-gate }
480*0Sstevel@tonic-gate else if (SvTYPE(sv) == SVt_PVAV) {
481*0Sstevel@tonic-gate if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
482*0Sstevel@tonic-gate av_reify((AV*)sv);
483*0Sstevel@tonic-gate SvTEMP_off(sv);
484*0Sstevel@tonic-gate (void)SvREFCNT_inc(sv);
485*0Sstevel@tonic-gate }
486*0Sstevel@tonic-gate else if (SvPADTMP(sv) && !IS_PADGV(sv))
487*0Sstevel@tonic-gate sv = newSVsv(sv);
488*0Sstevel@tonic-gate else {
489*0Sstevel@tonic-gate SvTEMP_off(sv);
490*0Sstevel@tonic-gate (void)SvREFCNT_inc(sv);
491*0Sstevel@tonic-gate }
492*0Sstevel@tonic-gate rv = sv_newmortal();
493*0Sstevel@tonic-gate sv_upgrade(rv, SVt_RV);
494*0Sstevel@tonic-gate SvRV(rv) = sv;
495*0Sstevel@tonic-gate SvROK_on(rv);
496*0Sstevel@tonic-gate return rv;
497*0Sstevel@tonic-gate }
498*0Sstevel@tonic-gate
PP(pp_ref)499*0Sstevel@tonic-gate PP(pp_ref)
500*0Sstevel@tonic-gate {
501*0Sstevel@tonic-gate dSP; dTARGET;
502*0Sstevel@tonic-gate SV *sv;
503*0Sstevel@tonic-gate char *pv;
504*0Sstevel@tonic-gate
505*0Sstevel@tonic-gate sv = POPs;
506*0Sstevel@tonic-gate
507*0Sstevel@tonic-gate if (sv && SvGMAGICAL(sv))
508*0Sstevel@tonic-gate mg_get(sv);
509*0Sstevel@tonic-gate
510*0Sstevel@tonic-gate if (!sv || !SvROK(sv))
511*0Sstevel@tonic-gate RETPUSHNO;
512*0Sstevel@tonic-gate
513*0Sstevel@tonic-gate sv = SvRV(sv);
514*0Sstevel@tonic-gate pv = sv_reftype(sv,TRUE);
515*0Sstevel@tonic-gate PUSHp(pv, strlen(pv));
516*0Sstevel@tonic-gate RETURN;
517*0Sstevel@tonic-gate }
518*0Sstevel@tonic-gate
PP(pp_bless)519*0Sstevel@tonic-gate PP(pp_bless)
520*0Sstevel@tonic-gate {
521*0Sstevel@tonic-gate dSP;
522*0Sstevel@tonic-gate HV *stash;
523*0Sstevel@tonic-gate
524*0Sstevel@tonic-gate if (MAXARG == 1)
525*0Sstevel@tonic-gate stash = CopSTASH(PL_curcop);
526*0Sstevel@tonic-gate else {
527*0Sstevel@tonic-gate SV *ssv = POPs;
528*0Sstevel@tonic-gate STRLEN len;
529*0Sstevel@tonic-gate char *ptr;
530*0Sstevel@tonic-gate
531*0Sstevel@tonic-gate if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
532*0Sstevel@tonic-gate Perl_croak(aTHX_ "Attempt to bless into a reference");
533*0Sstevel@tonic-gate ptr = SvPV(ssv,len);
534*0Sstevel@tonic-gate if (ckWARN(WARN_MISC) && len == 0)
535*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_MISC),
536*0Sstevel@tonic-gate "Explicit blessing to '' (assuming package main)");
537*0Sstevel@tonic-gate stash = gv_stashpvn(ptr, len, TRUE);
538*0Sstevel@tonic-gate }
539*0Sstevel@tonic-gate
540*0Sstevel@tonic-gate (void)sv_bless(TOPs, stash);
541*0Sstevel@tonic-gate RETURN;
542*0Sstevel@tonic-gate }
543*0Sstevel@tonic-gate
PP(pp_gelem)544*0Sstevel@tonic-gate PP(pp_gelem)
545*0Sstevel@tonic-gate {
546*0Sstevel@tonic-gate GV *gv;
547*0Sstevel@tonic-gate SV *sv;
548*0Sstevel@tonic-gate SV *tmpRef;
549*0Sstevel@tonic-gate char *elem;
550*0Sstevel@tonic-gate dSP;
551*0Sstevel@tonic-gate STRLEN n_a;
552*0Sstevel@tonic-gate
553*0Sstevel@tonic-gate sv = POPs;
554*0Sstevel@tonic-gate elem = SvPV(sv, n_a);
555*0Sstevel@tonic-gate gv = (GV*)POPs;
556*0Sstevel@tonic-gate tmpRef = Nullsv;
557*0Sstevel@tonic-gate sv = Nullsv;
558*0Sstevel@tonic-gate switch (elem ? *elem : '\0')
559*0Sstevel@tonic-gate {
560*0Sstevel@tonic-gate case 'A':
561*0Sstevel@tonic-gate if (strEQ(elem, "ARRAY"))
562*0Sstevel@tonic-gate tmpRef = (SV*)GvAV(gv);
563*0Sstevel@tonic-gate break;
564*0Sstevel@tonic-gate case 'C':
565*0Sstevel@tonic-gate if (strEQ(elem, "CODE"))
566*0Sstevel@tonic-gate tmpRef = (SV*)GvCVu(gv);
567*0Sstevel@tonic-gate break;
568*0Sstevel@tonic-gate case 'F':
569*0Sstevel@tonic-gate if (strEQ(elem, "FILEHANDLE")) {
570*0Sstevel@tonic-gate /* finally deprecated in 5.8.0 */
571*0Sstevel@tonic-gate deprecate("*glob{FILEHANDLE}");
572*0Sstevel@tonic-gate tmpRef = (SV*)GvIOp(gv);
573*0Sstevel@tonic-gate }
574*0Sstevel@tonic-gate else
575*0Sstevel@tonic-gate if (strEQ(elem, "FORMAT"))
576*0Sstevel@tonic-gate tmpRef = (SV*)GvFORM(gv);
577*0Sstevel@tonic-gate break;
578*0Sstevel@tonic-gate case 'G':
579*0Sstevel@tonic-gate if (strEQ(elem, "GLOB"))
580*0Sstevel@tonic-gate tmpRef = (SV*)gv;
581*0Sstevel@tonic-gate break;
582*0Sstevel@tonic-gate case 'H':
583*0Sstevel@tonic-gate if (strEQ(elem, "HASH"))
584*0Sstevel@tonic-gate tmpRef = (SV*)GvHV(gv);
585*0Sstevel@tonic-gate break;
586*0Sstevel@tonic-gate case 'I':
587*0Sstevel@tonic-gate if (strEQ(elem, "IO"))
588*0Sstevel@tonic-gate tmpRef = (SV*)GvIOp(gv);
589*0Sstevel@tonic-gate break;
590*0Sstevel@tonic-gate case 'N':
591*0Sstevel@tonic-gate if (strEQ(elem, "NAME"))
592*0Sstevel@tonic-gate sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
593*0Sstevel@tonic-gate break;
594*0Sstevel@tonic-gate case 'P':
595*0Sstevel@tonic-gate if (strEQ(elem, "PACKAGE"))
596*0Sstevel@tonic-gate sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
597*0Sstevel@tonic-gate break;
598*0Sstevel@tonic-gate case 'S':
599*0Sstevel@tonic-gate if (strEQ(elem, "SCALAR"))
600*0Sstevel@tonic-gate tmpRef = GvSV(gv);
601*0Sstevel@tonic-gate break;
602*0Sstevel@tonic-gate }
603*0Sstevel@tonic-gate if (tmpRef)
604*0Sstevel@tonic-gate sv = newRV(tmpRef);
605*0Sstevel@tonic-gate if (sv)
606*0Sstevel@tonic-gate sv_2mortal(sv);
607*0Sstevel@tonic-gate else
608*0Sstevel@tonic-gate sv = &PL_sv_undef;
609*0Sstevel@tonic-gate XPUSHs(sv);
610*0Sstevel@tonic-gate RETURN;
611*0Sstevel@tonic-gate }
612*0Sstevel@tonic-gate
613*0Sstevel@tonic-gate /* Pattern matching */
614*0Sstevel@tonic-gate
PP(pp_study)615*0Sstevel@tonic-gate PP(pp_study)
616*0Sstevel@tonic-gate {
617*0Sstevel@tonic-gate dSP; dPOPss;
618*0Sstevel@tonic-gate register unsigned char *s;
619*0Sstevel@tonic-gate register I32 pos;
620*0Sstevel@tonic-gate register I32 ch;
621*0Sstevel@tonic-gate register I32 *sfirst;
622*0Sstevel@tonic-gate register I32 *snext;
623*0Sstevel@tonic-gate STRLEN len;
624*0Sstevel@tonic-gate
625*0Sstevel@tonic-gate if (sv == PL_lastscream) {
626*0Sstevel@tonic-gate if (SvSCREAM(sv))
627*0Sstevel@tonic-gate RETPUSHYES;
628*0Sstevel@tonic-gate }
629*0Sstevel@tonic-gate else {
630*0Sstevel@tonic-gate if (PL_lastscream) {
631*0Sstevel@tonic-gate SvSCREAM_off(PL_lastscream);
632*0Sstevel@tonic-gate SvREFCNT_dec(PL_lastscream);
633*0Sstevel@tonic-gate }
634*0Sstevel@tonic-gate PL_lastscream = SvREFCNT_inc(sv);
635*0Sstevel@tonic-gate }
636*0Sstevel@tonic-gate
637*0Sstevel@tonic-gate s = (unsigned char*)(SvPV(sv, len));
638*0Sstevel@tonic-gate pos = len;
639*0Sstevel@tonic-gate if (pos <= 0)
640*0Sstevel@tonic-gate RETPUSHNO;
641*0Sstevel@tonic-gate if (pos > PL_maxscream) {
642*0Sstevel@tonic-gate if (PL_maxscream < 0) {
643*0Sstevel@tonic-gate PL_maxscream = pos + 80;
644*0Sstevel@tonic-gate New(301, PL_screamfirst, 256, I32);
645*0Sstevel@tonic-gate New(302, PL_screamnext, PL_maxscream, I32);
646*0Sstevel@tonic-gate }
647*0Sstevel@tonic-gate else {
648*0Sstevel@tonic-gate PL_maxscream = pos + pos / 4;
649*0Sstevel@tonic-gate Renew(PL_screamnext, PL_maxscream, I32);
650*0Sstevel@tonic-gate }
651*0Sstevel@tonic-gate }
652*0Sstevel@tonic-gate
653*0Sstevel@tonic-gate sfirst = PL_screamfirst;
654*0Sstevel@tonic-gate snext = PL_screamnext;
655*0Sstevel@tonic-gate
656*0Sstevel@tonic-gate if (!sfirst || !snext)
657*0Sstevel@tonic-gate DIE(aTHX_ "do_study: out of memory");
658*0Sstevel@tonic-gate
659*0Sstevel@tonic-gate for (ch = 256; ch; --ch)
660*0Sstevel@tonic-gate *sfirst++ = -1;
661*0Sstevel@tonic-gate sfirst -= 256;
662*0Sstevel@tonic-gate
663*0Sstevel@tonic-gate while (--pos >= 0) {
664*0Sstevel@tonic-gate ch = s[pos];
665*0Sstevel@tonic-gate if (sfirst[ch] >= 0)
666*0Sstevel@tonic-gate snext[pos] = sfirst[ch] - pos;
667*0Sstevel@tonic-gate else
668*0Sstevel@tonic-gate snext[pos] = -pos;
669*0Sstevel@tonic-gate sfirst[ch] = pos;
670*0Sstevel@tonic-gate }
671*0Sstevel@tonic-gate
672*0Sstevel@tonic-gate SvSCREAM_on(sv);
673*0Sstevel@tonic-gate /* piggyback on m//g magic */
674*0Sstevel@tonic-gate sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
675*0Sstevel@tonic-gate RETPUSHYES;
676*0Sstevel@tonic-gate }
677*0Sstevel@tonic-gate
PP(pp_trans)678*0Sstevel@tonic-gate PP(pp_trans)
679*0Sstevel@tonic-gate {
680*0Sstevel@tonic-gate dSP; dTARG;
681*0Sstevel@tonic-gate SV *sv;
682*0Sstevel@tonic-gate
683*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_STACKED)
684*0Sstevel@tonic-gate sv = POPs;
685*0Sstevel@tonic-gate else {
686*0Sstevel@tonic-gate sv = DEFSV;
687*0Sstevel@tonic-gate EXTEND(SP,1);
688*0Sstevel@tonic-gate }
689*0Sstevel@tonic-gate TARG = sv_newmortal();
690*0Sstevel@tonic-gate PUSHi(do_trans(sv));
691*0Sstevel@tonic-gate RETURN;
692*0Sstevel@tonic-gate }
693*0Sstevel@tonic-gate
694*0Sstevel@tonic-gate /* Lvalue operators. */
695*0Sstevel@tonic-gate
PP(pp_schop)696*0Sstevel@tonic-gate PP(pp_schop)
697*0Sstevel@tonic-gate {
698*0Sstevel@tonic-gate dSP; dTARGET;
699*0Sstevel@tonic-gate do_chop(TARG, TOPs);
700*0Sstevel@tonic-gate SETTARG;
701*0Sstevel@tonic-gate RETURN;
702*0Sstevel@tonic-gate }
703*0Sstevel@tonic-gate
PP(pp_chop)704*0Sstevel@tonic-gate PP(pp_chop)
705*0Sstevel@tonic-gate {
706*0Sstevel@tonic-gate dSP; dMARK; dTARGET; dORIGMARK;
707*0Sstevel@tonic-gate while (MARK < SP)
708*0Sstevel@tonic-gate do_chop(TARG, *++MARK);
709*0Sstevel@tonic-gate SP = ORIGMARK;
710*0Sstevel@tonic-gate PUSHTARG;
711*0Sstevel@tonic-gate RETURN;
712*0Sstevel@tonic-gate }
713*0Sstevel@tonic-gate
PP(pp_schomp)714*0Sstevel@tonic-gate PP(pp_schomp)
715*0Sstevel@tonic-gate {
716*0Sstevel@tonic-gate dSP; dTARGET;
717*0Sstevel@tonic-gate SETi(do_chomp(TOPs));
718*0Sstevel@tonic-gate RETURN;
719*0Sstevel@tonic-gate }
720*0Sstevel@tonic-gate
PP(pp_chomp)721*0Sstevel@tonic-gate PP(pp_chomp)
722*0Sstevel@tonic-gate {
723*0Sstevel@tonic-gate dSP; dMARK; dTARGET;
724*0Sstevel@tonic-gate register I32 count = 0;
725*0Sstevel@tonic-gate
726*0Sstevel@tonic-gate while (SP > MARK)
727*0Sstevel@tonic-gate count += do_chomp(POPs);
728*0Sstevel@tonic-gate PUSHi(count);
729*0Sstevel@tonic-gate RETURN;
730*0Sstevel@tonic-gate }
731*0Sstevel@tonic-gate
PP(pp_defined)732*0Sstevel@tonic-gate PP(pp_defined)
733*0Sstevel@tonic-gate {
734*0Sstevel@tonic-gate dSP;
735*0Sstevel@tonic-gate register SV* sv;
736*0Sstevel@tonic-gate
737*0Sstevel@tonic-gate sv = POPs;
738*0Sstevel@tonic-gate if (!sv || !SvANY(sv))
739*0Sstevel@tonic-gate RETPUSHNO;
740*0Sstevel@tonic-gate switch (SvTYPE(sv)) {
741*0Sstevel@tonic-gate case SVt_PVAV:
742*0Sstevel@tonic-gate if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
743*0Sstevel@tonic-gate || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
744*0Sstevel@tonic-gate RETPUSHYES;
745*0Sstevel@tonic-gate break;
746*0Sstevel@tonic-gate case SVt_PVHV:
747*0Sstevel@tonic-gate if (HvARRAY(sv) || SvGMAGICAL(sv)
748*0Sstevel@tonic-gate || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
749*0Sstevel@tonic-gate RETPUSHYES;
750*0Sstevel@tonic-gate break;
751*0Sstevel@tonic-gate case SVt_PVCV:
752*0Sstevel@tonic-gate if (CvROOT(sv) || CvXSUB(sv))
753*0Sstevel@tonic-gate RETPUSHYES;
754*0Sstevel@tonic-gate break;
755*0Sstevel@tonic-gate default:
756*0Sstevel@tonic-gate if (SvGMAGICAL(sv))
757*0Sstevel@tonic-gate mg_get(sv);
758*0Sstevel@tonic-gate if (SvOK(sv))
759*0Sstevel@tonic-gate RETPUSHYES;
760*0Sstevel@tonic-gate }
761*0Sstevel@tonic-gate RETPUSHNO;
762*0Sstevel@tonic-gate }
763*0Sstevel@tonic-gate
PP(pp_undef)764*0Sstevel@tonic-gate PP(pp_undef)
765*0Sstevel@tonic-gate {
766*0Sstevel@tonic-gate dSP;
767*0Sstevel@tonic-gate SV *sv;
768*0Sstevel@tonic-gate
769*0Sstevel@tonic-gate if (!PL_op->op_private) {
770*0Sstevel@tonic-gate EXTEND(SP, 1);
771*0Sstevel@tonic-gate RETPUSHUNDEF;
772*0Sstevel@tonic-gate }
773*0Sstevel@tonic-gate
774*0Sstevel@tonic-gate sv = POPs;
775*0Sstevel@tonic-gate if (!sv)
776*0Sstevel@tonic-gate RETPUSHUNDEF;
777*0Sstevel@tonic-gate
778*0Sstevel@tonic-gate if (SvTHINKFIRST(sv))
779*0Sstevel@tonic-gate sv_force_normal(sv);
780*0Sstevel@tonic-gate
781*0Sstevel@tonic-gate switch (SvTYPE(sv)) {
782*0Sstevel@tonic-gate case SVt_NULL:
783*0Sstevel@tonic-gate break;
784*0Sstevel@tonic-gate case SVt_PVAV:
785*0Sstevel@tonic-gate av_undef((AV*)sv);
786*0Sstevel@tonic-gate break;
787*0Sstevel@tonic-gate case SVt_PVHV:
788*0Sstevel@tonic-gate hv_undef((HV*)sv);
789*0Sstevel@tonic-gate break;
790*0Sstevel@tonic-gate case SVt_PVCV:
791*0Sstevel@tonic-gate if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
792*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
793*0Sstevel@tonic-gate CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
794*0Sstevel@tonic-gate /* FALL THROUGH */
795*0Sstevel@tonic-gate case SVt_PVFM:
796*0Sstevel@tonic-gate {
797*0Sstevel@tonic-gate /* let user-undef'd sub keep its identity */
798*0Sstevel@tonic-gate GV* gv = CvGV((CV*)sv);
799*0Sstevel@tonic-gate cv_undef((CV*)sv);
800*0Sstevel@tonic-gate CvGV((CV*)sv) = gv;
801*0Sstevel@tonic-gate }
802*0Sstevel@tonic-gate break;
803*0Sstevel@tonic-gate case SVt_PVGV:
804*0Sstevel@tonic-gate if (SvFAKE(sv))
805*0Sstevel@tonic-gate SvSetMagicSV(sv, &PL_sv_undef);
806*0Sstevel@tonic-gate else {
807*0Sstevel@tonic-gate GP *gp;
808*0Sstevel@tonic-gate gp_free((GV*)sv);
809*0Sstevel@tonic-gate Newz(602, gp, 1, GP);
810*0Sstevel@tonic-gate GvGP(sv) = gp_ref(gp);
811*0Sstevel@tonic-gate GvSV(sv) = NEWSV(72,0);
812*0Sstevel@tonic-gate GvLINE(sv) = CopLINE(PL_curcop);
813*0Sstevel@tonic-gate GvEGV(sv) = (GV*)sv;
814*0Sstevel@tonic-gate GvMULTI_on(sv);
815*0Sstevel@tonic-gate }
816*0Sstevel@tonic-gate break;
817*0Sstevel@tonic-gate default:
818*0Sstevel@tonic-gate if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
819*0Sstevel@tonic-gate (void)SvOOK_off(sv);
820*0Sstevel@tonic-gate Safefree(SvPVX(sv));
821*0Sstevel@tonic-gate SvPV_set(sv, Nullch);
822*0Sstevel@tonic-gate SvLEN_set(sv, 0);
823*0Sstevel@tonic-gate }
824*0Sstevel@tonic-gate (void)SvOK_off(sv);
825*0Sstevel@tonic-gate SvSETMAGIC(sv);
826*0Sstevel@tonic-gate }
827*0Sstevel@tonic-gate
828*0Sstevel@tonic-gate RETPUSHUNDEF;
829*0Sstevel@tonic-gate }
830*0Sstevel@tonic-gate
PP(pp_predec)831*0Sstevel@tonic-gate PP(pp_predec)
832*0Sstevel@tonic-gate {
833*0Sstevel@tonic-gate dSP;
834*0Sstevel@tonic-gate if (SvTYPE(TOPs) > SVt_PVLV)
835*0Sstevel@tonic-gate DIE(aTHX_ PL_no_modify);
836*0Sstevel@tonic-gate if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
837*0Sstevel@tonic-gate && SvIVX(TOPs) != IV_MIN)
838*0Sstevel@tonic-gate {
839*0Sstevel@tonic-gate --SvIVX(TOPs);
840*0Sstevel@tonic-gate SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
841*0Sstevel@tonic-gate }
842*0Sstevel@tonic-gate else
843*0Sstevel@tonic-gate sv_dec(TOPs);
844*0Sstevel@tonic-gate SvSETMAGIC(TOPs);
845*0Sstevel@tonic-gate return NORMAL;
846*0Sstevel@tonic-gate }
847*0Sstevel@tonic-gate
PP(pp_postinc)848*0Sstevel@tonic-gate PP(pp_postinc)
849*0Sstevel@tonic-gate {
850*0Sstevel@tonic-gate dSP; dTARGET;
851*0Sstevel@tonic-gate if (SvTYPE(TOPs) > SVt_PVLV)
852*0Sstevel@tonic-gate DIE(aTHX_ PL_no_modify);
853*0Sstevel@tonic-gate sv_setsv(TARG, TOPs);
854*0Sstevel@tonic-gate if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
855*0Sstevel@tonic-gate && SvIVX(TOPs) != IV_MAX)
856*0Sstevel@tonic-gate {
857*0Sstevel@tonic-gate ++SvIVX(TOPs);
858*0Sstevel@tonic-gate SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
859*0Sstevel@tonic-gate }
860*0Sstevel@tonic-gate else
861*0Sstevel@tonic-gate sv_inc(TOPs);
862*0Sstevel@tonic-gate SvSETMAGIC(TOPs);
863*0Sstevel@tonic-gate /* special case for undef: see thread at 2003-03/msg00536.html in archive */
864*0Sstevel@tonic-gate if (!SvOK(TARG))
865*0Sstevel@tonic-gate sv_setiv(TARG, 0);
866*0Sstevel@tonic-gate SETs(TARG);
867*0Sstevel@tonic-gate return NORMAL;
868*0Sstevel@tonic-gate }
869*0Sstevel@tonic-gate
PP(pp_postdec)870*0Sstevel@tonic-gate PP(pp_postdec)
871*0Sstevel@tonic-gate {
872*0Sstevel@tonic-gate dSP; dTARGET;
873*0Sstevel@tonic-gate if (SvTYPE(TOPs) > SVt_PVLV)
874*0Sstevel@tonic-gate DIE(aTHX_ PL_no_modify);
875*0Sstevel@tonic-gate sv_setsv(TARG, TOPs);
876*0Sstevel@tonic-gate if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
877*0Sstevel@tonic-gate && SvIVX(TOPs) != IV_MIN)
878*0Sstevel@tonic-gate {
879*0Sstevel@tonic-gate --SvIVX(TOPs);
880*0Sstevel@tonic-gate SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
881*0Sstevel@tonic-gate }
882*0Sstevel@tonic-gate else
883*0Sstevel@tonic-gate sv_dec(TOPs);
884*0Sstevel@tonic-gate SvSETMAGIC(TOPs);
885*0Sstevel@tonic-gate SETs(TARG);
886*0Sstevel@tonic-gate return NORMAL;
887*0Sstevel@tonic-gate }
888*0Sstevel@tonic-gate
889*0Sstevel@tonic-gate /* Ordinary operators. */
890*0Sstevel@tonic-gate
PP(pp_pow)891*0Sstevel@tonic-gate PP(pp_pow)
892*0Sstevel@tonic-gate {
893*0Sstevel@tonic-gate dSP; dATARGET;
894*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
895*0Sstevel@tonic-gate bool is_int = 0;
896*0Sstevel@tonic-gate #endif
897*0Sstevel@tonic-gate tryAMAGICbin(pow,opASSIGN);
898*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
899*0Sstevel@tonic-gate /* For integer to integer power, we do the calculation by hand wherever
900*0Sstevel@tonic-gate we're sure it is safe; otherwise we call pow() and try to convert to
901*0Sstevel@tonic-gate integer afterwards. */
902*0Sstevel@tonic-gate {
903*0Sstevel@tonic-gate SvIV_please(TOPm1s);
904*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
905*0Sstevel@tonic-gate bool baseuok = SvUOK(TOPm1s);
906*0Sstevel@tonic-gate UV baseuv;
907*0Sstevel@tonic-gate
908*0Sstevel@tonic-gate if (baseuok) {
909*0Sstevel@tonic-gate baseuv = SvUVX(TOPm1s);
910*0Sstevel@tonic-gate } else {
911*0Sstevel@tonic-gate IV iv = SvIVX(TOPm1s);
912*0Sstevel@tonic-gate if (iv >= 0) {
913*0Sstevel@tonic-gate baseuv = iv;
914*0Sstevel@tonic-gate baseuok = TRUE; /* effectively it's a UV now */
915*0Sstevel@tonic-gate } else {
916*0Sstevel@tonic-gate baseuv = -iv; /* abs, baseuok == false records sign */
917*0Sstevel@tonic-gate }
918*0Sstevel@tonic-gate }
919*0Sstevel@tonic-gate SvIV_please(TOPs);
920*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
921*0Sstevel@tonic-gate UV power;
922*0Sstevel@tonic-gate
923*0Sstevel@tonic-gate if (SvUOK(TOPs)) {
924*0Sstevel@tonic-gate power = SvUVX(TOPs);
925*0Sstevel@tonic-gate } else {
926*0Sstevel@tonic-gate IV iv = SvIVX(TOPs);
927*0Sstevel@tonic-gate if (iv >= 0) {
928*0Sstevel@tonic-gate power = iv;
929*0Sstevel@tonic-gate } else {
930*0Sstevel@tonic-gate goto float_it; /* Can't do negative powers this way. */
931*0Sstevel@tonic-gate }
932*0Sstevel@tonic-gate }
933*0Sstevel@tonic-gate /* now we have integer ** positive integer. */
934*0Sstevel@tonic-gate is_int = 1;
935*0Sstevel@tonic-gate
936*0Sstevel@tonic-gate /* foo & (foo - 1) is zero only for a power of 2. */
937*0Sstevel@tonic-gate if (!(baseuv & (baseuv - 1))) {
938*0Sstevel@tonic-gate /* We are raising power-of-2 to a positive integer.
939*0Sstevel@tonic-gate The logic here will work for any base (even non-integer
940*0Sstevel@tonic-gate bases) but it can be less accurate than
941*0Sstevel@tonic-gate pow (base,power) or exp (power * log (base)) when the
942*0Sstevel@tonic-gate intermediate values start to spill out of the mantissa.
943*0Sstevel@tonic-gate With powers of 2 we know this can't happen.
944*0Sstevel@tonic-gate And powers of 2 are the favourite thing for perl
945*0Sstevel@tonic-gate programmers to notice ** not doing what they mean. */
946*0Sstevel@tonic-gate NV result = 1.0;
947*0Sstevel@tonic-gate NV base = baseuok ? baseuv : -(NV)baseuv;
948*0Sstevel@tonic-gate int n = 0;
949*0Sstevel@tonic-gate
950*0Sstevel@tonic-gate for (; power; base *= base, n++) {
951*0Sstevel@tonic-gate /* Do I look like I trust gcc with long longs here?
952*0Sstevel@tonic-gate Do I hell. */
953*0Sstevel@tonic-gate UV bit = (UV)1 << (UV)n;
954*0Sstevel@tonic-gate if (power & bit) {
955*0Sstevel@tonic-gate result *= base;
956*0Sstevel@tonic-gate /* Only bother to clear the bit if it is set. */
957*0Sstevel@tonic-gate power -= bit;
958*0Sstevel@tonic-gate /* Avoid squaring base again if we're done. */
959*0Sstevel@tonic-gate if (power == 0) break;
960*0Sstevel@tonic-gate }
961*0Sstevel@tonic-gate }
962*0Sstevel@tonic-gate SP--;
963*0Sstevel@tonic-gate SETn( result );
964*0Sstevel@tonic-gate SvIV_please(TOPs);
965*0Sstevel@tonic-gate RETURN;
966*0Sstevel@tonic-gate } else {
967*0Sstevel@tonic-gate register unsigned int highbit = 8 * sizeof(UV);
968*0Sstevel@tonic-gate register unsigned int lowbit = 0;
969*0Sstevel@tonic-gate register unsigned int diff;
970*0Sstevel@tonic-gate bool odd_power = (bool)(power & 1);
971*0Sstevel@tonic-gate while ((diff = (highbit - lowbit) >> 1)) {
972*0Sstevel@tonic-gate if (baseuv & ~((1 << (lowbit + diff)) - 1))
973*0Sstevel@tonic-gate lowbit += diff;
974*0Sstevel@tonic-gate else
975*0Sstevel@tonic-gate highbit -= diff;
976*0Sstevel@tonic-gate }
977*0Sstevel@tonic-gate /* we now have baseuv < 2 ** highbit */
978*0Sstevel@tonic-gate if (power * highbit <= 8 * sizeof(UV)) {
979*0Sstevel@tonic-gate /* result will definitely fit in UV, so use UV math
980*0Sstevel@tonic-gate on same algorithm as above */
981*0Sstevel@tonic-gate register UV result = 1;
982*0Sstevel@tonic-gate register UV base = baseuv;
983*0Sstevel@tonic-gate register int n = 0;
984*0Sstevel@tonic-gate for (; power; base *= base, n++) {
985*0Sstevel@tonic-gate register UV bit = (UV)1 << (UV)n;
986*0Sstevel@tonic-gate if (power & bit) {
987*0Sstevel@tonic-gate result *= base;
988*0Sstevel@tonic-gate power -= bit;
989*0Sstevel@tonic-gate if (power == 0) break;
990*0Sstevel@tonic-gate }
991*0Sstevel@tonic-gate }
992*0Sstevel@tonic-gate SP--;
993*0Sstevel@tonic-gate if (baseuok || !odd_power)
994*0Sstevel@tonic-gate /* answer is positive */
995*0Sstevel@tonic-gate SETu( result );
996*0Sstevel@tonic-gate else if (result <= (UV)IV_MAX)
997*0Sstevel@tonic-gate /* answer negative, fits in IV */
998*0Sstevel@tonic-gate SETi( -(IV)result );
999*0Sstevel@tonic-gate else if (result == (UV)IV_MIN)
1000*0Sstevel@tonic-gate /* 2's complement assumption: special case IV_MIN */
1001*0Sstevel@tonic-gate SETi( IV_MIN );
1002*0Sstevel@tonic-gate else
1003*0Sstevel@tonic-gate /* answer negative, doesn't fit */
1004*0Sstevel@tonic-gate SETn( -(NV)result );
1005*0Sstevel@tonic-gate RETURN;
1006*0Sstevel@tonic-gate }
1007*0Sstevel@tonic-gate }
1008*0Sstevel@tonic-gate }
1009*0Sstevel@tonic-gate }
1010*0Sstevel@tonic-gate }
1011*0Sstevel@tonic-gate float_it:
1012*0Sstevel@tonic-gate #endif
1013*0Sstevel@tonic-gate {
1014*0Sstevel@tonic-gate dPOPTOPnnrl;
1015*0Sstevel@tonic-gate SETn( Perl_pow( left, right) );
1016*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1017*0Sstevel@tonic-gate if (is_int)
1018*0Sstevel@tonic-gate SvIV_please(TOPs);
1019*0Sstevel@tonic-gate #endif
1020*0Sstevel@tonic-gate RETURN;
1021*0Sstevel@tonic-gate }
1022*0Sstevel@tonic-gate }
1023*0Sstevel@tonic-gate
PP(pp_multiply)1024*0Sstevel@tonic-gate PP(pp_multiply)
1025*0Sstevel@tonic-gate {
1026*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1027*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1028*0Sstevel@tonic-gate SvIV_please(TOPs);
1029*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1030*0Sstevel@tonic-gate /* Unless the left argument is integer in range we are going to have to
1031*0Sstevel@tonic-gate use NV maths. Hence only attempt to coerce the right argument if
1032*0Sstevel@tonic-gate we know the left is integer. */
1033*0Sstevel@tonic-gate /* Left operand is defined, so is it IV? */
1034*0Sstevel@tonic-gate SvIV_please(TOPm1s);
1035*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
1036*0Sstevel@tonic-gate bool auvok = SvUOK(TOPm1s);
1037*0Sstevel@tonic-gate bool buvok = SvUOK(TOPs);
1038*0Sstevel@tonic-gate const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1039*0Sstevel@tonic-gate const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1040*0Sstevel@tonic-gate UV alow;
1041*0Sstevel@tonic-gate UV ahigh;
1042*0Sstevel@tonic-gate UV blow;
1043*0Sstevel@tonic-gate UV bhigh;
1044*0Sstevel@tonic-gate
1045*0Sstevel@tonic-gate if (auvok) {
1046*0Sstevel@tonic-gate alow = SvUVX(TOPm1s);
1047*0Sstevel@tonic-gate } else {
1048*0Sstevel@tonic-gate IV aiv = SvIVX(TOPm1s);
1049*0Sstevel@tonic-gate if (aiv >= 0) {
1050*0Sstevel@tonic-gate alow = aiv;
1051*0Sstevel@tonic-gate auvok = TRUE; /* effectively it's a UV now */
1052*0Sstevel@tonic-gate } else {
1053*0Sstevel@tonic-gate alow = -aiv; /* abs, auvok == false records sign */
1054*0Sstevel@tonic-gate }
1055*0Sstevel@tonic-gate }
1056*0Sstevel@tonic-gate if (buvok) {
1057*0Sstevel@tonic-gate blow = SvUVX(TOPs);
1058*0Sstevel@tonic-gate } else {
1059*0Sstevel@tonic-gate IV biv = SvIVX(TOPs);
1060*0Sstevel@tonic-gate if (biv >= 0) {
1061*0Sstevel@tonic-gate blow = biv;
1062*0Sstevel@tonic-gate buvok = TRUE; /* effectively it's a UV now */
1063*0Sstevel@tonic-gate } else {
1064*0Sstevel@tonic-gate blow = -biv; /* abs, buvok == false records sign */
1065*0Sstevel@tonic-gate }
1066*0Sstevel@tonic-gate }
1067*0Sstevel@tonic-gate
1068*0Sstevel@tonic-gate /* If this does sign extension on unsigned it's time for plan B */
1069*0Sstevel@tonic-gate ahigh = alow >> (4 * sizeof (UV));
1070*0Sstevel@tonic-gate alow &= botmask;
1071*0Sstevel@tonic-gate bhigh = blow >> (4 * sizeof (UV));
1072*0Sstevel@tonic-gate blow &= botmask;
1073*0Sstevel@tonic-gate if (ahigh && bhigh) {
1074*0Sstevel@tonic-gate /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1075*0Sstevel@tonic-gate which is overflow. Drop to NVs below. */
1076*0Sstevel@tonic-gate } else if (!ahigh && !bhigh) {
1077*0Sstevel@tonic-gate /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1078*0Sstevel@tonic-gate so the unsigned multiply cannot overflow. */
1079*0Sstevel@tonic-gate UV product = alow * blow;
1080*0Sstevel@tonic-gate if (auvok == buvok) {
1081*0Sstevel@tonic-gate /* -ve * -ve or +ve * +ve gives a +ve result. */
1082*0Sstevel@tonic-gate SP--;
1083*0Sstevel@tonic-gate SETu( product );
1084*0Sstevel@tonic-gate RETURN;
1085*0Sstevel@tonic-gate } else if (product <= (UV)IV_MIN) {
1086*0Sstevel@tonic-gate /* 2s complement assumption that (UV)-IV_MIN is correct. */
1087*0Sstevel@tonic-gate /* -ve result, which could overflow an IV */
1088*0Sstevel@tonic-gate SP--;
1089*0Sstevel@tonic-gate SETi( -(IV)product );
1090*0Sstevel@tonic-gate RETURN;
1091*0Sstevel@tonic-gate } /* else drop to NVs below. */
1092*0Sstevel@tonic-gate } else {
1093*0Sstevel@tonic-gate /* One operand is large, 1 small */
1094*0Sstevel@tonic-gate UV product_middle;
1095*0Sstevel@tonic-gate if (bhigh) {
1096*0Sstevel@tonic-gate /* swap the operands */
1097*0Sstevel@tonic-gate ahigh = bhigh;
1098*0Sstevel@tonic-gate bhigh = blow; /* bhigh now the temp var for the swap */
1099*0Sstevel@tonic-gate blow = alow;
1100*0Sstevel@tonic-gate alow = bhigh;
1101*0Sstevel@tonic-gate }
1102*0Sstevel@tonic-gate /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1103*0Sstevel@tonic-gate multiplies can't overflow. shift can, add can, -ve can. */
1104*0Sstevel@tonic-gate product_middle = ahigh * blow;
1105*0Sstevel@tonic-gate if (!(product_middle & topmask)) {
1106*0Sstevel@tonic-gate /* OK, (ahigh * blow) won't lose bits when we shift it. */
1107*0Sstevel@tonic-gate UV product_low;
1108*0Sstevel@tonic-gate product_middle <<= (4 * sizeof (UV));
1109*0Sstevel@tonic-gate product_low = alow * blow;
1110*0Sstevel@tonic-gate
1111*0Sstevel@tonic-gate /* as for pp_add, UV + something mustn't get smaller.
1112*0Sstevel@tonic-gate IIRC ANSI mandates this wrapping *behaviour* for
1113*0Sstevel@tonic-gate unsigned whatever the actual representation*/
1114*0Sstevel@tonic-gate product_low += product_middle;
1115*0Sstevel@tonic-gate if (product_low >= product_middle) {
1116*0Sstevel@tonic-gate /* didn't overflow */
1117*0Sstevel@tonic-gate if (auvok == buvok) {
1118*0Sstevel@tonic-gate /* -ve * -ve or +ve * +ve gives a +ve result. */
1119*0Sstevel@tonic-gate SP--;
1120*0Sstevel@tonic-gate SETu( product_low );
1121*0Sstevel@tonic-gate RETURN;
1122*0Sstevel@tonic-gate } else if (product_low <= (UV)IV_MIN) {
1123*0Sstevel@tonic-gate /* 2s complement assumption again */
1124*0Sstevel@tonic-gate /* -ve result, which could overflow an IV */
1125*0Sstevel@tonic-gate SP--;
1126*0Sstevel@tonic-gate SETi( -(IV)product_low );
1127*0Sstevel@tonic-gate RETURN;
1128*0Sstevel@tonic-gate } /* else drop to NVs below. */
1129*0Sstevel@tonic-gate }
1130*0Sstevel@tonic-gate } /* product_middle too large */
1131*0Sstevel@tonic-gate } /* ahigh && bhigh */
1132*0Sstevel@tonic-gate } /* SvIOK(TOPm1s) */
1133*0Sstevel@tonic-gate } /* SvIOK(TOPs) */
1134*0Sstevel@tonic-gate #endif
1135*0Sstevel@tonic-gate {
1136*0Sstevel@tonic-gate dPOPTOPnnrl;
1137*0Sstevel@tonic-gate SETn( left * right );
1138*0Sstevel@tonic-gate RETURN;
1139*0Sstevel@tonic-gate }
1140*0Sstevel@tonic-gate }
1141*0Sstevel@tonic-gate
PP(pp_divide)1142*0Sstevel@tonic-gate PP(pp_divide)
1143*0Sstevel@tonic-gate {
1144*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1145*0Sstevel@tonic-gate /* Only try to do UV divide first
1146*0Sstevel@tonic-gate if ((SLOPPYDIVIDE is true) or
1147*0Sstevel@tonic-gate (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1148*0Sstevel@tonic-gate to preserve))
1149*0Sstevel@tonic-gate The assumption is that it is better to use floating point divide
1150*0Sstevel@tonic-gate whenever possible, only doing integer divide first if we can't be sure.
1151*0Sstevel@tonic-gate If NV_PRESERVES_UV is true then we know at compile time that no UV
1152*0Sstevel@tonic-gate can be too large to preserve, so don't need to compile the code to
1153*0Sstevel@tonic-gate test the size of UVs. */
1154*0Sstevel@tonic-gate
1155*0Sstevel@tonic-gate #ifdef SLOPPYDIVIDE
1156*0Sstevel@tonic-gate # define PERL_TRY_UV_DIVIDE
1157*0Sstevel@tonic-gate /* ensure that 20./5. == 4. */
1158*0Sstevel@tonic-gate #else
1159*0Sstevel@tonic-gate # ifdef PERL_PRESERVE_IVUV
1160*0Sstevel@tonic-gate # ifndef NV_PRESERVES_UV
1161*0Sstevel@tonic-gate # define PERL_TRY_UV_DIVIDE
1162*0Sstevel@tonic-gate # endif
1163*0Sstevel@tonic-gate # endif
1164*0Sstevel@tonic-gate #endif
1165*0Sstevel@tonic-gate
1166*0Sstevel@tonic-gate #ifdef PERL_TRY_UV_DIVIDE
1167*0Sstevel@tonic-gate SvIV_please(TOPs);
1168*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1169*0Sstevel@tonic-gate SvIV_please(TOPm1s);
1170*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
1171*0Sstevel@tonic-gate bool left_non_neg = SvUOK(TOPm1s);
1172*0Sstevel@tonic-gate bool right_non_neg = SvUOK(TOPs);
1173*0Sstevel@tonic-gate UV left;
1174*0Sstevel@tonic-gate UV right;
1175*0Sstevel@tonic-gate
1176*0Sstevel@tonic-gate if (right_non_neg) {
1177*0Sstevel@tonic-gate right = SvUVX(TOPs);
1178*0Sstevel@tonic-gate }
1179*0Sstevel@tonic-gate else {
1180*0Sstevel@tonic-gate IV biv = SvIVX(TOPs);
1181*0Sstevel@tonic-gate if (biv >= 0) {
1182*0Sstevel@tonic-gate right = biv;
1183*0Sstevel@tonic-gate right_non_neg = TRUE; /* effectively it's a UV now */
1184*0Sstevel@tonic-gate }
1185*0Sstevel@tonic-gate else {
1186*0Sstevel@tonic-gate right = -biv;
1187*0Sstevel@tonic-gate }
1188*0Sstevel@tonic-gate }
1189*0Sstevel@tonic-gate /* historically undef()/0 gives a "Use of uninitialized value"
1190*0Sstevel@tonic-gate warning before dieing, hence this test goes here.
1191*0Sstevel@tonic-gate If it were immediately before the second SvIV_please, then
1192*0Sstevel@tonic-gate DIE() would be invoked before left was even inspected, so
1193*0Sstevel@tonic-gate no inpsection would give no warning. */
1194*0Sstevel@tonic-gate if (right == 0)
1195*0Sstevel@tonic-gate DIE(aTHX_ "Illegal division by zero");
1196*0Sstevel@tonic-gate
1197*0Sstevel@tonic-gate if (left_non_neg) {
1198*0Sstevel@tonic-gate left = SvUVX(TOPm1s);
1199*0Sstevel@tonic-gate }
1200*0Sstevel@tonic-gate else {
1201*0Sstevel@tonic-gate IV aiv = SvIVX(TOPm1s);
1202*0Sstevel@tonic-gate if (aiv >= 0) {
1203*0Sstevel@tonic-gate left = aiv;
1204*0Sstevel@tonic-gate left_non_neg = TRUE; /* effectively it's a UV now */
1205*0Sstevel@tonic-gate }
1206*0Sstevel@tonic-gate else {
1207*0Sstevel@tonic-gate left = -aiv;
1208*0Sstevel@tonic-gate }
1209*0Sstevel@tonic-gate }
1210*0Sstevel@tonic-gate
1211*0Sstevel@tonic-gate if (left >= right
1212*0Sstevel@tonic-gate #ifdef SLOPPYDIVIDE
1213*0Sstevel@tonic-gate /* For sloppy divide we always attempt integer division. */
1214*0Sstevel@tonic-gate #else
1215*0Sstevel@tonic-gate /* Otherwise we only attempt it if either or both operands
1216*0Sstevel@tonic-gate would not be preserved by an NV. If both fit in NVs
1217*0Sstevel@tonic-gate we fall through to the NV divide code below. However,
1218*0Sstevel@tonic-gate as left >= right to ensure integer result here, we know that
1219*0Sstevel@tonic-gate we can skip the test on the right operand - right big
1220*0Sstevel@tonic-gate enough not to be preserved can't get here unless left is
1221*0Sstevel@tonic-gate also too big. */
1222*0Sstevel@tonic-gate
1223*0Sstevel@tonic-gate && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1224*0Sstevel@tonic-gate #endif
1225*0Sstevel@tonic-gate ) {
1226*0Sstevel@tonic-gate /* Integer division can't overflow, but it can be imprecise. */
1227*0Sstevel@tonic-gate UV result = left / right;
1228*0Sstevel@tonic-gate if (result * right == left) {
1229*0Sstevel@tonic-gate SP--; /* result is valid */
1230*0Sstevel@tonic-gate if (left_non_neg == right_non_neg) {
1231*0Sstevel@tonic-gate /* signs identical, result is positive. */
1232*0Sstevel@tonic-gate SETu( result );
1233*0Sstevel@tonic-gate RETURN;
1234*0Sstevel@tonic-gate }
1235*0Sstevel@tonic-gate /* 2s complement assumption */
1236*0Sstevel@tonic-gate if (result <= (UV)IV_MIN)
1237*0Sstevel@tonic-gate SETi( -(IV)result );
1238*0Sstevel@tonic-gate else {
1239*0Sstevel@tonic-gate /* It's exact but too negative for IV. */
1240*0Sstevel@tonic-gate SETn( -(NV)result );
1241*0Sstevel@tonic-gate }
1242*0Sstevel@tonic-gate RETURN;
1243*0Sstevel@tonic-gate } /* tried integer divide but it was not an integer result */
1244*0Sstevel@tonic-gate } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1245*0Sstevel@tonic-gate } /* left wasn't SvIOK */
1246*0Sstevel@tonic-gate } /* right wasn't SvIOK */
1247*0Sstevel@tonic-gate #endif /* PERL_TRY_UV_DIVIDE */
1248*0Sstevel@tonic-gate {
1249*0Sstevel@tonic-gate dPOPPOPnnrl;
1250*0Sstevel@tonic-gate if (right == 0.0)
1251*0Sstevel@tonic-gate DIE(aTHX_ "Illegal division by zero");
1252*0Sstevel@tonic-gate PUSHn( left / right );
1253*0Sstevel@tonic-gate RETURN;
1254*0Sstevel@tonic-gate }
1255*0Sstevel@tonic-gate }
1256*0Sstevel@tonic-gate
PP(pp_modulo)1257*0Sstevel@tonic-gate PP(pp_modulo)
1258*0Sstevel@tonic-gate {
1259*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1260*0Sstevel@tonic-gate {
1261*0Sstevel@tonic-gate UV left = 0;
1262*0Sstevel@tonic-gate UV right = 0;
1263*0Sstevel@tonic-gate bool left_neg = FALSE;
1264*0Sstevel@tonic-gate bool right_neg = FALSE;
1265*0Sstevel@tonic-gate bool use_double = FALSE;
1266*0Sstevel@tonic-gate bool dright_valid = FALSE;
1267*0Sstevel@tonic-gate NV dright = 0.0;
1268*0Sstevel@tonic-gate NV dleft = 0.0;
1269*0Sstevel@tonic-gate
1270*0Sstevel@tonic-gate SvIV_please(TOPs);
1271*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1272*0Sstevel@tonic-gate right_neg = !SvUOK(TOPs);
1273*0Sstevel@tonic-gate if (!right_neg) {
1274*0Sstevel@tonic-gate right = SvUVX(POPs);
1275*0Sstevel@tonic-gate } else {
1276*0Sstevel@tonic-gate IV biv = SvIVX(POPs);
1277*0Sstevel@tonic-gate if (biv >= 0) {
1278*0Sstevel@tonic-gate right = biv;
1279*0Sstevel@tonic-gate right_neg = FALSE; /* effectively it's a UV now */
1280*0Sstevel@tonic-gate } else {
1281*0Sstevel@tonic-gate right = -biv;
1282*0Sstevel@tonic-gate }
1283*0Sstevel@tonic-gate }
1284*0Sstevel@tonic-gate }
1285*0Sstevel@tonic-gate else {
1286*0Sstevel@tonic-gate dright = POPn;
1287*0Sstevel@tonic-gate right_neg = dright < 0;
1288*0Sstevel@tonic-gate if (right_neg)
1289*0Sstevel@tonic-gate dright = -dright;
1290*0Sstevel@tonic-gate if (dright < UV_MAX_P1) {
1291*0Sstevel@tonic-gate right = U_V(dright);
1292*0Sstevel@tonic-gate dright_valid = TRUE; /* In case we need to use double below. */
1293*0Sstevel@tonic-gate } else {
1294*0Sstevel@tonic-gate use_double = TRUE;
1295*0Sstevel@tonic-gate }
1296*0Sstevel@tonic-gate }
1297*0Sstevel@tonic-gate
1298*0Sstevel@tonic-gate /* At this point use_double is only true if right is out of range for
1299*0Sstevel@tonic-gate a UV. In range NV has been rounded down to nearest UV and
1300*0Sstevel@tonic-gate use_double false. */
1301*0Sstevel@tonic-gate SvIV_please(TOPs);
1302*0Sstevel@tonic-gate if (!use_double && SvIOK(TOPs)) {
1303*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1304*0Sstevel@tonic-gate left_neg = !SvUOK(TOPs);
1305*0Sstevel@tonic-gate if (!left_neg) {
1306*0Sstevel@tonic-gate left = SvUVX(POPs);
1307*0Sstevel@tonic-gate } else {
1308*0Sstevel@tonic-gate IV aiv = SvIVX(POPs);
1309*0Sstevel@tonic-gate if (aiv >= 0) {
1310*0Sstevel@tonic-gate left = aiv;
1311*0Sstevel@tonic-gate left_neg = FALSE; /* effectively it's a UV now */
1312*0Sstevel@tonic-gate } else {
1313*0Sstevel@tonic-gate left = -aiv;
1314*0Sstevel@tonic-gate }
1315*0Sstevel@tonic-gate }
1316*0Sstevel@tonic-gate }
1317*0Sstevel@tonic-gate }
1318*0Sstevel@tonic-gate else {
1319*0Sstevel@tonic-gate dleft = POPn;
1320*0Sstevel@tonic-gate left_neg = dleft < 0;
1321*0Sstevel@tonic-gate if (left_neg)
1322*0Sstevel@tonic-gate dleft = -dleft;
1323*0Sstevel@tonic-gate
1324*0Sstevel@tonic-gate /* This should be exactly the 5.6 behaviour - if left and right are
1325*0Sstevel@tonic-gate both in range for UV then use U_V() rather than floor. */
1326*0Sstevel@tonic-gate if (!use_double) {
1327*0Sstevel@tonic-gate if (dleft < UV_MAX_P1) {
1328*0Sstevel@tonic-gate /* right was in range, so is dleft, so use UVs not double.
1329*0Sstevel@tonic-gate */
1330*0Sstevel@tonic-gate left = U_V(dleft);
1331*0Sstevel@tonic-gate }
1332*0Sstevel@tonic-gate /* left is out of range for UV, right was in range, so promote
1333*0Sstevel@tonic-gate right (back) to double. */
1334*0Sstevel@tonic-gate else {
1335*0Sstevel@tonic-gate /* The +0.5 is used in 5.6 even though it is not strictly
1336*0Sstevel@tonic-gate consistent with the implicit +0 floor in the U_V()
1337*0Sstevel@tonic-gate inside the #if 1. */
1338*0Sstevel@tonic-gate dleft = Perl_floor(dleft + 0.5);
1339*0Sstevel@tonic-gate use_double = TRUE;
1340*0Sstevel@tonic-gate if (dright_valid)
1341*0Sstevel@tonic-gate dright = Perl_floor(dright + 0.5);
1342*0Sstevel@tonic-gate else
1343*0Sstevel@tonic-gate dright = right;
1344*0Sstevel@tonic-gate }
1345*0Sstevel@tonic-gate }
1346*0Sstevel@tonic-gate }
1347*0Sstevel@tonic-gate if (use_double) {
1348*0Sstevel@tonic-gate NV dans;
1349*0Sstevel@tonic-gate
1350*0Sstevel@tonic-gate if (!dright)
1351*0Sstevel@tonic-gate DIE(aTHX_ "Illegal modulus zero");
1352*0Sstevel@tonic-gate
1353*0Sstevel@tonic-gate dans = Perl_fmod(dleft, dright);
1354*0Sstevel@tonic-gate if ((left_neg != right_neg) && dans)
1355*0Sstevel@tonic-gate dans = dright - dans;
1356*0Sstevel@tonic-gate if (right_neg)
1357*0Sstevel@tonic-gate dans = -dans;
1358*0Sstevel@tonic-gate sv_setnv(TARG, dans);
1359*0Sstevel@tonic-gate }
1360*0Sstevel@tonic-gate else {
1361*0Sstevel@tonic-gate UV ans;
1362*0Sstevel@tonic-gate
1363*0Sstevel@tonic-gate if (!right)
1364*0Sstevel@tonic-gate DIE(aTHX_ "Illegal modulus zero");
1365*0Sstevel@tonic-gate
1366*0Sstevel@tonic-gate ans = left % right;
1367*0Sstevel@tonic-gate if ((left_neg != right_neg) && ans)
1368*0Sstevel@tonic-gate ans = right - ans;
1369*0Sstevel@tonic-gate if (right_neg) {
1370*0Sstevel@tonic-gate /* XXX may warn: unary minus operator applied to unsigned type */
1371*0Sstevel@tonic-gate /* could change -foo to be (~foo)+1 instead */
1372*0Sstevel@tonic-gate if (ans <= ~((UV)IV_MAX)+1)
1373*0Sstevel@tonic-gate sv_setiv(TARG, ~ans+1);
1374*0Sstevel@tonic-gate else
1375*0Sstevel@tonic-gate sv_setnv(TARG, -(NV)ans);
1376*0Sstevel@tonic-gate }
1377*0Sstevel@tonic-gate else
1378*0Sstevel@tonic-gate sv_setuv(TARG, ans);
1379*0Sstevel@tonic-gate }
1380*0Sstevel@tonic-gate PUSHTARG;
1381*0Sstevel@tonic-gate RETURN;
1382*0Sstevel@tonic-gate }
1383*0Sstevel@tonic-gate }
1384*0Sstevel@tonic-gate
PP(pp_repeat)1385*0Sstevel@tonic-gate PP(pp_repeat)
1386*0Sstevel@tonic-gate {
1387*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1388*0Sstevel@tonic-gate {
1389*0Sstevel@tonic-gate register IV count = POPi;
1390*0Sstevel@tonic-gate if (count < 0)
1391*0Sstevel@tonic-gate count = 0;
1392*0Sstevel@tonic-gate if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1393*0Sstevel@tonic-gate dMARK;
1394*0Sstevel@tonic-gate I32 items = SP - MARK;
1395*0Sstevel@tonic-gate I32 max;
1396*0Sstevel@tonic-gate static const char list_extend[] = "panic: list extend";
1397*0Sstevel@tonic-gate
1398*0Sstevel@tonic-gate max = items * count;
1399*0Sstevel@tonic-gate MEM_WRAP_CHECK_1(max, SV*, list_extend);
1400*0Sstevel@tonic-gate if (items > 0 && max > 0 && (max < items || max < count))
1401*0Sstevel@tonic-gate Perl_croak(aTHX_ list_extend);
1402*0Sstevel@tonic-gate MEXTEND(MARK, max);
1403*0Sstevel@tonic-gate if (count > 1) {
1404*0Sstevel@tonic-gate while (SP > MARK) {
1405*0Sstevel@tonic-gate #if 0
1406*0Sstevel@tonic-gate /* This code was intended to fix 20010809.028:
1407*0Sstevel@tonic-gate
1408*0Sstevel@tonic-gate $x = 'abcd';
1409*0Sstevel@tonic-gate for (($x =~ /./g) x 2) {
1410*0Sstevel@tonic-gate print chop; # "abcdabcd" expected as output.
1411*0Sstevel@tonic-gate }
1412*0Sstevel@tonic-gate
1413*0Sstevel@tonic-gate * but that change (#11635) broke this code:
1414*0Sstevel@tonic-gate
1415*0Sstevel@tonic-gate $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1416*0Sstevel@tonic-gate
1417*0Sstevel@tonic-gate * I can't think of a better fix that doesn't introduce
1418*0Sstevel@tonic-gate * an efficiency hit by copying the SVs. The stack isn't
1419*0Sstevel@tonic-gate * refcounted, and mortalisation obviously doesn't
1420*0Sstevel@tonic-gate * Do The Right Thing when the stack has more than
1421*0Sstevel@tonic-gate * one pointer to the same mortal value.
1422*0Sstevel@tonic-gate * .robin.
1423*0Sstevel@tonic-gate */
1424*0Sstevel@tonic-gate if (*SP) {
1425*0Sstevel@tonic-gate *SP = sv_2mortal(newSVsv(*SP));
1426*0Sstevel@tonic-gate SvREADONLY_on(*SP);
1427*0Sstevel@tonic-gate }
1428*0Sstevel@tonic-gate #else
1429*0Sstevel@tonic-gate if (*SP)
1430*0Sstevel@tonic-gate SvTEMP_off((*SP));
1431*0Sstevel@tonic-gate #endif
1432*0Sstevel@tonic-gate SP--;
1433*0Sstevel@tonic-gate }
1434*0Sstevel@tonic-gate MARK++;
1435*0Sstevel@tonic-gate repeatcpy((char*)(MARK + items), (char*)MARK,
1436*0Sstevel@tonic-gate items * sizeof(SV*), count - 1);
1437*0Sstevel@tonic-gate SP += max;
1438*0Sstevel@tonic-gate }
1439*0Sstevel@tonic-gate else if (count <= 0)
1440*0Sstevel@tonic-gate SP -= items;
1441*0Sstevel@tonic-gate }
1442*0Sstevel@tonic-gate else { /* Note: mark already snarfed by pp_list */
1443*0Sstevel@tonic-gate SV *tmpstr = POPs;
1444*0Sstevel@tonic-gate STRLEN len;
1445*0Sstevel@tonic-gate bool isutf;
1446*0Sstevel@tonic-gate
1447*0Sstevel@tonic-gate SvSetSV(TARG, tmpstr);
1448*0Sstevel@tonic-gate SvPV_force(TARG, len);
1449*0Sstevel@tonic-gate isutf = DO_UTF8(TARG);
1450*0Sstevel@tonic-gate if (count != 1) {
1451*0Sstevel@tonic-gate if (count < 1)
1452*0Sstevel@tonic-gate SvCUR_set(TARG, 0);
1453*0Sstevel@tonic-gate else {
1454*0Sstevel@tonic-gate MEM_WRAP_CHECK_1(count, len, "panic: string extend");
1455*0Sstevel@tonic-gate SvGROW(TARG, (count * len) + 1);
1456*0Sstevel@tonic-gate repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1457*0Sstevel@tonic-gate SvCUR(TARG) *= count;
1458*0Sstevel@tonic-gate }
1459*0Sstevel@tonic-gate *SvEND(TARG) = '\0';
1460*0Sstevel@tonic-gate }
1461*0Sstevel@tonic-gate if (isutf)
1462*0Sstevel@tonic-gate (void)SvPOK_only_UTF8(TARG);
1463*0Sstevel@tonic-gate else
1464*0Sstevel@tonic-gate (void)SvPOK_only(TARG);
1465*0Sstevel@tonic-gate
1466*0Sstevel@tonic-gate if (PL_op->op_private & OPpREPEAT_DOLIST) {
1467*0Sstevel@tonic-gate /* The parser saw this as a list repeat, and there
1468*0Sstevel@tonic-gate are probably several items on the stack. But we're
1469*0Sstevel@tonic-gate in scalar context, and there's no pp_list to save us
1470*0Sstevel@tonic-gate now. So drop the rest of the items -- robin@kitsite.com
1471*0Sstevel@tonic-gate */
1472*0Sstevel@tonic-gate dMARK;
1473*0Sstevel@tonic-gate SP = MARK;
1474*0Sstevel@tonic-gate }
1475*0Sstevel@tonic-gate PUSHTARG;
1476*0Sstevel@tonic-gate }
1477*0Sstevel@tonic-gate RETURN;
1478*0Sstevel@tonic-gate }
1479*0Sstevel@tonic-gate }
1480*0Sstevel@tonic-gate
PP(pp_subtract)1481*0Sstevel@tonic-gate PP(pp_subtract)
1482*0Sstevel@tonic-gate {
1483*0Sstevel@tonic-gate dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1484*0Sstevel@tonic-gate useleft = USE_LEFT(TOPm1s);
1485*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1486*0Sstevel@tonic-gate /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1487*0Sstevel@tonic-gate "bad things" happen if you rely on signed integers wrapping. */
1488*0Sstevel@tonic-gate SvIV_please(TOPs);
1489*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1490*0Sstevel@tonic-gate /* Unless the left argument is integer in range we are going to have to
1491*0Sstevel@tonic-gate use NV maths. Hence only attempt to coerce the right argument if
1492*0Sstevel@tonic-gate we know the left is integer. */
1493*0Sstevel@tonic-gate register UV auv = 0;
1494*0Sstevel@tonic-gate bool auvok = FALSE;
1495*0Sstevel@tonic-gate bool a_valid = 0;
1496*0Sstevel@tonic-gate
1497*0Sstevel@tonic-gate if (!useleft) {
1498*0Sstevel@tonic-gate auv = 0;
1499*0Sstevel@tonic-gate a_valid = auvok = 1;
1500*0Sstevel@tonic-gate /* left operand is undef, treat as zero. */
1501*0Sstevel@tonic-gate } else {
1502*0Sstevel@tonic-gate /* Left operand is defined, so is it IV? */
1503*0Sstevel@tonic-gate SvIV_please(TOPm1s);
1504*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
1505*0Sstevel@tonic-gate if ((auvok = SvUOK(TOPm1s)))
1506*0Sstevel@tonic-gate auv = SvUVX(TOPm1s);
1507*0Sstevel@tonic-gate else {
1508*0Sstevel@tonic-gate register IV aiv = SvIVX(TOPm1s);
1509*0Sstevel@tonic-gate if (aiv >= 0) {
1510*0Sstevel@tonic-gate auv = aiv;
1511*0Sstevel@tonic-gate auvok = 1; /* Now acting as a sign flag. */
1512*0Sstevel@tonic-gate } else { /* 2s complement assumption for IV_MIN */
1513*0Sstevel@tonic-gate auv = (UV)-aiv;
1514*0Sstevel@tonic-gate }
1515*0Sstevel@tonic-gate }
1516*0Sstevel@tonic-gate a_valid = 1;
1517*0Sstevel@tonic-gate }
1518*0Sstevel@tonic-gate }
1519*0Sstevel@tonic-gate if (a_valid) {
1520*0Sstevel@tonic-gate bool result_good = 0;
1521*0Sstevel@tonic-gate UV result;
1522*0Sstevel@tonic-gate register UV buv;
1523*0Sstevel@tonic-gate bool buvok = SvUOK(TOPs);
1524*0Sstevel@tonic-gate
1525*0Sstevel@tonic-gate if (buvok)
1526*0Sstevel@tonic-gate buv = SvUVX(TOPs);
1527*0Sstevel@tonic-gate else {
1528*0Sstevel@tonic-gate register IV biv = SvIVX(TOPs);
1529*0Sstevel@tonic-gate if (biv >= 0) {
1530*0Sstevel@tonic-gate buv = biv;
1531*0Sstevel@tonic-gate buvok = 1;
1532*0Sstevel@tonic-gate } else
1533*0Sstevel@tonic-gate buv = (UV)-biv;
1534*0Sstevel@tonic-gate }
1535*0Sstevel@tonic-gate /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1536*0Sstevel@tonic-gate else "IV" now, independent of how it came in.
1537*0Sstevel@tonic-gate if a, b represents positive, A, B negative, a maps to -A etc
1538*0Sstevel@tonic-gate a - b => (a - b)
1539*0Sstevel@tonic-gate A - b => -(a + b)
1540*0Sstevel@tonic-gate a - B => (a + b)
1541*0Sstevel@tonic-gate A - B => -(a - b)
1542*0Sstevel@tonic-gate all UV maths. negate result if A negative.
1543*0Sstevel@tonic-gate subtract if signs same, add if signs differ. */
1544*0Sstevel@tonic-gate
1545*0Sstevel@tonic-gate if (auvok ^ buvok) {
1546*0Sstevel@tonic-gate /* Signs differ. */
1547*0Sstevel@tonic-gate result = auv + buv;
1548*0Sstevel@tonic-gate if (result >= auv)
1549*0Sstevel@tonic-gate result_good = 1;
1550*0Sstevel@tonic-gate } else {
1551*0Sstevel@tonic-gate /* Signs same */
1552*0Sstevel@tonic-gate if (auv >= buv) {
1553*0Sstevel@tonic-gate result = auv - buv;
1554*0Sstevel@tonic-gate /* Must get smaller */
1555*0Sstevel@tonic-gate if (result <= auv)
1556*0Sstevel@tonic-gate result_good = 1;
1557*0Sstevel@tonic-gate } else {
1558*0Sstevel@tonic-gate result = buv - auv;
1559*0Sstevel@tonic-gate if (result <= buv) {
1560*0Sstevel@tonic-gate /* result really should be -(auv-buv). as its negation
1561*0Sstevel@tonic-gate of true value, need to swap our result flag */
1562*0Sstevel@tonic-gate auvok = !auvok;
1563*0Sstevel@tonic-gate result_good = 1;
1564*0Sstevel@tonic-gate }
1565*0Sstevel@tonic-gate }
1566*0Sstevel@tonic-gate }
1567*0Sstevel@tonic-gate if (result_good) {
1568*0Sstevel@tonic-gate SP--;
1569*0Sstevel@tonic-gate if (auvok)
1570*0Sstevel@tonic-gate SETu( result );
1571*0Sstevel@tonic-gate else {
1572*0Sstevel@tonic-gate /* Negate result */
1573*0Sstevel@tonic-gate if (result <= (UV)IV_MIN)
1574*0Sstevel@tonic-gate SETi( -(IV)result );
1575*0Sstevel@tonic-gate else {
1576*0Sstevel@tonic-gate /* result valid, but out of range for IV. */
1577*0Sstevel@tonic-gate SETn( -(NV)result );
1578*0Sstevel@tonic-gate }
1579*0Sstevel@tonic-gate }
1580*0Sstevel@tonic-gate RETURN;
1581*0Sstevel@tonic-gate } /* Overflow, drop through to NVs. */
1582*0Sstevel@tonic-gate }
1583*0Sstevel@tonic-gate }
1584*0Sstevel@tonic-gate #endif
1585*0Sstevel@tonic-gate useleft = USE_LEFT(TOPm1s);
1586*0Sstevel@tonic-gate {
1587*0Sstevel@tonic-gate dPOPnv;
1588*0Sstevel@tonic-gate if (!useleft) {
1589*0Sstevel@tonic-gate /* left operand is undef, treat as zero - value */
1590*0Sstevel@tonic-gate SETn(-value);
1591*0Sstevel@tonic-gate RETURN;
1592*0Sstevel@tonic-gate }
1593*0Sstevel@tonic-gate SETn( TOPn - value );
1594*0Sstevel@tonic-gate RETURN;
1595*0Sstevel@tonic-gate }
1596*0Sstevel@tonic-gate }
1597*0Sstevel@tonic-gate
PP(pp_left_shift)1598*0Sstevel@tonic-gate PP(pp_left_shift)
1599*0Sstevel@tonic-gate {
1600*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1601*0Sstevel@tonic-gate {
1602*0Sstevel@tonic-gate IV shift = POPi;
1603*0Sstevel@tonic-gate if (PL_op->op_private & HINT_INTEGER) {
1604*0Sstevel@tonic-gate IV i = TOPi;
1605*0Sstevel@tonic-gate SETi(i << shift);
1606*0Sstevel@tonic-gate }
1607*0Sstevel@tonic-gate else {
1608*0Sstevel@tonic-gate UV u = TOPu;
1609*0Sstevel@tonic-gate SETu(u << shift);
1610*0Sstevel@tonic-gate }
1611*0Sstevel@tonic-gate RETURN;
1612*0Sstevel@tonic-gate }
1613*0Sstevel@tonic-gate }
1614*0Sstevel@tonic-gate
PP(pp_right_shift)1615*0Sstevel@tonic-gate PP(pp_right_shift)
1616*0Sstevel@tonic-gate {
1617*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1618*0Sstevel@tonic-gate {
1619*0Sstevel@tonic-gate IV shift = POPi;
1620*0Sstevel@tonic-gate if (PL_op->op_private & HINT_INTEGER) {
1621*0Sstevel@tonic-gate IV i = TOPi;
1622*0Sstevel@tonic-gate SETi(i >> shift);
1623*0Sstevel@tonic-gate }
1624*0Sstevel@tonic-gate else {
1625*0Sstevel@tonic-gate UV u = TOPu;
1626*0Sstevel@tonic-gate SETu(u >> shift);
1627*0Sstevel@tonic-gate }
1628*0Sstevel@tonic-gate RETURN;
1629*0Sstevel@tonic-gate }
1630*0Sstevel@tonic-gate }
1631*0Sstevel@tonic-gate
PP(pp_lt)1632*0Sstevel@tonic-gate PP(pp_lt)
1633*0Sstevel@tonic-gate {
1634*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(lt,0);
1635*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1636*0Sstevel@tonic-gate SvIV_please(TOPs);
1637*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1638*0Sstevel@tonic-gate SvIV_please(TOPm1s);
1639*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
1640*0Sstevel@tonic-gate bool auvok = SvUOK(TOPm1s);
1641*0Sstevel@tonic-gate bool buvok = SvUOK(TOPs);
1642*0Sstevel@tonic-gate
1643*0Sstevel@tonic-gate if (!auvok && !buvok) { /* ## IV < IV ## */
1644*0Sstevel@tonic-gate IV aiv = SvIVX(TOPm1s);
1645*0Sstevel@tonic-gate IV biv = SvIVX(TOPs);
1646*0Sstevel@tonic-gate
1647*0Sstevel@tonic-gate SP--;
1648*0Sstevel@tonic-gate SETs(boolSV(aiv < biv));
1649*0Sstevel@tonic-gate RETURN;
1650*0Sstevel@tonic-gate }
1651*0Sstevel@tonic-gate if (auvok && buvok) { /* ## UV < UV ## */
1652*0Sstevel@tonic-gate UV auv = SvUVX(TOPm1s);
1653*0Sstevel@tonic-gate UV buv = SvUVX(TOPs);
1654*0Sstevel@tonic-gate
1655*0Sstevel@tonic-gate SP--;
1656*0Sstevel@tonic-gate SETs(boolSV(auv < buv));
1657*0Sstevel@tonic-gate RETURN;
1658*0Sstevel@tonic-gate }
1659*0Sstevel@tonic-gate if (auvok) { /* ## UV < IV ## */
1660*0Sstevel@tonic-gate UV auv;
1661*0Sstevel@tonic-gate IV biv;
1662*0Sstevel@tonic-gate
1663*0Sstevel@tonic-gate biv = SvIVX(TOPs);
1664*0Sstevel@tonic-gate SP--;
1665*0Sstevel@tonic-gate if (biv < 0) {
1666*0Sstevel@tonic-gate /* As (a) is a UV, it's >=0, so it cannot be < */
1667*0Sstevel@tonic-gate SETs(&PL_sv_no);
1668*0Sstevel@tonic-gate RETURN;
1669*0Sstevel@tonic-gate }
1670*0Sstevel@tonic-gate auv = SvUVX(TOPs);
1671*0Sstevel@tonic-gate SETs(boolSV(auv < (UV)biv));
1672*0Sstevel@tonic-gate RETURN;
1673*0Sstevel@tonic-gate }
1674*0Sstevel@tonic-gate { /* ## IV < UV ## */
1675*0Sstevel@tonic-gate IV aiv;
1676*0Sstevel@tonic-gate UV buv;
1677*0Sstevel@tonic-gate
1678*0Sstevel@tonic-gate aiv = SvIVX(TOPm1s);
1679*0Sstevel@tonic-gate if (aiv < 0) {
1680*0Sstevel@tonic-gate /* As (b) is a UV, it's >=0, so it must be < */
1681*0Sstevel@tonic-gate SP--;
1682*0Sstevel@tonic-gate SETs(&PL_sv_yes);
1683*0Sstevel@tonic-gate RETURN;
1684*0Sstevel@tonic-gate }
1685*0Sstevel@tonic-gate buv = SvUVX(TOPs);
1686*0Sstevel@tonic-gate SP--;
1687*0Sstevel@tonic-gate SETs(boolSV((UV)aiv < buv));
1688*0Sstevel@tonic-gate RETURN;
1689*0Sstevel@tonic-gate }
1690*0Sstevel@tonic-gate }
1691*0Sstevel@tonic-gate }
1692*0Sstevel@tonic-gate #endif
1693*0Sstevel@tonic-gate #ifndef NV_PRESERVES_UV
1694*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1695*0Sstevel@tonic-gate else
1696*0Sstevel@tonic-gate #endif
1697*0Sstevel@tonic-gate if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1698*0Sstevel@tonic-gate SP--;
1699*0Sstevel@tonic-gate SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1700*0Sstevel@tonic-gate RETURN;
1701*0Sstevel@tonic-gate }
1702*0Sstevel@tonic-gate #endif
1703*0Sstevel@tonic-gate {
1704*0Sstevel@tonic-gate dPOPnv;
1705*0Sstevel@tonic-gate SETs(boolSV(TOPn < value));
1706*0Sstevel@tonic-gate RETURN;
1707*0Sstevel@tonic-gate }
1708*0Sstevel@tonic-gate }
1709*0Sstevel@tonic-gate
PP(pp_gt)1710*0Sstevel@tonic-gate PP(pp_gt)
1711*0Sstevel@tonic-gate {
1712*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(gt,0);
1713*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1714*0Sstevel@tonic-gate SvIV_please(TOPs);
1715*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1716*0Sstevel@tonic-gate SvIV_please(TOPm1s);
1717*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
1718*0Sstevel@tonic-gate bool auvok = SvUOK(TOPm1s);
1719*0Sstevel@tonic-gate bool buvok = SvUOK(TOPs);
1720*0Sstevel@tonic-gate
1721*0Sstevel@tonic-gate if (!auvok && !buvok) { /* ## IV > IV ## */
1722*0Sstevel@tonic-gate IV aiv = SvIVX(TOPm1s);
1723*0Sstevel@tonic-gate IV biv = SvIVX(TOPs);
1724*0Sstevel@tonic-gate
1725*0Sstevel@tonic-gate SP--;
1726*0Sstevel@tonic-gate SETs(boolSV(aiv > biv));
1727*0Sstevel@tonic-gate RETURN;
1728*0Sstevel@tonic-gate }
1729*0Sstevel@tonic-gate if (auvok && buvok) { /* ## UV > UV ## */
1730*0Sstevel@tonic-gate UV auv = SvUVX(TOPm1s);
1731*0Sstevel@tonic-gate UV buv = SvUVX(TOPs);
1732*0Sstevel@tonic-gate
1733*0Sstevel@tonic-gate SP--;
1734*0Sstevel@tonic-gate SETs(boolSV(auv > buv));
1735*0Sstevel@tonic-gate RETURN;
1736*0Sstevel@tonic-gate }
1737*0Sstevel@tonic-gate if (auvok) { /* ## UV > IV ## */
1738*0Sstevel@tonic-gate UV auv;
1739*0Sstevel@tonic-gate IV biv;
1740*0Sstevel@tonic-gate
1741*0Sstevel@tonic-gate biv = SvIVX(TOPs);
1742*0Sstevel@tonic-gate SP--;
1743*0Sstevel@tonic-gate if (biv < 0) {
1744*0Sstevel@tonic-gate /* As (a) is a UV, it's >=0, so it must be > */
1745*0Sstevel@tonic-gate SETs(&PL_sv_yes);
1746*0Sstevel@tonic-gate RETURN;
1747*0Sstevel@tonic-gate }
1748*0Sstevel@tonic-gate auv = SvUVX(TOPs);
1749*0Sstevel@tonic-gate SETs(boolSV(auv > (UV)biv));
1750*0Sstevel@tonic-gate RETURN;
1751*0Sstevel@tonic-gate }
1752*0Sstevel@tonic-gate { /* ## IV > UV ## */
1753*0Sstevel@tonic-gate IV aiv;
1754*0Sstevel@tonic-gate UV buv;
1755*0Sstevel@tonic-gate
1756*0Sstevel@tonic-gate aiv = SvIVX(TOPm1s);
1757*0Sstevel@tonic-gate if (aiv < 0) {
1758*0Sstevel@tonic-gate /* As (b) is a UV, it's >=0, so it cannot be > */
1759*0Sstevel@tonic-gate SP--;
1760*0Sstevel@tonic-gate SETs(&PL_sv_no);
1761*0Sstevel@tonic-gate RETURN;
1762*0Sstevel@tonic-gate }
1763*0Sstevel@tonic-gate buv = SvUVX(TOPs);
1764*0Sstevel@tonic-gate SP--;
1765*0Sstevel@tonic-gate SETs(boolSV((UV)aiv > buv));
1766*0Sstevel@tonic-gate RETURN;
1767*0Sstevel@tonic-gate }
1768*0Sstevel@tonic-gate }
1769*0Sstevel@tonic-gate }
1770*0Sstevel@tonic-gate #endif
1771*0Sstevel@tonic-gate #ifndef NV_PRESERVES_UV
1772*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1773*0Sstevel@tonic-gate else
1774*0Sstevel@tonic-gate #endif
1775*0Sstevel@tonic-gate if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1776*0Sstevel@tonic-gate SP--;
1777*0Sstevel@tonic-gate SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1778*0Sstevel@tonic-gate RETURN;
1779*0Sstevel@tonic-gate }
1780*0Sstevel@tonic-gate #endif
1781*0Sstevel@tonic-gate {
1782*0Sstevel@tonic-gate dPOPnv;
1783*0Sstevel@tonic-gate SETs(boolSV(TOPn > value));
1784*0Sstevel@tonic-gate RETURN;
1785*0Sstevel@tonic-gate }
1786*0Sstevel@tonic-gate }
1787*0Sstevel@tonic-gate
PP(pp_le)1788*0Sstevel@tonic-gate PP(pp_le)
1789*0Sstevel@tonic-gate {
1790*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(le,0);
1791*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1792*0Sstevel@tonic-gate SvIV_please(TOPs);
1793*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1794*0Sstevel@tonic-gate SvIV_please(TOPm1s);
1795*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
1796*0Sstevel@tonic-gate bool auvok = SvUOK(TOPm1s);
1797*0Sstevel@tonic-gate bool buvok = SvUOK(TOPs);
1798*0Sstevel@tonic-gate
1799*0Sstevel@tonic-gate if (!auvok && !buvok) { /* ## IV <= IV ## */
1800*0Sstevel@tonic-gate IV aiv = SvIVX(TOPm1s);
1801*0Sstevel@tonic-gate IV biv = SvIVX(TOPs);
1802*0Sstevel@tonic-gate
1803*0Sstevel@tonic-gate SP--;
1804*0Sstevel@tonic-gate SETs(boolSV(aiv <= biv));
1805*0Sstevel@tonic-gate RETURN;
1806*0Sstevel@tonic-gate }
1807*0Sstevel@tonic-gate if (auvok && buvok) { /* ## UV <= UV ## */
1808*0Sstevel@tonic-gate UV auv = SvUVX(TOPm1s);
1809*0Sstevel@tonic-gate UV buv = SvUVX(TOPs);
1810*0Sstevel@tonic-gate
1811*0Sstevel@tonic-gate SP--;
1812*0Sstevel@tonic-gate SETs(boolSV(auv <= buv));
1813*0Sstevel@tonic-gate RETURN;
1814*0Sstevel@tonic-gate }
1815*0Sstevel@tonic-gate if (auvok) { /* ## UV <= IV ## */
1816*0Sstevel@tonic-gate UV auv;
1817*0Sstevel@tonic-gate IV biv;
1818*0Sstevel@tonic-gate
1819*0Sstevel@tonic-gate biv = SvIVX(TOPs);
1820*0Sstevel@tonic-gate SP--;
1821*0Sstevel@tonic-gate if (biv < 0) {
1822*0Sstevel@tonic-gate /* As (a) is a UV, it's >=0, so a cannot be <= */
1823*0Sstevel@tonic-gate SETs(&PL_sv_no);
1824*0Sstevel@tonic-gate RETURN;
1825*0Sstevel@tonic-gate }
1826*0Sstevel@tonic-gate auv = SvUVX(TOPs);
1827*0Sstevel@tonic-gate SETs(boolSV(auv <= (UV)biv));
1828*0Sstevel@tonic-gate RETURN;
1829*0Sstevel@tonic-gate }
1830*0Sstevel@tonic-gate { /* ## IV <= UV ## */
1831*0Sstevel@tonic-gate IV aiv;
1832*0Sstevel@tonic-gate UV buv;
1833*0Sstevel@tonic-gate
1834*0Sstevel@tonic-gate aiv = SvIVX(TOPm1s);
1835*0Sstevel@tonic-gate if (aiv < 0) {
1836*0Sstevel@tonic-gate /* As (b) is a UV, it's >=0, so a must be <= */
1837*0Sstevel@tonic-gate SP--;
1838*0Sstevel@tonic-gate SETs(&PL_sv_yes);
1839*0Sstevel@tonic-gate RETURN;
1840*0Sstevel@tonic-gate }
1841*0Sstevel@tonic-gate buv = SvUVX(TOPs);
1842*0Sstevel@tonic-gate SP--;
1843*0Sstevel@tonic-gate SETs(boolSV((UV)aiv <= buv));
1844*0Sstevel@tonic-gate RETURN;
1845*0Sstevel@tonic-gate }
1846*0Sstevel@tonic-gate }
1847*0Sstevel@tonic-gate }
1848*0Sstevel@tonic-gate #endif
1849*0Sstevel@tonic-gate #ifndef NV_PRESERVES_UV
1850*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1851*0Sstevel@tonic-gate else
1852*0Sstevel@tonic-gate #endif
1853*0Sstevel@tonic-gate if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1854*0Sstevel@tonic-gate SP--;
1855*0Sstevel@tonic-gate SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1856*0Sstevel@tonic-gate RETURN;
1857*0Sstevel@tonic-gate }
1858*0Sstevel@tonic-gate #endif
1859*0Sstevel@tonic-gate {
1860*0Sstevel@tonic-gate dPOPnv;
1861*0Sstevel@tonic-gate SETs(boolSV(TOPn <= value));
1862*0Sstevel@tonic-gate RETURN;
1863*0Sstevel@tonic-gate }
1864*0Sstevel@tonic-gate }
1865*0Sstevel@tonic-gate
PP(pp_ge)1866*0Sstevel@tonic-gate PP(pp_ge)
1867*0Sstevel@tonic-gate {
1868*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(ge,0);
1869*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1870*0Sstevel@tonic-gate SvIV_please(TOPs);
1871*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1872*0Sstevel@tonic-gate SvIV_please(TOPm1s);
1873*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
1874*0Sstevel@tonic-gate bool auvok = SvUOK(TOPm1s);
1875*0Sstevel@tonic-gate bool buvok = SvUOK(TOPs);
1876*0Sstevel@tonic-gate
1877*0Sstevel@tonic-gate if (!auvok && !buvok) { /* ## IV >= IV ## */
1878*0Sstevel@tonic-gate IV aiv = SvIVX(TOPm1s);
1879*0Sstevel@tonic-gate IV biv = SvIVX(TOPs);
1880*0Sstevel@tonic-gate
1881*0Sstevel@tonic-gate SP--;
1882*0Sstevel@tonic-gate SETs(boolSV(aiv >= biv));
1883*0Sstevel@tonic-gate RETURN;
1884*0Sstevel@tonic-gate }
1885*0Sstevel@tonic-gate if (auvok && buvok) { /* ## UV >= UV ## */
1886*0Sstevel@tonic-gate UV auv = SvUVX(TOPm1s);
1887*0Sstevel@tonic-gate UV buv = SvUVX(TOPs);
1888*0Sstevel@tonic-gate
1889*0Sstevel@tonic-gate SP--;
1890*0Sstevel@tonic-gate SETs(boolSV(auv >= buv));
1891*0Sstevel@tonic-gate RETURN;
1892*0Sstevel@tonic-gate }
1893*0Sstevel@tonic-gate if (auvok) { /* ## UV >= IV ## */
1894*0Sstevel@tonic-gate UV auv;
1895*0Sstevel@tonic-gate IV biv;
1896*0Sstevel@tonic-gate
1897*0Sstevel@tonic-gate biv = SvIVX(TOPs);
1898*0Sstevel@tonic-gate SP--;
1899*0Sstevel@tonic-gate if (biv < 0) {
1900*0Sstevel@tonic-gate /* As (a) is a UV, it's >=0, so it must be >= */
1901*0Sstevel@tonic-gate SETs(&PL_sv_yes);
1902*0Sstevel@tonic-gate RETURN;
1903*0Sstevel@tonic-gate }
1904*0Sstevel@tonic-gate auv = SvUVX(TOPs);
1905*0Sstevel@tonic-gate SETs(boolSV(auv >= (UV)biv));
1906*0Sstevel@tonic-gate RETURN;
1907*0Sstevel@tonic-gate }
1908*0Sstevel@tonic-gate { /* ## IV >= UV ## */
1909*0Sstevel@tonic-gate IV aiv;
1910*0Sstevel@tonic-gate UV buv;
1911*0Sstevel@tonic-gate
1912*0Sstevel@tonic-gate aiv = SvIVX(TOPm1s);
1913*0Sstevel@tonic-gate if (aiv < 0) {
1914*0Sstevel@tonic-gate /* As (b) is a UV, it's >=0, so a cannot be >= */
1915*0Sstevel@tonic-gate SP--;
1916*0Sstevel@tonic-gate SETs(&PL_sv_no);
1917*0Sstevel@tonic-gate RETURN;
1918*0Sstevel@tonic-gate }
1919*0Sstevel@tonic-gate buv = SvUVX(TOPs);
1920*0Sstevel@tonic-gate SP--;
1921*0Sstevel@tonic-gate SETs(boolSV((UV)aiv >= buv));
1922*0Sstevel@tonic-gate RETURN;
1923*0Sstevel@tonic-gate }
1924*0Sstevel@tonic-gate }
1925*0Sstevel@tonic-gate }
1926*0Sstevel@tonic-gate #endif
1927*0Sstevel@tonic-gate #ifndef NV_PRESERVES_UV
1928*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1929*0Sstevel@tonic-gate else
1930*0Sstevel@tonic-gate #endif
1931*0Sstevel@tonic-gate if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1932*0Sstevel@tonic-gate SP--;
1933*0Sstevel@tonic-gate SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1934*0Sstevel@tonic-gate RETURN;
1935*0Sstevel@tonic-gate }
1936*0Sstevel@tonic-gate #endif
1937*0Sstevel@tonic-gate {
1938*0Sstevel@tonic-gate dPOPnv;
1939*0Sstevel@tonic-gate SETs(boolSV(TOPn >= value));
1940*0Sstevel@tonic-gate RETURN;
1941*0Sstevel@tonic-gate }
1942*0Sstevel@tonic-gate }
1943*0Sstevel@tonic-gate
PP(pp_ne)1944*0Sstevel@tonic-gate PP(pp_ne)
1945*0Sstevel@tonic-gate {
1946*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(ne,0);
1947*0Sstevel@tonic-gate #ifndef NV_PRESERVES_UV
1948*0Sstevel@tonic-gate if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1949*0Sstevel@tonic-gate SP--;
1950*0Sstevel@tonic-gate SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1951*0Sstevel@tonic-gate RETURN;
1952*0Sstevel@tonic-gate }
1953*0Sstevel@tonic-gate #endif
1954*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
1955*0Sstevel@tonic-gate SvIV_please(TOPs);
1956*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
1957*0Sstevel@tonic-gate SvIV_please(TOPm1s);
1958*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
1959*0Sstevel@tonic-gate bool auvok = SvUOK(TOPm1s);
1960*0Sstevel@tonic-gate bool buvok = SvUOK(TOPs);
1961*0Sstevel@tonic-gate
1962*0Sstevel@tonic-gate if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1963*0Sstevel@tonic-gate /* Casting IV to UV before comparison isn't going to matter
1964*0Sstevel@tonic-gate on 2s complement. On 1s complement or sign&magnitude
1965*0Sstevel@tonic-gate (if we have any of them) it could make negative zero
1966*0Sstevel@tonic-gate differ from normal zero. As I understand it. (Need to
1967*0Sstevel@tonic-gate check - is negative zero implementation defined behaviour
1968*0Sstevel@tonic-gate anyway?). NWC */
1969*0Sstevel@tonic-gate UV buv = SvUVX(POPs);
1970*0Sstevel@tonic-gate UV auv = SvUVX(TOPs);
1971*0Sstevel@tonic-gate
1972*0Sstevel@tonic-gate SETs(boolSV(auv != buv));
1973*0Sstevel@tonic-gate RETURN;
1974*0Sstevel@tonic-gate }
1975*0Sstevel@tonic-gate { /* ## Mixed IV,UV ## */
1976*0Sstevel@tonic-gate IV iv;
1977*0Sstevel@tonic-gate UV uv;
1978*0Sstevel@tonic-gate
1979*0Sstevel@tonic-gate /* != is commutative so swap if needed (save code) */
1980*0Sstevel@tonic-gate if (auvok) {
1981*0Sstevel@tonic-gate /* swap. top of stack (b) is the iv */
1982*0Sstevel@tonic-gate iv = SvIVX(TOPs);
1983*0Sstevel@tonic-gate SP--;
1984*0Sstevel@tonic-gate if (iv < 0) {
1985*0Sstevel@tonic-gate /* As (a) is a UV, it's >0, so it cannot be == */
1986*0Sstevel@tonic-gate SETs(&PL_sv_yes);
1987*0Sstevel@tonic-gate RETURN;
1988*0Sstevel@tonic-gate }
1989*0Sstevel@tonic-gate uv = SvUVX(TOPs);
1990*0Sstevel@tonic-gate } else {
1991*0Sstevel@tonic-gate iv = SvIVX(TOPm1s);
1992*0Sstevel@tonic-gate SP--;
1993*0Sstevel@tonic-gate if (iv < 0) {
1994*0Sstevel@tonic-gate /* As (b) is a UV, it's >0, so it cannot be == */
1995*0Sstevel@tonic-gate SETs(&PL_sv_yes);
1996*0Sstevel@tonic-gate RETURN;
1997*0Sstevel@tonic-gate }
1998*0Sstevel@tonic-gate uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1999*0Sstevel@tonic-gate }
2000*0Sstevel@tonic-gate SETs(boolSV((UV)iv != uv));
2001*0Sstevel@tonic-gate RETURN;
2002*0Sstevel@tonic-gate }
2003*0Sstevel@tonic-gate }
2004*0Sstevel@tonic-gate }
2005*0Sstevel@tonic-gate #endif
2006*0Sstevel@tonic-gate {
2007*0Sstevel@tonic-gate dPOPnv;
2008*0Sstevel@tonic-gate SETs(boolSV(TOPn != value));
2009*0Sstevel@tonic-gate RETURN;
2010*0Sstevel@tonic-gate }
2011*0Sstevel@tonic-gate }
2012*0Sstevel@tonic-gate
PP(pp_ncmp)2013*0Sstevel@tonic-gate PP(pp_ncmp)
2014*0Sstevel@tonic-gate {
2015*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICbin(ncmp,0);
2016*0Sstevel@tonic-gate #ifndef NV_PRESERVES_UV
2017*0Sstevel@tonic-gate if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2018*0Sstevel@tonic-gate UV right = PTR2UV(SvRV(POPs));
2019*0Sstevel@tonic-gate UV left = PTR2UV(SvRV(TOPs));
2020*0Sstevel@tonic-gate SETi((left > right) - (left < right));
2021*0Sstevel@tonic-gate RETURN;
2022*0Sstevel@tonic-gate }
2023*0Sstevel@tonic-gate #endif
2024*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
2025*0Sstevel@tonic-gate /* Fortunately it seems NaN isn't IOK */
2026*0Sstevel@tonic-gate SvIV_please(TOPs);
2027*0Sstevel@tonic-gate if (SvIOK(TOPs)) {
2028*0Sstevel@tonic-gate SvIV_please(TOPm1s);
2029*0Sstevel@tonic-gate if (SvIOK(TOPm1s)) {
2030*0Sstevel@tonic-gate bool leftuvok = SvUOK(TOPm1s);
2031*0Sstevel@tonic-gate bool rightuvok = SvUOK(TOPs);
2032*0Sstevel@tonic-gate I32 value;
2033*0Sstevel@tonic-gate if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2034*0Sstevel@tonic-gate IV leftiv = SvIVX(TOPm1s);
2035*0Sstevel@tonic-gate IV rightiv = SvIVX(TOPs);
2036*0Sstevel@tonic-gate
2037*0Sstevel@tonic-gate if (leftiv > rightiv)
2038*0Sstevel@tonic-gate value = 1;
2039*0Sstevel@tonic-gate else if (leftiv < rightiv)
2040*0Sstevel@tonic-gate value = -1;
2041*0Sstevel@tonic-gate else
2042*0Sstevel@tonic-gate value = 0;
2043*0Sstevel@tonic-gate } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2044*0Sstevel@tonic-gate UV leftuv = SvUVX(TOPm1s);
2045*0Sstevel@tonic-gate UV rightuv = SvUVX(TOPs);
2046*0Sstevel@tonic-gate
2047*0Sstevel@tonic-gate if (leftuv > rightuv)
2048*0Sstevel@tonic-gate value = 1;
2049*0Sstevel@tonic-gate else if (leftuv < rightuv)
2050*0Sstevel@tonic-gate value = -1;
2051*0Sstevel@tonic-gate else
2052*0Sstevel@tonic-gate value = 0;
2053*0Sstevel@tonic-gate } else if (leftuvok) { /* ## UV <=> IV ## */
2054*0Sstevel@tonic-gate UV leftuv;
2055*0Sstevel@tonic-gate IV rightiv;
2056*0Sstevel@tonic-gate
2057*0Sstevel@tonic-gate rightiv = SvIVX(TOPs);
2058*0Sstevel@tonic-gate if (rightiv < 0) {
2059*0Sstevel@tonic-gate /* As (a) is a UV, it's >=0, so it cannot be < */
2060*0Sstevel@tonic-gate value = 1;
2061*0Sstevel@tonic-gate } else {
2062*0Sstevel@tonic-gate leftuv = SvUVX(TOPm1s);
2063*0Sstevel@tonic-gate if (leftuv > (UV)rightiv) {
2064*0Sstevel@tonic-gate value = 1;
2065*0Sstevel@tonic-gate } else if (leftuv < (UV)rightiv) {
2066*0Sstevel@tonic-gate value = -1;
2067*0Sstevel@tonic-gate } else {
2068*0Sstevel@tonic-gate value = 0;
2069*0Sstevel@tonic-gate }
2070*0Sstevel@tonic-gate }
2071*0Sstevel@tonic-gate } else { /* ## IV <=> UV ## */
2072*0Sstevel@tonic-gate IV leftiv;
2073*0Sstevel@tonic-gate UV rightuv;
2074*0Sstevel@tonic-gate
2075*0Sstevel@tonic-gate leftiv = SvIVX(TOPm1s);
2076*0Sstevel@tonic-gate if (leftiv < 0) {
2077*0Sstevel@tonic-gate /* As (b) is a UV, it's >=0, so it must be < */
2078*0Sstevel@tonic-gate value = -1;
2079*0Sstevel@tonic-gate } else {
2080*0Sstevel@tonic-gate rightuv = SvUVX(TOPs);
2081*0Sstevel@tonic-gate if ((UV)leftiv > rightuv) {
2082*0Sstevel@tonic-gate value = 1;
2083*0Sstevel@tonic-gate } else if ((UV)leftiv < rightuv) {
2084*0Sstevel@tonic-gate value = -1;
2085*0Sstevel@tonic-gate } else {
2086*0Sstevel@tonic-gate value = 0;
2087*0Sstevel@tonic-gate }
2088*0Sstevel@tonic-gate }
2089*0Sstevel@tonic-gate }
2090*0Sstevel@tonic-gate SP--;
2091*0Sstevel@tonic-gate SETi(value);
2092*0Sstevel@tonic-gate RETURN;
2093*0Sstevel@tonic-gate }
2094*0Sstevel@tonic-gate }
2095*0Sstevel@tonic-gate #endif
2096*0Sstevel@tonic-gate {
2097*0Sstevel@tonic-gate dPOPTOPnnrl;
2098*0Sstevel@tonic-gate I32 value;
2099*0Sstevel@tonic-gate
2100*0Sstevel@tonic-gate #ifdef Perl_isnan
2101*0Sstevel@tonic-gate if (Perl_isnan(left) || Perl_isnan(right)) {
2102*0Sstevel@tonic-gate SETs(&PL_sv_undef);
2103*0Sstevel@tonic-gate RETURN;
2104*0Sstevel@tonic-gate }
2105*0Sstevel@tonic-gate value = (left > right) - (left < right);
2106*0Sstevel@tonic-gate #else
2107*0Sstevel@tonic-gate if (left == right)
2108*0Sstevel@tonic-gate value = 0;
2109*0Sstevel@tonic-gate else if (left < right)
2110*0Sstevel@tonic-gate value = -1;
2111*0Sstevel@tonic-gate else if (left > right)
2112*0Sstevel@tonic-gate value = 1;
2113*0Sstevel@tonic-gate else {
2114*0Sstevel@tonic-gate SETs(&PL_sv_undef);
2115*0Sstevel@tonic-gate RETURN;
2116*0Sstevel@tonic-gate }
2117*0Sstevel@tonic-gate #endif
2118*0Sstevel@tonic-gate SETi(value);
2119*0Sstevel@tonic-gate RETURN;
2120*0Sstevel@tonic-gate }
2121*0Sstevel@tonic-gate }
2122*0Sstevel@tonic-gate
PP(pp_slt)2123*0Sstevel@tonic-gate PP(pp_slt)
2124*0Sstevel@tonic-gate {
2125*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(slt,0);
2126*0Sstevel@tonic-gate {
2127*0Sstevel@tonic-gate dPOPTOPssrl;
2128*0Sstevel@tonic-gate int cmp = (IN_LOCALE_RUNTIME
2129*0Sstevel@tonic-gate ? sv_cmp_locale(left, right)
2130*0Sstevel@tonic-gate : sv_cmp(left, right));
2131*0Sstevel@tonic-gate SETs(boolSV(cmp < 0));
2132*0Sstevel@tonic-gate RETURN;
2133*0Sstevel@tonic-gate }
2134*0Sstevel@tonic-gate }
2135*0Sstevel@tonic-gate
PP(pp_sgt)2136*0Sstevel@tonic-gate PP(pp_sgt)
2137*0Sstevel@tonic-gate {
2138*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(sgt,0);
2139*0Sstevel@tonic-gate {
2140*0Sstevel@tonic-gate dPOPTOPssrl;
2141*0Sstevel@tonic-gate int cmp = (IN_LOCALE_RUNTIME
2142*0Sstevel@tonic-gate ? sv_cmp_locale(left, right)
2143*0Sstevel@tonic-gate : sv_cmp(left, right));
2144*0Sstevel@tonic-gate SETs(boolSV(cmp > 0));
2145*0Sstevel@tonic-gate RETURN;
2146*0Sstevel@tonic-gate }
2147*0Sstevel@tonic-gate }
2148*0Sstevel@tonic-gate
PP(pp_sle)2149*0Sstevel@tonic-gate PP(pp_sle)
2150*0Sstevel@tonic-gate {
2151*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(sle,0);
2152*0Sstevel@tonic-gate {
2153*0Sstevel@tonic-gate dPOPTOPssrl;
2154*0Sstevel@tonic-gate int cmp = (IN_LOCALE_RUNTIME
2155*0Sstevel@tonic-gate ? sv_cmp_locale(left, right)
2156*0Sstevel@tonic-gate : sv_cmp(left, right));
2157*0Sstevel@tonic-gate SETs(boolSV(cmp <= 0));
2158*0Sstevel@tonic-gate RETURN;
2159*0Sstevel@tonic-gate }
2160*0Sstevel@tonic-gate }
2161*0Sstevel@tonic-gate
PP(pp_sge)2162*0Sstevel@tonic-gate PP(pp_sge)
2163*0Sstevel@tonic-gate {
2164*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(sge,0);
2165*0Sstevel@tonic-gate {
2166*0Sstevel@tonic-gate dPOPTOPssrl;
2167*0Sstevel@tonic-gate int cmp = (IN_LOCALE_RUNTIME
2168*0Sstevel@tonic-gate ? sv_cmp_locale(left, right)
2169*0Sstevel@tonic-gate : sv_cmp(left, right));
2170*0Sstevel@tonic-gate SETs(boolSV(cmp >= 0));
2171*0Sstevel@tonic-gate RETURN;
2172*0Sstevel@tonic-gate }
2173*0Sstevel@tonic-gate }
2174*0Sstevel@tonic-gate
PP(pp_seq)2175*0Sstevel@tonic-gate PP(pp_seq)
2176*0Sstevel@tonic-gate {
2177*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(seq,0);
2178*0Sstevel@tonic-gate {
2179*0Sstevel@tonic-gate dPOPTOPssrl;
2180*0Sstevel@tonic-gate SETs(boolSV(sv_eq(left, right)));
2181*0Sstevel@tonic-gate RETURN;
2182*0Sstevel@tonic-gate }
2183*0Sstevel@tonic-gate }
2184*0Sstevel@tonic-gate
PP(pp_sne)2185*0Sstevel@tonic-gate PP(pp_sne)
2186*0Sstevel@tonic-gate {
2187*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(sne,0);
2188*0Sstevel@tonic-gate {
2189*0Sstevel@tonic-gate dPOPTOPssrl;
2190*0Sstevel@tonic-gate SETs(boolSV(!sv_eq(left, right)));
2191*0Sstevel@tonic-gate RETURN;
2192*0Sstevel@tonic-gate }
2193*0Sstevel@tonic-gate }
2194*0Sstevel@tonic-gate
PP(pp_scmp)2195*0Sstevel@tonic-gate PP(pp_scmp)
2196*0Sstevel@tonic-gate {
2197*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICbin(scmp,0);
2198*0Sstevel@tonic-gate {
2199*0Sstevel@tonic-gate dPOPTOPssrl;
2200*0Sstevel@tonic-gate int cmp = (IN_LOCALE_RUNTIME
2201*0Sstevel@tonic-gate ? sv_cmp_locale(left, right)
2202*0Sstevel@tonic-gate : sv_cmp(left, right));
2203*0Sstevel@tonic-gate SETi( cmp );
2204*0Sstevel@tonic-gate RETURN;
2205*0Sstevel@tonic-gate }
2206*0Sstevel@tonic-gate }
2207*0Sstevel@tonic-gate
PP(pp_bit_and)2208*0Sstevel@tonic-gate PP(pp_bit_and)
2209*0Sstevel@tonic-gate {
2210*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2211*0Sstevel@tonic-gate {
2212*0Sstevel@tonic-gate dPOPTOPssrl;
2213*0Sstevel@tonic-gate if (SvNIOKp(left) || SvNIOKp(right)) {
2214*0Sstevel@tonic-gate if (PL_op->op_private & HINT_INTEGER) {
2215*0Sstevel@tonic-gate IV i = SvIV(left) & SvIV(right);
2216*0Sstevel@tonic-gate SETi(i);
2217*0Sstevel@tonic-gate }
2218*0Sstevel@tonic-gate else {
2219*0Sstevel@tonic-gate UV u = SvUV(left) & SvUV(right);
2220*0Sstevel@tonic-gate SETu(u);
2221*0Sstevel@tonic-gate }
2222*0Sstevel@tonic-gate }
2223*0Sstevel@tonic-gate else {
2224*0Sstevel@tonic-gate do_vop(PL_op->op_type, TARG, left, right);
2225*0Sstevel@tonic-gate SETTARG;
2226*0Sstevel@tonic-gate }
2227*0Sstevel@tonic-gate RETURN;
2228*0Sstevel@tonic-gate }
2229*0Sstevel@tonic-gate }
2230*0Sstevel@tonic-gate
PP(pp_bit_xor)2231*0Sstevel@tonic-gate PP(pp_bit_xor)
2232*0Sstevel@tonic-gate {
2233*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2234*0Sstevel@tonic-gate {
2235*0Sstevel@tonic-gate dPOPTOPssrl;
2236*0Sstevel@tonic-gate if (SvNIOKp(left) || SvNIOKp(right)) {
2237*0Sstevel@tonic-gate if (PL_op->op_private & HINT_INTEGER) {
2238*0Sstevel@tonic-gate IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2239*0Sstevel@tonic-gate SETi(i);
2240*0Sstevel@tonic-gate }
2241*0Sstevel@tonic-gate else {
2242*0Sstevel@tonic-gate UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2243*0Sstevel@tonic-gate SETu(u);
2244*0Sstevel@tonic-gate }
2245*0Sstevel@tonic-gate }
2246*0Sstevel@tonic-gate else {
2247*0Sstevel@tonic-gate do_vop(PL_op->op_type, TARG, left, right);
2248*0Sstevel@tonic-gate SETTARG;
2249*0Sstevel@tonic-gate }
2250*0Sstevel@tonic-gate RETURN;
2251*0Sstevel@tonic-gate }
2252*0Sstevel@tonic-gate }
2253*0Sstevel@tonic-gate
PP(pp_bit_or)2254*0Sstevel@tonic-gate PP(pp_bit_or)
2255*0Sstevel@tonic-gate {
2256*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2257*0Sstevel@tonic-gate {
2258*0Sstevel@tonic-gate dPOPTOPssrl;
2259*0Sstevel@tonic-gate if (SvNIOKp(left) || SvNIOKp(right)) {
2260*0Sstevel@tonic-gate if (PL_op->op_private & HINT_INTEGER) {
2261*0Sstevel@tonic-gate IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2262*0Sstevel@tonic-gate SETi(i);
2263*0Sstevel@tonic-gate }
2264*0Sstevel@tonic-gate else {
2265*0Sstevel@tonic-gate UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2266*0Sstevel@tonic-gate SETu(u);
2267*0Sstevel@tonic-gate }
2268*0Sstevel@tonic-gate }
2269*0Sstevel@tonic-gate else {
2270*0Sstevel@tonic-gate do_vop(PL_op->op_type, TARG, left, right);
2271*0Sstevel@tonic-gate SETTARG;
2272*0Sstevel@tonic-gate }
2273*0Sstevel@tonic-gate RETURN;
2274*0Sstevel@tonic-gate }
2275*0Sstevel@tonic-gate }
2276*0Sstevel@tonic-gate
PP(pp_negate)2277*0Sstevel@tonic-gate PP(pp_negate)
2278*0Sstevel@tonic-gate {
2279*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(neg);
2280*0Sstevel@tonic-gate {
2281*0Sstevel@tonic-gate dTOPss;
2282*0Sstevel@tonic-gate int flags = SvFLAGS(sv);
2283*0Sstevel@tonic-gate if (SvGMAGICAL(sv))
2284*0Sstevel@tonic-gate mg_get(sv);
2285*0Sstevel@tonic-gate if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2286*0Sstevel@tonic-gate /* It's publicly an integer, or privately an integer-not-float */
2287*0Sstevel@tonic-gate oops_its_an_int:
2288*0Sstevel@tonic-gate if (SvIsUV(sv)) {
2289*0Sstevel@tonic-gate if (SvIVX(sv) == IV_MIN) {
2290*0Sstevel@tonic-gate /* 2s complement assumption. */
2291*0Sstevel@tonic-gate SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2292*0Sstevel@tonic-gate RETURN;
2293*0Sstevel@tonic-gate }
2294*0Sstevel@tonic-gate else if (SvUVX(sv) <= IV_MAX) {
2295*0Sstevel@tonic-gate SETi(-SvIVX(sv));
2296*0Sstevel@tonic-gate RETURN;
2297*0Sstevel@tonic-gate }
2298*0Sstevel@tonic-gate }
2299*0Sstevel@tonic-gate else if (SvIVX(sv) != IV_MIN) {
2300*0Sstevel@tonic-gate SETi(-SvIVX(sv));
2301*0Sstevel@tonic-gate RETURN;
2302*0Sstevel@tonic-gate }
2303*0Sstevel@tonic-gate #ifdef PERL_PRESERVE_IVUV
2304*0Sstevel@tonic-gate else {
2305*0Sstevel@tonic-gate SETu((UV)IV_MIN);
2306*0Sstevel@tonic-gate RETURN;
2307*0Sstevel@tonic-gate }
2308*0Sstevel@tonic-gate #endif
2309*0Sstevel@tonic-gate }
2310*0Sstevel@tonic-gate if (SvNIOKp(sv))
2311*0Sstevel@tonic-gate SETn(-SvNV(sv));
2312*0Sstevel@tonic-gate else if (SvPOKp(sv)) {
2313*0Sstevel@tonic-gate STRLEN len;
2314*0Sstevel@tonic-gate char *s = SvPV(sv, len);
2315*0Sstevel@tonic-gate if (isIDFIRST(*s)) {
2316*0Sstevel@tonic-gate sv_setpvn(TARG, "-", 1);
2317*0Sstevel@tonic-gate sv_catsv(TARG, sv);
2318*0Sstevel@tonic-gate }
2319*0Sstevel@tonic-gate else if (*s == '+' || *s == '-') {
2320*0Sstevel@tonic-gate sv_setsv(TARG, sv);
2321*0Sstevel@tonic-gate *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2322*0Sstevel@tonic-gate }
2323*0Sstevel@tonic-gate else if (DO_UTF8(sv)) {
2324*0Sstevel@tonic-gate SvIV_please(sv);
2325*0Sstevel@tonic-gate if (SvIOK(sv))
2326*0Sstevel@tonic-gate goto oops_its_an_int;
2327*0Sstevel@tonic-gate if (SvNOK(sv))
2328*0Sstevel@tonic-gate sv_setnv(TARG, -SvNV(sv));
2329*0Sstevel@tonic-gate else {
2330*0Sstevel@tonic-gate sv_setpvn(TARG, "-", 1);
2331*0Sstevel@tonic-gate sv_catsv(TARG, sv);
2332*0Sstevel@tonic-gate }
2333*0Sstevel@tonic-gate }
2334*0Sstevel@tonic-gate else {
2335*0Sstevel@tonic-gate SvIV_please(sv);
2336*0Sstevel@tonic-gate if (SvIOK(sv))
2337*0Sstevel@tonic-gate goto oops_its_an_int;
2338*0Sstevel@tonic-gate sv_setnv(TARG, -SvNV(sv));
2339*0Sstevel@tonic-gate }
2340*0Sstevel@tonic-gate SETTARG;
2341*0Sstevel@tonic-gate }
2342*0Sstevel@tonic-gate else
2343*0Sstevel@tonic-gate SETn(-SvNV(sv));
2344*0Sstevel@tonic-gate }
2345*0Sstevel@tonic-gate RETURN;
2346*0Sstevel@tonic-gate }
2347*0Sstevel@tonic-gate
PP(pp_not)2348*0Sstevel@tonic-gate PP(pp_not)
2349*0Sstevel@tonic-gate {
2350*0Sstevel@tonic-gate dSP; tryAMAGICunSET(not);
2351*0Sstevel@tonic-gate *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2352*0Sstevel@tonic-gate return NORMAL;
2353*0Sstevel@tonic-gate }
2354*0Sstevel@tonic-gate
PP(pp_complement)2355*0Sstevel@tonic-gate PP(pp_complement)
2356*0Sstevel@tonic-gate {
2357*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(compl);
2358*0Sstevel@tonic-gate {
2359*0Sstevel@tonic-gate dTOPss;
2360*0Sstevel@tonic-gate if (SvNIOKp(sv)) {
2361*0Sstevel@tonic-gate if (PL_op->op_private & HINT_INTEGER) {
2362*0Sstevel@tonic-gate IV i = ~SvIV(sv);
2363*0Sstevel@tonic-gate SETi(i);
2364*0Sstevel@tonic-gate }
2365*0Sstevel@tonic-gate else {
2366*0Sstevel@tonic-gate UV u = ~SvUV(sv);
2367*0Sstevel@tonic-gate SETu(u);
2368*0Sstevel@tonic-gate }
2369*0Sstevel@tonic-gate }
2370*0Sstevel@tonic-gate else {
2371*0Sstevel@tonic-gate register U8 *tmps;
2372*0Sstevel@tonic-gate register I32 anum;
2373*0Sstevel@tonic-gate STRLEN len;
2374*0Sstevel@tonic-gate
2375*0Sstevel@tonic-gate (void)SvPV_nomg(sv,len); /* force check for uninit var */
2376*0Sstevel@tonic-gate SvSetSV(TARG, sv);
2377*0Sstevel@tonic-gate tmps = (U8*)SvPV_force(TARG, len);
2378*0Sstevel@tonic-gate anum = len;
2379*0Sstevel@tonic-gate if (SvUTF8(TARG)) {
2380*0Sstevel@tonic-gate /* Calculate exact length, let's not estimate. */
2381*0Sstevel@tonic-gate STRLEN targlen = 0;
2382*0Sstevel@tonic-gate U8 *result;
2383*0Sstevel@tonic-gate U8 *send;
2384*0Sstevel@tonic-gate STRLEN l;
2385*0Sstevel@tonic-gate UV nchar = 0;
2386*0Sstevel@tonic-gate UV nwide = 0;
2387*0Sstevel@tonic-gate
2388*0Sstevel@tonic-gate send = tmps + len;
2389*0Sstevel@tonic-gate while (tmps < send) {
2390*0Sstevel@tonic-gate UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2391*0Sstevel@tonic-gate tmps += UTF8SKIP(tmps);
2392*0Sstevel@tonic-gate targlen += UNISKIP(~c);
2393*0Sstevel@tonic-gate nchar++;
2394*0Sstevel@tonic-gate if (c > 0xff)
2395*0Sstevel@tonic-gate nwide++;
2396*0Sstevel@tonic-gate }
2397*0Sstevel@tonic-gate
2398*0Sstevel@tonic-gate /* Now rewind strings and write them. */
2399*0Sstevel@tonic-gate tmps -= len;
2400*0Sstevel@tonic-gate
2401*0Sstevel@tonic-gate if (nwide) {
2402*0Sstevel@tonic-gate Newz(0, result, targlen + 1, U8);
2403*0Sstevel@tonic-gate while (tmps < send) {
2404*0Sstevel@tonic-gate UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2405*0Sstevel@tonic-gate tmps += UTF8SKIP(tmps);
2406*0Sstevel@tonic-gate result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2407*0Sstevel@tonic-gate }
2408*0Sstevel@tonic-gate *result = '\0';
2409*0Sstevel@tonic-gate result -= targlen;
2410*0Sstevel@tonic-gate sv_setpvn(TARG, (char*)result, targlen);
2411*0Sstevel@tonic-gate SvUTF8_on(TARG);
2412*0Sstevel@tonic-gate }
2413*0Sstevel@tonic-gate else {
2414*0Sstevel@tonic-gate Newz(0, result, nchar + 1, U8);
2415*0Sstevel@tonic-gate while (tmps < send) {
2416*0Sstevel@tonic-gate U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2417*0Sstevel@tonic-gate tmps += UTF8SKIP(tmps);
2418*0Sstevel@tonic-gate *result++ = ~c;
2419*0Sstevel@tonic-gate }
2420*0Sstevel@tonic-gate *result = '\0';
2421*0Sstevel@tonic-gate result -= nchar;
2422*0Sstevel@tonic-gate sv_setpvn(TARG, (char*)result, nchar);
2423*0Sstevel@tonic-gate SvUTF8_off(TARG);
2424*0Sstevel@tonic-gate }
2425*0Sstevel@tonic-gate Safefree(result);
2426*0Sstevel@tonic-gate SETs(TARG);
2427*0Sstevel@tonic-gate RETURN;
2428*0Sstevel@tonic-gate }
2429*0Sstevel@tonic-gate #ifdef LIBERAL
2430*0Sstevel@tonic-gate {
2431*0Sstevel@tonic-gate register long *tmpl;
2432*0Sstevel@tonic-gate for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2433*0Sstevel@tonic-gate *tmps = ~*tmps;
2434*0Sstevel@tonic-gate tmpl = (long*)tmps;
2435*0Sstevel@tonic-gate for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2436*0Sstevel@tonic-gate *tmpl = ~*tmpl;
2437*0Sstevel@tonic-gate tmps = (U8*)tmpl;
2438*0Sstevel@tonic-gate }
2439*0Sstevel@tonic-gate #endif
2440*0Sstevel@tonic-gate for ( ; anum > 0; anum--, tmps++)
2441*0Sstevel@tonic-gate *tmps = ~*tmps;
2442*0Sstevel@tonic-gate
2443*0Sstevel@tonic-gate SETs(TARG);
2444*0Sstevel@tonic-gate }
2445*0Sstevel@tonic-gate RETURN;
2446*0Sstevel@tonic-gate }
2447*0Sstevel@tonic-gate }
2448*0Sstevel@tonic-gate
2449*0Sstevel@tonic-gate /* integer versions of some of the above */
2450*0Sstevel@tonic-gate
PP(pp_i_multiply)2451*0Sstevel@tonic-gate PP(pp_i_multiply)
2452*0Sstevel@tonic-gate {
2453*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2454*0Sstevel@tonic-gate {
2455*0Sstevel@tonic-gate dPOPTOPiirl;
2456*0Sstevel@tonic-gate SETi( left * right );
2457*0Sstevel@tonic-gate RETURN;
2458*0Sstevel@tonic-gate }
2459*0Sstevel@tonic-gate }
2460*0Sstevel@tonic-gate
PP(pp_i_divide)2461*0Sstevel@tonic-gate PP(pp_i_divide)
2462*0Sstevel@tonic-gate {
2463*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2464*0Sstevel@tonic-gate {
2465*0Sstevel@tonic-gate dPOPiv;
2466*0Sstevel@tonic-gate if (value == 0)
2467*0Sstevel@tonic-gate DIE(aTHX_ "Illegal division by zero");
2468*0Sstevel@tonic-gate value = POPi / value;
2469*0Sstevel@tonic-gate PUSHi( value );
2470*0Sstevel@tonic-gate RETURN;
2471*0Sstevel@tonic-gate }
2472*0Sstevel@tonic-gate }
2473*0Sstevel@tonic-gate
2474*0Sstevel@tonic-gate STATIC
PP(pp_i_modulo_0)2475*0Sstevel@tonic-gate PP(pp_i_modulo_0)
2476*0Sstevel@tonic-gate {
2477*0Sstevel@tonic-gate /* This is the vanilla old i_modulo. */
2478*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2479*0Sstevel@tonic-gate {
2480*0Sstevel@tonic-gate dPOPTOPiirl;
2481*0Sstevel@tonic-gate if (!right)
2482*0Sstevel@tonic-gate DIE(aTHX_ "Illegal modulus zero");
2483*0Sstevel@tonic-gate SETi( left % right );
2484*0Sstevel@tonic-gate RETURN;
2485*0Sstevel@tonic-gate }
2486*0Sstevel@tonic-gate }
2487*0Sstevel@tonic-gate
2488*0Sstevel@tonic-gate #if defined(__GLIBC__) && IVSIZE == 8
2489*0Sstevel@tonic-gate STATIC
PP(pp_i_modulo_1)2490*0Sstevel@tonic-gate PP(pp_i_modulo_1)
2491*0Sstevel@tonic-gate {
2492*0Sstevel@tonic-gate /* This is the i_modulo with the workaround for the _moddi3 bug
2493*0Sstevel@tonic-gate * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2494*0Sstevel@tonic-gate * See below for pp_i_modulo. */
2495*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2496*0Sstevel@tonic-gate {
2497*0Sstevel@tonic-gate dPOPTOPiirl;
2498*0Sstevel@tonic-gate if (!right)
2499*0Sstevel@tonic-gate DIE(aTHX_ "Illegal modulus zero");
2500*0Sstevel@tonic-gate SETi( left % PERL_ABS(right) );
2501*0Sstevel@tonic-gate RETURN;
2502*0Sstevel@tonic-gate }
2503*0Sstevel@tonic-gate }
2504*0Sstevel@tonic-gate #endif
2505*0Sstevel@tonic-gate
PP(pp_i_modulo)2506*0Sstevel@tonic-gate PP(pp_i_modulo)
2507*0Sstevel@tonic-gate {
2508*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2509*0Sstevel@tonic-gate {
2510*0Sstevel@tonic-gate dPOPTOPiirl;
2511*0Sstevel@tonic-gate if (!right)
2512*0Sstevel@tonic-gate DIE(aTHX_ "Illegal modulus zero");
2513*0Sstevel@tonic-gate /* The assumption is to use hereafter the old vanilla version... */
2514*0Sstevel@tonic-gate PL_op->op_ppaddr =
2515*0Sstevel@tonic-gate PL_ppaddr[OP_I_MODULO] =
2516*0Sstevel@tonic-gate &Perl_pp_i_modulo_0;
2517*0Sstevel@tonic-gate /* .. but if we have glibc, we might have a buggy _moddi3
2518*0Sstevel@tonic-gate * (at least glicb 2.2.5 is known to have this bug), in other
2519*0Sstevel@tonic-gate * words our integer modulus with negative quad as the second
2520*0Sstevel@tonic-gate * argument might be broken. Test for this and re-patch the
2521*0Sstevel@tonic-gate * opcode dispatch table if that is the case, remembering to
2522*0Sstevel@tonic-gate * also apply the workaround so that this first round works
2523*0Sstevel@tonic-gate * right, too. See [perl #9402] for more information. */
2524*0Sstevel@tonic-gate #if defined(__GLIBC__) && IVSIZE == 8
2525*0Sstevel@tonic-gate {
2526*0Sstevel@tonic-gate IV l = 3;
2527*0Sstevel@tonic-gate IV r = -10;
2528*0Sstevel@tonic-gate /* Cannot do this check with inlined IV constants since
2529*0Sstevel@tonic-gate * that seems to work correctly even with the buggy glibc. */
2530*0Sstevel@tonic-gate if (l % r == -3) {
2531*0Sstevel@tonic-gate /* Yikes, we have the bug.
2532*0Sstevel@tonic-gate * Patch in the workaround version. */
2533*0Sstevel@tonic-gate PL_op->op_ppaddr =
2534*0Sstevel@tonic-gate PL_ppaddr[OP_I_MODULO] =
2535*0Sstevel@tonic-gate &Perl_pp_i_modulo_1;
2536*0Sstevel@tonic-gate /* Make certain we work right this time, too. */
2537*0Sstevel@tonic-gate right = PERL_ABS(right);
2538*0Sstevel@tonic-gate }
2539*0Sstevel@tonic-gate }
2540*0Sstevel@tonic-gate #endif
2541*0Sstevel@tonic-gate SETi( left % right );
2542*0Sstevel@tonic-gate RETURN;
2543*0Sstevel@tonic-gate }
2544*0Sstevel@tonic-gate }
2545*0Sstevel@tonic-gate
PP(pp_i_add)2546*0Sstevel@tonic-gate PP(pp_i_add)
2547*0Sstevel@tonic-gate {
2548*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2549*0Sstevel@tonic-gate {
2550*0Sstevel@tonic-gate dPOPTOPiirl_ul;
2551*0Sstevel@tonic-gate SETi( left + right );
2552*0Sstevel@tonic-gate RETURN;
2553*0Sstevel@tonic-gate }
2554*0Sstevel@tonic-gate }
2555*0Sstevel@tonic-gate
PP(pp_i_subtract)2556*0Sstevel@tonic-gate PP(pp_i_subtract)
2557*0Sstevel@tonic-gate {
2558*0Sstevel@tonic-gate dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2559*0Sstevel@tonic-gate {
2560*0Sstevel@tonic-gate dPOPTOPiirl_ul;
2561*0Sstevel@tonic-gate SETi( left - right );
2562*0Sstevel@tonic-gate RETURN;
2563*0Sstevel@tonic-gate }
2564*0Sstevel@tonic-gate }
2565*0Sstevel@tonic-gate
PP(pp_i_lt)2566*0Sstevel@tonic-gate PP(pp_i_lt)
2567*0Sstevel@tonic-gate {
2568*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(lt,0);
2569*0Sstevel@tonic-gate {
2570*0Sstevel@tonic-gate dPOPTOPiirl;
2571*0Sstevel@tonic-gate SETs(boolSV(left < right));
2572*0Sstevel@tonic-gate RETURN;
2573*0Sstevel@tonic-gate }
2574*0Sstevel@tonic-gate }
2575*0Sstevel@tonic-gate
PP(pp_i_gt)2576*0Sstevel@tonic-gate PP(pp_i_gt)
2577*0Sstevel@tonic-gate {
2578*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(gt,0);
2579*0Sstevel@tonic-gate {
2580*0Sstevel@tonic-gate dPOPTOPiirl;
2581*0Sstevel@tonic-gate SETs(boolSV(left > right));
2582*0Sstevel@tonic-gate RETURN;
2583*0Sstevel@tonic-gate }
2584*0Sstevel@tonic-gate }
2585*0Sstevel@tonic-gate
PP(pp_i_le)2586*0Sstevel@tonic-gate PP(pp_i_le)
2587*0Sstevel@tonic-gate {
2588*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(le,0);
2589*0Sstevel@tonic-gate {
2590*0Sstevel@tonic-gate dPOPTOPiirl;
2591*0Sstevel@tonic-gate SETs(boolSV(left <= right));
2592*0Sstevel@tonic-gate RETURN;
2593*0Sstevel@tonic-gate }
2594*0Sstevel@tonic-gate }
2595*0Sstevel@tonic-gate
PP(pp_i_ge)2596*0Sstevel@tonic-gate PP(pp_i_ge)
2597*0Sstevel@tonic-gate {
2598*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(ge,0);
2599*0Sstevel@tonic-gate {
2600*0Sstevel@tonic-gate dPOPTOPiirl;
2601*0Sstevel@tonic-gate SETs(boolSV(left >= right));
2602*0Sstevel@tonic-gate RETURN;
2603*0Sstevel@tonic-gate }
2604*0Sstevel@tonic-gate }
2605*0Sstevel@tonic-gate
PP(pp_i_eq)2606*0Sstevel@tonic-gate PP(pp_i_eq)
2607*0Sstevel@tonic-gate {
2608*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(eq,0);
2609*0Sstevel@tonic-gate {
2610*0Sstevel@tonic-gate dPOPTOPiirl;
2611*0Sstevel@tonic-gate SETs(boolSV(left == right));
2612*0Sstevel@tonic-gate RETURN;
2613*0Sstevel@tonic-gate }
2614*0Sstevel@tonic-gate }
2615*0Sstevel@tonic-gate
PP(pp_i_ne)2616*0Sstevel@tonic-gate PP(pp_i_ne)
2617*0Sstevel@tonic-gate {
2618*0Sstevel@tonic-gate dSP; tryAMAGICbinSET(ne,0);
2619*0Sstevel@tonic-gate {
2620*0Sstevel@tonic-gate dPOPTOPiirl;
2621*0Sstevel@tonic-gate SETs(boolSV(left != right));
2622*0Sstevel@tonic-gate RETURN;
2623*0Sstevel@tonic-gate }
2624*0Sstevel@tonic-gate }
2625*0Sstevel@tonic-gate
PP(pp_i_ncmp)2626*0Sstevel@tonic-gate PP(pp_i_ncmp)
2627*0Sstevel@tonic-gate {
2628*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICbin(ncmp,0);
2629*0Sstevel@tonic-gate {
2630*0Sstevel@tonic-gate dPOPTOPiirl;
2631*0Sstevel@tonic-gate I32 value;
2632*0Sstevel@tonic-gate
2633*0Sstevel@tonic-gate if (left > right)
2634*0Sstevel@tonic-gate value = 1;
2635*0Sstevel@tonic-gate else if (left < right)
2636*0Sstevel@tonic-gate value = -1;
2637*0Sstevel@tonic-gate else
2638*0Sstevel@tonic-gate value = 0;
2639*0Sstevel@tonic-gate SETi(value);
2640*0Sstevel@tonic-gate RETURN;
2641*0Sstevel@tonic-gate }
2642*0Sstevel@tonic-gate }
2643*0Sstevel@tonic-gate
PP(pp_i_negate)2644*0Sstevel@tonic-gate PP(pp_i_negate)
2645*0Sstevel@tonic-gate {
2646*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(neg);
2647*0Sstevel@tonic-gate SETi(-TOPi);
2648*0Sstevel@tonic-gate RETURN;
2649*0Sstevel@tonic-gate }
2650*0Sstevel@tonic-gate
2651*0Sstevel@tonic-gate /* High falutin' math. */
2652*0Sstevel@tonic-gate
PP(pp_atan2)2653*0Sstevel@tonic-gate PP(pp_atan2)
2654*0Sstevel@tonic-gate {
2655*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICbin(atan2,0);
2656*0Sstevel@tonic-gate {
2657*0Sstevel@tonic-gate dPOPTOPnnrl;
2658*0Sstevel@tonic-gate SETn(Perl_atan2(left, right));
2659*0Sstevel@tonic-gate RETURN;
2660*0Sstevel@tonic-gate }
2661*0Sstevel@tonic-gate }
2662*0Sstevel@tonic-gate
PP(pp_sin)2663*0Sstevel@tonic-gate PP(pp_sin)
2664*0Sstevel@tonic-gate {
2665*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(sin);
2666*0Sstevel@tonic-gate {
2667*0Sstevel@tonic-gate NV value;
2668*0Sstevel@tonic-gate value = POPn;
2669*0Sstevel@tonic-gate value = Perl_sin(value);
2670*0Sstevel@tonic-gate XPUSHn(value);
2671*0Sstevel@tonic-gate RETURN;
2672*0Sstevel@tonic-gate }
2673*0Sstevel@tonic-gate }
2674*0Sstevel@tonic-gate
PP(pp_cos)2675*0Sstevel@tonic-gate PP(pp_cos)
2676*0Sstevel@tonic-gate {
2677*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(cos);
2678*0Sstevel@tonic-gate {
2679*0Sstevel@tonic-gate NV value;
2680*0Sstevel@tonic-gate value = POPn;
2681*0Sstevel@tonic-gate value = Perl_cos(value);
2682*0Sstevel@tonic-gate XPUSHn(value);
2683*0Sstevel@tonic-gate RETURN;
2684*0Sstevel@tonic-gate }
2685*0Sstevel@tonic-gate }
2686*0Sstevel@tonic-gate
2687*0Sstevel@tonic-gate /* Support Configure command-line overrides for rand() functions.
2688*0Sstevel@tonic-gate After 5.005, perhaps we should replace this by Configure support
2689*0Sstevel@tonic-gate for drand48(), random(), or rand(). For 5.005, though, maintain
2690*0Sstevel@tonic-gate compatibility by calling rand() but allow the user to override it.
2691*0Sstevel@tonic-gate See INSTALL for details. --Andy Dougherty 15 July 1998
2692*0Sstevel@tonic-gate */
2693*0Sstevel@tonic-gate /* Now it's after 5.005, and Configure supports drand48() and random(),
2694*0Sstevel@tonic-gate in addition to rand(). So the overrides should not be needed any more.
2695*0Sstevel@tonic-gate --Jarkko Hietaniemi 27 September 1998
2696*0Sstevel@tonic-gate */
2697*0Sstevel@tonic-gate
2698*0Sstevel@tonic-gate #ifndef HAS_DRAND48_PROTO
2699*0Sstevel@tonic-gate extern double drand48 (void);
2700*0Sstevel@tonic-gate #endif
2701*0Sstevel@tonic-gate
PP(pp_rand)2702*0Sstevel@tonic-gate PP(pp_rand)
2703*0Sstevel@tonic-gate {
2704*0Sstevel@tonic-gate dSP; dTARGET;
2705*0Sstevel@tonic-gate NV value;
2706*0Sstevel@tonic-gate if (MAXARG < 1)
2707*0Sstevel@tonic-gate value = 1.0;
2708*0Sstevel@tonic-gate else
2709*0Sstevel@tonic-gate value = POPn;
2710*0Sstevel@tonic-gate if (value == 0.0)
2711*0Sstevel@tonic-gate value = 1.0;
2712*0Sstevel@tonic-gate if (!PL_srand_called) {
2713*0Sstevel@tonic-gate (void)seedDrand01((Rand_seed_t)seed());
2714*0Sstevel@tonic-gate PL_srand_called = TRUE;
2715*0Sstevel@tonic-gate }
2716*0Sstevel@tonic-gate value *= Drand01();
2717*0Sstevel@tonic-gate XPUSHn(value);
2718*0Sstevel@tonic-gate RETURN;
2719*0Sstevel@tonic-gate }
2720*0Sstevel@tonic-gate
PP(pp_srand)2721*0Sstevel@tonic-gate PP(pp_srand)
2722*0Sstevel@tonic-gate {
2723*0Sstevel@tonic-gate dSP;
2724*0Sstevel@tonic-gate UV anum;
2725*0Sstevel@tonic-gate if (MAXARG < 1)
2726*0Sstevel@tonic-gate anum = seed();
2727*0Sstevel@tonic-gate else
2728*0Sstevel@tonic-gate anum = POPu;
2729*0Sstevel@tonic-gate (void)seedDrand01((Rand_seed_t)anum);
2730*0Sstevel@tonic-gate PL_srand_called = TRUE;
2731*0Sstevel@tonic-gate EXTEND(SP, 1);
2732*0Sstevel@tonic-gate RETPUSHYES;
2733*0Sstevel@tonic-gate }
2734*0Sstevel@tonic-gate
PP(pp_exp)2735*0Sstevel@tonic-gate PP(pp_exp)
2736*0Sstevel@tonic-gate {
2737*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(exp);
2738*0Sstevel@tonic-gate {
2739*0Sstevel@tonic-gate NV value;
2740*0Sstevel@tonic-gate value = POPn;
2741*0Sstevel@tonic-gate value = Perl_exp(value);
2742*0Sstevel@tonic-gate XPUSHn(value);
2743*0Sstevel@tonic-gate RETURN;
2744*0Sstevel@tonic-gate }
2745*0Sstevel@tonic-gate }
2746*0Sstevel@tonic-gate
PP(pp_log)2747*0Sstevel@tonic-gate PP(pp_log)
2748*0Sstevel@tonic-gate {
2749*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(log);
2750*0Sstevel@tonic-gate {
2751*0Sstevel@tonic-gate NV value;
2752*0Sstevel@tonic-gate value = POPn;
2753*0Sstevel@tonic-gate if (value <= 0.0) {
2754*0Sstevel@tonic-gate SET_NUMERIC_STANDARD();
2755*0Sstevel@tonic-gate DIE(aTHX_ "Can't take log of %"NVgf, value);
2756*0Sstevel@tonic-gate }
2757*0Sstevel@tonic-gate value = Perl_log(value);
2758*0Sstevel@tonic-gate XPUSHn(value);
2759*0Sstevel@tonic-gate RETURN;
2760*0Sstevel@tonic-gate }
2761*0Sstevel@tonic-gate }
2762*0Sstevel@tonic-gate
PP(pp_sqrt)2763*0Sstevel@tonic-gate PP(pp_sqrt)
2764*0Sstevel@tonic-gate {
2765*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(sqrt);
2766*0Sstevel@tonic-gate {
2767*0Sstevel@tonic-gate NV value;
2768*0Sstevel@tonic-gate value = POPn;
2769*0Sstevel@tonic-gate if (value < 0.0) {
2770*0Sstevel@tonic-gate SET_NUMERIC_STANDARD();
2771*0Sstevel@tonic-gate DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2772*0Sstevel@tonic-gate }
2773*0Sstevel@tonic-gate value = Perl_sqrt(value);
2774*0Sstevel@tonic-gate XPUSHn(value);
2775*0Sstevel@tonic-gate RETURN;
2776*0Sstevel@tonic-gate }
2777*0Sstevel@tonic-gate }
2778*0Sstevel@tonic-gate
PP(pp_int)2779*0Sstevel@tonic-gate PP(pp_int)
2780*0Sstevel@tonic-gate {
2781*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(int);
2782*0Sstevel@tonic-gate {
2783*0Sstevel@tonic-gate NV value;
2784*0Sstevel@tonic-gate IV iv = TOPi; /* attempt to convert to IV if possible. */
2785*0Sstevel@tonic-gate /* XXX it's arguable that compiler casting to IV might be subtly
2786*0Sstevel@tonic-gate different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2787*0Sstevel@tonic-gate else preferring IV has introduced a subtle behaviour change bug. OTOH
2788*0Sstevel@tonic-gate relying on floating point to be accurate is a bug. */
2789*0Sstevel@tonic-gate
2790*0Sstevel@tonic-gate if (!SvOK(TOPs))
2791*0Sstevel@tonic-gate SETu(0);
2792*0Sstevel@tonic-gate else if (SvIOK(TOPs)) {
2793*0Sstevel@tonic-gate if (SvIsUV(TOPs)) {
2794*0Sstevel@tonic-gate UV uv = TOPu;
2795*0Sstevel@tonic-gate SETu(uv);
2796*0Sstevel@tonic-gate } else
2797*0Sstevel@tonic-gate SETi(iv);
2798*0Sstevel@tonic-gate } else {
2799*0Sstevel@tonic-gate value = TOPn;
2800*0Sstevel@tonic-gate if (value >= 0.0) {
2801*0Sstevel@tonic-gate if (value < (NV)UV_MAX + 0.5) {
2802*0Sstevel@tonic-gate SETu(U_V(value));
2803*0Sstevel@tonic-gate } else {
2804*0Sstevel@tonic-gate SETn(Perl_floor(value));
2805*0Sstevel@tonic-gate }
2806*0Sstevel@tonic-gate }
2807*0Sstevel@tonic-gate else {
2808*0Sstevel@tonic-gate if (value > (NV)IV_MIN - 0.5) {
2809*0Sstevel@tonic-gate SETi(I_V(value));
2810*0Sstevel@tonic-gate } else {
2811*0Sstevel@tonic-gate SETn(Perl_ceil(value));
2812*0Sstevel@tonic-gate }
2813*0Sstevel@tonic-gate }
2814*0Sstevel@tonic-gate }
2815*0Sstevel@tonic-gate }
2816*0Sstevel@tonic-gate RETURN;
2817*0Sstevel@tonic-gate }
2818*0Sstevel@tonic-gate
PP(pp_abs)2819*0Sstevel@tonic-gate PP(pp_abs)
2820*0Sstevel@tonic-gate {
2821*0Sstevel@tonic-gate dSP; dTARGET; tryAMAGICun(abs);
2822*0Sstevel@tonic-gate {
2823*0Sstevel@tonic-gate /* This will cache the NV value if string isn't actually integer */
2824*0Sstevel@tonic-gate IV iv = TOPi;
2825*0Sstevel@tonic-gate
2826*0Sstevel@tonic-gate if (!SvOK(TOPs))
2827*0Sstevel@tonic-gate SETu(0);
2828*0Sstevel@tonic-gate else if (SvIOK(TOPs)) {
2829*0Sstevel@tonic-gate /* IVX is precise */
2830*0Sstevel@tonic-gate if (SvIsUV(TOPs)) {
2831*0Sstevel@tonic-gate SETu(TOPu); /* force it to be numeric only */
2832*0Sstevel@tonic-gate } else {
2833*0Sstevel@tonic-gate if (iv >= 0) {
2834*0Sstevel@tonic-gate SETi(iv);
2835*0Sstevel@tonic-gate } else {
2836*0Sstevel@tonic-gate if (iv != IV_MIN) {
2837*0Sstevel@tonic-gate SETi(-iv);
2838*0Sstevel@tonic-gate } else {
2839*0Sstevel@tonic-gate /* 2s complement assumption. Also, not really needed as
2840*0Sstevel@tonic-gate IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2841*0Sstevel@tonic-gate SETu(IV_MIN);
2842*0Sstevel@tonic-gate }
2843*0Sstevel@tonic-gate }
2844*0Sstevel@tonic-gate }
2845*0Sstevel@tonic-gate } else{
2846*0Sstevel@tonic-gate NV value = TOPn;
2847*0Sstevel@tonic-gate if (value < 0.0)
2848*0Sstevel@tonic-gate value = -value;
2849*0Sstevel@tonic-gate SETn(value);
2850*0Sstevel@tonic-gate }
2851*0Sstevel@tonic-gate }
2852*0Sstevel@tonic-gate RETURN;
2853*0Sstevel@tonic-gate }
2854*0Sstevel@tonic-gate
2855*0Sstevel@tonic-gate
PP(pp_hex)2856*0Sstevel@tonic-gate PP(pp_hex)
2857*0Sstevel@tonic-gate {
2858*0Sstevel@tonic-gate dSP; dTARGET;
2859*0Sstevel@tonic-gate char *tmps;
2860*0Sstevel@tonic-gate I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2861*0Sstevel@tonic-gate STRLEN len;
2862*0Sstevel@tonic-gate NV result_nv;
2863*0Sstevel@tonic-gate UV result_uv;
2864*0Sstevel@tonic-gate SV* sv = POPs;
2865*0Sstevel@tonic-gate
2866*0Sstevel@tonic-gate tmps = (SvPVx(sv, len));
2867*0Sstevel@tonic-gate if (DO_UTF8(sv)) {
2868*0Sstevel@tonic-gate /* If Unicode, try to downgrade
2869*0Sstevel@tonic-gate * If not possible, croak. */
2870*0Sstevel@tonic-gate SV* tsv = sv_2mortal(newSVsv(sv));
2871*0Sstevel@tonic-gate
2872*0Sstevel@tonic-gate SvUTF8_on(tsv);
2873*0Sstevel@tonic-gate sv_utf8_downgrade(tsv, FALSE);
2874*0Sstevel@tonic-gate tmps = SvPVX(tsv);
2875*0Sstevel@tonic-gate }
2876*0Sstevel@tonic-gate result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2877*0Sstevel@tonic-gate if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2878*0Sstevel@tonic-gate XPUSHn(result_nv);
2879*0Sstevel@tonic-gate }
2880*0Sstevel@tonic-gate else {
2881*0Sstevel@tonic-gate XPUSHu(result_uv);
2882*0Sstevel@tonic-gate }
2883*0Sstevel@tonic-gate RETURN;
2884*0Sstevel@tonic-gate }
2885*0Sstevel@tonic-gate
PP(pp_oct)2886*0Sstevel@tonic-gate PP(pp_oct)
2887*0Sstevel@tonic-gate {
2888*0Sstevel@tonic-gate dSP; dTARGET;
2889*0Sstevel@tonic-gate char *tmps;
2890*0Sstevel@tonic-gate I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2891*0Sstevel@tonic-gate STRLEN len;
2892*0Sstevel@tonic-gate NV result_nv;
2893*0Sstevel@tonic-gate UV result_uv;
2894*0Sstevel@tonic-gate SV* sv = POPs;
2895*0Sstevel@tonic-gate
2896*0Sstevel@tonic-gate tmps = (SvPVx(sv, len));
2897*0Sstevel@tonic-gate if (DO_UTF8(sv)) {
2898*0Sstevel@tonic-gate /* If Unicode, try to downgrade
2899*0Sstevel@tonic-gate * If not possible, croak. */
2900*0Sstevel@tonic-gate SV* tsv = sv_2mortal(newSVsv(sv));
2901*0Sstevel@tonic-gate
2902*0Sstevel@tonic-gate SvUTF8_on(tsv);
2903*0Sstevel@tonic-gate sv_utf8_downgrade(tsv, FALSE);
2904*0Sstevel@tonic-gate tmps = SvPVX(tsv);
2905*0Sstevel@tonic-gate }
2906*0Sstevel@tonic-gate while (*tmps && len && isSPACE(*tmps))
2907*0Sstevel@tonic-gate tmps++, len--;
2908*0Sstevel@tonic-gate if (*tmps == '0')
2909*0Sstevel@tonic-gate tmps++, len--;
2910*0Sstevel@tonic-gate if (*tmps == 'x')
2911*0Sstevel@tonic-gate result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2912*0Sstevel@tonic-gate else if (*tmps == 'b')
2913*0Sstevel@tonic-gate result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2914*0Sstevel@tonic-gate else
2915*0Sstevel@tonic-gate result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2916*0Sstevel@tonic-gate
2917*0Sstevel@tonic-gate if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2918*0Sstevel@tonic-gate XPUSHn(result_nv);
2919*0Sstevel@tonic-gate }
2920*0Sstevel@tonic-gate else {
2921*0Sstevel@tonic-gate XPUSHu(result_uv);
2922*0Sstevel@tonic-gate }
2923*0Sstevel@tonic-gate RETURN;
2924*0Sstevel@tonic-gate }
2925*0Sstevel@tonic-gate
2926*0Sstevel@tonic-gate /* String stuff. */
2927*0Sstevel@tonic-gate
PP(pp_length)2928*0Sstevel@tonic-gate PP(pp_length)
2929*0Sstevel@tonic-gate {
2930*0Sstevel@tonic-gate dSP; dTARGET;
2931*0Sstevel@tonic-gate SV *sv = TOPs;
2932*0Sstevel@tonic-gate
2933*0Sstevel@tonic-gate if (DO_UTF8(sv))
2934*0Sstevel@tonic-gate SETi(sv_len_utf8(sv));
2935*0Sstevel@tonic-gate else
2936*0Sstevel@tonic-gate SETi(sv_len(sv));
2937*0Sstevel@tonic-gate RETURN;
2938*0Sstevel@tonic-gate }
2939*0Sstevel@tonic-gate
PP(pp_substr)2940*0Sstevel@tonic-gate PP(pp_substr)
2941*0Sstevel@tonic-gate {
2942*0Sstevel@tonic-gate dSP; dTARGET;
2943*0Sstevel@tonic-gate SV *sv;
2944*0Sstevel@tonic-gate I32 len = 0;
2945*0Sstevel@tonic-gate STRLEN curlen;
2946*0Sstevel@tonic-gate STRLEN utf8_curlen;
2947*0Sstevel@tonic-gate I32 pos;
2948*0Sstevel@tonic-gate I32 rem;
2949*0Sstevel@tonic-gate I32 fail;
2950*0Sstevel@tonic-gate I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2951*0Sstevel@tonic-gate char *tmps;
2952*0Sstevel@tonic-gate I32 arybase = PL_curcop->cop_arybase;
2953*0Sstevel@tonic-gate SV *repl_sv = NULL;
2954*0Sstevel@tonic-gate char *repl = 0;
2955*0Sstevel@tonic-gate STRLEN repl_len;
2956*0Sstevel@tonic-gate int num_args = PL_op->op_private & 7;
2957*0Sstevel@tonic-gate bool repl_need_utf8_upgrade = FALSE;
2958*0Sstevel@tonic-gate bool repl_is_utf8 = FALSE;
2959*0Sstevel@tonic-gate
2960*0Sstevel@tonic-gate SvTAINTED_off(TARG); /* decontaminate */
2961*0Sstevel@tonic-gate SvUTF8_off(TARG); /* decontaminate */
2962*0Sstevel@tonic-gate if (num_args > 2) {
2963*0Sstevel@tonic-gate if (num_args > 3) {
2964*0Sstevel@tonic-gate repl_sv = POPs;
2965*0Sstevel@tonic-gate repl = SvPV(repl_sv, repl_len);
2966*0Sstevel@tonic-gate repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2967*0Sstevel@tonic-gate }
2968*0Sstevel@tonic-gate len = POPi;
2969*0Sstevel@tonic-gate }
2970*0Sstevel@tonic-gate pos = POPi;
2971*0Sstevel@tonic-gate sv = POPs;
2972*0Sstevel@tonic-gate PUTBACK;
2973*0Sstevel@tonic-gate if (repl_sv) {
2974*0Sstevel@tonic-gate if (repl_is_utf8) {
2975*0Sstevel@tonic-gate if (!DO_UTF8(sv))
2976*0Sstevel@tonic-gate sv_utf8_upgrade(sv);
2977*0Sstevel@tonic-gate }
2978*0Sstevel@tonic-gate else if (DO_UTF8(sv))
2979*0Sstevel@tonic-gate repl_need_utf8_upgrade = TRUE;
2980*0Sstevel@tonic-gate }
2981*0Sstevel@tonic-gate tmps = SvPV(sv, curlen);
2982*0Sstevel@tonic-gate if (DO_UTF8(sv)) {
2983*0Sstevel@tonic-gate utf8_curlen = sv_len_utf8(sv);
2984*0Sstevel@tonic-gate if (utf8_curlen == curlen)
2985*0Sstevel@tonic-gate utf8_curlen = 0;
2986*0Sstevel@tonic-gate else
2987*0Sstevel@tonic-gate curlen = utf8_curlen;
2988*0Sstevel@tonic-gate }
2989*0Sstevel@tonic-gate else
2990*0Sstevel@tonic-gate utf8_curlen = 0;
2991*0Sstevel@tonic-gate
2992*0Sstevel@tonic-gate if (pos >= arybase) {
2993*0Sstevel@tonic-gate pos -= arybase;
2994*0Sstevel@tonic-gate rem = curlen-pos;
2995*0Sstevel@tonic-gate fail = rem;
2996*0Sstevel@tonic-gate if (num_args > 2) {
2997*0Sstevel@tonic-gate if (len < 0) {
2998*0Sstevel@tonic-gate rem += len;
2999*0Sstevel@tonic-gate if (rem < 0)
3000*0Sstevel@tonic-gate rem = 0;
3001*0Sstevel@tonic-gate }
3002*0Sstevel@tonic-gate else if (rem > len)
3003*0Sstevel@tonic-gate rem = len;
3004*0Sstevel@tonic-gate }
3005*0Sstevel@tonic-gate }
3006*0Sstevel@tonic-gate else {
3007*0Sstevel@tonic-gate pos += curlen;
3008*0Sstevel@tonic-gate if (num_args < 3)
3009*0Sstevel@tonic-gate rem = curlen;
3010*0Sstevel@tonic-gate else if (len >= 0) {
3011*0Sstevel@tonic-gate rem = pos+len;
3012*0Sstevel@tonic-gate if (rem > (I32)curlen)
3013*0Sstevel@tonic-gate rem = curlen;
3014*0Sstevel@tonic-gate }
3015*0Sstevel@tonic-gate else {
3016*0Sstevel@tonic-gate rem = curlen+len;
3017*0Sstevel@tonic-gate if (rem < pos)
3018*0Sstevel@tonic-gate rem = pos;
3019*0Sstevel@tonic-gate }
3020*0Sstevel@tonic-gate if (pos < 0)
3021*0Sstevel@tonic-gate pos = 0;
3022*0Sstevel@tonic-gate fail = rem;
3023*0Sstevel@tonic-gate rem -= pos;
3024*0Sstevel@tonic-gate }
3025*0Sstevel@tonic-gate if (fail < 0) {
3026*0Sstevel@tonic-gate if (lvalue || repl)
3027*0Sstevel@tonic-gate Perl_croak(aTHX_ "substr outside of string");
3028*0Sstevel@tonic-gate if (ckWARN(WARN_SUBSTR))
3029*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3030*0Sstevel@tonic-gate RETPUSHUNDEF;
3031*0Sstevel@tonic-gate }
3032*0Sstevel@tonic-gate else {
3033*0Sstevel@tonic-gate I32 upos = pos;
3034*0Sstevel@tonic-gate I32 urem = rem;
3035*0Sstevel@tonic-gate if (utf8_curlen)
3036*0Sstevel@tonic-gate sv_pos_u2b(sv, &pos, &rem);
3037*0Sstevel@tonic-gate tmps += pos;
3038*0Sstevel@tonic-gate /* we either return a PV or an LV. If the TARG hasn't been used
3039*0Sstevel@tonic-gate * before, or is of that type, reuse it; otherwise use a mortal
3040*0Sstevel@tonic-gate * instead. Note that LVs can have an extended lifetime, so also
3041*0Sstevel@tonic-gate * dont reuse if refcount > 1 (bug #20933) */
3042*0Sstevel@tonic-gate if (SvTYPE(TARG) > SVt_NULL) {
3043*0Sstevel@tonic-gate if ( (SvTYPE(TARG) == SVt_PVLV)
3044*0Sstevel@tonic-gate ? (!lvalue || SvREFCNT(TARG) > 1)
3045*0Sstevel@tonic-gate : lvalue)
3046*0Sstevel@tonic-gate {
3047*0Sstevel@tonic-gate TARG = sv_newmortal();
3048*0Sstevel@tonic-gate }
3049*0Sstevel@tonic-gate }
3050*0Sstevel@tonic-gate
3051*0Sstevel@tonic-gate sv_setpvn(TARG, tmps, rem);
3052*0Sstevel@tonic-gate #ifdef USE_LOCALE_COLLATE
3053*0Sstevel@tonic-gate sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3054*0Sstevel@tonic-gate #endif
3055*0Sstevel@tonic-gate if (utf8_curlen)
3056*0Sstevel@tonic-gate SvUTF8_on(TARG);
3057*0Sstevel@tonic-gate if (repl) {
3058*0Sstevel@tonic-gate SV* repl_sv_copy = NULL;
3059*0Sstevel@tonic-gate
3060*0Sstevel@tonic-gate if (repl_need_utf8_upgrade) {
3061*0Sstevel@tonic-gate repl_sv_copy = newSVsv(repl_sv);
3062*0Sstevel@tonic-gate sv_utf8_upgrade(repl_sv_copy);
3063*0Sstevel@tonic-gate repl = SvPV(repl_sv_copy, repl_len);
3064*0Sstevel@tonic-gate repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3065*0Sstevel@tonic-gate }
3066*0Sstevel@tonic-gate sv_insert(sv, pos, rem, repl, repl_len);
3067*0Sstevel@tonic-gate if (repl_is_utf8)
3068*0Sstevel@tonic-gate SvUTF8_on(sv);
3069*0Sstevel@tonic-gate if (repl_sv_copy)
3070*0Sstevel@tonic-gate SvREFCNT_dec(repl_sv_copy);
3071*0Sstevel@tonic-gate }
3072*0Sstevel@tonic-gate else if (lvalue) { /* it's an lvalue! */
3073*0Sstevel@tonic-gate if (!SvGMAGICAL(sv)) {
3074*0Sstevel@tonic-gate if (SvROK(sv)) {
3075*0Sstevel@tonic-gate STRLEN n_a;
3076*0Sstevel@tonic-gate SvPV_force(sv,n_a);
3077*0Sstevel@tonic-gate if (ckWARN(WARN_SUBSTR))
3078*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3079*0Sstevel@tonic-gate "Attempt to use reference as lvalue in substr");
3080*0Sstevel@tonic-gate }
3081*0Sstevel@tonic-gate if (SvOK(sv)) /* is it defined ? */
3082*0Sstevel@tonic-gate (void)SvPOK_only_UTF8(sv);
3083*0Sstevel@tonic-gate else
3084*0Sstevel@tonic-gate sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3085*0Sstevel@tonic-gate }
3086*0Sstevel@tonic-gate
3087*0Sstevel@tonic-gate if (SvTYPE(TARG) < SVt_PVLV) {
3088*0Sstevel@tonic-gate sv_upgrade(TARG, SVt_PVLV);
3089*0Sstevel@tonic-gate sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3090*0Sstevel@tonic-gate }
3091*0Sstevel@tonic-gate else
3092*0Sstevel@tonic-gate (void)SvOK_off(TARG);
3093*0Sstevel@tonic-gate
3094*0Sstevel@tonic-gate LvTYPE(TARG) = 'x';
3095*0Sstevel@tonic-gate if (LvTARG(TARG) != sv) {
3096*0Sstevel@tonic-gate if (LvTARG(TARG))
3097*0Sstevel@tonic-gate SvREFCNT_dec(LvTARG(TARG));
3098*0Sstevel@tonic-gate LvTARG(TARG) = SvREFCNT_inc(sv);
3099*0Sstevel@tonic-gate }
3100*0Sstevel@tonic-gate LvTARGOFF(TARG) = upos;
3101*0Sstevel@tonic-gate LvTARGLEN(TARG) = urem;
3102*0Sstevel@tonic-gate }
3103*0Sstevel@tonic-gate }
3104*0Sstevel@tonic-gate SPAGAIN;
3105*0Sstevel@tonic-gate PUSHs(TARG); /* avoid SvSETMAGIC here */
3106*0Sstevel@tonic-gate RETURN;
3107*0Sstevel@tonic-gate }
3108*0Sstevel@tonic-gate
PP(pp_vec)3109*0Sstevel@tonic-gate PP(pp_vec)
3110*0Sstevel@tonic-gate {
3111*0Sstevel@tonic-gate dSP; dTARGET;
3112*0Sstevel@tonic-gate register IV size = POPi;
3113*0Sstevel@tonic-gate register IV offset = POPi;
3114*0Sstevel@tonic-gate register SV *src = POPs;
3115*0Sstevel@tonic-gate I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3116*0Sstevel@tonic-gate
3117*0Sstevel@tonic-gate SvTAINTED_off(TARG); /* decontaminate */
3118*0Sstevel@tonic-gate if (lvalue) { /* it's an lvalue! */
3119*0Sstevel@tonic-gate if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3120*0Sstevel@tonic-gate TARG = sv_newmortal();
3121*0Sstevel@tonic-gate if (SvTYPE(TARG) < SVt_PVLV) {
3122*0Sstevel@tonic-gate sv_upgrade(TARG, SVt_PVLV);
3123*0Sstevel@tonic-gate sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3124*0Sstevel@tonic-gate }
3125*0Sstevel@tonic-gate LvTYPE(TARG) = 'v';
3126*0Sstevel@tonic-gate if (LvTARG(TARG) != src) {
3127*0Sstevel@tonic-gate if (LvTARG(TARG))
3128*0Sstevel@tonic-gate SvREFCNT_dec(LvTARG(TARG));
3129*0Sstevel@tonic-gate LvTARG(TARG) = SvREFCNT_inc(src);
3130*0Sstevel@tonic-gate }
3131*0Sstevel@tonic-gate LvTARGOFF(TARG) = offset;
3132*0Sstevel@tonic-gate LvTARGLEN(TARG) = size;
3133*0Sstevel@tonic-gate }
3134*0Sstevel@tonic-gate
3135*0Sstevel@tonic-gate sv_setuv(TARG, do_vecget(src, offset, size));
3136*0Sstevel@tonic-gate PUSHs(TARG);
3137*0Sstevel@tonic-gate RETURN;
3138*0Sstevel@tonic-gate }
3139*0Sstevel@tonic-gate
PP(pp_index)3140*0Sstevel@tonic-gate PP(pp_index)
3141*0Sstevel@tonic-gate {
3142*0Sstevel@tonic-gate dSP; dTARGET;
3143*0Sstevel@tonic-gate SV *big;
3144*0Sstevel@tonic-gate SV *little;
3145*0Sstevel@tonic-gate I32 offset;
3146*0Sstevel@tonic-gate I32 retval;
3147*0Sstevel@tonic-gate char *tmps;
3148*0Sstevel@tonic-gate char *tmps2;
3149*0Sstevel@tonic-gate STRLEN biglen;
3150*0Sstevel@tonic-gate I32 arybase = PL_curcop->cop_arybase;
3151*0Sstevel@tonic-gate
3152*0Sstevel@tonic-gate if (MAXARG < 3)
3153*0Sstevel@tonic-gate offset = 0;
3154*0Sstevel@tonic-gate else
3155*0Sstevel@tonic-gate offset = POPi - arybase;
3156*0Sstevel@tonic-gate little = POPs;
3157*0Sstevel@tonic-gate big = POPs;
3158*0Sstevel@tonic-gate tmps = SvPV(big, biglen);
3159*0Sstevel@tonic-gate if (offset > 0 && DO_UTF8(big))
3160*0Sstevel@tonic-gate sv_pos_u2b(big, &offset, 0);
3161*0Sstevel@tonic-gate if (offset < 0)
3162*0Sstevel@tonic-gate offset = 0;
3163*0Sstevel@tonic-gate else if (offset > (I32)biglen)
3164*0Sstevel@tonic-gate offset = biglen;
3165*0Sstevel@tonic-gate if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3166*0Sstevel@tonic-gate (unsigned char*)tmps + biglen, little, 0)))
3167*0Sstevel@tonic-gate retval = -1;
3168*0Sstevel@tonic-gate else
3169*0Sstevel@tonic-gate retval = tmps2 - tmps;
3170*0Sstevel@tonic-gate if (retval > 0 && DO_UTF8(big))
3171*0Sstevel@tonic-gate sv_pos_b2u(big, &retval);
3172*0Sstevel@tonic-gate PUSHi(retval + arybase);
3173*0Sstevel@tonic-gate RETURN;
3174*0Sstevel@tonic-gate }
3175*0Sstevel@tonic-gate
PP(pp_rindex)3176*0Sstevel@tonic-gate PP(pp_rindex)
3177*0Sstevel@tonic-gate {
3178*0Sstevel@tonic-gate dSP; dTARGET;
3179*0Sstevel@tonic-gate SV *big;
3180*0Sstevel@tonic-gate SV *little;
3181*0Sstevel@tonic-gate STRLEN blen;
3182*0Sstevel@tonic-gate STRLEN llen;
3183*0Sstevel@tonic-gate I32 offset;
3184*0Sstevel@tonic-gate I32 retval;
3185*0Sstevel@tonic-gate char *tmps;
3186*0Sstevel@tonic-gate char *tmps2;
3187*0Sstevel@tonic-gate I32 arybase = PL_curcop->cop_arybase;
3188*0Sstevel@tonic-gate
3189*0Sstevel@tonic-gate if (MAXARG >= 3)
3190*0Sstevel@tonic-gate offset = POPi;
3191*0Sstevel@tonic-gate little = POPs;
3192*0Sstevel@tonic-gate big = POPs;
3193*0Sstevel@tonic-gate tmps2 = SvPV(little, llen);
3194*0Sstevel@tonic-gate tmps = SvPV(big, blen);
3195*0Sstevel@tonic-gate if (MAXARG < 3)
3196*0Sstevel@tonic-gate offset = blen;
3197*0Sstevel@tonic-gate else {
3198*0Sstevel@tonic-gate if (offset > 0 && DO_UTF8(big))
3199*0Sstevel@tonic-gate sv_pos_u2b(big, &offset, 0);
3200*0Sstevel@tonic-gate offset = offset - arybase + llen;
3201*0Sstevel@tonic-gate }
3202*0Sstevel@tonic-gate if (offset < 0)
3203*0Sstevel@tonic-gate offset = 0;
3204*0Sstevel@tonic-gate else if (offset > (I32)blen)
3205*0Sstevel@tonic-gate offset = blen;
3206*0Sstevel@tonic-gate if (!(tmps2 = rninstr(tmps, tmps + offset,
3207*0Sstevel@tonic-gate tmps2, tmps2 + llen)))
3208*0Sstevel@tonic-gate retval = -1;
3209*0Sstevel@tonic-gate else
3210*0Sstevel@tonic-gate retval = tmps2 - tmps;
3211*0Sstevel@tonic-gate if (retval > 0 && DO_UTF8(big))
3212*0Sstevel@tonic-gate sv_pos_b2u(big, &retval);
3213*0Sstevel@tonic-gate PUSHi(retval + arybase);
3214*0Sstevel@tonic-gate RETURN;
3215*0Sstevel@tonic-gate }
3216*0Sstevel@tonic-gate
PP(pp_sprintf)3217*0Sstevel@tonic-gate PP(pp_sprintf)
3218*0Sstevel@tonic-gate {
3219*0Sstevel@tonic-gate dSP; dMARK; dORIGMARK; dTARGET;
3220*0Sstevel@tonic-gate do_sprintf(TARG, SP-MARK, MARK+1);
3221*0Sstevel@tonic-gate TAINT_IF(SvTAINTED(TARG));
3222*0Sstevel@tonic-gate if (DO_UTF8(*(MARK+1)))
3223*0Sstevel@tonic-gate SvUTF8_on(TARG);
3224*0Sstevel@tonic-gate SP = ORIGMARK;
3225*0Sstevel@tonic-gate PUSHTARG;
3226*0Sstevel@tonic-gate RETURN;
3227*0Sstevel@tonic-gate }
3228*0Sstevel@tonic-gate
PP(pp_ord)3229*0Sstevel@tonic-gate PP(pp_ord)
3230*0Sstevel@tonic-gate {
3231*0Sstevel@tonic-gate dSP; dTARGET;
3232*0Sstevel@tonic-gate SV *argsv = POPs;
3233*0Sstevel@tonic-gate STRLEN len;
3234*0Sstevel@tonic-gate U8 *s = (U8*)SvPVx(argsv, len);
3235*0Sstevel@tonic-gate SV *tmpsv;
3236*0Sstevel@tonic-gate
3237*0Sstevel@tonic-gate if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3238*0Sstevel@tonic-gate tmpsv = sv_2mortal(newSVsv(argsv));
3239*0Sstevel@tonic-gate s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3240*0Sstevel@tonic-gate argsv = tmpsv;
3241*0Sstevel@tonic-gate }
3242*0Sstevel@tonic-gate
3243*0Sstevel@tonic-gate XPUSHu(DO_UTF8(argsv) ?
3244*0Sstevel@tonic-gate utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3245*0Sstevel@tonic-gate (*s & 0xff));
3246*0Sstevel@tonic-gate
3247*0Sstevel@tonic-gate RETURN;
3248*0Sstevel@tonic-gate }
3249*0Sstevel@tonic-gate
PP(pp_chr)3250*0Sstevel@tonic-gate PP(pp_chr)
3251*0Sstevel@tonic-gate {
3252*0Sstevel@tonic-gate dSP; dTARGET;
3253*0Sstevel@tonic-gate char *tmps;
3254*0Sstevel@tonic-gate UV value = POPu;
3255*0Sstevel@tonic-gate
3256*0Sstevel@tonic-gate (void)SvUPGRADE(TARG,SVt_PV);
3257*0Sstevel@tonic-gate
3258*0Sstevel@tonic-gate if (value > 255 && !IN_BYTES) {
3259*0Sstevel@tonic-gate SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3260*0Sstevel@tonic-gate tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3261*0Sstevel@tonic-gate SvCUR_set(TARG, tmps - SvPVX(TARG));
3262*0Sstevel@tonic-gate *tmps = '\0';
3263*0Sstevel@tonic-gate (void)SvPOK_only(TARG);
3264*0Sstevel@tonic-gate SvUTF8_on(TARG);
3265*0Sstevel@tonic-gate XPUSHs(TARG);
3266*0Sstevel@tonic-gate RETURN;
3267*0Sstevel@tonic-gate }
3268*0Sstevel@tonic-gate
3269*0Sstevel@tonic-gate SvGROW(TARG,2);
3270*0Sstevel@tonic-gate SvCUR_set(TARG, 1);
3271*0Sstevel@tonic-gate tmps = SvPVX(TARG);
3272*0Sstevel@tonic-gate *tmps++ = (char)value;
3273*0Sstevel@tonic-gate *tmps = '\0';
3274*0Sstevel@tonic-gate (void)SvPOK_only(TARG);
3275*0Sstevel@tonic-gate if (PL_encoding && !IN_BYTES) {
3276*0Sstevel@tonic-gate sv_recode_to_utf8(TARG, PL_encoding);
3277*0Sstevel@tonic-gate tmps = SvPVX(TARG);
3278*0Sstevel@tonic-gate if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3279*0Sstevel@tonic-gate memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3280*0Sstevel@tonic-gate SvGROW(TARG, 3);
3281*0Sstevel@tonic-gate tmps = SvPVX(TARG);
3282*0Sstevel@tonic-gate SvCUR_set(TARG, 2);
3283*0Sstevel@tonic-gate *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3284*0Sstevel@tonic-gate *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3285*0Sstevel@tonic-gate *tmps = '\0';
3286*0Sstevel@tonic-gate SvUTF8_on(TARG);
3287*0Sstevel@tonic-gate }
3288*0Sstevel@tonic-gate }
3289*0Sstevel@tonic-gate XPUSHs(TARG);
3290*0Sstevel@tonic-gate RETURN;
3291*0Sstevel@tonic-gate }
3292*0Sstevel@tonic-gate
PP(pp_crypt)3293*0Sstevel@tonic-gate PP(pp_crypt)
3294*0Sstevel@tonic-gate {
3295*0Sstevel@tonic-gate dSP; dTARGET;
3296*0Sstevel@tonic-gate #ifdef HAS_CRYPT
3297*0Sstevel@tonic-gate dPOPTOPssrl;
3298*0Sstevel@tonic-gate STRLEN n_a;
3299*0Sstevel@tonic-gate STRLEN len;
3300*0Sstevel@tonic-gate char *tmps = SvPV(left, len);
3301*0Sstevel@tonic-gate
3302*0Sstevel@tonic-gate if (DO_UTF8(left)) {
3303*0Sstevel@tonic-gate /* If Unicode, try to downgrade.
3304*0Sstevel@tonic-gate * If not possible, croak.
3305*0Sstevel@tonic-gate * Yes, we made this up. */
3306*0Sstevel@tonic-gate SV* tsv = sv_2mortal(newSVsv(left));
3307*0Sstevel@tonic-gate
3308*0Sstevel@tonic-gate SvUTF8_on(tsv);
3309*0Sstevel@tonic-gate sv_utf8_downgrade(tsv, FALSE);
3310*0Sstevel@tonic-gate tmps = SvPVX(tsv);
3311*0Sstevel@tonic-gate }
3312*0Sstevel@tonic-gate # ifdef USE_ITHREADS
3313*0Sstevel@tonic-gate # ifdef HAS_CRYPT_R
3314*0Sstevel@tonic-gate if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3315*0Sstevel@tonic-gate /* This should be threadsafe because in ithreads there is only
3316*0Sstevel@tonic-gate * one thread per interpreter. If this would not be true,
3317*0Sstevel@tonic-gate * we would need a mutex to protect this malloc. */
3318*0Sstevel@tonic-gate PL_reentrant_buffer->_crypt_struct_buffer =
3319*0Sstevel@tonic-gate (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3320*0Sstevel@tonic-gate #if defined(__GLIBC__) || defined(__EMX__)
3321*0Sstevel@tonic-gate if (PL_reentrant_buffer->_crypt_struct_buffer) {
3322*0Sstevel@tonic-gate PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3323*0Sstevel@tonic-gate /* work around glibc-2.2.5 bug */
3324*0Sstevel@tonic-gate PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3325*0Sstevel@tonic-gate }
3326*0Sstevel@tonic-gate #endif
3327*0Sstevel@tonic-gate }
3328*0Sstevel@tonic-gate # endif /* HAS_CRYPT_R */
3329*0Sstevel@tonic-gate # endif /* USE_ITHREADS */
3330*0Sstevel@tonic-gate # ifdef FCRYPT
3331*0Sstevel@tonic-gate sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3332*0Sstevel@tonic-gate # else
3333*0Sstevel@tonic-gate sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3334*0Sstevel@tonic-gate # endif
3335*0Sstevel@tonic-gate SETs(TARG);
3336*0Sstevel@tonic-gate RETURN;
3337*0Sstevel@tonic-gate #else
3338*0Sstevel@tonic-gate DIE(aTHX_
3339*0Sstevel@tonic-gate "The crypt() function is unimplemented due to excessive paranoia.");
3340*0Sstevel@tonic-gate #endif
3341*0Sstevel@tonic-gate }
3342*0Sstevel@tonic-gate
PP(pp_ucfirst)3343*0Sstevel@tonic-gate PP(pp_ucfirst)
3344*0Sstevel@tonic-gate {
3345*0Sstevel@tonic-gate dSP;
3346*0Sstevel@tonic-gate SV *sv = TOPs;
3347*0Sstevel@tonic-gate register U8 *s;
3348*0Sstevel@tonic-gate STRLEN slen;
3349*0Sstevel@tonic-gate
3350*0Sstevel@tonic-gate SvGETMAGIC(sv);
3351*0Sstevel@tonic-gate if (DO_UTF8(sv) &&
3352*0Sstevel@tonic-gate (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3353*0Sstevel@tonic-gate UTF8_IS_START(*s)) {
3354*0Sstevel@tonic-gate U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3355*0Sstevel@tonic-gate STRLEN ulen;
3356*0Sstevel@tonic-gate STRLEN tculen;
3357*0Sstevel@tonic-gate
3358*0Sstevel@tonic-gate utf8_to_uvchr(s, &ulen);
3359*0Sstevel@tonic-gate toTITLE_utf8(s, tmpbuf, &tculen);
3360*0Sstevel@tonic-gate utf8_to_uvchr(tmpbuf, 0);
3361*0Sstevel@tonic-gate
3362*0Sstevel@tonic-gate if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3363*0Sstevel@tonic-gate dTARGET;
3364*0Sstevel@tonic-gate /* slen is the byte length of the whole SV.
3365*0Sstevel@tonic-gate * ulen is the byte length of the original Unicode character
3366*0Sstevel@tonic-gate * stored as UTF-8 at s.
3367*0Sstevel@tonic-gate * tculen is the byte length of the freshly titlecased
3368*0Sstevel@tonic-gate * Unicode character stored as UTF-8 at tmpbuf.
3369*0Sstevel@tonic-gate * We first set the result to be the titlecased character,
3370*0Sstevel@tonic-gate * and then append the rest of the SV data. */
3371*0Sstevel@tonic-gate sv_setpvn(TARG, (char*)tmpbuf, tculen);
3372*0Sstevel@tonic-gate if (slen > ulen)
3373*0Sstevel@tonic-gate sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3374*0Sstevel@tonic-gate SvUTF8_on(TARG);
3375*0Sstevel@tonic-gate SETs(TARG);
3376*0Sstevel@tonic-gate }
3377*0Sstevel@tonic-gate else {
3378*0Sstevel@tonic-gate s = (U8*)SvPV_force_nomg(sv, slen);
3379*0Sstevel@tonic-gate Copy(tmpbuf, s, tculen, U8);
3380*0Sstevel@tonic-gate }
3381*0Sstevel@tonic-gate }
3382*0Sstevel@tonic-gate else {
3383*0Sstevel@tonic-gate if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3384*0Sstevel@tonic-gate dTARGET;
3385*0Sstevel@tonic-gate SvUTF8_off(TARG); /* decontaminate */
3386*0Sstevel@tonic-gate sv_setsv_nomg(TARG, sv);
3387*0Sstevel@tonic-gate sv = TARG;
3388*0Sstevel@tonic-gate SETs(sv);
3389*0Sstevel@tonic-gate }
3390*0Sstevel@tonic-gate s = (U8*)SvPV_force_nomg(sv, slen);
3391*0Sstevel@tonic-gate if (*s) {
3392*0Sstevel@tonic-gate if (IN_LOCALE_RUNTIME) {
3393*0Sstevel@tonic-gate TAINT;
3394*0Sstevel@tonic-gate SvTAINTED_on(sv);
3395*0Sstevel@tonic-gate *s = toUPPER_LC(*s);
3396*0Sstevel@tonic-gate }
3397*0Sstevel@tonic-gate else
3398*0Sstevel@tonic-gate *s = toUPPER(*s);
3399*0Sstevel@tonic-gate }
3400*0Sstevel@tonic-gate }
3401*0Sstevel@tonic-gate SvSETMAGIC(sv);
3402*0Sstevel@tonic-gate RETURN;
3403*0Sstevel@tonic-gate }
3404*0Sstevel@tonic-gate
PP(pp_lcfirst)3405*0Sstevel@tonic-gate PP(pp_lcfirst)
3406*0Sstevel@tonic-gate {
3407*0Sstevel@tonic-gate dSP;
3408*0Sstevel@tonic-gate SV *sv = TOPs;
3409*0Sstevel@tonic-gate register U8 *s;
3410*0Sstevel@tonic-gate STRLEN slen;
3411*0Sstevel@tonic-gate
3412*0Sstevel@tonic-gate SvGETMAGIC(sv);
3413*0Sstevel@tonic-gate if (DO_UTF8(sv) &&
3414*0Sstevel@tonic-gate (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3415*0Sstevel@tonic-gate UTF8_IS_START(*s)) {
3416*0Sstevel@tonic-gate STRLEN ulen;
3417*0Sstevel@tonic-gate U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3418*0Sstevel@tonic-gate U8 *tend;
3419*0Sstevel@tonic-gate UV uv;
3420*0Sstevel@tonic-gate
3421*0Sstevel@tonic-gate toLOWER_utf8(s, tmpbuf, &ulen);
3422*0Sstevel@tonic-gate uv = utf8_to_uvchr(tmpbuf, 0);
3423*0Sstevel@tonic-gate tend = uvchr_to_utf8(tmpbuf, uv);
3424*0Sstevel@tonic-gate
3425*0Sstevel@tonic-gate if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3426*0Sstevel@tonic-gate dTARGET;
3427*0Sstevel@tonic-gate sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3428*0Sstevel@tonic-gate if (slen > ulen)
3429*0Sstevel@tonic-gate sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3430*0Sstevel@tonic-gate SvUTF8_on(TARG);
3431*0Sstevel@tonic-gate SETs(TARG);
3432*0Sstevel@tonic-gate }
3433*0Sstevel@tonic-gate else {
3434*0Sstevel@tonic-gate s = (U8*)SvPV_force_nomg(sv, slen);
3435*0Sstevel@tonic-gate Copy(tmpbuf, s, ulen, U8);
3436*0Sstevel@tonic-gate }
3437*0Sstevel@tonic-gate }
3438*0Sstevel@tonic-gate else {
3439*0Sstevel@tonic-gate if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3440*0Sstevel@tonic-gate dTARGET;
3441*0Sstevel@tonic-gate SvUTF8_off(TARG); /* decontaminate */
3442*0Sstevel@tonic-gate sv_setsv_nomg(TARG, sv);
3443*0Sstevel@tonic-gate sv = TARG;
3444*0Sstevel@tonic-gate SETs(sv);
3445*0Sstevel@tonic-gate }
3446*0Sstevel@tonic-gate s = (U8*)SvPV_force_nomg(sv, slen);
3447*0Sstevel@tonic-gate if (*s) {
3448*0Sstevel@tonic-gate if (IN_LOCALE_RUNTIME) {
3449*0Sstevel@tonic-gate TAINT;
3450*0Sstevel@tonic-gate SvTAINTED_on(sv);
3451*0Sstevel@tonic-gate *s = toLOWER_LC(*s);
3452*0Sstevel@tonic-gate }
3453*0Sstevel@tonic-gate else
3454*0Sstevel@tonic-gate *s = toLOWER(*s);
3455*0Sstevel@tonic-gate }
3456*0Sstevel@tonic-gate }
3457*0Sstevel@tonic-gate SvSETMAGIC(sv);
3458*0Sstevel@tonic-gate RETURN;
3459*0Sstevel@tonic-gate }
3460*0Sstevel@tonic-gate
PP(pp_uc)3461*0Sstevel@tonic-gate PP(pp_uc)
3462*0Sstevel@tonic-gate {
3463*0Sstevel@tonic-gate dSP;
3464*0Sstevel@tonic-gate SV *sv = TOPs;
3465*0Sstevel@tonic-gate register U8 *s;
3466*0Sstevel@tonic-gate STRLEN len;
3467*0Sstevel@tonic-gate
3468*0Sstevel@tonic-gate SvGETMAGIC(sv);
3469*0Sstevel@tonic-gate if (DO_UTF8(sv)) {
3470*0Sstevel@tonic-gate dTARGET;
3471*0Sstevel@tonic-gate STRLEN ulen;
3472*0Sstevel@tonic-gate register U8 *d;
3473*0Sstevel@tonic-gate U8 *send;
3474*0Sstevel@tonic-gate U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3475*0Sstevel@tonic-gate
3476*0Sstevel@tonic-gate s = (U8*)SvPV_nomg(sv,len);
3477*0Sstevel@tonic-gate if (!len) {
3478*0Sstevel@tonic-gate SvUTF8_off(TARG); /* decontaminate */
3479*0Sstevel@tonic-gate sv_setpvn(TARG, "", 0);
3480*0Sstevel@tonic-gate SETs(TARG);
3481*0Sstevel@tonic-gate }
3482*0Sstevel@tonic-gate else {
3483*0Sstevel@tonic-gate STRLEN nchar = utf8_length(s, s + len);
3484*0Sstevel@tonic-gate
3485*0Sstevel@tonic-gate (void)SvUPGRADE(TARG, SVt_PV);
3486*0Sstevel@tonic-gate SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3487*0Sstevel@tonic-gate (void)SvPOK_only(TARG);
3488*0Sstevel@tonic-gate d = (U8*)SvPVX(TARG);
3489*0Sstevel@tonic-gate send = s + len;
3490*0Sstevel@tonic-gate while (s < send) {
3491*0Sstevel@tonic-gate toUPPER_utf8(s, tmpbuf, &ulen);
3492*0Sstevel@tonic-gate Copy(tmpbuf, d, ulen, U8);
3493*0Sstevel@tonic-gate d += ulen;
3494*0Sstevel@tonic-gate s += UTF8SKIP(s);
3495*0Sstevel@tonic-gate }
3496*0Sstevel@tonic-gate *d = '\0';
3497*0Sstevel@tonic-gate SvUTF8_on(TARG);
3498*0Sstevel@tonic-gate SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3499*0Sstevel@tonic-gate SETs(TARG);
3500*0Sstevel@tonic-gate }
3501*0Sstevel@tonic-gate }
3502*0Sstevel@tonic-gate else {
3503*0Sstevel@tonic-gate if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3504*0Sstevel@tonic-gate dTARGET;
3505*0Sstevel@tonic-gate SvUTF8_off(TARG); /* decontaminate */
3506*0Sstevel@tonic-gate sv_setsv_nomg(TARG, sv);
3507*0Sstevel@tonic-gate sv = TARG;
3508*0Sstevel@tonic-gate SETs(sv);
3509*0Sstevel@tonic-gate }
3510*0Sstevel@tonic-gate s = (U8*)SvPV_force_nomg(sv, len);
3511*0Sstevel@tonic-gate if (len) {
3512*0Sstevel@tonic-gate register U8 *send = s + len;
3513*0Sstevel@tonic-gate
3514*0Sstevel@tonic-gate if (IN_LOCALE_RUNTIME) {
3515*0Sstevel@tonic-gate TAINT;
3516*0Sstevel@tonic-gate SvTAINTED_on(sv);
3517*0Sstevel@tonic-gate for (; s < send; s++)
3518*0Sstevel@tonic-gate *s = toUPPER_LC(*s);
3519*0Sstevel@tonic-gate }
3520*0Sstevel@tonic-gate else {
3521*0Sstevel@tonic-gate for (; s < send; s++)
3522*0Sstevel@tonic-gate *s = toUPPER(*s);
3523*0Sstevel@tonic-gate }
3524*0Sstevel@tonic-gate }
3525*0Sstevel@tonic-gate }
3526*0Sstevel@tonic-gate SvSETMAGIC(sv);
3527*0Sstevel@tonic-gate RETURN;
3528*0Sstevel@tonic-gate }
3529*0Sstevel@tonic-gate
PP(pp_lc)3530*0Sstevel@tonic-gate PP(pp_lc)
3531*0Sstevel@tonic-gate {
3532*0Sstevel@tonic-gate dSP;
3533*0Sstevel@tonic-gate SV *sv = TOPs;
3534*0Sstevel@tonic-gate register U8 *s;
3535*0Sstevel@tonic-gate STRLEN len;
3536*0Sstevel@tonic-gate
3537*0Sstevel@tonic-gate SvGETMAGIC(sv);
3538*0Sstevel@tonic-gate if (DO_UTF8(sv)) {
3539*0Sstevel@tonic-gate dTARGET;
3540*0Sstevel@tonic-gate STRLEN ulen;
3541*0Sstevel@tonic-gate register U8 *d;
3542*0Sstevel@tonic-gate U8 *send;
3543*0Sstevel@tonic-gate U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3544*0Sstevel@tonic-gate
3545*0Sstevel@tonic-gate s = (U8*)SvPV_nomg(sv,len);
3546*0Sstevel@tonic-gate if (!len) {
3547*0Sstevel@tonic-gate SvUTF8_off(TARG); /* decontaminate */
3548*0Sstevel@tonic-gate sv_setpvn(TARG, "", 0);
3549*0Sstevel@tonic-gate SETs(TARG);
3550*0Sstevel@tonic-gate }
3551*0Sstevel@tonic-gate else {
3552*0Sstevel@tonic-gate STRLEN nchar = utf8_length(s, s + len);
3553*0Sstevel@tonic-gate
3554*0Sstevel@tonic-gate (void)SvUPGRADE(TARG, SVt_PV);
3555*0Sstevel@tonic-gate SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3556*0Sstevel@tonic-gate (void)SvPOK_only(TARG);
3557*0Sstevel@tonic-gate d = (U8*)SvPVX(TARG);
3558*0Sstevel@tonic-gate send = s + len;
3559*0Sstevel@tonic-gate while (s < send) {
3560*0Sstevel@tonic-gate UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3561*0Sstevel@tonic-gate #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3562*0Sstevel@tonic-gate if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3563*0Sstevel@tonic-gate /*
3564*0Sstevel@tonic-gate * Now if the sigma is NOT followed by
3565*0Sstevel@tonic-gate * /$ignorable_sequence$cased_letter/;
3566*0Sstevel@tonic-gate * and it IS preceded by
3567*0Sstevel@tonic-gate * /$cased_letter$ignorable_sequence/;
3568*0Sstevel@tonic-gate * where $ignorable_sequence is
3569*0Sstevel@tonic-gate * [\x{2010}\x{AD}\p{Mn}]*
3570*0Sstevel@tonic-gate * and $cased_letter is
3571*0Sstevel@tonic-gate * [\p{Ll}\p{Lo}\p{Lt}]
3572*0Sstevel@tonic-gate * then it should be mapped to 0x03C2,
3573*0Sstevel@tonic-gate * (GREEK SMALL LETTER FINAL SIGMA),
3574*0Sstevel@tonic-gate * instead of staying 0x03A3.
3575*0Sstevel@tonic-gate * See lib/unicore/SpecCase.txt.
3576*0Sstevel@tonic-gate */
3577*0Sstevel@tonic-gate }
3578*0Sstevel@tonic-gate Copy(tmpbuf, d, ulen, U8);
3579*0Sstevel@tonic-gate d += ulen;
3580*0Sstevel@tonic-gate s += UTF8SKIP(s);
3581*0Sstevel@tonic-gate }
3582*0Sstevel@tonic-gate *d = '\0';
3583*0Sstevel@tonic-gate SvUTF8_on(TARG);
3584*0Sstevel@tonic-gate SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3585*0Sstevel@tonic-gate SETs(TARG);
3586*0Sstevel@tonic-gate }
3587*0Sstevel@tonic-gate }
3588*0Sstevel@tonic-gate else {
3589*0Sstevel@tonic-gate if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3590*0Sstevel@tonic-gate dTARGET;
3591*0Sstevel@tonic-gate SvUTF8_off(TARG); /* decontaminate */
3592*0Sstevel@tonic-gate sv_setsv_nomg(TARG, sv);
3593*0Sstevel@tonic-gate sv = TARG;
3594*0Sstevel@tonic-gate SETs(sv);
3595*0Sstevel@tonic-gate }
3596*0Sstevel@tonic-gate
3597*0Sstevel@tonic-gate s = (U8*)SvPV_force_nomg(sv, len);
3598*0Sstevel@tonic-gate if (len) {
3599*0Sstevel@tonic-gate register U8 *send = s + len;
3600*0Sstevel@tonic-gate
3601*0Sstevel@tonic-gate if (IN_LOCALE_RUNTIME) {
3602*0Sstevel@tonic-gate TAINT;
3603*0Sstevel@tonic-gate SvTAINTED_on(sv);
3604*0Sstevel@tonic-gate for (; s < send; s++)
3605*0Sstevel@tonic-gate *s = toLOWER_LC(*s);
3606*0Sstevel@tonic-gate }
3607*0Sstevel@tonic-gate else {
3608*0Sstevel@tonic-gate for (; s < send; s++)
3609*0Sstevel@tonic-gate *s = toLOWER(*s);
3610*0Sstevel@tonic-gate }
3611*0Sstevel@tonic-gate }
3612*0Sstevel@tonic-gate }
3613*0Sstevel@tonic-gate SvSETMAGIC(sv);
3614*0Sstevel@tonic-gate RETURN;
3615*0Sstevel@tonic-gate }
3616*0Sstevel@tonic-gate
PP(pp_quotemeta)3617*0Sstevel@tonic-gate PP(pp_quotemeta)
3618*0Sstevel@tonic-gate {
3619*0Sstevel@tonic-gate dSP; dTARGET;
3620*0Sstevel@tonic-gate SV *sv = TOPs;
3621*0Sstevel@tonic-gate STRLEN len;
3622*0Sstevel@tonic-gate register char *s = SvPV(sv,len);
3623*0Sstevel@tonic-gate register char *d;
3624*0Sstevel@tonic-gate
3625*0Sstevel@tonic-gate SvUTF8_off(TARG); /* decontaminate */
3626*0Sstevel@tonic-gate if (len) {
3627*0Sstevel@tonic-gate (void)SvUPGRADE(TARG, SVt_PV);
3628*0Sstevel@tonic-gate SvGROW(TARG, (len * 2) + 1);
3629*0Sstevel@tonic-gate d = SvPVX(TARG);
3630*0Sstevel@tonic-gate if (DO_UTF8(sv)) {
3631*0Sstevel@tonic-gate while (len) {
3632*0Sstevel@tonic-gate if (UTF8_IS_CONTINUED(*s)) {
3633*0Sstevel@tonic-gate STRLEN ulen = UTF8SKIP(s);
3634*0Sstevel@tonic-gate if (ulen > len)
3635*0Sstevel@tonic-gate ulen = len;
3636*0Sstevel@tonic-gate len -= ulen;
3637*0Sstevel@tonic-gate while (ulen--)
3638*0Sstevel@tonic-gate *d++ = *s++;
3639*0Sstevel@tonic-gate }
3640*0Sstevel@tonic-gate else {
3641*0Sstevel@tonic-gate if (!isALNUM(*s))
3642*0Sstevel@tonic-gate *d++ = '\\';
3643*0Sstevel@tonic-gate *d++ = *s++;
3644*0Sstevel@tonic-gate len--;
3645*0Sstevel@tonic-gate }
3646*0Sstevel@tonic-gate }
3647*0Sstevel@tonic-gate SvUTF8_on(TARG);
3648*0Sstevel@tonic-gate }
3649*0Sstevel@tonic-gate else {
3650*0Sstevel@tonic-gate while (len--) {
3651*0Sstevel@tonic-gate if (!isALNUM(*s))
3652*0Sstevel@tonic-gate *d++ = '\\';
3653*0Sstevel@tonic-gate *d++ = *s++;
3654*0Sstevel@tonic-gate }
3655*0Sstevel@tonic-gate }
3656*0Sstevel@tonic-gate *d = '\0';
3657*0Sstevel@tonic-gate SvCUR_set(TARG, d - SvPVX(TARG));
3658*0Sstevel@tonic-gate (void)SvPOK_only_UTF8(TARG);
3659*0Sstevel@tonic-gate }
3660*0Sstevel@tonic-gate else
3661*0Sstevel@tonic-gate sv_setpvn(TARG, s, len);
3662*0Sstevel@tonic-gate SETs(TARG);
3663*0Sstevel@tonic-gate if (SvSMAGICAL(TARG))
3664*0Sstevel@tonic-gate mg_set(TARG);
3665*0Sstevel@tonic-gate RETURN;
3666*0Sstevel@tonic-gate }
3667*0Sstevel@tonic-gate
3668*0Sstevel@tonic-gate /* Arrays. */
3669*0Sstevel@tonic-gate
PP(pp_aslice)3670*0Sstevel@tonic-gate PP(pp_aslice)
3671*0Sstevel@tonic-gate {
3672*0Sstevel@tonic-gate dSP; dMARK; dORIGMARK;
3673*0Sstevel@tonic-gate register SV** svp;
3674*0Sstevel@tonic-gate register AV* av = (AV*)POPs;
3675*0Sstevel@tonic-gate register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3676*0Sstevel@tonic-gate I32 arybase = PL_curcop->cop_arybase;
3677*0Sstevel@tonic-gate I32 elem;
3678*0Sstevel@tonic-gate
3679*0Sstevel@tonic-gate if (SvTYPE(av) == SVt_PVAV) {
3680*0Sstevel@tonic-gate if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3681*0Sstevel@tonic-gate I32 max = -1;
3682*0Sstevel@tonic-gate for (svp = MARK + 1; svp <= SP; svp++) {
3683*0Sstevel@tonic-gate elem = SvIVx(*svp);
3684*0Sstevel@tonic-gate if (elem > max)
3685*0Sstevel@tonic-gate max = elem;
3686*0Sstevel@tonic-gate }
3687*0Sstevel@tonic-gate if (max > AvMAX(av))
3688*0Sstevel@tonic-gate av_extend(av, max);
3689*0Sstevel@tonic-gate }
3690*0Sstevel@tonic-gate while (++MARK <= SP) {
3691*0Sstevel@tonic-gate elem = SvIVx(*MARK);
3692*0Sstevel@tonic-gate
3693*0Sstevel@tonic-gate if (elem > 0)
3694*0Sstevel@tonic-gate elem -= arybase;
3695*0Sstevel@tonic-gate svp = av_fetch(av, elem, lval);
3696*0Sstevel@tonic-gate if (lval) {
3697*0Sstevel@tonic-gate if (!svp || *svp == &PL_sv_undef)
3698*0Sstevel@tonic-gate DIE(aTHX_ PL_no_aelem, elem);
3699*0Sstevel@tonic-gate if (PL_op->op_private & OPpLVAL_INTRO)
3700*0Sstevel@tonic-gate save_aelem(av, elem, svp);
3701*0Sstevel@tonic-gate }
3702*0Sstevel@tonic-gate *MARK = svp ? *svp : &PL_sv_undef;
3703*0Sstevel@tonic-gate }
3704*0Sstevel@tonic-gate }
3705*0Sstevel@tonic-gate if (GIMME != G_ARRAY) {
3706*0Sstevel@tonic-gate MARK = ORIGMARK;
3707*0Sstevel@tonic-gate *++MARK = *SP;
3708*0Sstevel@tonic-gate SP = MARK;
3709*0Sstevel@tonic-gate }
3710*0Sstevel@tonic-gate RETURN;
3711*0Sstevel@tonic-gate }
3712*0Sstevel@tonic-gate
3713*0Sstevel@tonic-gate /* Associative arrays. */
3714*0Sstevel@tonic-gate
PP(pp_each)3715*0Sstevel@tonic-gate PP(pp_each)
3716*0Sstevel@tonic-gate {
3717*0Sstevel@tonic-gate dSP;
3718*0Sstevel@tonic-gate HV *hash = (HV*)POPs;
3719*0Sstevel@tonic-gate HE *entry;
3720*0Sstevel@tonic-gate I32 gimme = GIMME_V;
3721*0Sstevel@tonic-gate I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3722*0Sstevel@tonic-gate
3723*0Sstevel@tonic-gate PUTBACK;
3724*0Sstevel@tonic-gate /* might clobber stack_sp */
3725*0Sstevel@tonic-gate entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3726*0Sstevel@tonic-gate SPAGAIN;
3727*0Sstevel@tonic-gate
3728*0Sstevel@tonic-gate EXTEND(SP, 2);
3729*0Sstevel@tonic-gate if (entry) {
3730*0Sstevel@tonic-gate SV* sv = hv_iterkeysv(entry);
3731*0Sstevel@tonic-gate PUSHs(sv); /* won't clobber stack_sp */
3732*0Sstevel@tonic-gate if (gimme == G_ARRAY) {
3733*0Sstevel@tonic-gate SV *val;
3734*0Sstevel@tonic-gate PUTBACK;
3735*0Sstevel@tonic-gate /* might clobber stack_sp */
3736*0Sstevel@tonic-gate val = realhv ?
3737*0Sstevel@tonic-gate hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3738*0Sstevel@tonic-gate SPAGAIN;
3739*0Sstevel@tonic-gate PUSHs(val);
3740*0Sstevel@tonic-gate }
3741*0Sstevel@tonic-gate }
3742*0Sstevel@tonic-gate else if (gimme == G_SCALAR)
3743*0Sstevel@tonic-gate RETPUSHUNDEF;
3744*0Sstevel@tonic-gate
3745*0Sstevel@tonic-gate RETURN;
3746*0Sstevel@tonic-gate }
3747*0Sstevel@tonic-gate
PP(pp_values)3748*0Sstevel@tonic-gate PP(pp_values)
3749*0Sstevel@tonic-gate {
3750*0Sstevel@tonic-gate return do_kv();
3751*0Sstevel@tonic-gate }
3752*0Sstevel@tonic-gate
PP(pp_keys)3753*0Sstevel@tonic-gate PP(pp_keys)
3754*0Sstevel@tonic-gate {
3755*0Sstevel@tonic-gate return do_kv();
3756*0Sstevel@tonic-gate }
3757*0Sstevel@tonic-gate
PP(pp_delete)3758*0Sstevel@tonic-gate PP(pp_delete)
3759*0Sstevel@tonic-gate {
3760*0Sstevel@tonic-gate dSP;
3761*0Sstevel@tonic-gate I32 gimme = GIMME_V;
3762*0Sstevel@tonic-gate I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3763*0Sstevel@tonic-gate SV *sv;
3764*0Sstevel@tonic-gate HV *hv;
3765*0Sstevel@tonic-gate
3766*0Sstevel@tonic-gate if (PL_op->op_private & OPpSLICE) {
3767*0Sstevel@tonic-gate dMARK; dORIGMARK;
3768*0Sstevel@tonic-gate U32 hvtype;
3769*0Sstevel@tonic-gate hv = (HV*)POPs;
3770*0Sstevel@tonic-gate hvtype = SvTYPE(hv);
3771*0Sstevel@tonic-gate if (hvtype == SVt_PVHV) { /* hash element */
3772*0Sstevel@tonic-gate while (++MARK <= SP) {
3773*0Sstevel@tonic-gate sv = hv_delete_ent(hv, *MARK, discard, 0);
3774*0Sstevel@tonic-gate *MARK = sv ? sv : &PL_sv_undef;
3775*0Sstevel@tonic-gate }
3776*0Sstevel@tonic-gate }
3777*0Sstevel@tonic-gate else if (hvtype == SVt_PVAV) {
3778*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3779*0Sstevel@tonic-gate while (++MARK <= SP) {
3780*0Sstevel@tonic-gate sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3781*0Sstevel@tonic-gate *MARK = sv ? sv : &PL_sv_undef;
3782*0Sstevel@tonic-gate }
3783*0Sstevel@tonic-gate }
3784*0Sstevel@tonic-gate else { /* pseudo-hash element */
3785*0Sstevel@tonic-gate while (++MARK <= SP) {
3786*0Sstevel@tonic-gate sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3787*0Sstevel@tonic-gate *MARK = sv ? sv : &PL_sv_undef;
3788*0Sstevel@tonic-gate }
3789*0Sstevel@tonic-gate }
3790*0Sstevel@tonic-gate }
3791*0Sstevel@tonic-gate else
3792*0Sstevel@tonic-gate DIE(aTHX_ "Not a HASH reference");
3793*0Sstevel@tonic-gate if (discard)
3794*0Sstevel@tonic-gate SP = ORIGMARK;
3795*0Sstevel@tonic-gate else if (gimme == G_SCALAR) {
3796*0Sstevel@tonic-gate MARK = ORIGMARK;
3797*0Sstevel@tonic-gate if (SP > MARK)
3798*0Sstevel@tonic-gate *++MARK = *SP;
3799*0Sstevel@tonic-gate else
3800*0Sstevel@tonic-gate *++MARK = &PL_sv_undef;
3801*0Sstevel@tonic-gate SP = MARK;
3802*0Sstevel@tonic-gate }
3803*0Sstevel@tonic-gate }
3804*0Sstevel@tonic-gate else {
3805*0Sstevel@tonic-gate SV *keysv = POPs;
3806*0Sstevel@tonic-gate hv = (HV*)POPs;
3807*0Sstevel@tonic-gate if (SvTYPE(hv) == SVt_PVHV)
3808*0Sstevel@tonic-gate sv = hv_delete_ent(hv, keysv, discard, 0);
3809*0Sstevel@tonic-gate else if (SvTYPE(hv) == SVt_PVAV) {
3810*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_SPECIAL)
3811*0Sstevel@tonic-gate sv = av_delete((AV*)hv, SvIV(keysv), discard);
3812*0Sstevel@tonic-gate else
3813*0Sstevel@tonic-gate sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3814*0Sstevel@tonic-gate }
3815*0Sstevel@tonic-gate else
3816*0Sstevel@tonic-gate DIE(aTHX_ "Not a HASH reference");
3817*0Sstevel@tonic-gate if (!sv)
3818*0Sstevel@tonic-gate sv = &PL_sv_undef;
3819*0Sstevel@tonic-gate if (!discard)
3820*0Sstevel@tonic-gate PUSHs(sv);
3821*0Sstevel@tonic-gate }
3822*0Sstevel@tonic-gate RETURN;
3823*0Sstevel@tonic-gate }
3824*0Sstevel@tonic-gate
PP(pp_exists)3825*0Sstevel@tonic-gate PP(pp_exists)
3826*0Sstevel@tonic-gate {
3827*0Sstevel@tonic-gate dSP;
3828*0Sstevel@tonic-gate SV *tmpsv;
3829*0Sstevel@tonic-gate HV *hv;
3830*0Sstevel@tonic-gate
3831*0Sstevel@tonic-gate if (PL_op->op_private & OPpEXISTS_SUB) {
3832*0Sstevel@tonic-gate GV *gv;
3833*0Sstevel@tonic-gate CV *cv;
3834*0Sstevel@tonic-gate SV *sv = POPs;
3835*0Sstevel@tonic-gate cv = sv_2cv(sv, &hv, &gv, FALSE);
3836*0Sstevel@tonic-gate if (cv)
3837*0Sstevel@tonic-gate RETPUSHYES;
3838*0Sstevel@tonic-gate if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3839*0Sstevel@tonic-gate RETPUSHYES;
3840*0Sstevel@tonic-gate RETPUSHNO;
3841*0Sstevel@tonic-gate }
3842*0Sstevel@tonic-gate tmpsv = POPs;
3843*0Sstevel@tonic-gate hv = (HV*)POPs;
3844*0Sstevel@tonic-gate if (SvTYPE(hv) == SVt_PVHV) {
3845*0Sstevel@tonic-gate if (hv_exists_ent(hv, tmpsv, 0))
3846*0Sstevel@tonic-gate RETPUSHYES;
3847*0Sstevel@tonic-gate }
3848*0Sstevel@tonic-gate else if (SvTYPE(hv) == SVt_PVAV) {
3849*0Sstevel@tonic-gate if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3850*0Sstevel@tonic-gate if (av_exists((AV*)hv, SvIV(tmpsv)))
3851*0Sstevel@tonic-gate RETPUSHYES;
3852*0Sstevel@tonic-gate }
3853*0Sstevel@tonic-gate else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3854*0Sstevel@tonic-gate RETPUSHYES;
3855*0Sstevel@tonic-gate }
3856*0Sstevel@tonic-gate else {
3857*0Sstevel@tonic-gate DIE(aTHX_ "Not a HASH reference");
3858*0Sstevel@tonic-gate }
3859*0Sstevel@tonic-gate RETPUSHNO;
3860*0Sstevel@tonic-gate }
3861*0Sstevel@tonic-gate
PP(pp_hslice)3862*0Sstevel@tonic-gate PP(pp_hslice)
3863*0Sstevel@tonic-gate {
3864*0Sstevel@tonic-gate dSP; dMARK; dORIGMARK;
3865*0Sstevel@tonic-gate register HV *hv = (HV*)POPs;
3866*0Sstevel@tonic-gate register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3867*0Sstevel@tonic-gate I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3868*0Sstevel@tonic-gate bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3869*0Sstevel@tonic-gate bool other_magic = FALSE;
3870*0Sstevel@tonic-gate
3871*0Sstevel@tonic-gate if (localizing) {
3872*0Sstevel@tonic-gate MAGIC *mg;
3873*0Sstevel@tonic-gate HV *stash;
3874*0Sstevel@tonic-gate
3875*0Sstevel@tonic-gate other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3876*0Sstevel@tonic-gate ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3877*0Sstevel@tonic-gate /* Try to preserve the existenceness of a tied hash
3878*0Sstevel@tonic-gate * element by using EXISTS and DELETE if possible.
3879*0Sstevel@tonic-gate * Fallback to FETCH and STORE otherwise */
3880*0Sstevel@tonic-gate && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3881*0Sstevel@tonic-gate && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3882*0Sstevel@tonic-gate && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3883*0Sstevel@tonic-gate }
3884*0Sstevel@tonic-gate
3885*0Sstevel@tonic-gate if (!realhv && localizing)
3886*0Sstevel@tonic-gate DIE(aTHX_ "Can't localize pseudo-hash element");
3887*0Sstevel@tonic-gate
3888*0Sstevel@tonic-gate if (realhv || SvTYPE(hv) == SVt_PVAV) {
3889*0Sstevel@tonic-gate while (++MARK <= SP) {
3890*0Sstevel@tonic-gate SV *keysv = *MARK;
3891*0Sstevel@tonic-gate SV **svp;
3892*0Sstevel@tonic-gate bool preeminent = FALSE;
3893*0Sstevel@tonic-gate
3894*0Sstevel@tonic-gate if (localizing) {
3895*0Sstevel@tonic-gate preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3896*0Sstevel@tonic-gate realhv ? hv_exists_ent(hv, keysv, 0)
3897*0Sstevel@tonic-gate : avhv_exists_ent((AV*)hv, keysv, 0);
3898*0Sstevel@tonic-gate }
3899*0Sstevel@tonic-gate
3900*0Sstevel@tonic-gate if (realhv) {
3901*0Sstevel@tonic-gate HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3902*0Sstevel@tonic-gate svp = he ? &HeVAL(he) : 0;
3903*0Sstevel@tonic-gate }
3904*0Sstevel@tonic-gate else {
3905*0Sstevel@tonic-gate svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3906*0Sstevel@tonic-gate }
3907*0Sstevel@tonic-gate if (lval) {
3908*0Sstevel@tonic-gate if (!svp || *svp == &PL_sv_undef) {
3909*0Sstevel@tonic-gate STRLEN n_a;
3910*0Sstevel@tonic-gate DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3911*0Sstevel@tonic-gate }
3912*0Sstevel@tonic-gate if (localizing) {
3913*0Sstevel@tonic-gate if (preeminent)
3914*0Sstevel@tonic-gate save_helem(hv, keysv, svp);
3915*0Sstevel@tonic-gate else {
3916*0Sstevel@tonic-gate STRLEN keylen;
3917*0Sstevel@tonic-gate char *key = SvPV(keysv, keylen);
3918*0Sstevel@tonic-gate SAVEDELETE(hv, savepvn(key,keylen), keylen);
3919*0Sstevel@tonic-gate }
3920*0Sstevel@tonic-gate }
3921*0Sstevel@tonic-gate }
3922*0Sstevel@tonic-gate *MARK = svp ? *svp : &PL_sv_undef;
3923*0Sstevel@tonic-gate }
3924*0Sstevel@tonic-gate }
3925*0Sstevel@tonic-gate if (GIMME != G_ARRAY) {
3926*0Sstevel@tonic-gate MARK = ORIGMARK;
3927*0Sstevel@tonic-gate *++MARK = *SP;
3928*0Sstevel@tonic-gate SP = MARK;
3929*0Sstevel@tonic-gate }
3930*0Sstevel@tonic-gate RETURN;
3931*0Sstevel@tonic-gate }
3932*0Sstevel@tonic-gate
3933*0Sstevel@tonic-gate /* List operators. */
3934*0Sstevel@tonic-gate
PP(pp_list)3935*0Sstevel@tonic-gate PP(pp_list)
3936*0Sstevel@tonic-gate {
3937*0Sstevel@tonic-gate dSP; dMARK;
3938*0Sstevel@tonic-gate if (GIMME != G_ARRAY) {
3939*0Sstevel@tonic-gate if (++MARK <= SP)
3940*0Sstevel@tonic-gate *MARK = *SP; /* unwanted list, return last item */
3941*0Sstevel@tonic-gate else
3942*0Sstevel@tonic-gate *MARK = &PL_sv_undef;
3943*0Sstevel@tonic-gate SP = MARK;
3944*0Sstevel@tonic-gate }
3945*0Sstevel@tonic-gate RETURN;
3946*0Sstevel@tonic-gate }
3947*0Sstevel@tonic-gate
PP(pp_lslice)3948*0Sstevel@tonic-gate PP(pp_lslice)
3949*0Sstevel@tonic-gate {
3950*0Sstevel@tonic-gate dSP;
3951*0Sstevel@tonic-gate SV **lastrelem = PL_stack_sp;
3952*0Sstevel@tonic-gate SV **lastlelem = PL_stack_base + POPMARK;
3953*0Sstevel@tonic-gate SV **firstlelem = PL_stack_base + POPMARK + 1;
3954*0Sstevel@tonic-gate register SV **firstrelem = lastlelem + 1;
3955*0Sstevel@tonic-gate I32 arybase = PL_curcop->cop_arybase;
3956*0Sstevel@tonic-gate I32 lval = PL_op->op_flags & OPf_MOD;
3957*0Sstevel@tonic-gate I32 is_something_there = lval;
3958*0Sstevel@tonic-gate
3959*0Sstevel@tonic-gate register I32 max = lastrelem - lastlelem;
3960*0Sstevel@tonic-gate register SV **lelem;
3961*0Sstevel@tonic-gate register I32 ix;
3962*0Sstevel@tonic-gate
3963*0Sstevel@tonic-gate if (GIMME != G_ARRAY) {
3964*0Sstevel@tonic-gate ix = SvIVx(*lastlelem);
3965*0Sstevel@tonic-gate if (ix < 0)
3966*0Sstevel@tonic-gate ix += max;
3967*0Sstevel@tonic-gate else
3968*0Sstevel@tonic-gate ix -= arybase;
3969*0Sstevel@tonic-gate if (ix < 0 || ix >= max)
3970*0Sstevel@tonic-gate *firstlelem = &PL_sv_undef;
3971*0Sstevel@tonic-gate else
3972*0Sstevel@tonic-gate *firstlelem = firstrelem[ix];
3973*0Sstevel@tonic-gate SP = firstlelem;
3974*0Sstevel@tonic-gate RETURN;
3975*0Sstevel@tonic-gate }
3976*0Sstevel@tonic-gate
3977*0Sstevel@tonic-gate if (max == 0) {
3978*0Sstevel@tonic-gate SP = firstlelem - 1;
3979*0Sstevel@tonic-gate RETURN;
3980*0Sstevel@tonic-gate }
3981*0Sstevel@tonic-gate
3982*0Sstevel@tonic-gate for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3983*0Sstevel@tonic-gate ix = SvIVx(*lelem);
3984*0Sstevel@tonic-gate if (ix < 0)
3985*0Sstevel@tonic-gate ix += max;
3986*0Sstevel@tonic-gate else
3987*0Sstevel@tonic-gate ix -= arybase;
3988*0Sstevel@tonic-gate if (ix < 0 || ix >= max)
3989*0Sstevel@tonic-gate *lelem = &PL_sv_undef;
3990*0Sstevel@tonic-gate else {
3991*0Sstevel@tonic-gate is_something_there = TRUE;
3992*0Sstevel@tonic-gate if (!(*lelem = firstrelem[ix]))
3993*0Sstevel@tonic-gate *lelem = &PL_sv_undef;
3994*0Sstevel@tonic-gate }
3995*0Sstevel@tonic-gate }
3996*0Sstevel@tonic-gate if (is_something_there)
3997*0Sstevel@tonic-gate SP = lastlelem;
3998*0Sstevel@tonic-gate else
3999*0Sstevel@tonic-gate SP = firstlelem - 1;
4000*0Sstevel@tonic-gate RETURN;
4001*0Sstevel@tonic-gate }
4002*0Sstevel@tonic-gate
PP(pp_anonlist)4003*0Sstevel@tonic-gate PP(pp_anonlist)
4004*0Sstevel@tonic-gate {
4005*0Sstevel@tonic-gate dSP; dMARK; dORIGMARK;
4006*0Sstevel@tonic-gate I32 items = SP - MARK;
4007*0Sstevel@tonic-gate SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4008*0Sstevel@tonic-gate SP = ORIGMARK; /* av_make() might realloc stack_sp */
4009*0Sstevel@tonic-gate XPUSHs(av);
4010*0Sstevel@tonic-gate RETURN;
4011*0Sstevel@tonic-gate }
4012*0Sstevel@tonic-gate
PP(pp_anonhash)4013*0Sstevel@tonic-gate PP(pp_anonhash)
4014*0Sstevel@tonic-gate {
4015*0Sstevel@tonic-gate dSP; dMARK; dORIGMARK;
4016*0Sstevel@tonic-gate HV* hv = (HV*)sv_2mortal((SV*)newHV());
4017*0Sstevel@tonic-gate
4018*0Sstevel@tonic-gate while (MARK < SP) {
4019*0Sstevel@tonic-gate SV* key = *++MARK;
4020*0Sstevel@tonic-gate SV *val = NEWSV(46, 0);
4021*0Sstevel@tonic-gate if (MARK < SP)
4022*0Sstevel@tonic-gate sv_setsv(val, *++MARK);
4023*0Sstevel@tonic-gate else if (ckWARN(WARN_MISC))
4024*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4025*0Sstevel@tonic-gate (void)hv_store_ent(hv,key,val,0);
4026*0Sstevel@tonic-gate }
4027*0Sstevel@tonic-gate SP = ORIGMARK;
4028*0Sstevel@tonic-gate XPUSHs((SV*)hv);
4029*0Sstevel@tonic-gate RETURN;
4030*0Sstevel@tonic-gate }
4031*0Sstevel@tonic-gate
PP(pp_splice)4032*0Sstevel@tonic-gate PP(pp_splice)
4033*0Sstevel@tonic-gate {
4034*0Sstevel@tonic-gate dSP; dMARK; dORIGMARK;
4035*0Sstevel@tonic-gate register AV *ary = (AV*)*++MARK;
4036*0Sstevel@tonic-gate register SV **src;
4037*0Sstevel@tonic-gate register SV **dst;
4038*0Sstevel@tonic-gate register I32 i;
4039*0Sstevel@tonic-gate register I32 offset;
4040*0Sstevel@tonic-gate register I32 length;
4041*0Sstevel@tonic-gate I32 newlen;
4042*0Sstevel@tonic-gate I32 after;
4043*0Sstevel@tonic-gate I32 diff;
4044*0Sstevel@tonic-gate SV **tmparyval = 0;
4045*0Sstevel@tonic-gate MAGIC *mg;
4046*0Sstevel@tonic-gate
4047*0Sstevel@tonic-gate if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4048*0Sstevel@tonic-gate *MARK-- = SvTIED_obj((SV*)ary, mg);
4049*0Sstevel@tonic-gate PUSHMARK(MARK);
4050*0Sstevel@tonic-gate PUTBACK;
4051*0Sstevel@tonic-gate ENTER;
4052*0Sstevel@tonic-gate call_method("SPLICE",GIMME_V);
4053*0Sstevel@tonic-gate LEAVE;
4054*0Sstevel@tonic-gate SPAGAIN;
4055*0Sstevel@tonic-gate RETURN;
4056*0Sstevel@tonic-gate }
4057*0Sstevel@tonic-gate
4058*0Sstevel@tonic-gate SP++;
4059*0Sstevel@tonic-gate
4060*0Sstevel@tonic-gate if (++MARK < SP) {
4061*0Sstevel@tonic-gate offset = i = SvIVx(*MARK);
4062*0Sstevel@tonic-gate if (offset < 0)
4063*0Sstevel@tonic-gate offset += AvFILLp(ary) + 1;
4064*0Sstevel@tonic-gate else
4065*0Sstevel@tonic-gate offset -= PL_curcop->cop_arybase;
4066*0Sstevel@tonic-gate if (offset < 0)
4067*0Sstevel@tonic-gate DIE(aTHX_ PL_no_aelem, i);
4068*0Sstevel@tonic-gate if (++MARK < SP) {
4069*0Sstevel@tonic-gate length = SvIVx(*MARK++);
4070*0Sstevel@tonic-gate if (length < 0) {
4071*0Sstevel@tonic-gate length += AvFILLp(ary) - offset + 1;
4072*0Sstevel@tonic-gate if (length < 0)
4073*0Sstevel@tonic-gate length = 0;
4074*0Sstevel@tonic-gate }
4075*0Sstevel@tonic-gate }
4076*0Sstevel@tonic-gate else
4077*0Sstevel@tonic-gate length = AvMAX(ary) + 1; /* close enough to infinity */
4078*0Sstevel@tonic-gate }
4079*0Sstevel@tonic-gate else {
4080*0Sstevel@tonic-gate offset = 0;
4081*0Sstevel@tonic-gate length = AvMAX(ary) + 1;
4082*0Sstevel@tonic-gate }
4083*0Sstevel@tonic-gate if (offset > AvFILLp(ary) + 1) {
4084*0Sstevel@tonic-gate if (ckWARN(WARN_MISC))
4085*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4086*0Sstevel@tonic-gate offset = AvFILLp(ary) + 1;
4087*0Sstevel@tonic-gate }
4088*0Sstevel@tonic-gate after = AvFILLp(ary) + 1 - (offset + length);
4089*0Sstevel@tonic-gate if (after < 0) { /* not that much array */
4090*0Sstevel@tonic-gate length += after; /* offset+length now in array */
4091*0Sstevel@tonic-gate after = 0;
4092*0Sstevel@tonic-gate if (!AvALLOC(ary))
4093*0Sstevel@tonic-gate av_extend(ary, 0);
4094*0Sstevel@tonic-gate }
4095*0Sstevel@tonic-gate
4096*0Sstevel@tonic-gate /* At this point, MARK .. SP-1 is our new LIST */
4097*0Sstevel@tonic-gate
4098*0Sstevel@tonic-gate newlen = SP - MARK;
4099*0Sstevel@tonic-gate diff = newlen - length;
4100*0Sstevel@tonic-gate if (newlen && !AvREAL(ary) && AvREIFY(ary))
4101*0Sstevel@tonic-gate av_reify(ary);
4102*0Sstevel@tonic-gate
4103*0Sstevel@tonic-gate if (diff < 0) { /* shrinking the area */
4104*0Sstevel@tonic-gate if (newlen) {
4105*0Sstevel@tonic-gate New(451, tmparyval, newlen, SV*); /* so remember insertion */
4106*0Sstevel@tonic-gate Copy(MARK, tmparyval, newlen, SV*);
4107*0Sstevel@tonic-gate }
4108*0Sstevel@tonic-gate
4109*0Sstevel@tonic-gate MARK = ORIGMARK + 1;
4110*0Sstevel@tonic-gate if (GIMME == G_ARRAY) { /* copy return vals to stack */
4111*0Sstevel@tonic-gate MEXTEND(MARK, length);
4112*0Sstevel@tonic-gate Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4113*0Sstevel@tonic-gate if (AvREAL(ary)) {
4114*0Sstevel@tonic-gate EXTEND_MORTAL(length);
4115*0Sstevel@tonic-gate for (i = length, dst = MARK; i; i--) {
4116*0Sstevel@tonic-gate sv_2mortal(*dst); /* free them eventualy */
4117*0Sstevel@tonic-gate dst++;
4118*0Sstevel@tonic-gate }
4119*0Sstevel@tonic-gate }
4120*0Sstevel@tonic-gate MARK += length - 1;
4121*0Sstevel@tonic-gate }
4122*0Sstevel@tonic-gate else {
4123*0Sstevel@tonic-gate *MARK = AvARRAY(ary)[offset+length-1];
4124*0Sstevel@tonic-gate if (AvREAL(ary)) {
4125*0Sstevel@tonic-gate sv_2mortal(*MARK);
4126*0Sstevel@tonic-gate for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4127*0Sstevel@tonic-gate SvREFCNT_dec(*dst++); /* free them now */
4128*0Sstevel@tonic-gate }
4129*0Sstevel@tonic-gate }
4130*0Sstevel@tonic-gate AvFILLp(ary) += diff;
4131*0Sstevel@tonic-gate
4132*0Sstevel@tonic-gate /* pull up or down? */
4133*0Sstevel@tonic-gate
4134*0Sstevel@tonic-gate if (offset < after) { /* easier to pull up */
4135*0Sstevel@tonic-gate if (offset) { /* esp. if nothing to pull */
4136*0Sstevel@tonic-gate src = &AvARRAY(ary)[offset-1];
4137*0Sstevel@tonic-gate dst = src - diff; /* diff is negative */
4138*0Sstevel@tonic-gate for (i = offset; i > 0; i--) /* can't trust Copy */
4139*0Sstevel@tonic-gate *dst-- = *src--;
4140*0Sstevel@tonic-gate }
4141*0Sstevel@tonic-gate dst = AvARRAY(ary);
4142*0Sstevel@tonic-gate SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4143*0Sstevel@tonic-gate AvMAX(ary) += diff;
4144*0Sstevel@tonic-gate }
4145*0Sstevel@tonic-gate else {
4146*0Sstevel@tonic-gate if (after) { /* anything to pull down? */
4147*0Sstevel@tonic-gate src = AvARRAY(ary) + offset + length;
4148*0Sstevel@tonic-gate dst = src + diff; /* diff is negative */
4149*0Sstevel@tonic-gate Move(src, dst, after, SV*);
4150*0Sstevel@tonic-gate }
4151*0Sstevel@tonic-gate dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4152*0Sstevel@tonic-gate /* avoid later double free */
4153*0Sstevel@tonic-gate }
4154*0Sstevel@tonic-gate i = -diff;
4155*0Sstevel@tonic-gate while (i)
4156*0Sstevel@tonic-gate dst[--i] = &PL_sv_undef;
4157*0Sstevel@tonic-gate
4158*0Sstevel@tonic-gate if (newlen) {
4159*0Sstevel@tonic-gate for (src = tmparyval, dst = AvARRAY(ary) + offset;
4160*0Sstevel@tonic-gate newlen; newlen--) {
4161*0Sstevel@tonic-gate *dst = NEWSV(46, 0);
4162*0Sstevel@tonic-gate sv_setsv(*dst++, *src++);
4163*0Sstevel@tonic-gate }
4164*0Sstevel@tonic-gate Safefree(tmparyval);
4165*0Sstevel@tonic-gate }
4166*0Sstevel@tonic-gate }
4167*0Sstevel@tonic-gate else { /* no, expanding (or same) */
4168*0Sstevel@tonic-gate if (length) {
4169*0Sstevel@tonic-gate New(452, tmparyval, length, SV*); /* so remember deletion */
4170*0Sstevel@tonic-gate Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4171*0Sstevel@tonic-gate }
4172*0Sstevel@tonic-gate
4173*0Sstevel@tonic-gate if (diff > 0) { /* expanding */
4174*0Sstevel@tonic-gate
4175*0Sstevel@tonic-gate /* push up or down? */
4176*0Sstevel@tonic-gate
4177*0Sstevel@tonic-gate if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4178*0Sstevel@tonic-gate if (offset) {
4179*0Sstevel@tonic-gate src = AvARRAY(ary);
4180*0Sstevel@tonic-gate dst = src - diff;
4181*0Sstevel@tonic-gate Move(src, dst, offset, SV*);
4182*0Sstevel@tonic-gate }
4183*0Sstevel@tonic-gate SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4184*0Sstevel@tonic-gate AvMAX(ary) += diff;
4185*0Sstevel@tonic-gate AvFILLp(ary) += diff;
4186*0Sstevel@tonic-gate }
4187*0Sstevel@tonic-gate else {
4188*0Sstevel@tonic-gate if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4189*0Sstevel@tonic-gate av_extend(ary, AvFILLp(ary) + diff);
4190*0Sstevel@tonic-gate AvFILLp(ary) += diff;
4191*0Sstevel@tonic-gate
4192*0Sstevel@tonic-gate if (after) {
4193*0Sstevel@tonic-gate dst = AvARRAY(ary) + AvFILLp(ary);
4194*0Sstevel@tonic-gate src = dst - diff;
4195*0Sstevel@tonic-gate for (i = after; i; i--) {
4196*0Sstevel@tonic-gate *dst-- = *src--;
4197*0Sstevel@tonic-gate }
4198*0Sstevel@tonic-gate }
4199*0Sstevel@tonic-gate }
4200*0Sstevel@tonic-gate }
4201*0Sstevel@tonic-gate
4202*0Sstevel@tonic-gate for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4203*0Sstevel@tonic-gate *dst = NEWSV(46, 0);
4204*0Sstevel@tonic-gate sv_setsv(*dst++, *src++);
4205*0Sstevel@tonic-gate }
4206*0Sstevel@tonic-gate MARK = ORIGMARK + 1;
4207*0Sstevel@tonic-gate if (GIMME == G_ARRAY) { /* copy return vals to stack */
4208*0Sstevel@tonic-gate if (length) {
4209*0Sstevel@tonic-gate Copy(tmparyval, MARK, length, SV*);
4210*0Sstevel@tonic-gate if (AvREAL(ary)) {
4211*0Sstevel@tonic-gate EXTEND_MORTAL(length);
4212*0Sstevel@tonic-gate for (i = length, dst = MARK; i; i--) {
4213*0Sstevel@tonic-gate sv_2mortal(*dst); /* free them eventualy */
4214*0Sstevel@tonic-gate dst++;
4215*0Sstevel@tonic-gate }
4216*0Sstevel@tonic-gate }
4217*0Sstevel@tonic-gate Safefree(tmparyval);
4218*0Sstevel@tonic-gate }
4219*0Sstevel@tonic-gate MARK += length - 1;
4220*0Sstevel@tonic-gate }
4221*0Sstevel@tonic-gate else if (length--) {
4222*0Sstevel@tonic-gate *MARK = tmparyval[length];
4223*0Sstevel@tonic-gate if (AvREAL(ary)) {
4224*0Sstevel@tonic-gate sv_2mortal(*MARK);
4225*0Sstevel@tonic-gate while (length-- > 0)
4226*0Sstevel@tonic-gate SvREFCNT_dec(tmparyval[length]);
4227*0Sstevel@tonic-gate }
4228*0Sstevel@tonic-gate Safefree(tmparyval);
4229*0Sstevel@tonic-gate }
4230*0Sstevel@tonic-gate else
4231*0Sstevel@tonic-gate *MARK = &PL_sv_undef;
4232*0Sstevel@tonic-gate }
4233*0Sstevel@tonic-gate SP = MARK;
4234*0Sstevel@tonic-gate RETURN;
4235*0Sstevel@tonic-gate }
4236*0Sstevel@tonic-gate
PP(pp_push)4237*0Sstevel@tonic-gate PP(pp_push)
4238*0Sstevel@tonic-gate {
4239*0Sstevel@tonic-gate dSP; dMARK; dORIGMARK; dTARGET;
4240*0Sstevel@tonic-gate register AV *ary = (AV*)*++MARK;
4241*0Sstevel@tonic-gate register SV *sv = &PL_sv_undef;
4242*0Sstevel@tonic-gate MAGIC *mg;
4243*0Sstevel@tonic-gate
4244*0Sstevel@tonic-gate if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4245*0Sstevel@tonic-gate *MARK-- = SvTIED_obj((SV*)ary, mg);
4246*0Sstevel@tonic-gate PUSHMARK(MARK);
4247*0Sstevel@tonic-gate PUTBACK;
4248*0Sstevel@tonic-gate ENTER;
4249*0Sstevel@tonic-gate call_method("PUSH",G_SCALAR|G_DISCARD);
4250*0Sstevel@tonic-gate LEAVE;
4251*0Sstevel@tonic-gate SPAGAIN;
4252*0Sstevel@tonic-gate }
4253*0Sstevel@tonic-gate else {
4254*0Sstevel@tonic-gate /* Why no pre-extend of ary here ? */
4255*0Sstevel@tonic-gate for (++MARK; MARK <= SP; MARK++) {
4256*0Sstevel@tonic-gate sv = NEWSV(51, 0);
4257*0Sstevel@tonic-gate if (*MARK)
4258*0Sstevel@tonic-gate sv_setsv(sv, *MARK);
4259*0Sstevel@tonic-gate av_push(ary, sv);
4260*0Sstevel@tonic-gate }
4261*0Sstevel@tonic-gate }
4262*0Sstevel@tonic-gate SP = ORIGMARK;
4263*0Sstevel@tonic-gate PUSHi( AvFILL(ary) + 1 );
4264*0Sstevel@tonic-gate RETURN;
4265*0Sstevel@tonic-gate }
4266*0Sstevel@tonic-gate
PP(pp_pop)4267*0Sstevel@tonic-gate PP(pp_pop)
4268*0Sstevel@tonic-gate {
4269*0Sstevel@tonic-gate dSP;
4270*0Sstevel@tonic-gate AV *av = (AV*)POPs;
4271*0Sstevel@tonic-gate SV *sv = av_pop(av);
4272*0Sstevel@tonic-gate if (AvREAL(av))
4273*0Sstevel@tonic-gate (void)sv_2mortal(sv);
4274*0Sstevel@tonic-gate PUSHs(sv);
4275*0Sstevel@tonic-gate RETURN;
4276*0Sstevel@tonic-gate }
4277*0Sstevel@tonic-gate
PP(pp_shift)4278*0Sstevel@tonic-gate PP(pp_shift)
4279*0Sstevel@tonic-gate {
4280*0Sstevel@tonic-gate dSP;
4281*0Sstevel@tonic-gate AV *av = (AV*)POPs;
4282*0Sstevel@tonic-gate SV *sv = av_shift(av);
4283*0Sstevel@tonic-gate EXTEND(SP, 1);
4284*0Sstevel@tonic-gate if (!sv)
4285*0Sstevel@tonic-gate RETPUSHUNDEF;
4286*0Sstevel@tonic-gate if (AvREAL(av))
4287*0Sstevel@tonic-gate (void)sv_2mortal(sv);
4288*0Sstevel@tonic-gate PUSHs(sv);
4289*0Sstevel@tonic-gate RETURN;
4290*0Sstevel@tonic-gate }
4291*0Sstevel@tonic-gate
PP(pp_unshift)4292*0Sstevel@tonic-gate PP(pp_unshift)
4293*0Sstevel@tonic-gate {
4294*0Sstevel@tonic-gate dSP; dMARK; dORIGMARK; dTARGET;
4295*0Sstevel@tonic-gate register AV *ary = (AV*)*++MARK;
4296*0Sstevel@tonic-gate register SV *sv;
4297*0Sstevel@tonic-gate register I32 i = 0;
4298*0Sstevel@tonic-gate MAGIC *mg;
4299*0Sstevel@tonic-gate
4300*0Sstevel@tonic-gate if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4301*0Sstevel@tonic-gate *MARK-- = SvTIED_obj((SV*)ary, mg);
4302*0Sstevel@tonic-gate PUSHMARK(MARK);
4303*0Sstevel@tonic-gate PUTBACK;
4304*0Sstevel@tonic-gate ENTER;
4305*0Sstevel@tonic-gate call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4306*0Sstevel@tonic-gate LEAVE;
4307*0Sstevel@tonic-gate SPAGAIN;
4308*0Sstevel@tonic-gate }
4309*0Sstevel@tonic-gate else {
4310*0Sstevel@tonic-gate av_unshift(ary, SP - MARK);
4311*0Sstevel@tonic-gate while (MARK < SP) {
4312*0Sstevel@tonic-gate sv = NEWSV(27, 0);
4313*0Sstevel@tonic-gate sv_setsv(sv, *++MARK);
4314*0Sstevel@tonic-gate (void)av_store(ary, i++, sv);
4315*0Sstevel@tonic-gate }
4316*0Sstevel@tonic-gate }
4317*0Sstevel@tonic-gate SP = ORIGMARK;
4318*0Sstevel@tonic-gate PUSHi( AvFILL(ary) + 1 );
4319*0Sstevel@tonic-gate RETURN;
4320*0Sstevel@tonic-gate }
4321*0Sstevel@tonic-gate
PP(pp_reverse)4322*0Sstevel@tonic-gate PP(pp_reverse)
4323*0Sstevel@tonic-gate {
4324*0Sstevel@tonic-gate dSP; dMARK;
4325*0Sstevel@tonic-gate register SV *tmp;
4326*0Sstevel@tonic-gate SV **oldsp = SP;
4327*0Sstevel@tonic-gate
4328*0Sstevel@tonic-gate if (GIMME == G_ARRAY) {
4329*0Sstevel@tonic-gate MARK++;
4330*0Sstevel@tonic-gate while (MARK < SP) {
4331*0Sstevel@tonic-gate tmp = *MARK;
4332*0Sstevel@tonic-gate *MARK++ = *SP;
4333*0Sstevel@tonic-gate *SP-- = tmp;
4334*0Sstevel@tonic-gate }
4335*0Sstevel@tonic-gate /* safe as long as stack cannot get extended in the above */
4336*0Sstevel@tonic-gate SP = oldsp;
4337*0Sstevel@tonic-gate }
4338*0Sstevel@tonic-gate else {
4339*0Sstevel@tonic-gate register char *up;
4340*0Sstevel@tonic-gate register char *down;
4341*0Sstevel@tonic-gate register I32 tmp;
4342*0Sstevel@tonic-gate dTARGET;
4343*0Sstevel@tonic-gate STRLEN len;
4344*0Sstevel@tonic-gate
4345*0Sstevel@tonic-gate SvUTF8_off(TARG); /* decontaminate */
4346*0Sstevel@tonic-gate if (SP - MARK > 1)
4347*0Sstevel@tonic-gate do_join(TARG, &PL_sv_no, MARK, SP);
4348*0Sstevel@tonic-gate else
4349*0Sstevel@tonic-gate sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4350*0Sstevel@tonic-gate up = SvPV_force(TARG, len);
4351*0Sstevel@tonic-gate if (len > 1) {
4352*0Sstevel@tonic-gate if (DO_UTF8(TARG)) { /* first reverse each character */
4353*0Sstevel@tonic-gate U8* s = (U8*)SvPVX(TARG);
4354*0Sstevel@tonic-gate U8* send = (U8*)(s + len);
4355*0Sstevel@tonic-gate while (s < send) {
4356*0Sstevel@tonic-gate if (UTF8_IS_INVARIANT(*s)) {
4357*0Sstevel@tonic-gate s++;
4358*0Sstevel@tonic-gate continue;
4359*0Sstevel@tonic-gate }
4360*0Sstevel@tonic-gate else {
4361*0Sstevel@tonic-gate if (!utf8_to_uvchr(s, 0))
4362*0Sstevel@tonic-gate break;
4363*0Sstevel@tonic-gate up = (char*)s;
4364*0Sstevel@tonic-gate s += UTF8SKIP(s);
4365*0Sstevel@tonic-gate down = (char*)(s - 1);
4366*0Sstevel@tonic-gate /* reverse this character */
4367*0Sstevel@tonic-gate while (down > up) {
4368*0Sstevel@tonic-gate tmp = *up;
4369*0Sstevel@tonic-gate *up++ = *down;
4370*0Sstevel@tonic-gate *down-- = (char)tmp;
4371*0Sstevel@tonic-gate }
4372*0Sstevel@tonic-gate }
4373*0Sstevel@tonic-gate }
4374*0Sstevel@tonic-gate up = SvPVX(TARG);
4375*0Sstevel@tonic-gate }
4376*0Sstevel@tonic-gate down = SvPVX(TARG) + len - 1;
4377*0Sstevel@tonic-gate while (down > up) {
4378*0Sstevel@tonic-gate tmp = *up;
4379*0Sstevel@tonic-gate *up++ = *down;
4380*0Sstevel@tonic-gate *down-- = (char)tmp;
4381*0Sstevel@tonic-gate }
4382*0Sstevel@tonic-gate (void)SvPOK_only_UTF8(TARG);
4383*0Sstevel@tonic-gate }
4384*0Sstevel@tonic-gate SP = MARK + 1;
4385*0Sstevel@tonic-gate SETTARG;
4386*0Sstevel@tonic-gate }
4387*0Sstevel@tonic-gate RETURN;
4388*0Sstevel@tonic-gate }
4389*0Sstevel@tonic-gate
PP(pp_split)4390*0Sstevel@tonic-gate PP(pp_split)
4391*0Sstevel@tonic-gate {
4392*0Sstevel@tonic-gate dSP; dTARG;
4393*0Sstevel@tonic-gate AV *ary;
4394*0Sstevel@tonic-gate register IV limit = POPi; /* note, negative is forever */
4395*0Sstevel@tonic-gate SV *sv = POPs;
4396*0Sstevel@tonic-gate STRLEN len;
4397*0Sstevel@tonic-gate register char *s = SvPV(sv, len);
4398*0Sstevel@tonic-gate bool do_utf8 = DO_UTF8(sv);
4399*0Sstevel@tonic-gate char *strend = s + len;
4400*0Sstevel@tonic-gate register PMOP *pm;
4401*0Sstevel@tonic-gate register REGEXP *rx;
4402*0Sstevel@tonic-gate register SV *dstr;
4403*0Sstevel@tonic-gate register char *m;
4404*0Sstevel@tonic-gate I32 iters = 0;
4405*0Sstevel@tonic-gate STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4406*0Sstevel@tonic-gate I32 maxiters = slen + 10;
4407*0Sstevel@tonic-gate I32 i;
4408*0Sstevel@tonic-gate char *orig;
4409*0Sstevel@tonic-gate I32 origlimit = limit;
4410*0Sstevel@tonic-gate I32 realarray = 0;
4411*0Sstevel@tonic-gate I32 base;
4412*0Sstevel@tonic-gate AV *oldstack = PL_curstack;
4413*0Sstevel@tonic-gate I32 gimme = GIMME_V;
4414*0Sstevel@tonic-gate I32 oldsave = PL_savestack_ix;
4415*0Sstevel@tonic-gate I32 make_mortal = 1;
4416*0Sstevel@tonic-gate MAGIC *mg = (MAGIC *) NULL;
4417*0Sstevel@tonic-gate
4418*0Sstevel@tonic-gate #ifdef DEBUGGING
4419*0Sstevel@tonic-gate Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4420*0Sstevel@tonic-gate #else
4421*0Sstevel@tonic-gate pm = (PMOP*)POPs;
4422*0Sstevel@tonic-gate #endif
4423*0Sstevel@tonic-gate if (!pm || !s)
4424*0Sstevel@tonic-gate DIE(aTHX_ "panic: pp_split");
4425*0Sstevel@tonic-gate rx = PM_GETRE(pm);
4426*0Sstevel@tonic-gate
4427*0Sstevel@tonic-gate TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4428*0Sstevel@tonic-gate (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4429*0Sstevel@tonic-gate
4430*0Sstevel@tonic-gate RX_MATCH_UTF8_set(rx, do_utf8);
4431*0Sstevel@tonic-gate
4432*0Sstevel@tonic-gate if (pm->op_pmreplroot) {
4433*0Sstevel@tonic-gate #ifdef USE_ITHREADS
4434*0Sstevel@tonic-gate ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4435*0Sstevel@tonic-gate #else
4436*0Sstevel@tonic-gate ary = GvAVn((GV*)pm->op_pmreplroot);
4437*0Sstevel@tonic-gate #endif
4438*0Sstevel@tonic-gate }
4439*0Sstevel@tonic-gate else if (gimme != G_ARRAY)
4440*0Sstevel@tonic-gate #ifdef USE_5005THREADS
4441*0Sstevel@tonic-gate ary = (AV*)PAD_SVl(0);
4442*0Sstevel@tonic-gate #else
4443*0Sstevel@tonic-gate ary = GvAVn(PL_defgv);
4444*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
4445*0Sstevel@tonic-gate else
4446*0Sstevel@tonic-gate ary = Nullav;
4447*0Sstevel@tonic-gate if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4448*0Sstevel@tonic-gate realarray = 1;
4449*0Sstevel@tonic-gate PUTBACK;
4450*0Sstevel@tonic-gate av_extend(ary,0);
4451*0Sstevel@tonic-gate av_clear(ary);
4452*0Sstevel@tonic-gate SPAGAIN;
4453*0Sstevel@tonic-gate if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4454*0Sstevel@tonic-gate PUSHMARK(SP);
4455*0Sstevel@tonic-gate XPUSHs(SvTIED_obj((SV*)ary, mg));
4456*0Sstevel@tonic-gate }
4457*0Sstevel@tonic-gate else {
4458*0Sstevel@tonic-gate if (!AvREAL(ary)) {
4459*0Sstevel@tonic-gate AvREAL_on(ary);
4460*0Sstevel@tonic-gate AvREIFY_off(ary);
4461*0Sstevel@tonic-gate for (i = AvFILLp(ary); i >= 0; i--)
4462*0Sstevel@tonic-gate AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4463*0Sstevel@tonic-gate }
4464*0Sstevel@tonic-gate /* temporarily switch stacks */
4465*0Sstevel@tonic-gate SWITCHSTACK(PL_curstack, ary);
4466*0Sstevel@tonic-gate PL_curstackinfo->si_stack = ary;
4467*0Sstevel@tonic-gate make_mortal = 0;
4468*0Sstevel@tonic-gate }
4469*0Sstevel@tonic-gate }
4470*0Sstevel@tonic-gate base = SP - PL_stack_base;
4471*0Sstevel@tonic-gate orig = s;
4472*0Sstevel@tonic-gate if (pm->op_pmflags & PMf_SKIPWHITE) {
4473*0Sstevel@tonic-gate if (pm->op_pmflags & PMf_LOCALE) {
4474*0Sstevel@tonic-gate while (isSPACE_LC(*s))
4475*0Sstevel@tonic-gate s++;
4476*0Sstevel@tonic-gate }
4477*0Sstevel@tonic-gate else {
4478*0Sstevel@tonic-gate while (isSPACE(*s))
4479*0Sstevel@tonic-gate s++;
4480*0Sstevel@tonic-gate }
4481*0Sstevel@tonic-gate }
4482*0Sstevel@tonic-gate if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4483*0Sstevel@tonic-gate SAVEINT(PL_multiline);
4484*0Sstevel@tonic-gate PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4485*0Sstevel@tonic-gate }
4486*0Sstevel@tonic-gate
4487*0Sstevel@tonic-gate if (!limit)
4488*0Sstevel@tonic-gate limit = maxiters + 2;
4489*0Sstevel@tonic-gate if (pm->op_pmflags & PMf_WHITE) {
4490*0Sstevel@tonic-gate while (--limit) {
4491*0Sstevel@tonic-gate m = s;
4492*0Sstevel@tonic-gate while (m < strend &&
4493*0Sstevel@tonic-gate !((pm->op_pmflags & PMf_LOCALE)
4494*0Sstevel@tonic-gate ? isSPACE_LC(*m) : isSPACE(*m)))
4495*0Sstevel@tonic-gate ++m;
4496*0Sstevel@tonic-gate if (m >= strend)
4497*0Sstevel@tonic-gate break;
4498*0Sstevel@tonic-gate
4499*0Sstevel@tonic-gate dstr = NEWSV(30, m-s);
4500*0Sstevel@tonic-gate sv_setpvn(dstr, s, m-s);
4501*0Sstevel@tonic-gate if (make_mortal)
4502*0Sstevel@tonic-gate sv_2mortal(dstr);
4503*0Sstevel@tonic-gate if (do_utf8)
4504*0Sstevel@tonic-gate (void)SvUTF8_on(dstr);
4505*0Sstevel@tonic-gate XPUSHs(dstr);
4506*0Sstevel@tonic-gate
4507*0Sstevel@tonic-gate s = m + 1;
4508*0Sstevel@tonic-gate while (s < strend &&
4509*0Sstevel@tonic-gate ((pm->op_pmflags & PMf_LOCALE)
4510*0Sstevel@tonic-gate ? isSPACE_LC(*s) : isSPACE(*s)))
4511*0Sstevel@tonic-gate ++s;
4512*0Sstevel@tonic-gate }
4513*0Sstevel@tonic-gate }
4514*0Sstevel@tonic-gate else if (strEQ("^", rx->precomp)) {
4515*0Sstevel@tonic-gate while (--limit) {
4516*0Sstevel@tonic-gate /*SUPPRESS 530*/
4517*0Sstevel@tonic-gate for (m = s; m < strend && *m != '\n'; m++) ;
4518*0Sstevel@tonic-gate m++;
4519*0Sstevel@tonic-gate if (m >= strend)
4520*0Sstevel@tonic-gate break;
4521*0Sstevel@tonic-gate dstr = NEWSV(30, m-s);
4522*0Sstevel@tonic-gate sv_setpvn(dstr, s, m-s);
4523*0Sstevel@tonic-gate if (make_mortal)
4524*0Sstevel@tonic-gate sv_2mortal(dstr);
4525*0Sstevel@tonic-gate if (do_utf8)
4526*0Sstevel@tonic-gate (void)SvUTF8_on(dstr);
4527*0Sstevel@tonic-gate XPUSHs(dstr);
4528*0Sstevel@tonic-gate s = m;
4529*0Sstevel@tonic-gate }
4530*0Sstevel@tonic-gate }
4531*0Sstevel@tonic-gate else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4532*0Sstevel@tonic-gate (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4533*0Sstevel@tonic-gate && (rx->reganch & ROPT_CHECK_ALL)
4534*0Sstevel@tonic-gate && !(rx->reganch & ROPT_ANCH)) {
4535*0Sstevel@tonic-gate int tail = (rx->reganch & RE_INTUIT_TAIL);
4536*0Sstevel@tonic-gate SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4537*0Sstevel@tonic-gate
4538*0Sstevel@tonic-gate len = rx->minlen;
4539*0Sstevel@tonic-gate if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4540*0Sstevel@tonic-gate STRLEN n_a;
4541*0Sstevel@tonic-gate char c = *SvPV(csv, n_a);
4542*0Sstevel@tonic-gate while (--limit) {
4543*0Sstevel@tonic-gate /*SUPPRESS 530*/
4544*0Sstevel@tonic-gate for (m = s; m < strend && *m != c; m++) ;
4545*0Sstevel@tonic-gate if (m >= strend)
4546*0Sstevel@tonic-gate break;
4547*0Sstevel@tonic-gate dstr = NEWSV(30, m-s);
4548*0Sstevel@tonic-gate sv_setpvn(dstr, s, m-s);
4549*0Sstevel@tonic-gate if (make_mortal)
4550*0Sstevel@tonic-gate sv_2mortal(dstr);
4551*0Sstevel@tonic-gate if (do_utf8)
4552*0Sstevel@tonic-gate (void)SvUTF8_on(dstr);
4553*0Sstevel@tonic-gate XPUSHs(dstr);
4554*0Sstevel@tonic-gate /* The rx->minlen is in characters but we want to step
4555*0Sstevel@tonic-gate * s ahead by bytes. */
4556*0Sstevel@tonic-gate if (do_utf8)
4557*0Sstevel@tonic-gate s = (char*)utf8_hop((U8*)m, len);
4558*0Sstevel@tonic-gate else
4559*0Sstevel@tonic-gate s = m + len; /* Fake \n at the end */
4560*0Sstevel@tonic-gate }
4561*0Sstevel@tonic-gate }
4562*0Sstevel@tonic-gate else {
4563*0Sstevel@tonic-gate #ifndef lint
4564*0Sstevel@tonic-gate while (s < strend && --limit &&
4565*0Sstevel@tonic-gate (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4566*0Sstevel@tonic-gate csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4567*0Sstevel@tonic-gate #endif
4568*0Sstevel@tonic-gate {
4569*0Sstevel@tonic-gate dstr = NEWSV(31, m-s);
4570*0Sstevel@tonic-gate sv_setpvn(dstr, s, m-s);
4571*0Sstevel@tonic-gate if (make_mortal)
4572*0Sstevel@tonic-gate sv_2mortal(dstr);
4573*0Sstevel@tonic-gate if (do_utf8)
4574*0Sstevel@tonic-gate (void)SvUTF8_on(dstr);
4575*0Sstevel@tonic-gate XPUSHs(dstr);
4576*0Sstevel@tonic-gate /* The rx->minlen is in characters but we want to step
4577*0Sstevel@tonic-gate * s ahead by bytes. */
4578*0Sstevel@tonic-gate if (do_utf8)
4579*0Sstevel@tonic-gate s = (char*)utf8_hop((U8*)m, len);
4580*0Sstevel@tonic-gate else
4581*0Sstevel@tonic-gate s = m + len; /* Fake \n at the end */
4582*0Sstevel@tonic-gate }
4583*0Sstevel@tonic-gate }
4584*0Sstevel@tonic-gate }
4585*0Sstevel@tonic-gate else {
4586*0Sstevel@tonic-gate maxiters += slen * rx->nparens;
4587*0Sstevel@tonic-gate while (s < strend && --limit)
4588*0Sstevel@tonic-gate {
4589*0Sstevel@tonic-gate PUTBACK;
4590*0Sstevel@tonic-gate i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4591*0Sstevel@tonic-gate SPAGAIN;
4592*0Sstevel@tonic-gate if (i == 0)
4593*0Sstevel@tonic-gate break;
4594*0Sstevel@tonic-gate TAINT_IF(RX_MATCH_TAINTED(rx));
4595*0Sstevel@tonic-gate if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4596*0Sstevel@tonic-gate m = s;
4597*0Sstevel@tonic-gate s = orig;
4598*0Sstevel@tonic-gate orig = rx->subbeg;
4599*0Sstevel@tonic-gate s = orig + (m - s);
4600*0Sstevel@tonic-gate strend = s + (strend - m);
4601*0Sstevel@tonic-gate }
4602*0Sstevel@tonic-gate m = rx->startp[0] + orig;
4603*0Sstevel@tonic-gate dstr = NEWSV(32, m-s);
4604*0Sstevel@tonic-gate sv_setpvn(dstr, s, m-s);
4605*0Sstevel@tonic-gate if (make_mortal)
4606*0Sstevel@tonic-gate sv_2mortal(dstr);
4607*0Sstevel@tonic-gate if (do_utf8)
4608*0Sstevel@tonic-gate (void)SvUTF8_on(dstr);
4609*0Sstevel@tonic-gate XPUSHs(dstr);
4610*0Sstevel@tonic-gate if (rx->nparens) {
4611*0Sstevel@tonic-gate for (i = 1; i <= (I32)rx->nparens; i++) {
4612*0Sstevel@tonic-gate s = rx->startp[i] + orig;
4613*0Sstevel@tonic-gate m = rx->endp[i] + orig;
4614*0Sstevel@tonic-gate
4615*0Sstevel@tonic-gate /* japhy (07/27/01) -- the (m && s) test doesn't catch
4616*0Sstevel@tonic-gate parens that didn't match -- they should be set to
4617*0Sstevel@tonic-gate undef, not the empty string */
4618*0Sstevel@tonic-gate if (m >= orig && s >= orig) {
4619*0Sstevel@tonic-gate dstr = NEWSV(33, m-s);
4620*0Sstevel@tonic-gate sv_setpvn(dstr, s, m-s);
4621*0Sstevel@tonic-gate }
4622*0Sstevel@tonic-gate else
4623*0Sstevel@tonic-gate dstr = &PL_sv_undef; /* undef, not "" */
4624*0Sstevel@tonic-gate if (make_mortal)
4625*0Sstevel@tonic-gate sv_2mortal(dstr);
4626*0Sstevel@tonic-gate if (do_utf8)
4627*0Sstevel@tonic-gate (void)SvUTF8_on(dstr);
4628*0Sstevel@tonic-gate XPUSHs(dstr);
4629*0Sstevel@tonic-gate }
4630*0Sstevel@tonic-gate }
4631*0Sstevel@tonic-gate s = rx->endp[0] + orig;
4632*0Sstevel@tonic-gate }
4633*0Sstevel@tonic-gate }
4634*0Sstevel@tonic-gate
4635*0Sstevel@tonic-gate LEAVE_SCOPE(oldsave);
4636*0Sstevel@tonic-gate iters = (SP - PL_stack_base) - base;
4637*0Sstevel@tonic-gate if (iters > maxiters)
4638*0Sstevel@tonic-gate DIE(aTHX_ "Split loop");
4639*0Sstevel@tonic-gate
4640*0Sstevel@tonic-gate /* keep field after final delim? */
4641*0Sstevel@tonic-gate if (s < strend || (iters && origlimit)) {
4642*0Sstevel@tonic-gate STRLEN l = strend - s;
4643*0Sstevel@tonic-gate dstr = NEWSV(34, l);
4644*0Sstevel@tonic-gate sv_setpvn(dstr, s, l);
4645*0Sstevel@tonic-gate if (make_mortal)
4646*0Sstevel@tonic-gate sv_2mortal(dstr);
4647*0Sstevel@tonic-gate if (do_utf8)
4648*0Sstevel@tonic-gate (void)SvUTF8_on(dstr);
4649*0Sstevel@tonic-gate XPUSHs(dstr);
4650*0Sstevel@tonic-gate iters++;
4651*0Sstevel@tonic-gate }
4652*0Sstevel@tonic-gate else if (!origlimit) {
4653*0Sstevel@tonic-gate while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4654*0Sstevel@tonic-gate if (TOPs && !make_mortal)
4655*0Sstevel@tonic-gate sv_2mortal(TOPs);
4656*0Sstevel@tonic-gate iters--;
4657*0Sstevel@tonic-gate *SP-- = &PL_sv_undef;
4658*0Sstevel@tonic-gate }
4659*0Sstevel@tonic-gate }
4660*0Sstevel@tonic-gate
4661*0Sstevel@tonic-gate if (realarray) {
4662*0Sstevel@tonic-gate if (!mg) {
4663*0Sstevel@tonic-gate SWITCHSTACK(ary, oldstack);
4664*0Sstevel@tonic-gate PL_curstackinfo->si_stack = oldstack;
4665*0Sstevel@tonic-gate if (SvSMAGICAL(ary)) {
4666*0Sstevel@tonic-gate PUTBACK;
4667*0Sstevel@tonic-gate mg_set((SV*)ary);
4668*0Sstevel@tonic-gate SPAGAIN;
4669*0Sstevel@tonic-gate }
4670*0Sstevel@tonic-gate if (gimme == G_ARRAY) {
4671*0Sstevel@tonic-gate EXTEND(SP, iters);
4672*0Sstevel@tonic-gate Copy(AvARRAY(ary), SP + 1, iters, SV*);
4673*0Sstevel@tonic-gate SP += iters;
4674*0Sstevel@tonic-gate RETURN;
4675*0Sstevel@tonic-gate }
4676*0Sstevel@tonic-gate }
4677*0Sstevel@tonic-gate else {
4678*0Sstevel@tonic-gate PUTBACK;
4679*0Sstevel@tonic-gate ENTER;
4680*0Sstevel@tonic-gate call_method("PUSH",G_SCALAR|G_DISCARD);
4681*0Sstevel@tonic-gate LEAVE;
4682*0Sstevel@tonic-gate SPAGAIN;
4683*0Sstevel@tonic-gate if (gimme == G_ARRAY) {
4684*0Sstevel@tonic-gate /* EXTEND should not be needed - we just popped them */
4685*0Sstevel@tonic-gate EXTEND(SP, iters);
4686*0Sstevel@tonic-gate for (i=0; i < iters; i++) {
4687*0Sstevel@tonic-gate SV **svp = av_fetch(ary, i, FALSE);
4688*0Sstevel@tonic-gate PUSHs((svp) ? *svp : &PL_sv_undef);
4689*0Sstevel@tonic-gate }
4690*0Sstevel@tonic-gate RETURN;
4691*0Sstevel@tonic-gate }
4692*0Sstevel@tonic-gate }
4693*0Sstevel@tonic-gate }
4694*0Sstevel@tonic-gate else {
4695*0Sstevel@tonic-gate if (gimme == G_ARRAY)
4696*0Sstevel@tonic-gate RETURN;
4697*0Sstevel@tonic-gate }
4698*0Sstevel@tonic-gate
4699*0Sstevel@tonic-gate GETTARGET;
4700*0Sstevel@tonic-gate PUSHi(iters);
4701*0Sstevel@tonic-gate RETURN;
4702*0Sstevel@tonic-gate }
4703*0Sstevel@tonic-gate
4704*0Sstevel@tonic-gate #ifdef USE_5005THREADS
4705*0Sstevel@tonic-gate void
Perl_unlock_condpair(pTHX_ void * svv)4706*0Sstevel@tonic-gate Perl_unlock_condpair(pTHX_ void *svv)
4707*0Sstevel@tonic-gate {
4708*0Sstevel@tonic-gate MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4709*0Sstevel@tonic-gate
4710*0Sstevel@tonic-gate if (!mg)
4711*0Sstevel@tonic-gate Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4712*0Sstevel@tonic-gate MUTEX_LOCK(MgMUTEXP(mg));
4713*0Sstevel@tonic-gate if (MgOWNER(mg) != thr)
4714*0Sstevel@tonic-gate Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4715*0Sstevel@tonic-gate MgOWNER(mg) = 0;
4716*0Sstevel@tonic-gate COND_SIGNAL(MgOWNERCONDP(mg));
4717*0Sstevel@tonic-gate DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4718*0Sstevel@tonic-gate PTR2UV(thr), PTR2UV(svv)));
4719*0Sstevel@tonic-gate MUTEX_UNLOCK(MgMUTEXP(mg));
4720*0Sstevel@tonic-gate }
4721*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
4722*0Sstevel@tonic-gate
PP(pp_lock)4723*0Sstevel@tonic-gate PP(pp_lock)
4724*0Sstevel@tonic-gate {
4725*0Sstevel@tonic-gate dSP;
4726*0Sstevel@tonic-gate dTOPss;
4727*0Sstevel@tonic-gate SV *retsv = sv;
4728*0Sstevel@tonic-gate SvLOCK(sv);
4729*0Sstevel@tonic-gate if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4730*0Sstevel@tonic-gate || SvTYPE(retsv) == SVt_PVCV) {
4731*0Sstevel@tonic-gate retsv = refto(retsv);
4732*0Sstevel@tonic-gate }
4733*0Sstevel@tonic-gate SETs(retsv);
4734*0Sstevel@tonic-gate RETURN;
4735*0Sstevel@tonic-gate }
4736*0Sstevel@tonic-gate
PP(pp_threadsv)4737*0Sstevel@tonic-gate PP(pp_threadsv)
4738*0Sstevel@tonic-gate {
4739*0Sstevel@tonic-gate #ifdef USE_5005THREADS
4740*0Sstevel@tonic-gate dSP;
4741*0Sstevel@tonic-gate EXTEND(SP, 1);
4742*0Sstevel@tonic-gate if (PL_op->op_private & OPpLVAL_INTRO)
4743*0Sstevel@tonic-gate PUSHs(*save_threadsv(PL_op->op_targ));
4744*0Sstevel@tonic-gate else
4745*0Sstevel@tonic-gate PUSHs(THREADSV(PL_op->op_targ));
4746*0Sstevel@tonic-gate RETURN;
4747*0Sstevel@tonic-gate #else
4748*0Sstevel@tonic-gate DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4749*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
4750*0Sstevel@tonic-gate }
4751