ext/threads/shared/shared.pm

   1 package threads::shared;
   2
   3 use strict;
   4 use warnings;
   5 use Config;
   6 use Scalar::Util qw(weaken);
   7 use attributes qw(reftype);
   8
   9 BEGIN {
  10     if($Config{'useithreads'} && $Config::threads) {
  11         *share = \&share_enabled;
  12         *cond_wait = \&cond_wait_disabled;
  13         *cond_signal = \&cond_signal_disabled;
  14         *cond_broadcast = \&cond_broadcast_disabled;
  15         *unlock = \&unlock_disabled;
  16         *lock = \&lock_disabled;
  17     } else {
  18         *share = \&share_enabled;
  19     }
  20 }
  21
  22 require Exporter;
  23 require DynaLoader;
  24 our @ISA = qw(Exporter DynaLoader);
  25
  26 our @EXPORT = qw(share cond_wait cond_broadcast cond_signal unlock lock);
  27 our $VERSION = '0.01';
  28
  29 our %shared;
  30
  31 sub cond_wait_disabled { return @_ };
  32 sub cond_signal_disabled { return @_};
  33 sub cond_broadcast_disabled { return @_};
  34 sub unlock_disabled { 1 };
  35 sub lock_disabled { 1 }
  36 sub share_disabled { return @_}
  37
  38 sub share_enabled (\[$@%]) { # \]
  39     my $value = $_[0];
  40     my $ref = reftype($value);
  41     if($ref eq 'SCALAR') {
  42         my $obj = \threads::shared::sv->new($$value);
  43         bless $obj, 'threads::shared::sv';
  44         $shared{$$obj} = $value;
  45         weaken($shared{$$obj});
  46     } elsif($ref eq "ARRAY") {
  47         tie @$value, 'threads::shared::av', $value;
  48     } elsif($ref eq "HASH") {
  49         tie %$value, "threads::shared::hv", $value;
  50     } else {
  51         die "You cannot share ref of type $_[0]\n";
  52     }
  53 }
  54
  55 sub CLONE {
  56     return unless($_[0] eq "threads::shared");
  57         foreach my $ptr (keys %shared) {
  58             if($ptr) {
  59                 thrcnt_inc($shared{$ptr});
  60             }
  61         }
  62 }
  63
  64 sub DESTROY {
  65     my $self = shift;
  66     delete($shared{$$self});
  67 }
  68
  69 package threads::shared::sv;
  70 use base 'threads::shared';
  71
  72 sub DESTROY {}
  73
  74 package threads::shared::av;
  75 use base 'threads::shared';
  76 use Scalar::Util qw(weaken);
  77 sub TIEARRAY {
  78         my $class = shift;
  79         my $value = shift;
  80         my $self = bless \threads::shared::av->new($value),'threads::shared::av';
  81         $shared{$self->ptr} = $value;
  82         weaken($shared{$self->ptr});
  83         return $self;
  84 }
  85
  86 package threads::shared::hv;
  87 use base 'threads::shared';
  88 use Scalar::Util qw(weaken);
  89 sub TIEHASH {
  90     my $class = shift;
  91     my $value = shift;
  92     my $self = bless \threads::shared::hv->new($value),'threads::shared::hv';
  93     $shared{$self->ptr} = $value;
  94     weaken($shared{$self->ptr});
  95     return $self;
  96 }
  97
  98 package threads::shared;
  99 bootstrap threads::shared $VERSION;
 100
 101 __END__
 102
 103 =head1 NAME
 104
 105 threads::shared - Perl extension for sharing data structures between threads
 106
 107 =head1 SYNOPSIS
 108
 109   use threads::shared;
 110
 111   my($foo, @foo, %foo);
 112   share($foo);
 113   share(@foo);
 114   share(%hash);
 115   my $bar = share([]);
 116   $hash{bar} = share({});
 117
 118   lock(\%hash);
 119   unlock(\%hash);
 120   cond_wait($scalar);
 121   cond_broadcast(\@array);
 122   cond_signal($scalar);
 123
 124 =head1 DESCRIPTION
 125
 126 This modules allows you to share() variables. These variables will
 127 then be shared across different threads (and pseudoforks on
 128 win32). They are used together with the threads module.
 129
 130 =head2 EXPORT
 131
 132 share(), lock(), unlock(), cond_wait, cond_signal, cond_broadcast
 133
 134 =head1 BUGS
 135
 136 Not stress tested!
 137 Does not support splice on arrays!
 138
 139 =head1 AUTHOR
 140
 141 Arthur Bergman E<lt>arthur at contiller.seE<gt>
 142
 143 threads::shared is released under the same license as Perl
 144
 145 =head1 SEE ALSO
 146
 147 L<perl> L<threads>
 148
 149 =cut