File Coverage

blib/lib/Thread/Isolate.pm

Criterion	Covered	Total	%
statement	22	39	56.4
branch	2	12	16.6
condition			n/a
subroutine	8	9	88.8
pod			n/a
total	32	60	53.3

#############################################################################
## Name:        Isolate.pm
## Purpose:     Thread::Isolate
## 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 ;
use 5.008006 ;

use strict qw(vars);
no warnings ;

use vars qw($VERSION @ISA) ;

$VERSION = '0.05' ;

@ISA = qw(Thread::Isolate::Thread) ;

sub BEGIN {
  *CORE::GLOBAL::exit = \&EXIT ;
  *CORE::GLOBAL::die = \&DIE ;
}

#######
# DIE #
#######

sub DIE {
  my $is_exit ;
  if ( $_[0] =~ /#CORE::GLOBAL::exit#/s ) {
    my $err = shift ;
    $err =~ s/#CORE::GLOBAL::exit#/exit()/gsi ; ;
    unshift (@_, $err) ;
    $is_exit = 1 ;
  }

  if ( $^S ) {
    my $thi = Thread::Isolate->self ;
    $thi->add_job('SHUTDOWN') if $thi ;
    CORE::die(@_) ;
  }
  else {
    if ( $is_exit ) {
      Thread::Isolate->new_from_id( $Thread::Isolate::Thread::MOTHER_THREAD )->eval(' CORE::exit() ;') if $Thread::Isolate::Thread::MOTHER_THREAD ;
      CORE::exit ;
    }
    else { warn(@_) ;}
  }
}

########
# EXIT #
########

sub EXIT {
  my @call = caller ;
  if ( $call[1] =~ /^\(eval/ ) {
    my @call2 = caller(1) ;
    die("#CORE::GLOBAL::exit# at $call[1] (package $call[0]) line $call[2]:\n$call2[6]\n") ;
  }
  else {
    die("#CORE::GLOBAL::exit# at $call[1] (package $call[0]) line $call[2].\n") ;
  }
}

###########
# REQUIRE #
###########

  use Storable () ;
  use Thread::Isolate::Thread ;

  Thread::Isolate::Thread::start_mother_thread() ;

######################
# STORABLE SIGNATURE #
######################

use vars qw($STORABLE_SIGN $USE_EXTERNAL_PERL) ;

BEGIN {
  return if $STORABLE_SIGN ;

  ($USE_EXTERNAL_PERL , $STORABLE_SIGN) = ('','') ;

  if ( $STORABLE_SIGN eq '' ) {
    if (!$USE_EXTERNAL_PERL) {
      $STORABLE_SIGN = unpack( 'l',Storable::freeze( [] )) ;
    }
    else {
      open( my $handle,
      qq($^X -MStorable -e "print unpack('l',Storable::freeze( [] ))" | )
      ) or die "Cannot determine Storable signature\n" ;
      $STORABLE_SIGN = <$handle>;
      $USE_EXTERNAL_PERL = 'Signature obtained with an external Perl!' ;
    }
  }
}

##########
# FREEZE #
##########

sub freeze {
  if (@_) {
    foreach (@_) {
      if ( !defined() or ref() or m#\0# ) {
        my ( $stable_tree , $holder ) = make_stable_tree(\@_) ;
        my $freeze = Storable::freeze($stable_tree) ;
        make_stable_tree($stable_tree , $holder , 1) ;
        return $freeze ;
      }
    }
    return join("\0" , @_) ;
  }
  else { return ;}
}

########
# THAW #
########

sub thaw {
  return unless defined( $_[0] ) and defined( wantarray ) ;

  if ( (unpack('l', $_[0]) || 0) == $STORABLE_SIGN ) {
    my $thaw = Storable::thaw( $_[0] ) ;
    restore_stable_tree($thaw) ;
    return wantarray ? @$thaw : $$thaw[0] ;
  }
  else {
    if (wantarray) {
      return split("\0" , $_[0]) ;
    }
    else {
      return $1 if $_[0] =~ m#^([^\0]*)# ;
      return $_[0] ;
    }
  }

}

####################
# MAKE_STABLE_TREE #
####################

sub make_stable_tree {
  my $ref = shift ;
  my $holder = shift(@_) || [] ;
  my $restore = shift ;

  if ( !ref $ref ) {
    return wantarray ? ( $ref , $holder ) : $ref ;
  }

  if (ref $ref eq 'GLOB') {
    push(@$holder , $ref) ;
    my $fileno = fileno($ref) || '' . *$ref ;
    $ref = bless(['GLOB' , $fileno] , 'Thread::Isolate::FREEZE') ;
  }
  elsif (ref $ref eq 'CODE') {
    push(@$holder , $ref) ;
    $ref = bless(['CODE' , undef] , 'Thread::Isolate::FREEZE') ;
  }

  if (ref $ref eq 'HASH') {
    foreach my $Key ( sort keys %$ref ) {
      &make_stable_tree($$ref{$Key} , $holder , $restore) if ref $$ref{$Key} ;
    }
  }
  elsif (ref $ref eq 'ARRAY') {
    foreach my $i ( @$ref ) {
      $i = &make_stable_tree($i , $holder , $restore) if ref $i ;
    }
  }
  elsif (ref $ref eq 'SCALAR' || ref $ref eq 'REF') {
    $$ref = &make_stable_tree($$ref , $holder , $restore) if ref $$ref ;
  }
  elsif (ref $ref eq 'Thread::Isolate::FREEZE') {
    if ( $restore == 1 ) {
      $ref = shift @$holder ;
    }
    elsif ( $restore == 2 ) {
      if ( $$ref[0] eq 'GLOB' ) {
        if ( $$ref[1] =~ /^\d+$/ ) {
          open(my $fh , "+<&=$$ref[1]") ;
          $ref = $fh ;
        }
        elsif ( $$ref[1] =~ /^\*(.+)/s ) {
          $ref = \*{$1} ;
        }
      }
      elsif ( $$ref[0] eq 'CODE' ) {
        $ref = eval('sub {}') ;
      }
    }
  }
  elsif (ref $ref && UNIVERSAL::isa($ref , 'UNIVERSAL')) {
    if ( UNIVERSAL::isa($ref , 'HASH') ) {
      foreach my $Key ( sort keys %$ref ) {
        $$ref{$Key} = &make_stable_tree($$ref{$Key} , $holder , $restore) if ref $$ref{$Key} ;
      }
    }
    elsif ( UNIVERSAL::isa($ref , 'ARRAY') ) {
      foreach my $i ( @$ref ) {
        $i = &make_stable_tree($i , $holder , $restore) if ref $i ;
      }
    }
    elsif ( UNIVERSAL::isa($ref , 'SCALAR') || UNIVERSAL::isa($ref , 'REF') ) {
      $$ref = &make_stable_tree($$ref , $holder , $restore) if ref $$ref ;
    }
  }

  return wantarray ? ( $ref , $holder ) : $ref ;
}

#######################
# RESTORE_STABLE_TREE #
#######################

sub restore_stable_tree {
  my $stable_tree = shift ;
  return make_stable_tree($stable_tree , undef , 2) ;
}

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

1;


__END__