File Coverage

lib/JavaScript/Duktape.pm

Criterion	Covered	Total	%
statement	484	513	94.3
branch	137	166	82.5
condition	26	36	72.2
subroutine	90	93	96.7
pod	9	14	64.2
total	746	822	90.7

package JavaScript::Duktape;
use strict;
use warnings;
use Carp;
use Data::Dumper;
use Scalar::Util qw( weaken );
our $VERSION = '2.5.0';

my $GlobalRef = {};

my $THIS;
my $DUKTAPE;
my $isNew  = bless [], "NEW";
my $HEAP   = bless [], "HEAP";
my $DUK    = bless [], "DUK";
my $NOARGS = bless [], "NOARGS";

use base qw/Exporter/;
our @EXPORT = qw (
  DUK_TYPE_NONE
  DUK_TYPE_UNDEFINED
  DUK_TYPE_NULL
  DUK_TYPE_BOOLEAN
  DUK_TYPE_NUMBER
  DUK_TYPE_STRING
  DUK_TYPE_OBJECT
  DUK_TYPE_BUFFER
  DUK_TYPE_POINTER
  DUK_TYPE_LIGHTFUNC
  DUK_ENUM_INCLUDE_NONENUMERABLE
  DUK_ENUM_INCLUDE_HIDDEN
  DUK_ENUM_INCLUDE_SYMBOLS
  DUK_ENUM_EXCLUDE_STRINGS
  DUK_ENUM_INCLUDE_INTERNAL
  DUK_ENUM_OWN_PROPERTIES_ONLY
  DUK_ENUM_ARRAY_INDICES_ONLY
  DUK_ENUM_SORT_ARRAY_INDICES
  DUK_ENUM_NO_PROXY_BEHAVIOR
  DUK_TYPE_MASK_NONE
  DUK_TYPE_MASK_UNDEFINED
  DUK_TYPE_MASK_NULL
  DUK_TYPE_MASK_BOOLEAN
  DUK_TYPE_MASK_NUMBER
  DUK_TYPE_MASK_STRING
  DUK_TYPE_MASK_OBJECT
  DUK_TYPE_MASK_BUFFER
  DUK_TYPE_MASK_POINTER
  DUK_TYPE_MASK_LIGHTFUNC
  DUK_TYPE_MASK_THROW
  DUK_COMPILE_EVAL
  DUK_COMPILE_FUNCTION
  DUK_COMPILE_STRICT
  DUK_COMPILE_SAFE
  DUK_COMPILE_NORESULT
  DUK_COMPILE_NOSOURCE
  DUK_COMPILE_STRLEN
  DUK_DEFPROP_WRITABLE
  DUK_DEFPROP_ENUMERABLE
  DUK_DEFPROP_CONFIGURABLE
  DUK_DEFPROP_HAVE_WRITABLE
  DUK_DEFPROP_HAVE_ENUMERABLE
  DUK_DEFPROP_HAVE_CONFIGURABLE
  DUK_DEFPROP_HAVE_VALUE
  DUK_DEFPROP_HAVE_GETTER
  DUK_DEFPROP_HAVE_SETTER
  DUK_DEFPROP_FORCE
  DUK_VARARGS
  null
  true
  false
  _
  this
);

##constants
use constant {
    DUK_TYPE_NONE      => 0,
    DUK_TYPE_UNDEFINED => 1,
    DUK_TYPE_NULL      => 2,
    DUK_TYPE_BOOLEAN   => 3,
    DUK_TYPE_NUMBER    => 4,
    DUK_TYPE_STRING    => 5,
    DUK_TYPE_OBJECT    => 6,
    DUK_TYPE_BUFFER    => 7,
    DUK_TYPE_POINTER   => 8,
    DUK_TYPE_LIGHTFUNC => 9,

    DUK_TYPE_MASK_NONE      => ( 1 << 0 ),
    DUK_TYPE_MASK_UNDEFINED => ( 1 << 1 ),
    DUK_TYPE_MASK_NULL      => ( 1 << 2 ),
    DUK_TYPE_MASK_BOOLEAN   => ( 1 << 3 ),
    DUK_TYPE_MASK_NUMBER    => ( 1 << 4 ),
    DUK_TYPE_MASK_STRING    => ( 1 << 5 ),
    DUK_TYPE_MASK_OBJECT    => ( 1 << 6 ),
    DUK_TYPE_MASK_BUFFER    => ( 1 << 7 ),
    DUK_TYPE_MASK_POINTER   => ( 1 << 8 ),
    DUK_TYPE_MASK_LIGHTFUNC => ( 1 << 9 ),
    DUK_TYPE_MASK_THROW     => ( 1 << 10 ),

    # Enumeration flags for duk_enum()
    DUK_ENUM_INCLUDE_NONENUMERABLE => ( 1 << 0 ),
    DUK_ENUM_INCLUDE_HIDDEN        => ( 1 << 1 ),
    DUK_ENUM_INCLUDE_SYMBOLS       => ( 1 << 2 ),
    DUK_ENUM_EXCLUDE_STRINGS       => ( 1 << 3 ),
    DUK_ENUM_OWN_PROPERTIES_ONLY   => ( 1 << 4 ),
    DUK_ENUM_ARRAY_INDICES_ONLY    => ( 1 << 5 ),
    DUK_ENUM_SORT_ARRAY_INDICES    => ( 1 << 6 ),
    DUK_ENUM_NO_PROXY_BEHAVIOR     => ( 1 << 7 ),

    DUK_COMPILE_EVAL     => ( 1 << 3 ),
    DUK_COMPILE_FUNCTION => ( 1 << 4 ),
    DUK_COMPILE_STRICT   => ( 1 << 5 ),
    DUK_COMPILE_SAFE     => ( 1 << 6 ),
    DUK_COMPILE_NORESULT => ( 1 << 7 ),
    DUK_COMPILE_NOSOURCE => ( 1 << 8 ),
    DUK_COMPILE_STRLEN   => ( 1 << 9 ),

    #Flags for duk_def_prop() and its variants
    DUK_DEFPROP_WRITABLE          => ( 1 << 0 ),
    DUK_DEFPROP_ENUMERABLE        => ( 1 << 1 ),
    DUK_DEFPROP_CONFIGURABLE      => ( 1 << 2 ),
    DUK_DEFPROP_HAVE_WRITABLE     => ( 1 << 3 ),
    DUK_DEFPROP_HAVE_ENUMERABLE   => ( 1 << 4 ),
    DUK_DEFPROP_HAVE_CONFIGURABLE => ( 1 << 5 ),
    DUK_DEFPROP_HAVE_VALUE        => ( 1 << 6 ),
    DUK_DEFPROP_HAVE_GETTER       => ( 1 << 7 ),
    DUK_DEFPROP_HAVE_SETTER       => ( 1 << 8 ),
    DUK_DEFPROP_FORCE             => ( 1 << 9 ),
    DUK_VARARGS                   => -1
};

sub new {
    my $class = shift;
    my %options = @_;

    my $max_memory = $options{max_memory} || 0;
    my $timeout    = $options{timeout} || 0;

    if ($timeout){
        croak "timeout option must be a number" if !JavaScript::Duktape::Vm::duk_sv_is_number( $timeout );
    }

    if ( $max_memory ){
        croak "max_memory option must be a number" if !JavaScript::Duktape::Vm::duk_sv_is_number( $max_memory );
        croak "max_memory must be at least 256k (256 * 1024)" if $max_memory < 256 * 1024;
    }

    my $self  = bless {}, $class;

    my $duk   = $self->{duk} = JavaScript::Duktape::Vm->perl_duk_new( $max_memory, $timeout );

    $self->{pid} = $$;
    $self->{max_memory} = $max_memory;

    # Initialize global stash 'PerlGlobalStash'
    # this will be used to store some perl refs
    $duk->push_global_stash();
    $duk->push_object();
    $duk->put_prop_string( -2, "PerlGlobalStash" );
    $duk->pop();

    $THIS = bless { duk => $duk, heapptr => 0 }, "JavaScript::Duktape::Object";

    ##finalizer method
    $self->{finalizer} = sub {
        my $ref = $duk->get_string(0);
        delete $GlobalRef->{$ref};
        return 1;
    };

    weaken $GlobalRef;

    $duk->perl_push_function( $self->{finalizer}, 1 );
    $duk->put_global_string('perlFinalizer');

    return $self;
}

sub null                   { $JavaScript::Duktape::NULL::null; }
sub true                   { $JavaScript::Duktape::Bool::true; }
sub false                  { $JavaScript::Duktape::Bool::false }
sub JavaScript::Duktape::_ { $NOARGS }
sub this                   { $THIS }

sub set {
    my $self = shift;
    my $name = shift;
    my $val  = shift;
    my $duk  = $self->vm;

    if ( $name =~ /\./ ) {

        my @props  = split /\./, $name;
        my $last   = pop @props;
        my $others = join '.', @props;

        if ( $duk->peval_string($others) != 0 ) {
            croak $others . " is not a javascript object ";
        }

        my $type = $duk->get_type(-1);
        if ( $type != DUK_TYPE_OBJECT ) {
            croak $others . " isn't an object";
        }

        $duk->push_string($last);
        $duk->push_perl($val);
        $duk->put_prop(-3);
        $duk->pop();
        return 1;
    }

    $duk->push_perl($val);
    $duk->put_global_string($name);
    return 1;
}

sub get {
    my $self = shift;
    my $name = shift;
    my $duk  = $self->vm;
    $duk->push_string($name);
    if ( $duk->peval() != 0 ) {
        croak $duk->last_error_string();
    }
    my $ret = $duk->to_perl(-1);
    $duk->pop();
    return $ret;
}

sub get_object {
    my $self = shift;
    my $name = shift;
    my $duk  = $self->vm;
    $duk->push_string($name);
    if ( $duk->peval() != 0 ) {
        croak $duk->last_error_string();
    }
    my $ret = $duk->to_perl_object(-1);
    $duk->pop();
    return $ret;
}

##FIXME : should pop here?
sub eval {
    my $self   = shift;
    my $string = shift;
    my $duk    = $self->duk;

    if ( $duk->peval_string($string) != 0 ) {
        croak $duk->last_error_string();
    }

    return $duk->to_perl(-1);
}

sub vm  { shift->{duk}; }
sub duk { shift->{duk}; }

sub set_timeout {
    my $self = shift;
    $self->duk->set_timeout( shift );
}

sub resize_memory {
    my $self = shift;
    $self->duk->resize_memory( shift );
}

sub destroy {
    local $@;
    my $self = shift;
    my $duk  = delete $self->{duk};
    return if !$duk;
    $duk->free_perl_duk();
    $duk->destroy_heap();
}

sub DESTROY {
    my $self = shift;
    if ( $self->{pid} && $self->{pid} == $$ ) {
        $self->destroy();
    }
}

package JavaScript::Duktape::Vm;
use strict;
use warnings;
no warnings 'redefine';
use Data::Dumper;
use Config qw( %Config );
use JavaScript::Duktape::C::libPath;
use Carp;

my $Duklib;

my $BOOL_PACKAGES = {
    'JavaScript::Duktape::Bool'  => 1,
    'boolean'                    => 1,
    'JSON::PP::Boolean'          => 1,
    'JSON::Tiny::_Bool'          => 1,
    'Data::MessagePack::Boolean' => 1
};

BEGIN {
    my $FunctionsMap = _get_path("FunctionsMap.pl");
    require $FunctionsMap;

    sub _get_path { &JavaScript::Duktape::C::libPath::getPath }

    $Duklib =
      $^O eq 'MSWin32'
      ? _get_path('duktape.dll')
      : _get_path('duktape.so');
}

use Inline C => config =>
    typemaps => _get_path('typemap'),
    INC      => '-I' . _get_path('../C') . ' -I' .  _get_path('../C/lib');
    # myextlib => $Duklib,
    # LIBS     => '-L'. _get_path('../C/lib') . ' -lduktape';

use Inline C => _get_path('duk_perl.c');

use Inline C => q{
    void poke_buffer(IV to, IV from, IV sz) {
        memcpy( to, from, sz );
    }
};

my $ptr_format = do {
    my $ptr_size = $Config{ptrsize};
        $ptr_size == 4 ? "L"
      : $ptr_size == 8 ? "Q"
      :                  die("Unrecognized pointer size");
};

sub peek { unpack 'P' . $_[1], pack $ptr_format, $_[0] }
sub pv_address { unpack( $ptr_format, pack( "p", $_[0] ) ) }

sub push_perl {
    my $self  = shift;
    my $val   = shift;
    my $stash = shift || {};

    if ( my $ref = ref $val ) {
        if ( $ref eq 'JavaScript::Duktape::NULL' ) {
            $self->push_null();
        }

        elsif ( $BOOL_PACKAGES->{$ref} ) {
            if ($val) {
                $self->push_true();
            }
            else {
                $self->push_false();
            }
        }

        elsif ( $ref eq 'ARRAY' ) {
            my $arr_idx = $self->push_array();
            $stash->{$val} = $self->get_heapptr(-1);
            my $len = scalar @{$val};
            for ( my $idx = 0 ; $idx < $len ; $idx++ ) {
                if ( $stash->{ $val->[$idx] } ) {
                    $self->push_heapptr( $stash->{ $val->[$idx] } );
                }
                else {
                    $self->push_perl( $val->[$idx], $stash );
                }
                $self->put_prop_index( $arr_idx, $idx );
            }
        }

        elsif ( $ref eq 'HASH' ) {
            $self->push_object();
            $stash->{$val} = $self->get_heapptr(-1);
            while ( my ( $k, $v ) = each %{$val} ) {
                $self->push_string($k);
                if ( $v && $stash->{$v} ) {
                    $self->push_heapptr( $stash->{$v} );
                }
                else {
                    $self->push_perl( $v, $stash );
                }
                $self->put_prop(-3);
            }
        }

        elsif ( $ref eq 'CODE' ) {
            $self->push_function($val);
        }

        elsif ( $ref eq 'JavaScript::Duktape::Object' ) {
            $self->push_heapptr( $val->{heapptr} );
        }

        elsif ( $ref eq 'JavaScript::Duktape::Function' ) {
            $self->push_heapptr( $val->($HEAP) );
        }

        elsif ( $ref eq 'JavaScript::Duktape::Pointer' ) {
            $self->push_pointer($$val);
        }

        elsif ( $ref eq 'JavaScript::Duktape::Buffer' ) {
            my $len = defined $$val ? length($$val) : 0;
            my $ptr = $self->push_fixed_buffer($len);
            poke_buffer( $ptr, pv_address($$val), $len );
        }

        elsif ( $ref eq 'SCALAR' ) {
            $$val ? $self->push_true() : $self->push_false()
        }

        else {
            $self->push_undefined();
        }
    }
    else {
        if ( !defined $val ) {
            $self->push_undefined();
        }
        elsif ( duk_sv_is_number($val) ) {
            $self->push_number($val);
        }
        else {
            $self->push_string($val);
        }
    }
}

sub to_perl_object {
    my $self    = shift;
    my $index   = shift;
    my $heapptr = $self->get_heapptr($index);
    if ( !$heapptr ) { croak "value at stack $index is not an object" }
    return JavaScript::Duktape::Util::jsObject(
        {
            duk     => $self,
            heapptr => $heapptr
        }
    );
}

sub to_perl {
    my $self  = shift;
    my $index = shift;
    my $stash = shift || {};

    my $ret;

    my $type = $self->get_type($index);

    if ( $type == JavaScript::Duktape::DUK_TYPE_UNDEFINED ) {
        $ret = undef;
    }

    elsif ( $type == JavaScript::Duktape::DUK_TYPE_STRING ) {
        $ret = $self->get_utf8_string($index);
    }

    elsif ( $type == JavaScript::Duktape::DUK_TYPE_NUMBER ) {
        $ret = $self->get_number($index);
    }

    elsif ( $type == JavaScript::Duktape::DUK_TYPE_BUFFER ) {
        my $ptr = $self->get_buffer_data( $index, my $sz );
        $ret = peek( $ptr, $sz );
    }

    elsif ( $type == JavaScript::Duktape::DUK_TYPE_OBJECT ) {

        if ( $self->is_function($index) ) {
            my $ptr = $self->get_heapptr($index);
            return sub {
                $self->push_heapptr($ptr);
                $self->push_this();
                my $len = 0 + @_;
                for ( my $i = 0 ; $i < $len ; $i++ ) {
                    $self->push_perl( $_[$i] );
                }
                if ( $self->pcall_method($len) == 1 ) {
                    croak $self->last_error_string();
                }
                my $ret = $self->to_perl(-1);
                $self->pop();
                return $ret;
            };
        }

        my $isArray = $self->is_array($index);

        my $heapptr = $self->require_heapptr($index);
        if ( $stash->{$heapptr} ) {
            $ret = $stash->{$heapptr};
        }
        else {
            $ret = $isArray ? [] : {};
            $stash->{$heapptr} = $ret;
        }

        $self->enum( $index, JavaScript::Duktape::DUK_ENUM_OWN_PROPERTIES_ONLY );

        while ( $self->next( -1, 1 ) ) {
            my ( $key, $val );

            $key = $self->to_perl(-2);

            if ( $self->get_type(-1) == JavaScript::Duktape::DUK_TYPE_OBJECT ) {
                my $heapptr = $self->get_heapptr(-1);
                if ( $stash->{$heapptr} ) {
                    $val = $stash->{$heapptr};
                }
                else {
                    $val = $self->to_perl( -1, $stash );
                }
            }
            else {
                $val = $self->to_perl(-1);
            }

            $self->pop_n(2);

            if ($isArray) {
                $ret->[$key] = $val;
            }
            else {
                $ret->{$key} = $val;
            }
        }

        $self->pop();
    }

    elsif ( $type == JavaScript::Duktape::DUK_TYPE_BOOLEAN ) {
        my $bool = $self->get_boolean($index);
        if ( $bool == 1 ) {
            $ret = JavaScript::Duktape::Bool::true();
        }
        else {
            $ret = JavaScript::Duktape::Bool::false();
        }
    }

    elsif ( $type == JavaScript::Duktape::DUK_TYPE_NULL ) {
        $ret = JavaScript::Duktape::NULL::null();
    }

    elsif ( $type == JavaScript::Duktape::DUK_TYPE_POINTER ) {
        my $p = $self->get_pointer($index);
        $ret = bless \$p, 'JavaScript::Duktape::Pointer';
    }

    return $ret;
}

##############################################
# push functions
##############################################
sub push_function {
    my $self  = shift;
    my $sub   = shift;
    my $nargs = shift || -1;

    $self->push_c_function(
        sub {
            my @args;
            my $top = $self->get_top();
            for ( my $i = 0 ; $i < $top ; $i++ ) {
                push @args, $self->to_perl($i);
            }

            $self->push_this();
            my $heap = $self->get_heapptr(-1);
            $self->pop();

            if ( !$heap ) {
                $self->push_global_object();
                $heap = $self->get_heapptr(-1);
                $self->pop();
            }

            $THIS->{heapptr} = $heap;
            $THIS->{duk}     = $self;

            my $ret = $sub->(@args);
            $self->push_perl($ret);
            return 1;
        },
        $nargs
    );
}

#####################################################################
# safe call
#####################################################################
sub push_c_function {
    my $self  = shift;
    my $sub   = shift;
    my $nargs = shift || -1;

    $GlobalRef->{"$sub"} = sub {
        my @args = @_;
        my $top  = $self->get_top();
        my $ret  = 1;

        my $err = $self->safe_call(
            sub {
                $ret = $sub->(@args);
                return 1;
            },
            $top,
            1
        );

        if ($err) {
            croak $self->last_error_string();
        }
        return $ret;
    };

    $self->perl_push_function( $GlobalRef->{"$sub"}, $nargs );
    $self->eval_string("(function(){perlFinalizer('$sub')})");
    $self->set_finalizer(-2);
}

#####################################################################
# safe call
#####################################################################
sub safe_call {
    my $self = shift;
    my $sub  = shift;
    my $ret;
    my $safe = sub {
        local $@;
        eval { $ret = $sub->($self) };
        if ( my $error = $@ ) {
            if ( $error =~ /^Duk::Error/i ) {
                croak $self->last_error_string();
            }
            else {
                $self->eval_string('(function (e){ throw new Error(e) })');
                $self->push_string($error);
                $self->call(1);
            }
        }

        return defined $ret ? $ret : 1;
    };

    eval { $ret = $self->perl_duk_safe_call( $safe, @_ ) };
    return defined $ret ? $ret : 1;
}

sub set_timeout {
    my $self = shift;
    my $timeout = shift;

    croak "timeout must be a number" if !duk_sv_is_number($timeout);
    $self->perl_duk_set_timeout($timeout);
}

sub resize_memory {
    my $self = shift;
    my $max_memory = shift || 0;

    croak "max_memory should be a number" if !duk_sv_is_number( $max_memory );
    croak "max_memory must be at least 256k (256 * 1024)" if $max_memory < 256 * 1024;

    $self->perl_duk_resize_memory($max_memory);
}

##############################################
# custom functions
##############################################
*get_utf8_string     = \&perl_duk_get_utf8_string;
*push_perl_function  = \&push_c_function;
*push_light_function = \&perl_push_function;

##############################################
# overridden functions
##############################################
*require_context = \&perl_duk_require_context;

##############################################
# helper functions
##############################################
*reset_top = \&perl_duk_reset_top;

sub last_error_string {
    my $self = shift;
    $self->dup(-1);
    my $error_str = $self->safe_to_string(-1);
    $self->pop();
    return $error_str;
}

sub dump {
    my $self = shift;
    my $name = shift || "Duktape";
    my $fh   = shift || \*STDOUT;
    my $n    = $self->get_top();
    printf $fh "%s (top=%ld):", $name, $n;
    for ( my $i = 0 ; $i < $n ; $i++ ) {
        printf $fh " ";
        $self->dup($i);
        printf $fh "%s", $self->safe_to_string(-1);
        $self->pop();
    }
    printf $fh "\n";
}

sub DESTROY { }

package JavaScript::Duktape::Bool;
{
    use warnings;
    use strict;
    our ( $true, $false );
    use overload
      '""'   => sub { ${ $_[0] } },
      'bool' => sub { ${ $_[0] } ? 1 : 0 },
      fallback => 1;

    BEGIN {
        my $use_boolean = eval { require boolean; 1; };
        my $t = 1;
        my $f = 0;
        $true  = $use_boolean ? boolean::true() : bless \$t, 'JavaScript::Duktape::Bool';
        $false = $use_boolean ? boolean::false() : bless \$f, 'JavaScript::Duktape::Bool';
    }

    sub true  { $true }
    sub false { $false }

    sub TO_JSON { ${$_[0]} ? \1 : \0 }
}

package JavaScript::Duktape::NULL;
{
    use warnings;
    use strict;
    our ($null);
    use overload
      '""'   => sub { ${ $_[0] } },
      'bool' => sub { ${ $_[0] } ? 1 : 0 },
      fallback => 1;

    BEGIN {
        my $n = '';
        $null = bless \$n, 'JavaScript::Duktape::NULL';
    }

    sub null { $null }
}

package JavaScript::Duktape::Object;
{
    use warnings;
    use strict;
    use Carp;
    use Data::Dumper;
    my $CONSTRUCTORS = {};
    use Scalar::Util 'weaken';
    use overload '""' => sub {
        my $self = shift;
        $self->inspect();
      },
      fallback => 1;

    sub inspect {
        my $self    = shift;
        my $heapptr = $self->{heapptr};
        my $duk     = $self->{duk};
        $duk->push_heapptr($heapptr);
        my $ret = $duk->to_perl(-1);
        $duk->pop();
        return $ret;
    }

    our $AUTOLOAD;

    sub AUTOLOAD {
        my $self     = shift;
        my $heapptr  = $self->{heapptr};
        my $duk      = $self->{duk};
        my ($method) = ( $AUTOLOAD =~ /([^:']+$)/ );
        return if $method eq 'DESTROY';
        return JavaScript::Duktape::Util::autoload( $self, $method, $duk, $heapptr, @_ );
    }

    DESTROY {
        my $self = shift;
        my $duk  = $self->{duk};

        my $refcount = delete $self->{refcount};
        return if ( !$refcount );
        $duk->push_global_stash();
        $duk->get_prop_string( -1, "PerlGlobalStash" );
        $duk->push_number($refcount);
        $duk->del_prop(-2);
        $duk->pop_2();
    }
}

package JavaScript::Duktape::Function;
{
    use strict;
    use warnings;
    use Data::Dumper;

    sub new {
        my $self = shift;
        $self->( $isNew, @_ );
    }

    our $AUTOLOAD;

    sub AUTOLOAD {
        my $self    = shift;
        my $heapptr = $self->($HEAP);
        my $duk     = $self->($DUK);

        my ($method) = ( $AUTOLOAD =~ /([^:']+$)/ );
        return if $method eq 'DESTROY';
        return JavaScript::Duktape::Util::autoload( $self, $method, $duk, $heapptr, @_ );
    }

    sub DESTROY { }
};

package JavaScript::Duktape::Util;
{
    use strict;
    use warnings;
    use Data::Dumper;
    use Carp;

    sub autoload {
        my $self    = shift;
        my $method  = shift;
        my $duk     = shift;
        my $heapptr = shift;

        $duk->push_heapptr($heapptr);
        if ( $method eq 'new' ) {
            my $len = @_ + 0;
            foreach my $val (@_) {
                $duk->push_perl($val);
            }
            if ( $duk->pnew($len) != 0 ) {
                croak $duk->last_error_string();
            }
            my $val = $duk->to_perl_object(-1);
            $duk->pop();
            return $val;
        }

        my $val = undef;
        $duk->get_prop_string( -1, $method );

        my $type = $duk->get_type(-1);
        if (   $type == JavaScript::Duktape::DUK_TYPE_OBJECT
            || $type == JavaScript::Duktape::DUK_TYPE_BUFFER )
        {

            if ( $duk->is_function(-1) ) {
                my $function_heap = $duk->get_heapptr(-1);

                if (@_) {
                    #called with special no arg _
                    shift if ( ref $_[0] eq 'NOARGS' );
                    $val = jsFunction( $method, $duk, $function_heap, $heapptr, 'call', @_ );
                }
                else {
                    $val = jsFunction( $method, $duk, $function_heap, $heapptr );
                }
            }
            else {
                $val = $duk->to_perl_object(-1);
            }
        }
        else {
            $val = $duk->to_perl(-1);
        }
        $duk->pop_2();
        return $val;
    }

    sub jsFunction {
        my $methodname  = shift;
        my $duk         = shift;
        my $heapptr     = shift;
        my $constructor = shift || $heapptr;
        my $doCall      = shift;
        my $sub         = sub {

            # check first value, if it a ref of NEW
            # then this is a constructor call, other wise
            # it's just a normal call
            my $isNew;
            my $ref = ref $_[0];
            if ( $ref eq "NEW" ) {
                shift;
                $isNew = 1;
            }
            elsif ( $ref eq "HEAP" ) {
                return $heapptr;
            }
            elsif ( $ref eq "DUK" ) {
                return $duk;
            }

            my $len = @_ + 0;
            $duk->push_heapptr($heapptr);
            $duk->push_heapptr($constructor) if !$isNew;
            foreach my $val (@_) {
                if ( ref $val eq 'CODE' ) {
                    $duk->push_function($val);
                }
                else {
                    $duk->push_perl($val);
                }
            }

            if ($isNew) {
                if ( $duk->pnew($len) != 0 ) {
                    croak $duk->last_error_string();
                }
            }
            else {
                if ( $duk->pcall_method($len) != 0 ) {
                    croak $duk->last_error_string();
                }
            }

            my $ret;
            ##getting function call values
            my $type = $duk->get_type(-1);
            if (   $type == JavaScript::Duktape::DUK_TYPE_OBJECT
                || $type == JavaScript::Duktape::DUK_TYPE_BUFFER )
            {
                $ret = $duk->to_perl_object(-1);
            }
            else {
                $ret = $duk->to_perl(-1);
            }
            $duk->pop();
            return $ret;
        };

        return $sub->(@_) if $doCall;
        return bless $sub, "JavaScript::Duktape::Function";
    }

    my $REFCOUNT = 0;

    sub jsObject {
        my $options = shift;

        my $duk         = $options->{duk};
        my $heapptr     = $options->{heapptr};
        my $constructor = $options->{constructor} || $heapptr;

        #We may push same heapptr on the global stack more
        #than once, this results in segmentation fault when
        #we destroy the object and delete heapptr from the
        #global stash then trying to use it again
        #TODO : this is really a poor man solution
        #for this problem, we use a refcounter to create
        #a unique id for each heapptr, a better solution
        #would be making sure same heapptr pushed once and not to
        #be free unless all gone
        my $refcount = ( ++$REFCOUNT ) + ( rand(3) );

        $duk->push_global_stash();
        $duk->get_prop_string( -1, "PerlGlobalStash" );
        $duk->push_number($refcount);
        $duk->push_heapptr($heapptr);
        $duk->put_prop(-3);    #PerlGlobalStash[heapptr] = object
        $duk->pop_2();

        my $type = $duk->get_type(-1);

        if ( $duk->is_function(-1) ) {
            return JavaScript::Duktape::Util::jsFunction( 'anon', $duk, $heapptr, $constructor );
        }

        return bless {
            refcount => $refcount,
            duk      => $duk,
            heapptr  => $heapptr
        }, "JavaScript::Duktape::Object";
    }
}

1;

__END__