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
|
#!perl
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
@INC = '../lib';
}
}
use strict; use warnings;
use Test::More;
my $n_tests = 0;
use Config;
BEGIN { $n_tests += 2 }
{
my $p = Impostor->new( 'Donald Duck');
is( $p->greeting, "Hi, I'm Donald Duck", "blank title");
$p->assume_title( 'Mr');
is( $p->greeting, "Hi, I'm Mr Donald Duck", "changed title");
}
# thread support?
BEGIN { $n_tests += 5 }
SKIP: {
skip "No thread support", 5 unless $Config{ usethreads};
require threads;
treads->import if threads->can( 'import');
my $ans;
my $p = Impostor->new( 'Donald Duck');
$ans = threads->create( sub { $p->greeting })->join;
is( $ans, "Hi, I'm Donald Duck", "thread: blank title");
$p->assume_title( 'Mr');
$ans = threads->create( sub { $p->greeting })->join;
is( $ans, "Hi, I'm Mr Donald Duck", "thread: changed title");
$ans = threads->create(
sub {
$p->assume_title( 'Uncle');
$p->greeting;
}
)->join;
is( $ans, "Hi, I'm Uncle Donald Duck", "thread: local change");
is( $p->greeting, "Hi, I'm Mr Donald Duck", "thread: change is local");
# second generation thread
$ans = threads->create(
sub {
threads->create( sub { $p->greeting })->join;
}
)->join;
is( $ans, "Hi, I'm Mr Donald Duck", "double thread: got greeting");
}
BEGIN { plan tests => $n_tests }
############################################################################
# must do this in BEGIN so that field hashes are declared before
# first use above
BEGIN {
package CFF;
use Hash::Util::FieldHash qw( :all);
package Person;
{
CFF::fieldhash my %name;
CFF::fieldhash my %title;
sub init {
my $p = shift;
$name{ $p} = shift || '';
$title{ $p} = shift || '';
$p;
}
sub name { $name{ shift()} }
sub title { $title{ shift() } }
}
sub new {
my $class = shift;
bless( \ my $x, $class)->init( @_);
}
sub greeting {
my $p = shift;
my $greet = "Hi, I'm ";
$_ and $greet .= "$_ " for $p->title;
$greet .= $p->name;
$greet;
}
package Impostor;
use base 'Person';
{
CFF::fieldhash my %assumed_title;
sub init {
my $p = shift;
my ( $name, $title) = @_;
$p->Person::init( $name, $title);
$p->assume_title( $title);
$p;
}
sub title { $assumed_title{ shift()} }
sub assume_title {
my $p = shift;
$assumed_title{ $p} = shift || '';
$p;
}
}
}
|
