Move threads from ext/ to dist/
[perl.git] / ext / threads-shared / shared.pm
1 package threads::shared;
2
3 use 5.008;
4
5 use strict;
6 use warnings;
7
8 use Scalar::Util qw(reftype refaddr blessed);
9
10 our $VERSION = '1.31';
11 my $XS_VERSION = $VERSION;
12 $VERSION = eval $VERSION;
13
14 # Declare that we have been loaded
15 $threads::shared::threads_shared = 1;
16
17 # Load the XS code, if applicable
18 if ($threads::threads) {
19     require XSLoader;
20     XSLoader::load('threads::shared', $XS_VERSION);
21
22     *is_shared = \&_id;
23
24 } else {
25     # String eval is generally evil, but we don't want these subs to
26     # exist at all if 'threads' is not loaded successfully.
27     # Vivifying them conditionally this way saves on average about 4K
28     # of memory per thread.
29     eval <<'_MARKER_';
30         sub share          (\[$@%])         { return $_[0] }
31         sub is_shared      (\[$@%])         { undef }
32         sub cond_wait      (\[$@%];\[$@%])  { undef }
33         sub cond_timedwait (\[$@%]$;\[$@%]) { undef }
34         sub cond_signal    (\[$@%])         { undef }
35         sub cond_broadcast (\[$@%])         { undef }
36 _MARKER_
37 }
38
39
40 ### Export ###
41
42 sub import
43 {
44     # Exported subroutines
45     my @EXPORT = qw(share is_shared cond_wait cond_timedwait
46                     cond_signal cond_broadcast shared_clone);
47     if ($threads::threads) {
48         push(@EXPORT, 'bless');
49     }
50
51     # Export subroutine names
52     my $caller = caller();
53     foreach my $sym (@EXPORT) {
54         no strict 'refs';
55         *{$caller.'::'.$sym} = \&{$sym};
56     }
57 }
58
59
60 # Predeclarations for internal functions
61 my ($make_shared);
62
63
64 ### Methods, etc. ###
65
66 sub threads::shared::tie::SPLICE
67 {
68     require Carp;
69     Carp::croak('Splice not implemented for shared arrays');
70 }
71
72
73 # Create a thread-shared clone of a complex data structure or object
74 sub shared_clone
75 {
76     if (@_ != 1) {
77         require Carp;
78         Carp::croak('Usage: shared_clone(REF)');
79     }
80
81     return $make_shared->(shift, {});
82 }
83
84
85 ### Internal Functions ###
86
87 # Used by shared_clone() to recursively clone
88 #   a complex data structure or object
89 $make_shared = sub {
90     my ($item, $cloned) = @_;
91
92     # Just return the item if:
93     # 1. Not a ref;
94     # 2. Already shared; or
95     # 3. Not running 'threads'.
96     return $item if (! ref($item) || is_shared($item) || ! $threads::threads);
97
98     # Check for previously cloned references
99     #   (this takes care of circular refs as well)
100     my $addr = refaddr($item);
101     if (exists($cloned->{$addr})) {
102         # Return the already existing clone
103         return $cloned->{$addr};
104     }
105
106     # Make copies of array, hash and scalar refs and refs of refs
107     my $copy;
108     my $ref_type = reftype($item);
109
110     # Copy an array ref
111     if ($ref_type eq 'ARRAY') {
112         # Make empty shared array ref
113         $copy = &share([]);
114         # Add to clone checking hash
115         $cloned->{$addr} = $copy;
116         # Recursively copy and add contents
117         push(@$copy, map { $make_shared->($_, $cloned) } @$item);
118     }
119
120     # Copy a hash ref
121     elsif ($ref_type eq 'HASH') {
122         # Make empty shared hash ref
123         $copy = &share({});
124         # Add to clone checking hash
125         $cloned->{$addr} = $copy;
126         # Recursively copy and add contents
127         foreach my $key (keys(%{$item})) {
128             $copy->{$key} = $make_shared->($item->{$key}, $cloned);
129         }
130     }
131
132     # Copy a scalar ref
133     elsif ($ref_type eq 'SCALAR') {
134         $copy = \do{ my $scalar = $$item; };
135         share($copy);
136         # Add to clone checking hash
137         $cloned->{$addr} = $copy;
138     }
139
140     # Copy of a ref of a ref
141     elsif ($ref_type eq 'REF') {
142         # Special handling for $x = \$x
143         if ($addr == refaddr($$item)) {
144             $copy = \$copy;
145             share($copy);
146             $cloned->{$addr} = $copy;
147         } else {
148             my $tmp;
149             $copy = \$tmp;
150             share($copy);
151             # Add to clone checking hash
152             $cloned->{$addr} = $copy;
153             # Recursively copy and add contents
154             $tmp = $make_shared->($$item, $cloned);
155         }
156
157     } else {
158         require Carp;
159         Carp::croak("Unsupported ref type: ", $ref_type);
160     }
161
162     # If input item is an object, then bless the copy into the same class
163     if (my $class = blessed($item)) {
164         bless($copy, $class);
165     }
166
167     # Clone READONLY flag
168     if ($ref_type eq 'SCALAR') {
169         if (Internals::SvREADONLY($$item)) {
170             Internals::SvREADONLY($$copy, 1) if ($] >= 5.008003);
171         }
172     }
173     if (Internals::SvREADONLY($item)) {
174         Internals::SvREADONLY($copy, 1) if ($] >= 5.008003);
175     }
176
177     return $copy;
178 };
179
180 1;
181
182 __END__
183
184 =head1 NAME
185
186 threads::shared - Perl extension for sharing data structures between threads
187
188 =head1 VERSION
189
190 This document describes threads::shared version 1.31
191
192 =head1 SYNOPSIS
193
194   use threads;
195   use threads::shared;
196
197   my $var :shared;
198   my %hsh :shared;
199   my @ary :shared;
200
201   my ($scalar, @array, %hash);
202   share($scalar);
203   share(@array);
204   share(%hash);
205
206   $var = $scalar_value;
207   $var = $shared_ref_value;
208   $var = shared_clone($non_shared_ref_value);
209   $var = shared_clone({'foo' => [qw/foo bar baz/]});
210
211   $hsh{'foo'} = $scalar_value;
212   $hsh{'bar'} = $shared_ref_value;
213   $hsh{'baz'} = shared_clone($non_shared_ref_value);
214   $hsh{'quz'} = shared_clone([1..3]);
215
216   $ary[0] = $scalar_value;
217   $ary[1] = $shared_ref_value;
218   $ary[2] = shared_clone($non_shared_ref_value);
219   $ary[3] = shared_clone([ {}, [] ]);
220
221   { lock(%hash); ...  }
222
223   cond_wait($scalar);
224   cond_timedwait($scalar, time() + 30);
225   cond_broadcast(@array);
226   cond_signal(%hash);
227
228   my $lockvar :shared;
229   # condition var != lock var
230   cond_wait($var, $lockvar);
231   cond_timedwait($var, time()+30, $lockvar);
232
233 =head1 DESCRIPTION
234
235 By default, variables are private to each thread, and each newly created
236 thread gets a private copy of each existing variable.  This module allows you
237 to share variables across different threads (and pseudo-forks on Win32).  It
238 is used together with the L<threads> module.
239
240 This module supports the sharing of the following data types only:  scalars
241 and scalar refs, arrays and array refs, and hashes and hash refs.
242
243 =head1 EXPORT
244
245 The following functions are exported by this module: C<share>,
246 C<shared_clone>, C<is_shared>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>
247 and C<cond_broadcast>
248
249 Note that if this module is imported when L<threads> has not yet been loaded,
250 then these functions all become no-ops.  This makes it possible to write
251 modules that will work in both threaded and non-threaded environments.
252
253 =head1 FUNCTIONS
254
255 =over 4
256
257 =item share VARIABLE
258
259 C<share> takes a variable and marks it as shared:
260
261   my ($scalar, @array, %hash);
262   share($scalar);
263   share(@array);
264   share(%hash);
265
266 C<share> will return the shared rvalue, but always as a reference.
267
268 Variables can also be marked as shared at compile time by using the
269 C<:shared> attribute:
270
271   my ($var, %hash, @array) :shared;
272
273 Shared variables can only store scalars, refs of shared variables, or
274 refs of shared data (discussed in next section):
275
276   my ($var, %hash, @array) :shared;
277   my $bork;
278
279   # Storing scalars
280   $var = 1;
281   $hash{'foo'} = 'bar';
282   $array[0] = 1.5;
283
284   # Storing shared refs
285   $var = \%hash;
286   $hash{'ary'} = \@array;
287   $array[1] = \$var;
288
289   # The following are errors:
290   #   $var = \$bork;                    # ref of non-shared variable
291   #   $hash{'bork'} = [];               # non-shared array ref
292   #   push(@array, { 'x' => 1 });       # non-shared hash ref
293
294 =item shared_clone REF
295
296 C<shared_clone> takes a reference, and returns a shared version of its
297 argument, performing a deep copy on any non-shared elements.  Any shared
298 elements in the argument are used as is (i.e., they are not cloned).
299
300   my $cpy = shared_clone({'foo' => [qw/foo bar baz/]});
301
302 Object status (i.e., the class an object is blessed into) is also cloned.
303
304   my $obj = {'foo' => [qw/foo bar baz/]};
305   bless($obj, 'Foo');
306   my $cpy = shared_clone($obj);
307   print(ref($cpy), "\n");         # Outputs 'Foo'
308
309 For cloning empty array or hash refs, the following may also be used:
310
311   $var = &share([]);   # Same as $var = shared_clone([]);
312   $var = &share({});   # Same as $var = shared_clone({});
313
314 =item is_shared VARIABLE
315
316 C<is_shared> checks if the specified variable is shared or not.  If shared,
317 returns the variable's internal ID (similar to
318 L<refaddr()|Scalar::Util/"refaddr EXPR">).  Otherwise, returns C<undef>.
319
320   if (is_shared($var)) {
321       print("\$var is shared\n");
322   } else {
323       print("\$var is not shared\n");
324   }
325
326 When used on an element of an array or hash, C<is_shared> checks if the
327 specified element belongs to a shared array or hash.  (It does not check
328 the contents of that element.)
329
330   my %hash :shared;
331   if (is_shared(%hash)) {
332       print("\%hash is shared\n");
333   }
334
335   $hash{'elem'} = 1;
336   if (is_shared($hash{'elem'})) {
337       print("\$hash{'elem'} is in a shared hash\n");
338   }
339
340 =item lock VARIABLE
341
342 C<lock> places a B<advisory> lock on a variable until the lock goes out of
343 scope.  If the variable is locked by another thread, the C<lock> call will
344 block until it's available.  Multiple calls to C<lock> by the same thread from
345 within dynamically nested scopes are safe -- the variable will remain locked
346 until the outermost lock on the variable goes out of scope.
347
348 C<lock> follows references exactly I<one> level:
349
350   my %hash :shared;
351   my $ref = \%hash;
352   lock($ref);           # This is equivalent to lock(%hash)
353
354 Note that you cannot explicitly unlock a variable; you can only wait for the
355 lock to go out of scope.  This is most easily accomplished by locking the
356 variable inside a block.
357
358   my $var :shared;
359   {
360       lock($var);
361       # $var is locked from here to the end of the block
362       ...
363   }
364   # $var is now unlocked
365
366 As locks are advisory, they do not prevent data access or modification by
367 another thread that does not itself attempt to obtain a lock on the variable.
368
369 You cannot lock the individual elements of a container variable:
370
371   my %hash :shared;
372   $hash{'foo'} = 'bar';
373   #lock($hash{'foo'});          # Error
374   lock(%hash);                  # Works
375
376 If you need more fine-grained control over shared variable access, see
377 L<Thread::Semaphore>.
378
379 =item cond_wait VARIABLE
380
381 =item cond_wait CONDVAR, LOCKVAR
382
383 The C<cond_wait> function takes a B<locked> variable as a parameter, unlocks
384 the variable, and blocks until another thread does a C<cond_signal> or
385 C<cond_broadcast> for that same locked variable.  The variable that
386 C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied.  If
387 there are multiple threads C<cond_wait>ing on the same variable, all but one
388 will re-block waiting to reacquire the lock on the variable. (So if you're only
389 using C<cond_wait> for synchronisation, give up the lock as soon as possible).
390 The two actions of unlocking the variable and entering the blocked wait state
391 are atomic, the two actions of exiting from the blocked wait state and
392 re-locking the variable are not.
393
394 In its second form, C<cond_wait> takes a shared, B<unlocked> variable followed
395 by a shared, B<locked> variable.  The second variable is unlocked and thread
396 execution suspended until another thread signals the first variable.
397
398 It is important to note that the variable can be notified even if no thread
399 C<cond_signal> or C<cond_broadcast> on the variable.  It is therefore
400 important to check the value of the variable and go back to waiting if the
401 requirement is not fulfilled.  For example, to pause until a shared counter
402 drops to zero:
403
404   { lock($counter); cond_wait($counter) until $counter == 0; }
405
406 =item cond_timedwait VARIABLE, ABS_TIMEOUT
407
408 =item cond_timedwait CONDVAR, ABS_TIMEOUT, LOCKVAR
409
410 In its two-argument form, C<cond_timedwait> takes a B<locked> variable and an
411 absolute timeout as parameters, unlocks the variable, and blocks until the
412 timeout is reached or another thread signals the variable.  A false value is
413 returned if the timeout is reached, and a true value otherwise.  In either
414 case, the variable is re-locked upon return.
415
416 Like C<cond_wait>, this function may take a shared, B<locked> variable as an
417 additional parameter; in this case the first parameter is an B<unlocked>
418 condition variable protected by a distinct lock variable.
419
420 Again like C<cond_wait>, waking up and reacquiring the lock are not atomic,
421 and you should always check your desired condition after this function
422 returns.  Since the timeout is an absolute value, however, it does not have to
423 be recalculated with each pass:
424
425   lock($var);
426   my $abs = time() + 15;
427   until ($ok = desired_condition($var)) {
428       last if !cond_timedwait($var, $abs);
429   }
430   # we got it if $ok, otherwise we timed out!
431
432 =item cond_signal VARIABLE
433
434 The C<cond_signal> function takes a B<locked> variable as a parameter and
435 unblocks one thread that's C<cond_wait>ing on that variable. If more than one
436 thread is blocked in a C<cond_wait> on that variable, only one (and which one
437 is indeterminate) will be unblocked.
438
439 If there are no threads blocked in a C<cond_wait> on the variable, the signal
440 is discarded. By always locking before signaling, you can (with care), avoid
441 signaling before another thread has entered cond_wait().
442
443 C<cond_signal> will normally generate a warning if you attempt to use it on an
444 unlocked variable. On the rare occasions where doing this may be sensible, you
445 can suppress the warning with:
446
447   { no warnings 'threads'; cond_signal($foo); }
448
449 =item cond_broadcast VARIABLE
450
451 The C<cond_broadcast> function works similarly to C<cond_signal>.
452 C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in
453 a C<cond_wait> on the locked variable, rather than only one.
454
455 =back
456
457 =head1 OBJECTS
458
459 L<threads::shared> exports a version of L<bless()|perlfunc/"bless REF"> that
460 works on shared objects such that I<blessings> propagate across threads.
461
462   # Create a shared 'Foo' object
463   my $foo :shared = shared_clone({});
464   bless($foo, 'Foo');
465
466   # Create a shared 'Bar' object
467   my $bar :shared = shared_clone({});
468   bless($bar, 'Bar');
469
470   # Put 'bar' inside 'foo'
471   $foo->{'bar'} = $bar;
472
473   # Rebless the objects via a thread
474   threads->create(sub {
475       # Rebless the outer object
476       bless($foo, 'Yin');
477
478       # Cannot directly rebless the inner object
479       #bless($foo->{'bar'}, 'Yang');
480
481       # Retrieve and rebless the inner object
482       my $obj = $foo->{'bar'};
483       bless($obj, 'Yang');
484       $foo->{'bar'} = $obj;
485
486   })->join();
487
488   print(ref($foo),          "\n");    # Prints 'Yin'
489   print(ref($foo->{'bar'}), "\n");    # Prints 'Yang'
490   print(ref($bar),          "\n");    # Also prints 'Yang'
491
492 =head1 NOTES
493
494 L<threads::shared> is designed to disable itself silently if threads are not
495 available.  This allows you to write modules and packages that can be used
496 in both threaded and non-threaded applications.
497
498 If you want access to threads, you must C<use threads> before you
499 C<use threads::shared>.  L<threads> will emit a warning if you use it after
500 L<threads::shared>.
501
502 =head1 BUGS AND LIMITATIONS
503
504 When C<share> is used on arrays, hashes, array refs or hash refs, any data
505 they contain will be lost.
506
507   my @arr = qw(foo bar baz);
508   share(@arr);
509   # @arr is now empty (i.e., == ());
510
511   # Create a 'foo' object
512   my $foo = { 'data' => 99 };
513   bless($foo, 'foo');
514
515   # Share the object
516   share($foo);        # Contents are now wiped out
517   print("ERROR: \$foo is empty\n")
518       if (! exists($foo->{'data'}));
519
520 Therefore, populate such variables B<after> declaring them as shared.  (Scalar
521 and scalar refs are not affected by this problem.)
522
523 It is often not wise to share an object unless the class itself has been
524 written to support sharing.  For example, an object's destructor may get
525 called multiple times, once for each thread's scope exit.  Another danger is
526 that the contents of hash-based objects will be lost due to the above
527 mentioned limitation.  See F<examples/class.pl> (in the CPAN distribution of
528 this module) for how to create a class that supports object sharing.
529
530 Does not support C<splice> on arrays!
531
532 Taking references to the elements of shared arrays and hashes does not
533 autovivify the elements, and neither does slicing a shared array/hash over
534 non-existent indices/keys autovivify the elements.
535
536 C<share()> allows you to C<< share($hashref->{key}) >> and
537 C<< share($arrayref->[idx]) >> without giving any error message.  But the
538 C<< $hashref->{key} >> or C<< $arrayref->[idx] >> is B<not> shared, causing
539 the error "lock can only be used on shared values" to occur when you attempt
540 to C<< lock($hasref->{key}) >> or C<< lock($arrayref->[idx]) >> in another
541 thread.
542
543 Using L<refaddr()|Scalar::Util/"refaddr EXPR">) is unreliable for testing
544 whether or not two shared references are equivalent (e.g., when testing for
545 circular references).  Use L<is_shared()/"is_shared VARIABLE">, instead:
546
547     use threads;
548     use threads::shared;
549     use Scalar::Util qw(refaddr);
550
551     # If ref is shared, use threads::shared's internal ID.
552     # Otherwise, use refaddr().
553     my $addr1 = is_shared($ref1) || refaddr($ref1);
554     my $addr2 = is_shared($ref2) || refaddr($ref2);
555
556     if ($addr1 == $addr2) {
557         # The refs are equivalent
558     }
559
560 L<each()|perlfunc/"each HASH"> does not work properly on shared references
561 embedded in shared structures.  For example:
562
563     my %foo :shared;
564     $foo{'bar'} = shared_clone({'a'=>'x', 'b'=>'y', 'c'=>'z'});
565
566     while (my ($key, $val) = each(%{$foo{'bar'}})) {
567         ...
568     }
569
570 Either of the following will work instead:
571
572     my $ref = $foo{'bar'};
573     while (my ($key, $val) = each(%{$ref})) {
574         ...
575     }
576
577     foreach my $key (keys(%{$foo{'bar'}})) {
578         my $val = $foo{'bar'}{$key};
579         ...
580     }
581
582 View existing bug reports at, and submit any new bugs, problems, patches, etc.
583 to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared>
584
585 =head1 SEE ALSO
586
587 L<threads::shared> Discussion Forum on CPAN:
588 L<http://www.cpanforum.com/dist/threads-shared>
589
590 Annotated POD for L<threads::shared>:
591 L<http://annocpan.org/~JDHEDDEN/threads-shared-1.31/shared.pm>
592
593 Source repository:
594 L<http://code.google.com/p/threads-shared/>
595
596 L<threads>, L<perlthrtut>
597
598 L<http://www.perl.com/pub/a/2002/06/11/threads.html> and
599 L<http://www.perl.com/pub/a/2002/09/04/threads.html>
600
601 Perl threads mailing list:
602 L<http://lists.cpan.org/showlist.cgi?name=iThreads>
603
604 =head1 AUTHOR
605
606 Artur Bergman E<lt>sky AT crucially DOT netE<gt>
607
608 Documentation borrowed from the old Thread.pm.
609
610 CPAN version produced by Jerry D. Hedden E<lt>jdhedden AT cpan DOT orgE<gt>.
611
612 =head1 LICENSE
613
614 threads::shared is released under the same license as Perl.
615
616 =cut