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