pp.c revision 7c478bd95313f5f23a4c958a745db2134aa03244
/* pp.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
* 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
/*
* "It's a big house this, and very peculiar. Always a bit more to discover,
* and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
*/
#include "EXTERN.h"
#define PERL_IN_PP_C
#include "perl.h"
#include "keywords.h"
#include "reentr.h"
/* XXX I can't imagine anyone who doesn't have this actually _needs_
it, since pid_t is an integral type.
--AD 2/20/1998
*/
#ifdef NEED_GETPID_PROTO
#endif
/* variations on pp_null */
{
dSP;
}
{
return NORMAL;
}
/* Pushy stuff. */
{
} else if (LVRET) {
}
U32 i;
}
}
else {
}
}
}
}
{
else if (LVRET) {
}
}
}
}
{
}
/* Translations. */
{
(void)SvREFCNT_inc(sv);
}
}
else {
char *sym;
if (SvGMAGICAL(sv)) {
goto wasref;
}
/* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
*/
char *name;
}
else {
}
}
SvSETMAGIC(sv);
goto wasref;
}
if (ckWARN(WARN_UNINITIALIZED))
}
{
if (!sv
{
}
}
else {
}
}
}
}
{
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
}
}
else {
char *sym;
if (SvGMAGICAL(sv)) {
goto wasref;
}
if (ckWARN(WARN_UNINITIALIZED))
}
{
if (!gv
{
}
}
else {
}
}
}
else if (gv)
else
}
}
}
{
dSP;
if (!sv) {
}
}
{
}
}
}
else {
sv_pos_b2u(sv, &i);
}
}
}
}
{
dSP;
/* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
/* (But not in defined().) */
if (cv) {
}
}
else
}
{
dSP;
ret = &PL_sv_undef;
int code;
if (code < 0) { /* Overridable. */
int i = 0, n = 0, seen_question = 0;
goto set;
while (i < MAXO) { /* The slow way. */
{
goto found;
}
i++;
}
goto nonesuch; /* Should not happen... */
while (oa) {
seen_question = 1;
str[n++] = ';';
}
goto set; /* XXXX system, exec */
/* But globs are already references (kinda) */
) {
str[n++] = '\\';
}
}
str[n++] = '\0';
}
else if (code) /* Non-Overridable */
goto set;
else { /* None such */
}
}
}
set:
}
{
dSP;
}
{
dSP;
}
{
else
*MARK = &PL_sv_undef;
}
}
{
sv = &PL_sv_undef;
else
(void)SvREFCNT_inc(sv);
}
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
}
else {
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
}
rv = sv_newmortal();
return rv;
}
{
char *pv;
}
{
dSP;
if (MAXARG == 1)
else {
char *ptr;
"Explicit blessing to '' (assuming package main)");
}
}
{
char *elem;
dSP;
{
case 'A':
break;
case 'C':
break;
case 'F':
/* finally deprecated in 5.8.0 */
deprecate("*glob{FILEHANDLE}");
}
else
break;
case 'G':
break;
case 'H':
break;
case 'I':
break;
case 'N':
break;
case 'P':
break;
case 'S':
break;
}
if (tmpRef)
if (sv)
sv_2mortal(sv);
else
sv = &PL_sv_undef;
}
/* Pattern matching */
{
register unsigned char *s;
if (sv == PL_lastscream) {
}
else {
if (PL_lastscream) {
}
}
if (pos <= 0)
if (pos > PL_maxscream) {
if (PL_maxscream < 0) {
}
else {
}
}
*sfirst++ = -1;
sfirst -= 256;
while (--pos >= 0) {
else
}
/* piggyback on m//g magic */
}
{
else {
}
TARG = sv_newmortal();
}
/* Lvalue operators. */
{
}
{
}
{
}
{
}
{
dSP;
case SVt_PVAV:
break;
case SVt_PVHV:
break;
case SVt_PVCV:
break;
default:
if (SvGMAGICAL(sv))
}
}
{
dSP;
if (!PL_op->op_private) {
}
if (!sv)
if (SvTHINKFIRST(sv))
case SVt_NULL:
break;
case SVt_PVAV:
break;
case SVt_PVHV:
break;
case SVt_PVCV:
/* FALL THROUGH */
case SVt_PVFM:
{
/* let user-undef'd sub keep its identity */
}
break;
case SVt_PVGV:
else {
GvMULTI_on(sv);
}
break;
default:
}
SvSETMAGIC(sv);
}
}
{
dSP;
{
}
else
return NORMAL;
}
{
{
}
else
/* special case for undef: see thread at 2003-03/msg00536.html in archive */
return NORMAL;
}
{
{
}
else
return NORMAL;
}
/* Ordinary operators. */
{
#ifdef PERL_PRESERVE_IVUV
bool is_int = 0;
#endif
#ifdef PERL_PRESERVE_IVUV
/* For integer to integer power, we do the calculation by hand wherever
we're sure it is safe; otherwise we call pow() and try to convert to
integer afterwards. */
{
if (baseuok) {
} else {
if (iv >= 0) {
} else {
}
}
} else {
if (iv >= 0) {
} else {
goto float_it; /* Can't do negative powers this way. */
}
}
/* now we have integer ** positive integer. */
is_int = 1;
/* foo & (foo - 1) is zero only for a power of 2. */
/* We are raising power-of-2 to a positive integer.
The logic here will work for any base (even non-integer
bases) but it can be less accurate than
pow (base,power) or exp (power * log (base)) when the
intermediate values start to spill out of the mantissa.
With powers of 2 we know this can't happen.
And powers of 2 are the favourite thing for perl
programmers to notice ** not doing what they mean. */
int n = 0;
/* Do I look like I trust gcc with long longs here?
Do I hell. */
/* Only bother to clear the bit if it is set. */
/* Avoid squaring base again if we're done. */
if (power == 0) break;
}
}
SP--;
} else {
register unsigned int lowbit = 0;
register unsigned int diff;
else
}
/* we now have baseuv < 2 ** highbit */
/* result will definitely fit in UV, so use UV math
on same algorithm as above */
register int n = 0;
if (power == 0) break;
}
}
SP--;
/* answer is positive */
/* answer negative, fits in IV */
/* 2's complement assumption: special case IV_MIN */
else
/* answer negative, doesn't fit */
}
}
}
}
}
#endif
{
#ifdef PERL_PRESERVE_IVUV
if (is_int)
#endif
}
}
{
#ifdef PERL_PRESERVE_IVUV
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
/* Left operand is defined, so is it IV? */
if (auvok) {
} else {
if (aiv >= 0) {
} else {
}
}
if (buvok) {
} else {
if (biv >= 0) {
} else {
}
}
/* If this does sign extension on unsigned it's time for plan B */
/* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
which is overflow. Drop to NVs below. */
/* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
so the unsigned multiply cannot overflow. */
/* -ve * -ve or +ve * +ve gives a +ve result. */
SP--;
/* 2s complement assumption that (UV)-IV_MIN is correct. */
/* -ve result, which could overflow an IV */
SP--;
} /* else drop to NVs below. */
} else {
/* One operand is large, 1 small */
if (bhigh) {
/* swap the operands */
}
/* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
multiplies can't overflow. shift can, add can, -ve can. */
if (!(product_middle & topmask)) {
/* OK, (ahigh * blow) won't lose bits when we shift it. */
/* as for pp_add, UV + something mustn't get smaller.
IIRC ANSI mandates this wrapping *behaviour* for
unsigned whatever the actual representation*/
if (product_low >= product_middle) {
/* didn't overflow */
/* -ve * -ve or +ve * +ve gives a +ve result. */
SP--;
SETu( product_low );
/* 2s complement assumption again */
/* -ve result, which could overflow an IV */
SP--;
} /* else drop to NVs below. */
}
} /* product_middle too large */
} /* ahigh && bhigh */
} /* SvIOK(TOPm1s) */
} /* SvIOK(TOPs) */
#endif
{
}
}
{
/* Only try to do UV divide first
if ((SLOPPYDIVIDE is true) or
(PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
to preserve))
The assumption is that it is better to use floating point divide
whenever possible, only doing integer divide first if we can't be sure.
If NV_PRESERVES_UV is true then we know at compile time that no UV
can be too large to preserve, so don't need to compile the code to
test the size of UVs. */
#ifdef SLOPPYDIVIDE
# define PERL_TRY_UV_DIVIDE
/* ensure that 20./5. == 4. */
#else
# ifdef PERL_PRESERVE_IVUV
# ifndef NV_PRESERVES_UV
# define PERL_TRY_UV_DIVIDE
# endif
# endif
#endif
#ifdef PERL_TRY_UV_DIVIDE
if (right_non_neg) {
}
else {
if (biv >= 0) {
}
else {
}
}
/* historically undef()/0 gives a "Use of uninitialized value"
warning before dieing, hence this test goes here.
If it were immediately before the second SvIV_please, then
DIE() would be invoked before left was even inspected, so
no inpsection would give no warning. */
if (right == 0)
if (left_non_neg) {
}
else {
if (aiv >= 0) {
}
else {
}
}
#ifdef SLOPPYDIVIDE
/* For sloppy divide we always attempt integer division. */
#else
/* Otherwise we only attempt it if either or both operands
would not be preserved by an NV. If both fit in NVs
we fall through to the NV divide code below. However,
as left >= right to ensure integer result here, we know that
we can skip the test on the right operand - right big
enough not to be preserved can't get here unless left is
also too big. */
#endif
) {
/* Integer division can't overflow, but it can be imprecise. */
SP--; /* result is valid */
if (left_non_neg == right_non_neg) {
/* signs identical, result is positive. */
}
/* 2s complement assumption */
else {
/* It's exact but too negative for IV. */
}
} /* tried integer divide but it was not an integer result */
} /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
} /* left wasn't SvIOK */
} /* right wasn't SvIOK */
#endif /* PERL_TRY_UV_DIVIDE */
{
if (right == 0.0)
}
}
{
{
bool use_double = FALSE;
bool dright_valid = FALSE;
if (!right_neg) {
} else {
if (biv >= 0) {
} else {
}
}
}
else {
if (right_neg)
} else {
use_double = TRUE;
}
}
/* At this point use_double is only true if right is out of range for
a UV. In range NV has been rounded down to nearest UV and
use_double false. */
if (!left_neg) {
} else {
if (aiv >= 0) {
} else {
}
}
}
}
else {
if (left_neg)
/* This should be exactly the 5.6 behaviour - if left and right are
both in range for UV then use U_V() rather than floor. */
if (!use_double) {
/* right was in range, so is dleft, so use UVs not double.
*/
}
/* left is out of range for UV, right was in range, so promote
right (back) to double. */
else {
/* The +0.5 is used in 5.6 even though it is not strictly
consistent with the implicit +0 floor in the U_V()
inside the #if 1. */
use_double = TRUE;
if (dright_valid)
else
}
}
}
if (use_double) {
if (!dright)
if (right_neg)
}
else {
if (!right)
if (right_neg) {
/* XXX may warn: unary minus operator applied to unsigned type */
/* could change -foo to be (~foo)+1 instead */
else
}
else
}
}
}
{
{
if (count < 0)
count = 0;
static const char list_extend[] = "panic: list extend";
if (count > 1) {
#if 0
/* This code was intended to fix 20010809.028:
$x = 'abcd';
for (($x =~ /./g) x 2) {
print chop; # "abcdabcd" expected as output.
}
* but that change (#11635) broke this code:
$x = [("foo")x2]; # only one "foo" ended up in the anonlist.
* I can't think of a better fix that doesn't introduce
* an efficiency hit by copying the SVs. The stack isn't
* refcounted, and mortalisation obviously doesn't
* Do The Right Thing when the stack has more than
* one pointer to the same mortal value.
* .robin.
*/
if (*SP) {
SvREADONLY_on(*SP);
}
#else
if (*SP)
SvTEMP_off((*SP));
#endif
SP--;
}
MARK++;
}
else if (count <= 0)
}
else { /* Note: mark already snarfed by pp_list */
bool isutf;
if (count != 1) {
if (count < 1)
else {
}
}
if (isutf)
(void)SvPOK_only_UTF8(TARG);
else
(void)SvPOK_only(TARG);
/* The parser saw this as a list repeat, and there
are probably several items on the stack. But we're
in scalar context, and there's no pp_list to save us
now. So drop the rest of the items -- robin@kitsite.com
*/
}
}
}
}
{
#ifdef PERL_PRESERVE_IVUV
/* See comments in pp_add (in pp_hot.c) about Overflow, and how
"bad things" happen if you rely on signed integers wrapping. */
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
bool a_valid = 0;
if (!useleft) {
auv = 0;
/* left operand is undef, treat as zero. */
} else {
/* Left operand is defined, so is it IV? */
else {
if (aiv >= 0) {
} else { /* 2s complement assumption for IV_MIN */
}
}
a_valid = 1;
}
}
if (a_valid) {
bool result_good = 0;
if (buvok)
else {
if (biv >= 0) {
buvok = 1;
} else
}
/* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
else "IV" now, independent of how it came in.
if a, b represents positive, A, B negative, a maps to -A etc
a - b => (a - b)
A - b => -(a + b)
a - B => (a + b)
A - B => -(a - b)
all UV maths. negate result if A negative.
subtract if signs same, add if signs differ. */
/* Signs differ. */
result_good = 1;
} else {
/* Signs same */
/* Must get smaller */
result_good = 1;
} else {
/* result really should be -(auv-buv). as its negation
of true value, need to swap our result flag */
result_good = 1;
}
}
}
if (result_good) {
SP--;
if (auvok)
else {
/* Negate result */
else {
/* result valid, but out of range for IV. */
}
}
} /* Overflow, drop through to NVs. */
}
}
#endif
{
if (!useleft) {
/* left operand is undef, treat as zero - value */
}
}
}
{
{
}
else {
}
}
}
{
{
}
else {
}
}
}
{
#ifdef PERL_PRESERVE_IVUV
SP--;
}
SP--;
}
if (auvok) { /* ## UV < IV ## */
SP--;
if (biv < 0) {
/* As (a) is a UV, it's >=0, so it cannot be < */
}
}
{ /* ## IV < UV ## */
if (aiv < 0) {
/* As (b) is a UV, it's >=0, so it must be < */
SP--;
}
SP--;
}
}
}
#endif
#ifndef NV_PRESERVES_UV
#ifdef PERL_PRESERVE_IVUV
else
#endif
SP--;
}
#endif
{
}
}
{
#ifdef PERL_PRESERVE_IVUV
SP--;
}
SP--;
}
if (auvok) { /* ## UV > IV ## */
SP--;
if (biv < 0) {
/* As (a) is a UV, it's >=0, so it must be > */
}
}
{ /* ## IV > UV ## */
if (aiv < 0) {
/* As (b) is a UV, it's >=0, so it cannot be > */
SP--;
}
SP--;
}
}
}
#endif
#ifndef NV_PRESERVES_UV
#ifdef PERL_PRESERVE_IVUV
else
#endif
SP--;
}
#endif
{
}
}
{
#ifdef PERL_PRESERVE_IVUV
SP--;
}
SP--;
}
if (auvok) { /* ## UV <= IV ## */
SP--;
if (biv < 0) {
/* As (a) is a UV, it's >=0, so a cannot be <= */
}
}
{ /* ## IV <= UV ## */
if (aiv < 0) {
/* As (b) is a UV, it's >=0, so a must be <= */
SP--;
}
SP--;
}
}
}
#endif
#ifndef NV_PRESERVES_UV
#ifdef PERL_PRESERVE_IVUV
else
#endif
SP--;
}
#endif
{
}
}
{
#ifdef PERL_PRESERVE_IVUV
SP--;
}
SP--;
}
if (auvok) { /* ## UV >= IV ## */
SP--;
if (biv < 0) {
/* As (a) is a UV, it's >=0, so it must be >= */
}
}
{ /* ## IV >= UV ## */
if (aiv < 0) {
/* As (b) is a UV, it's >=0, so a cannot be >= */
SP--;
}
SP--;
}
}
}
#endif
#ifndef NV_PRESERVES_UV
#ifdef PERL_PRESERVE_IVUV
else
#endif
SP--;
}
#endif
{
}
}
{
#ifndef NV_PRESERVES_UV
SP--;
}
#endif
#ifdef PERL_PRESERVE_IVUV
/* Casting IV to UV before comparison isn't going to matter
on 2s complement. On 1s complement or sign&magnitude
(if we have any of them) it could make negative zero
differ from normal zero. As I understand it. (Need to
check - is negative zero implementation defined behaviour
anyway?). NWC */
}
{ /* ## Mixed IV,UV ## */
/* != is commutative so swap if needed (save code) */
if (auvok) {
/* swap. top of stack (b) is the iv */
SP--;
if (iv < 0) {
/* As (a) is a UV, it's >0, so it cannot be == */
}
} else {
SP--;
if (iv < 0) {
/* As (b) is a UV, it's >0, so it cannot be == */
}
}
}
}
}
#endif
{
}
}
{
#ifndef NV_PRESERVES_UV
}
#endif
#ifdef PERL_PRESERVE_IVUV
/* Fortunately it seems NaN isn't IOK */
value = 1;
value = -1;
else
value = 0;
value = 1;
value = -1;
else
value = 0;
} else if (leftuvok) { /* ## UV <=> IV ## */
if (rightiv < 0) {
/* As (a) is a UV, it's >=0, so it cannot be < */
value = 1;
} else {
value = 1;
value = -1;
} else {
value = 0;
}
}
} else { /* ## IV <=> UV ## */
if (leftiv < 0) {
/* As (b) is a UV, it's >=0, so it must be < */
value = -1;
} else {
value = 1;
value = -1;
} else {
value = 0;
}
}
}
SP--;
}
}
#endif
{
#ifdef Perl_isnan
SETs(&PL_sv_undef);
}
#else
value = 0;
value = -1;
value = 1;
else {
SETs(&PL_sv_undef);
}
#endif
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
}
}
{
{
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
SETi(i);
}
else {
SETu(u);
}
}
else {
}
}
}
{
{
SETi(i);
}
else {
SETu(u);
}
}
else {
}
}
}
{
{
SETi(i);
}
else {
SETu(u);
}
}
else {
}
}
}
{
{
if (SvGMAGICAL(sv))
/* It's publicly an integer, or privately an integer-not-float */
/* 2s complement assumption. */
}
}
}
}
#ifdef PERL_PRESERVE_IVUV
else {
}
#endif
}
if (isIDFIRST(*s)) {
}
else if (*s == '+' || *s == '-') {
}
goto oops_its_an_int;
else {
}
}
else {
goto oops_its_an_int;
}
}
else
}
}
{
return NORMAL;
}
{
{
SETi(i);
}
else {
SETu(u);
}
}
else {
/* Calculate exact length, let's not estimate. */
STRLEN l;
nchar++;
if (c > 0xff)
nwide++;
}
/* Now rewind strings and write them. */
if (nwide) {
}
*result = '\0';
}
else {
*result++ = ~c;
}
*result = '\0';
}
}
#ifdef LIBERAL
{
register long *tmpl;
}
#endif
}
}
}
/* integer versions of some of the above */
{
{
}
}
{
{
if (value == 0)
}
}
{
/* This is the vanilla old i_modulo. */
{
if (!right)
}
}
{
/* This is the i_modulo with the workaround for the _moddi3 bug
* in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
* See below for pp_i_modulo. */
{
if (!right)
}
}
#endif
{
{
if (!right)
/* The assumption is to use hereafter the old vanilla version... */
/* .. but if we have glibc, we might have a buggy _moddi3
* (at least glicb 2.2.5 is known to have this bug), in other
* words our integer modulus with negative quad as the second
* argument might be broken. Test for this and re-patch the
* opcode dispatch table if that is the case, remembering to
* also apply the workaround so that this first round works
* right, too. See [perl #9402] for more information. */
{
IV l = 3;
IV r = -10;
/* Cannot do this check with inlined IV constants since
* that seems to work correctly even with the buggy glibc. */
if (l % r == -3) {
/* Yikes, we have the bug.
* Patch in the workaround version. */
/* Make certain we work right this time, too. */
}
}
#endif
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
value = 1;
value = -1;
else
value = 0;
}
}
{
}
/* High falutin' math. */
{
{
}
}
{
{
}
}
{
{
}
}
/* Support Configure command-line overrides for rand() functions.
After 5.005, perhaps we should replace this by Configure support
for drand48(), random(), or rand(). For 5.005, though, maintain
compatibility by calling rand() but allow the user to override it.
See INSTALL for details. --Andy Dougherty 15 July 1998
*/
/* Now it's after 5.005, and Configure supports drand48() and random(),
in addition to rand(). So the overrides should not be needed any more.
--Jarkko Hietaniemi 27 September 1998
*/
#ifndef HAS_DRAND48_PROTO
extern double drand48 (void);
#endif
{
if (MAXARG < 1)
value = 1.0;
else
if (value == 0.0)
value = 1.0;
if (!PL_srand_called) {
}
}
{
dSP;
if (MAXARG < 1)
else
}
{
{
}
}
{
{
if (value <= 0.0) {
}
}
}
{
{
if (value < 0.0) {
}
}
}
{
{
/* XXX it's arguable that compiler casting to IV might be subtly
different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
else preferring IV has introduced a subtle behaviour change bug. OTOH
relying on floating point to be accurate is a bug. */
SETu(0);
} else
} else {
if (value >= 0.0) {
} else {
}
}
else {
} else {
}
}
}
}
}
{
{
/* This will cache the NV value if string isn't actually integer */
SETu(0);
/* IVX is precise */
} else {
if (iv >= 0) {
} else {
} else {
/* 2s complement assumption. Also, not really needed as
IV_MIN and -IV_MIN should both be %100...00 and NV-able */
}
}
}
} else{
if (value < 0.0)
}
}
}
{
char *tmps;
/* If Unicode, try to downgrade
* If not possible, croak. */
}
if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
}
else {
}
}
{
char *tmps;
/* If Unicode, try to downgrade
* If not possible, croak. */
}
if (*tmps == '0')
if (*tmps == 'x')
else if (*tmps == 'b')
else
if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
}
else {
}
}
/* String stuff. */
{
else
}
{
char *tmps;
char *repl = 0;
bool repl_need_utf8_upgrade = FALSE;
bool repl_is_utf8 = FALSE;
if (num_args > 2) {
if (num_args > 3) {
}
}
if (repl_sv) {
if (repl_is_utf8) {
}
}
if (utf8_curlen == curlen)
utf8_curlen = 0;
else
}
else
utf8_curlen = 0;
if (num_args > 2) {
if (len < 0) {
if (rem < 0)
rem = 0;
}
}
}
else {
if (num_args < 3)
else if (len >= 0) {
}
else {
}
if (pos < 0)
pos = 0;
}
if (fail < 0) {
if (ckWARN(WARN_SUBSTR))
}
else {
if (utf8_curlen)
/* we either return a PV or an LV. If the TARG hasn't been used
* before, or is of that type, reuse it; otherwise use a mortal
* instead. Note that LVs can have an extended lifetime, so also
* dont reuse if refcount > 1 (bug #20933) */
: lvalue)
{
TARG = sv_newmortal();
}
}
#ifdef USE_LOCALE_COLLATE
#endif
if (utf8_curlen)
if (repl) {
if (repl_need_utf8_upgrade) {
}
if (repl_is_utf8)
if (repl_sv_copy)
}
else if (lvalue) { /* it's an lvalue! */
if (!SvGMAGICAL(sv)) {
if (ckWARN(WARN_SUBSTR))
"Attempt to use reference as lvalue in substr");
}
(void)SvPOK_only_UTF8(sv);
else
}
}
else
}
}
}
}
{
if (lvalue) { /* it's an lvalue! */
TARG = sv_newmortal();
}
}
}
}
{
char *tmps;
char *tmps2;
if (MAXARG < 3)
offset = 0;
else
if (offset < 0)
offset = 0;
retval = -1;
else
}
{
char *tmps;
char *tmps2;
if (MAXARG >= 3)
if (MAXARG < 3)
else {
}
if (offset < 0)
offset = 0;
retval = -1;
else
}
{
}
{
}
(*s & 0xff));
}
{
char *tmps;
*tmps = '\0';
(void)SvPOK_only(TARG);
}
*tmps = '\0';
(void)SvPOK_only(TARG);
if (PL_encoding && !IN_BYTES) {
*tmps = '\0';
}
}
}
{
#ifdef HAS_CRYPT
/* If Unicode, try to downgrade.
* If not possible, croak.
* Yes, we made this up. */
}
# ifdef USE_ITHREADS
# ifdef HAS_CRYPT_R
if (!PL_reentrant_buffer->_crypt_struct_buffer) {
/* This should be threadsafe because in ithreads there is only
* one thread per interpreter. If this would not be true,
* we would need a mutex to protect this malloc. */
/* work around glibc-2.2.5 bug */
}
#endif
}
# endif /* HAS_CRYPT_R */
# endif /* USE_ITHREADS */
# ifdef FCRYPT
# else
# endif
#else
"The crypt() function is unimplemented due to excessive paranoia.");
#endif
}
{
dSP;
register U8 *s;
SvGETMAGIC(sv);
UTF8_IS_START(*s)) {
utf8_to_uvchr(s, &ulen);
utf8_to_uvchr(tmpbuf, 0);
/* slen is the byte length of the whole SV.
* ulen is the byte length of the original Unicode character
* stored as UTF-8 at s.
* tculen is the byte length of the freshly titlecased
* Unicode character stored as UTF-8 at tmpbuf.
* We first set the result to be the titlecased character,
* and then append the rest of the SV data. */
}
else {
}
}
else {
}
if (*s) {
if (IN_LOCALE_RUNTIME) {
*s = toUPPER_LC(*s);
}
else
*s = toUPPER(*s);
}
}
SvSETMAGIC(sv);
}
{
dSP;
register U8 *s;
SvGETMAGIC(sv);
UTF8_IS_START(*s)) {
}
else {
}
}
else {
}
if (*s) {
if (IN_LOCALE_RUNTIME) {
*s = toLOWER_LC(*s);
}
else
*s = toLOWER(*s);
}
}
SvSETMAGIC(sv);
}
{
dSP;
register U8 *s;
SvGETMAGIC(sv);
register U8 *d;
if (!len) {
}
else {
(void)SvPOK_only(TARG);
while (s < send) {
d += ulen;
s += UTF8SKIP(s);
}
*d = '\0';
}
}
else {
}
if (len) {
if (IN_LOCALE_RUNTIME) {
for (; s < send; s++)
*s = toUPPER_LC(*s);
}
else {
for (; s < send; s++)
*s = toUPPER(*s);
}
}
}
SvSETMAGIC(sv);
}
{
dSP;
register U8 *s;
SvGETMAGIC(sv);
register U8 *d;
if (!len) {
}
else {
(void)SvPOK_only(TARG);
while (s < send) {
if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
/*
* Now if the sigma is NOT followed by
* /$ignorable_sequence$cased_letter/;
* and it IS preceded by
* /$cased_letter$ignorable_sequence/;
* where $ignorable_sequence is
* [\x{2010}\x{AD}\p{Mn}]*
* and $cased_letter is
* [\p{Ll}\p{Lo}\p{Lt}]
* then it should be mapped to 0x03C2,
* (GREEK SMALL LETTER FINAL SIGMA),
* instead of staying 0x03A3.
* See lib/unicore/SpecCase.txt.
*/
}
d += ulen;
s += UTF8SKIP(s);
}
*d = '\0';
}
}
else {
}
if (len) {
if (IN_LOCALE_RUNTIME) {
for (; s < send; s++)
*s = toLOWER_LC(*s);
}
else {
for (; s < send; s++)
*s = toLOWER(*s);
}
}
}
SvSETMAGIC(sv);
}
{
register char *d;
if (len) {
while (len) {
if (UTF8_IS_CONTINUED(*s)) {
while (ulen--)
*d++ = *s++;
}
else {
if (!isALNUM(*s))
*d++ = '\\';
*d++ = *s++;
len--;
}
}
}
else {
while (len--) {
if (!isALNUM(*s))
*d++ = '\\';
*d++ = *s++;
}
}
*d = '\0';
(void)SvPOK_only_UTF8(TARG);
}
else
if (SvSMAGICAL(TARG))
}
/* Arrays. */
{
}
}
if (elem > 0)
if (lval) {
}
}
}
}
}
/* Associative arrays. */
{
dSP;
/* might clobber stack_sp */
if (entry) {
/* might clobber stack_sp */
}
}
}
{
return do_kv();
}
{
return do_kv();
}
{
dSP;
}
}
}
}
else { /* pseudo-hash element */
}
}
}
else
if (discard)
else
*++MARK = &PL_sv_undef;
}
}
else {
else
}
else
if (!sv)
sv = &PL_sv_undef;
if (!discard)
}
}
{
dSP;
if (cv)
}
}
}
}
else {
}
}
{
bool other_magic = FALSE;
if (localizing) {
/* Try to preserve the existenceness of a tied hash
* element by using EXISTS and DELETE if possible.
* Fallback to FETCH and STORE otherwise */
}
if (!realhv && localizing)
bool preeminent = FALSE;
if (localizing) {
}
if (realhv) {
}
else {
}
if (lval) {
}
if (localizing) {
if (preeminent)
else {
}
}
}
}
}
}
}
/* List operators. */
{
else
*MARK = &PL_sv_undef;
}
}
{
dSP;
if (ix < 0)
else
*firstlelem = &PL_sv_undef;
else
SP = firstlelem;
}
if (max == 0) {
}
if (ix < 0)
else
*lelem = &PL_sv_undef;
else {
*lelem = &PL_sv_undef;
}
}
if (is_something_there)
else
}
{
}
{
}
}
{
register I32 i;
}
SP++;
if (offset < 0)
else
if (offset < 0)
if (length < 0) {
if (length < 0)
length = 0;
}
}
else
}
else {
offset = 0;
}
}
if (after < 0) { /* not that much array */
after = 0;
}
/* At this point, MARK .. SP-1 is our new LIST */
if (diff < 0) { /* shrinking the area */
if (newlen) {
}
dst++;
}
}
}
else {
sv_2mortal(*MARK);
}
}
/* pull up or down? */
if (offset) { /* esp. if nothing to pull */
for (i = offset; i > 0; i--) /* can't trust Copy */
}
}
else {
if (after) { /* anything to pull down? */
}
/* avoid later double free */
}
i = -diff;
while (i)
dst[--i] = &PL_sv_undef;
if (newlen) {
}
}
}
else { /* no, expanding (or same) */
if (length) {
}
if (diff > 0) { /* expanding */
/* push up or down? */
if (offset) {
}
}
else {
if (after) {
for (i = after; i; i--) {
}
}
}
}
}
if (length) {
dst++;
}
}
}
}
else if (length--) {
sv_2mortal(*MARK);
while (length-- > 0)
}
}
else
*MARK = &PL_sv_undef;
}
}
{
}
else {
/* Why no pre-extend of ary here ? */
if (*MARK)
}
}
}
{
dSP;
(void)sv_2mortal(sv);
}
{
dSP;
if (!sv)
(void)sv_2mortal(sv);
}
{
register I32 i = 0;
}
else {
}
}
}
{
MARK++;
}
/* safe as long as stack cannot get extended in the above */
}
else {
register char *up;
register char *down;
else
if (len > 1) {
while (s < send) {
if (UTF8_IS_INVARIANT(*s)) {
s++;
continue;
}
else {
if (!utf8_to_uvchr(s, 0))
break;
up = (char*)s;
s += UTF8SKIP(s);
down = (char*)(s - 1);
/* reverse this character */
}
}
}
}
}
(void)SvPOK_only_UTF8(TARG);
}
}
}
{
register char *m;
I32 i;
char *orig;
#ifdef DEBUGGING
#else
#endif
if (!pm || !s)
if (pm->op_pmreplroot) {
#ifdef USE_ITHREADS
#else
#endif
}
#ifdef USE_5005THREADS
#else
#endif /* USE_5005THREADS */
else
realarray = 1;
}
else {
}
/* temporarily switch stacks */
make_mortal = 0;
}
}
orig = s;
while (isSPACE_LC(*s))
s++;
}
else {
while (isSPACE(*s))
s++;
}
}
}
if (!limit)
while (--limit) {
m = s;
while (m < strend &&
? isSPACE_LC(*m) : isSPACE(*m)))
++m;
if (m >= strend)
break;
if (make_mortal)
if (do_utf8)
s = m + 1;
while (s < strend &&
? isSPACE_LC(*s) : isSPACE(*s)))
++s;
}
}
while (--limit) {
/*SUPPRESS 530*/
for (m = s; m < strend && *m != '\n'; m++) ;
m++;
if (m >= strend)
break;
if (make_mortal)
if (do_utf8)
s = m;
}
}
while (--limit) {
/*SUPPRESS 530*/
for (m = s; m < strend && *m != c; m++) ;
if (m >= strend)
break;
if (make_mortal)
if (do_utf8)
/* The rx->minlen is in characters but we want to step
* s ahead by bytes. */
if (do_utf8)
else
s = m + len; /* Fake \n at the end */
}
}
else {
#ifndef lint
#endif
{
if (make_mortal)
if (do_utf8)
/* The rx->minlen is in characters but we want to step
* s ahead by bytes. */
if (do_utf8)
else
s = m + len; /* Fake \n at the end */
}
}
}
else {
{
if (i == 0)
break;
m = s;
s = orig;
s = orig + (m - s);
}
if (make_mortal)
if (do_utf8)
/* japhy (07/27/01) -- the (m && s) test doesn't catch
parens that didn't match -- they should be set to
undef, not the empty string */
}
else
if (make_mortal)
if (do_utf8)
}
}
}
}
/* keep field after final delim? */
if (make_mortal)
if (do_utf8)
iters++;
}
else if (!origlimit) {
if (TOPs && !make_mortal)
iters--;
*SP-- = &PL_sv_undef;
}
}
if (realarray) {
if (!mg) {
if (SvSMAGICAL(ary)) {
}
}
}
else {
/* EXTEND should not be needed - we just popped them */
for (i=0; i < iters; i++) {
}
}
}
}
else {
}
}
#ifdef USE_5005THREADS
void
{
if (!mg)
}
#endif /* USE_5005THREADS */
{
dSP;
}
}
{
#ifdef USE_5005THREADS
dSP;
else
#else
#endif /* USE_5005THREADS */
}