*** /dev/null Sat Nov 23 08:44:00 2024
--- - Sat Nov 23 08:44:29 2024
***************
*** 0 ****
--- 1,244 ----
+ #
+ # ***** BEGIN LICENSE BLOCK *****
+ # Version: MPL 1.1/GPL 2.0/LGPL 2.1
+ #
+ # The contents of this file are subject to the Mozilla Public License Version
+ # 1.1 (the "License"); you may not use this file except in compliance with
+ # the License. You may obtain a copy of the License at
+ # http://www.mozilla.org/MPL/
+ #
+ # Software distributed under the License is distributed on an "AS IS" basis,
+ # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ # for the specific language governing rights and limitations under the
+ # License.
+ #
+ # The Original Code is Mozilla Communicator client code, released
+ # March 31, 1998.
+ #
+ # The Initial Developer of the Original Code is
+ # Netscape Communications Corporation.
+ # Portions created by the Initial Developer are Copyright (C) 1998
+ # the Initial Developer. All Rights Reserved.
+ #
+ # Contributor(s):
+ #
+ # Alternatively, the contents of this file may be used under the terms of
+ # either the GNU General Public License Version 2 or later (the "GPL"), or
+ # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
+ # in which case the provisions of the GPL or the LGPL are applicable instead
+ # of those above. If you wish to allow use of your version of this file only
+ # under the terms of either the GPL or the LGPL, and not to allow others to
+ # use your version of this file under the terms of the MPL, indicate your
+ # decision by deleting the provisions above and replace them with the notice
+ # and other provisions required by the GPL or the LGPL. If you do not delete
+ # the provisions above, a recipient may use your version of this file under
+ # the terms of any one of the MPL, the GPL or the LGPL.
+ #
+ # ***** END LICENSE BLOCK *****
+
+ #
+ # Test file for JS.pm
+ #
+
+ ############################################################
+ # support packages for test script
+ ############################################################
+
+ ############################################################
+ # Fotrik
+ package Father;
+
+ sub old_meth {
+ return "Father::old_meth";
+ }
+
+
+ ############################################################
+ # Synacek
+ package Son;
+ use vars qw( @ISA );
+ @ISA = qw( Father );
+
+ sub new {
+ my $class = shift;
+ $class = ref $class || $class;
+ my $self = {};
+ bless $self, $class;
+ return $self;
+ }
+
+ sub new_meth {
+ return "Son::new_meth";
+ }
+
+ ############################################################
+ # Proxy
+ package Proxy;
+
+ sub new {
+ my $class = shift;
+ $class = ref $class || $class;
+ my $self = { property => shift };
+ bless $self, $class;
+ return $self;
+ }
+
+ sub getObj {
+ my $ret = new Son();
+ return $ret;
+ }
+
+ sub getValue {
+ my $self = shift;
+ return $self->{ property };
+ }
+
+ sub getArray {
+ my $self = shift;
+ return [34, 35, 36, 37, 38];
+ }
+
+ sub getHash {
+ my $self = shift;
+ return { testkey1 => 'testvalue1',
+ testkey2 => 'testvalue2',
+ testkey3 => 'testvalue3', };
+ }
+
+ ############################################################
+ # main part of the test script
+ ############################################################
+
+ package main;
+ use JS;
+
+ BEGIN {
+ $| = 1; print "1..12\n";
+ }
+
+ END
+ { print "not ok 1\n" unless $loaded; }
+
+ $loaded = 1;
+ print "ok 1\n";
+
+ use strict; #no typos, please
+
+ my $rt = new JS(1_204 ** 2);
+ my $cx = $rt->createContext(8 * 1_024);
+
+ my $jsval;
+ my $testc = 1; #testcounter
+ ############################################################
+ # the simplest test
+ $testc++;
+ $jsval = $cx->eval('6;');
+ print $jsval == 6 ? "ok $testc\n" : "not ok $testc\n"; #2
+
+ ############################################################
+ #second very simple test
+ $testc++;
+ $jsval = $cx->eval('"hallo";');
+ print $jsval eq "hallo" ? "ok $testc\n" : "not ok $testc\n"; #3
+
+ ############################################################
+ # third very simple test
+ $testc++;
+ $jsval = $cx->eval("1.23");
+ print $jsval == 1.23 ? "ok $testc\n" : "not ok $testc\n"; #4
+
+ ############################################################
+ #undef is little bit tricky
+ $testc++;
+ $jsval = $cx->eval('undefined');
+ print ! defined $jsval ? "ok $testc\n" : "not ok $testc\n"; #5
+
+ ############################################################
+ #can ve tie js objects? (generally to hash, Arrays to arrays too)
+ $testc++;
+ $jsval = $cx->eval('foo = new Object(); foo.prop = 11; foo;');
+ my %hash;
+ #read js property
+ tie %hash, 'JS::Object', $jsval;
+ print $hash{prop} == 11 ? "ok $testc\n" : "not ok $testc\n"; #6
+
+ ############################################################
+ #set js propertry
+ $testc++;
+ $hash{prop2} = 2;
+ $jsval = $cx->eval('foo.prop2;');
+ print $jsval == 2 ? "ok $testc\n" : "not ok $testc\n"; #7
+
+ ############################################################
+ #tie array
+ $testc++;
+ my @arr;
+ $jsval = $cx->eval('arr = new Array(); arr[0] = 0; arr[1] = 1; arr;');
+ tie @arr, "JS::Object", $jsval;
+ print ((($#arr == 1) && ($arr[1] == 1)) ? "ok $testc\n" : "not ok $testc\n");#8
+
+ ############################################################
+ # object delegation test
+ $testc++;
+ $cx->createObject(new Proxy("init_value"), "perlobj",
+ { getObj => \&Proxy::getObj,
+ getValue => \&Proxy::getValue,
+ getArray => \&Proxy::getArray,
+ getHash => \&Proxy::getHash,
+ });
+ $jsval = $cx->eval("perlobj.getValue()");
+ print $jsval eq "init_value" ? "ok $testc\n" : "not ok $testc\n"; #9
+
+ ############################################################
+ # perl object returned to js
+ $testc++;
+ $jsval = $cx->eval("po = perlobj.getObj(); po.new_meth()");
+ print $jsval eq "Son::new_meth" ? "ok $testc\n" : "not ok $testc\n"; #10
+
+ ############################################################
+ # and what about inherited methods?
+ $testc++;
+ $jsval = $cx->eval("po.old_meth()");
+ print $jsval eq "Father::old_meth" ? "ok $testc\n" : "not ok $testc\n"; #11
+
+ ############################################################
+ # pass an array, check the element
+ $testc++;
+ $jsval = $cx->eval("parr = perlobj.getArray(); parr[2];");
+ print $jsval == 36 ? "ok $testc\n" : "not ok $testc\n"; #12
+
+ ############################################################
+ # check the array length
+ $testc++;
+ $jsval = $cx->eval("parr.length");
+ print $jsval == 5 ? "ok $testc\n" : "not ok $testc\n"; #13
+
+ ############################################################
+ # pass a hash, check the element
+ $testc++;
+ $jsval = $cx->eval("phash = perlobj.getHash(); phash.testkey1;");
+ print $jsval eq 'testvalue1' ? "ok $testc\n" : "not ok $testc\n"; #14
+
+ ############################################################
+ # error test
+ $testc++;
+ my $line;
+ my $err;
+ sub js_ErrorReporter {
+ my ($msg, $file, $line, $linebuf, $token) = @_;
+ $err = "line $line $msg";
+ }
+ $cx->setErrorReporter( \&js_ErrorReporter );
+ $cx->eval("x = 2 + 4;\nx.method()\n");
+ print $err =~ /^line 1/ ? "ok $testc\n" : "not ok $testc\n"; #15
+
+ ############################################################
+ # cleanup
+ # so far we have to undef context value, to make sure,
+ # it is disposed before runtime
+ undef $cx;
+ undef $rt;
+
+ __END__
+
+
|
