mirror/perl
1
0
Fork 0
mirror of https://github.com/Perl/perl5.git synced 2026-01-26 16:39:36 +00:00
Code Issues Packages Projects Releases Wiki Activity

OP_SUBSTR_LEFT - a specialised OP_SUBSTR variant

Browse Source 
This commit adds OP_SUBSTR_LEFT and associated machinery for fast
handling of the constructions:

        substr EXPR,0,LENGTH,''
and
        substr EXPR,0,LENGTH

Where EXPR is a scalar lexical, the OFFSET is zero, and either there
is no REPLACEMENT or it is the empty string. LENGTH can be anything
that OP_SUBSTR supports. These constraints allow for a very stripped
back and optimised version of pp_substr.

The primary motivation was for situations where a scalar, containing
some network packets or other binary data structure, is being parsed
piecemeal. Nibbling away at the scalar can be useful when you don't
know how exactly it will be parsed and unpacked until you get started.
It also means that you don't need to worry about correctly updating
a separate offset variable.

This operator also turns out to be an efficient way to (destructively)
break an expression up into fixed size chunks. For example, given:

    my $x = ''; my $str = "A"x100_000_000;

This code:

    $x = substr($str, 0, 5, "") while ($str);

is twice as fast as doing:

    for ($pos = 0; $pos < length($str); $pos += 5) {
        $x = substr($str, $pos, 5);
    }

Compared with blead, `$y = substr($x, 0, 5)` runs 40% faster and
`$y = substr($x, 0, 5, '')` runs 45% faster.
This commit is contained in:
Richard Leach 2024-11-19 23:02:37 +00:00
parent c107bb0b9c
commit cdbed2a40e
15 changed files with 826 additions and 399 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
MANIFEST
View File

@ -6445,6 +6445,7 @@ t/op/studytied.t See if study works with tied scalars
t/op/sub.t See if subroutines work
t/op/sub_lval.t See if lvalue subroutines work
t/op/substr.t See if substr works
t/op/substr_left.t See if substr($x, 0, $l, '') optimisation works
t/op/substr_thr.t See if substr works in another thread
t/op/svflags.t See if POK is set as expected.
t/op/svleak.pl Test file for svleak.t

5
ext/Opcode/Opcode.pm
View File

@ -1,4 +1,4 @@
package Opcode 1.67;
package Opcode 1.68;
use strict;
@ -322,7 +322,8 @@ invert_opset function.
slt sgt sle sge seq sne scmp
isa
substr vec stringify study pos length index rindex ord chr
substr substr_left vec stringify study pos length index
rindex ord chr
ucfirst lcfirst uc lc fc quotemeta trans transr chop schop
chomp schomp

21
lib/B/Deparse.pm
View File

@ -7,7 +7,7 @@
# This is based on the module of the same name by Malcolm Beattie,
# but essentially none of his code remains.
package B::Deparse 1.81;
package B::Deparse 1.82;
use strict;
use Carp;
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
@ -3436,6 +3436,25 @@ sub pp_substr {
maybe_local(@_, listop(@_, "substr"))
}
sub pp_substr_left {
my ($self,$op,$cx) = @_;
my $lex = ($op->private & OPpTARGET_MY);
my $val = 'substr(' . $self->deparse($op->first->sibling, $cx)
. ', 0, ' . $self->deparse($op->first->sibling->sibling->sibling, $cx)
. ( (($op->private & 7) == 3) ? '' : ", '')" );
if ($lex) {
my $targ = $op->targ;
my $var = $self->maybe_my($op, $cx, $self->padname($op->targ),
$self->padname_sv($targ),
0);
$val = $self->maybe_parens("$var = $val", $cx, 7);
}
$val;
}
sub pp_index {
# Also handles pp_rindex.
#

8
lib/B/Deparse.t
View File

@ -1770,6 +1770,14 @@ print sort(foo('bar'));
substr(my $a, 0, 0) = (foo(), bar());
$a++;
####
# 4-arg substr (non-chop)
my $str = 'ABCD';
my $bbb = substr($str, 1, 1, '');
####
# 4-arg substr (chop)
my $str = 'ABCD';
my $aaa = substr($str, 0, 1, '');
####
# This following line works around an unfixed bug that we are not trying to
# test for here:
# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised

5
lib/B/Op_private.pm generated
View File

@ -150,7 +150,7 @@ $bits{$_}{6} = 'OPpPAD_STATE' for qw(emptyavhv lvavref lvref padav padhv padsv p
$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo);
$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite);
$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv);
$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 ceil chmod chomp chown chr chroot concat cos crypt divide emptyavhv exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_negate i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement negate oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time undef unlink unshift utime wait waitpid);
$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 ceil chmod chomp chown chr chroot concat cos crypt divide emptyavhv exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_negate i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement negate oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify substr_left subtract symlink system time undef unlink unshift utime wait waitpid);
$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr);
$bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr);
$bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr);
@ -586,6 +586,7 @@ $bits{stat}{0} = $bf[0];
$bits{study}{0} = $bf[0];
$bits{substcont}{0} = $bf[0];
@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[4], $bf[4], $bf[4]);
@{$bits{substr_left}}{2,1,0} = ($bf[4], $bf[4], $bf[4]);
@{$bits{subtract}}{1,0} = ($bf[1], $bf[1]);
@{$bits{symlink}}{3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5]);
@{$bits{syscall}}{3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5]);
@ -926,7 +927,7 @@ our %ops_using = (
OPpSORT_DESCEND => [qw(sort)],
OPpSPLIT_ASSIGN => [qw(split)],
OPpSUBSTR_REPL_FIRST => [qw(substr)],
OPpTARGET_MY => [qw(abs add atan2 ceil chmod chomp chown chr chroot concat cos crypt divide emptyavhv exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_negate i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement negate oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time undef unlink unshift utime wait waitpid)],
OPpTARGET_MY => [qw(abs add atan2 ceil chmod chomp chown chr chroot concat cos crypt divide emptyavhv exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_negate i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement negate oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify substr_left subtract symlink system time undef unlink unshift utime wait waitpid)],
OPpTRANS_COMPLEMENT => [qw(trans transr)],
OPpTRUEBOOL => [qw(blessed grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst)],
OPpUNDEF_KEEP_PV => [qw(undef)],

200
opcode.h generated
View File

@ -270,6 +270,7 @@ EXTCONST char* const PL_op_name[] INIT({
"abs",
"length",
"substr",
"substr_left",
"vec",
"index",
"rindex",
@ -692,6 +693,7 @@ EXTCONST char* const PL_op_desc[] INIT({
"abs",
"length",
"substr",
"substr left",
"vec",
"index",
"rindex",
@ -1119,6 +1121,7 @@ INIT({
Perl_pp_abs,
Perl_pp_length,
Perl_pp_substr,
Perl_pp_substr_left,
Perl_pp_vec,
Perl_pp_index,
Perl_pp_rindex, /* implemented by Perl_pp_index */
@ -1541,6 +1544,7 @@ INIT({
Perl_ck_fun, /* abs */
Perl_ck_length, /* length */
Perl_ck_substr, /* substr */
Perl_ck_substr, /* substr_left */
Perl_ck_fun, /* vec */
Perl_ck_index, /* index */
Perl_ck_index, /* rindex */
@ -1962,6 +1966,7 @@ EXTCONST U32 PL_opargs[] INIT({
0x00009b9e, /* abs */
0x00009b9e, /* length */
0x0991140c, /* substr */
0x0991141c, /* substr_left */
0x0011140c, /* vec */
0x0091141c, /* index */
0x0091141c, /* rindex */
@ -2685,9 +2690,10 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
78, /* abs */
106, /* length */
109, /* substr */
112, /* vec */
114, /* index */
114, /* rindex */
112, /* substr_left */
114, /* vec */
116, /* index */
116, /* rindex */
56, /* sprintf */
56, /* formline */
78, /* ord */
@ -2698,94 +2704,94 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* uc */
0, /* lc */
0, /* quotemeta */
118, /* rv2av */
125, /* aelemfast */
125, /* aelemfast_lex */
125, /* aelemfastlex_store */
126, /* aelem */
131, /* aslice */
134, /* kvaslice */
120, /* rv2av */
127, /* aelemfast */
127, /* aelemfast_lex */
127, /* aelemfastlex_store */
128, /* aelem */
133, /* aslice */
136, /* kvaslice */
0, /* aeach */
0, /* avalues */
44, /* akeys */
0, /* each */
44, /* values */
44, /* keys */
135, /* delete */
139, /* exists */
141, /* rv2hv */
126, /* helem */
131, /* hslice */
134, /* kvhslice */
149, /* multideref */
137, /* delete */
141, /* exists */
143, /* rv2hv */
128, /* helem */
133, /* hslice */
136, /* kvhslice */
151, /* multideref */
56, /* unpack */
56, /* pack */
156, /* split */
158, /* split */
56, /* join */
161, /* list */
163, /* list */
13, /* lslice */
56, /* anonlist */
56, /* anonhash */
163, /* emptyavhv */
165, /* emptyavhv */
56, /* splice */
101, /* push */
0, /* pop */
0, /* shift */
101, /* unshift */
168, /* sort */
173, /* reverse */
170, /* sort */
175, /* reverse */
0, /* grepstart */
175, /* grepwhile */
177, /* grepwhile */
-1, /* anystart */
-1, /* allstart */
0, /* anywhile */
0, /* mapstart */
0, /* mapwhile */
0, /* range */
177, /* flip */
177, /* flop */
179, /* flip */
179, /* flop */
0, /* and */
0, /* or */
13, /* xor */
0, /* dor */
179, /* cond_expr */
181, /* cond_expr */
0, /* andassign */
0, /* orassign */
0, /* dorassign */
181, /* entersub */
188, /* leavesub */
188, /* leavesublv */
183, /* entersub */
190, /* leavesub */
190, /* leavesublv */
0, /* argcheck */
190, /* argelem */
192, /* argdefelem */
195, /* caller */
192, /* argelem */
194, /* argdefelem */
197, /* caller */
56, /* warn */
56, /* die */
56, /* reset */
-1, /* lineseq */
197, /* nextstate */
197, /* dbstate */
199, /* nextstate */
199, /* dbstate */
-1, /* unstack */
-1, /* enter */
198, /* leave */
200, /* leave */
-1, /* scope */
200, /* enteriter */
204, /* iter */
202, /* enteriter */
206, /* iter */
-1, /* enterloop */
206, /* leaveloop */
208, /* leaveloop */
-1, /* return */
208, /* last */
208, /* next */
208, /* redo */
208, /* dump */
210, /* goto */
210, /* last */
210, /* next */
210, /* redo */
210, /* dump */
212, /* goto */
56, /* exit */
213, /* method */
213, /* method_named */
213, /* method_super */
213, /* method_redir */
213, /* method_redir_super */
215, /* open */
215, /* method */
215, /* method_named */
215, /* method_super */
215, /* method_redir */
215, /* method_redir_super */
217, /* open */
56, /* close */
56, /* pipe_op */
56, /* fileno */
@ -2801,7 +2807,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
56, /* getc */
56, /* read */
56, /* enterwrite */
188, /* leavewrite */
190, /* leavewrite */
-1, /* prtf */
-1, /* print */
-1, /* say */
@ -2831,33 +2837,33 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* getpeername */
0, /* lstat */
0, /* stat */
220, /* ftrread */
220, /* ftrwrite */
220, /* ftrexec */
220, /* fteread */
220, /* ftewrite */
220, /* fteexec */
225, /* ftis */
225, /* ftsize */
225, /* ftmtime */
225, /* ftatime */
225, /* ftctime */
225, /* ftrowned */
225, /* fteowned */
225, /* ftzero */
225, /* ftsock */
225, /* ftchr */
225, /* ftblk */
225, /* ftfile */
225, /* ftdir */
225, /* ftpipe */
225, /* ftsuid */
225, /* ftsgid */
225, /* ftsvtx */
225, /* ftlink */
225, /* fttty */
225, /* fttext */
225, /* ftbinary */
222, /* ftrread */
222, /* ftrwrite */
222, /* ftrexec */
222, /* fteread */
222, /* ftewrite */
222, /* fteexec */
227, /* ftis */
227, /* ftsize */
227, /* ftmtime */
227, /* ftatime */
227, /* ftctime */
227, /* ftrowned */
227, /* fteowned */
227, /* ftzero */
227, /* ftsock */
227, /* ftchr */
227, /* ftblk */
227, /* ftfile */
227, /* ftdir */
227, /* ftpipe */
227, /* ftsuid */
227, /* ftsgid */
227, /* ftsvtx */
227, /* ftlink */
227, /* fttty */
227, /* fttext */
227, /* ftbinary */
56, /* chdir */
101, /* chown */
78, /* chroot */
@ -2877,17 +2883,17 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* rewinddir */
0, /* closedir */
-1, /* fork */
229, /* wait */
231, /* wait */
101, /* waitpid */
101, /* system */
101, /* exec */
101, /* kill */
229, /* getppid */
231, /* getppid */
101, /* getpgrp */
101, /* setpgrp */
101, /* getpriority */
101, /* setpriority */
229, /* time */
231, /* time */
-1, /* tms */
0, /* localtime */
56, /* gmtime */
@ -2907,8 +2913,8 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* require */
0, /* dofile */
-1, /* hintseval */
230, /* entereval */
188, /* leaveeval */
232, /* entereval */
190, /* leaveeval */
0, /* entertry */
-1, /* leavetry */
0, /* ghbyname */
@ -2946,17 +2952,17 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* lock */
0, /* once */
-1, /* custom */
237, /* coreargs */
241, /* avhvswitch */
239, /* coreargs */
243, /* avhvswitch */
3, /* runcv */
0, /* fc */
-1, /* padcv */
-1, /* introcv */
-1, /* clonecv */
243, /* padrange */
245, /* refassign */
251, /* lvref */
257, /* lvrefslice */
245, /* padrange */
247, /* refassign */
253, /* lvref */
259, /* lvrefslice */
17, /* lvavref */
0, /* anonconst */
13, /* isa */
@ -2966,20 +2972,20 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
-1, /* leavetrycatch */
-1, /* poptry */
0, /* catch */
258, /* pushdefer */
260, /* pushdefer */
0, /* is_bool */
0, /* is_weak */
0, /* weaken */
0, /* unweaken */
53, /* blessed */
260, /* refaddr */
260, /* reftype */
260, /* ceil */
260, /* floor */
262, /* refaddr */
262, /* reftype */
262, /* ceil */
262, /* floor */
0, /* is_tainted */
263, /* helemexistsor */
265, /* methstart */
267, /* initfield */
265, /* helemexistsor */
267, /* methstart */
269, /* initfield */
-1, /* classname */
};
@ -3033,6 +3039,7 @@ EXTCONST U16 PL_op_private_bitdefs[] = {
0x5aa9, /* bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, complement */
0x06d4, 0x57d0, 0x0003, /* length */
0x4d30, 0x3dec, 0x024b, /* substr */
0x57d0, 0x024b, /* substr_left */
0x3dec, 0x0067, /* vec */
0x3f58, 0x06d4, 0x57d0, 0x02af, /* index, rindex */
0x3cfc, 0x47f8, 0x06d4, 0x3dec, 0x5148, 0x5424, 0x0003, /* rv2av */
@ -3211,6 +3218,7 @@ EXTCONST U8 PL_op_private_valid[] = {
/* ABS */ (OPpARG1_MASK|OPpTARGET_MY),
/* LENGTH */ (OPpARG1_MASK|OPpTARGET_MY|OPpTRUEBOOL),
/* SUBSTR */ (OPpARG3_MASK|OPpMAYBE_LVSUB|OPpSUBSTR_REPL_FIRST),
/* SUBSTR_LEFT */ (OPpARG3_MASK|OPpTARGET_MY),
/* VEC */ (OPpARG2_MASK|OPpMAYBE_LVSUB),
/* INDEX */ (OPpARG4_MASK|OPpTARGET_MY|OPpTRUEBOOL|OPpINDEX_BOOLNEG),
/* RINDEX */ (OPpARG4_MASK|OPpTARGET_MY|OPpTRUEBOOL|OPpINDEX_BOOLNEG),

595
opnames.h generated
View File

@ -136,302 +136,303 @@ typedef enum opcode {
OP_ABS = 119,
OP_LENGTH = 120,
OP_SUBSTR = 121,
OP_VEC = 122,
OP_INDEX = 123,
OP_RINDEX = 124,
OP_SPRINTF = 125,
OP_FORMLINE = 126,
OP_ORD = 127,
OP_CHR = 128,
OP_CRYPT = 129,
OP_UCFIRST = 130,
OP_LCFIRST = 131,
OP_UC = 132,
OP_LC = 133,
OP_QUOTEMETA = 134,
OP_RV2AV = 135,
OP_AELEMFAST = 136,
OP_AELEMFAST_LEX = 137,
OP_AELEMFASTLEX_STORE = 138,
OP_AELEM = 139,
OP_ASLICE = 140,
OP_KVASLICE = 141,
OP_AEACH = 142,
OP_AVALUES = 143,
OP_AKEYS = 144,
OP_EACH = 145,
OP_VALUES = 146,
OP_KEYS = 147,
OP_DELETE = 148,
OP_EXISTS = 149,
OP_RV2HV = 150,
OP_HELEM = 151,
OP_HSLICE = 152,
OP_KVHSLICE = 153,
OP_MULTIDEREF = 154,
OP_UNPACK = 155,
OP_PACK = 156,
OP_SPLIT = 157,
OP_JOIN = 158,
OP_LIST = 159,
OP_LSLICE = 160,
OP_ANONLIST = 161,
OP_ANONHASH = 162,
OP_EMPTYAVHV = 163,
OP_SPLICE = 164,
OP_PUSH = 165,
OP_POP = 166,
OP_SHIFT = 167,
OP_UNSHIFT = 168,
OP_SORT = 169,
OP_REVERSE = 170,
OP_GREPSTART = 171,
OP_GREPWHILE = 172,
OP_ANYSTART = 173,
OP_ALLSTART = 174,
OP_ANYWHILE = 175,
OP_MAPSTART = 176,
OP_MAPWHILE = 177,
OP_RANGE = 178,
OP_FLIP = 179,
OP_FLOP = 180,
OP_AND = 181,
OP_OR = 182,
OP_XOR = 183,
OP_DOR = 184,
OP_COND_EXPR = 185,
OP_ANDASSIGN = 186,
OP_ORASSIGN = 187,
OP_DORASSIGN = 188,
OP_ENTERSUB = 189,
OP_LEAVESUB = 190,
OP_LEAVESUBLV = 191,
OP_ARGCHECK = 192,
OP_ARGELEM = 193,
OP_ARGDEFELEM = 194,
OP_CALLER = 195,
OP_WARN = 196,
OP_DIE = 197,
OP_RESET = 198,
OP_LINESEQ = 199,
OP_NEXTSTATE = 200,
OP_DBSTATE = 201,
OP_UNSTACK = 202,
OP_ENTER = 203,
OP_LEAVE = 204,
OP_SCOPE = 205,
OP_ENTERITER = 206,
OP_ITER = 207,
OP_ENTERLOOP = 208,
OP_LEAVELOOP = 209,
OP_RETURN = 210,
OP_LAST = 211,
OP_NEXT = 212,
OP_REDO = 213,
OP_DUMP = 214,
OP_GOTO = 215,
OP_EXIT = 216,
OP_METHOD = 217,
OP_METHOD_NAMED = 218,
OP_METHOD_SUPER = 219,
OP_METHOD_REDIR = 220,
OP_METHOD_REDIR_SUPER = 221,
OP_OPEN = 222,
OP_CLOSE = 223,
OP_PIPE_OP = 224,
OP_FILENO = 225,
OP_UMASK = 226,
OP_BINMODE = 227,
OP_TIE = 228,
OP_UNTIE = 229,
OP_TIED = 230,
OP_DBMOPEN = 231,
OP_DBMCLOSE = 232,
OP_SSELECT = 233,
OP_SELECT = 234,
OP_GETC = 235,
OP_READ = 236,
OP_ENTERWRITE = 237,
OP_LEAVEWRITE = 238,
OP_PRTF = 239,
OP_PRINT = 240,
OP_SAY = 241,
OP_SYSOPEN = 242,
OP_SYSSEEK = 243,
OP_SYSREAD = 244,
OP_SYSWRITE = 245,
OP_EOF = 246,
OP_TELL = 247,
OP_SEEK = 248,
OP_TRUNCATE = 249,
OP_FCNTL = 250,
OP_IOCTL = 251,
OP_FLOCK = 252,
OP_SEND = 253,
OP_RECV = 254,
OP_SOCKET = 255,
OP_SOCKPAIR = 256,
OP_BIND = 257,
OP_CONNECT = 258,
OP_LISTEN = 259,
OP_ACCEPT = 260,
OP_SHUTDOWN = 261,
OP_GSOCKOPT = 262,
OP_SSOCKOPT = 263,
OP_GETSOCKNAME = 264,
OP_GETPEERNAME = 265,
OP_LSTAT = 266,
OP_STAT = 267,
OP_FTRREAD = 268,
OP_FTRWRITE = 269,
OP_FTREXEC = 270,
OP_FTEREAD = 271,
OP_FTEWRITE = 272,
OP_FTEEXEC = 273,
OP_FTIS = 274,
OP_FTSIZE = 275,
OP_FTMTIME = 276,
OP_FTATIME = 277,
OP_FTCTIME = 278,
OP_FTROWNED = 279,
OP_FTEOWNED = 280,
OP_FTZERO = 281,
OP_FTSOCK = 282,
OP_FTCHR = 283,
OP_FTBLK = 284,
OP_FTFILE = 285,
OP_FTDIR = 286,
OP_FTPIPE = 287,
OP_FTSUID = 288,
OP_FTSGID = 289,
OP_FTSVTX = 290,
OP_FTLINK = 291,
OP_FTTTY = 292,
OP_FTTEXT = 293,
OP_FTBINARY = 294,
OP_CHDIR = 295,
OP_CHOWN = 296,
OP_CHROOT = 297,
OP_UNLINK = 298,
OP_CHMOD = 299,
OP_UTIME = 300,
OP_RENAME = 301,
OP_LINK = 302,
OP_SYMLINK = 303,
OP_READLINK = 304,
OP_MKDIR = 305,
OP_RMDIR = 306,
OP_OPEN_DIR = 307,
OP_READDIR = 308,
OP_TELLDIR = 309,
OP_SEEKDIR = 310,
OP_REWINDDIR = 311,
OP_CLOSEDIR = 312,
OP_FORK = 313,
OP_WAIT = 314,
OP_WAITPID = 315,
OP_SYSTEM = 316,
OP_EXEC = 317,
OP_KILL = 318,
OP_GETPPID = 319,
OP_GETPGRP = 320,
OP_SETPGRP = 321,
OP_GETPRIORITY = 322,
OP_SETPRIORITY = 323,
OP_TIME = 324,
OP_TMS = 325,
OP_LOCALTIME = 326,
OP_GMTIME = 327,
OP_ALARM = 328,
OP_SLEEP = 329,
OP_SHMGET = 330,
OP_SHMCTL = 331,
OP_SHMREAD = 332,
OP_SHMWRITE = 333,
OP_MSGGET = 334,
OP_MSGCTL = 335,
OP_MSGSND = 336,
OP_MSGRCV = 337,
OP_SEMOP = 338,
OP_SEMGET = 339,
OP_SEMCTL = 340,
OP_REQUIRE = 341,
OP_DOFILE = 342,
OP_HINTSEVAL = 343,
OP_ENTEREVAL = 344,
OP_LEAVEEVAL = 345,
OP_ENTERTRY = 346,
OP_LEAVETRY = 347,
OP_GHBYNAME = 348,
OP_GHBYADDR = 349,
OP_GHOSTENT = 350,
OP_GNBYNAME = 351,
OP_GNBYADDR = 352,
OP_GNETENT = 353,
OP_GPBYNAME = 354,
OP_GPBYNUMBER = 355,
OP_GPROTOENT = 356,
OP_GSBYNAME = 357,
OP_GSBYPORT = 358,
OP_GSERVENT = 359,
OP_SHOSTENT = 360,
OP_SNETENT = 361,
OP_SPROTOENT = 362,
OP_SSERVENT = 363,
OP_EHOSTENT = 364,
OP_ENETENT = 365,
OP_EPROTOENT = 366,
OP_ESERVENT = 367,
OP_GPWNAM = 368,
OP_GPWUID = 369,
OP_GPWENT = 370,
OP_SPWENT = 371,
OP_EPWENT = 372,
OP_GGRNAM = 373,
OP_GGRGID = 374,
OP_GGRENT = 375,
OP_SGRENT = 376,
OP_EGRENT = 377,
OP_GETLOGIN = 378,
OP_SYSCALL = 379,
OP_LOCK = 380,
OP_ONCE = 381,
OP_CUSTOM = 382,
OP_COREARGS = 383,
OP_AVHVSWITCH = 384,
OP_RUNCV = 385,
OP_FC = 386,
OP_PADCV = 387,
OP_INTROCV = 388,
OP_CLONECV = 389,
OP_PADRANGE = 390,
OP_REFASSIGN = 391,
OP_LVREF = 392,
OP_LVREFSLICE = 393,
OP_LVAVREF = 394,
OP_ANONCONST = 395,
OP_ISA = 396,
OP_CMPCHAIN_AND = 397,
OP_CMPCHAIN_DUP = 398,
OP_ENTERTRYCATCH = 399,
OP_LEAVETRYCATCH = 400,
OP_POPTRY = 401,
OP_CATCH = 402,
OP_PUSHDEFER = 403,
OP_IS_BOOL = 404,
OP_IS_WEAK = 405,
OP_WEAKEN = 406,
OP_UNWEAKEN = 407,
OP_BLESSED = 408,
OP_REFADDR = 409,
OP_REFTYPE = 410,
OP_CEIL = 411,
OP_FLOOR = 412,
OP_IS_TAINTED = 413,
OP_HELEMEXISTSOR = 414,
OP_METHSTART = 415,
OP_INITFIELD = 416,
OP_CLASSNAME = 417,
OP_SUBSTR_LEFT = 122,
OP_VEC = 123,
OP_INDEX = 124,
OP_RINDEX = 125,
OP_SPRINTF = 126,
OP_FORMLINE = 127,
OP_ORD = 128,
OP_CHR = 129,
OP_CRYPT = 130,
OP_UCFIRST = 131,
OP_LCFIRST = 132,
OP_UC = 133,
OP_LC = 134,
OP_QUOTEMETA = 135,
OP_RV2AV = 136,
OP_AELEMFAST = 137,
OP_AELEMFAST_LEX = 138,
OP_AELEMFASTLEX_STORE = 139,
OP_AELEM = 140,
OP_ASLICE = 141,
OP_KVASLICE = 142,
OP_AEACH = 143,
OP_AVALUES = 144,
OP_AKEYS = 145,
OP_EACH = 146,
OP_VALUES = 147,
OP_KEYS = 148,
OP_DELETE = 149,
OP_EXISTS = 150,
OP_RV2HV = 151,
OP_HELEM = 152,
OP_HSLICE = 153,
OP_KVHSLICE = 154,
OP_MULTIDEREF = 155,
OP_UNPACK = 156,
OP_PACK = 157,
OP_SPLIT = 158,
OP_JOIN = 159,
OP_LIST = 160,
OP_LSLICE = 161,
OP_ANONLIST = 162,
OP_ANONHASH = 163,
OP_EMPTYAVHV = 164,
OP_SPLICE = 165,
OP_PUSH = 166,
OP_POP = 167,
OP_SHIFT = 168,
OP_UNSHIFT = 169,
OP_SORT = 170,
OP_REVERSE = 171,
OP_GREPSTART = 172,
OP_GREPWHILE = 173,
OP_ANYSTART = 174,
OP_ALLSTART = 175,
OP_ANYWHILE = 176,
OP_MAPSTART = 177,
OP_MAPWHILE = 178,
OP_RANGE = 179,
OP_FLIP = 180,
OP_FLOP = 181,
OP_AND = 182,
OP_OR = 183,
OP_XOR = 184,
OP_DOR = 185,
OP_COND_EXPR = 186,
OP_ANDASSIGN = 187,
OP_ORASSIGN = 188,
OP_DORASSIGN = 189,
OP_ENTERSUB = 190,
OP_LEAVESUB = 191,
OP_LEAVESUBLV = 192,
OP_ARGCHECK = 193,
OP_ARGELEM = 194,
OP_ARGDEFELEM = 195,
OP_CALLER = 196,
OP_WARN = 197,
OP_DIE = 198,
OP_RESET = 199,
OP_LINESEQ = 200,
OP_NEXTSTATE = 201,
OP_DBSTATE = 202,
OP_UNSTACK = 203,
OP_ENTER = 204,
OP_LEAVE = 205,
OP_SCOPE = 206,
OP_ENTERITER = 207,
OP_ITER = 208,
OP_ENTERLOOP = 209,
OP_LEAVELOOP = 210,
OP_RETURN = 211,
OP_LAST = 212,
OP_NEXT = 213,
OP_REDO = 214,
OP_DUMP = 215,
OP_GOTO = 216,
OP_EXIT = 217,
OP_METHOD = 218,
OP_METHOD_NAMED = 219,
OP_METHOD_SUPER = 220,
OP_METHOD_REDIR = 221,
OP_METHOD_REDIR_SUPER = 222,
OP_OPEN = 223,
OP_CLOSE = 224,
OP_PIPE_OP = 225,
OP_FILENO = 226,
OP_UMASK = 227,
OP_BINMODE = 228,
OP_TIE = 229,
OP_UNTIE = 230,
OP_TIED = 231,
OP_DBMOPEN = 232,
OP_DBMCLOSE = 233,
OP_SSELECT = 234,
OP_SELECT = 235,
OP_GETC = 236,
OP_READ = 237,
OP_ENTERWRITE = 238,
OP_LEAVEWRITE = 239,
OP_PRTF = 240,
OP_PRINT = 241,
OP_SAY = 242,
OP_SYSOPEN = 243,
OP_SYSSEEK = 244,
OP_SYSREAD = 245,
OP_SYSWRITE = 246,
OP_EOF = 247,
OP_TELL = 248,
OP_SEEK = 249,
OP_TRUNCATE = 250,
OP_FCNTL = 251,
OP_IOCTL = 252,
OP_FLOCK = 253,
OP_SEND = 254,
OP_RECV = 255,
OP_SOCKET = 256,
OP_SOCKPAIR = 257,
OP_BIND = 258,
OP_CONNECT = 259,
OP_LISTEN = 260,
OP_ACCEPT = 261,
OP_SHUTDOWN = 262,
OP_GSOCKOPT = 263,
OP_SSOCKOPT = 264,
OP_GETSOCKNAME = 265,
OP_GETPEERNAME = 266,
OP_LSTAT = 267,
OP_STAT = 268,
OP_FTRREAD = 269,
OP_FTRWRITE = 270,
OP_FTREXEC = 271,
OP_FTEREAD = 272,
OP_FTEWRITE = 273,
OP_FTEEXEC = 274,
OP_FTIS = 275,
OP_FTSIZE = 276,
OP_FTMTIME = 277,
OP_FTATIME = 278,
OP_FTCTIME = 279,
OP_FTROWNED = 280,
OP_FTEOWNED = 281,
OP_FTZERO = 282,
OP_FTSOCK = 283,
OP_FTCHR = 284,
OP_FTBLK = 285,
OP_FTFILE = 286,
OP_FTDIR = 287,
OP_FTPIPE = 288,
OP_FTSUID = 289,
OP_FTSGID = 290,
OP_FTSVTX = 291,
OP_FTLINK = 292,
OP_FTTTY = 293,
OP_FTTEXT = 294,
OP_FTBINARY = 295,
OP_CHDIR = 296,
OP_CHOWN = 297,
OP_CHROOT = 298,
OP_UNLINK = 299,
OP_CHMOD = 300,
OP_UTIME = 301,
OP_RENAME = 302,
OP_LINK = 303,
OP_SYMLINK = 304,
OP_READLINK = 305,
OP_MKDIR = 306,
OP_RMDIR = 307,
OP_OPEN_DIR = 308,
OP_READDIR = 309,
OP_TELLDIR = 310,
OP_SEEKDIR = 311,
OP_REWINDDIR = 312,
OP_CLOSEDIR = 313,
OP_FORK = 314,
OP_WAIT = 315,
OP_WAITPID = 316,
OP_SYSTEM = 317,
OP_EXEC = 318,
OP_KILL = 319,
OP_GETPPID = 320,
OP_GETPGRP = 321,
OP_SETPGRP = 322,
OP_GETPRIORITY = 323,
OP_SETPRIORITY = 324,
OP_TIME = 325,
OP_TMS = 326,
OP_LOCALTIME = 327,
OP_GMTIME = 328,
OP_ALARM = 329,
OP_SLEEP = 330,
OP_SHMGET = 331,
OP_SHMCTL = 332,
OP_SHMREAD = 333,
OP_SHMWRITE = 334,
OP_MSGGET = 335,
OP_MSGCTL = 336,
OP_MSGSND = 337,
OP_MSGRCV = 338,
OP_SEMOP = 339,
OP_SEMGET = 340,
OP_SEMCTL = 341,
OP_REQUIRE = 342,
OP_DOFILE = 343,
OP_HINTSEVAL = 344,
OP_ENTEREVAL = 345,
OP_LEAVEEVAL = 346,
OP_ENTERTRY = 347,
OP_LEAVETRY = 348,
OP_GHBYNAME = 349,
OP_GHBYADDR = 350,
OP_GHOSTENT = 351,
OP_GNBYNAME = 352,
OP_GNBYADDR = 353,
OP_GNETENT = 354,
OP_GPBYNAME = 355,
OP_GPBYNUMBER = 356,
OP_GPROTOENT = 357,
OP_GSBYNAME = 358,
OP_GSBYPORT = 359,
OP_GSERVENT = 360,
OP_SHOSTENT = 361,
OP_SNETENT = 362,
OP_SPROTOENT = 363,
OP_SSERVENT = 364,
OP_EHOSTENT = 365,
OP_ENETENT = 366,
OP_EPROTOENT = 367,
OP_ESERVENT = 368,
OP_GPWNAM = 369,
OP_GPWUID = 370,
OP_GPWENT = 371,
OP_SPWENT = 372,
OP_EPWENT = 373,
OP_GGRNAM = 374,
OP_GGRGID = 375,
OP_GGRENT = 376,
OP_SGRENT = 377,
OP_EGRENT = 378,
OP_GETLOGIN = 379,
OP_SYSCALL = 380,
OP_LOCK = 381,
OP_ONCE = 382,
OP_CUSTOM = 383,
OP_COREARGS = 384,
OP_AVHVSWITCH = 385,
OP_RUNCV = 386,
OP_FC = 387,
OP_PADCV = 388,
OP_INTROCV = 389,
OP_CLONECV = 390,
OP_PADRANGE = 391,
OP_REFASSIGN = 392,
OP_LVREF = 393,
OP_LVREFSLICE = 394,
OP_LVAVREF = 395,
OP_ANONCONST = 396,
OP_ISA = 397,
OP_CMPCHAIN_AND = 398,
OP_CMPCHAIN_DUP = 399,
OP_ENTERTRYCATCH = 400,
OP_LEAVETRYCATCH = 401,
OP_POPTRY = 402,
OP_CATCH = 403,
OP_PUSHDEFER = 404,
OP_IS_BOOL = 405,
OP_IS_WEAK = 406,
OP_WEAKEN = 407,
OP_UNWEAKEN = 408,
OP_BLESSED = 409,
OP_REFADDR = 410,
OP_REFTYPE = 411,
OP_CEIL = 412,
OP_FLOOR = 413,
OP_IS_TAINTED = 414,
OP_HELEMEXISTSOR = 415,
OP_METHSTART = 416,
OP_INITFIELD = 417,
OP_CLASSNAME = 418,
OP_max
} opcode;
@ -442,7 +443,7 @@ An enum of all the legal Perl opcodes, defined in F<opnames.h>
=cut
*/
#define MAXO 418
#define MAXO 419
#define OP_FREED MAXO
/* the OP_IS_* macros are optimized to a simple range check because

92
peep.c
View File

@ -3868,6 +3868,98 @@ Perl_rpeep(pTHX_ OP *o)
}
break;
case OP_SUBSTR: {
OP *expr, *offs, *len;
/* Specialize substr($x, 0, $y) and substr($x,0,$y,"") */
/* Does this substr have 3-4 args and amiable flags? */
if (
((cMAXARG3x(o) == 4) || (cMAXARG3x(o) == 3))
/* No lvalue cases, no OPpSUBSTR_REPL_FIRST*/
&& !(o->op_private & (OPpSUBSTR_REPL_FIRST|OPpMAYBE_LVSUB))
&& !(o->op_flags & OPf_MOD)
){
/* Should be a leading ex-pushmark */
OP *pushmark = cBINOPx(o)->op_first;
assert(pushmark->op_type == OP_NULL);
expr = OpSIBLING(pushmark);
offs = OpSIBLING(expr);
/* Gets complicated fast if the expr isn't simple*/
if (expr->op_type != OP_PADSV)
break;
/* Is the offset CONST zero? */
if (offs->op_type != OP_CONST)
break;
SV *offs_sv = cSVOPx_sv(offs);
if (!(SvIOK(offs_sv) && SvIVX(offs_sv) == 0))
break;
len = OpSIBLING(offs);
if (cMAXARG3x(o) == 4) {/* replacement */
/* Is the replacement string CONST ""? */
OP *repl = OpSIBLING(len);
if (repl->op_type != OP_CONST)
break;
SV *repl_sv = cSVOPx_sv(repl);
if(!(SvPOK(repl_sv) && SvCUR(repl_sv) == 0))
break;
}
} else {
break;
}
/* It's on! */
/* Take out the static LENGTH & REPLACMENT OPs */
/* (The finalizer does not seem to change op_next here) */
expr->op_next = offs->op_next;
o->op_private = cMAXARG3x(o);
if (cMAXARG3x(o) == 4)
len->op_next = o;
/* We have a problem if padrange pushes the expr OP for us,
* then jumps straight to the offs CONST OP. For example:
* push @{$pref{ substr($key, 0, 1) }}, $key;
* We don't want to hit that OP, but cannot easily figure
* out if that is going to happen and adjust for it.
* So we have to null out the OP, and then do a fixup in
* B::Deparse. :/ */
op_null(offs);
/* repl status unchanged because it makes Deparsing easier. */
/* Upgrade the SUBSTR to a SUBSTR_LEFT */
OpTYPE_set(o, OP_SUBSTR_LEFT);
/* oldop will be the OP_CONST associated with "" */
/* oldoldop is more unpredictable */
oldoldop = oldop = NULL;
/* pp_substr may be unsuitable for TARGMY optimization
* because of its potential RETPUSHUNDEF, and use of
* bit 4 for OPpSUBSTR_REPL_FIRST, but no such
* problems with pp_substr_left. Must just avoid
* sv == TARG.*/
if (OP_TYPE_IS(o->op_next, OP_PADSV) &&
!(o->op_next->op_private) &&
OP_TYPE_IS(o->op_next->op_next, OP_SASSIGN) &&
(o->op_next->op_targ != expr->op_targ)
) {
OP * padsv = o->op_next;
OP * sassign = padsv->op_next;
/* Carry over some flags */
o->op_flags = OPf_KIDS | (o->op_flags & OPf_PARENS) |
(sassign->op_flags & (OPf_WANT|OPf_PARENS));
o->op_private |= OPpTARGET_MY;
/* Steal the TARG, set op_next pointers*/
o->op_targ = padsv->op_targ;
padsv->op_targ = 0;
o->op_next = sassign->op_next;
/* Null the replaced OPs*/
op_null(padsv);
op_null(sassign);
}
}
break;
case OP_SASSIGN: {
if (OP_GIMME(o,0) == G_VOID
|| ( o->op_next->op_type == OP_LINESEQ

92
pp.c
View File

@ -3717,6 +3717,98 @@ PP_wrapped(pp_substr,
RETPUSHUNDEF;
}
/* OP_SUBSTR_LEFT is a specialized version of OP_SUBSTR, where:
* the EXPR is a PADSV
* the OFFSET is a CONST zero
* the replacement pattern is a CONST ""
* it's definitely not in lvalue context (see the check in pp_substr)
* it definitely doesn't have OPpSUBSTR_REPL_FIRST set
* it may be an rvalue or in void context (may support TARGMY later)
*/
PP(pp_substr_left)
{
dTARGET;
STRLEN curlen;
STRLEN utf8_curlen = 0;
STRLEN byte_len = 0;
SV *sv = PL_stack_sp[-1];
const bool rvalue = (GIMME_V != G_VOID) || (PL_op->op_private & OPpTARGET_MY);
const bool do_chop = (MAXARG3 == 4);
const char *tmps;
if (do_chop) {
SvGETMAGIC(sv);
if (SvROK(sv))
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
"Attempt to use reference as lvalue in substr"
);
tmps = SvPV_force_nomg(sv, curlen);
} else
tmps = SvPV_const(sv, curlen);
if (DO_UTF8(sv)) {
utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
if (utf8_curlen == curlen)
utf8_curlen = 0;
else
curlen = utf8_curlen;
}
/* Inlined, simplified Perl_translate_substr_offsets */
if (curlen) {
const IV len_iv = SvIV(PL_stack_sp[0]);
const int len_is_uv = len_iv == 0 || SvIOK_UV(PL_stack_sp[0]);
if (!len_is_uv && len_iv < 0) { /* Negative length supplied */
const IV pos2_iv = curlen + len_iv;
if (!(curlen-1 > ~(UV)len_iv) && pos2_iv < 0) {
byte_len = 0;
} else if ((UV)pos2_iv > curlen) {
byte_len = (STRLEN)( (UV)curlen);
} else {
byte_len = (STRLEN)( (UV)pos2_iv );
}
} else if ((UV)len_iv <= curlen) { /* Non-negative length supplied */
byte_len = (STRLEN)( (UV)len_iv);
} else {
byte_len = curlen;
}
}
/* End of inlined, simplified Perl_translate_substr_offsets */
if (utf8_curlen) {
/* This could update byte_len, but the return value
will always be zero, which subsequent code has
assumed to be the case. */
sv_or_pv_pos_u2b(sv, tmps, 0, &byte_len);
}
if (rvalue) {
SvTAINTED_off(TARG); /* decontaminate */
SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, tmps, byte_len);
#ifdef USE_LOCALE_COLLATE
sv_unmagic(TARG, PERL_MAGIC_collxfrm);
#endif
if (utf8_curlen)
SvUTF8_on(TARG);
}
if (do_chop) {
SvTAINT(sv);
sv_chop(sv, SvPVX(sv) + byte_len);
SvSETMAGIC(sv);
}
if (rvalue) {
SvSETMAGIC(TARG);
rpp_replace_2_1(TARG);
} else {
rpp_popfree_2();
}
return NORMAL;
}
PP_wrapped(pp_vec, 3, 0)
{
dSP;

1
pp_proto.h generated
View File

@ -283,6 +283,7 @@ PERL_CALLCONV PP(pp_study) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_subst) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_substcont) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_substr) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_substr_left) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_subtract) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_syscall) __attribute__visibility__("hidden");
PERL_CALLCONV PP(pp_sysopen) __attribute__visibility__("hidden");

2
regen/op_private
View File

@ -234,7 +234,7 @@ use strict;
# substr starts off with 4 bits set in
# ck_fun(), but since it never has more than 7
# args, bit 3 is later stolen
qw(substr);
qw(substr substr_left);
$args4{$_} = 1 for keys %maxarg,
grep !$args0{$_} && !$args1{$_}

1
regen/opcodes
View File

@ -200,6 +200,7 @@ abs abs ck_fun fsTu% S?
length length ck_length ifsTu% S?
substr substr ck_substr st@ S S S? S?
substr_left substr left ck_substr sT@ S S S? S?
vec vec ck_fun ist@ S S S
index index ck_index isT@ S S S?

108
t/op/substr_left.t Normal file
View File

@ -0,0 +1,108 @@
BEGIN {
chdir 't';
require './test.pl';
@INC = '../lib';
}
use warnings;
use strict;
my $str; my $result; my $len;
# In each of the tests below, the OP_SUBSTR should have been replaced
# with a specialised OP_SUBSTR_LEFT OP. The tests in this file are
# intended as sanity tests for pp_substr_left's string position
# calculations and treatment of the input `sv` and output TARG.
# Basic functionality with a simple string
$str = "Hello, World!";
$result = substr($str, 0, 5, "");
is($result, "Hello", 'simple case: correct extraction');
is($str, ", World!", 'simple case: remainder is correct');
# LENGTH is zero
$result = substr($str, 0, 0, "");
is($result, "", 'zero length: returns empty string');
is($str, ", World!", 'zero length: EXPR remains unchanged');
# LENGTH is larger than the string
$result = substr($str, 0, 10, "");
is($result, ", World!", 'LENGTH: returns entire string');
is($str, "", 'LENGTH: EXPR is empty');
# EXPR is an empty string
$result = substr($str, 0, 4, "");
is($result, "", 'empty EXPR: returns empty string');
is($str, "", 'empty EXPR: EXPR remains empty');
# EXPR lexical is undef
{
no warnings 'uninitialized';
$str = undef;
$result = substr($str, 0, 2, "");
is($result, "", 'undef EXPR: returns empty string');
is($str, "", 'undef EXPR: EXPR becomes empty string');
# LENGTH is undef
$str = "Hello";
$result = substr($str, 0, undef, "");
is($result, "", 'undef LENGTH: returns empty string');
is($str, "Hello", 'undef LENGTH: EXPR is unchanged');
}
# LENGTH is negative
$result = substr($str, 0, -2, "");
is($result, "Hel", 'negative LENGTH: returns characters 0..length-2');
is($str, "lo", 'negative LENGTH: 2 chars remaining');
# EXPR is numeric (non-string)
$str = 12345678;
$result = substr($str, 0, 6, "");
is($result, "123456", 'IV EXPR: returns stringified characters');
is($str, "78", 'IV EXPR: stringified EXPR');
# LENGTH IS A NV
$str = "Hello, again";
$len = 2.5;
$result = substr($str, 0, $len, "");
is($result, "He", 'NV LENGTH: returns floor() characters');
is($str, "llo, again", 'NV LENGTH: EXPR retains length-floor() characters');
use Tie::Scalar;
{
package TiedScalar;
use base 'Tie::StdScalar';
sub STORE {
my ($self, $value) = @_;
$$self = $value;
}
sub FETCH {
my ($self) = @_;
return $$self;
}
}
# EXPR is a tied variable
my $str2;
tie $str2, 'TiedScalar';
$str2 = "Hello World";
$result = substr($str2, 0, 5, "");
is($result, "Hello", 'tied EXPR: returns correct characters');
is($str2, " World", 'tied EXPR: tied EXPR variable updated correctly');
# TARG is a tied variable
my $result2;
tie $result2, 'TiedScalar';
$result2 = substr($str2, 0, 2, "");
is($result2, " W", 'tied TARG: returns correct characters');
is($str2, "orld", 'tied TARG: tied EXPR variable updated correctly');
# EXPR is a scalar containing UTF-8 string
use utf8;
$str = "Привет мир"; # "Hello world" in Russian
$result = substr($str, 0, 7, "");
is($result, "Привет ", 'UTF-8 EXPR: returns correct UTF-8 characters');
is($str, "мир", 'UTF-8 EXPR: UTF-8 string updated correctly');
# LENGTH is outside of IV range
use Config;
$str = "Hello, Bernard";
my $max_iv = $Config{ivsize} == 8 ? 9_223_372_036_854_775_807 : 2_147_483_647;
$result = substr($str, 0, $max_iv + 1, "");
is($result, "Hello, Bernard", 'UV LENGTH: returns entire string');
is($str, "", 'UV LENGTH: EXPR is emptied');
# EXPR contains binary data
$str = "\x00\x01\x02\x03\x04\x05";
$result = substr($str, 0, 3, "");
is($result, "\x00\x01\x02", 'hex EXPR: returns correct characters');
is($str, "\x03\x04\x05", 'hex EXPR: retains correct characters');
done_testing();

16
t/perf/benchmarks
View File

@ -1779,6 +1779,22 @@
code => 'index $x, "b"',
},
# SUBSTR
'func::substr::nibble_void' => {
desc => 'substr with a zero offset, empty replacement pattern (void)',
setup => 'my $z = "JAPH"x1000',
code => 'substr($z, 0, 2, "")',
},
'func::substr::nibble_lex' => {
desc => 'substr with a zero offset, empty replacement pattern (lex assign)',
setup => 'my $x; my $z = "JAPH"x1000',
code => '$x = substr($z, 0, 2, "")',
},
'func::substr::nibble_gvsv' => {
desc => 'substr with a zero offset, empty replacement pattern (global assign)',
setup => 'our $x; my $z = "JAPH"x1000',
code => '$x = substr($z, 0, 2, "")',
},
# JOIN

78
t/perf/opcount.t
View File

@ -1028,4 +1028,82 @@ test_opcount(0, "foreach 2 lexicals on builtin::indexed LIST",
iter => 1,
});
# substr with const zero offset and "" replacements
test_opcount(0, "substr with const zero offset and '' repl (void)",
sub { my $z; substr($z, 0, 2, "") },
{
substr => 0,
substr_left => 1,
const => 2,
});
test_opcount(0, "substr with const zero offset and '' repl (lexical)",
sub { my $z; my $x = substr($z, 0, 2, "") },
{
substr => 0,
substr_left => 1,
const => 2,
padsv => 3,
sassign => 1
});
test_opcount(0, "substr with const zero offset and '' repl (lexical TARGMY)",
sub { my ($z, $x); $x = substr($z, 0, 2, "") },
{
substr => 0,
substr_left => 1,
const => 2,
padsv => 3,
padsv_store => 0,
sassign => 0
});
test_opcount(0, "substr with const zero offset and '' repl (gv)",
sub { my $z; our $x = substr($z, 0, 2, "") },
{
substr => 0,
substr_left => 1,
const => 2,
gvsv => 1,
sassign => 1
});
test_opcount(0, "substr with const zero offset (void)",
sub { my $z; substr($z, 0, 2) },
{
substr => 0,
substr_left => 1,
const => 1,
});
test_opcount(0, "substr with const zero offset (lexical)",
sub { my $z; my $x = substr($z, 0, 2) },
{
substr => 0,
substr_left => 1,
const => 1,
padsv => 3,
sassign => 1
});
test_opcount(0, "substr with const zero offset (lexical TARGMY)",
sub { my ($z, $x); $x = substr($z, 0, 2) },
{
substr => 0,
substr_left => 1,
const => 1,
padsv => 3,
sassign => 0
});
test_opcount(0, "substr with const zero offset (gv)",
sub { my $z; our $x = substr($z, 0, 2) },
{
substr => 0,
substr_left => 1,
const => 1,
gvsv => 1,
sassign => 1
});
done_testing();