view release on metacpan or  search on metacpan

lib/Acme/Locals.pm  view on Meta::CPAN

# $Id$
# $Source$
# $Author$
# $HeadURL$
# $Revision$
# $Date$
package Acme::Locals;

use strict;
use warnings;
use version; our $VERSION = qv('0.1.1');
use 5.00600;

use Carp            qw(carp croak);
use PadWalker       ();
use Params::Util    qw(_SCALAR _ARRAY);

BEGIN {
    use English qw(-no_match_vars);
    my $find_best_say = sub {
        eval q{use Perl6::Say}; ## no critic
        return if not $EVAL_ERROR;
        no warnings 'once'; ## no critic
        *say = sub { print @_, "\n" };
    };
    $find_best_say->();
}

my $DEFAULT_FORMAT = q{%s};
my $DEFAULT_MODE   = '-python';

my %EXPORT_OK      = (
    sayx     => \&sayx,
    printx   => \&printx,
    sprintx  => \&sprintx,
    locals   => \&locals,
    globals  => \&globals,
    lexicals => \&lexicals,
);

my %EXPORT_TAGS    = (
    ':all'  => [ keys %EXPORT_OK ],
);

my %MODES = (
    '-python' => qr/\%\( (.+?) \)(\w)?/xms,
    '-ruby'   => qr/\#\{ (.+?) \}/xms,
);

my %mode_for_class;

sub sayx        ($@); ## no critic
sub printx      ($@); ## no critic
sub sprintfx    ($@); ## no critic

sub import {
    my ($this_class, @tags) = @_;
    my $call_class = caller 0;

    my @to_export;
    for my $tag (@tags) {
        if ($tag =~ m/^:/xms) {
            croak __PACKAGE__, " does not support the tag  $tag"
                if not exists $EXPORT_TAGS{$tag};

            push @to_export, @{ $EXPORT_TAGS{$tag} };
        }
        elsif ($tag =~ m/^-/xms) {
            $mode_for_class{$call_class} = $tag;
        }
        else {
            push @to_export, $tag;
        }
    }
    $mode_for_class{$call_class} ||= $DEFAULT_MODE;
    if (not exists $MODES{ $mode_for_class{$call_class} }) {
        my $cur_mode = $mode_for_class{$call_class};
        carp "Unknown mode $cur_mode. Switching to default mode $DEFAULT_MODE";
        $mode_for_class{$call_class} = $DEFAULT_MODE;
    }

    no strict 'refs'; ## no critic
    for my $export_sub (@to_export) {
        croak __PACKAGE__, " does not export $export_sub"
            if not exists $EXPORT_OK{$export_sub};