1#!perl
2use strict; use warnings;
3use Test::More;
4my $n_tests = 0;
5
6use Config;
7BEGIN { $n_tests += 2 }
8{
9    my $p = Impostor->new( 'Donald Duck');
10    is( $p->greeting, "Hi, I'm Donald Duck", "blank title");
11    $p->assume_title( 'Mr');
12    is( $p->greeting, "Hi, I'm Mr Donald Duck", "changed title");
13}
14
15# thread support?
16BEGIN { $n_tests += 5 }
17SKIP: {
18    skip "No thread support", 5 unless $Config{ usethreads};
19    require threads;
20    treads->import if threads->can( 'import');
21
22    my $ans;
23    my $p = Impostor->new( 'Donald Duck');
24    $ans = threads->create( sub { $p->greeting })->join;
25    is( $ans, "Hi, I'm Donald Duck", "thread: blank title");
26    $p->assume_title( 'Mr');
27    $ans = threads->create( sub { $p->greeting })->join;
28    is( $ans, "Hi, I'm Mr Donald Duck", "thread: changed title");
29    $ans = threads->create(
30        sub {
31            $p->assume_title( 'Uncle');
32            $p->greeting;
33        }
34    )->join;
35    is( $ans, "Hi, I'm Uncle Donald Duck", "thread: local change");
36    is( $p->greeting, "Hi, I'm Mr Donald Duck", "thread: change is local");
37
38    # second generation thread
39    $ans = threads->create(
40        sub {
41            threads->create( sub { $p->greeting })->join;
42        }
43    )->join;
44    is( $ans, "Hi, I'm Mr Donald Duck", "double thread: got greeting");
45}
46
47BEGIN { plan tests => $n_tests }
48
49############################################################################
50
51# must do this in BEGIN so that field hashes are declared before
52# first use above
53
54BEGIN {
55    package CFF;
56    use Hash::Util::FieldHash qw( :all);
57
58    package Person;
59
60    {
61        CFF::fieldhash my %name;
62        CFF::fieldhash my %title;
63
64        sub init {
65            my $p = shift;
66            $name{ $p} = shift || '';
67            $title{ $p} = shift || '';
68            $p;
69        }
70
71        sub name { $name{ shift()} }
72        sub title { $title{ shift() } }
73    }
74
75    sub new {
76        my $class = shift;
77        bless( \ my $x, $class)->init( @_);
78    }
79
80    sub greeting {
81        my $p = shift;
82        my $greet = "Hi, I'm ";
83        $_ and $greet .= "$_ " for $p->title;
84        $greet .= $p->name;
85        $greet;
86    }
87
88    package Impostor;
89    use base 'Person';
90
91    {
92        CFF::fieldhash my %assumed_title;
93
94        sub init {
95            my $p = shift;
96            my ( $name, $title) = @_;
97            $p->Person::init( $name, $title);
98            $p->assume_title( $title);
99            $p;
100        }
101
102        sub title { $assumed_title{ shift()} }
103
104        sub assume_title {
105            my $p = shift;
106            $assumed_title{ $p} = shift || '';
107            $p;
108        }
109    }
110}
111