Commit | Line | Data |
1e73acc8 |
1 | #!perl |
1e73acc8 |
2 | use strict; use warnings; |
3 | use Test::More; |
4 | my $n_tests = 0; |
5 | |
6 | use Config; |
7 | BEGIN { $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? |
16 | BEGIN { $n_tests += 5 } |
17 | SKIP: { |
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 | |
47 | BEGIN { 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 | |
54 | BEGIN { |
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 | } |