File Coverage

blib/lib/Sub/Versions.pm

Criterion	Covered	Total	%
statement	17	79	21.5
branch	0	30	0.0
condition	0	7	0.0
subroutine	6	9	66.6
pod			n/a
total	23	125	18.4

package Sub::Versions;
# ABSTRACT: Subroutine versioning syntactic sugar

use 5.014;
use exact;

use Sub::Util 'subname';
use Devel::Hook;

our $VERSION = '1.06'; # VERSION

my $versions;
my $subspaces;

sub import {
    my $package = ( caller() )[0];
    my $mca     = \&{"$package\::MODIFY_CODE_ATTRIBUTES"};

    _eq_sub( $package . '::MODIFY_CODE_ATTRIBUTES', sub {
        my ( $package, $code, @attrs ) = @_;
        $mca->(@_) if ( defined &$mca );

        my $version = substr( ( grep { /^v\d+$/ } @attrs )[0] || ' ', 1 );
        return unless ($version);

        my $name = subname($code);
        my ( $class, $method ) = $name =~ m/^(.+)::(.+?)$/;

        # store sub ref along with version in $versions for later use
        $versions->{$package}{$method} = [
            sort { $b->{version} <=> $a->{version} } (
                @{ $versions->{$package}{$method} || [] },
                {
                    version => $version,
                    code    => $code,
                },
            )
        ];

        # remove existing sub
        {
            no strict 'refs';
            undef *{$name};
        }

        # setup versioned sub
        _eq_sub( "${name}_v${version}", $code );

        # setup version interstitial objects
        my $subspace = __PACKAGE__ . "::Subspace::${package}::v${version}";
        unless ( defined &{"${package}::v${version}"} ) {
            _eq_sub( "${subspace}::new", sub {
                my ( $self, $object ) = @_;
                return bless( { version => $version, object => $object }, $self );
            } );
            _eq_sub( "${package}::v${version}", sub {
                return $subspaces->{"${package}::v${version}"} ||= "$subspace"->new(shift);
            } );
        }
        _eq_sub( "${subspace}::$method", sub {
            my $self = shift;
            my $target_method = "${method}_v${version}";
            $self->{object}->$target_method(@_);
        } );

        # setup most recent version as default sub
        Devel::Hook->push_INIT_hook( sub {
            for my $method ( keys %{ $versions->{$package} } ) {
                _eq_sub( $package . '::' . $method, $versions->{$package}{$method}[0]{code} );
            }
        } );

        # setup the subver() method functionality
        _eq_sub( "$package\::subver", sub {
            my ( $self, $version, $method ) = @_;
            ( my $v = $version ) =~ s/\s+//g;

            my ( $v_vector, $v_number ) = $v =~ /^([<>=]{0,2})(\d+)$/;
            $v_vector ||= '=';
            croak(qq{"$version" not a valid version criteria}) unless ( defined $v_number );

            # unique version numbers of any method matching the name $method
            my %versions_found = map {
                map { $_->{version} => 1 } @{ $versions->{$_}{$method} || [] }
            } keys %$versions;

            # valid version numbers based on version vector input
            my @valid_versions = sort { $b <=> $a } grep {
                ( $v_vector eq '='  ) ? $_ == $v_number :
                ( $v_vector eq '==' ) ? $_ == $v_number :
                ( $v_vector eq '>=' ) ? $_ >= $v_number :
                ( $v_vector eq '<=' ) ? $_ <= $v_number :
                ( $v_vector eq '>'  ) ? $_ >  $v_number :
                ( $v_vector eq '<'  ) ? $_ <  $v_number : $_ != $v_number
            } keys %versions_found;

            # pick the highest version that can be called off the object
            my $selected_version = ( grep { $self->can( $method . '_v' . $_ ) } @valid_versions )[0];

            if ( defined $selected_version ) {
                $selected_version = 'v' . $selected_version;
                return sub { $self->$selected_version->$method(@_) };
            }

            return sub { $self->$method(@_) } if ( $self->can($method) );

            croak(qq{No "$method" subroutine with "$version" version});
        } ) unless ( defined &{"$package\::subver"} );

        return;
    } );
}

sub _eq_sub {
    my ( $name, $code ) = @_;

    {
        no strict 'refs';
        *{$name} = $code;
    }

    return $code;
}

1;

__END__