File Coverage

blib/lib/Pixie/Proxy.pm

Criterion	Covered	Total	%
statement	33	190	17.3
branch	0	52	0.0
condition	0	18	0.0
subroutine	11	43	25.5
pod	0	7	0.0
total	44	310	14.1

package Pixie::Proxy;

use strict;
use warnings::register;
require overload;

# For now we're going to assume that we can only handle hashes or
# array based objects. This may not remain the case.


use Scalar::Util qw/reftype/;

our $AUTOLOAD;

our $VERSION="2.06";

use Pixie::Object;
use Pixie::FinalMethods;
use Pixie::Complicity;
use base 'Pixie::Object';

sub px_make_proxy {
  my $self = shift;
  my($oid, $obj) = @_;
  my $proxied_class = ref($obj);
  my $real_class = 'Pixie::Proxy::' . reftype($obj);

  $real_class .= '::Overloaded' if overload::Overloaded($proxied_class);
  $real_class->new->_oid($oid)
                  ->px_class($proxied_class);
}

sub px_restore {
  my $class = $_[0]->px_class;
  my $pixie = $_[0]->px_the_store;
  $_[0]->px_clear_the_store;
  my $real_obj = $_[0]->px_fetch_from($pixie);
  return $_[0] = undef unless defined $real_obj;
  $_[0]->populate_from($real_obj);
  bless $real_obj, 'Class::Whitehole';
  my $ret = bless $_[0], $class;
}

sub px_fetch_from {
  my $self = shift;
  my $pixie = shift;

  my $oid = $self->_oid;

  $pixie->get_with_strategy($oid, $self->px_lock_strategy);
}

sub isa {
  my $self = shift;
  my($class) = @_;
  $self->UNIVERSAL::isa($class) || ref($self) && $self->px_class->isa($class);
}

sub can {
  my $self = shift;
  my($method) = @_;

  $self->UNIVERSAL::can($method) ||
      ref($self) && $self->px_restore->can($method);
}


sub STORABLE_freeze {
  my $self = shift;
  my $cloning = shift;
  return if $cloning;

  return $self->_oid, [$self->px_class];
}

sub STORABLE_thaw {
  my($target, $cloning, $oid, $class) = @_;
  return if $cloning;
  $target->_oid($oid);
  $target->px_class($class->[0]);
  return $target;
}

sub _px_insertion_thaw {
  my $self = shift;
  $self->px_the_store(Pixie->get_the_current_pixie);
  return $self;
}

sub _px_insertion_freeze {
  my $self = shift;
  my $dupe = ref($self)->new->_oid($self->_oid)
                            ->px_class($self->px_class);
}



sub _px_extraction_thaw {
  my $self = shift;
  my $pixie = Pixie->get_the_current_pixie($self->_oid);
  my $ret = Pixie->get_the_current_pixie->cache_get($self->_oid);
  if ( defined $ret ) {
    bless $self, 'Class::Whitehole';
    $pixie->forget_about($self);
    return $ret;
  }

  $self->px_lock_strategy( $pixie->get_the_current_lock_strategy ||
                           $pixie->lock_strategy );


  if ($self->px_class->px_is_immediate) {
    my $oid = $self->_oid;
    bless $self, 'Class::Whitehole';
    Pixie->get_the_current_pixie->_get($oid);
  }
  else {
    $self->px_the_store($pixie);
    $pixie->cache_insert($self);
    return $self;
  }
}

sub DESTROY {
  my $self = shift;
  local $@ = $@;
  return unless ref $self;
  my $store = $self->px_the_store;
  if (defined $store) {
    $store->forget_about($self);
  }
}

sub AUTOLOAD {
  my $method = $AUTOLOAD;
  $method =~ s/.*:://;
  $_[0]->px_restore->$method(@_[1..$#_]);
}

package Pixie::Proxy::ARRAY;

use base 'Pixie::Proxy';

sub new {
  my $proto = shift;
  return bless [], $proto;
}

sub _oid {
  my $self = shift;
  if (@_) {
    my $new_oid = shift;
    $self->[0] = "$new_oid";
    return $self;
  } else {
    return $self->[0];
  }
}

sub px_class {
  my $self = shift;
  if (@_) {
    $self->[1] = shift;
    return $self;
  } else {
    return $self->[1];
  }
}

sub populate_from {
  $#{$_[0]} = 0;
  @{$_[0]} = @{$_[1]};
  return $_[0];
}

sub px_the_store {
  my $self = shift;
  if (@_) {
    $self->[2] = shift;
    return $self;
  }
  else {
    return $self->[2];
  }
}

sub px_clear_the_store {
  my $self = shift;
  $self->[2] = undef;
  return $self;
}

sub px_lock_strategy {
  my $self = shift;
  if (@_) {
    $self->[3] = shift;
    return $self;
  }
  else {
    return $self->[3];
  }
}


package Pixie::Proxy::HASH;

use base 'Pixie::Proxy';

sub new {
  my $proto = shift;

  return bless {}, $proto;
}

sub _oid {
  my $self = shift;
  if (@_) {
    my $new_oid = shift;
    $self->{oid} = "$new_oid";
    return $self;
  } else {
    return $self->{oid};
  }
}


sub px_oid { $_[0]->_oid }

sub px_class {
  my $self = shift;

  if (@_) {
    $self->{class} = shift;
    return $self;
  } else {
    unless (ref($self)) {
      require Carp;
      Carp::confess "Invalid thing: $self";
    }
    return $self->{class};
  }
}

sub populate_from {
  foreach my $key (keys %{$_[0]}) {
    delete $_[0]->{$key};
  }
  %{$_[0]} = %{$_[1]};
  return $_[0];
}

sub px_the_store {
  my $self = shift;
  if (@_) {
    $self->{_the_store} = shift;
    return $self;
  }
  else {
    return $self->{_the_store};
  }
}

sub px_clear_the_store {
  my $self = shift;
  delete $self->{_the_store};
}

sub px_lock_strategy {
  my $self = shift;
  if (@_) {
    $self->{_lock_strategy} = shift;
    return $self;
  }
  else {
    return $self->{_lock_strategy};
  }
}

package Pixie::Proxy::Overloaded;

my %FALLBACK = ( '!' => \&bool_not,
                 '.' => \&concat_str,
                 '""' => \&stringify,
                 'bool' => \&bool,
               );



use overload
    fallback => 0,
    nomethod => sub {
      no strict 'refs';
      my $method = pop;
      my $class = $_[0]->px_class;
      my $fb = $ {$class . "::()"};
      if ( my $sub = overload::ov_method( overload::mycan($class, "\($method"), $class) ) {
        $_[0]->px_restore;
        &$sub;
      }
      elsif (!defined($fb) || $fb) {
        # Try falling back
        push @_, $fb;
        if (exists $FALLBACK{$method}) {
          goto &{$FALLBACK{$method}}
        }
        else {
          die "No Fallback found for $method";
        }
      }
      elsif (defined $ {$class . "::()"}) {
        $_[0]->can('nomethod')->(@_, $method);
      }
      else {
        require Carp;
        Carp::confess "Can't find overloaded method for $method";
      }
    };

sub bool_not {
  if ( caller->isa('Pixie::Proxy') || caller->isa('Pixie') ) {
    return;
  }
  else {
    $_[0]->px_restore;
    return ! $_[0];
  }
}

sub bool {
  if ( caller->isa('Pixie::Proxy') || caller->isa('Pixie') ) {
    return 1;
  }
  else {
    $_[0]->px_restore;
    return $_[0];
  }
}

sub concat_str {
  my($target, $rev) = @_[1,2];
    return $rev ? ($target . "$_[0]")  : ("$_[0]" . $target);
}

sub stringify {
  $_[0]->overload::StrVal;
}

package Pixie::Proxy::HASH::Overloaded;
our @ISA = qw/Pixie::Proxy::HASH Pixie::Proxy::Overloaded/;

package Pixie::Proxy::ARRAY::Overloaded;
our @ISA = qw/Pixie::Proxy::ARRAY Pixie::Proxy::Overloaded/;
1;