develooper Front page | perl.perl5.porters | Postings from March 2006

[PATCH] 2nd patch to sync blead 'threads' with CPAN

Thread Next
From:
Jerry D. Hedden
Date:
March 24, 2006 11:28
Subject:
[PATCH] 2nd patch to sync blead 'threads' with CPAN
Message ID:
20060324122742.fb30e530d17747c2b054d625b8945d88.d36c753ee8.wbe@email.email.secureserver.net
diff -ur perl-patch1/ext/threads/Changes perl-patch2/ext/threads/Changes
--- perl-patch1/ext/threads/Changes	2006-03-23 10:33:02.000000000 -0500
+++ perl-patch2/ext/threads/Changes	2006-03-24 14:24:46.000000000 -0500
@@ -1,5 +1,10 @@
 Revision history for Perl extension threads.
 
+1.18 Fri Mar 24 14:21:36 EST 2006
+	- ->equal returns 0 on false for backwards compatibility
+	- Changed UVs to IVs in XS code (except for TID)
+	- Use ->create in tests
+
 1.17 Thu Mar 23 10:31:20 EST 2006
 	- Restoration of 'core' build parameters
 
diff -ur perl-patch1/ext/threads/README perl-patch2/ext/threads/README
--- perl-patch1/ext/threads/README	2006-03-23 10:33:08.000000000 -0500
+++ perl-patch2/ext/threads/README	2006-03-24 13:15:36.000000000 -0500
@@ -1,4 +1,4 @@
-threads version 1.17
+threads version 1.18
 ====================
 
 This module needs perl 5.8.0 or later compiled with 'useithreads'.
diff -ur perl-patch1/ext/threads/t/basic.t perl-patch2/ext/threads/t/basic.t
--- perl-patch1/ext/threads/t/basic.t	2006-03-21 17:05:38.000000000 -0500
+++ perl-patch2/ext/threads/t/basic.t	2006-03-24 12:31:18.000000000 -0500
@@ -1,19 +1,6 @@
 use strict;
 use warnings;
 
-#
-# The reason this does not use a Test module is that
-# they mess up test numbers between threads
-#
-# And even when that will be fixed, this is a basic
-# test and should not rely on shared variables
-#
-# This will test the basic API, it will not use any coderefs
-# as they are more advanced
-#
-#########################
-
-
 BEGIN {
     if ($ENV{'PERL_CORE'}){
         chdir 't';
@@ -28,7 +15,7 @@
 
 use ExtUtils::testlib;
 
-BEGIN { $| = 1; print "1..28\n" };
+BEGIN { $| = 1; print "1..30\n" };
 use threads;
 
 
@@ -147,22 +134,25 @@
 ok(20, $thr1 != $thr2,   'Treads not equal');
 ok(21, $thr1 == $thr3,   'Threads equal');
 
-ok(22, threads->object($thr1->tid())->tid() == 11, 'Object method');
-ok(23, threads->object($thr2->tid())->tid() == 12, 'Object method');
+ok(22, $thr1->_handle(), 'Handle method');
+ok(23, $thr2->_handle(), 'Handle method');
+
+ok(24, threads->object($thr1->tid())->tid() == 11, 'Object method');
+ok(25, threads->object($thr2->tid())->tid() == 12, 'Object method');
 
 $thr1->join();
 $thr2->join();
 
-my $sub = sub { ok(24, shift() == 1, "Test code ref"); };
+my $sub = sub { ok(26, shift() == 1, "Test code ref"); };
 threads->create($sub, 1)->join();
 
 my $thrx = threads->object(99);
-ok(25, ! defined($thrx), 'No object');
+ok(27, ! defined($thrx), 'No object');
 $thrx = threads->object();
-ok(26, ! defined($thrx), 'No object');
+ok(28, ! defined($thrx), 'No object');
 $thrx = threads->object(undef);
-ok(27, ! defined($thrx), 'No object');
+ok(29, ! defined($thrx), 'No object');
 $thrx = threads->object(0);
-ok(28, ! defined($thrx), 'No object');
+ok(30, ! defined($thrx), 'No object');
 
 # EOF
diff -ur perl-patch1/ext/threads/t/join.t perl-patch2/ext/threads/t/join.t
--- perl-patch1/ext/threads/t/join.t	2006-03-21 17:05:42.000000000 -0500
+++ perl-patch2/ext/threads/t/join.t	2006-03-24 11:57:48.000000000 -0500
@@ -102,7 +102,7 @@
 if ($^O eq 'linux') {
   # First modify $0 in a subthread.
   print "# mainthread: \$0 = $0\n";
-  threads->new( sub {
+  threads->create( sub {
 		  print "# subthread: \$0 = $0\n";
 		  $0 = "foobar";
 		  print "# subthread: \$0 = $0\n" } )->join;
@@ -135,9 +135,9 @@
 }
 
 {
-    my $t = threads->new(sub {});
+    my $t = threads->create(sub {});
     $t->join;
-    my $x = threads->new(sub {});
+    my $x = threads->create(sub {});
     $x->join;
     eval {
       $t->join;
@@ -153,6 +153,6 @@
     # archives for the thread "maint@20974 or before broke mp2 ithreads test".
     use IO::File;
     # this coredumped between #20930 and #21000
-    $_->join for map threads->new(sub{ok($_, "stress newCONSTSUB")}), 1..2;
+    $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2;
 }
 
diff -ur perl-patch1/ext/threads/t/list.t perl-patch2/ext/threads/t/list.t
--- perl-patch1/ext/threads/t/list.t	2006-03-21 17:05:42.000000000 -0500
+++ perl-patch2/ext/threads/t/list.t	2006-03-24 12:35:56.000000000 -0500
@@ -17,7 +17,7 @@
 
 
 
-BEGIN { $| = 1; print "1..8\n" };
+BEGIN { $| = 1; print "1..15\n" };
 use threads;
 
 
@@ -37,21 +37,36 @@
     return $ok;
 }
 
-ok(2, scalar @{[threads->list]} == 0,'');
-
+### Start of Testing ###
 
+ok(2, scalar @{[threads->list()]} == 0, 'No threads yet');
 
 threads->create(sub {})->join();
-ok(3, scalar @{[threads->list]} == 0,'');
+ok(3, scalar @{[threads->list()]} == 0, 'Empty thread list after join');
 
 my $thread = threads->create(sub {});
-ok(4, scalar @{[threads->list]} == 1,'');
+ok(4, scalar(threads->list()) == 1, 'Non-empty thread list');
+ok(5, threads->list() == 1,             'Non-empty thread list');
 $thread->join();
-ok(5, scalar @{[threads->list]} == 0,'');
+ok(6, scalar @{[threads->list()]} == 0, 'Thread list empty again');
+ok(7, threads->list() == 0,             'Thread list empty again');
+
+$thread = threads->create(sub {
+    ok(8, threads->list() == 1, 'Non-empty thread list in thread');
+    ok(9, threads->self == (threads->list())[0], 'Self in thread list')
+});
 
-$thread = threads->create(sub { ok(6, threads->self == (threads->list)[0],'')});
 threads->yield; # help out non-preemptive thread implementations
 sleep 1;
-ok(7, $thread == (threads->list)[0],'');
+
+ok(10, scalar(threads->list()) == 1, 'Thread count 1');
+ok(11, threads->list() == 1,             'Thread count 1');
+my $cnt = threads->list();
+ok(12, $cnt == 1,                        'Thread count 1');
+my ($thr_x) = threads->list();
+ok(13, $thread == $thr_x,                'Thread in list');
 $thread->join();
-ok(8, scalar @{[threads->list]} == 0,'');
+ok(14, scalar @{[threads->list()]} == 0, 'Thread list empty');
+ok(15, threads->list() == 0,             'Thread list empty');
+
+# EOF
diff -ur perl-patch1/ext/threads/t/problems.t perl-patch2/ext/threads/t/problems.t
--- perl-patch1/ext/threads/t/problems.t	2006-03-22 11:13:38.000000000 -0500
+++ perl-patch2/ext/threads/t/problems.t	2006-03-24 11:57:52.000000000 -0500
@@ -85,7 +85,7 @@
 #########################
 
 if ($] == 5.008 || $] >= 5.008003) {
-    threads->new( sub {1} )->join;
+    threads->create( sub {1} )->join;
     my $not = eval { Config::myconfig() } ? '' : 'not ';
     print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
 } else {
@@ -99,7 +99,7 @@
 our $unique_scalar : unique;
 our @unique_array : unique;
 our %unique_hash : unique;
-threads->new(
+threads->create(
     sub {
 	my $TODO = ":unique needs to be re-implemented in a non-broken way";
 	eval { $unique_scalar = 1 };
@@ -147,7 +147,7 @@
 #     sub { $x."bar" };
 # }
 # 
-# my $string = threads->new(\&f)->join->();
+# my $string = threads->create(\&f)->join->();
 # print $string eq 'foobar' ?  '' : 'not ', "ok $test - returning closure\n";
 # $test++;
 
@@ -157,7 +157,7 @@
 my %h = (1,2,3,4);
 is (keys %h, 2, "keys correct in parent");
 
-my $child = threads->new(sub { return scalar keys %h })->join;
+my $child = threads->create(sub { return scalar keys %h })->join;
 is ($child, 2, "keys correct in child");
 
 lock_keys (%h);
@@ -165,7 +165,7 @@
 
 is (keys %h, 1, "keys correct in parent with restricted hash");
 
-$child = threads->new(sub { return scalar keys %h })->join;
+$child = threads->create(sub { return scalar keys %h })->join;
 is ($child, 1, "keys correct in child with restricted hash");
 
 1;
diff -ur perl-patch1/ext/threads/t/thread.t perl-patch2/ext/threads/t/thread.t
--- perl-patch1/ext/threads/t/thread.t	2006-03-21 17:05:42.000000000 -0500
+++ perl-patch2/ext/threads/t/thread.t	2006-03-24 11:57:52.000000000 -0500
@@ -28,7 +28,7 @@
     return shift;
 }
 {
-    my $t = threads->new(\&content, "ok 2\n", "ok 3\n", 1..1000);
+    my $t = threads->create(\&content, "ok 2\n", "ok 3\n", 1..1000);
     print $t->join();
 }
 {
@@ -36,7 +36,7 @@
     my $t;
     {
 	lock($lock);
-	$t = threads->new(sub { lock($lock); print "ok 5\n"});
+	$t = threads->create(sub { lock($lock); print "ok 5\n"});
 	print "ok 4\n";
     }
     $t->join();
@@ -47,18 +47,18 @@
     my $ret;
     print $val;
     if(@_) {
-	$ret = threads->new(\&dorecurse, @_);
+	$ret = threads->create(\&dorecurse, @_);
 	$ret->join;
     }
 }
 {
-    my $t = threads->new(\&dorecurse, map { "ok $_\n" } 6..10);
+    my $t = threads->create(\&dorecurse, map { "ok $_\n" } 6..10);
     $t->join();
 }
 
 {
     # test that sleep lets other thread run
-    my $t = threads->new(\&dorecurse, "ok 11\n");
+    my $t = threads->create(\&dorecurse, "ok 11\n");
     threads->yield; # help out non-preemptive thread implementations
     sleep 1;
     print "ok 12\n";
@@ -72,11 +72,11 @@
 	my $ret;
 	print $val;
 	if (@_) {
-	    $ret = threads->new(\&islocked, shift);
+	    $ret = threads->create(\&islocked, shift);
 	}
 	return $ret;
     }
-my $t = threads->new(\&islocked, "ok 13\n", "ok 14\n");
+my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n");
 $t->join->join;
 }
 
@@ -103,8 +103,8 @@
 { 
     curr_test(15);
 
-    my $thr1 = threads->new(\&testsprintf, 15);
-    my $thr2 = threads->new(\&testsprintf, 16);
+    my $thr1 = threads->create(\&testsprintf, 15);
+    my $thr2 = threads->create(\&testsprintf, 16);
     
     my $short = "This is a long string that goes on and on.";
     my $shorte = " a long string that goes on and on.";
@@ -150,7 +150,7 @@
     # since it tests rand	
     my %rand : shared;
     rand(10);
-    threads->new( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
+    threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
     $_->join foreach threads->list;
 #    use Data::Dumper qw(Dumper);
 #    print Dumper(\%rand);
@@ -161,7 +161,7 @@
 # bugid #24165
 
 run_perl(prog =>
-    'use threads; sub a{threads->new(shift)} $t = a sub{}; $t->tid; $t->join; $t->tid');
+    'use threads; sub a{threads->create(shift)} $t = a sub{}; $t->tid; $t->join; $t->tid');
 is($?, 0, 'coredump in global destruction');
 
 # test CLONE_SKIP() functionality
@@ -233,7 +233,7 @@
 	    $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs;
 	    is($cloned, ($depth ? '00010001111' : '11111111111'),
 		"objs clone skip at depth $depth");
-	    threads->new( \&f, $depth+1)->join if $depth < 2;
+	    threads->create( \&f, $depth+1)->join if $depth < 2;
 	    @objs = ();
 	}
 	f(0);
diff -ur perl-patch1/ext/threads/threads.pm perl-patch2/ext/threads/threads.pm
--- perl-patch1/ext/threads/threads.pm	2006-03-23 10:33:18.000000000 -0500
+++ perl-patch2/ext/threads/threads.pm	2006-03-24 13:15:52.000000000 -0500
@@ -38,7 +38,7 @@
                if($threads::shared::threads_shared);
 }
 
-our $VERSION = '1.17';
+our $VERSION = '1.18';
 
 
 # Load the XS code
@@ -76,25 +76,14 @@
 
 ### Methods, etc. ###
 
-# || 0 to ensure compatibility with previous versions
-sub equal { ($_[0]->tid == $_[1]->tid) || 0 }
-
 # use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2)
 # should also be faster
 sub async (&;@) { unshift @_,'threads'; goto &new }
 
-sub object {
-    return undef unless @_ > 1;
-    foreach (threads->list) {
-        return $_ if $_->tid == $_[1];
-    }
-    return undef;
-}
-
 $threads::threads = 1;
 
-# why document 'new' then use 'create' in the tests!
-*create = \&new;
+# 'new' is an alias for 'create'
+*new = \&create;
 
 1;
 
@@ -106,7 +95,7 @@
 
 =head1 VERSION
 
-This document describes threads version 1.17
+This document describes threads version 1.18
 
 =head1 SYNOPSIS
 
@@ -276,9 +265,10 @@
 You may do C<use threads qw(yield)> then use just a bare C<yield> in your
 code.
 
-=item threads->list();
+=item threads->list()
 
-This will return a list of all non joined, non detached threads.
+In a list context, returns a list of all non-joined, non-detached I<threads>
+objects.  In a scalar context, returns a count of the same.
 
 =item $thr1->equal($thr2)
 
@@ -298,6 +288,22 @@
 semi-colon after the closing brace. Like C<< threads->new >>, C<async>
 returns a thread object.
 
+=item $thr->_handle()
+
+This I<private> method returns the memory location of the internal thread
+structure associated with a threads object.  For Win32, this is the handle
+returned by C<CreateThread>; for other platforms, it is the pointer returned
+by C<pthread_create>.
+
+This method is of no use for general Perl threads programming.  Its intent is
+to provide other (XS-based) thread modules with the capability to access, and
+possibly manipulate, the underlying thread structure associated with a Perl
+thread.
+
+=item threads->_handle()
+
+Class method that allows a thread to obtain its own I<handle>.
+
 =back
 
 =head1 WARNINGS
@@ -338,11 +344,6 @@
 On some platforms it might not be possible to destroy "parent"
 threads while there are still existing child "threads".
 
-=item tid is I32
-
-The thread id is a 32 bit integer, it can potentially overflow.
-This might be fixed in a later version of perl.
-
 =item Creating threads inside BEGIN blocks
 
 Creating threads inside BEGIN blocks (or during the compilation phase
@@ -375,6 +376,9 @@
 
 =back
 
+View existing bug reports at, and submit any new bugs, problems, patches, etc.
+to: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=threads>
+
 =head1 REQUIREMENTS
 
 Perl 5.8.0 or later
@@ -385,7 +389,7 @@
 L<http://www.cpanforum.com/dist/threads>
 
 Annotated POD for L<threads>:
-L<http://annocpan.org/~JDHEDDEN/threads-1.17/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.18/shared.pm>
 
 L<threads::shared>, L<perlthrtut>
 
diff -ur perl-patch1/ext/threads/threads.xs perl-patch2/ext/threads/threads.xs
--- perl-patch1/ext/threads/threads.xs	2006-03-23 10:24:40.000000000 -0500
+++ perl-patch2/ext/threads/threads.xs	2006-03-24 12:16:40.000000000 -0500
@@ -43,9 +43,9 @@
     struct ithread_s *next;	/* Next thread in the list */
     struct ithread_s *prev;	/* Prev thread in the list */
     PerlInterpreter *interp;	/* The threads interpreter */
-    I32 tid;              	/* Threads module's thread id */
+    UV tid;              	/* Threads module's thread id */
     perl_mutex mutex; 		/* Mutex for updating things in this struct */
-    I32 count;			/* How many SVs have a reference to us */
+    IV count;			/* How many SVs have a reference to us */
     signed char state;		/* Are we detached ? */
     int gimme;			/* Context of create */
     SV* init_function;          /* Code to run */
@@ -67,30 +67,24 @@
 START_MY_CXT
 
 
-ithread *threads;
-
-/* Macros to supply the aTHX_ in an embed.h like manner */
-#define ithread_join(thread)		Perl_ithread_join(aTHX_ thread)
-#define ithread_DESTROY(thread)		Perl_ithread_DESTROY(aTHX_ thread)
-#define ithread_CLONE(thread)		Perl_ithread_CLONE(aTHX_ thread)
-#define ithread_detach(thread)		Perl_ithread_detach(aTHX_ thread)
-#define ithread_tid(thread)		((thread)->tid)
-#define ithread_yield(thread)		(YIELD);
+static ithread *threads;
 
 static perl_mutex create_destruct_mutex;  /* protects the creation and destruction of threads*/
 
-I32 tid_counter = 0;
-I32 known_threads = 0;
-I32 active_threads = 0;
+static UV tid_counter = 0;
+static IV known_threads = 0;
+static IV active_threads = 0;
 
 
-void Perl_ithread_set (pTHX_ ithread* thread)
+static void
+Perl_ithread_set (pTHX_ ithread* thread)
 {
     dMY_CXT;
     MY_CXT.thread = thread;
 }
 
-ithread* Perl_ithread_get (pTHX) {
+static ithread*
+Perl_ithread_get (pTHX) {
     dMY_CXT;
     return MY_CXT.thread;
 }
@@ -192,7 +186,7 @@
     if (aTHX == PL_curinterp && active_threads != 1) {
 	if (ckWARN_d(WARN_THREADS))
 	    Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
-						      (IV)active_threads);
+						      active_threads);
 	veto_cleanup = 1;
     }
     MUTEX_UNLOCK(&create_destruct_mutex);
@@ -284,10 +278,10 @@
  */
 
 #ifdef WIN32
-THREAD_RET_TYPE
+static THREAD_RET_TYPE
 Perl_ithread_run(LPVOID arg) {
 #else
-void*
+static void*
 Perl_ithread_run(void * arg) {
 #endif
 	ithread* thread = (ithread*) arg;
@@ -310,22 +304,22 @@
 
 	{
 		AV* params = (AV*) SvRV(thread->params);
-		I32 len = av_len(params)+1;
-		int i;
+		int len = (int)av_len(params)+1;
+		int ii;
 		dSP;
 		ENTER;
 		SAVETMPS;
 		PUSHMARK(SP);
-		for(i = 0; i < len; i++) {
+		for(ii = 0; ii < len; ii++) {
 		    XPUSHs(av_shift(params));
 		}
 		PUTBACK;
-		len = call_sv(thread->init_function, thread->gimme|G_EVAL);
+		len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
 
 		SPAGAIN;
-		for (i=len-1; i >= 0; i--) {
+		for (ii=len-1; ii >= 0; ii--) {
 		  SV *sv = POPs;
-		  av_store(params, i, SvREFCNT_inc(sv));
+		  av_store(params, ii, SvREFCNT_inc(sv));
 		}
 		if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
 		    Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
@@ -357,7 +351,7 @@
 #endif
 }
 
-SV *
+static SV *
 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
 {
     SV *sv;
@@ -377,7 +371,7 @@
     return obj;
 }
 
-ithread *
+static ithread *
 SV_to_ithread(pTHX_ SV *sv)
 {
     if (SvROK(sv))
@@ -395,7 +389,7 @@
  * Called in context of parent thread
  */
 
-SV *
+static SV *
 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
 {
 	ithread*	thread;
@@ -403,7 +397,7 @@
 	ithread*        current_thread = Perl_ithread_get(aTHX);
 
 	SV**            tmps_tmp = PL_tmps_stack;
-	I32             tmps_ix  = PL_tmps_ix;
+	IV              tmps_ix  = PL_tmps_ix;
 #ifndef WIN32
 	int		failure;
 	const char*	panic = NULL;
@@ -572,7 +566,7 @@
 	return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
 }
 
-SV*
+static SV*
 Perl_ithread_self (pTHX_ SV *obj, char* Class)
 {
    ithread *thread = Perl_ithread_get(aTHX);
@@ -583,23 +577,11 @@
    return NULL; /* silence compiler warning */
 }
 
-/*
- * Joins the thread this code needs to take the returnvalue from the
- * call_sv and send it back
- */
-
-void
-Perl_ithread_CLONE(pTHX_ SV *obj)
-{
-    if (SvROK(obj)) {
-	ithread *thread = SV_to_ithread(aTHX_ obj);
-    }
-    else if (ckWARN_d(WARN_THREADS)) {
-	Perl_warn(aTHX_ "CLONE %" SVf,obj);
-    }
-}
 
-AV*
+/* Joins the thread.
+ * This code takes the return value from the call_sv and sends it back.
+ */
+static AV*
 Perl_ithread_join(pTHX_ SV *obj)
 {
     ithread *thread = SV_to_ithread(aTHX_ obj);
@@ -681,7 +663,7 @@
     return (AV*)NULL;
 }
 
-void
+static void
 Perl_ithread_DESTROY(pTHX_ SV *sv)
 {
     ithread *thread = SV_to_ithread(aTHX_ sv);
@@ -696,83 +678,222 @@
 #ifdef USE_ITHREADS
 
 void
-ithread_new (classname, function_to_call, ...)
-char *	classname
-SV *	function_to_call
-CODE:
-{
-    AV* params = newAV();
-    if (items > 2) {
-	int i;
-	for(i = 2; i < items ; i++) {
-	    av_push(params, SvREFCNT_inc(ST(i)));
-	}
-    }
-    ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
-    XSRETURN(1);
-}
+ithread_create(...)
+    PREINIT:
+        char *classname;
+        SV *function_to_call;
+        AV *params;
+        int ii;
+    CODE:
+        if (items < 2)
+            Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
+
+        classname = (char *)SvPV_nolen(ST(0));
+        function_to_call = ST(1);
+
+        /* Function args */
+        params = newAV();
+        if (items > 2) {
+            for (ii=2; ii < items; ii++) {
+                av_push(params, SvREFCNT_inc(ST(ii)));
+            }
+        }
+
+        /* Create thread */
+        ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv,
+                                               classname,
+                                               function_to_call,
+                                               newRV_noinc((SV*)params)));
+        /* XSRETURN(1); - implied */
+
 
 void
-ithread_list(char *classname)
-PPCODE:
-{
-  ithread *curr_thread;
-  MUTEX_LOCK(&create_destruct_mutex);
-  curr_thread = threads;
-  if(curr_thread->tid != 0)	
-    XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
-  while(curr_thread) {
-    curr_thread = curr_thread->next;
-    if(curr_thread == threads)
-      break;
-    if(curr_thread->state & PERL_ITHR_DETACHED ||
-       curr_thread->state & PERL_ITHR_JOINED)
-         continue;
-     XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
-  }	
-  MUTEX_UNLOCK(&create_destruct_mutex);
-}
+ithread_list(...)
+    PREINIT:
+        char *classname;
+        ithread *thr;
+        int list_context;
+        IV count = 0;
+    PPCODE:
+        /* Class method only */
+        if (SvROK(ST(0)))
+            Perl_croak(aTHX_ "Usage: threads->list()");
+        classname = (char *)SvPV_nolen(ST(0));
+
+        /* Calling context */
+        list_context = (GIMME_V == G_ARRAY);
+
+        /* Walk through threads list */
+        MUTEX_LOCK(&create_destruct_mutex);
+        for (thr = threads->next;
+             thr != threads;
+             thr = thr->next)
+        {
+            /* Ignore detached or joined threads */
+            if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
+                continue;
+            }
+            /* Push object on stack if list context */
+            if (list_context) {
+                XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)));
+            }
+            count++;
+        }
+        MUTEX_UNLOCK(&create_destruct_mutex);
+        /* If scalar context, send back count */
+        if (! list_context) {
+            XSRETURN_IV(count);
+        }
 
 
 void
-ithread_self(char *classname)
-CODE:
-{
-	ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
-	XSRETURN(1);
-}
+ithread_self(...)
+    PREINIT:
+        char *classname;
+    CODE:
+        /* Class method only */
+        if (SvROK(ST(0)))
+            Perl_croak(aTHX_ "Usage: threads->self()");
+        classname = (char *)SvPV_nolen(ST(0));
+
+        ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv, classname));
+        /* XSRETURN(1); - implied */
 
-int
-ithread_tid(ithread *thread)
 
 void
-ithread_join(SV *obj)
-PPCODE:
-{
-  AV* params = Perl_ithread_join(aTHX_ obj);
-  int i;
-  I32 len = AvFILL(params);
-  for (i = 0; i <= len; i++) {
-    SV* tmp = av_shift(params);
-    XPUSHs(tmp);
-    sv_2mortal(tmp);
-  }
-  SvREFCNT_dec(params);
-}
+ithread_tid(...)
+    PREINIT:
+        ithread *thread;
+    CODE:
+        thread = SV_to_ithread(aTHX_ ST(0));
+        XST_mUV(0, thread->tid);
+        /* XSRETURN(1); - implied */
+
 
 void
-yield(...)
-CODE:
-{
-    YIELD;
-}
-	
+ithread_join(...)
+    PREINIT:
+        AV *params;
+        int len;
+        int ii;
+    PPCODE:
+        /* Object method only */
+        if (! sv_isobject(ST(0)))
+            Perl_croak(aTHX_ "Usage: $thr->join()");
+
+        /* Join thread and get return values */
+        params = Perl_ithread_join(aTHX_ ST(0));
+        if (! params) {
+            XSRETURN_UNDEF;
+        }
+
+        /* Put return values on stack */
+        len = (int)AvFILL(params);
+        for (ii=0; ii <= len; ii++) {
+            SV* param = av_shift(params);
+            XPUSHs(sv_2mortal(param));
+        }
+
+        /* Free return value array */
+        SvREFCNT_dec(params);
+
+
+void
+ithread_yield(...)
+    CODE:
+        YIELD;
+
+
+void
+ithread_detach(...)
+    PREINIT:
+        ithread *thread;
+    CODE:
+        thread = SV_to_ithread(aTHX_ ST(0));
+        Perl_ithread_detach(aTHX_ thread);
+
+
+void
+ithread_DESTROY(...)
+    CODE:
+        Perl_ithread_DESTROY(aTHX_ ST(0));
+
 
 void
-ithread_detach(ithread *thread)
+ithread_equal(...)
+    CODE:
+        /* Compares TIDs to determine thread equality.
+         * Return 0 on false for backward compatibility.
+         */
+        if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
+            ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
+            ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
+            if (thr1->tid == thr2->tid) {
+                XST_mYES(0);
+            } else {
+                XST_mIV(0, 0);
+            }
+        } else {
+            XST_mIV(0, 0);
+        }
+        /* XSRETURN(1); - implied */
+
 
 void
-ithread_DESTROY(SV *thread)
+ithread_object(...)
+    PREINIT:
+        char *classname;
+        UV tid;
+        ithread *thr;
+        int found = 0;
+    CODE:
+        /* Class method only */
+        if (SvROK(ST(0)))
+            Perl_croak(aTHX_ "Usage: threads->object($tid)");
+        classname = (char *)SvPV_nolen(ST(0));
+
+        if ((items < 2) || ! SvOK(ST(1))) {
+            XSRETURN_UNDEF;
+        }
+
+        tid = SvUV(ST(1));
+
+        /* Walk through threads list */
+        MUTEX_LOCK(&create_destruct_mutex);
+        for (thr = threads->next;
+             thr != threads;
+             thr = thr->next)
+        {
+            /* Look for TID, but ignore detached or joined threads */
+            if ((thr->tid != tid) ||
+                (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
+            {
+                continue;
+            }
+            /* Put object on stack */
+            ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
+            found = 1;
+            break;
+        }
+        MUTEX_UNLOCK(&create_destruct_mutex);
+        if (! found) {
+            XSRETURN_UNDEF;
+        }
+        /* XSRETURN(1); - implied */
+
+
+void
+ithread__handle(...);
+    PREINIT:
+        ithread *thread;
+    CODE:
+        thread = SV_to_ithread(aTHX_ ST(0));
+#ifdef WIN32
+        XST_mUV(0, PTR2UV(thread->handle));
+#else
+        XST_mUV(0, PTR2UV(thread->thr));
+#endif
+        /* XSRETURN(1); - implied */
 
 #endif /* USE_ITHREADS */
 

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About