view release on metacpan or  search on metacpan

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

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};
    
        *{ $call_class . "::$export_sub" } = $EXPORT_OK{$export_sub};
    }

    return;
}

sub sayx ($@){ ## no critic
    say sprintx([caller 0], @_);
}

sub printx ($@) { ## no critic
    print sprintx([caller 0], @_);
}

sub sprintx ($@) { ## no critic
    my $peek_level = 1;
    my $call_class;
    if (_ARRAY( $_[0] )) {
        $call_class = shift->[0];
        $peek_level++;
    }
    $call_class ||= caller 0;

    my ($fmt, %bind_vars) = @_;

    my @binds;
    my $map_bind_var = sub {
        my ($bind_var_name, $format_char) = @_;
        local *__ANON__ = 'map_bind_var'; ## no critic

        my $internal_name = $bind_var_name;
        if (exists $bind_vars{$internal_name}) {
            # pass
        }
        elsif (exists $bind_vars{q{$}.$internal_name}) {
            $internal_name = q{$}.$internal_name;
        }
        else {
            croak "No such bind var: $bind_var_name";
        }

        my $value_ref = $bind_vars{$internal_name};
        croak 'Bind var must be scalar'
            if not _SCALAR($value_ref);

        push @binds, ${ $value_ref };

        return defined $format_char ? q{%} . $format_char
                                    : $DEFAULT_FORMAT;
    };

    my $mode = $mode_for_class{$call_class} || $DEFAULT_MODE;