From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

LNATION / Thread-Synchronized-0.04 / lib / Thread / Synchronized.pm 

            

              
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

              
package Thread::Synchronized;
# Make sure we have version info for this module
# Make sure we do everything by the book from now on
$VERSION = '0.04';
use strict;
# Make sure we can do threads
# Make sure we can do shared variables
use threads ();
use threads::shared ();
# Make sure we can do a source filter
use Filter::Util::Call ();
# The hash containing the subroutine locks
our %VERSION; # this is called VERSION to save on a glob
# Satisfy -require-
1;
#---------------------------------------------------------------------------
# Methods needed by Perl
#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
sub import {
# Obtain the current package (default package to be prefixed to subroutine name)
# Register the caller's package for this module in load (if possible)
    my $package = caller();
#    load->register( $package,__PACKAGE__ )
#     if defined( $load::VERSION ) and $load::VERSION > 0.11;
# Obtain a reference to the fixit routine (ref only to so it'll clean up)
#  Obtain the parameters
#  Initialize the extra code to be generated
    my $fix = sub {
        my ($sub,$prototype,$attributes) = @_;
        my $code = '';
#  We want subroutine synchronization (removing the attribute)
#   We want object synchronization (keeping the attribute, others might need it)
#    Add code to lock on the object, it should be externally shared
        if ($attributes =~ s#\bsynchronized\b##) {
            if ($attributes =~ m#\bmethod\b#) {
                $code = 'lock( $_[0] );';
#   Else (just synchronize)
#    Create the key to be used to synchronize this sub
#    Make sure that becomes a shared value
#    Create the extra code to lock the sub
#  Return the substitute string
            } else {
                my $key = $sub =~ m#::# ? $sub : $package.'::'.$sub;
                threads::shared::share( $VERSION{$key} );
                $code = 'lock( $'.__PACKAGE__."::VERSION{'$key'} );";
            }
        }
        "sub $sub$prototype:$attributes\{$code";
    };
# Install the filter as an anonymous sub
#  Initialize status
    Filter::Util::Call::filter_add( sub {
        my $status;
# If there are still lines to read
#  Update package info if a package was found
#  Convert the line if "synchronized" attribute found
# Return the status
        if (($status = Filter::Util::Call::filter_read()) > 0) {
            $package = $1 if m#\bpackage\s+([\w:_]+)#;
#warn $_ if # uncomment if you want to see changed lines
            s#\bsub\s+((?:\w|_|::)+)([^:]*):([^{]+){#$fix->($1,$2,$3)#e;
        }
        $status;
    } );
} #import
#---------------------------------------------------------------------------
__END__
=head1 NAME
Thread::Synchronized - synchronize subroutine calls between threads
=head1 SYNOPSIS
    use Thread::Synchronized;  # activate synchronized and method attribute
    sub foo : synchronized { } # only one subroutine running at a time
    sub bar : synchronized method { } # only one method per object
=head1 DESCRIPTION
                  *** A note of CAUTION ***
 This module only functions on Perl versions 5.8.0 and later.
 And then only when threads are enabled with -Dusethreads.  It
 is of no use with any version of Perl before 5.8.0 or without
 threads enabled.
                  *************************
This module currently adds one feature to threaded programs: the
"synchronized" and "method" subroutine attributes which causes calls to that
subroutine to be automatically synchronized between threads (only one thread
can execute that subroutine at a time or per object at a time).
=head1 REQUIRED MODULES
 (none)
=head1 CAVEATS
This module is implemented using a source filter.  This has the advantage
of not needing to incur any runtime overhead.  But this of course happens at
the expense of a slightly longer compile time.
=head1 AUTHOR
Elizabeth Mattijsen, <liz@dijkmat.nl>.
Please report bugs to <perlbugs@dijkmat.nl>.
=head1 COPYRIGHT
Copyright (c) 2003 Elizabeth Mattijsen <liz@dijkmat.nl>. All rights
reserved.  This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<threads>.
=cut