From fdbe7067d978165773bc0afcd9042c7235d4367c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Olivier=20Mengu=C3=A9?= <dolmen@cpan.org>
Date: Mon, 21 Jan 2013 23:33:44 +0100
Subject: [PATCH] Add option '()' to allow to define the prototype of the sub

---
 Changes           |  1 +
 dist.ini          |  2 ++
 lib/System/Sub.pm | 24 +++++++++++++++++++++++-
 t/23-prototype.t  | 32 ++++++++++++++++++++++++++++++++
 4 files changed, 58 insertions(+), 1 deletion(-)
 create mode 100644 t/23-prototype.t

diff --git a/Changes b/Changes
index b3ab75d..ddea8b4 100644
--- a/Changes
+++ b/Changes
@@ -1,6 +1,7 @@
 Revision history for System-Sub.
 
 {{$NEXT}}
+	Add option '()' to define the prototype of the sub.
 
 0.130180     2013-01-18    DOLMEN (Olivier Mengué)
 	Minor fixes from BOOK (Philippe Bruhat).
diff --git a/dist.ini b/dist.ini
index 0be415a..9e5b574 100644
--- a/dist.ini
+++ b/dist.ini
@@ -22,6 +22,8 @@ format = %-9v    %{yyyy-MM-dd}d    DOLMEN (Olivier Mengué)
 [GithubMeta]
 remote = github
 
+[Prereqs]
+Scalar::Util = 1.11  ; For set_prototype
 [AutoPrereqs]
 [MinimumPerl]
 
diff --git a/lib/System/Sub.pm b/lib/System/Sub.pm
index 53a201d..77336fd 100644
--- a/lib/System/Sub.pm
+++ b/lib/System/Sub.pm
@@ -6,6 +6,8 @@ use File::Which ();
 use Sub::Name 'subname';
 use Symbol 'gensym';
 use IPC::Run qw(start finish);
+use Scalar::Util 1.11 ();  # set_prototype(&$) appeared in 1.11
+
 our @CARP_NOT;
 
 use constant DEBUG => !! $ENV{PERL_SYSTEM_SUB_DEBUG};
@@ -41,7 +43,10 @@ sub import
         my $name = shift;
         # Must be a scalar
         _croak "invalid arg: SCALAR expected" unless defined ref $name && ! ref $name;
-        my $fq_name;
+        my ($fq_name, $proto);
+        if ($name =~ s/\(([^)]*)\)$//s) {
+            $proto = $1;
+        }
         if (index($name, ':') > 0) {
             $fq_name = $name;
             $name = substr($fq_name, 1+rindex($fq_name, ':'));
@@ -62,6 +67,8 @@ sub import
                     _croak 'duplicate @ARGV' if $args;
                     $args = $options;
                     last
+                } elsif ($opt eq '()') {
+                    $proto = shift @$options;
                 } elsif ($opt =~ /^\$?0$/) { # $0
                     $cmd = shift @$options;
                 } elsif ($opt =~ /^\@?ARGV$/) { # @ARGV
@@ -94,6 +101,10 @@ sub import
                 ? _build_sub($name, [ $cmd, ($args ? @$args : ())], \%options)
                 : sub { _croak "'$name' not found in PATH" };
 
+        # As set_prototype *has* a prototype, we have to workaround it
+        # with '&'
+        &Scalar::Util::set_prototype($sub, $proto) if defined $proto;
+
         no strict 'refs';
         *{$fq_name} = subname $fq_name, $sub;
     }
@@ -231,6 +242,13 @@ System::Sub - Wrap external command with a DWIM sub
         }
     }
 
+    # Import with a prototype (see perlsub)
+    use System::Sub 'hostname()';  # Empty prototype: no args allowed
+    use strict;
+    # This will fail at compile time with "Too many arguments"
+    hostname("xx");
+
+
 =head1 DESCRIPTION
 
 See also C<L<System::Sub::AutoLoad>> for even simpler usage.
@@ -291,6 +309,10 @@ The sigil (C<$>, C<@>, C<%>) is optional.
 
 =item *
 
+C<()>: prototype of the sub. See L<perlsub/Prototypes>.
+
+=item *
+
 C<$0>: the path to the executable file. It will be expanded from PATH if it
 doesn't contain a directory separator.
 
diff --git a/t/23-prototype.t b/t/23-prototype.t
new file mode 100644
index 0000000..0fd1986
--- /dev/null
+++ b/t/23-prototype.t
@@ -0,0 +1,32 @@
+
+use strict;
+use warnings;
+
+use Test::More (-x '/bin/hostname' ? (tests => 8)
+                                   : (skip_all => 'No /bin/hostname'));
+
+use System::Sub
+    hostname => [ '$0' => '/bin/hostname' ],
+    'hostname_proto()' => [ '$0' => '/bin/hostname' ],
+    'hostname_proto2' => [ '()' => '', '$0' => '/bin/hostname' ];
+
+my $expected = `hostname`;
+chomp $expected;
+
+my $got = hostname;
+is($got, $expected, 'scalar context');
+is(prototype \&hostname, undef, 'prototype: undef');
+
+$got = hostname_proto;
+is($got, $expected, 'scalar context');
+is(prototype \&hostname_proto, '', 'prototype: ""');
+
+is(scalar eval 'hostname_proto(1)', undef, 'call with arg fails');
+like($@, qr/Too many arguments for main::hostname_proto at /, 'error "Too many arguments"');
+
+$got = hostname_proto2;
+is($got, $expected, 'scalar context');
+is(prototype \&hostname_proto2, '', 'prototype: ""');
+
+
+# vim:set et sw=4 sts=4: