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