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.22';
  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         # Clone READONLY flag
 137         if (Internals::SvREADONLY($$item)) {
 138             Internals::SvREADONLY($$copy, 1);
 139         }
 140         # Add to clone checking hash
 141         $cloned->{$addr} = $copy;
 142     }
 143
 144     # Copy of a ref of a ref
 145     elsif ($ref_type eq 'REF') {
 146         # Special handling for $x = \$x
 147         if ($addr == refaddr($$item)) {
 148             $copy = \$copy;
 149             share($copy);
 150             $cloned->{$addr} = $copy;
 151         } else {
 152             my $tmp;
 153             $copy = \$tmp;
 154             share($copy);
 155             # Add to clone checking hash
 156             $cloned->{$addr} = $copy;
 157             # Recursively copy and add contents
 158             $tmp = $make_shared->($$item, $cloned);
 159         }
 160
 161     } else {
 162         require Carp;
 163         Carp::croak("Unsupported ref type: ", $ref_type);
 164     }
 165
 166     # If input item is an object, then bless the copy into the same class
 167     if (my $class = blessed($item)) {
 168         bless($copy, $class);
 169     }
 170
 171     # Clone READONLY flag
 172     if (Internals::SvREADONLY($item)) {
 173         Internals::SvREADONLY($copy, 1);
 174     }
 175
 176     return $copy;
 177 };
 178
 179 1;
 180
 181 __END__
 182
 183 =head1 NAME
 184
 185 threads::shared - Perl extension for sharing data structures between threads
 186
 187 =head1 VERSION
 188
 189 This document describes threads::shared version 1.22
 190
 191 =head1 SYNOPSIS
 192
 193   use threads;
 194   use threads::shared;
 195
 196   my $var :shared;
 197   my %hsh :shared;
 198   my @ary :shared;
 199
 200   my ($scalar, @array, %hash);
 201   share($scalar);
 202   share(@array);
 203   share(%hash);
 204
 205   $var = $scalar_value;
 206   $var = $shared_ref_value;
 207   $var = shared_clone($non_shared_ref_value);
 208   $var = shared_clone({'foo' => [qw/foo bar baz/]});
 209
 210   $hsh{'foo'} = $scalar_value;
 211   $hsh{'bar'} = $shared_ref_value;
 212   $hsh{'baz'} = shared_clone($non_shared_ref_value);
 213   $hsh{'quz'} = shared_clone([1..3]);
 214
 215   $ary[0] = $scalar_value;
 216   $ary[1] = $shared_ref_value;
 217   $ary[2] = shared_clone($non_shared_ref_value);
 218   $ary[3] = shared_clone([ {}, [] ]);
 219
 220   { lock(%hash); ...  }
 221
 222   cond_wait($scalar);
 223   cond_timedwait($scalar, time() + 30);
 224   cond_broadcast(@array);
 225   cond_signal(%hash);
 226
 227   my $lockvar :shared;
 228   # condition var != lock var
 229   cond_wait($var, $lockvar);
 230   cond_timedwait($var, time()+30, $lockvar);
 231
 232 =head1 DESCRIPTION
 233
 234 By default, variables are private to each thread, and each newly created
 235 thread gets a private copy of each existing variable.  This module allows you
 236 to share variables across different threads (and pseudo-forks on Win32).  It
 237 is used together with the L<threads> module.
 238
 239 This module supports the sharing of the following data types only:  scalars
 240 and scalar refs, arrays and array refs, and hashes and hash refs.
 241
 242 =head1 EXPORT
 243
 244 The following functions are exported by this module: C<share>,
 245 C<shared_clone>, C<is_shared>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>
 246 and C<cond_broadcast>
 247
 248 Note that if this module is imported when L<threads> has not yet been loaded,
 249 then these functions all become no-ops.  This makes it possible to write
 250 modules that will work in both threaded and non-threaded environments.
 251
 252 =head1 FUNCTIONS
 253
 254 =over 4
 255
 256 =item share VARIABLE
 257
 258 C<share> takes a variable and marks it as shared:
 259
 260   my ($scalar, @array, %hash);
 261   share($scalar);
 262   share(@array);
 263   share(%hash);
 264
 265 C<share> will return the shared rvalue, but always as a reference.
 266
 267 Variables can also be marked as shared at compile time by using the
 268 C<:shared> attribute:
 269
 270   my ($var, %hash, @array) :shared;
 271
 272 Shared variables can only store scalars, refs of shared variables, or
 273 refs of shared data (discussed in next section):
 274
 275   my ($var, %hash, @array) :shared;
 276   my $bork;
 277
 278   # Storing scalars
 279   $var = 1;
 280   $hash{'foo'} = 'bar';
 281   $array[0] = 1.5;
 282
 283   # Storing shared refs
 284   $var = \%hash;
 285   $hash{'ary'} = \@array;
 286   $array[1] = \$var;
 287
 288   # The following are errors:
 289   #   $var = \$bork;                    # ref of non-shared variable
 290   #   $hash{'bork'} = [];               # non-shared array ref
 291   #   push(@array, { 'x' => 1 });       # non-shared hash ref
 292
 293 =item shared_clone REF
 294
 295 C<shared_clone> takes a reference, and returns a shared version of its
 296 argument, preforming a deep copy on any non-shared elements.  Any shared
 297 elements in the argument are used as is (i.e., they are not cloned).
 298
 299   my $cpy = shared_clone({'foo' => [qw/foo bar baz/]});
 300
 301 Object status (i.e., the class an object is blessed into) is also cloned.
 302
 303   my $obj = {'foo' => [qw/foo bar baz/]};
 304   bless($obj, 'Foo');
 305   my $cpy = shared_clone($obj);
 306   print(ref($cpy), "\n");         # Outputs 'Foo'
 307
 308 For cloning empty array or hash refs, the following may also be used:
 309
 310   $var = &share([]);   # Same as $var = share_clone([]);
 311   $var = &share({});   # Same as $var = share_clone({});
 312
 313 =item is_shared VARIABLE
 314
 315 C<is_shared> checks if the specified variable is shared or not.  If shared,
 316 returns the variable's internal ID (similar to
 317 L<refaddr()|Scalar::Util/"refaddr EXPR">).  Otherwise, returns C<undef>.
 318
 319   if (is_shared($var)) {
 320       print("\$var is shared\n");
 321   } else {
 322       print("\$var is not shared\n");
 323   }
 324
 325 =item lock VARIABLE
 326
 327 C<lock> places a lock on a variable until the lock goes out of scope.  If the
 328 variable is locked by another thread, the C<lock> call will block until it's
 329 available.  Multiple calls to C<lock> by the same thread from within
 330 dynamically nested scopes are safe -- the variable will remain locked until
 331 the outermost lock on the variable goes out of scope.
 332
 333 Locking a container object, such as a hash or array, doesn't lock the elements
 334 of that container. For example, if a thread does a C<lock(@a)>, any other
 335 thread doing a C<lock($a[12])> won't block.
 336
 337 C<lock()> follows references exactly I<one> level.  C<lock(\$a)> is equivalent
 338 to C<lock($a)>, while C<lock(\\$a)> is not.
 339
 340 Note that you cannot explicitly unlock a variable; you can only wait for the
 341 lock to go out of scope.  This is most easily accomplished by locking the
 342 variable inside a block.
 343
 344   my $var :shared;
 345   {
 346       lock($var);
 347       # $var is locked from here to the end of the block
 348       ...
 349   }
 350   # $var is now unlocked
 351
 352 If you need more fine-grained control over shared variable access, see
 353 L<Thread::Semaphore>.
 354
 355 =item cond_wait VARIABLE
 356
 357 =item cond_wait CONDVAR, LOCKVAR
 358
 359 The C<cond_wait> function takes a B<locked> variable as a parameter, unlocks
 360 the variable, and blocks until another thread does a C<cond_signal> or
 361 C<cond_broadcast> for that same locked variable.  The variable that
 362 C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied.  If
 363 there are multiple threads C<cond_wait>ing on the same variable, all but one
 364 will re-block waiting to reacquire the lock on the variable. (So if you're only
 365 using C<cond_wait> for synchronisation, give up the lock as soon as possible).
 366 The two actions of unlocking the variable and entering the blocked wait state
 367 are atomic, the two actions of exiting from the blocked wait state and
 368 re-locking the variable are not.
 369
 370 In its second form, C<cond_wait> takes a shared, B<unlocked> variable followed
 371 by a shared, B<locked> variable.  The second variable is unlocked and thread
 372 execution suspended until another thread signals the first variable.
 373
 374 It is important to note that the variable can be notified even if no thread
 375 C<cond_signal> or C<cond_broadcast> on the variable.  It is therefore
 376 important to check the value of the variable and go back to waiting if the
 377 requirement is not fulfilled.  For example, to pause until a shared counter
 378 drops to zero:
 379
 380   { lock($counter); cond_wait($count) until $counter == 0; }
 381
 382 =item cond_timedwait VARIABLE, ABS_TIMEOUT
 383
 384 =item cond_timedwait CONDVAR, ABS_TIMEOUT, LOCKVAR
 385
 386 In its two-argument form, C<cond_timedwait> takes a B<locked> variable and an
 387 absolute timeout as parameters, unlocks the variable, and blocks until the
 388 timeout is reached or another thread signals the variable.  A false value is
 389 returned if the timeout is reached, and a true value otherwise.  In either
 390 case, the variable is re-locked upon return.
 391
 392 Like C<cond_wait>, this function may take a shared, B<locked> variable as an
 393 additional parameter; in this case the first parameter is an B<unlocked>
 394 condition variable protected by a distinct lock variable.
 395
 396 Again like C<cond_wait>, waking up and reacquiring the lock are not atomic,
 397 and you should always check your desired condition after this function
 398 returns.  Since the timeout is an absolute value, however, it does not have to
 399 be recalculated with each pass:
 400
 401   lock($var);
 402   my $abs = time() + 15;
 403   until ($ok = desired_condition($var)) {
 404       last if !cond_timedwait($var, $abs);
 405   }
 406   # we got it if $ok, otherwise we timed out!
 407
 408 =item cond_signal VARIABLE
 409
 410 The C<cond_signal> function takes a B<locked> variable as a parameter and
 411 unblocks one thread that's C<cond_wait>ing on that variable. If more than one
 412 thread is blocked in a C<cond_wait> on that variable, only one (and which one
 413 is indeterminate) will be unblocked.
 414
 415 If there are no threads blocked in a C<cond_wait> on the variable, the signal
 416 is discarded. By always locking before signaling, you can (with care), avoid
 417 signaling before another thread has entered cond_wait().
 418
 419 C<cond_signal> will normally generate a warning if you attempt to use it on an
 420 unlocked variable. On the rare occasions where doing this may be sensible, you
 421 can suppress the warning with:
 422
 423   { no warnings 'threads'; cond_signal($foo); }
 424
 425 =item cond_broadcast VARIABLE
 426
 427 The C<cond_broadcast> function works similarly to C<cond_signal>.
 428 C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in
 429 a C<cond_wait> on the locked variable, rather than only one.
 430
 431 =back
 432
 433 =head1 OBJECTS
 434
 435 L<threads::shared> exports a version of L<bless()|perlfunc/"bless REF"> that
 436 works on shared objects such that I<blessings> propagate across threads.
 437
 438   # Create a shared 'Foo' object
 439   my $foo :shared = shared_clone({});
 440   bless($foo, 'Foo');
 441
 442   # Create a shared 'Bar' object
 443   my $bar :shared = shared_clone({});
 444   bless($bar, 'Bar');
 445
 446   # Put 'bar' inside 'foo'
 447   $foo->{'bar'} = $bar;
 448
 449   # Rebless the objects via a thread
 450   threads->create(sub {
 451       # Rebless the outer object
 452       bless($foo, 'Yin');
 453
 454       # Cannot directly rebless the inner object
 455       #bless($foo->{'bar'}, 'Yang');
 456
 457       # Retrieve and rebless the inner object
 458       my $obj = $foo->{'bar'};
 459       bless($obj, 'Yang');
 460       $foo->{'bar'} = $obj;
 461
 462   })->join();
 463
 464   print(ref($foo),          "\n");    # Prints 'Yin'
 465   print(ref($foo->{'bar'}), "\n");    # Prints 'Yang'
 466   print(ref($bar),          "\n");    # Also prints 'Yang'
 467
 468 =head1 NOTES
 469
 470 L<threads::shared> is designed to disable itself silently if threads are not
 471 available.  This allows you to write modules and packages that can be used
 472 in both threaded and non-threaded applications.
 473
 474 If you want access to threads, you must C<use threads> before you
 475 C<use threads::shared>.  L<threads> will emit a warning if you use it after
 476 L<threads::shared>.
 477
 478 =head1 BUGS AND LIMITATIONS
 479
 480 When C<share> is used on arrays, hashes, array refs or hash refs, any data
 481 they contain will be lost.
 482
 483   my @arr = qw(foo bar baz);
 484   share(@arr);
 485   # @arr is now empty (i.e., == ());
 486
 487   # Create a 'foo' object
 488   my $foo = { 'data' => 99 };
 489   bless($foo, 'foo');
 490
 491   # Share the object
 492   share($foo);        # Contents are now wiped out
 493   print("ERROR: \$foo is empty\n")
 494       if (! exists($foo->{'data'}));
 495
 496 Therefore, populate such variables B<after> declaring them as shared.  (Scalar
 497 and scalar refs are not affected by this problem.)
 498
 499 It is often not wise to share an object unless the class itself has been
 500 written to support sharing.  For example, an object's destructor may get
 501 called multiple times, once for each thread's scope exit.  Another danger is
 502 that the contents of hash-based objects will be lost due to the above
 503 mentioned limitation.  See F<examples/class.pl> (in the CPAN distribution of
 504 this module) for how to create a class that supports object sharing.
 505
 506 Does not support C<splice> on arrays!
 507
 508 Taking references to the elements of shared arrays and hashes does not
 509 autovivify the elements, and neither does slicing a shared array/hash over
 510 non-existent indices/keys autovivify the elements.
 511
 512 C<share()> allows you to C<< share($hashref->{key}) >> without giving any
 513 error message.  But the C<< $hashref->{key} >> is B<not> shared, causing the
 514 error "locking can only be used on shared values" to occur when you attempt to
 515 C<< lock($hasref->{key}) >>.
 516
 517 Using L<refaddr()|Scalar::Util/"refaddr EXPR">) is unreliable for testing
 518 whether or not two shared references are equivalent (e.g., when testing for
 519 circular references).  Use L<is_shared()/"is_shared VARIABLE">, instead:
 520
 521     use threads;
 522     use threads::shared;
 523     use Scalar::Util qw(refaddr);
 524
 525     # If ref is shared, use threads::shared's internal ID.
 526     # Otherwise, use refaddr().
 527     my $addr1 = is_shared($ref1) || refaddr($ref1);
 528     my $addr2 = is_shared($ref2) || refaddr($ref2);
 529
 530     if ($addr1 == $addr2) {
 531         # The refs are equivalent
 532     }
 533
 534 View existing bug reports at, and submit any new bugs, problems, patches, etc.
 535 to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared>
 536
 537 =head1 SEE ALSO
 538
 539 L<threads::shared> Discussion Forum on CPAN:
 540 L<http://www.cpanforum.com/dist/threads-shared>
 541
 542 Annotated POD for L<threads::shared>:
 543 L<http://annocpan.org/~JDHEDDEN/threads-shared-1.22/shared.pm>
 544
 545 Source repository:
 546 L<http://code.google.com/p/threads-shared/>
 547
 548 L<threads>, L<perlthrtut>
 549
 550 L<http://www.perl.com/pub/a/2002/06/11/threads.html> and
 551 L<http://www.perl.com/pub/a/2002/09/04/threads.html>
 552
 553 Perl threads mailing list:
 554 L<http://lists.cpan.org/showlist.cgi?name=iThreads>
 555
 556 =head1 AUTHOR
 557
 558 Artur Bergman E<lt>sky AT crucially DOT netE<gt>
 559
 560 Documentation borrowed from the old Thread.pm.
 561
 562 CPAN version produced by Jerry D. Hedden E<lt>jdhedden AT cpan DOT orgE<gt>.
 563
 564 =head1 LICENSE
 565
 566 threads::shared is released under the same license as Perl.
 567
 568 =cut