1#!./perl
2
3use strict;
4use warnings;
5
6use Scalar::Util ();
7use Test::More  (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL)
8    ? (skip_all => 'set_prototype requires XS version')
9    : (tests => 14);
10
11Scalar::Util->import('set_prototype');
12
13sub f { }
14is( prototype('f'), undef, 'no prototype');
15
16my $r = set_prototype(\&f,'$');
17is( prototype('f'), '$', 'set prototype');
18is( $r, \&f, 'return value');
19
20set_prototype(\&f,undef);
21is( prototype('f'), undef, 'remove prototype');
22
23set_prototype(\&f,'');
24is( prototype('f'), '', 'empty prototype');
25
26sub g (@) { }
27is( prototype('g'), '@', '@ prototype');
28
29set_prototype(\&g,undef);
30is( prototype('g'), undef, 'remove prototype');
31
32sub stub;
33is( prototype('stub'), undef, 'non existing sub');
34
35set_prototype(\&stub,'$$$');
36is( prototype('stub'), '$$$', 'change non existing sub');
37
38sub f_decl ($$$$);
39is( prototype('f_decl'), '$$$$', 'forward declaration');
40
41set_prototype(\&f_decl,'\%');
42is( prototype('f_decl'), '\%', 'change forward declaration');
43
44eval { &set_prototype( 'f', '' ); };
45print "not " unless
46ok($@ =~ /^set_prototype: not a reference/, 'not a reference');
47
48eval { &set_prototype( \'f', '' ); };
49ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference');
50
51# RT 72080
52
53{
54  package TiedCV;
55  sub TIESCALAR {
56    my $class = shift;
57    return bless {@_}, $class;
58  }
59  sub FETCH {
60    return \&my_subr;
61  }
62  sub my_subr {
63  }
64}
65
66my $cv;
67tie $cv, 'TiedCV';
68
69&Scalar::Util::set_prototype($cv, '$$');
70is( prototype($cv), '$$', 'set_prototype() on tied CV ref' );
71