view release on metacpan or  search on metacpan

lib/Keyword/Declare.pm  view on Meta::CPAN

        my %keywords = %{$^H{+HINTK_KEYWORDS} // {}};
        $keywords{$kw} = $sub;
        $^H{+HINTK_KEYWORDS} = \%keywords;
    }
}

# Install a __DATA__ keyword to overcome bug in Keyword::Simple...
# [REMOVE WHEN UPSTREAM MODULE (Keyword::Simple) IS FIXED]
sub _install_data_handler {
    my $DATA_HANDLER = sub {
        # Unpack trailing code...
        my ($src_ref) = @_;

        # Convert to data handle...
        my $data = $$src_ref;
        $data =~ s{ \A [^\n]* \n }{}xms;
        $data .= "\n" unless substr($data,-1) eq "\n";

        # Create end-of-__DATA__ marker unlikely to be in the data...
        my $END_DATA = "\3" x 253;  # \3 is ASCII END-OF-TEXT, 253 is max ident length

        # Replace trailing code with code that opens a local *DATA handle...
        $$src_ref = qq{BEGIN {open *DATA, '<', \\<<'$END_DATA'\n$data$END_DATA\n} 1; };
    };
    _replacement_define('__DATA__', $DATA_HANDLER);
}


# Remove special prefix on names of internal named captures...
sub _deprefix {
    my ($hash_ref) = @_;

    return undef if !defined $hash_ref;
    return { map { my $key = $_; $key =~ s{^____K_D___}{}; $key => $hash_ref->{$_} }
                 keys %{$hash_ref} };
}


# Generate the source code that actually installs a keyword...
sub _build_keyword_code {
    my ($keyword_name, $keyword_sig, $keyword_ID, $keyword_block, $block_location, $block_hashline,  $prefix_var)
        = @{shift()}{qw< keyword sig_desc ID block location hashline prefix >};

    # Generate the keyword definition and set up its unique lexical ID...
    return qq{
        \$^H{"Keyword::Declare active:$keyword_name:\Q$keyword_sig\E"} = $keyword_ID;
        Keyword::Declare::_replacement_define('$keyword_name', Keyword::Declare::_get_dispatcher_for('$keyword_name',
            $keyword_ID, sub
#line $block_hashline
            { $keyword_impls[$keyword_ID]{sig_vars_unpack}  do $keyword_block }));
    };
}

# Locate prefix code for keyword...
sub _get_prefix {
    state $source_cache = {};

    my ($trail_ref, $keyword) = @_;

    my $filename = (caller 2)[1];
    my $source = $source_cache->{$filename} //= do { local (*ARGV, $/); @ARGV=$filename; <> };

    my $trailing = $$trail_ref;
    $trailing =~ s/\s+\z//;
    $source =~ s{\b$keyword\s*\Q$trailing\E\s*\z}{};

    return 'qq{' . quotemeta($source) . '}';
}


# Install keyword's source-code generator, and return a dispatcher sub for that keyword
# (building a closure for it, if necessary)...
sub _get_dispatcher_for {
    my ($keyword_name, $keyword_ID, $keyword_generator) = @_;

    # Install the keyword generator sub...
    $keyword_impls[$keyword_ID]{generator} = $keyword_generator;

    # This will dispatch any keyword of the specified name...
    state %dispatcher_for;
    return $dispatcher_for{$keyword_name} //= sub {
        my ($src_ref) = @_;
        my ($package, $file, $line) = caller;
        local $PPR::ERROR;

        # Which variants of this keyword are currently in scope???
        my @candidate_IDs = @^H{ grep { m{^ Keyword::Declare \s+ active:$keyword_name:}xms } keys %^H };

        # Which keywords are allowed in nested code at this point...
        my @active_IDs = @^H{ grep { m{^ Keyword::Declare \s+ active:}xms } keys %^H };
        my $lexical_keywords
            = @active_IDs ? join '|', reverse sort map { $keyword_impls[$_]{skip_matcher} } @active_IDs
            :               '(?!)';
        $lexical_keywords = "(?(DEFINE) (?<PerlKeyword> $lexical_keywords ) )";

        # Which of them match the keyword's actual arguments???
        my @viable_IDs
            = grep { $$src_ref =~ m{ \A $keyword_impls[$_]{sig_matcher} $lexical_keywords $PPR::GRAMMAR }xms }
                   @candidate_IDs;


        # If none of them match...game over!!!
        if (!@viable_IDs) {
            my $error = eval "no strict;sub{\n" . ($PPR::ERROR//q{}) . '}'
                            ? "    $keyword_name  "
                                 . do{ my $src = $$src_ref;
                                       $src =~ s{ \A \s*+ (\S++ [^\n]*+) \n .* }{$1}xs;
                                       $src;
                                   }
                            : do{ my $err = $@;
                                  $err =~ s{^}{    }gm;
                                  $err =~ s{\(eval \d++\) line \d++}
                                           { "$file line " . $PPR::ERROR->line($line) }eg;
                                  $err
                                };
            croak "Invalid "
                . join(" or ", uniqstr map { $keyword_impls[$_]{desc} } @candidate_IDs)
                . " at $file line $line.\nExpected:"
                . join("\n    ", q{}, uniqstr map { $keyword_impls[$_]{syntax} } @candidate_IDs)
                . "\nbut found:\n$error"
                . "\nCompilation failed";