1use Sub::Install; 2use Test::More tests => 17; 3 4use strict; 5use warnings; 6 7# These tests largely copied from Damian Conway's Sub::Installer tests. 8 9{ # Install a sub in a package... 10 my $sub_ref = Sub::Install::install_sub({ code => \&ok, as => 'ok1' }); 11 12 isa_ok($sub_ref, 'CODE', 'return value of first install_sub'); 13 14 is_deeply($sub_ref, \&ok, 'it returns the correct code ref'); 15 16 ok1(1, 'installed sub runs'); 17} 18 19{ 20 my $to_avail = eval "use Test::Output; 1"; 21 SKIP: { 22 skip "can't run this test without Test::Output", 1 unless $to_avail; 23 Sub::Install::install_sub({ code => \&ok, as => 'tmp_ok' }); 24 25 my $expected_warning = <<'END_WARNING'; 26Subroutine main::tmp_ok redefined at t/install.t line 31 27Prototype mismatch: sub main::tmp_ok ($;$) vs ($$;$) at t/install.t line 31 28END_WARNING 29 30 my $stderr = Test::Output::stderr_from( 31 sub { Sub::Install::install_sub({ code => \&is, as => 'tmp_ok' }) } 32 ); 33 34 $stderr =~ s!\\!/!g; 35 is( 36 $stderr, 37 $expected_warning, 38 "got expected warning", 39 ); 40 } 41} 42 43{ # Install the same sub in the same package... 44 my $redef = 0; 45 my $proto = 0; 46 47 local $SIG{__WARN__} = sub { 48 return ($redef = 1) if $_[0] =~ m{Subroutine \S+ redef.+t.install\.t}; 49 return ($proto = 1) if $_[0] =~ m{Prototype mismatch.+t.install\.t}; 50 # pass("warned as expected: $_[0]") if $_[0] =~ /redefined/; 51 die "unexpected warning: @_"; 52 }; 53 54 my $sub_ref = Sub::Install::install_sub({ code => \&is, as => 'ok1' }); 55 56 ok($redef, 'correct redefinition warning went to $SIG{__WARN__}'); 57 ok($proto, 'correct prototype warning went to $SIG{__WARN__}'); 58 59 isa_ok($sub_ref, 'CODE', 'return value of second install_sub'); 60 61 is_deeply($sub_ref, \&is, 'install2 returns correct code ref'); 62 63 ok1(1,1, 'installed sub runs (with new arguments)'); 64} 65 66{ # Install in another package... 67 my $sub_ref = Sub::Install::install_sub({ 68 code => \&ok, 69 into => 'Other', 70 as => 'ok1' 71 }); 72 73 isa_ok($sub_ref, 'CODE', 'return value of third install_sub'); 74 75 is_deeply($sub_ref, \&ok, 'it returns the correct code ref'); 76 77 ok1(1,1, 'sub previously installed into main still runs properly'); 78 79 package Other; 80 ok1(1, 'remotely installed sub runs properly'); 81} 82 83{ # cross-package installation 84 sub Other::Another::foo { return $_[0] } 85 86 my $sub_ref = Sub::Install::install_sub({ 87 code => 'foo', 88 from => 'Other::Another', 89 into => 'Other::YetAnother', 90 as => 'return_lhs' 91 }); 92 93 isa_ok($sub_ref, 'CODE', 'return value of fourth install_sub'); 94 95 is_deeply( 96 $sub_ref, 97 \&Other::Another::foo, 98 'it returns the correct code ref' 99 ); 100 101 is( 102 Other::Another->foo, 103 'Other::Another', 104 'the original code does what we want', 105 ); 106 107 is( 108 Other::YetAnother->return_lhs, 109 'Other::YetAnother', 110 'and the installed code works, too', 111 ); 112} 113