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'} && $threads::threads) {
  11         *share = \&share_enabled;
  12         *cond_wait = \&cond_wait_enabled;
  13         *cond_signal = \&cond_signal_enabled;
  14         *cond_broadcast = \&cond_broadcast_enabled;
  15         *unlock = \&unlock_enabled;
  16     } else {
  17         *share = \&share_disabled;
  18         *cond_wait = \&cond_wait_disabled;
  19         *cond_signal = \&cond_signal_disabled;
  20         *cond_broadcast = \&cond_broadcast_dosabled;
  21         *unlock = \&unlock_disabled;
  22     }
  23 }
  24
  25 require Exporter;
  26 require DynaLoader;
  27 our @ISA = qw(Exporter DynaLoader);
  28
  29 our @EXPORT = qw(share cond_wait cond_broadcast cond_signal unlock);
  30 our $VERSION = '0.90';
  31
  32 our %shared;
  33
  34 sub cond_wait_disabled { return @_ };
  35 sub cond_signal_disabled { return @_};
  36 sub cond_broadcast_disabled { return @_};
  37 sub unlock_disabled { 1 };
  38 sub lock_disabled { 1 }
  39 sub share_disabled { return @_}
  40
  41 sub share_enabled (\[$@%]) { # \]
  42     my $value = $_[0];
  43     my $ref = reftype($value);
  44     if($ref eq 'SCALAR') {
  45         my $obj = \threads::shared::sv->new($$value);
  46         bless $obj, 'threads::shared::sv';
  47         $shared{$$obj} = $value;
  48         weaken($shared{$$obj});
  49     } elsif($ref eq "ARRAY") {
  50         tie @$value, 'threads::shared::av', $value;
  51     } elsif($ref eq "HASH") {
  52         tie %$value, "threads::shared::hv", $value;
  53     } else {
  54         die "You cannot share ref of type $_[0]\n";
  55     }
  56 }
  57
  58 sub CLONE {
  59     return unless($_[0] eq "threads::shared");
  60         foreach my $ptr (keys %shared) {
  61             if($ptr) {
  62                 thrcnt_inc($shared{$ptr});
  63             }
  64         }
  65 }
  66
  67 sub DESTROY {
  68     my $self = shift;
  69     _thrcnt_dec($$self);
  70     delete($shared{$$self});
  71 }
  72
  73 package threads::shared::sv;
  74 use base 'threads::shared';
  75
  76 sub DESTROY {}
  77
  78 package threads::shared::av;
  79 use base 'threads::shared';
  80 use Scalar::Util qw(weaken);
  81 sub TIEARRAY {
  82         my $class = shift;
  83         my $value = shift;
  84         my $self = bless \threads::shared::av->new($value),'threads::shared::av';
  85         $shared{$self->ptr} = $value;
  86         weaken($shared{$self->ptr});
  87         return $self;
  88 }
  89
  90 package threads::shared::hv;
  91 use base 'threads::shared';
  92 use Scalar::Util qw(weaken);
  93 sub TIEHASH {
  94     my $class = shift;
  95     my $value = shift;
  96     my $self = bless \threads::shared::hv->new($value),'threads::shared::hv';
  97     $shared{$self->ptr} = $value;
  98     weaken($shared{$self->ptr});
  99     return $self;
 100 }
 101
 102 package threads::shared;
 103 bootstrap threads::shared $VERSION;
 104
 105 __END__
 106
 107 =head1 NAME
 108
 109 threads::shared - Perl extension for sharing data structures between threads
 110
 111 =head1 SYNOPSIS
 112
 113   use threads::shared;
 114
 115   my($foo, @foo, %foo);
 116   share($foo);
 117   share(@foo);
 118   share(%hash);
 119   my $bar = share([]);
 120   $hash{bar} = share({});
 121
 122   lock(%hash);
 123   unlock(%hash);
 124   cond_wait($scalar);
 125   cond_broadcast(@array);
 126   cond_signal(%hash);
 127
 128 =head1 DESCRIPTION
 129
 130 This modules allows you to share() variables. These variables will
 131 then be shared across different threads (and pseudoforks on
 132 win32). They are used together with the threads module.
 133
 134 =head1 EXPORT
 135
 136 C<share>, C<lock>, C<unlock>, C<cond_wait>, C<cond_signal>, C<cond_broadcast>
 137
 138 =head1 FUNCTIONS
 139
 140 =over 4
 141
 142 =item share VARIABLE
 143
 144 C<share> takes a value and marks it as shared, you can share an scalar, array, hash
 145 scalar ref, array ref and hash ref, C<share> will return the shared value.
 146
 147 C<share> will traverse up references exactly I<one> level.
 148 C<share(\$a)> is equivalent to C<share($a)>, while C<share(\\$a)> is not.
 149
 150 =item lock VARIABLE
 151
 152 C<lock> places a lock on a variable until the lock goes out of scope.  If
 153 the variable is locked by another thread, the C<lock> call will block until
 154 it's available. C<lock> is recursive, so multiple calls to C<lock> are
 155 safe--the variable will remain locked until the outermost lock on the
 156 variable goes out of scope or C<unlock> is called enough times to match
 157 the number of calls to <lock>.
 158
 159 If a container object, such as a hash or array, is locked, all the elements
 160 of that container are not locked. For example, if a thread does a C<lock
 161 @a>, any other thread doing a C<lock($a[12])> won't block.
 162
 163 C<lock> will traverse up references exactly I<one> level.
 164 C<lock(\$a)> is equivalent to C<lock($a)>, while C<lock(\\$a)> is not.
 165
 166
 167 =item unlock VARIABLE
 168
 169 C<unlock> takes a locked shared value and decrements the lock count.
 170 If the lock count is zero the variable is unlocked. It is not necessary
 171 to call C<unlock> but it can be usefull to reduce lock contention.
 172
 173 C<unlock> will traverse up references exactly I<one> level.
 174 C<unlock(\$a)> is equivalent to C<unlock($a)>, while C<unlock(\\$a)> is not.
 175
 176 =item cond_wait VARIABLE
 177
 178 The C<cond_wait> function takes a B<locked> variable as a parameter,
 179 unlocks the variable, and blocks until another thread does a C<cond_signal>
 180 or C<cond_broadcast> for that same locked variable. The variable that
 181 C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied.
 182 If there are multiple threads C<cond_wait>ing on the same variable, all but
 183 one will reblock waiting to reaquire the lock on the variable. (So if
 184 you're only using C<cond_wait> for synchronization, give up the lock as
 185 soon as possible)
 186
 187 It is important to note that the variable can be notified even if no
 188 thread C<cond_signal> or C<cond_broadcast> on the variable. It is therefore
 189 important to check the value of the variable and go back to waiting if the
 190 requirment is not fullfilled.
 191
 192 =item cond_signal VARIABLE
 193
 194 The C<cond_signal> function takes a B<locked> variable as a parameter and
 195 unblocks one thread that's C<cond_wait>ing on that variable. If more than
 196 one thread is blocked in a C<cond_wait> on that variable, only one (and
 197 which one is indeterminate) will be unblocked.
 198
 199 If there are no threads blocked in a C<cond_wait> on the variable, the
 200 signal is discarded.
 201
 202 =item cond_broadcast VARIABLE
 203
 204 The C<cond_broadcast> function works similarly to C<cond_signal>.
 205 C<cond_broadcast>, though, will unblock B<all> the threads that are blocked
 206 in a C<cond_wait> on the locked variable, rather than only one.
 207
 208 =head1 BUGS
 209
 210 C<bless> is not supported on shared references, in the current version
 211 C<bless> will only bless the thread local reference and the blessing
 212 will not propagate to the other threads, this is expected to be implmented
 213 in the future.
 214
 215 Does not support splice on arrays!
 216
 217 =head1 AUTHOR
 218
 219 Arthur Bergman E<lt>arthur at contiller.seE<gt>
 220
 221 threads::shared is released under the same license as Perl
 222
 223 Documentation borrowed from Thread.pm
 224
 225 =head1 SEE ALSO
 226
 227 L<perl> L<threads>
 228
 229 =cut
 230
 231
 232
 233
 234