Thread-Tie-0.13/000755 000765 000765 00000000000 11445735233 013042 5ustar00lizliz000000 000000 Thread-Tie-0.13/CHANGELOG000644 000765 000765 00000012670 11445735154 014264 0ustar00lizliz000000 000000 0.13 19 September 2010 Checking out the tool chain with perl 5.13.5. 28 January 2004 Made sure the test-suite cleans up on multi-versioned systems. 0.12 28 December 2003 Added automatic required modules update using Devel::Required. 0.11 27 September 2003 Added dependency on load.pm, version 0.11, as that has some more fixes, particularly relating to running under taint. 18 September 2003 Increased dependency on Thread::Serialize 0.07, which in turn should get at least load 0.09, which contains several fixes. Removed warning from test-suite as the strange warnings seems to have disappeared with the new version of load. 0.10 13 August 2003 Fixed strange error that would sometimes cause an execution error during global destruction. I guess it's just another case of fake objects being presented for destruction ;-( Tweaked the message in the test-suite a little. 0.09 11 August 2003 Fixed some typos in the Makefile.PL. Adapted some areas in the test-suite to allow for better testing. Made sure that the tests run with strict and warnings. 0.08 30 September 2002 Use "load" instead of "AutoLoader" in all but Thread::Tie itself. Increased dependency of Thread::Serialize to 0.05. 27 September 2002 Removed "our" from $VERSION and @ISA, should shave off some bytes in memory usage, as found from testing with Benchmark::Thread::Size. 5 September 2002 Adapted MANIFEST: the 2nd test-file of the test-suite was missing ;-( so nobody but me did the stress test. 0.07 1 September 2002 Removed shutdown test from Tie02.t: default thread should close down on its own now, you shouldn't get a "Threads were running" error anymore. Added END {} to take care of shutdown of default thread: apparently the going out of scope of the main thread object doesn't cause the DESTROY method to be called. So this is really a workaround for a bug in Perl. Increased dependency on Thread::Serialize to 0.02, to ensure that the most efficient one is always used. 0.06 31 August 2002 Added OPTIMIZATIONS section to pod of T::T::Thread. Changed T::T::Thread to use AutoLoader to defer loading of necessary subroutines to when they are actually needed. This should save memory and CPU for larger programs, or with large numbers of threads. The test-suite takes 1% less memory and uses 5% less CPU: the overhead of compiling is levelled out with the overhead of cloning pre-compiled routines. 0.05 20 August 2002 Dave Mitchell showed me the error of my ways with regards to client server thread programming. Fixed the main handler so that no yield()s are necessary anymore. The whole thing now gets through the test suite more than 10% faster. Scalability to many more threads should now be a lot better too. 0.04 15 August 2002 Added CAVEATS section about limitations of what can be transported between threads. Removed custom freeze and thaw operations from Thread::Tie::Thread. Replaced by Thread::Serialize's versions. Added depenendency on Thread::Serialize. 0.03 13 August 2002 Fixed problem with DESTROYing of tied variables after the thread was shut down. Added error message when trying to do things other than DESTROYing or UNTIEing after the thread was shut down. Completed first version of documentation of Thread::Tie and Thread::Tie::Thread. Added "hammering" test-suite for tied file handles. 12 August 2002 Added "hammering" test-suite. This now tests the array and hash implementation as well as the capability to lock using a semaphore. Streamlined the thread dispatcher further, succeeding in a 9% gain in CPU usage. Removed the DESTROY method from the default implementation of tied variables in the thread (Thread::Tie::(Array|Hash|Scalar)) as they are not necessary anymore since we have untie() support now. Added support for untie(). Untieing a variable will cause the DESTROY method to be called inside the thread before being untied there as well. Any subsequent DESTROY's (after the variable was untied) will be ignored (thereby averting the untie GOTCHA). This can save significant amounts of memory. Added method "shutdown" to Thread::Tie (as class method, to shut down the default thread) and as object method to Thread::Tie::Thread. Added support for "eval" field for evaluating arbitrary perl code inside the thread when tie()ing the variable. 0.02 10 August 2002 Added support for "use" field for using extra modules inside the thread when tie()ing the variable. Added documentation for the TIEHANDLE implementation. Fixed up the default TIEHANDLE implementation. Should now work except for readline() in list context: because the context is not (yet) passed to the thread correctly, reading lines from a file in list context doesn't work. Added BEGIN section to Thread::Tie, causing the default thread to be started during compilation. This can make the thread as lightweight as possible, especially if it is the first module used. Added some intelligence to Thread::Tie::Thread's _freeze and _thaw so that they will not use Storable unless it is really needed. This should be a performance boost for the simple cases. Removed mention of being truly shared because Arthur Bergman pointed out that the current tie() implementation _always_ saves the values in the (thread local) SV. Although this has nothing to do with shared variables, it _does_ cause the values to actually be copied into thread local space everytime they are fetched. 0.01 9 August 2002 First version of Thread::Tie. Thread-Tie-0.13/lib/000755 000765 000765 00000000000 11445735233 013610 5ustar00lizliz000000 000000 Thread-Tie-0.13/Makefile.PL000644 000765 000765 00000000641 10050423662 015004 0ustar00lizliz000000 000000 require 5.008; use threads (); # just to force breakage if threads are not available use ExtUtils::MakeMaker; eval "use Devel::Required"; WriteMakefile ( NAME => "Thread::Tie", AUTHOR => 'Elizabeth Mattijsen (liz@dijkmat.nl)', ABSTRACT => 'tie variables into a thread of their own', VERSION_FROM => 'lib/Thread/Tie.pm', PREREQ_PM => {qw( load 0.11 Thread::Serialize 0.07 )}, ); Thread-Tie-0.13/MANIFEST000644 000765 000765 00000000441 10050423662 014161 0ustar00lizliz000000 000000 MANIFEST CHANGELOG README TODO VERSION Makefile.PL lib/Thread/Tie.pm lib/Thread/Tie/Array.pm lib/Thread/Tie/Handle.pm lib/Thread/Tie/Hash.pm lib/Thread/Tie/Scalar.pm lib/Thread/Tie/Thread.pm t/Tie01.t t/Tie02.t META.yml Module meta-data (added by MakeMaker) Thread-Tie-0.13/META.yml000644 000765 000765 00000001133 11445735233 014311 0ustar00lizliz000000 000000 --- #YAML:1.0 name: Thread-Tie version: 0.13 abstract: tie variables into a thread of their own author: - Elizabeth Mattijsen (liz@dijkmat.nl) license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: load: 0.11 Thread::Serialize: 0.07 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Thread-Tie-0.13/README000644 000765 000765 00000001567 11445441061 013724 0ustar00lizliz000000 000000 README for Thread::Tie Tie variables into a thread of their own. Creates alternative to the current shared variables implementation. Also allows shared variables to be tied to the module of your choice (inside the thread they reside in). *** 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. ************************* Copyright (c) 2002-2003 Elizabeth Mattijsen . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Version: 0.13 Required Modules: load (0.11) Thread::Serialize (0.07) The build is standard: perl Makefile.PL make make test make install Thread-Tie-0.13/t/000755 000765 000765 00000000000 11445735233 013305 5ustar00lizliz000000 000000 Thread-Tie-0.13/TODO000644 000765 000765 00000000412 10050423662 013516 0ustar00lizliz000000 000000 Reading lines in list context only reads first line. Need some way to correctly propegate the context to the actual read routine. First attempt at this screwed up so many things I undid the changes. Maybe a rogue DESTROY test should be added to the DESTROY subs? Thread-Tie-0.13/VERSION000644 000765 000765 00000000005 11445440756 014110 0ustar00lizliz000000 000000 0.13 Thread-Tie-0.13/t/Tie01.t000644 000765 000765 00000013723 10050423662 014351 0ustar00lizliz000000 000000 use Thread::Tie; # use as first to get maximum effect use strict; use warnings; BEGIN { # Magic Perl CORE pragma if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = '../lib'; } } use Test::More tests => 71; use_ok( 'Thread::Tie::Thread' ); can_ok( 'Thread::Tie::Thread',qw( new thread tid ) ); use_ok( 'Thread::Tie' ); can_ok( 'Thread::Tie',qw( module semaphore TIESCALAR TIEARRAY TIEHASH TIEHANDLE thread ) ); #== SCALAR ========================================================= my $tied = tie my $scalar, 'Thread::Tie',{},10; isa_ok( $tied,'Thread::Tie', 'check tied object type' ); isa_ok( $tied->thread,'Thread::Tie::Thread','check thread object type' ); cmp_ok( $tied->thread->tid,'==',1, 'check tid of thread' ); isa_ok( $tied->thread->thread,'threads','check thread object type' ); isa_ok( $tied->semaphore,'SCALAR', 'check semaphore type' ); cmp_ok( $scalar,'==',10, 'check scalar numerical fetch' ); $scalar++; cmp_ok( $scalar,'==',11, 'check scalar increment' ); $scalar = 'Apenootjes'; is( $scalar,'Apenootjes', 'check scalar fetch' ); threads->new( sub {$scalar = 'from thread'} )->join; is( $scalar,'from thread', 'check scalar fetch' ); #== ARRAY ========================================================== $tied = tie my @array, 'Thread::Tie',{},qw(a b c); isa_ok( $tied,'Thread::Tie', 'check tied object type' ); is( "@array",'a b c', 'check array fetch' ); push( @array,qw(d e f) ); is( "@array",'a b c d e f', 'check array fetch' ); threads->new( sub {push( @array,qw(g h i) )} )->join; is( "@array",'a b c d e f g h i', 'check array fetch' ); shift( @array ); is( "@array",'b c d e f g h i', 'check array fetch' ); unshift( @array,'a' ); is( "@array",'a b c d e f g h i', 'check array fetch' ); pop( @array ); is( "@array",'a b c d e f g h', 'check array fetch' ); push( @array,'i' ); is( "@array",'a b c d e f g h i', 'check array fetch' ); splice( @array,3,3 ); is( "@array",'a b c g h i', 'check array fetch' ); splice( @array,3,0,qw(d e f) ); is( "@array",'a b c d e f g h i', 'check array fetch' ); splice( @array,0,3,qw(d e f) ); is( "@array",'d e f d e f g h i', 'check array fetch' ); delete( $array[0] ); {no warnings 'uninitialized'; is( "@array",' e f d e f g h i', 'check array fetch' ); } @array = qw(a b c d e f g h i); is( join('',@array),'abcdefghi', 'check array fetch' ); cmp_ok( $#array,'==',8, 'check size' ); ok( exists( $array[8] ), 'check whether array element exists' ); ok( !exists( $array[9] ), 'check whether array element exists' ); $#array = 10; cmp_ok( scalar(@array),'==',11, 'check number of elements' ); {no warnings 'uninitialized'; is( "@array",'a b c d e f g h i ', 'check array fetch' ); } ok( !exists( $array[10] ), 'check whether array element exists' ); $array[10] = undef; ok( exists( $array[10] ), 'check whether array element exists' ); ok( !exists( $array[11] ), 'check whether array element exists' ); ok( !defined( $array[10] ), 'check whether array element defined' ); ok( !defined( $array[11] ), 'check whether array element defined' ); cmp_ok( scalar(@array),'==',11, 'check number of elements' ); @array = (); cmp_ok( scalar(@array),'==',0, 'check number of elements' ); is( join('',@array),'', 'check array fetch' ); #== HASH =========================================================== $tied = tie my %hash, 'Thread::Tie',{},(a => 'A'); isa_ok( $tied,'Thread::Tie', 'check tied object type' ); is( $hash{'a'},'A', 'check hash fetch' ); $hash{'b'} = 'B'; is( $hash{'b'},'B', 'check hash fetch' ); is( join('',sort keys %hash),'ab', 'check hash keys' ); ok( !exists( $hash{'c'} ), 'check existence of key' ); threads->new( sub { $hash{'c'} = 'C' } )->join; ok( exists( $hash{'c'} ), 'check existence of key' ); is( $hash{'c'},'C', 'check hash fetch' ); is( join('',sort keys %hash),'abc', 'check hash keys' ); my %otherhash = %hash; is( join('',sort keys %otherhash),'abc','check hash keys' ); my @list; while (my ($key,$value) = each %hash) { push( @list,$key,$value ) } is( join('',sort @list),'ABCabc', 'check all eaches' ); delete( $hash{'b'} ); # attempt to free unreferenced scalar ? is( join('',sort keys %hash),'ac', 'check hash keys' ); %hash = (); cmp_ok( scalar(keys %hash),'==',0, 'check number of elements' ); is( join('',keys %hash),'', 'check hash fetch' ); #== HANDLE ========================================================= my $file = 'testfile'; ok( open( my $handle,'>',$file ), 'check opening of file' ); my $text = <; is( $read,$text, 'check contents of file' ); ok( close( HANDLE ), 'close the file' ); ok( open( HANDLE,">$file" ), 'check opening of file' ); ok( (print HANDLE $text), 'check printing to the file' ); ok( (printf HANDLE '%s',$text), 'check printing to the file' ); ok( close( HANDLE ), 'close the file' ); ok( open( $handle,$file ), 'check opening of file' ); $read = ''; $read.= $_ while <$handle>; is( $read,$text.$text, 'check contents of file' ); ok( unlink( $file ), "unlink $file" ); 1 while unlink $file; # multiversioned filesystems my @thread = threads->list; cmp_ok( scalar(@thread),'==',1, 'check number of threads' ); Thread::Tie->shutdown; @thread = threads->list; cmp_ok( scalar(@thread),'==',0, 'check number of threads' ); eval{ $scalar = 'a' }; is( $@,"Cannot handle Thread::Tie::Scalar::STORE after shutdown\n", 'check error message' ); eval{ @array = ('a') }; is( $@,"Cannot handle Thread::Tie::Array::CLEAR after shutdown\n", 'check error message' ); eval{ %hash = (a => 'A') }; is( $@,"Cannot handle Thread::Tie::Hash::CLEAR after shutdown\n", 'check error message' ); eval{ readline( HANDLE ) }; is( $@,"Cannot handle Thread::Tie::Handle::READLINE after shutdown\n", 'check error message' ); Thread-Tie-0.13/t/Tie02.t000644 000765 000765 00000007607 10050423662 014356 0ustar00lizliz000000 000000 use Thread::Tie; # use as first to get maximum effect use strict; use warnings; BEGIN { # Magic Perl CORE pragma if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = '../lib'; } } use Test::More tests => 26; use_ok( 'Thread::Tie' ); my $times = 10000; my $testfile = 'testfile'; #= ARRAY ============================================================== { my $tied = tie my @array,'Thread::Tie'; isa_ok( $tied,'Thread::Tie', 'check object type' ); my $count = $tied->semaphore; isa_ok( $count,'SCALAR', 'check object type' ); $$count = 0; # to prevent warnings my @thread; push( @thread,threads->new( sub { while (1) { {lock ($count); return if $$count == $times; push( @array,++$$count ); } } } ) ) foreach 1..10; $_->join foreach @thread; my $check; $check = join( ' ',1..$times ); is( "@array",$check, 'check array contents' ); pop( @array ) foreach 1..$times; is( "@array",'', 'check array contents' ); untie( @array ); } #= HASH =============================================================== { my $tied = tie my %hash,'Thread::Tie'; isa_ok( $tied,'Thread::Tie', 'check object type' ); my $count = $tied->semaphore; isa_ok( $count,'SCALAR', 'check object type' ); $$count = 0; # to prevent warnings my @thread; push( @thread,threads->new( sub { while (1) { {lock ($count); return if $$count == $times; $$count++; $hash{$$count} = $$count; } } } ) ) foreach 1..10; $_->join foreach @thread; my $check; $check .= ($_.$_) foreach 1..$times; my $hash; $hash .= ($_.$hash{$_}) foreach (sort {$a <=> $b} keys %hash); is( $hash,$check, 'check hash contents' ); delete( $hash{$_} ) foreach 1..$times; # attempt to free unreferenced scalar is( join('',%hash),'', 'check hash contents' ); untie( %hash ); } #= HANDLE (output) ==================================================== { my $tied = tie *HANDLE,'Thread::Tie'; isa_ok( $tied,'Thread::Tie', 'check object type' ); my $count = $tied->semaphore; isa_ok( $count,'SCALAR', 'check object type' ); $$count = 0; # to prevent warnings ok( open( HANDLE,">$testfile" ), 'check opening of file' ); my @thread; push( @thread,threads->new( sub { while (1) { {lock ($count); return if $$count == $times; $$count++; print HANDLE $$count; } } } ) ) foreach 1..10; $_->join foreach @thread; ok( close( HANDLE ), 'check closing of handle' ); my $check; $check .= $_ foreach 1..$times; ok( open( my $handle,'<',$testfile ), 'check opening of file' ); is( <$handle>,$check, 'check file contents' ); ok( close( $handle ), 'check closing of handle' ); ok( unlink( $testfile ), 'check removing of file' ); 1 while unlink $testfile; # multiversioned filesystems untie( *HANDLE ); } #= HANDLE (input) ===================================================== { ok( open( my $handle,'>',$testfile ), 'check opening of file' ); my $check; foreach (1..$times) { $check .= "$_\n"; print $handle "$_\n"; } ok( close( $handle ), 'check closing of handle' ); my $tied = tie *HANDLE,'Thread::Tie'; isa_ok( $tied,'Thread::Tie', 'check object type' ); my $count = $tied->semaphore; isa_ok( $count,'SCALAR', 'check object type' ); $$count = 0; # to prevent warnings ok( open( HANDLE,'<',$testfile ), 'check opening of file' ); my @check : shared; my @thread; push( @thread,threads->new( sub { while (1) { {lock ($count); return if $$count == $times; $$count++; my $line = ; push( @check,$line ); } } } ) ) foreach 1..10; $_->join foreach @thread; ok( close( HANDLE ), 'check closing of handle' ); is( join('',@check),$check, 'check file contents' ); ok( unlink( $testfile ), 'check removing of file' ); 1 while unlink $testfile; # multiversioned filesystems untie( *HANDLE ); } my @thread = threads->list; cmp_ok( scalar(@thread),'==',1, 'check number of threads' ); Thread-Tie-0.13/lib/Thread/000755 000765 000765 00000000000 11445735233 015017 5ustar00lizliz000000 000000 Thread-Tie-0.13/lib/Thread/Tie/000755 000765 000765 00000000000 11445735233 015540 5ustar00lizliz000000 000000 Thread-Tie-0.13/lib/Thread/Tie.pm000644 000765 000765 00000044153 11445441061 016076 0ustar00lizliz000000 000000 package Thread::Tie; # Default thread to be used # When we're compiling # Make sure we can start the thread # And start the default thread # Make sure the default thread is shut down when we're done my $THREAD; BEGIN { require Thread::Tie::Thread; $THREAD = Thread::Tie::Thread->new; } END { Thread::Tie->shutdown } # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.13'; use strict; # Clone detection logic our $CLONE = 0; # Satisfy -require- 1; #--------------------------------------------------------------------------- # class methods #--------------------------------------------------------------------------- # IN: class (ignored) sub shutdown { # If there is a default thread running # Shut it down # Mark it shut down if ($THREAD) { $THREAD->shutdown; undef( $THREAD ); } } #shutdown #--------------------------------------------------------------------------- # instance methods #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 module to which variable is tied in thread sub module { shift->{'module'} } #module #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 reference to semaphore for lock() sub semaphore { shift->{'semaphore'} } #semaphore #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 Thread::Tie::Thread object hosting this variable sub thread { shift->{'thread'} } #thread #--------------------------------------------------------------------------- # internal methods #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 default module to tie to in thread # 4 reference to hash containing parameters # 5..N any parameters # OUT: 1 instantiated object sub _tie { # Obtain the class # Obtain the default module # Create the tie subroutine name # Obtain the hash reference # Make it a blessed object my $class = shift; my $default_module = shift; my $tie_sub = 'TIE'.uc($default_module); my $self = shift || {}; bless $self,$class; # Set the thread that will be used # Set the module that should be used to tie to # Save the clone level my $thread = $self->{'thread'} ||= $THREAD ||= ($class.'::Thread')->new; my $module = $self->{'module'} ||= $class.'::'.$default_module; $self->{'CLONE'} = $CLONE; # Obtain the reference to the thread shared ordinal area # Make sure we're the only one doing stuff now # Save the current ordinal number on the tied object, incrementing on the fly # Obtain reference to the method to be executed my $ordinal = $thread->{'ordinal'}; {lock( $ordinal ); $self->{'ordinal'} = $$ordinal++; my $code = $self->can( '_handle' ); # Use additional modules if we have additional modules that should be used # Eval additional code if we have additional code to execute $self->_code_uc_field( $code,'use' ) if exists( $self->{'use'} ); $self->_code_uc_field( $code,'eval' ) if exists( $self->{'eval'} ); # Make sure that the module is available in the thread # Handle the tie request in the thread $code->( $self, 'USE', $module ); $code->( $self, $module.'::'.$tie_sub, @_ ); } #$ordinal # Create a semaphore for external locking # Save a reference to it in the object # Return the instantiated object my $semaphore : shared; $self->{'semaphore'} = \$semaphore; $self; } #_tie #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 subroutine to execute inside the thread # 3..N data to be sent (optional) # OUT: 1..N result of action (optional) sub _handle { # Obtain the object # Obtain the subroutine # Obtain the thread object being used # Return now if there is no thread my $self = shift; my $sub = shift; my $thread = $self->{'thread'}; return unless $thread; # needed for pbs during global destruction # If there is no thread anymore # Return now if we're destroying or untieing # Die now with error message, we can't handle anymore # Handle it using the thread object unless ($thread->tid) { return if $sub =~ m#(?:DESTROY|UNTIE)$#; die "Cannot handle $sub after shutdown\n"; } $thread->_handle( $sub,$self->{'ordinal'},@_ ); } #_handle #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 code reference to execute # 3 name of field to check sub _code_uc_field { # Obtain the parameters # Create uppercase version of field name (=command to execute in thread) my ($self,$code,$field) = @_; my $FIELD = uc($field); # If it is an (array) reference # Use all the modules specified in the thread # Else (just one extra module) # Just use that single module in the thread if (ref( $self->{$field} )) { $code->( $self, $FIELD, $_ ) foreach @{$self->{$field}}; } else { $code->( $self, $FIELD, $self->{$field} ); } } #_code_uc_field #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # Increment the current clone value (mark this as a cloned version) sub CLONE { $CLONE++ } #CLONE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N input parameters # OUT: 1..N output parameters sub AUTOLOAD { # Obtain the object # Obtain the subroutine name # Handle the command with the appropriate data my $self = shift; (my $sub = $Thread::Tie::AUTOLOAD) =~ s#^.*::#$self->{'module'}::#; $self->_handle( $sub,@_ ); } #AUTOLOAD #--------------------------------------------------------------------------- # IN: 1 instantiated object sub DESTROY { # Obtain the object # Return if we're not in the originating thread # Handle the command with the appropriate data my $self = shift; return if $self->{'CLONE'} != $CLONE; $self->_handle( $self->{'module'}.'::DESTROY',@_ ); } #DESTROY #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 reference to hash containing parameters # 3 initial value of scalar # OUT: 1 instantiated object sub TIESCALAR { shift->_tie( 'Scalar',@_ ) } #TIESCALAR #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 reference to hash containing parameters # OUT: 1 instantiated object sub TIEARRAY { shift->_tie( 'Array',@_ ) } #TIEARRAY #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 reference to hash containing parameters # OUT: 1 instantiated object sub TIEHASH { shift->_tie( 'Hash',@_ ) } #TIEHASH #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 reference to hash containing parameters # 3..N any parameters passed to open() # OUT: 1 instantiated object sub TIEHANDLE { shift->_tie( 'Handle',@_ ) } #TIEHANDLE #--------------------------------------------------------------------------- # IN: 1 instantiated object sub UNTIE { # Obtain the object # Return if we're not in the originating thread # Handle the command with the appropriate data my $self = shift; return if $self->{'CLONE'} != $CLONE; $self->_handle( 'UNTIE',$self->{'ordinal'} ); } #UNTIE #--------------------------------------------------------------------------- __END__ =head1 NAME Thread::Tie - tie variables into a thread of their own =head1 VERSION This documentation describes version 0.13. =head1 SYNOPSIS use Thread::Tie; # use as early as possible for maximum memory savings # use default thread + tieing + create thread when needed tie $scalar, 'Thread::Tie'; tie @array, 'Thread::Tie'; tie %hash, 'Thread::Tie'; tie *HANDLE, 'Thread::Tie'; # use alternate implementation tie $scalar, 'Thread::Tie', { module => 'Own::Tie::Implementation', # used automatically use => 'Use::This::Module::Also', # optional, also as [] eval => 'arbitrary Perl code', # optional }; # initialize right away tie $scalar, 'Thread::Tie', {}, 10; tie @array, 'Thread::Tie', {}, qw(a b c); tie %hash, 'Thread::Tie', {}, (a => 'A', b => 'B', c => 'C'); tie *HANDLE, 'Thread::Tie', {},'>:layer','filename'; # create an alternate thread and use that my $tiethread = Thread::Tie::Thread->new; tie $scalar, 'Thread::Tie', {thread => $tiethread}; # object methods my $tied = tie stuff,'Thread::Tie',parameters; my $tied = tied( stuff ); my $semaphore = $tied->semaphore; # scalar for lock()ing tied variable my $module = $tied->module; # module tied to in thread my $tiethread = $tied->thread; # thread to which variable is tied my $tid = $tiethread->tid; # thread id of tied thread my $thread = $tiethread->thread; # actual "threads" thread untie( stuff ); # calls DESTROY in thread, cleans up thoroughly Thread::Tie->shutdown; # shut down default handling thread $tiethread->shutdown; # shut down specific thread =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. ************************* The standard shared variable scheme used by Perl, is based on tie-ing the variable to some very special dark magic. This dark magic ensures that shared variables, which are copied just as any other variable when a thread is started, update values in all of the threads where they exist as soon as the value of a shared variable is changed. Needless to say, this could use some improvement. The Thread::Tie module is a proof-of-concept implementation of another approach to shared variables. Instead of having shared variables exist in all the threads from which they are accessible, shared variable exist as "normal", unshared variables in a seperate thread. Only a tied object exists in each thread from which the shared variable is accesible. Through the use of a client-server model, any thread can fetch and/or update variables living in that thread. This client-server functionality is hidden under the hood of tie(). So you could say that one dark magic (the current shared variables implementation) is replaced by another dark magic. I see the following advantages to this approach: =over 2 =item memory usage This implementation circumvents the memory leak that currently (threads::shared version 0.90) plagues any shared array or shared hash access. =item tieing shared variables Because the current implementation uses tie-ing, you can B tie a shared variable. The same applies for this implementation you might say. However, it B possible to specify a non-standard tie implementation for use B the thread. So with this implementation you B C a shared variable. So you B tie a shared hash to a DBM file à la dbmopen() with this module. =back Of course there are disadvantages to this approach: =over 2 =item pure perl implementation This module is currently a pure perl implementation. This is ok for a proof of concept, but may need re-implementation in pure XS or in Inline::C for production use. =item tradeoff between cpu and memory This implementation currently uses (much) more cpu than the standard shared variables implementation. Whether this would still be true when re-implemented in XS or Inline::C, remains to be seen. =back =head1 tie() You cannot activate this module with a named class method. Instead, you should tie() a scalar, array, hash or glob (handle). The appropriate class method will then be selected for you by Perl. Whether you tie a scalar, array, hash or glob, the first parameter to tie(), the second and third parameter (if specified) to tie() are always the same. And the tie() always returns the same thing: the blessed Thread::Tie object to which the variable is tied. You may or may not need that in your application. If you need to do lock()ing on the tied variable, then you need the object to be able to call the L method. =head2 class to tie with You should always tie() to the class B. So the second parameter should always read B<'Thread::Tie'>. This parameter is B optional. =head2 reference to parameter hash The third parameter is optional. If specified, it should be a reference to a hash with key/value pairs. The following fields may be specified in the hash. =over 2 =item module module => 'Your::Tie::Implementation', The optional "module" field specifies the module to which the variable should be tied inside the thread. If there is no "module" field specified, a standard tie implementation, associated with the type of the variable, will be assumed. Please note that you should probably B use() the module yourself. The specified module will be use()d automatically inside the thread (only), avoiding bloat in all the other threads. =item use use => 'Additional::Module', use => [qw(Additional::Module::1 Additional::Module::2)], The optional "use" field specifies one or more modules that should B be loaded inside the thread before the variable is tied. These can e.g. be prerequisites for the module specified in the "module" field. A single module can be specified by its name. If you need more than one module to be use()d, you can specify these in an array reference. =item eval eval => 'any Perl code that you like;', The optional "eval" field specifies additional Perl code that should be executed inside the thread before the variable is tied. This can e.g. be used to set up prerequisites. Please note that the code to be executed currently needs to be specified as a string that is valid in an eval(). =item thread thread => Thread::Tie::Thread->new, thread => $thread, The optional "thread" field specifies the instantiated L object that should be used to tie the variable in. This is only needed if you want to use more than one thread to tie variables in, which could e.g. be needed if there is a conflict between different tie implementations. You can create a new thread for tie()ing with the "new" class method of the Thread::Tie::Thread module. =back All the other input parameters are passed through to the tie() implementation of your choice. If you are using the default tie() implementation for the type of variable that you have specified, then the input parameters have the following meaning: =over 2 =item scalar tie my $scalar,'Thread::Tie',{},10; Initialize the tied scalar to B<10>. =item array tie my @array,'Thread::Tie',{},qw(a b c); Initialize the tied array with the elements 'a', 'b' and 'c'. =item hash tie my %hash,'Thread::Tie',{},(a => 'A', b => 'B', c => 'C'); Initialize the tied hash with the keys 'a', 'b' and 'c' with values that are the uppercase version of the key. =item glob tie *HANDLE,'Thread::Tie',{},">$file"; # 2 parameter open() tie *HANDLE,'Thread::Tie',{},'>',$file; # 3 parameter open() Initialize the tied glob by calling open() with the indicated parameters. =back =head1 CLASS METHODS There is only one named class method. =head2 shutdown Thread::Tie->shutdown; The "shutdown" class method shuts down the thread that is used for variables that have been tie()d without specifying an explicit thread with the "thread" field. It in fact calls the "shutdown" method of the L module on the instantiated object of the default thread. Any variables that were tie()d, will not function anymore. Any variables that are tie()d B the thread was shut down, will automatically create a new default thread. =head1 OBJECT METHODS The following object methods are available for the instantiated Thread::Tie object, as returned by the tie() function. =head2 semaphore my $semaphore = $tied->semaphore; my $semaphore = (tie my $variable,'Thread::Tie)->semaphore; my $semaphore = tied( $variable )->semaphore; {lock( $semaphore ); do stuff with tied variable privately} The "semaphore" object method returns a reference to a shared scalar that is associated with the tied variable. It can be used for lock()ing access to the tied variable. Scalar values can be assigned to the shared scalar without any problem: it is not used internally for anything other than to allow the developer to lock() access to the tied variable. =head2 module my $module = $tied->module; my $module = (tie my $variable,'Thread::Tie)->module; my $module = tied( $variable )->module; The "module" object method returns the name of the module to which the variable is tied inside the thread. It is the same as what was (implicitely) specified with the "module" field when the variable was tied. =head2 thread my $tiethread = $tied->thread; my $tiethread = (tie my $variable,'Thread::Tie)->thread; my $tiethread = tied( $variable )->thread; The "thread" object method returns the instantiated 'Thread::Tie::Thread' object to which the variable is tied. It is the same as what was (implicetely) specified with the "thread" field when the variable was tied. =head1 REQUIRED MODULES load (0.11) Thread::Serialize (0.07) =head1 CAVEATS Because transport of data structures between threads is severely limited in the current threads implementation (perl 5.8.0), data structures need to be serialized. This is achieved by using the L library. Please check that module for information about the limitations (of any) of data structure transport between threads. =head1 TODO Examples should be added. =head1 AUTHOR Elizabeth Mattijsen, . Please report bugs to . =head1 COPYRIGHT Copyright (c) 2002-2003, 2010 Elizabeth Mattijsen . 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, L. =cut Thread-Tie-0.13/lib/Thread/Tie/Array.pm000644 000765 000765 00000010123 11445440721 017144 0ustar00lizliz000000 000000 package Thread::Tie::Array; # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.13'; use strict; # Load only the stuff that we really need use load; # Satisfy -require- 1; #--------------------------------------------------------------------------- # Following subroutines are loaded on demand only __END__ #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2..N initial values # OUT: 1 instantiated object sub TIEARRAY { my $class = shift; bless \@_,$class } #TIEARRAY #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 index of element to fetch # OUT: 1 value of element sub FETCH { $_[0]->[$_[1]] } #FETCH #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 number of elements sub FETCHSIZE { scalar @{$_[0]} } #FETCHSIZE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 index for which to store # 3 new value sub STORE { $_[0]->[$_[1]] = $_[2] } #STORE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 new number of elements sub STORESIZE { $#{$_[0]} = $_[1]-1 } #STORESIZE #--------------------------------------------------------------------------- # IN: 1 instantiated object sub CLEAR { @{$_[0]} = () } #CLEAR #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 popped off value sub POP { pop(@{$_[0]}) } #POP #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N values to push sub PUSH { push( @{shift()},@_ ) } #PUSH #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 shifted off value sub SHIFT { shift(@{$_[0]}) } #SHIFT #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N values to unshift sub UNSHIFT { unshift( @{shift()},@_ ) } #UNSHIFT #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 offset (index) from which to splice (default: 0) # 3 number of elements to remove (default: rest) # 4..N values to to put in place # OUT: 1..N elements that were removed sub SPLICE { # Obtain the object # Obtain the current size of the list # Obtain the offset to use # Adapt if it was to be relative from the end # Obtain the number of element to remove my $list = shift; my $size = $list->FETCHSIZE; my $offset = @_ ? shift : 0; $offset += $size if $offset < 0; my $length = @_ ? shift : $size - $offset; # Perform the actual action and return its result splice( @$list, $offset, $length, @_ ); } #SPLICE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 index of element to check # OUT: 1 flag: whether element exists sub EXISTS { exists $_[0]->[$_[1]] } #EXISTS #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 index of element to delete sub DELETE { delete $_[0]->[$_[1]] } #DELETE #--------------------------------------------------------------------------- __END__ =head1 NAME Thread::Tie::Array - default class for tie-ing arrays to threads =head1 DESCRIPTION Helper class for L. See documentation there. =head1 CREDITS Implementation inspired by L. =head1 AUTHOR Elizabeth Mattijsen, . Please report bugs to . =head1 COPYRIGHT Copyright (c) 2002-2003 Elizabeth Mattijsen . 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. =cut Thread-Tie-0.13/lib/Thread/Tie/Handle.pm000644 000765 000765 00000011701 11445440726 017271 0ustar00lizliz000000 000000 package Thread::Tie::Handle; # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.13'; use strict; # Load only the stuff that we really need use load; # Satisfy -require- 1; #--------------------------------------------------------------------------- # Following subroutines are loaded on demand only __END__ #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2..N any parameters passed to open() # OUT: 1 instantiated object sub TIEHANDLE { # Obtain the class # Obtain a reference to an undefined scalar # Bless it so we can use it to call ourselves my $class = shift; my $handle = \do { local *TIEHANDLE }; # basically rw \undef bless $handle,$class; # Open it if there are any parameters # Return the instantiated object $handle->OPEN( @_ ) if @_; $handle; } #TIEHANDLE #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 flag: whether at end of file sub EOF { eof( $_[0] ) } #EOF #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 position at which the filepointer is located sub TELL { tell( $_[0] ) } #TELL #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 fileno of handle sub FILENO { fileno( $_[0] ) } #FILENO #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 position to seek to # 3 type of offset # OUT: 1 result of seek() sub SEEK { seek( $_[0],$_[1],$_[2] ) } #SEEK #--------------------------------------------------------------------------- # IN: 1 instantiated object sub CLOSE { close( $_[0] ) } #CLOSE #--------------------------------------------------------------------------- # IN: 1 instantiated object sub BINMODE { binmode( $_[0] ) } #BINMODE #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N any parameters passed to open() # OUT: 1 result of open() sub OPEN { # Close any file that is already opened here # Perform a 2 or 3 argument open and return the result $_[0]->CLOSE if defined($_[0]->FILENO); @_ == 2 ? open( $_[0], $_[1] ) : open( $_[0],$_[1],$_[2] ); } #OPEN #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 reference to scalar to read into # 3 number of bytes/characters to read # 4 offset into variable sub READ { read( $_[0],$_[1],$_[2] ) } #READ #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 line read sub READLINE { scalar(readline( $_[0] )) } #READLINE #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 character read sub GETC { getc( $_[0] ) } #GETC #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2..N stuff to print # OUT: 1 result sub PRINT { # Obtain the object # Get local copy of what needs to be printed including extra $\ if needed # Write the stuff that we need and return the result my $self = shift; my $buffer = join( $, || '',@_,'' ); # || to calm if $, is undef in -w $self->WRITE( $buffer,length($buffer),0 ); } #PRINT #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 format with which to printf # 3..N stuff to print # OUT: 1 result sub PRINTF { # Obtain the object # Get the stuff in the right format # Write the stuff that we need and return the result my $self = shift; my $buffer = sprintf( shift,@_ ); # can't use @_ because of tokenization $self->WRITE( $buffer,length($buffer),0 ); } #PRINTF #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 reference to scalar to write from # 3 number of bytes/characters to write # 4 offset into variable # OUT: 1 number of bytes/characters written sub WRITE { syswrite( $_[0],$_[1],$_[2],$_[3] ) } #WRITE #--------------------------------------------------------------------------- __END__ =head1 NAME Thread::Tie::Handle - default class for tie-ing handles to threads =head1 DESCRIPTION Helper class for L. See documentation there. =head1 CREDITS Implementation inspired by L. =head1 AUTHOR Elizabeth Mattijsen, . Please report bugs to . =head1 COPYRIGHT Copyright (c) 2002-2003 Elizabeth Mattijsen . 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. =cut Thread-Tie-0.13/lib/Thread/Tie/Hash.pm000644 000765 000765 00000005472 11445440733 016767 0ustar00lizliz000000 000000 package Thread::Tie::Hash; # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.13'; use strict; # Load only the stuff that we really need use load; # Satisfy -require- 1; #--------------------------------------------------------------------------- # Following subroutines are loaded on demand only __END__ #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2..N key-value pairs to initialize with # OUT: 1 instantiated object sub TIEHASH { my $class = shift; bless {@_},$class } #TIEHASH #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 key of element to fetch # OUT: 1 value of element sub FETCH { $_[0]->{$_[1]} } #FETCH #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 key for which to store # 3 new value sub STORE { $_[0]->{$_[1]} = $_[2] } #STORE #--------------------------------------------------------------------------- # IN: 1 instantiated object sub CLEAR { %{$_[0]} = () } #CLEAR #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 first key of hash # 2 value associated with first key sub FIRSTKEY { # Reset the each() magic # Return first key/value pair scalar( keys %{$_[0]} ); each %{$_[0]}; } #FIRSTKEY #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 next key of hash # 2 value associated with next key sub NEXTKEY { each %{$_[0]} } #NEXTKEY #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 key of element to check # OUT: 1 flag: whether element exists sub EXISTS { exists $_[0]->{$_[1]} } #EXISTS #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 key of element to delete sub DELETE { delete $_[0]->{$_[1]} } #DELETE #--------------------------------------------------------------------------- __END__ =head1 NAME Thread::Tie::Hash - default class for tie-ing hashes to threads =head1 DESCRIPTION Helper class for L. See documentation there. =head1 CREDITS Implementation inspired by L. =head1 AUTHOR Elizabeth Mattijsen, . Please report bugs to . =head1 COPYRIGHT Copyright (c) 2002-2003 Elizabeth Mattijsen . 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. =cut Thread-Tie-0.13/lib/Thread/Tie/Scalar.pm000644 000765 000765 00000003444 11445440740 017304 0ustar00lizliz000000 000000 package Thread::Tie::Scalar; # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.13'; use strict; # Load only the stuff that we really need use load; # Satisfy -require- 1; #--------------------------------------------------------------------------- # Following subroutines are loaded on demand only __END__ #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # IN: 1 class for which to bless # 2 initial value # OUT: 1 instantiated object sub TIESCALAR { # Obtain the class # Obtain the initial value # Return it as a blessed object my $class = shift; my $instance = shift || undef; bless \$instance,$class; } #TIESCALAR #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 value sub FETCH { ${$_[0]} } #FETCH #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 new value sub STORE { ${$_[0]} = $_[1] } #STORE #--------------------------------------------------------------------------- __END__ =head1 NAME Thread::Tie::Scalar - default class for tie-ing scalars to threads =head1 DESCRIPTION Helper class for L. See documentation there. =head1 CREDITS Implementation inspired by L. =head1 AUTHOR Elizabeth Mattijsen, . Please report bugs to . =head1 COPYRIGHT Copyright (c) 2002-2003 Elizabeth Mattijsen . 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. =cut Thread-Tie-0.13/lib/Thread/Tie/Thread.pm000644 000765 000765 00000026466 11445440745 017324 0ustar00lizliz000000 000000 package Thread::Tie::Thread; # Make sure we have version info for this module # Make sure we do everything by the book from now on $VERSION = '0.13'; use strict; # Make sure we only load stuff when we actually need it use load; # Make sure we can do threads # Make sure we can do shared threads # Make sure we can serialize with freeze() and thaw() use threads (); use threads::shared (); use Thread::Serialize; # Clone detection logic # Thread local list of tied objects our $CLONE = 0; our @OBJECT; # Satisfy -require- 1; #--------------------------------------------------------------------------- # class methods #--------------------------------------------------------------------------- # IN: 1 class with which to bless the object # OUT: 1 instantiated object sub new { # Obtain the class # Make sure we have a blessed object so we can do stuff with it # Save the clone level (so we can check later if we've been cloned) my $class = shift; my $self = bless {},$class; $self->{'CLONE'} = $CLONE; # Create the server semaphore # Create the client semaphore # Store references to these inside the object # Start the thread, save the thread id on the fly my $server : shared = ''; my $client : shared; @$self{qw(server client)} = (\$server,\$client); $self->{'tid'} = threads->new( \&OBJECT,$self )->tid; # Create the ordinal number channel (reserve 0 for special purposes) # Save reference to it inside the object # Wait for the thread to take control # Return with the instantiated object my $ordinal : shared = 1; $self->{'ordinal'} = \$ordinal; threads->yield while defined($server); $self; } #new #--------------------------------------------------------------------------- # standard Perl features #--------------------------------------------------------------------------- # Increment the current clone value (mark this as a cloned version) sub CLONE { $CLONE++ } #CLONE #--------------------------------------------------------------------------- # Following subroutines are loaded on demand only __END__ #--------------------------------------------------------------------------- # IN: 1 instantiated object sub DESTROY { # Obtain the object # Return if we're not in the originating thread # Shut the thread down my $self = shift; return if $self->{'CLONE'} != $CLONE; $self->shutdown; } #DESTROY #--------------------------------------------------------------------------- # instance methods #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 thread encapsulated in object sub thread { threads->object( shift->{'tid'} ) } #thread #--------------------------------------------------------------------------- # IN: 1 instantiated object # OUT: 1 thread id of thread encapsulated in object sub tid { shift->{'tid'} } #tid #--------------------------------------------------------------------------- # IN: 1 instantiated object sub shutdown { # Obtain the object # Return if we're not in the originating thread # Return now if already shut down my $self = shift; return if $self->{'CLONE'} != $CLONE; return unless defined( $self->{'tid'} ); # Shut the thread down # Wait for it to be actually finished # Mark the thread as shut down $self->_handle; $self->thread->join; undef( $self->{'tid'} ); } #shutdown #--------------------------------------------------------------------------- # internal methods #--------------------------------------------------------------------------- # IN: 1 instantiated object # 2 subroutine to execute inside the thread # 3..N data to be sent (optional) # OUT: 1..N result of action (optional) sub _handle { # Obtain the object # Obtain the subroutine # Obtain the references to the shared server and client fields # Create frozen version of the data my $self = shift; my $sub = shift; my ($server,$client) = @$self{qw(server client)}; my $frozen = freeze( @_ ); # Wait until we're allowed as client # Wait for access to the server {lock( $client ); lock( $server ); # Set the data to be passed # Mark there is something being done now # Signal the server to do its thing $$client = $frozen; $$server = $sub; threads::shared::cond_signal( $server ); # Wait for the server to finish # Obtain local copy of result # Return result of the action threads::shared::cond_wait( $server ); $frozen = $$client; } #$client,$server thaw( $frozen ); } #_handle #--------------------------------------------------------------------------- # IN: 1 instantiated object sub OBJECT { # Obtain the object # Obtain the references to the fields that we need # Subroutine to execute # Ordinal number of object to which it is tied my $self = shift; my ($server,$client) = @$self{qw(server client)}; my $sub; my $ordinal; # Initialize general dispatch my %dispatch = ( EVAL => \&doEVAL, UNTIE => \&doUNTIE, USE => \&doUSE, ); # Local copy of object to use # Local copy of code to execute # Frozen copy of no values my $object; my $code; my $undef = freeze( undef ); # Initialize the tie() dispatch hash my %tie_dispatch = ( TIESCALAR => sub {my $scalar; tie $scalar, shift, @_}, TIEARRAY => sub {my @array; tie @array, shift, @_ }, TIEHASH => sub {my %hash; tie %hash, shift, @_ }, TIEHANDLE => sub {tie *CLONE, shift, @_ } ); # Take control of the belt # Indicate to the world we've taken control lock( $server ); undef( $$server ); # While we're accepting things to do # Wait for something to do # Outloop when we're done, obtaining name of sub on the fly # Obtain the ordinal number of the object to execute + data to be sent while (1) { threads::shared::cond_wait( $server ); last unless $sub = $$server; ($ordinal,@_) = thaw( $$client ); # If we have an object, obtaining local copy of object on the fly # If we have a code reference for this method, saving it on the fly # Elseif we haven't checked before # Normalize the subroutine name # Obtain a code reference for this method on this object if there is one # Call the method with the right object and save result if ($object = $OBJECT[$ordinal]) { if ($code = $dispatch{$sub}) { } elsif( !exists( $dispatch{$sub} ) ) { (my $localsub = $sub) =~ s#^.*::##; $code = $dispatch{$sub} = $object->can( $localsub ); } $$client = $code ? freeze( $code->( $object,@_ ) ) : $undef; # Elseif we have a tie action # If it is a known tie method # Perform the appropriate tieing subroutine # Else (unknown tie method) # Die, we don't know how to handle this } elsif ($sub =~ m#^(.*)::(TIE\w+)$#) { if ($sub = $tie_dispatch{ $2 }) { $OBJECT[$ordinal] = $sub->( $1,@_ ); } else { die "Don't know how to TIE with $sub"; } # Elseif we're attempting to destroy without an object # Just set an undefined results (assume it is DESTROY after untie() # Elseif it is a known subroutine that is allowed # Execute the action, assume it's a special startup function # Else # Die now, this is strange! } elsif ($sub =~ m#DESTROY$#) { $$client = $undef; } elsif ($code = $dispatch{$sub}) { $$client = $code->( undef,@_ ); } else { die "Attempting to $sub without an object at $ordinal\n"; } # Mark the data to be ready for usage # Signal the one doing the shutdown that we're done threads::shared::cond_signal( $server ); } threads::shared::cond_signal( $server ); } #OBJECT #--------------------------------------------------------------------------- # IN: 1 object (ignored) # 2 code to eval sub doEVAL { eval( $_[1] ) } #doEVAL #--------------------------------------------------------------------------- # IN: 1 object # 2 ordinal number of object to remove sub doUNTIE { # Obtain the object # If we can destroy the object, obtaining code ref on the fly # Perform whatever needs to be done to destroy # Kill all references to the variable my $object = shift; if (my $code = $object->can( 'DESTROY' )) { $code->( $object ); } undef( $OBJECT[shift] ); } #doUNTIE #--------------------------------------------------------------------------- # IN: 1 object (ignored) # 2 module to load # 3..N any parameters to import sub doUSE { # Remove object # Obtain the class # Create a copy for the filename # Make sure we have a correct filename # Load the module file # Execute import routine (if any) shift; my $class = shift; my $file = $class; $file =~ s#::#/#g; $file .= '.pm'; require $file; $class->import( @_ ); } #doUSE #--------------------------------------------------------------------------- __END__ =head1 NAME Thread::Tie::Thread - create threads for tied variables =head1 SYNOPSIS use Thread::Tie; # use as early as possible for maximum memory savings my $tiethread = Thread::Tie::Thread->new; tie stuff, 'Thread::Tie', {thread => $thread}; my $tid = $tiethread->tid; # thread id of tied thread my $thread = $tiethread->thread; # actual "threads" thread $tiethread->shutdown; # shut down specific thread =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. ************************* The Thread::Tie::Thread module is a helper class for the L module. It is used to create the thread in which the actual code, to which variables are tied with the Thread::Tie class, is located. Please see the documentation of the L module for more information. =head1 CLASS METHODS There is only one class method. =head2 new my $tiethread = Thread::Tie::Thread->new; The "new" class method returns an instantiated object that can be specified with the "thread" field when tie()ing a variable. =head1 OBJECT METHODS The following object methods are available for the instantiated Thread::Tie::Thread object. =head2 tid my $tid = $tiethread->tid; The "tid" object method returns the thread id of the actual L thread that is being used. =head2 thread my $thread = $tiethread->thread; The "thread" object method returns the actual L thread object that is being used. =head1 OPTIMIZATIONS This module uses L to reduce memory and CPU usage. This causes subroutines only to be compiled in a thread when they are actually needed at the expense of more CPU when they need to be compiled. Simple benchmarks however revealed that the overhead of the compiling single routines is not much more (and sometimes a lot less) than the overhead of cloning a Perl interpreter with a lot of subroutines pre-loaded. =head1 AUTHOR Elizabeth Mattijsen, . Please report bugs to . =head1 COPYRIGHT Copyright (c) 2002-2003 Elizabeth Mattijsen . 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, L, L. =cut