package Symbol::Rename;
use strict;
use warnings;

use Carp qw/croak/;
use B;

our $VERSION = '0.000001';

my %SIGMAP = (
    '&' => 'CODE',
    '$' => 'SCALAR',
    '%' => 'HASH',
    '@' => 'ARRAY',
    # Others are unsupported.
);
my %TYPEMAP = reverse %SIGMAP;

sub import {
    my $class = shift;
    return unless @_;
    my ($opts, %renames) = _parse_args(@_);

    my $package = delete $opts->{package} || caller;

    croak "Unsupported option(s): " . join(", ", keys %$opts)
        if keys %$opts;

    _rename_symbols($package, %renames);
}

sub rename_symbols {
    my $class = shift;
    my ($opts, %renames) = _parse_args(@_);

    croak "Unsupported options: " . join(", ", keys %$opts)
        if keys %$opts;

    _rename_symbols($class, %renames);
}

sub _parse_args {
    my (%opts, %renames);

    while (my $symbol = shift @_) {
        if ($symbol =~ m/^-(.*)$/) {
            $opts{$1} = shift @_ or croak "No argument provided for option '-$1'";
            next;
        }

        my ($sig, $name) = ($symbol =~ qw/^(\W?)(.*)$/);
        my $type = $sig ? $SIGMAP{$sig} : 'CODE';
        croak "Unsupported sigil ($sig) on symbol '$symbol'" unless $type;

        my $new_name = shift(@_) or croak "No new name was specified for symbol '$symbol'";

        croak "Symbol '$symbol' ($type, $name) listed multiple times"
            if $renames{$name}->{$type};

        $renames{$name}->{$type} = $new_name;
    }

    return (\%opts, %renames);
}

sub _symbol_exists {
    my ($globref, $type) = @_;

    return defined(*{$globref}{$type})
        unless $type eq 'SCALAR';

    return defined(${ *{$globref}{$type} })
        if $] < 5.010;

    my $sv = B::svref_2object($globref)->SV;
    return 1 if $sv->isa('B::SV');
    return 0 unless $sv->isa('B::SPECIAL');
    return $B::specialsv_name[$$sv] ne 'Nullsv';
}

sub _rename_symbols {
    my $class = shift;
    my %renames = @_;

    no strict 'refs';
    my $stash = \%{"$class\::"};
    use strict 'refs';

    for my $name (keys %renames) {
        my $types = $renames{$name};

        no strict 'refs';
        local *GLOBCLONE = *{"$class\::$name"};
        use strict 'refs';

        delete $stash->{$name};

        for my $type (qw/CODE SCALAR HASH ARRAY FORMAT IO/) {
            if (my $new_name = $types->{$type}) {
                no strict 'refs';
                my $destglob = \*{"$class\::$new_name"};
                use strict 'refs';

                croak "Destination symbol '$TYPEMAP{$type}$class\::$new_name' already exists"
                    if _symbol_exists($destglob, $type);

                croak "Origin symbol '$TYPEMAP{$type}$class\::$name' does not exist"
                    unless _symbol_exists(\*GLOBCLONE, $type);

                no strict 'refs';
                *{"$class\::$new_name"} = *GLOBCLONE{$type};
            }
            elsif($type eq 'SCALAR' ? defined ${*GLOBCLONE{$type}} : defined *GLOBCLONE{$type}) {
                no strict 'refs';
                *{"$class\::$name"} = *GLOBCLONE{$type};
            }
        }
    }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Symbol::Rename - Rename imported symbols within a package

=head1 DESCRIPTION

Sometimes you want to import functions from multiple modules. Sometimes these
functions may have the same name. Not all exporters let you rename the function
when you import it. This module can help!

This module is intended for renaming imported symbols. It is not intended for
renaming other symbols. It will not complain when renaming non-imported
symbols, but be warned that renaming non-imported symbols can cause unexpected
behavior.

=head1 SYNOPSYS

=head2 INSIDE THE PACKAGE DOING THE IMPORTING

    use First::Tool 'widget';
    use Symbol::Rename 'widget' => 'widget_1';

    use Second::Tool 'widget';
    use Symbol::Rename 'widget' => 'widget_2';

    widget_1(...);
    widget_2(...);

=head2 AS A PACKAGE METHOD

    use Import::Into;
    use Symbol::Rename;

    sub bundle_into {
        my $pkg = shift;

        First::Tool->import::into($pkg, 'widget');
        $pkg->Symbol::Rename::rename_symbols('widget' => 'widget_1');

        Second::Tool->import::into($pkg, 'widget');
        $pkg->Symbol::Rename::rename_symbols('widget' => 'widget_2');
    }

=head1 IMPORTING

The primary way to use this tool is to C<use> it right after importing symbols
you wish to rename. Since the behavior is kicked off in a C<use> statement it
will be evaluated at compile-time, renaming the symbols BEFORE anything can use
them, and before the parser can bind anything. It is rare to need this behavior
at run time.

=head2 IMPORT ARGS

All arguments are expected to be pairs, that is C<< foo => 'bar', ... >>.

=head3 OPTIONS

Any argument prefixed with a '-' is considered a special option. Currently
'-package' is the only valid option:

    use Import::Into -package => 'Foo::Bar', ...;

This option allows you to specify a package name instead of relying on caller.

=head3 SYMBOL RENAMING

All argument pairs where the key does not have a '-' prefix are considered
symbol names to be renamed. The key may include a sigil. If no sigil is listed
then '&' is assumed and it is treated as a subroutine. The new symbol name
B<SHOULD NOT> contain a sigil.

    use Import::Into(
        '$foo' => 'new_scalar_name',
        '%foo' => 'new_hash_name',
        '@foo' => 'new_array_name',
        '&foo' => 'new_sub_name',
        'bar'  => 'another_new_sub_name',
        ...
    );

=head1 PACKAGE METHOD

You can use C<< $pkg->Symbol::Rename::rename_symbols(...) >> to rename symbols
without importing this package. The arguments are identical to input, but you
bypass the extra import logic. C<$pkg> is the namespace being modified.

This is mainly useful when external tools need to rename symbols in a package
that imports them.

=head1 SOURCE

The source code repository for Symbol-Rename can be found at
F<http://github.com/exodist/Symbol-Rename/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2015 Chad Granum E<lt>exodist7@gmail.comE<gt>.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See F<http://dev.perl.org/licenses/>

=cut
