File Coverage

blib/lib/Safe/World/Scope.pm

Criterion	Covered	Total	%
statement	103	168	61.3
branch	30	114	26.3
condition	4	12	33.3
subroutine	16	19	84.2
pod	6	8	75.0
total	159	321	49.5

#############################################################################
## Name:        Scope.pm
## Purpose:     Safe::World::Scope
## Author:      Graciliano M. P.
## Modified by:
## Created:     15/12/2003
## RCS-ID:
## Copyright:   (c) 2003 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 Safe::World::Scope ;

use strict qw(vars);

use vars qw($VERSION @ISA) ;
$VERSION = '0.03' ;

no warnings ;

my ($HOLE , %HOOK_IDS , %SCOPES_CACHE , %TABLES) ;

#######
# NEW # package , no_cache , only_call
#######

sub new {
  my $class = shift ;
  my ($package , $no_cache , $only_call) = @_ ;

  $package =~ s/[^\w:]//gs ;
  $package =~ s/[:\.]+/::/gs ;
  $package =~ s/^:+//g ;
  $package =~ s/:+$//g ;

  return $SCOPES_CACHE{$package} if ( !$no_cache && $SCOPES_CACHE{$package} ) ;

  delete $TABLES{$package} if $no_cache ;

  my $this = bless({} , $class) ;

  $this->{PACKAGE} = $package ;

  $this->{HOOK} = new_hook($package,$only_call) ;

  $this->{STASH} = $this->_STASH_REF_NOW ;

  $SCOPES_CACHE{$package} = $this ;

  return $this ;
}

##################
# _STASH_REF_NOW #
##################

sub _STASH_REF_NOW {
  my $ref = \%{ $_[0]->{PACKAGE} . '::' } ;
  return "$ref" ;
}

############
# NEW_HOOK #
############

sub new_hook {
  my $class = shift ;
  my $only_call = shift ;

  my $this = bless({} , $class) ;

  $this->{PACKAGE} = $class ;

  my $hook_sub = "$class\::__SAFEWORLD_HOOK__" ;

  my $table ;
  if ( !defined $TABLES{$class} ) {
    my @table = &scanpack_table($class) ;
    $table = {} ;

    foreach my $table_i ( @table ) {
      if ( $table_i =~ /^([\$\@\%\*\&])(\Q$class\E:*)(.*)/ ) {
        my ($tp , $sub , $name) = ($1,"$2$3",$3) ;
        next if $name eq '__SAFEWORLD_HOOK__' ;


        if ( $tp eq '&' )  { $table->{$tp}{$name} = \&$sub ;}
        elsif ( $only_call ) { ; }
        elsif ( $tp eq '$' )  { $table->{$tp}{$name} = \$$sub ;}
        elsif ( $tp eq '@' )  { $table->{$tp}{$name} = \@$sub ;}
        elsif ( $tp eq '%' )  { $table->{$tp}{$name} = \%$sub ;}
        elsif ( $tp eq '*' )  { $table->{$tp}{$name} = \&$sub ;}
      }
    }

    $TABLES{$class} = $table ;
  }
  else { $table = $TABLES{$class} ;}

  if ( !defined &$hook_sub ) {

    *{$hook_sub} = sub {
      my $hook = shift ;
      &__SAFEWORLD_HOOK__($hook,$table,@_) ;
    } ;

    ## Overload DESTROY to skeep DESTROY of HOOKs.
    if ( $table->{'&'}{DESTROY} ) {
      my $dest_ref = \&{"$class\::DESTROY"} ;
      *{"$class\::DESTROY"} = sub { return if $HOOK_IDS{"$_[0]"} ; &$dest_ref(@_) ;}
    }

  }

  if ( $only_call ) {
    $TABLES{$class}{only_call} = "$this" ;
  }

  $HOOK_IDS{"$this"} = 1 ;

  return $this ;
}

##################
# SCANPACK_TABLE # Copy from Safe::World::scanpack_table, since this package need to be scope independent!
##################

sub scanpack_table {
  my ( $packname ) = @_ ;

  $packname .= '::' unless $packname =~ /::$/ ;
  no strict "refs" ;
  my $package = *{$packname}{HASH} ;
  return unless defined $package ;

  no warnings ;
  local $^W = 0 ;

  my @table ;

  my $fullname ;
  foreach my $symb ( keys %$package ) {
    $fullname = "$packname$symb" ;
    if ( $symb !~ /::$/ && $symb !~ /[^\w:]/ ) {
      if (defined $$fullname) { push(@table , "\$$fullname") ;}
      if (defined %$fullname) { push(@table , "\%$fullname") ;}
      if (defined @$fullname) { push(@table , "\@$fullname") ;}
      if (defined &$fullname) { push(@table , "\&$fullname") ;}
      if (*{$fullname}{IO} && fileno $fullname) {
        push(@table , "\*$fullname") ;
      }
    }
  }

  return( @table ) ;
}

######################
# __SAFEWORLD_HOOK__ #
######################

sub __SAFEWORLD_HOOK__ {
  my $__HOOK__ = shift ;
  my $__TABLE__ = shift ;

  ##print main::STDOUT "SCOPE>> @_\n" ;

  if ( $_[0] eq 'call' ) { shift ;
    my $name = shift ;
    my $sub = $__TABLE__->{'&'}{$name} ;
    return &$sub(@_) if $sub ;
    die("Undefined subroutine &$__HOOK__->{PACKAGE}\::$name") ;
    return undef ;
  }

  elsif ( $__TABLE__->{only_call} && $__TABLE__->{only_call}{"$__HOOK__"} ) { return ;}

  elsif ( $_[0] eq 'get' ) { shift ;
    if    ( $_[0] eq '$' )  { return ${ $__TABLE__->{'$'}{$_[1]} } ;}
    elsif ( $_[0] eq '@' )  { return @{ $__TABLE__->{'@'}{$_[1]} } ;}
    elsif ( $_[0] eq '%' )  { return %{ $__TABLE__->{'%'}{$_[1]} } ;}
    elsif ( $_[0] eq '*' )  { return *{ $__TABLE__->{'*'}{$_[1]} } ;}
    elsif ( $_[0] eq '\$' ) { return $__TABLE__->{'$'}{$_[1]} ;}
    elsif ( $_[0] eq '\@' ) { return $__TABLE__->{'@'}{$_[1]} ;}
    elsif ( $_[0] eq '\%' ) { return $__TABLE__->{'%'}{$_[1]} ;}
    elsif ( $_[0] eq '\*' ) { return $__TABLE__->{'*'}{$_[1]} ;}
  }

  elsif ( $_[0] eq 'set' ) { shift ;
    my $__REF__ = ref($_[2]) ;
    if    ( $_[0] eq '$' )  { return ${ $__TABLE__->{'$'}{$_[1]} } = $__REF__ eq 'SCALAR' ? ${$_[2]} : $__REF__ eq 'ARRAY' ? @{$_[2]} : $__REF__ eq 'HASH' ? %{$_[2]} : $_[2] ;}
    elsif ( $_[0] eq '@' )  { return @{ $__TABLE__->{'@'}{$_[1]} } = $__REF__ eq 'SCALAR' ? ${$_[2]} : $__REF__ eq 'ARRAY' ? @{$_[2]} : $__REF__ eq 'HASH' ? %{$_[2]} : $_[2] ;}
    elsif ( $_[0] eq '%' )  { return %{ $__TABLE__->{'%'}{$_[1]} } = $__REF__ eq 'SCALAR' ? ${$_[2]} : $__REF__ eq 'ARRAY' ? @{$_[2]} : $__REF__ eq 'HASH' ? %{$_[2]} : $_[2] ;}
    elsif ( $_[0] eq '*' )  { return *{ $__TABLE__->{'*'}{$_[1]} } = $__REF__ eq 'SCALAR' ? ${$_[2]} : $__REF__ eq 'ARRAY' ? @{$_[2]} : $__REF__ eq 'HASH' ? %{$_[2]} : $_[2] ;}
  }

  return ;
}

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

sub NEW {
  my $this = shift ;
  $this->call_hole('new',$this->{PACKAGE},@_) ;
}

#############
# CALL_HOLE #
#############

sub call_hole {
  my $this = shift ;
  my $sub = shift ;

  &_load_HOLE if !$HOLE ;

  if ( $this->_STASH_REF_NOW ne $this->{STASH} ) {
    my $sub_ref = $TABLES{ $this->{HOOK}->{PACKAGE} }->{'&'}{$sub} ;
    die("Undefined subroutine &$this->{HOOK}->{PACKAGE}::$sub") if !$sub_ref ;
    return $HOLE->call($sub_ref,@_) ;
  }

  return $this->{HOOK}->__SAFEWORLD_HOOK__('call',$sub,@_) ;
}

##############
# _LOAD_HOLE #
##############

sub _load_HOLE {
  if ( !$HOLE ) {
    require Safe::World::Hole ;
    $HOLE = new Safe::World::Hole ;
  }
}

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

sub call {
  my $this = shift ;
  my $sub = shift ;
  return $this->{HOOK}->__SAFEWORLD_HOOK__('call',$sub,@_) ;
}

#######
# GET #
#######

sub get {
  my $this = shift ;
  my ($tp,$var) = ( $_[0] =~ /^(\\?[\$\@\%\*])(\w+(?:::\w+)*)/ );
  $this->{HOOK}->__SAFEWORLD_HOOK__('get',$tp,$var) ;
}

#######
# SET #
#######

sub set {
  my $this = shift ;
  my $toset = shift ;
  my ( undef , $keep_ref ) = @_ ;

  my ($tp,$var) = ( $toset =~ /^(\\?[\$\@\%\*])(\w+(?:::\w+)*)/ ) ;

  my $ref ;

  if ( $keep_ref ) { $ref = \$_[0] ;}
  else { $ref = $_[0] ;}

  $this->{HOOK}->__SAFEWORLD_HOOK__('set',$tp,$var,$ref) ;
}

sub DESTROY {}

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

1;

__END__