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