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.01';
  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($scalar);
 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 =head2 EXPORT
 135
 136 share(), lock(), unlock(), cond_wait, cond_signal, cond_broadcast
 137
 138 =head1 BUGS
 139
 140 Not stress tested!
 141 Does not support splice on arrays!
 142
 143 =head1 AUTHOR
 144
 145 Arthur Bergman E<lt>arthur at contiller.seE<gt>
 146
 147 threads::shared is released under the same license as Perl
 148
 149 =head1 SEE ALSO
 150
 151 L<perl> L<threads>
 152
 153 =cut