This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline changes into win32 branch. Now would be a good time
authorGurusamy Sarathy <gsar@cpan.org>
Fri, 14 Nov 1997 22:04:58 +0000 (22:04 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Fri, 14 Nov 1997 22:04:58 +0000 (22:04 +0000)
to reverse integrate the win32 branch into mainline.

p4raw-id: //depot/win32/perl@253

20 files changed:
MANIFEST
ext/Thread/Thread.pm
ext/Thread/Thread.xs
ext/Thread/Thread/Specific.pm [new file with mode: 0644]
ext/Thread/join.t
ext/Thread/specific.t [new file with mode: 0644]
lib/fields.pm [new file with mode: 0644]
mg.c
op.c
perl.c
perl.h
pp_ctl.c
pp_hot.c
pp_sys.c
proto.h
scope.c
t/io/pipe.t
t/lib/io_pipe.t
t/op/magic.t
thread.h

index a82fd45..8f1537d 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -212,15 +212,19 @@ ext/Thread/Notes  Thread notes
 ext/Thread/README      Thread README
 ext/Thread/Thread/Queue.pm     Thread synchronised queue objects
 ext/Thread/Thread/Semaphore.pm Thread semaphore objects
+ext/Thread/Thread/Specific.pm  Thread specific data access
 ext/Thread/Thread.pm   Thread extension Perl module
 ext/Thread/Thread.xs   Thread extension external subroutines
 ext/Thread/create.t    Test thread creation
+ext/Thread/die.t       Test thread die()
+ext/Thread/die2.t      Test thread die() differently
 ext/Thread/io.t                Test threads doing simple I/O
 ext/Thread/join.t      Test thread joining
 ext/Thread/join2.t     Test thread joining differently
 ext/Thread/list.t      Test getting list of all threads
 ext/Thread/lock.t      Test lock primitive
 ext/Thread/queue.t     Test Thread::Queue module
+ext/Thread/specific.t  Test thread-specific user data
 ext/Thread/sync.t      Test thread synchronisation
 ext/Thread/sync2.t     Test thread synchronisation
 ext/Thread/typemap     Thread extension interface types
index 2ace5dd..1936142 100644 (file)
@@ -15,6 +15,10 @@ sub async (&) {
     return new Thread $_[0];
 }
 
+sub eval {
+    return eval { shift->join; };
+}
+
 bootstrap Thread;
 
 1;
index 841b569..9e3c439 100644 (file)
@@ -19,7 +19,7 @@ static int sig_pipe[2];
 typedef struct thread *Thread;
 #define THREAD_RET_TYPE void *
 #define THREAD_RET_CAST(x) ((THREAD_RET_TYPE) x)
-#endif;
+#endif
 
 static void
 remove_thread(struct thread *t)
@@ -47,7 +47,7 @@ threadstart(void *arg)
     dSP;
     I32 oldscope = scopestack_ix;
     I32 retval;
-    AV *returnav;
+    AV *av;
     int i;
 
     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
@@ -86,7 +86,8 @@ threadstart(void *arg)
     I32 oldmark = TOPMARK;
     I32 oldscope = scopestack_ix;
     I32 retval;
-    AV *returnav;
+    SV *sv;
+    AV *av = newAV();
     int i, ret;
     dJMPENV;
     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p waiting to start\n",
@@ -114,47 +115,32 @@ threadstart(void *arg)
     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
                          thr, SvPEEK(TOPs)));
 
-    JMPENV_PUSH(ret);
-    switch (ret) {
-    case 3:
-        PerlIO_printf(PerlIO_stderr(), "panic: threadstart\n");
-       /* fall through */
-    case 1:
-       STATUS_ALL_FAILURE;
-       /* fall through */
-    case 2:
-       /* my_exit() was called */
-       while (scopestack_ix > oldscope)
-           LEAVE;
-       JMPENV_POP;
-       av_store(returnav, 0, newSViv(statusvalue));
-       goto finishoff;
-    }
-
-    CATCH_SET(TRUE);
-
-    /* Now duplicate most of perl_call_sv but with a few twists */
-    op = (OP*)&myop;
-    Zero(op, 1, LOGOP);
-    myop.op_flags = OPf_STACKED;
-    myop.op_next = Nullop;
-    myop.op_flags |= OPf_KNOW;
-    myop.op_flags |= OPf_WANT_LIST;
-    op = pp_entersub(ARGS);
-    if (op)
-       runops();
+    sv = POPs;
+    PUTBACK;
+    perl_call_sv(sv, G_ARRAY|G_EVAL);
     SPAGAIN;
     retval = sp - (stack_base + oldmark);
     sp = stack_base + oldmark + 1;
-    DEBUG_L(for (i = 1; i <= retval; i++)
-               PerlIO_printf(PerlIO_stderr(),
-                             "%p returnav[%d] = %s\n",
-                             thr, i, SvPEEK(sp[i - 1]));)
-    returnav = newAV();
-    av_store(returnav, 0, newSVpv("", 0));
-    for (i = 1; i <= retval; i++, sp++)
-       sv_setsv(*av_fetch(returnav, i, TRUE), SvREFCNT_inc(*sp));
-    
+    if (SvCUR(thr->errsv)) {
+       MUTEX_LOCK(&thr->mutex);
+       thr->flags |= THRf_DID_DIE;
+       MUTEX_UNLOCK(&thr->mutex);
+       av_store(av, 0, &sv_no);
+       av_store(av, 1, newSVsv(thr->errsv));
+       DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n",
+                             SvPV(thr->errsv, na));
+    } else {
+       DEBUG_L(STMT_START {
+           for (i = 1; i <= retval; i++) {
+               PerlIO_printf(PerlIO_stderr(), "%p return[%d] = %s\n",
+                               thr, i, SvPEEK(sp[i - 1]));)
+           }
+       } STMT_END);
+       av_store(av, 0, &sv_yes);
+       for (i = 1; i <= retval; i++, sp++)
+           sv_setsv(*av_fetch(av, i, TRUE), SvREFCNT_inc(*sp));
+    }
+
   finishoff:
 #if 0    
     /* removed for debug */
@@ -194,7 +180,7 @@ threadstart(void *arg)
     case THRf_R_DETACHED:
        ThrSETSTATE(thr, THRf_DEAD);
        MUTEX_UNLOCK(&thr->mutex);
-       SvREFCNT_dec(returnav);
+       SvREFCNT_dec(av);
        DEBUG_L(PerlIO_printf(PerlIO_stderr(),
                              "%p: DETACHED thread finished\n", thr));
        remove_thread(thr);     /* This might trigger main thread to finish */
@@ -204,7 +190,7 @@ threadstart(void *arg)
        croak("panic: illegal state %u at end of threadstart", ThrSTATE(thr));
        /* NOTREACHED */
     }
-    return THREAD_RET_CAST(returnav);  /* Available for anyone to join with */
+    return THREAD_RET_CAST(av);        /* Available for anyone to join with */
                                        /* us unless we're detached, in which */
                                        /* case noone sees the value anyway. */
 #endif    
@@ -214,7 +200,7 @@ threadstart(void *arg)
 }
 
 static SV *
-newthread (SV *startsv, AV *initargs, char *Class)
+newthread (SV *startsv, AV *initargs, char *classname)
 {
 #ifdef USE_THREADS
     dSP;
@@ -274,7 +260,7 @@ newthread (SV *startsv, AV *initargs, char *Class)
     sv = newSViv(thr->tid);
     sv_magic(sv, thr->oursv, '~', 0, 0);
     SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
-    return sv_bless(newRV_noinc(sv), gv_stashpv(Class, TRUE));
+    return sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE));
 #else
     croak("No threads in this perl");
     return &sv_undef;
@@ -294,12 +280,12 @@ MODULE = Thread           PACKAGE = Thread
 PROTOTYPES: DISABLE
 
 void
-new(Class, startsv, ...)
-       char *          Class
+new(classname, startsv, ...)
+       char *          classname
        SV *            startsv
        AV *            av = av_make(items - 2, &ST(2));
     PPCODE:
-       XPUSHs(sv_2mortal(newthread(startsv, av, Class)));
+       XPUSHs(sv_2mortal(newthread(startsv, av, classname)));
 
 void
 join(t)
@@ -329,9 +315,17 @@ join(t)
        }
        JOIN(t, &av);
 
-       /* Could easily speed up the following if necessary */
-       for (i = 0; i <= AvFILL(av); i++)
-           XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE)));
+       if (SvTRUE(*av_fetch(av, 0, FALSE))) {
+           /* Could easily speed up the following if necessary */
+           for (i = 1; i <= AvFILL(av); i++)
+               XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE)));
+       } else {
+           char *mess = SvPV(*av_fetch(av, 1, FALSE), na);
+           DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+                                 "%p: join propagating die message: %s\n",
+                                 thr, mess));
+           croak(mess);
+       }
 #endif
 
 void
@@ -379,8 +373,8 @@ flags(t)
 #endif
 
 void
-self(Class)
-       char *  Class
+self(classname)
+       char *  classname
     PREINIT:
        SV *sv;
     PPCODE:        
@@ -388,7 +382,8 @@ self(Class)
        sv = newSViv(thr->tid);
        sv_magic(sv, thr->oursv, '~', 0, 0);
        SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
-       PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv), gv_stashpv(Class, TRUE))));
+       PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv),
+                                 gv_stashpv(classname, TRUE))));
 #endif
 
 U32
@@ -486,8 +481,8 @@ CODE:
 #endif
 
 void
-list(Class)
-       char *  Class
+list(classname)
+       char *  classname
     PREINIT:
        Thread  t;
        AV *    av;
@@ -510,7 +505,7 @@ list(Class)
                    SV *sv = newSViv(0);        /* fill in tid later */
                    sv_magic(sv, 0, '~', 0, 0); /* fill in other magic later */
                    av_push(av, sv_bless(newRV_noinc(sv),
-                                        gv_stashpv(Class, TRUE)));
+                                        gv_stashpv(classname, TRUE)));
        
                }
            }
@@ -580,3 +575,14 @@ await_signal()
     OUTPUT:
        RETVAL
 
+MODULE = Thread                PACKAGE = Thread::Specific
+
+void
+data(classname = "Thread::Specific")
+       char *  classname
+    PPCODE:
+       if (AvFILL(thr->specific) == -1) {
+           GV *gv = gv_fetchpv("Thread::Specific::FIELDS", TRUE, SVt_PVHV);
+           av_store(thr->specific, 0, newRV((SV*)GvHV(gv)));
+       }
+       XPUSHs(sv_bless(newRV((SV*)thr->specific),gv_stashpv(classname,TRUE)));
diff --git a/ext/Thread/Thread/Specific.pm b/ext/Thread/Thread/Specific.pm
new file mode 100644 (file)
index 0000000..ec56539
--- /dev/null
@@ -0,0 +1,14 @@
+package Thread::Specific;
+
+sub import {
+    use attrs qw(locked method);
+    require fields;
+    fields->import(@_);
+}      
+
+sub key_create {
+    use attrs qw(locked method);
+    return ++$FIELDS{__MAX__};
+}
+
+1;
index 640256a..cba2c1c 100644 (file)
@@ -8,4 +8,4 @@ print "Starting thread\n";
 $t = new Thread \&foo, qw(foo bar baz);
 print "Joining with $t\n";
 @results = $t->join();
-print "Joining returned @results\n";
+print "Joining returned ", scalar(@results), " values: @results\n";
diff --git a/ext/Thread/specific.t b/ext/Thread/specific.t
new file mode 100644 (file)
index 0000000..da130b1
--- /dev/null
@@ -0,0 +1,17 @@
+use Thread;
+
+use Thread::Specific qw(foo);
+
+sub count {
+    my $tid = Thread->self->tid;
+    my Thread::Specific $tsd = Thread::Specific::data;
+    for (my $i = 0; $i < 5; $i++) {
+       $tsd->{foo} = $i;
+       print "thread $tid count: $tsd->{foo}\n";
+       select(undef, undef, undef, rand(2));
+    }
+};
+
+for(my $t = 0; $t < 5; $t++) {
+    new Thread \&count;
+}
diff --git a/lib/fields.pm b/lib/fields.pm
new file mode 100644 (file)
index 0000000..8e2d639
--- /dev/null
@@ -0,0 +1,18 @@
+package fields;
+
+sub import {
+    my $class = shift;
+    my ($package) = caller;
+    my $fields = \%{"$package\::FIELDS"};
+    my $i = $fields->{__MAX__};
+    foreach my $f (@_) {
+       if (defined($fields->{$f})) {
+           require Carp;
+           Carp::croak("Field name $f already in use");
+       }
+       $fields->{$f} = ++$i;
+    }
+    $fields->{__MAX__} = $i;
+}
+
+1;
diff --git a/mg.c b/mg.c
index bcb9e83..e2ecdf9 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1686,7 +1686,7 @@ sighandler(int sig)
     OP *myop = op;
     U32 flags = 0;
     I32 o_save_i = savestack_ix, type;
-    CONTEXT *cx;
+    PERL_CONTEXT *cx;
     XPV *tXpv = Xpv;
     
     if (savestack_ix + 15 <= savestack_max)
diff --git a/op.c b/op.c
index 796c034..bc672f7 100644 (file)
--- a/op.c
+++ b/op.c
@@ -163,7 +163,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
     I32 off;
     SV *sv;
     register I32 i;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     int saweval;
 
     for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
diff --git a/perl.c b/perl.c
index 40b781c..c2f7ffc 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1226,7 +1226,7 @@ perl_call_sv(SV *sv, I32 flags)
        markstack_ptr--;
        /* we're trying to emulate pp_entertry() here */
        {
-           register CONTEXT *cx;
+           register PERL_CONTEXT *cx;
            I32 gimme = GIMME_V;
            
            ENTER;
@@ -1294,7 +1294,7 @@ perl_call_sv(SV *sv, I32 flags)
            SV **newsp;
            PMOP *newpm;
            I32 gimme;
-           register CONTEXT *cx;
+           register PERL_CONTEXT *cx;
            I32 optype;
 
            POPBLOCK(cx,newpm);
@@ -2449,8 +2449,8 @@ init_stacks(ARGSproto)
     stack_sp = stack_base;
     stack_max = stack_base + 127;
 
-    cxstack_max = 8192 / sizeof(CONTEXT) - 2;  /* Use most of 8K. */
-    New(50,cxstack,cxstack_max + 1,CONTEXT);
+    cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2;     /* Use most of 8K. */
+    New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
     cxstack_ix = -1;
 
     New(50,tmps_stack,128,SV*);
@@ -2991,7 +2991,7 @@ static void
 my_exit_jump(void)
 {
     dTHR;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
 
diff --git a/perl.h b/perl.h
index 2bfe529..a2f5630 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -884,11 +884,6 @@ register struct op *op asm(stringify(OP_IN_REGISTER));
 
 #endif
 
-/* Digital UNIX defines a typedef CONTEXT when pthreads is in use */ 
-#if defined(__osf__)
-#  define CONTEXT PERL_CONTEXT
-#endif
-
 typedef MEM_SIZE STRLEN;
 
 typedef struct op OP;
@@ -917,7 +912,7 @@ typedef struct regexp REGEXP;
 typedef struct gp GP;
 typedef struct gv GV;
 typedef struct io IO;
-typedef struct context CONTEXT;
+typedef struct context PERL_CONTEXT;
 typedef struct block BLOCK;
 
 typedef struct magic MAGIC;
@@ -1949,7 +1944,7 @@ IEXT OP * Ieval_start;
 IEXT COP * VOL Icurcop IINIT(&compiling);
 IEXT COP *     Icurcopdb IINIT(NULL);
 IEXT line_t    Icopline IINIT(NOLINE);
-IEXT CONTEXT * Icxstack;
+IEXT PERL_CONTEXT *    Icxstack;
 IEXT I32       Icxstack_ix IINIT(-1);
 IEXT I32       Icxstack_max IINIT(128);
 IEXT JMPENV    Istart_env;     /* empty startup sigjmp() environment */
index df89d36..1ba4c8f 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -105,7 +105,7 @@ PP(pp_substcont)
 {
     djSP;
     register PMOP *pm = (PMOP*) cLOGOP->op_other;
-    register CONTEXT *cx = &cxstack[cxstack_ix];
+    register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
     register SV *dstr = cx->sb_dstr;
     register char *s = cx->sb_s;
     register char *m = cx->sb_m;
@@ -688,7 +688,7 @@ PP(pp_sort)
     if (sortcop) {
        if (max > 1) {
            AV *oldstack;
-           CONTEXT *cx;
+           PERL_CONTEXT *cx;
            SV** newsp;
            bool oldcatch = CATCH_GET;
 
@@ -846,7 +846,7 @@ dopoptolabel(char *label)
 {
     dTHR;
     register I32 i;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
 
     for (i = cxstack_ix; i >= 0; i--) {
        cx = &cxstack[i];
@@ -915,7 +915,7 @@ dopoptosub(I32 startingblock)
 {
     dTHR;
     I32 i;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
        cx = &cxstack[i];
        switch (cx->cx_type) {
@@ -935,7 +935,7 @@ dopoptoeval(I32 startingblock)
 {
     dTHR;
     I32 i;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
        cx = &cxstack[i];
        switch (cx->cx_type) {
@@ -954,7 +954,7 @@ dopoptoloop(I32 startingblock)
 {
     dTHR;
     I32 i;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
        cx = &cxstack[i];
        switch (cx->cx_type) {
@@ -986,7 +986,7 @@ void
 dounwind(I32 cxix)
 {
     dTHR;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     SV **newsp;
     I32 optype;
 
@@ -1021,7 +1021,7 @@ die_where(char *message)
     dTHR;
     if (in_eval) {
        I32 cxix;
-       register CONTEXT *cx;
+       register PERL_CONTEXT *cx;
        I32 gimme;
        SV **newsp;
 
@@ -1110,7 +1110,7 @@ PP(pp_caller)
 {
     djSP;
     register I32 cxix = dopoptosub(cxstack_ix);
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 dbcxix;
     I32 gimme;
     SV *sv;
@@ -1271,7 +1271,7 @@ PP(pp_dbstate)
     {
        SV **sp;
        register CV *cv;
-       register CONTEXT *cx;
+       register PERL_CONTEXT *cx;
        I32 gimme = G_ARRAY;
        I32 hasargs;
        GV *gv;
@@ -1314,7 +1314,7 @@ PP(pp_scope)
 PP(pp_enteriter)
 {
     djSP; dMARK;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
     SV **svp;
 
@@ -1346,7 +1346,7 @@ PP(pp_enteriter)
 PP(pp_enterloop)
 {
     djSP;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
 
     ENTER;
@@ -1362,7 +1362,7 @@ PP(pp_enterloop)
 PP(pp_leaveloop)
 {
     djSP;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     struct block_loop cxloop;
     I32 gimme;
     SV **newsp;
@@ -1404,7 +1404,7 @@ PP(pp_return)
 {
     djSP; dMARK;
     I32 cxix;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     struct block_sub cxsub;
     bool popsub2 = FALSE;
     I32 gimme;
@@ -1480,7 +1480,7 @@ PP(pp_last)
 {
     djSP;
     I32 cxix;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     struct block_loop cxloop;
     struct block_sub cxsub;
     I32 pop2 = 0;
@@ -1561,7 +1561,7 @@ PP(pp_last)
 PP(pp_next)
 {
     I32 cxix;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 oldsave;
 
     if (op->op_flags & OPf_SPECIAL) {
@@ -1586,7 +1586,7 @@ PP(pp_next)
 PP(pp_redo)
 {
     I32 cxix;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 oldsave;
 
     if (op->op_flags & OPf_SPECIAL) {
@@ -1663,7 +1663,7 @@ PP(pp_goto)
     djSP;
     OP *retop = 0;
     I32 ix;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
 #define GOTO_DEPTH 64
     OP *enterops[GOTO_DEPTH];
     char *label;
@@ -1676,7 +1676,7 @@ PP(pp_goto)
        /* This egregious kludge implements goto &subroutine */
        if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
            I32 cxix;
-           register CONTEXT *cx;
+           register PERL_CONTEXT *cx;
            CV* cv = (CV*)SvRV(sv);
            SV** mark;
            I32 items = 0;
@@ -2172,7 +2172,7 @@ doeval(int gimme)
     if (yyparse() || error_count || !eval_root) {
        SV **newsp;
        I32 gimme;
-       CONTEXT *cx;
+       PERL_CONTEXT *cx;
        I32 optype;
 
        op = saveop;
@@ -2243,7 +2243,7 @@ doeval(int gimme)
 PP(pp_require)
 {
     djSP;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     SV *sv;
     char *name;
     char *tryname;
@@ -2393,7 +2393,7 @@ PP(pp_dofile)
 PP(pp_entereval)
 {
     djSP;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     dPOPss;
     I32 gimme = GIMME_V, was = sub_generation;
     char tmpbuf[TYPE_DIGITS(long) + 12];
@@ -2457,7 +2457,7 @@ PP(pp_leaveeval)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     OP *retop;
     U8 save_flags = op -> op_flags;
     I32 optype;
@@ -2549,7 +2549,7 @@ PP(pp_leaveeval)
 PP(pp_entertry)
 {
     djSP;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
 
     ENTER;
@@ -2573,7 +2573,7 @@ PP(pp_leavetry)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 optype;
 
     POPBLOCK(cx,newpm);
index 141aa36..6dbc259 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1211,7 +1211,7 @@ do_readline(void)
 PP(pp_enter)
 {
     djSP;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 gimme = OP_GIMME(op, -1);
 
     if (gimme == -1) {
@@ -1281,7 +1281,7 @@ PP(pp_helem)
 PP(pp_leave)
 {
     djSP;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     register SV **mark;
     SV **newsp;
     PMOP *newpm;
@@ -1337,7 +1337,7 @@ PP(pp_leave)
 PP(pp_iter)
 {
     djSP;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     SV* sv;
     AV* av;
 
@@ -1579,7 +1579,7 @@ PP(pp_subst)
        sv_setpvn(dstr, m, s-m);
        curpm = pm;
        if (!c) {
-           register CONTEXT *cx;
+           register PERL_CONTEXT *cx;
            PUSHSUBST(cx);
            RETURNOP(cPMOP->op_pmreplroot);
        }
@@ -1680,7 +1680,7 @@ PP(pp_leavesub)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     struct block_sub cxsub;
 
     POPBLOCK(cx,newpm);
@@ -1748,7 +1748,7 @@ PP(pp_entersub)
     GV *gv;
     HV *stash;
     register CV *cv;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 gimme;
     bool hasargs = (op->op_flags & OPf_STACKED) != 0;
 
@@ -1834,9 +1834,10 @@ PP(pp_entersub)
 #ifdef USE_THREADS
     /*
      * First we need to check if the sub or method requires locking.
-     * If so, we gain a lock on the CV or the first argument, as
-     * appropriate. This has to be inline because for FAKE_THREADS,
-     * COND_WAIT inlines code to reschedule by returning a new op.
+     * If so, we gain a lock on the CV, the first argument or the
+     * stash (for static methods), as appropriate. This has to be
+     * inline because for FAKE_THREADS, COND_WAIT inlines code to
+     * reschedule by returning a new op.
      */
     MUTEX_LOCK(CvMUTEXP(cv));
     if (CvFLAGS(cv) & CVf_LOCKED) {
@@ -1850,6 +1851,11 @@ PP(pp_entersub)
            }
            if (SvROK(sv))
                sv = SvRV(sv);
+           else {              
+               STRLEN len;
+               char *stashname = SvPV(sv, len);
+               sv = (SV*)gv_stashpvn(stashname, len, TRUE);
+           }
        }
        else {
            sv = (SV*)cv;
index 3a87016..041539c 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -956,7 +956,7 @@ static OP *
 doform(CV *cv, GV *gv, OP *retop)
 {
     dTHR;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
     AV* padlist = CvPADLIST(cv);
     SV** svp = AvARRAY(padlist);
@@ -1024,7 +1024,7 @@ PP(pp_leavewrite)
     PerlIO *fp;
     SV **newsp;
     I32 gimme;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
 
     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
          (long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
@@ -3737,8 +3737,12 @@ PP(pp_gnetent)
     I32 which = op->op_type;
     register char **elem;
     register SV *sv;
-#ifndef DONT_DECLARE_STD
+#ifdef NETDB_H_OMITS_GETNET
     struct netent *getnetbyname(const char *);
+    /*
+     * long is wrong for getnetbyadddr (e.g. on Alpha). POSIX.1g says
+     * in_addr_t but then such systems don't have broken netdb.h anyway.
+     */
     struct netent *getnetbyaddr(long int, int);
     struct netent *getnetent(void);
 #endif
diff --git a/proto.h b/proto.h
index b5d60f6..b86ecd0 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -64,7 +64,7 @@ CV*   cv_clone _((CV* proto));
 SV*    cv_const_sv _((CV* cv));
 void   cv_undef _((CV* cv));
 #ifdef DEBUGGING
-void   cx_dump _((CONTEXT* cs));
+void   cx_dump _((PERL_CONTEXT* cs));
 #endif
 SV*    filter_add _((filter_t funcp, SV* datasv));
 void   filter_del _((filter_t funcp));
diff --git a/scope.c b/scope.c
index fe7cb2d..cc5c9c8 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -29,7 +29,7 @@ cxinc(void)
 {
     dTHR;
     cxstack_max = cxstack_max * 3 / 2;
-    Renew(cxstack, cxstack_max + 1, CONTEXT);  /* XXX should fix CXINC macro */
+    Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);     /* XXX should fix CXINC macro */
     return cxstack_ix + 1;
 }
 
@@ -683,7 +683,7 @@ leave_scope(I32 base)
 #ifdef DEBUGGING
 
 void
-cx_dump(CONTEXT *cx)
+cx_dump(PERL_CONTEXT *cx)
 {
     dTHR;
     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[cx->cx_type]);
index ac14981..efeda80 100755 (executable)
@@ -62,7 +62,7 @@ sub broken_pipe {
 
 print WRITER "not ok 7\n";
 close WRITER;
-
+sleep 1;
 print "ok 8\n";
 
 # VMS doesn't like spawning subprocesses that are still connected to
index eee3741..e1c48b6 100755 (executable)
@@ -104,6 +104,7 @@ sub broken_pipe {
 print $pipe "not ok 9\n";
 $pipe->close;
 
+sleep 1;
 
 print "ok 10\n";
 
index bddcd27..e48b71c 100755 (executable)
@@ -46,9 +46,9 @@ else {
 
     $| = 1;            # command buffering
 
-    $SIG{"INT"} = "ok3";     kill "INT",$$;
-    $SIG{"INT"} = "IGNORE";  kill "INT",$$; print "ok 4\n";
-    $SIG{"INT"} = "DEFAULT"; kill "INT",$$; print "not ok\n";
+    $SIG{"INT"} = "ok3";     kill "INT",$$; sleep 1;
+    $SIG{"INT"} = "IGNORE";  kill "INT",$$; sleep 1; print "ok 4\n";
+    $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print "not ok\n";
 
     sub ok3 {
        if (($x = pop(@_)) eq "INT") {
index dbfb56b..2b8e636 100644 (file)
--- a/thread.h
+++ b/thread.h
@@ -204,7 +204,7 @@ struct thread {
     U8         Tlocalizing;
     COP *      Tcurcop;
 
-    CONTEXT *  Tcxstack;
+    PERL_CONTEXT *     Tcxstack;
     I32                Tcxstack_ix;
     I32                Tcxstack_max;
 
@@ -242,10 +242,10 @@ typedef struct thread *Thread;
 #define THRf_ZOMBIE    3
 #define THRf_DEAD      4
 
-#define THRf_DIE_FATAL 8
+#define THRf_DID_DIE   8
 
 /* ThrSTATE(t) and ThrSETSTATE(t) must only be called while holding t->mutex */
-#define ThrSTATE(t) ((t)->flags)
+#define ThrSTATE(t) ((t)->flags & THRf_STATE_MASK)
 #define ThrSETSTATE(t, s) STMT_START {         \
        (t)->flags &= ~THRf_STATE_MASK;         \
        (t)->flags |= (s);                      \