In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/d40610d16eaa2c4551c2284e77d67581fc9ac258?hp=dd3f0a7a42a6b28853a3bb382e5d2d31de838a7c>
- Log ----------------------------------------------------------------- commit d40610d16eaa2c4551c2284e77d67581fc9ac258 Author: Daniel Dragan <[email protected]> Date: Fri Sep 12 15:36:34 2014 -0400 do not lock files when doing open() on :win32 layer MS CRT uses _SH_DENYNO flag internally for all open() calls. Not passing FILE_SHARE_READ and FILE_SHARE_WRITE to CreateFile means we want exclusive access to the file, otherwise CreateFile fails. Always locking the files causes :win32 is base layer perl to not be able to have 2 handles/FDs/PIOs open simultaneously to the same disk file. This causes a behavior different from :unix is base layer win32 perl, and also causes a number of test fails to fail. See #122224 for details of test fails. Getting read/write lock on open behavior comes from initial commit a8c08ecdc5 of win32 layer. M win32/win32io.c commit 83b69bfde6226f4bb6cc380f4730edc47f166ed9 Author: Daniel Dragan <[email protected]> Date: Tue Sep 9 10:03:32 2014 -0400 add /dev/null support to :win32 io layer :unix layer on Win32 OS supports this, so :win32 also has to. Without this base/term.t dies with ok 5 Can't open /dev/null. at base/term.t line 41. C:\perl521\src\t> After this, all tests in base/term.t pass when :win32 is the default OS layer. M pod/perldelta.pod M win32/win32io.c commit f814d560e84fb1708a02c0e9482182b47ea6e560 Author: Daniel Dragan <[email protected]> Date: Fri Sep 12 13:49:45 2014 -0400 rmv redundant PerlIO_find_layer from PerlIO_default_layers Obsolete as of commit fcf2db383b , prior to that commit, PerlIO_find_layer was needed to convert a PerlIO_funcs * (var osLayer) to a SV * since PL_def_layerlist wasn't a PerlIO_list_t * but a AV *. After that commit PerlIO_find_layer returns a PerlIO_funcs *, and we start with a PerlIO_funcs * (var osLayer), so PerlIO_find_layer is redundant. Also _NN a stack arg for smaller code. M perlio.c commit 4e0ef34209f54db7b7567b4768de7318aaf800cd Author: Daniel Dragan <[email protected]> Date: Sun Aug 31 01:40:27 2014 -0400 cleanup perlio.c and doio.c IoIFP will be assigned to again in say_false block. This redundant code is from commit 6e21c824d9 perl 4.0 patch 6. in PerlIO_allocate replace a duplicate block with a goto in PerlIO_resolve_layers replace a func call with a macro, this couldn't have been using magic due to the previous SvROK M doio.c M perlio.c commit ce409cc88cd7e9921c410d37ca33d12e05a50aa1 Author: Lukas Mai <[email protected]> Date: Sat Oct 25 00:39:03 2014 +0200 APIfy newDEFSVOP M MANIFEST M embed.fnc M embed.h M ext/XS-APItest/APItest.pm M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/newDEFSVOP.t M op.c M proto.h ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + doio.c | 1 - embed.fnc | 2 +- embed.h | 2 +- ext/XS-APItest/APItest.pm | 8 ++++++-- ext/XS-APItest/APItest.xs | 12 ++++++++++++ ext/XS-APItest/t/newDEFSVOP.t | 40 ++++++++++++++++++++++++++++++++++++++++ op.c | 14 ++++++++++++-- perlio.c | 18 +++++++----------- pod/perldelta.pod | 13 +++++++++++++ proto.h | 6 +++--- win32/win32io.c | 7 ++++--- 12 files changed, 100 insertions(+), 24 deletions(-) create mode 100644 ext/XS-APItest/t/newDEFSVOP.t diff --git a/MANIFEST b/MANIFEST index 8fb37a6..0f12230 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3835,6 +3835,7 @@ ext/XS-APItest/t/multicall.t XS::APItest: test MULTICALL macros ext/XS-APItest/t/my_cxt.t XS::APItest: test MY_CXT interface ext/XS-APItest/t/my_exit.t XS::APItest: test my_exit ext/XS-APItest/t/newCONSTSUB.t XS::APItest: test newCONSTSUB(_flags) +ext/XS-APItest/t/newDEFSVOP.t XS::APItest: test newDEFSVOP ext/XS-APItest/t/Null.pm Helper for ./blockhooks.t ext/XS-APItest/t/op_contextualize.t test op_contextualize() API ext/XS-APItest/t/op_list.t test OP list construction API diff --git a/doio.c b/doio.c index 1f5f932..a09800f 100644 --- a/doio.c +++ b/doio.c @@ -782,7 +782,6 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, *s = 'w'; if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) { PerlIO_close(fp); - IoIFP(io) = NULL; goto say_false; } } diff --git a/embed.fnc b/embed.fnc index 006fe45..6aa1ec3 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1018,6 +1018,7 @@ Apda |SV* |newRV_noinc |NN SV *const sv Apda |SV* |newSV |const STRLEN len Apa |OP* |newSVREF |NN OP* o Apda |OP* |newSVOP |I32 type|I32 flags|NN SV* sv +ApdR |OP* |newDEFSVOP pa |SV* |newSVavdefelem |NN AV *av|SSize_t ix|bool extendible Apda |SV* |newSViv |const IV i Apda |SV* |newSVuv |const UV u @@ -1932,7 +1933,6 @@ s |void |find_and_forget_pmops |NN OP *o s |void |cop_free |NN COP *cop s |OP* |modkids |NULLOK OP *o|I32 type s |OP* |scalarboolean |NN OP *o -sR |OP* |newDEFSVOP sR |OP* |search_const |NN OP *o sR |OP* |new_logop |I32 type|I32 flags|NN OP **firstp|NN OP **otherp s |void |simplify_sort |NN OP *o diff --git a/embed.h b/embed.h index e109c7e..ebf519f 100644 --- a/embed.h +++ b/embed.h @@ -359,6 +359,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 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) #define newGIVENOP(a,b,c) Perl_newGIVENOP(aTHX_ a,b,c) @@ -1531,7 +1532,6 @@ #define modkids(a,b) S_modkids(aTHX_ a,b) #define move_proto_attr(a,b,c) S_move_proto_attr(aTHX_ a,b,c) #define my_kid(a,b,c) S_my_kid(aTHX_ a,b,c) -#define newDEFSVOP() S_newDEFSVOP(aTHX) #define newGIVWHENOP(a,b,c,d,e) S_newGIVWHENOP(aTHX_ a,b,c,d,e) #define newMETHOP_internal(a,b,c,d) S_newMETHOP_internal(aTHX_ a,b,c,d) #define new_logop(a,b,c,d) S_new_logop(aTHX_ a,b,c,d) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 1dbb16f..a5953c6 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '0.65'; +our $VERSION = '0.66'; require XSLoader; @@ -40,7 +40,7 @@ sub import { } } foreach (keys %{$exports||{}}) { - next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexp ... [21 chars truncated] + next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexp ... [27 chars truncated] $^H{"XS::APItest/$_"} = 1; delete $exports->{$_}; } @@ -254,6 +254,10 @@ They are lexically scoped. =over +=item DEFSV + +Behaves like C<$_>. + =item rpn(EXPRESSION) This construct is a Perl expression. I<EXPRESSION> must be an RPN diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index da7bcee..de0b2eb 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -662,6 +662,7 @@ static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv; static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv; static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv; static SV *hintkey_arrayexprflags_sv; +static SV *hintkey_DEFSV_sv; static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); /* low-level parser helpers */ @@ -951,6 +952,12 @@ static OP *THX_parse_keyword_arrayexprflags(pTHX) return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0)); } +#define parse_keyword_DEFSV() THX_parse_keyword_DEFSV(aTHX) +static OP *THX_parse_keyword_DEFSV(pTHX) +{ + return newDEFSVOP(); +} + /* plugin glue */ #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv) @@ -1035,6 +1042,10 @@ static int my_keyword_plugin(pTHX_ keyword_active(hintkey_arrayexprflags_sv)) { *op_ptr = parse_keyword_arrayexprflags(); return KEYWORD_PLUGIN_EXPR; + } else if(keyword_len == 5 && strnEQ(keyword_ptr, "DEFSV", 5) && + keyword_active(hintkey_DEFSV_sv)) { + *op_ptr = parse_keyword_DEFSV(); + return KEYWORD_PLUGIN_EXPR; } else { return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); } @@ -3321,6 +3332,7 @@ BOOT: hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr"); hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr"); hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags"); + hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV"); next_keyword_plugin = PL_keyword_plugin; PL_keyword_plugin = my_keyword_plugin; } diff --git a/ext/XS-APItest/t/newDEFSVOP.t b/ext/XS-APItest/t/newDEFSVOP.t new file mode 100644 index 0000000..1ba6ee6 --- /dev/null +++ b/ext/XS-APItest/t/newDEFSVOP.t @@ -0,0 +1,40 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 16; + +use XS::APItest qw(DEFSV); + +is $_, undef; +is DEFSV, undef; +is \DEFSV, \$_; + +DEFSV = "foo"; +is DEFSV, "foo"; +is $_, "foo"; + +$_ = "bar"; +is DEFSV, "bar"; +is $_, "bar"; + +{ + no warnings 'experimental::lexical_topic'; + my $_; + + is $_, undef; + is DEFSV, undef; + is \DEFSV, \$_; + + DEFSV = "lex-foo"; + is DEFSV, "lex-foo"; + is $_, "lex-foo"; + + $_ = "lex-bar"; + is DEFSV, "lex-bar"; + is $_, "lex-bar"; +} + +is DEFSV, "bar"; +is $_, "bar"; diff --git a/op.c b/op.c index a4d7bb0..bdaf324 100644 --- a/op.c +++ b/op.c @@ -3671,8 +3671,18 @@ Perl_blockhook_register(pTHX_ BHK *hk) Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk))); } -STATIC OP * -S_newDEFSVOP(pTHX) +/* +=for apidoc Am|OP *|newDEFSVOP| + +Constructs and returns an op to access C<$_>, either as a lexical +variable (if declared as C<my $_>) in the current scope, or the +global C<$_>. + +=cut +*/ + +OP * +Perl_newDEFSVOP(pTHX) { const PADOFFSET offset = pad_findmy_pvs("$_", 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { diff --git a/perlio.c b/perlio.c index 19b73ab..b163849 100644 --- a/perlio.c +++ b/perlio.c @@ -477,10 +477,7 @@ PerlIO_allocate(pTHX) last = (PerlIOl **) (f); for (i = 1; i < PERLIO_TABLE_SIZE; i++) { if (!((++f)->next)) { - f->flags = 0; /* lockcnt */ - f->tab = NULL; - f->head = f; - return (PerlIO *)f; + goto good_exit; } } } @@ -489,6 +486,8 @@ PerlIO_allocate(pTHX) return NULL; } *last = (PerlIOl*) f++; + + good_exit: f->flags = 0; /* lockcnt */ f->tab = NULL; f->head = f; @@ -883,7 +882,7 @@ XS(XS_PerlIO__Layer__find) else { STRLEN len; const char * const name = SvPV_const(ST(1), len); - const bool load = (items > 2) ? SvTRUE(ST(2)) : 0; + const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0; PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load); ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : @@ -1004,8 +1003,7 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) tab = &PerlIO_stdio; #endif PerlIO_debug("Pushing %s\n", tab->name); - PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0), - &PL_sv_undef); + PerlIO_list_push(aTHX_ av, tab, &PL_sv_undef); } SV * @@ -1093,9 +1091,7 @@ PerlIO_default_layers(pTHX) PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); - PerlIO_list_push(aTHX_ PL_def_layerlist, - PerlIO_find_layer(aTHX_ osLayer->name, 0, 0), - &PL_sv_undef); + PerlIO_list_push(aTHX_ PL_def_layerlist, osLayer, &PL_sv_undef); if (s) { PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); } @@ -1459,7 +1455,7 @@ PerlIO_resolve_layers(pTHX_ const char *layers, * If it is a reference but not an object see if we have a handler * for it */ - if (SvROK(arg) && !sv_isobject(arg)) { + if (SvROK(arg) && !SvOBJECT(SvRV(arg))) { PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); if (handler) { def = PerlIO_list_alloc(aTHX); diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 261fc21..f783a9a 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -333,6 +333,19 @@ XXX =back +=head3 Win32 + +=over 4 + +=item * + +In the experimental C<:win32> layer, a crash in C<open> was fixed. Also +opening C</dev/null>, which works the Win32 Perl's normal C<:unix> layer, was +implemented for C<:win32>. +L<[perl #122224]|https://rt.perl.org/Ticket/Display.html?id=122224> + +=back + =head1 Internal Changes XXX Changes which affect the interface available to C<XS> code go here. Other diff --git a/proto.h b/proto.h index c0829e3..73a103f 100644 --- a/proto.h +++ b/proto.h @@ -2853,6 +2853,9 @@ PERL_CALLCONV OP* Perl_newCVREF(pTHX_ I32 flags, OP* o) __attribute__malloc__ __attribute__warn_unused_result__; +PERL_CALLCONV OP* Perl_newDEFSVOP(pTHX) + __attribute__warn_unused_result__; + PERL_CALLCONV void Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block); PERL_CALLCONV OP* Perl_newFOROP(pTHX_ I32 flags, OP* sv, OP* expr, OP* block, OP* cont) __attribute__malloc__ @@ -6279,9 +6282,6 @@ STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) #define PERL_ARGS_ASSERT_MY_KID \ assert(imopsp) -STATIC OP* S_newDEFSVOP(pTHX) - __attribute__warn_unused_result__; - STATIC OP* S_newGIVWHENOP(pTHX_ OP* cond, OP *block, I32 enter_opcode, I32 leave_opcode, PADOFFSET entertarg) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_NEWGIVWHENOP \ diff --git a/win32/win32io.c b/win32/win32io.c index 0483602..dc35d88 100644 --- a/win32/win32io.c +++ b/win32/win32io.c @@ -84,9 +84,12 @@ PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const ch { char *path = SvPV_nolen(*args); DWORD access = 0; - DWORD share = 0; + /* CRT uses _SH_DENYNO for open(), this the Win32 equivelent */ + DWORD share = FILE_SHARE_READ | FILE_SHARE_WRITE; DWORD create = -1; DWORD attr = FILE_ATTRIBUTE_NORMAL; + if (stricmp(path, "/dev/null")==0) + path = "NUL"; if (*mode == '#') { /* sysopen - imode is UNIX-like O_RDONLY etc. @@ -145,8 +148,6 @@ PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const ch SETERRNO(EINVAL,LIB$_INVARG); return NULL; } - if (!(access & GENERIC_WRITE)) - share = FILE_SHARE_READ; h = CreateFile(path,access,share,NULL,create,attr,NULL); if (h == INVALID_HANDLE_VALUE) { -- Perl5 Master Repository
