From: Nicholas Clark Date: Sat, 5 Jan 2002 18:10:13 +0000 (+0000) Subject: [REPATCH] Re: [PATCH] Re: socketpair blip on unicos/mk, too X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b4023995ae634362f5a7adbc294793a9acb0a4b2;p=p5sagit%2Fp5-mst-13.2.git [REPATCH] Re: [PATCH] Re: socketpair blip on unicos/mk, too Message-ID: <20020105181013.I300@Bagpuss.unfortu.net> p4raw-id: //depot/perl@14090 --- diff --git a/embed.fnc b/embed.fnc index da7e2ce..e534f52 100644 --- a/embed.fnc +++ b/embed.fnc @@ -584,7 +584,7 @@ Ap |void |push_scope p |OP* |ref |OP* o|I32 type p |OP* |refkids |OP* o|I32 type Ap |void |regdump |regexp* r -Ap |SV* |regclass_swash |struct regnode *n|bool doinit|SV **initsvp +Ap |SV* |regclass_swash |struct regnode *n|bool doinit|SV **listsvp|SV **altsvp Ap |I32 |pregexec |regexp* prog|char* stringarg \ |char* strend|char* strbeg|I32 minend \ |SV* screamer|U32 nosave @@ -1134,6 +1134,7 @@ s |I32 |regrepeat |regnode *p|I32 max s |I32 |regrepeat_hard |regnode *p|I32 max|I32 *lp s |I32 |regtry |regexp *prog|char *startpos s |bool |reginclass |regnode *n|U8 *p|bool do_utf8sv_is_utf8 +s |bool |reginclasslen |regnode *n|U8 *p|STRLEN *lenp|bool do_utf8sv_is_utf8 s |CHECKPOINT|regcppush |I32 parenfloor s |char*|regcppop s |char*|regcp_set_to |I32 ss diff --git a/embed.h b/embed.h index 8a5cc4e..6203634 100644 --- a/embed.h +++ b/embed.h @@ -1049,6 +1049,7 @@ #define regrepeat_hard S_regrepeat_hard #define regtry S_regtry #define reginclass S_reginclass +#define reginclasslen S_reginclasslen #define regcppush S_regcppush #define regcppop S_regcppop #define regcp_set_to S_regcp_set_to @@ -2104,7 +2105,7 @@ #define ref(a,b) Perl_ref(aTHX_ a,b) #define refkids(a,b) Perl_refkids(aTHX_ a,b) #define regdump(a) Perl_regdump(aTHX_ a) -#define regclass_swash(a,b,c) Perl_regclass_swash(aTHX_ a,b,c) +#define regclass_swash(a,b,c,d) Perl_regclass_swash(aTHX_ a,b,c,d) #define pregexec(a,b,c,d,e,f,g) Perl_pregexec(aTHX_ a,b,c,d,e,f,g) #define pregfree(a) Perl_pregfree(aTHX_ a) #define pregcomp(a,b,c) Perl_pregcomp(aTHX_ a,b,c) @@ -2588,6 +2589,7 @@ #define regrepeat_hard(a,b,c) S_regrepeat_hard(aTHX_ a,b,c) #define regtry(a,b) S_regtry(aTHX_ a,b) #define reginclass(a,b,c) S_reginclass(aTHX_ a,b,c) +#define reginclasslen(a,b,c,d) S_reginclasslen(aTHX_ a,b,c,d) #define regcppush(a) S_regcppush(aTHX_ a) #define regcppop() S_regcppop(aTHX) #define regcp_set_to(a) S_regcp_set_to(aTHX_ a) diff --git a/ext/Socket/socketpair.t b/ext/Socket/socketpair.t index 4f3f278..c3a548c 100644 --- a/ext/Socket/socketpair.t +++ b/ext/Socket/socketpair.t @@ -1,5 +1,7 @@ #!./perl -w +my $child; + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; @@ -8,9 +10,32 @@ BEGIN { !(($^O eq 'VMS') && $Config{d_socket})) { print "1..0\n"; exit 0; + } + + # Too many things in this test will hang forever if something is wrong, + # so we need a self destruct timer. And IO can hang despite an alarm. + + # This is convoluted, but we must fork before Test::More, else child's + # Test::More thinks that it ran no tests, and prints a message to that + # effect + if( $Config{d_fork} ) { + my $parent = $$; + $child = fork; + die "Fork failed" unless defined $child; + if (!$child) { + $SIG{INT} = sub {exit 0}; # You have 60 seconds. Your time starts now. + my $must_finish_by = time + 60; + my $remaining; + while ($remaining = time - $must_finish_by) { + sleep $remaining; + } + warn "Something unexpectedly hung during testing"; + kill "INT", $parent or die "Kill failed: $!"; + exit 1; + } } } - + use Socket; use Test::More; use strict; @@ -21,6 +46,8 @@ my $skip_reason; if( !$Config{d_alarm} ) { plan skip_all => "alarm() not implemented on this platform"; +} elsif( !$Config{d_fork} ) { + plan skip_all => "fork() not implemented on this platform"; } else { # This should fail but not die if there is real socketpair eval {socketpair LEFT, RIGHT, -1, -1, -1}; @@ -36,10 +63,8 @@ if( !$Config{d_alarm} ) { } } -# Too many things in this test will hang forever if something is wrong, so -# we need a self destruct timer. -$SIG{ALRM} = sub {die "Something unexpectedly hung during testing"}; -alarm(60); +# But we'll install an alarm handler in case any of the races below fail. +$SIG{ALRM} = sub {die "Unexpected alarm during testing"}; ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC), "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)") @@ -69,9 +94,11 @@ is (read (RIGHT, $buffer, length $expect), length $expect, "read on right"); is ($buffer, $expect, "content what we expected?"); ok (shutdown(LEFT, SHUT_WR), "shutdown left for writing"); -# This will hang forever if eof is buggy. +# This will hang forever if eof is buggy, and alarm doesn't interrupt system +# Calls. Hence the child process minder. { local $SIG{ALRM} = sub { warn "EOF on right took over 3 seconds" }; + local $TODO = "Known problems with unix sockets on $^O" if $^O eq 'hpux'; alarm 3; $! = 0; ok (eof RIGHT, "right is at EOF"); @@ -171,3 +198,6 @@ foreach $expect (@gripping) { ok (close LEFT, "close left"); ok (close RIGHT, "close right"); + +kill "INT", $child or warn "Failed to kill child process $child: $!"; +exit 0; diff --git a/proto.h b/proto.h index 52d634e..ea837ec 100644 --- a/proto.h +++ b/proto.h @@ -619,7 +619,7 @@ PERL_CALLCONV void Perl_push_scope(pTHX); PERL_CALLCONV OP* Perl_ref(pTHX_ OP* o, I32 type); PERL_CALLCONV OP* Perl_refkids(pTHX_ OP* o, I32 type); PERL_CALLCONV void Perl_regdump(pTHX_ regexp* r); -PERL_CALLCONV SV* Perl_regclass_swash(pTHX_ struct regnode *n, bool doinit, SV **initsvp); +PERL_CALLCONV SV* Perl_regclass_swash(pTHX_ struct regnode *n, bool doinit, SV **listsvp, SV **altsvp); PERL_CALLCONV I32 Perl_pregexec(pTHX_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave); PERL_CALLCONV void Perl_pregfree(pTHX_ struct regexp* r); PERL_CALLCONV regexp* Perl_pregcomp(pTHX_ char* exp, char* xend, PMOP* pm); @@ -1164,6 +1164,7 @@ STATIC I32 S_regrepeat(pTHX_ regnode *p, I32 max); STATIC I32 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp); STATIC I32 S_regtry(pTHX_ regexp *prog, char *startpos); STATIC bool S_reginclass(pTHX_ regnode *n, U8 *p, bool do_utf8sv_is_utf8); +STATIC bool S_reginclasslen(pTHX_ regnode *n, U8 *p, STRLEN *lenp, bool do_utf8sv_is_utf8); STATIC CHECKPOINT S_regcppush(pTHX_ I32 parenfloor); STATIC char* S_regcppop(pTHX); STATIC char* S_regcp_set_to(pTHX_ I32 ss); diff --git a/regcomp.c b/regcomp.c index aacae22..e81bc0a 100644 --- a/regcomp.c +++ b/regcomp.c @@ -3427,7 +3427,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state) SV *listsv = Nullsv; register char *e; UV n; - bool optimize_invert = TRUE; + bool optimize_invert = TRUE; + AV* unicode_alternate = 0; ret = reganode(pRExC_state, ANYOF, 0); @@ -4028,18 +4029,35 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state) /* If folding and foldable and a single * character, insert also the folded version * to the charclass. */ - if (f != value && foldlen == UNISKIP(f)) - Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", f); + if (f != value) { + if (foldlen == UNISKIP(f)) + Perl_sv_catpvf(aTHX_ listsv, + "%04"UVxf"\n", f); + else { + /* Any multicharacter foldings + * require the following transform: + * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) + * where E folds into "pq" and F folds + * into "rst", all other characters + * fold to single characters. */ + SV *sv; + + if (!unicode_alternate) + unicode_alternate = newAV(); + sv = newSVpvn((char*)foldbuf, foldlen); + SvUTF8_on(sv); + av_push(unicode_alternate, sv); + } + } /* If folding and the value is one of the Greek * sigmas insert a few more sigmas to make the * folding rules of the sigmas to work right. * Note that not all the possible combinations * are handled here: some of them are handled - * handled by the standard folding rules, and - * some of them (literal or EXACTF cases) are - * handled during runtime in - * regexec.c:S_find_byclass(). */ + * by the standard folding rules, and some of + * them (literal or EXACTF cases) are handled + * during runtime in regexec.c:S_find_byclass(). */ if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) { Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA); @@ -4096,6 +4114,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state) av_store(av, 0, listsv); av_store(av, 1, NULL); + av_store(av, 2, (SV*)unicode_alternate); rv = newRV_noinc((SV*)av); n = add_data(pRExC_state, 1, "s"); RExC_rx->data->data[n] = (void*)rv; @@ -4625,7 +4644,7 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) { SV *lv; - SV *sw = regclass_swash(o, FALSE, &lv); + SV *sw = regclass_swash(o, FALSE, &lv, 0); if (lv) { if (sw) { @@ -4779,7 +4798,7 @@ Perl_pregfree(pTHX_ struct regexp *r) new_comppad = NULL; break; case 'n': - break; + break; default: Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]); } diff --git a/regcomp.h b/regcomp.h index 16cf957..9053242 100644 --- a/regcomp.h +++ b/regcomp.h @@ -365,7 +365,9 @@ typedef struct re_scream_pos_data_s * n - Root of op tree for (?{EVAL}) item * o - Start op for (?{EVAL}) item * p - Pad for (?{EVAL} item - * s - swash for unicode-style character class + * s - swash for unicode-style character class, and the multicharacter + * strings resulting from casefolding the single-character entries + * in the character class * 20010712 mjd@plover.com * (Remember to update re_dup() and pregfree() if you add any items.) */ diff --git a/regexec.c b/regexec.c index fe9ad4b..5f25888 100644 --- a/regexec.c +++ b/regexec.c @@ -2369,11 +2369,13 @@ S_regmatch(pTHX_ regnode *prog) break; case ANYOF: if (do_utf8) { - if (!reginclass(scan, (U8*)locinput, do_utf8)) + STRLEN inclasslen = PL_regeol - locinput; + + if (!reginclasslen(scan, (U8*)locinput, &inclasslen, do_utf8)) sayNO; if (locinput >= PL_regeol) sayNO; - locinput += PL_utf8skip[nextchr]; + locinput += inclasslen; nextchr = UCHARAT(locinput); } else { @@ -4107,10 +4109,11 @@ S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp) */ SV * -Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp) +Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** listsvp, SV **altsvp) { - SV *sw = NULL; - SV *si = NULL; + SV *sw = NULL; + SV *si = NULL; + SV *alt = NULL; if (PL_regdata && PL_regdata->count) { U32 n = ARG(node); @@ -4118,10 +4121,11 @@ Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp) if (PL_regdata->what[n] == 's') { SV *rv = (SV*)PL_regdata->data[n]; AV *av = (AV*)SvRV((SV*)rv); - SV **a; + SV **a, **b; - si = *av_fetch(av, 0, FALSE); - a = av_fetch(av, 1, FALSE); + si = *av_fetch(av, 0, FALSE); + a = av_fetch(av, 1, FALSE); + b = av_fetch(av, 2, FALSE); if (a) sw = *a; @@ -4129,11 +4133,15 @@ Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp) sw = swash_init("utf8", "", si, 1, 0); (void)av_store(av, 1, sw); } + if (b) + alt = *b; } } - if (initsvp) - *initsvp = si; + if (listsvp) + *listsvp = si; + if (altsvp) + *altsvp = alt; return sw; } @@ -4143,16 +4151,20 @@ Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp) */ STATIC bool -S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8) +S_reginclasslen(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, register bool do_utf8) { char flags = ANYOF_FLAGS(n); bool match = FALSE; UV c; STRLEN len = 0; + STRLEN plen; c = do_utf8 ? utf8_to_uvchr(p, &len) : *p; + plen = lenp ? *lenp : UNISKIP(c); if (do_utf8 || (flags & ANYOF_UNICODE)) { + if (lenp) + *lenp = 0; if (do_utf8 && !ANYOF_RUNTIME(n)) { if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c)) match = TRUE; @@ -4160,24 +4172,46 @@ S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8) if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256) match = TRUE; if (!match) { - SV *sw = regclass_swash(n, TRUE, 0); + AV *av; + SV *sw = regclass_swash(n, TRUE, 0, (SV**)&av); if (sw) { if (swash_fetch(sw, p, do_utf8)) match = TRUE; else if (flags & ANYOF_FOLD) { - U8 foldbuf[UTF8_MAXLEN_FOLD+1]; - STRLEN foldlen; - - to_utf8_fold(p, foldbuf, &foldlen); - if (swash_fetch(sw, foldbuf, do_utf8)) - match = TRUE; - to_utf8_upper(p, foldbuf, &foldlen); - if (swash_fetch(sw, foldbuf, do_utf8)) - match = TRUE; + U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; + STRLEN tmplen; + + if (!match && lenp && av) { + I32 i; + + for (i = 0; i <= av_len(av); i++) { + SV* sv = *av_fetch(av, i, FALSE); + STRLEN len; + char *s = SvPV(sv, len); + + if (len <= plen && memEQ(s, p, len)) { + *lenp = len; + match = TRUE; + break; + } + } + } + if (!match) { + to_utf8_fold(p, tmpbuf, &tmplen); + if (swash_fetch(sw, tmpbuf, do_utf8)) + match = TRUE; + } + if (!match) { + to_utf8_upper(p, tmpbuf, &tmplen); + if (swash_fetch(sw, tmpbuf, do_utf8)) + match = TRUE; + } } } } + if (match && lenp && *lenp == 0) + *lenp = UNISKIP(c); } if (!match && c < 256) { if (ANYOF_BITMAP_TEST(n, c)) @@ -4238,6 +4272,12 @@ S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8) return (flags & ANYOF_INVERT) ? !match : match; } +STATIC bool +S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8) +{ + return S_reginclasslen(aTHX_ n, p, 0, do_utf8); +} + STATIC U8 * S_reghop(pTHX_ U8 *s, I32 off) {