File Coverage

blib/lib/Thread/Isolate/Pool.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

#############################################################################
## Name:        Pool.pm
## Purpose:     Thread::Isolate::Pool
## Author:      Graciliano M. P.
## Modified by:
## Created:     2005-01-29
## RCS-ID:
## Copyright:   (c) 2005 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package Thread::Isolate::Pool ;

use strict qw(vars) ;
no warnings ;

  use Thread::Isolate ;

#######
# NEW #
#######

sub new {
  my $this = shift ;
  return( $this ) if ref($this) ;
  my $class = $this || __PACKAGE__ ;

  my $limit = shift ;

  my $pool = Thread::Isolate::Thread::share_new_ref('@') ;

  my $main_thr = Thread::Isolate->new() ;
  $main_thr->{clone} = 1 ;

  $$pool[0] = $limit || 0 ;
  $$pool[1] = $main_thr ;

  $this = bless($pool , $class) ;

  return $this ;
}

########
# COPY #
########

sub copy {
  my $this = shift ;

  my $pool = Thread::Isolate::Thread::share_new_ref('@') ;

  my $tm = $this->main_thread ;

  my $main_thr = $this->main_thread->new_internal ;
  $main_thr->{clone} = 1 ;

  $$pool[0] = $$this[0] ;
  $$pool[1] = $main_thr ;

  return bless($pool , ref($this)) ;
}

###############
# MAIN_THREAD #
###############

sub main_thread {
  my $this = shift ;
  return $this->[1] ;
}

#########
# LIMIT #
#########

sub limit {
  my $this = shift ;
  return $this->[0] ;
}

###########
# THREADS #
###########

sub threads {
  my $this = shift ;

  { lock( @$this ) ;
    return @$this[2 .. $#{$this}] ;
  }
}

#################
# THREADS_TOTAL #
#################

sub threads_total {
  my $this = shift ;

  { lock( @$this ) ;
    return($#{$this} - 1) ;
  }
}

##############
# ADD_THREAD #
##############

sub add_thread {
  my $this = shift ;
  return if $this->limit && $this->threads_total == $this->limit ;
  my $th_new = $this->main_thread->new_internal ;
  $th_new->{clone} = 1 ;
  push(@$this , $th_new) ;
  return $th_new ;
}

###################
# GET_FREE_THREAD #
###################

sub get_free_thread {
  my $this = shift ;

  my ($th_free , $on_limit) ;

  { lock( @$this ) ;

    my @threads = $this->threads ;
    my @threads_free ;

    foreach my $threads_i ( @threads ) {
      if ( $threads_i && !$threads_i->is_running_any_job ) {
        push(@threads_free , $threads_i) ;
      }
    }

    if ( !@threads_free ) {
      my $new_thr = $this->add_thread() ;
      if ( $new_thr ) {
        push(@threads_free , $new_thr) ;
      }
      else {
        ## Let's sort a thread from all if we can't create a new due LIMIT:
        @threads_free = @threads ;
        $on_limit = 1 ;
      }
    }

    $th_free = (sort { $a->{pool_use} <=> $b->{pool_use} } @threads_free)[0] ;

    ++$th_free->{pool_use} ;
  }

  return( $th_free , $on_limit ) if wantarray ;
  return $th_free ;
}

#######
# USE #
#######

sub use {
  my $this = shift ;
  return $this->main_thread->use(@_) ;
}

########
# EVAL #
########

sub eval_detached {
  my $this = shift ;
  my ($thf , $on_limit) = $this->get_free_thread ;
  return ( $on_limit ? $thf->eval_detached_no_lock(@_) : $thf->eval_detached(@_) ) ;
}

sub eval {
  my $this = shift ;
  my ($thf , $on_limit) = $this->get_free_thread ;
  return ( $on_limit ? $thf->eval_no_lock(@_) : $thf->eval(@_) ) ;
}

########
# CALL #
########

sub call_detached {
  my $this = shift ;
  my ($thf , $on_limit) = $this->get_free_thread ;
  return ( $on_limit ? $thf->call_detached_no_lock(@_) : $thf->call_detached(@_) ) ;
}

sub call {
  my $this = shift ;
  my ($thf , $on_limit) = $this->get_free_thread ;
  return ( $on_limit ? $thf->call_no_lock(@_) : $thf->call(@_) ) ;
}

############
# SHUTDOWN #
############

sub shutdown {
  my $this = shift ;

  { lock( @$this ) ;

    my @threads = $this->threads ;

    foreach my $threads_i ( @threads ) {
      next if !$threads_i ;
      $threads_i->shutdown ;
      $threads_i = undef ;
    }
  }

  return 1 ;
}

###########
# DESTROY #
###########

sub DESTROY {
  my $this = shift ;
  $this->shutdown ;
}

#######
# END #
#######

1;

__END__