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

Create defer syntax and OP_PUSHDEFER opcode

Browse Source 
Adds syntax `defer { BLOCK }` to create a deferred block; code that is
deferred until the scope exits. This syntax is guarded by

  use feature 'defer';

Adds a new opcode, `OP_PUSHDEFER`, which is a LOGOP whose `op_other` field
gives the start of an optree to be deferred until scope exit. That op
pointer will be stored on the save stack and invoked as part of scope
unwind.

Included is support for `B::Deparse` to deparse the optree back into
syntax.
This commit is contained in:
Paul "LeoNerd" Evans 2021-07-27 14:55:14 +01:00 committed by Paul Evans
parent 4b21956ed6
commit f79e2ff95f
42 changed files with 2351 additions and 1682 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
MANIFEST
View File

@ -5852,6 +5852,7 @@ t/op/crypt.t See if crypt works
t/op/current_sub.t __SUB__ tests
t/op/dbm.t See if dbmopen/dbmclose work
t/op/decl-refs.t See if my \$foo works
t/op/defer.t See if defer blocks work
t/op/defined.t See if defined() edge cases work
t/op/defins.t See if auto-insert of defined() works
t/op/delete.t See if delete works

1
cop.h
View File

@ -1047,6 +1047,7 @@ struct context {
#define CXt_FORMAT 10
#define CXt_EVAL 11 /* eval'', eval{}, try{} */
#define CXt_SUBST 12
#define CXt_DEFER 13
/* SUBST doesn't feature in all switch statements. */
/* private flags for CXt_SUB and CXt_FORMAT */

1
embed.fnc
View File

@ -1460,6 +1460,7 @@ ApdR |OP* |newSTATEOP |I32 flags|NULLOK char* label|NULLOK OP* o
AdpbM |CV* |newSUB |I32 floor|NULLOK OP* o|NULLOK OP* proto \
|NULLOK OP* block
ApdRx |OP* |newTRYCATCHOP |I32 flags|NN OP* tryblock|NN OP *catchvar|NN OP* catchblock
ApdRx |OP* |newDEFEROP |I32 flags|NN OP *block
pd |CV * |newXS_len_flags|NULLOK const char *name|STRLEN len \
|NN XSUBADDR_t subaddr\
|NULLOK const char *const filename \

1
embed.h
View File

@ -352,6 +352,7 @@
#define newCONSTSUB(a,b,c) Perl_newCONSTSUB(aTHX_ a,b,c)
#define newCONSTSUB_flags(a,b,c,d,e) Perl_newCONSTSUB_flags(aTHX_ a,b,c,d,e)
#define newCVREF(a,b) Perl_newCVREF(aTHX_ a,b)
#define newDEFEROP(a,b) Perl_newDEFEROP(aTHX_ a,b)
#define newDEFSVOP() Perl_newDEFSVOP(aTHX)
#define newFORM(a,b,c) Perl_newFORM(aTHX_ a,b,c)
#define newFOROP(a,b,c,d,e) Perl_newFOROP(aTHX_ a,b,c,d,e)

2
ext/Opcode/Opcode.pm
View File

@ -441,6 +441,8 @@ These are a hotchpotch of opcodes still waiting to be considered
break continue
smartmatch
pushdefer
custom -- where should this go
=item :base_math

43
feature.h
View File

@ -16,20 +16,21 @@
#define FEATURE_BITWISE_BIT 0x0002
#define FEATURE___SUB___BIT 0x0004
#define FEATURE_MYREF_BIT 0x0008
#define FEATURE_EVALBYTES_BIT 0x0010
#define FEATURE_FC_BIT 0x0020
#define FEATURE_INDIRECT_BIT 0x0040
#define FEATURE_ISA_BIT 0x0080
#define FEATURE_MULTIDIMENSIONAL_BIT 0x0100
#define FEATURE_POSTDEREF_QQ_BIT 0x0200
#define FEATURE_REFALIASING_BIT 0x0400
#define FEATURE_SAY_BIT 0x0800
#define FEATURE_SIGNATURES_BIT 0x1000
#define FEATURE_STATE_BIT 0x2000
#define FEATURE_SWITCH_BIT 0x4000
#define FEATURE_TRY_BIT 0x8000
#define FEATURE_UNIEVAL_BIT 0x10000
#define FEATURE_UNICODE_BIT 0x20000
#define FEATURE_DEFER_BIT 0x0010
#define FEATURE_EVALBYTES_BIT 0x0020
#define FEATURE_FC_BIT 0x0040
#define FEATURE_INDIRECT_BIT 0x0080
#define FEATURE_ISA_BIT 0x0100
#define FEATURE_MULTIDIMENSIONAL_BIT 0x0200
#define FEATURE_POSTDEREF_QQ_BIT 0x0400
#define FEATURE_REFALIASING_BIT 0x0800
#define FEATURE_SAY_BIT 0x1000
#define FEATURE_SIGNATURES_BIT 0x2000
#define FEATURE_STATE_BIT 0x4000
#define FEATURE_SWITCH_BIT 0x8000
#define FEATURE_TRY_BIT 0x10000
#define FEATURE_UNIEVAL_BIT 0x20000
#define FEATURE_UNICODE_BIT 0x40000
#define FEATURE_BUNDLE_DEFAULT 0
#define FEATURE_BUNDLE_510 1
@ -80,6 +81,12 @@
FEATURE_IS_ENABLED_MASK(FEATURE_TRY_BIT) \
)
#define FEATURE_DEFER_IS_ENABLED \
( \
CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
FEATURE_IS_ENABLED_MASK(FEATURE_DEFER_BIT) \
)
#define FEATURE_STATE_IS_ENABLED \
( \
(CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \
@ -268,6 +275,14 @@ S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen,
}
return;
case 'd':
if (keylen == sizeof("feature_defer")-1
&& memcmp(subf+1, "efer", keylen - sizeof("feature_")) == 0) {
mask = FEATURE_DEFER_BIT;
break;
}
return;
case 'e':
if (keylen == sizeof("feature_evalbytes")-1
&& memcmp(subf+1, "valbytes", keylen - sizeof("feature_")) == 0) {

2
gv.c
View File

@ -545,7 +545,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
no support for funcs that do not parse like funcs */
case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
case KEY_BEGIN : case KEY_CHECK : case KEY_catch : case KEY_cmp:
case KEY_default : case KEY_DESTROY:
case KEY_default : case KEY_defer : case KEY_DESTROY:
case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
case KEY_END : case KEY_eq : case KEY_eval :
case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :

15
keywords.c
View File

@ -978,7 +978,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
goto unknown;
}
case 5: /* 40 tokens of length 5 */
case 5: /* 41 tokens of length 5 */
switch (name[0])
{
case 'B':
@ -1142,6 +1142,17 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
goto unknown;
}
case 'd':
if (name[1] == 'e' &&
name[2] == 'f' &&
name[3] == 'e' &&
name[4] == 'r')
{ /* defer */
return (all_keywords || FEATURE_DEFER_IS_ENABLED ? KEY_defer : 0);
}
goto unknown;
case 'e':
if (name[1] == 'l' &&
name[2] == 's' &&
@ -3475,5 +3486,5 @@ unknown:
}
/* Generated from:
* 3a4f2004642b00b871c01cbdc018f6ca5ead6b4e0b2b184120c60b0b62a229dd regen/keywords.pl
* de1ee232f68ea8ae75d09f4f70b58fee8a6e6244dec3ab68baab54f7af9ce306 regen/keywords.pl
* ex: set ro: */

435
keywords.h
View File

@ -55,223 +55,224 @@
#define KEY_dbmclose 39
#define KEY_dbmopen 40
#define KEY_default 41
#define KEY_defined 42
#define KEY_delete 43
#define KEY_die 44
#define KEY_do 45
#define KEY_dump 46
#define KEY_each 47
#define KEY_else 48
#define KEY_elsif 49
#define KEY_endgrent 50
#define KEY_endhostent 51
#define KEY_endnetent 52
#define KEY_endprotoent 53
#define KEY_endpwent 54
#define KEY_endservent 55
#define KEY_eof 56
#define KEY_eq 57
#define KEY_eval 58
#define KEY_evalbytes 59
#define KEY_exec 60
#define KEY_exists 61
#define KEY_exit 62
#define KEY_exp 63
#define KEY_fc 64
#define KEY_fcntl 65
#define KEY_fileno 66
#define KEY_flock 67
#define KEY_for 68
#define KEY_foreach 69
#define KEY_fork 70
#define KEY_format 71
#define KEY_formline 72
#define KEY_ge 73
#define KEY_getc 74
#define KEY_getgrent 75
#define KEY_getgrgid 76
#define KEY_getgrnam 77
#define KEY_gethostbyaddr 78
#define KEY_gethostbyname 79
#define KEY_gethostent 80
#define KEY_getlogin 81
#define KEY_getnetbyaddr 82
#define KEY_getnetbyname 83
#define KEY_getnetent 84
#define KEY_getpeername 85
#define KEY_getpgrp 86
#define KEY_getppid 87
#define KEY_getpriority 88
#define KEY_getprotobyname 89
#define KEY_getprotobynumber 90
#define KEY_getprotoent 91
#define KEY_getpwent 92
#define KEY_getpwnam 93
#define KEY_getpwuid 94
#define KEY_getservbyname 95
#define KEY_getservbyport 96
#define KEY_getservent 97
#define KEY_getsockname 98
#define KEY_getsockopt 99
#define KEY_given 100
#define KEY_glob 101
#define KEY_gmtime 102
#define KEY_goto 103
#define KEY_grep 104
#define KEY_gt 105
#define KEY_hex 106
#define KEY_if 107
#define KEY_index 108
#define KEY_int 109
#define KEY_ioctl 110
#define KEY_isa 111
#define KEY_join 112
#define KEY_keys 113
#define KEY_kill 114
#define KEY_last 115
#define KEY_lc 116
#define KEY_lcfirst 117
#define KEY_le 118
#define KEY_length 119
#define KEY_link 120
#define KEY_listen 121
#define KEY_local 122
#define KEY_localtime 123
#define KEY_lock 124
#define KEY_log 125
#define KEY_lstat 126
#define KEY_lt 127
#define KEY_m 128
#define KEY_map 129
#define KEY_mkdir 130
#define KEY_msgctl 131
#define KEY_msgget 132
#define KEY_msgrcv 133
#define KEY_msgsnd 134
#define KEY_my 135
#define KEY_ne 136
#define KEY_next 137
#define KEY_no 138
#define KEY_not 139
#define KEY_oct 140
#define KEY_open 141
#define KEY_opendir 142
#define KEY_or 143
#define KEY_ord 144
#define KEY_our 145
#define KEY_pack 146
#define KEY_package 147
#define KEY_pipe 148
#define KEY_pop 149
#define KEY_pos 150
#define KEY_print 151
#define KEY_printf 152
#define KEY_prototype 153
#define KEY_push 154
#define KEY_q 155
#define KEY_qq 156
#define KEY_qr 157
#define KEY_quotemeta 158
#define KEY_qw 159
#define KEY_qx 160
#define KEY_rand 161
#define KEY_read 162
#define KEY_readdir 163
#define KEY_readline 164
#define KEY_readlink 165
#define KEY_readpipe 166
#define KEY_recv 167
#define KEY_redo 168
#define KEY_ref 169
#define KEY_rename 170
#define KEY_require 171
#define KEY_reset 172
#define KEY_return 173
#define KEY_reverse 174
#define KEY_rewinddir 175
#define KEY_rindex 176
#define KEY_rmdir 177
#define KEY_s 178
#define KEY_say 179
#define KEY_scalar 180
#define KEY_seek 181
#define KEY_seekdir 182
#define KEY_select 183
#define KEY_semctl 184
#define KEY_semget 185
#define KEY_semop 186
#define KEY_send 187
#define KEY_setgrent 188
#define KEY_sethostent 189
#define KEY_setnetent 190
#define KEY_setpgrp 191
#define KEY_setpriority 192
#define KEY_setprotoent 193
#define KEY_setpwent 194
#define KEY_setservent 195
#define KEY_setsockopt 196
#define KEY_shift 197
#define KEY_shmctl 198
#define KEY_shmget 199
#define KEY_shmread 200
#define KEY_shmwrite 201
#define KEY_shutdown 202
#define KEY_sin 203
#define KEY_sleep 204
#define KEY_socket 205
#define KEY_socketpair 206
#define KEY_sort 207
#define KEY_splice 208
#define KEY_split 209
#define KEY_sprintf 210
#define KEY_sqrt 211
#define KEY_srand 212
#define KEY_stat 213
#define KEY_state 214
#define KEY_study 215
#define KEY_sub 216
#define KEY_substr 217
#define KEY_symlink 218
#define KEY_syscall 219
#define KEY_sysopen 220
#define KEY_sysread 221
#define KEY_sysseek 222
#define KEY_system 223
#define KEY_syswrite 224
#define KEY_tell 225
#define KEY_telldir 226
#define KEY_tie 227
#define KEY_tied 228
#define KEY_time 229
#define KEY_times 230
#define KEY_tr 231
#define KEY_try 232
#define KEY_truncate 233
#define KEY_uc 234
#define KEY_ucfirst 235
#define KEY_umask 236
#define KEY_undef 237
#define KEY_unless 238
#define KEY_unlink 239
#define KEY_unpack 240
#define KEY_unshift 241
#define KEY_untie 242
#define KEY_until 243
#define KEY_use 244
#define KEY_utime 245
#define KEY_values 246
#define KEY_vec 247
#define KEY_wait 248
#define KEY_waitpid 249
#define KEY_wantarray 250
#define KEY_warn 251
#define KEY_when 252
#define KEY_while 253
#define KEY_write 254
#define KEY_x 255
#define KEY_xor 256
#define KEY_y 257
#define KEY_defer 42
#define KEY_defined 43
#define KEY_delete 44
#define KEY_die 45
#define KEY_do 46
#define KEY_dump 47
#define KEY_each 48
#define KEY_else 49
#define KEY_elsif 50
#define KEY_endgrent 51
#define KEY_endhostent 52
#define KEY_endnetent 53
#define KEY_endprotoent 54
#define KEY_endpwent 55
#define KEY_endservent 56
#define KEY_eof 57
#define KEY_eq 58
#define KEY_eval 59
#define KEY_evalbytes 60
#define KEY_exec 61
#define KEY_exists 62
#define KEY_exit 63
#define KEY_exp 64
#define KEY_fc 65
#define KEY_fcntl 66
#define KEY_fileno 67
#define KEY_flock 68
#define KEY_for 69
#define KEY_foreach 70
#define KEY_fork 71
#define KEY_format 72
#define KEY_formline 73
#define KEY_ge 74
#define KEY_getc 75
#define KEY_getgrent 76
#define KEY_getgrgid 77
#define KEY_getgrnam 78
#define KEY_gethostbyaddr 79
#define KEY_gethostbyname 80
#define KEY_gethostent 81
#define KEY_getlogin 82
#define KEY_getnetbyaddr 83
#define KEY_getnetbyname 84
#define KEY_getnetent 85
#define KEY_getpeername 86
#define KEY_getpgrp 87
#define KEY_getppid 88
#define KEY_getpriority 89
#define KEY_getprotobyname 90
#define KEY_getprotobynumber 91
#define KEY_getprotoent 92
#define KEY_getpwent 93
#define KEY_getpwnam 94
#define KEY_getpwuid 95
#define KEY_getservbyname 96
#define KEY_getservbyport 97
#define KEY_getservent 98
#define KEY_getsockname 99
#define KEY_getsockopt 100
#define KEY_given 101
#define KEY_glob 102
#define KEY_gmtime 103
#define KEY_goto 104
#define KEY_grep 105
#define KEY_gt 106
#define KEY_hex 107
#define KEY_if 108
#define KEY_index 109
#define KEY_int 110
#define KEY_ioctl 111
#define KEY_isa 112
#define KEY_join 113
#define KEY_keys 114
#define KEY_kill 115
#define KEY_last 116
#define KEY_lc 117
#define KEY_lcfirst 118
#define KEY_le 119
#define KEY_length 120
#define KEY_link 121
#define KEY_listen 122
#define KEY_local 123
#define KEY_localtime 124
#define KEY_lock 125
#define KEY_log 126
#define KEY_lstat 127
#define KEY_lt 128
#define KEY_m 129
#define KEY_map 130
#define KEY_mkdir 131
#define KEY_msgctl 132
#define KEY_msgget 133
#define KEY_msgrcv 134
#define KEY_msgsnd 135
#define KEY_my 136
#define KEY_ne 137
#define KEY_next 138
#define KEY_no 139
#define KEY_not 140
#define KEY_oct 141
#define KEY_open 142
#define KEY_opendir 143
#define KEY_or 144
#define KEY_ord 145
#define KEY_our 146
#define KEY_pack 147
#define KEY_package 148
#define KEY_pipe 149
#define KEY_pop 150
#define KEY_pos 151
#define KEY_print 152
#define KEY_printf 153
#define KEY_prototype 154
#define KEY_push 155
#define KEY_q 156
#define KEY_qq 157
#define KEY_qr 158
#define KEY_quotemeta 159
#define KEY_qw 160
#define KEY_qx 161
#define KEY_rand 162
#define KEY_read 163
#define KEY_readdir 164
#define KEY_readline 165
#define KEY_readlink 166
#define KEY_readpipe 167
#define KEY_recv 168
#define KEY_redo 169
#define KEY_ref 170
#define KEY_rename 171
#define KEY_require 172
#define KEY_reset 173
#define KEY_return 174
#define KEY_reverse 175
#define KEY_rewinddir 176
#define KEY_rindex 177
#define KEY_rmdir 178
#define KEY_s 179
#define KEY_say 180
#define KEY_scalar 181
#define KEY_seek 182
#define KEY_seekdir 183
#define KEY_select 184
#define KEY_semctl 185
#define KEY_semget 186
#define KEY_semop 187
#define KEY_send 188
#define KEY_setgrent 189
#define KEY_sethostent 190
#define KEY_setnetent 191
#define KEY_setpgrp 192
#define KEY_setpriority 193
#define KEY_setprotoent 194
#define KEY_setpwent 195
#define KEY_setservent 196
#define KEY_setsockopt 197
#define KEY_shift 198
#define KEY_shmctl 199
#define KEY_shmget 200
#define KEY_shmread 201
#define KEY_shmwrite 202
#define KEY_shutdown 203
#define KEY_sin 204
#define KEY_sleep 205
#define KEY_socket 206
#define KEY_socketpair 207
#define KEY_sort 208
#define KEY_splice 209
#define KEY_split 210
#define KEY_sprintf 211
#define KEY_sqrt 212
#define KEY_srand 213
#define KEY_stat 214
#define KEY_state 215
#define KEY_study 216
#define KEY_sub 217
#define KEY_substr 218
#define KEY_symlink 219
#define KEY_syscall 220
#define KEY_sysopen 221
#define KEY_sysread 222
#define KEY_sysseek 223
#define KEY_system 224
#define KEY_syswrite 225
#define KEY_tell 226
#define KEY_telldir 227
#define KEY_tie 228
#define KEY_tied 229
#define KEY_time 230
#define KEY_times 231
#define KEY_tr 232
#define KEY_try 233
#define KEY_truncate 234
#define KEY_uc 235
#define KEY_ucfirst 236
#define KEY_umask 237
#define KEY_undef 238
#define KEY_unless 239
#define KEY_unlink 240
#define KEY_unpack 241
#define KEY_unshift 242
#define KEY_untie 243
#define KEY_until 244
#define KEY_use 245
#define KEY_utime 246
#define KEY_values 247
#define KEY_vec 248
#define KEY_wait 249
#define KEY_waitpid 250
#define KEY_wantarray 251
#define KEY_warn 252
#define KEY_when 253
#define KEY_while 254
#define KEY_write 255
#define KEY_x 256
#define KEY_xor 257
#define KEY_y 258
/* Generated from:
* 3a4f2004642b00b871c01cbdc018f6ca5ead6b4e0b2b184120c60b0b62a229dd regen/keywords.pl
* de1ee232f68ea8ae75d09f4f70b58fee8a6e6244dec3ab68baab54f7af9ce306 regen/keywords.pl
* ex: set ro: */

1
lib/B/Deparse-core.t
View File

@ -366,6 +366,7 @@ my %not_tested = map { $_ => 1} qw(
UNITCHECK
catch
default
defer
else
elsif
for

12
lib/B/Deparse.pm
View File

@ -52,7 +52,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
MDEREF_SHIFT
);
$VERSION = '1.57';
$VERSION = '1.58';
use strict;
our $AUTOLOAD;
use warnings ();
@ -2306,6 +2306,7 @@ my %feature_keywords = (
fc => 'fc',
try => 'try',
catch => 'try',
defer => 'defer',
);
# keywords that are strong and also have a prototype
@ -6582,6 +6583,15 @@ sub pp_argdefelem {
}
sub pp_pushdefer {
my $self = shift;
my($op, $cx) = @_;
# defer block body is stored in the ->first of an OP_NULL that is
# ->first of OP_PUSHDEFER
my $body = $self->deparse($op->first->first);
return "defer {\n\t$body\n\b}\cK";
}
1;
__END__

6
lib/B/Deparse.t
View File

@ -3180,3 +3180,9 @@ catch($var) {
my $x;
SECOND();
}
####
# defer blocks
# CONTEXT use feature "defer"; no warnings 'experimental::defer';
defer {
$a = 123;
}

1
lib/B/Op_private.pm
View File

@ -477,6 +477,7 @@ $bits{predec}{0} = $bf[0];
$bits{preinc}{0} = $bf[0];
$bits{prototype}{0} = $bf[0];
@{$bits{push}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{pushdefer}{0} = $bf[0];
$bits{quotemeta}{0} = $bf[0];
@{$bits{rand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{range}{0} = $bf[0];

11
lib/feature.pm
View File

@ -5,13 +5,14 @@
package feature;
our $VERSION = '1.67';
our $VERSION = '1.68';
our %feature = (
fc => 'feature_fc',
isa => 'feature_isa',
say => 'feature_say',
try => 'feature_try',
defer => 'feature_defer',
state => 'feature_state',
switch => 'feature_switch',
bitwise => 'feature_bitwise',
@ -35,7 +36,7 @@ our %feature_bundle = (
"5.23" => [qw(bareword_filehandles current_sub evalbytes fc indirect multidimensional postderef_qq say state switch unicode_eval unicode_strings)],
"5.27" => [qw(bareword_filehandles bitwise current_sub evalbytes fc indirect multidimensional postderef_qq say state switch unicode_eval unicode_strings)],
"5.35" => [qw(bareword_filehandles bitwise current_sub evalbytes fc indirect multidimensional postderef_qq say state unicode_eval unicode_strings)],
"all" => [qw(bareword_filehandles bitwise current_sub declared_refs evalbytes fc indirect isa multidimensional postderef_qq refaliasing say signatures state switch try unicode_eval unicode_strings)],
"all" => [qw(bareword_filehandles bitwise current_sub declared_refs defer evalbytes fc indirect isa multidimensional postderef_qq refaliasing say signatures state switch try unicode_eval unicode_strings)],
"default" => [qw(bareword_filehandles indirect multidimensional)],
);
@ -431,6 +432,12 @@ C<try> are caught by executing the body of the C<catch> block.
For more information, see L<perlsyn/"Try Catch Exception Handling">.
=head2 The 'defer' feature
This feature enables the C<defer> block syntax, which allows a block of code
to be deferred until when the flow of control leaves the block which contained
it. For more details, see L<perlsyn/defer>.
=head1 FEATURE BUNDLES
It's possible to load multiple features together, using

17
lib/warnings.pm
View File

@ -5,7 +5,7 @@
package warnings;
our $VERSION = "1.53";
our $VERSION = "1.54";
# Verify that we're called correctly so that warnings will work.
# Can't use Carp, since Carp uses us!
@ -111,6 +111,9 @@ our %Offsets = (
# Warnings Categories added in Perl 5.033
'experimental::try' => 146,
# Warnings Categories added in Perl 5.035
'experimental::defer' => 148,
);
our %Bits = (
@ -124,11 +127,12 @@ our %Bits = (
'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x51\x05\x54\x54\x05", # [51..56,58..61,65..67,69..73]
'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x51\x05\x54\x54\x15", # [51..56,58..61,65..67,69..74]
'experimental::alpha_assertions' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [66]
'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [58]
'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [59]
'experimental::declared_refs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [65]
'experimental::defer' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [74]
'experimental::isa' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [72]
'experimental::lexical_subs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [52]
'experimental::postderef' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [55]
@ -201,11 +205,12 @@ our %DeadBits = (
'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\xa2\x0a\xa8\xa8\x0a", # [51..56,58..61,65..67,69..73]
'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\xa2\x0a\xa8\xa8\x2a", # [51..56,58..61,65..67,69..74]
'experimental::alpha_assertions' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [66]
'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [58]
'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [59]
'experimental::declared_refs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [65]
'experimental::defer' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [74]
'experimental::isa' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [72]
'experimental::lexical_subs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [52]
'experimental::postderef' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [55]
@ -269,8 +274,8 @@ our %DeadBits = (
# These are used by various things, including our own tests
our $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
our $DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x51\x15\x54\x54\x05"; # [2,4,22,23,25,52..56,58..62,65..67,69..73]
our $LAST_BIT = 148 ;
our $DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x51\x15\x54\x54\x15"; # [2,4,22,23,25,52..56,58..62,65..67,69..74]
our $LAST_BIT = 150 ;
our $BYTES = 19 ;
sub Croaker
@ -876,6 +881,8 @@ The current hierarchy is:
| |
| +- experimental::declared_refs
| |
| +- experimental::defer
| |
| +- experimental::isa
| |
| +- experimental::lexical_subs

38
op.c
View File

@ -10612,6 +10612,43 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block)
return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
/*
=for apidoc newDEFEROP
Constructs and returns a deferred-block statement that implements the
C<defer> semantics. The C<block> optree is consumed by this function and
becomes part of the returned optree.
The C<flags> argument is currently ignored.
=cut
*/
OP *
Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
{
OP *o, *start, *blockfirst;
PERL_ARGS_ASSERT_NEWDEFEROP;
PERL_UNUSED_ARG(flags);
start = LINKLIST(block);
/* Hide the block inside an OP_NULL with no exection */
block = newUNOP(OP_NULL, 0, block);
block->op_next = block;
o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
o->op_flags |= OPf_WANT_VOID;
/* Terminate the block */
blockfirst = cUNOPx(block)->op_first;
assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE);
blockfirst->op_next = NULL;
return o;
}
/* must not conflict with SVf_UTF8 */
#define CV_CKPROTO_CURSTASH 0x1
@ -17748,6 +17785,7 @@ Perl_rpeep(pTHX_ OP *o)
case OP_OR:
case OP_DOR:
case OP_CMPCHAIN_AND:
case OP_PUSHDEFER:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
while (o->op_next && ( o->op_type == o->op_next->op_type

9
opcode.h
View File

@ -553,6 +553,7 @@ EXTCONST char* const PL_op_name[] = {
"leavetrycatch",
"poptry",
"catch",
"pushdefer",
"freed",
};
#endif
@ -965,6 +966,7 @@ EXTCONST char* const PL_op_desc[] = {
"try {block} exit",
"pop try",
"catch {} block",
"push defer {} block",
"freed op",
};
#endif
@ -1380,6 +1382,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
Perl_pp_leavetrycatch,
Perl_pp_poptry,
Perl_pp_catch,
Perl_pp_pushdefer,
}
#endif
;
@ -1791,6 +1794,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
Perl_ck_null, /* leavetrycatch */
Perl_ck_null, /* poptry */
Perl_ck_null, /* catch */
Perl_ck_null, /* pushdefer */
}
#endif
;
@ -2203,6 +2207,7 @@ EXTCONST U32 PL_opargs[] = {
0x00000400, /* leavetrycatch */
0x00000400, /* poptry */
0x00000300, /* catch */
0x00000300, /* pushdefer */
};
#endif
@ -2870,6 +2875,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
-1, /* leavetrycatch */
-1, /* poptry */
0, /* catch */
0, /* pushdefer */
};
@ -2888,7 +2894,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
*/
EXTCONST U16 PL_op_private_bitdefs[] = {
0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, entertrycatch, catch */
0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, entertrycatch, catch, pushdefer */
0x2fdc, 0x40d9, /* pushmark */
0x00bd, /* wantarray, runcv */
0x0438, 0x1a50, 0x418c, 0x3d28, 0x3505, /* const */
@ -3370,6 +3376,7 @@ EXTCONST U8 PL_op_private_valid[] = {
/* LEAVETRYCATCH */ (0),
/* POPTRY */ (0),
/* CATCH */ (OPpARG1_MASK),
/* PUSHDEFER */ (OPpARG1_MASK),
};

3
opnames.h
View File

@ -418,10 +418,11 @@ typedef enum opcode {
OP_LEAVETRYCATCH = 401,
OP_POPTRY = 402,
OP_CATCH = 403,
OP_PUSHDEFER = 404,
OP_max
} opcode;
#define MAXO 404
#define MAXO 405
#define OP_FREED MAXO
/* the OP_IS_* macros are optimized to a simple range check because

3
perl.h
View File

@ -5288,7 +5288,8 @@ EXTCONST char* const PL_block_type[] = {
"SUB",
"FORMAT",
"EVAL",
"SUBST"
"SUBST",
"DEFER"
};
#else
EXTCONST char* PL_block_type[];

1104
perly.act
View File

File diff suppressed because it is too large Load Diff

65
perly.h
View File

@ -135,37 +135,38 @@ extern int yydebug;
FORMRBRACK = 334,
SUBLEXSTART = 335,
SUBLEXEND = 336,
PREC_LOW = 337,
OROP = 338,
ANDOP = 339,
NOTOP = 340,
ASSIGNOP = 341,
PERLY_QUESTION_MARK = 342,
PERLY_COLON = 343,
OROR = 344,
DORDOR = 345,
ANDAND = 346,
BITOROP = 347,
BITANDOP = 348,
CHEQOP = 349,
NCEQOP = 350,
CHRELOP = 351,
NCRELOP = 352,
SHIFTOP = 353,
MATCHOP = 354,
PERLY_EXCLAMATION_MARK = 355,
PERLY_TILDE = 356,
UMINUS = 357,
REFGEN = 358,
POWOP = 359,
PREINC = 360,
PREDEC = 361,
POSTINC = 362,
POSTDEC = 363,
POSTJOIN = 364,
ARROW = 365,
PERLY_PAREN_CLOSE = 366,
PERLY_PAREN_OPEN = 367
DEFER = 337,
PREC_LOW = 338,
OROP = 339,
ANDOP = 340,
NOTOP = 341,
ASSIGNOP = 342,
PERLY_QUESTION_MARK = 343,
PERLY_COLON = 344,
OROR = 345,
DORDOR = 346,
ANDAND = 347,
BITOROP = 348,
BITANDOP = 349,
CHEQOP = 350,
NCEQOP = 351,
CHRELOP = 352,
NCRELOP = 353,
SHIFTOP = 354,
MATCHOP = 355,
PERLY_EXCLAMATION_MARK = 356,
PERLY_TILDE = 357,
UMINUS = 358,
REFGEN = 359,
POWOP = 360,
PREINC = 361,
PREDEC = 362,
POSTINC = 363,
POSTDEC = 364,
POSTJOIN = 365,
ARROW = 366,
PERLY_PAREN_CLOSE = 367,
PERLY_PAREN_OPEN = 368
};
#endif
@ -218,6 +219,6 @@ int yyparse (void);
/* Generated from:
* 427b422b0ce1154d834dc461973a3254729575694f98ab600032f67ccab7b9e5 perly.y
* 3759c9ee4ef2ae2879c32641e36adc50c85c0dc40dd6283752cdcac7e736fa5f perly.y
* acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl
* ex: set ro: */

1712
perly.tab
View File

File diff suppressed because it is too large Load Diff

5
perly.y
View File

@ -77,6 +77,7 @@
%token <ival> LOCAL MY REQUIRE
%token <ival> COLONATTR FORMLBRACK FORMRBRACK
%token <ival> SUBLEXSTART SUBLEXEND
%token <ival> DEFER
%type <ival> grammar remember mremember
%type <ival> startsub startanonsub startformsub
@ -494,6 +495,10 @@ barestmt: PLUGSTMT
{
$$ = $sideff;
}
| DEFER mblock
{
$$ = newDEFEROP(0, op_scope($2));
}
| YADAYADA PERLY_SEMICOLON
{
$$ = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),

8
pod/perldelta.pod
View File

@ -27,6 +27,14 @@ here, but most should go in the L</Performance Enhancements> section.
[ List each enhancement as a =head2 entry ]
=head2 C<defer> blocks
This release adds support for C<defer> blocks, which are blocks of code
prefixed by the C<defer> modifier. They provide a section of code which runs
at a later time, during scope exit.
For more information, see L<perlsyn/"defer blocks">.
=head1 Security
XXX Any security-related notices go here. In particular, any security

13
pod/perldiag.pod
View File

@ -757,6 +757,12 @@ of C<SV*> scalars containing the arguments.
integer format can only be used with positive integers, and you attempted
to compress something else. See L<perlfunc/pack>.
=item Can't "%s" out of a defer block
(F) An attempt was made to jump out of the scope of a defer block by using
a control-flow statement such as C<return>, C<goto> or a loop control. This is
not permitted.
=item Can't bless non-reference value
(F) Only hard references may be blessed. This is how Perl "enforces"
@ -2452,6 +2458,13 @@ a literal dollar sign, or was meant to introduce a variable name that
happens to be missing. So you have to put either the backslash or the
name.
=item defer is experimental
(S experimental::defer) The C<defer> block modifier is experimental. If you
want to use the feature, disable the warning with
C<no warnings 'experimental::defer'>, but know that in doing so you are taking
the risk that your code may break in a future Perl version.
=item flock() on closed filehandle %s
(W closed) The filehandle you're attempting to flock() got itself closed

4
pod/perlmod.pod
View File

@ -345,6 +345,10 @@ X<$?>
Inside of a C<END> block, the value of C<${^GLOBAL_PHASE}> will be
C<"END">.
Similar to an C<END> block are C<defer> blocks, though they operate on the
lifetime of individual block scopes, rather than the program as a whole. They
are documented in L<perlsyn/defer>.
C<UNITCHECK>, C<CHECK> and C<INIT> code blocks are useful to catch the
transition between the compilation phase and the execution phase of
the main program.

81
pod/perlsyn.pod
View File

@ -710,6 +710,87 @@ Such constructs are quite frequently used, both because older versions of
Perl had no official C<switch> statement, and also because the new version
described immediately below remains experimental and can sometimes be confusing.
=head2 defer blocks
X<defer>
A block prefixed by the C<defer> modifier provides a section of code which
runs at a later time during scope exit.
A C<defer> block can appear at any point where a regular block or other
statement is permitted. If the flow of execution reaches this statement, the
body of the block is stored for later, but not invoked immediately. When the
flow of control leaves the containing block for any reason, this stored block
is executed on the way past. It provides a means of deferring execution until
a later time. This acts similarly to syntax provided by some other languages,
often using keywords named C<try / finally>.
This syntax is available if enabled by the C<defer> named feature, and is
currently experimental. If experimental warnings are enabled it will emit a
warning when used.
use feature 'defer';
{
say "This happens first";
defer { say "This happens last"; }
say "And this happens inbetween";
}
If multiple C<defer> blocks are contained in a single scope, they are
executed in LIFO order; the last one reached is the first one executed.
The code stored by the C<defer> block will be invoked when control leaves
its containing block due to regular fallthrough, explicit C<return>,
exceptions thrown by C<die> or propagated by functions called by it, C<goto>,
or any of the loop control statements C<next>, C<last> or C<redo>.
If the flow of control does not reach the C<defer> statement itself then its
body is not stored for later execution. (This is in direct contrast to the
code provided by an C<END> phaser block, which is always enqueued by the
compiler, regardless of whether execution ever reached the line it was given
on.)
use feature 'defer';
{
defer { say "This will run"; }
return;
defer { say "This will not"; }
}
Exceptions thrown by code inside a C<defer> block will propagate to the
caller in the same way as any other exception thrown by normal code.
If the C<defer> block is being executed due to a thrown exception and throws
another one it is not specified what happens, beyond that the caller will
definitely receive an exception.
Besides throwing an exception, a C<defer> block is not permitted to
otherwise alter the control flow of its surrounding code. In particular, it
may not cause its containing function to C<return>, nor may it C<goto> a
label, or control a containing loop using C<next>, C<last> or C<redo>. These
constructions are however, permitted entirely within the body of the
C<defer>.
use feature 'defer';
{
defer {
foreach ( 1 .. 5 ) {
last if $_ == 3; # this is permitted
}
}
}
{
foreach ( 6 .. 10 ) {
defer {
last if $_ == 8; # this is not
}
}
}
=head2 Switch Statements
X<switch> X<case> X<given> X<when> X<default>

68
pp_ctl.c
View File

@ -1325,6 +1325,7 @@ static const char * const context_name[] = {
"format",
"eval",
"substitution",
"defer block",
};
STATIC I32
@ -1622,6 +1623,7 @@ Perl_dounwind(pTHX_ I32 cxix)
break;
case CXt_BLOCK:
case CXt_NULL:
case CXt_DEFER:
/* these two don't have a POPFOO() */
break;
case CXt_FORMAT:
@ -2488,6 +2490,12 @@ PP(pp_return)
assert(cxstack_ix >= 0);
if (cxix < cxstack_ix) {
I32 i;
/* Check for defer { return; } */
for(i = cxstack_ix; i > cxix; i--) {
if(CxTYPE(&cxstack[i]) == CXt_DEFER)
Perl_croak(aTHX_ "Can't \"%s\" out of a defer block", "return");
}
if (cxix < 0) {
if (!( PL_curstackinfo->si_type == PERLSI_SORT
|| ( PL_curstackinfo->si_type == PERLSI_MULTICALL
@ -2627,8 +2635,15 @@ S_unwind_loop(pTHX)
label_len,
label_flags | SVs_TEMP)));
}
if (cxix < cxstack_ix)
if (cxix < cxstack_ix) {
I32 i;
/* Check for defer { last ... } etc */
for(i = cxstack_ix; i > cxix; i--) {
if(CxTYPE(&cxstack[i]) == CXt_DEFER)
Perl_croak(aTHX_ "Can't \"%s\" out of a defer block", OP_NAME(PL_op));
}
dounwind(cxix);
}
return &cxstack[cxix];
}
@ -2872,6 +2887,12 @@ PP(pp_goto)
else if (CxMULTICALL(cx))
DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
/* Check for defer { goto &...; } */
for(ix = cxstack_ix; ix > cxix; ix--) {
if(CxTYPE(&cxstack[ix]) == CXt_DEFER)
Perl_croak(aTHX_ "Can't \"%s\" out of a defer block", "goto");
}
/* First do some returnish stuff. */
SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
@ -3110,6 +3131,8 @@ PP(pp_goto)
case CXt_FORMAT:
case CXt_NULL:
DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
case CXt_DEFER:
DIE(aTHX_ "Can't \"%s\" out of a defer block", "goto");
default:
if (ix)
DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
@ -5434,6 +5457,49 @@ PP(pp_break)
return cx->blk_givwhen.leave_op;
}
static void
invoke_defer_block(pTHX_ void *_arg)
{
OP *start = (OP *)_arg;
#ifdef DEBUGGING
I32 was_cxstack_ix = cxstack_ix;
#endif
cx_pushblock(CXt_DEFER, G_VOID, PL_stack_sp, PL_savestack_ix);
ENTER;
SAVETMPS;
SAVEOP();
PL_op = start;
CALLRUNOPS(aTHX);
FREETMPS;
LEAVE;
{
PERL_CONTEXT *cx;
cx = CX_CUR();
assert(CxTYPE(cx) == CXt_DEFER);
PL_stack_sp = PL_stack_base + cx->blk_oldsp;
CX_LEAVE_SCOPE(cx);
cx_popblock(cx);
CX_POP(cx);
}
assert(cxstack_ix == was_cxstack_ix);
}
PP(pp_pushdefer)
{
SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
return NORMAL;
}
static MAGIC *
S_doparseform(pTHX_ SV *sv)
{

1
pp_proto.h
View File

@ -205,6 +205,7 @@ PERL_CALLCONV OP *Perl_pp_print(pTHX);
PERL_CALLCONV OP *Perl_pp_prototype(pTHX);
PERL_CALLCONV OP *Perl_pp_prtf(pTHX);
PERL_CALLCONV OP *Perl_pp_push(pTHX);
PERL_CALLCONV OP *Perl_pp_pushdefer(pTHX);
PERL_CALLCONV OP *Perl_pp_pushmark(pTHX);
PERL_CALLCONV OP *Perl_pp_qr(pTHX);
PERL_CALLCONV OP *Perl_pp_quotemeta(pTHX);

5
proto.h
View File

@ -2308,6 +2308,11 @@ PERL_CALLCONV OP* Perl_newCVREF(pTHX_ I32 flags, OP* o)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWCVREF
PERL_CALLCONV OP* Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWDEFEROP \
assert(block)
PERL_CALLCONV OP* Perl_newDEFSVOP(pTHX)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEWDEFSVOP

9
regen/feature.pl
View File

@ -41,6 +41,7 @@ my %feature = (
multidimensional => 'multidimensional',
bareword_filehandles => 'bareword_filehandles',
try => 'try',
defer => 'defer',
);
# NOTE: If a feature is ever enabled in a non-contiguous range of Perl
@ -481,7 +482,7 @@ read_only_bottom_close_and_rename($h);
__END__
package feature;
our $VERSION = '1.67';
our $VERSION = '1.68';
FEATURES
@ -838,6 +839,12 @@ C<try> are caught by executing the body of the C<catch> block.
For more information, see L<perlsyn/"Try Catch Exception Handling">.
=head2 The 'defer' feature
This feature enables the C<defer> block syntax, which allows a block of code
to be deferred until when the flow of control leaves the block which contained
it. For more details, see L<perlsyn/defer>.
=head1 FEATURE BUNDLES
It's possible to load multiple features together, using

2
regen/keywords.pl
View File

@ -49,6 +49,7 @@ my %feature_kw = (
isa => 'isa',
try => 'try',
catch => 'try',
defer => 'defer',
);
my %pos = map { ($_ => 1) } @{$by_strength{'+'}};
@ -152,6 +153,7 @@ __END__
-dbmclose
-dbmopen
+default
+defer
+defined
+delete
-die

1
regen/opcodes
View File

@ -582,3 +582,4 @@ entertrycatch try {block} ck_trycatch |
leavetrycatch try {block} exit ck_null @
poptry pop try ck_null @
catch catch {} block ck_null |
pushdefer push defer {} block ck_null |

4
regen/warnings.pl
View File

@ -16,7 +16,7 @@
#
# This script is normally invoked from regen.pl.
$VERSION = '1.53';
$VERSION = '1.54';
BEGIN {
require './regen/regen_lib.pl';
@ -119,6 +119,8 @@ my $tree = {
[ 5.031, DEFAULT_ON ],
'experimental::try' =>
[ 5.033, DEFAULT_ON ],
'experimental::defer' =>
[ 5.035, DEFAULT_ON ],
}],
'missing' => [ 5.021, DEFAULT_OFF],

1
scope.c
View File

@ -1531,6 +1531,7 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
switch (CxTYPE(cx)) {
case CXt_NULL:
case CXt_BLOCK:
case CXt_DEFER:
break;
case CXt_FORMAT:
PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%" UVxf "\n",

1
sv.c
View File

@ -14629,6 +14629,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
case CXt_BLOCK:
case CXt_NULL:
case CXt_WHEN:
case CXt_DEFER:
break;
}
}

4
t/op/coreamp.t
View File

@ -1160,8 +1160,8 @@ like $@, qr'^Undefined format "STDOUT" called',
my %nottest_words = map { $_ => 1 } qw(
AUTOLOAD BEGIN CHECK CORE DESTROY END INIT UNITCHECK
__DATA__ __END__
and catch cmp default do dump else elsif eq eval for foreach format ge
given goto grep gt if isa last le local lt m map my ne next no or our
and catch cmp default defer do dump else elsif eq eval for foreach format
ge given goto grep gt if isa last le local lt m map my ne next no or our
package print printf q qq qr qw qx redo require return s say sort state
sub tr try unless until use when while x xor y
);

4
t/op/coresubs.t
View File

@ -15,8 +15,8 @@ BEGIN {
use B;
my %unsupported = map +($_=>1), qw (
__DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK and
catch cmp default do dump else elsif eq eval for foreach
__DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK
and catch cmp default defer do dump else elsif eq eval for foreach
format ge given goto grep gt if isa last le local lt m map my ne next
no or our package print printf q qq qr qw qx redo require
return s say sort state sub tr try unless until use

315
t/op/defer.t Normal file
View File

@ -0,0 +1,315 @@
#!./perl
BEGIN {
chdir 't' if -d 't';
require './test.pl';
set_up_inc('../lib');
}
plan 29;
use feature 'defer';
no warnings 'experimental::defer';
{
my $x = "";
{
defer { $x = "a" }
}
is($x, "a", 'defer block is invoked');
{
defer {
$x = "";
$x .= "abc";
$x .= "123";
}
}
is($x, "abc123", 'defer block can contain multiple statements');
{
defer {}
}
ok(1, 'Empty defer block parses OK');
}
{
my $x = "";
{
defer { $x .= "a" }
defer { $x .= "b" }
defer { $x .= "c" }
}
is($x, "cba", 'defer blocks happen in LIFO order');
}
{
my $x = "";
{
defer { $x .= "a" }
$x .= "A";
}
is($x, "Aa", 'defer blocks happen after the main body');
}
{
my $x = "";
foreach my $i (qw( a b c )) {
defer { $x .= $i }
}
is($x, "abc", 'defer block happens for every iteration of foreach');
}
{
my $x = "";
my $cond = 0;
if( $cond ) {
defer { $x .= "XXX" }
}
is($x, "", 'defer block does not happen inside non-taken conditional branch');
}
{
my $x = "";
while(1) {
last;
defer { $x .= "a" }
}
is($x, "", 'defer block does not happen if entered but unencountered');
}
{
my $x = "";
my $counter = 1;
{
defer { $x .= "A" }
redo if $counter++ < 5;
}
is($x, "AAAAA", 'defer block can happen multiple times');
}
{
my $x = "";
{
defer {
$x .= "a";
defer {
$x .= "b";
}
}
}
is($x, "ab", 'defer block can contain another defer');
}
{
my $x = "";
my $value = do {
defer { $x .= "before" }
"value";
};
is($x, "before", 'defer blocks run inside do { }');
is($value, "value", 'defer block does not disturb do { } value');
}
{
my $x = "";
my $sub = sub {
defer { $x .= "a" }
};
$sub->();
$sub->();
$sub->();
is($x, "aaa", 'defer block inside sub');
}
{
my $x = "";
my $sub = sub {
return;
defer { $x .= "a" }
};
$sub->();
is($x, "", 'defer block inside sub does not happen if entered but returned early');
}
{
my $x = "";
my sub after {
$x .= "c";
}
my sub before {
$x .= "a";
defer { $x .= "b" }
goto \&after;
}
before();
is($x, "abc", 'defer block invoked before tail-call');
}
# Sequencing with respect to variable cleanup
{
my $var = "outer";
my $x;
{
my $var = "inner";
defer { $x = $var }
}
is($x, "inner", 'defer block captures live value of same-scope lexicals');
}
{
my $var = "outer";
my $x;
{
defer { $x = $var }
my $var = "inner";
}
is ($x, "outer", 'defer block correctly captures outer lexical when only shadowed afterwards');
}
{
our $var = "outer";
{
local $var = "inner";
defer { $var = "finally" }
}
is($var, "outer", 'defer after localization still unlocalizes');
}
{
our $var = "outer";
{
defer { $var = "finally" }
local $var = "inner";
}
is($var, "finally", 'defer before localization overwrites');
}
# Interactions with exceptions
{
my $x = "";
my $sub = sub {
defer { $x .= "a" }
die "Oopsie\n";
};
my $e = defined eval { $sub->(); 1 } ? undef : $@;
is($x, "a", 'defer block still runs during exception unwind');
is($e, "Oopsie\n", 'Thrown exception still occurs after defer');
}
{
my $sub = sub {
defer { die "Oopsie\n"; }
return "retval";
};
my $e = defined eval { $sub->(); 1 } ? undef : $@;
is($e, "Oopsie\n", 'defer block can throw exception');
}
{
my $sub = sub {
defer { die "Oopsie 1\n"; }
die "Oopsie 2\n";
};
my $e = defined eval { $sub->(); 1 } ? undef : $@;
# TODO: Currently the first exception gets lost without even a warning
# We should consider what the behaviour ought to be here
# This test is happy for either exception to be seen, does not care which
like($e, qr/^Oopsie \d\n/, 'defer block can throw exception during exception unwind');
}
{
my $sub = sub {
while(1) {
defer { return "retval" }
last;
}
return "wrong";
};
my $e = defined eval { $sub->(); 1 } ? undef : $@;
like($e, qr/^Can't "return" out of a defer block /,
'Cannot return out of defer block');
}
{
my $sub = sub {
while(1) {
defer { goto HERE }
}
HERE:
};
my $e = defined eval { $sub->(); 1 } ? undef : $@;
like($e, qr/^Can't "goto" out of a defer block /,
'Cannot goto out of defer block');
}
{
my $subA = sub {
my $subB = sub {};
while(1) {
defer { goto &$subB }
}
};
my $e = defined eval { $subA->(); 1 } ? undef : $@;
like($e, qr/^Can't "goto" out of a defer block at /,
'Cannot goto &SUB out of a defer block');
}
{
my $sub = sub {
LOOP: while(1) {
defer { last LOOP }
}
};
my $e = defined eval { $sub->(); 1 } ? undef : $@;
like($e, qr/^Can't "last" out of a defer block /,
'Cannot last out of defer block');
}
{
# strictness failures are only checked at optree finalization time. This
# is a good way to test if that happens.
my $ok = eval 'defer { use strict; foo }';
my $e = $@;
ok(!$ok, 'defer BLOCK finalizes optree');
like($e, qr/^Bareword "foo" not allowed while "strict subs" in use at /,
'Error from finalization');
}

14
t/perf/opcount.t
View File

@ -20,7 +20,7 @@ BEGIN {
use warnings;
use strict;
plan 2583;
plan 2584;
use B ();
@ -675,3 +675,15 @@ test_opcount(0, "multiconcat: local assign",
concat => 0,
sassign => 1,
});
{
use feature 'defer';
no warnings 'experimental::defer';
test_opcount(1, "pushdefer: block is optimized",
sub { my @a; defer { $a[0] } },
{
aelemfast_lex => 1,
aelem => 0,
});
}

5
toke.c
View File

@ -7770,6 +7770,11 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct
case KEY_default:
PREBLOCK(DEFAULT);
case KEY_defer:
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__DEFER), "defer is experimental");
PREBLOCK(DEFER);
case KEY_do:
return yyl_do(aTHX_ s, orig_keyword);

5
warnings.h
View File

@ -133,6 +133,10 @@
/* Warnings Categories added in Perl 5.033 */
#define WARN_EXPERIMENTAL__TRY 73
/* Warnings Categories added in Perl 5.035 */
#define WARN_EXPERIMENTAL__DEFER 74
#define WARNsize 19
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125"
#define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
@ -316,6 +320,7 @@ category parameters passed.
=for apidoc Amnh||WARN_EXPERIMENTAL__VLB
=for apidoc Amnh||WARN_EXPERIMENTAL__ISA
=for apidoc Amnh||WARN_EXPERIMENTAL__TRY
=for apidoc Amnh||WARN_EXPERIMENTAL__DEFER
=cut
*/