Question

我正在尝试将原型应用于子程序的副本，而不修改现有的子程序。即这不行：

use Scalar::Util 'set_prototype';

sub foo {};
*bar = \&foo;
set_prototype(\&bar, '$');  # also modifes "foo"

我想要实现的目标可以通过goto &sub：

完成

sub foo {};
sub bar($) {
    goto &foo;
}

然而，这会引入不必要的开销，我并不热衷于此。因此我的问题是：有没有办法制作子程序（CV）的（浅）副本，以便设置副本的原型不会影响原始程序？ I.e。

之类的东西

use Scalar::Util 'set_prototype';

sub foo {};
*bar = magical_cv_copy(\&foo);
set_prototype(\&bar, '$');  # does not modify "foo"

我看了Sub:Clone，但它看起来已经过时了，不会强制安装在我的系统上。我不想为此编写XS代码。

测试用例以澄清我的要求：

use strict;
use warnings;
use Test::More tests => 7;
use Scalar::Util qw/refaddr set_prototype/;

sub foo {
    my ($x) = @_;
    return 40 + $x;
}
*bar = then_a_miracle_occurs(\&foo);

ok not(defined prototype \&foo), 'foo has no prototype';
ok not(defined prototype \&bar), 'bar has no prototype';
isnt refaddr(\&foo), refaddr(\&bar), 'foo and bar are distinct';

set_prototype \&bar, '$';

ok not(defined prototype \&foo), 'foo still has no prototype';
is prototype(\&bar), '$', 'bar has the correct prototype';

is foo(2), 42, 'foo has correct behavior';
is bar(2), 42, 'bar has correct behavior';

sub then_a_miracle_occurs {
    my ($cv) = @_;
    # what goes here?
    # return sub { goto &$cv }
}

避免X-Y问题：

我的 X - 问题是第三方模块定义了一些没有原型的函数foo。明智地使用原型可以使这个功能更加优雅，所以我想创建该子的副本，除了它有一个原型。我不能对foo函数做任何假设 - 它也可能是一个XS子例程。

我无法直接设置foo的原型，因为我不希望干扰依赖foo原始行为的其他模块。

所以我们到达了我的 Y -Problem：如何复制子程序。

Answer 1

奇迹功能可能是内部cv_clone。

您提到Sub::Clone，它似乎做了您想要的。它带有基于您描述的goto技巧的纯Perl实现，以及调用cv_clone的XS实现。

我无法找到另一个包含此内部功能的模块。如果您在安装模块时遇到问题，我建议您打开RT票。已经有了one older but unresolved ticket，所以你可能需要轻推其中一个维护者。

理想情况下，此功能将是Sub::Util等模块的一部分。我们已经有Scalar::Util，List::Util，Hash::Util，但子程序没有。

Answer 2

第三方模块定义了一些没有原型的函数foo。明智地使用原型可以使这个功能更加优雅，所以我想创建该子的副本，除了它有一个原型。

你需要的只是一个薄的包装：

sub foo(&@) { &Real::foo }

或

sub foo(&@) { goto &Real::foo }

不同之处在于后者隐藏了对foo的调用，如果Real :: foo检查其调用者（例如，在出错时构建堆栈跟踪），这会产生影响。

如果你的优化想法正在消除一个子调用，那么你做错了。

Answer 3

您可以使用B::Deparse获取sub的Perl代码作为字符串，然后重新eval该代码以重新生成sub。如果子关闭任何词法变量，则可以使用PadWalker处理这些变量。

这些技巧组合似乎适用于大多数潜艇：

#!/usr/bin/env perl

use strict;
use warnings;

{
   package Sub::Clone2;
   use PadWalker;
   use B::Deparse;
   use Sub::Identify;

   sub clone_sub
   {
      my ($orig) = @_;
      my $closed_over = PadWalker::closed_over($orig);

      my $orig_pkg = Sub::Identify::stash_name($orig);
      my $orig_code = B::Deparse->new->coderef2text($orig);
      my $decl = join(q[,], sort keys %$closed_over);
      my $clone = eval sprintf('package %s; my(%s); sub %s', $orig_pkg, $decl, $orig_code)
         or die($@);

      PadWalker::set_closed_over($clone, $closed_over);
      return $clone;
   }
}

{
   package Local::Test;

   my $var = 40; # variable to close over

   sub foo {
      my $total = 0;
      $total += ++$var;
      $total += $_ for @_;
      return $total;
   }

   sub reset {
      $var = 40;
   }
}

my $orig   = \&Local::Test::foo;

print "TESTING THE ORIGINAL FUNCTION\n";
print "$_\n"
   for $orig->(1), $orig->(2, 3), $orig->(4, 5, 6);

Local::Test::reset();

my $cloned = Sub::Clone2::clone_sub($orig);

print "TESTING THE CLONED FUNCTION\n";
print "$_\n"
   for $cloned->(1), $cloned->(2, 3), $cloned->(4, 5, 6);

Local::Test::reset();

对于使用our变量的subs来说它不起作用 - 这些将抛出一个异常，说明该变量尚未声明。（但是，它应该适用于通过完全限定名称使用包变量。）

一种可能性是使用上面的clone_sub技术，每当抛出异常时，都会回到使用问题中概述的goto包装技术。

Answer 4

我对你的用法略显不清楚，但是：

如果您想扩大原型，那么您首先应该正确地prototype the function foo？

如果您想应用其他限制，那么您可能应该对调用实际函数foo的函数进行原型设计。请注意"prototypes have no influence on subroutine references"，意味着此代码失败：

*bar = set_prototype(sub { return foo(@_); }, '$');

Answer 5

[我不确定OP能做什么或不能做什么，结果证明这个答案是不合适的。我会删除它，但它可能对其他人有用，所以我会把它留下来。]

很难说出你是什么trying to accomplish。

原型显然应用于闭包，而不是所有子实例共享的底层组件，因此强制创建闭包可以给你两个子。

use strict;
use warnings;

use Scalar::Util qw( set_prototype );

sub x {
   my $x;
   return sub { $x if 0; print("$_[0]\n"); };
}

my @a = qw( d e f );

BEGIN {
   my $f = x();
   set_prototype(\&$f, '@');
   *f = $f;
}

f(@a);   # d

BEGIN {
   my $g = x();
   set_prototype(\&$g, '$');
   *g = $g;
}

g(@a);   # 3
f(@a);   # d

复制子程序

测试用例以澄清我的要求：

避免X-Y问题：

5 个答案: