1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements. See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to You under the Apache License, Version 2.0
# (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.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
use strict;
use warnings;
use Test::More tests => 20;
package TestObj;
use base qw( Lucy::Object::Obj );
our $version = $Lucy::VERSION;
package SonOfTestObj;
use base qw( TestObj );
{
sub to_string {
my $self = shift;
return "STRING: " . $self->SUPER::to_string;
}
sub serialize {
my ( $self, $outstream ) = @_;
$self->SUPER::serialize($outstream);
$outstream->write_string("zowie");
}
sub deserialize {
my ( $self, $instream ) = @_;
$self = $self->SUPER::deserialize($instream);
$instream->read_string;
return $self;
}
}
package BadSerialize;
use base qw( Lucy::Object::Obj );
{
sub serialize { }
}
package BadDump;
use base qw( Lucy::Object::Obj );
{
sub dump { }
}
package main;
use Storable qw( freeze thaw );
ok( defined $TestObj::version,
"Using base class should grant access to "
. "package globals in the Lucy:: namespace"
);
# TODO: Port this test to C.
eval { my $foo = Lucy::Object::Obj->new };
like( $@, qr/abstract/i, "Obj is an abstract class" );
my $object = TestObj->new;
isa_ok( $object, "Lucy::Object::Obj",
"Clownfish objects can be subclassed outside the Lucy hierarchy" );
# TODO: Port this test to C.
eval { my $twin = $object->clone };
like( $@, qr/abstract/i, "clone throws an abstract method exception" );
ok( $object->is_a("Lucy::Object::Obj"), "custom is_a correct" );
ok( !$object->is_a("Lucy::Object"), "custom is_a too long" );
ok( !$object->is_a("Lucy"), "custom is_a substring" );
ok( !$object->is_a(""), "custom is_a blank" );
ok( !$object->is_a("thing"), "custom is_a wrong" );
eval { my $another_obj = TestObj->new( kill_me_now => 1 ) };
like( $@, qr/kill_me_now/, "reject bad param" );
my $stringified_perl_obj = "$object";
require Lucy::Object::Hash;
my $hash = Lucy::Object::Hash->new;
$hash->store( foo => $object );
is( $object->get_refcount, 2, "refcount increased via C code" );
is( $object->get_refcount, 2, "refcount increased via C code" );
undef $object;
$object = $hash->fetch("foo");
is( "$object", $stringified_perl_obj, "same perl object as before" );
is( $object->get_refcount, 2, "correct refcount after retrieval" );
undef $hash;
is( $object->get_refcount, 1, "correct refcount after destruction of ref" );
my $copy = thaw( freeze($object) );
is( ref($copy), ref($object), "freeze/thaw" );
$object = SonOfTestObj->new;
like( $object->to_string, qr/STRING:.*?SonOfTestObj/,
"overridden XS bindings can be called via SUPER" );
my $frozen = freeze($object);
my $dupe = thaw($frozen);
is( ref($dupe), ref($object), "override serialize/deserialize" );
SKIP: {
skip( "Invalid serialization causes leaks", 1 ) if $ENV{LUCY_VALGRIND};
my $bad = BadSerialize->new;
eval { my $froze = freeze($bad); };
like( $@, qr/empty/i,
"Don't allow subclasses to perform invalid serialization" );
}
SKIP: {
skip( "Exception thrown within callback leaks", 1 )
if $ENV{LUCY_VALGRIND};
$hash = Lucy::Object::Hash->new;
$hash->store( foo => BadDump->new );
eval { $hash->dump };
like( $@, qr/NULL/,
"Don't allow methods without nullable return values to return NULL" );
}
|
