#!/usr/bin/perl

package Sub::Clone;

use strict;
use warnings;

BEGIN {
	our $VERSION = '0.01';

	my $e = do {
		local $@;

		eval {
			require XSLoader;
			__PACKAGE__->XSLoader::load($VERSION);
		};
		   
		$@;
	};

	if ( $e && $e !~ /object version|loadable object/ ) {
		warn $e;
		require DynaLoader;
		push our @ISA, 'DynaLoader';
		__PACKAGE__->bootstrap($VERSION);
	}
}

use Sub::Exporter -setup => {
	exports => [qw(is_cloned clone_sub clone_if_immortal)],
	groups  => { default => [qw(is_cloned clone_sub)] },
};

# Pure Perl implementation:
unless ( defined &is_cloned ) {
	eval '
use B qw(svref_2object CVf_CLONED);
use Scalar::Util qw(blessed);

sub is_cloned ($) {
	my $sub = shift;
	svref_2object($sub)->CvFLAGS & CVf_CLONED;
}

sub clone_sub ($) {
	my $sub = shift;
	my $clone = sub { goto $sub };

	if ( defined( my $class = blessed($sub) ) ) {
		bless $clone, $class;
	}

	return $clone;
}

sub clone_if_immortal ($) {
	my $sub = shift;
	is_cloned($sub) ? $sub : clone_sub($sub)
}
';
}

__PACKAGE__

__END__

=pod

=head1 NAME

Sub::Clone - Clone subroutine refs for garbage collection/blessing purposes

=head1 SYNOPSIS

	use Sub::Clone;

=head1 DESCRIPTION

A surprising fact about Perl is that anonymous subroutines that do not close
over variables are actually shared, and do not garbage collect until global
destruction:

	sub get_callback {
		return sub { "hi!" };
	}

	my $first = get_callback();
	my $second = get_callback();

	warn "$first == $second"; # prints the same refaddr

This means that blessing such a sub would change all other copies (since they
are, in fact, not copies at all), and that C<DESTROY> will never be called.

=head1 EXPORTS

L<Sub::Clone> uses L<Sub::Exporter> so its C<import> has all the implied
goodness (renaming, etc).

=over 4

=item is_cloned $sub

Returns true if C<CVf_CLONED> is true (meaning that this subroutine is a clone
of a proto sub and being refcounted).

=item clone_sub $sub

Returns a clone of the sub, that is guaranteed to be refcounted, and can be
safely blessed.

=item clone_if_immortal $sub

Clones the sub if it's not C<is_cloned>.

=back

=head1 PURE PERL VS XS

This module is implemented in both XS and pure Perl, and the reference counting
behavior of the two is slightly different.

The XS implementation of C<clone_sub> uses C<cv_clone> internally, the function
that captures closure state into a clone of the code ref struct (sharing the
optree etc), which means that it's a real clone (the prototype's reference
count does not go up), whereas the pure Perl version must wrap the proto.

This means that in the pure Perl version C<DESTROY> might not be called as
early for the cloned sub as the XS version.

=head1 VERSION CONTROL

This module is maintained using Darcs. You can get the latest version from
L<http://nothingmuch.woobling.org/code>, and use C<darcs send> to commit
changes.

=head1 AUTHOR

Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>

=head1 COPYRIGHT

	Copyright (c) 2008 Yuval Kogman. All rights reserved
	This program is free software; you can redistribute
	it and/or modify it under the same terms as Perl itself.

=cut