view release on metacpan or  search on metacpan

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

package Keyword::Declare;
our $VERSION = '0.001018';

use 5.012;     # required for pluggable keywords plus /.../r
use warnings;
use Carp;
use List::Util 1.45 'max', 'uniqstr';

use Keyword::Simple;
use PPR;

my $NESTING_THRESHOLD = 100;   # How many nested keyword expansions is probably too many?

my $TYPE_JUNCTION = qr{ [^\W\d] \w*+ (?: [|] [^\W\d] \w*+ )*+ }x;   # How to match a TypeA|TypeB type

my @keyword_impls;  # Tracks all keyword information in every scope

sub import {
    my (undef, $opt_ref) = @_;
    $opt_ref //= {};

    # Don't allow bad arguments to be passed when the module is loaded...
    my $arg_type = ref($opt_ref);
    if (@_ > 2 || $arg_type ne 'HASH') {
        $arg_type ||= $opt_ref;
        croak "Invalid option for: use Keyword::Declare.\n",
              "Expected single hash reference, but found $arg_type instead.\n",
              "Error detected";
    }

    # If debugging requested, set in on for the caller's lexical scope...
    if ($opt_ref->{debug}) {
        ${^H}{'Keyword::Declare debug'} = !!$opt_ref->{debug};
    }

    # Install replacement __DATA__ handler...
    # [REMOVE IF UPSTREAM MODULE (Keyword::Simple) FIXED]
    _install_data_handler();

    # Install the 'keytype' (meta-)keyword...
    Keyword::Simple::define 'keytype', sub {
        # Unpack trailing code...
        my ($src_ref) = @_;

        # Where was this keyword declared???
        my ($file, $line) = (caller)[1,2];

        # These track error messages and help decompose the parameter list...
        # (they have to be package vars, so they're visible to in-regex code blocks in older Perls)
        our ($expected, $failed_at, $block_start, @params) = ('new type name', 0, 0);

        # Match and extract the keyword definition...
        use re 'eval';
        $$src_ref =~ s{
            \A
            (?<syntax>
                            (?&PerlNWS)
                (?{ $expected = "new type name"; $failed_at = pos() })
                (?<typesigil> \$?+ )
                (?<newtype>   (?&PerlIdentifier) )
                              (?&PerlOWS)
                (?{ $expected = "'is <existing type>'"; $failed_at = pos() })
                              is
                              (?&PerlOWS)
                (?{ $expected = "existing typename or literal string or regex after 'is'"; $failed_at = pos() })
                (?<oldtype>
                    (?<oldtyperegex>  (?&PerlMatch)  )
                |
                    (?<oldtypestring> (?&PerlString) )
                |
                    (?<oldtypetype>   $TYPE_JUNCTION )
                )
            )

            $PPR::GRAMMAR
        }{}xms
            or croak "Invalid keytype definition. Expected $expected\nbut found: ",
                     substr($$src_ref, $failed_at) =~ /(\S+)/;

        # Save the information from the keyword definition...
        my %keytype_info = ( %+, location => "$file line $line", hashline => "$line $file" );

        # Set up the sigil...
        my $sigil_decl = q{};
        if ($keytype_info{typesigil}) {
            my $var = qq{$keytype_info{typesigil}$keytype_info{newtype}};
            if ($keytype_info{oldtyperegex}) {
                $keytype_info{oldtyperegex} =~ s{^m}{};
                if ($keytype_info{oldtyperegex} =~ /\(\?\&Perl[A-Z]/) {
                    $keytype_info{oldtyperegex} =~ s{^\s*(\S)}{$1\$PPR::GRAMMAR};
                }
                $sigil_decl = qq{my $var; BEGIN { $var = qr$keytype_info{oldtyperegex} }}
            }
            elsif ($keytype_info{oldtypestring}) {
                $sigil_decl = qq{my $var; BEGIN { $var = $keytype_info{oldtypestring} }}
            }
            else {
                croak "Invalid keytype definition. Can only specify a sigil on new typename ($keytype_info{typesigil}$keytype_info{newtype}) if type is specified as a string or regex";
            }
        }

        # Debug, if requested...
        if (${^H}{"Keyword::Declare debug"}) {
            my $msg = ("#" x 50) . "\n"
                    . " Installed keytype at $keytype_info{location}:\n\n$keytype_info{syntax}\n\n"
                    . ("#" x 50) . "\n";
            $msg =~ s{^}{###}gm;
            warn $msg;
        }

        # Install the lexical type definition...
        $$src_ref
            = qq{BEGIN{\$^H{q{Keyword::Declare keytype:$keytype_info{newtype}=$keytype_info{oldtype}}} = 1;}}
            . $sigil_decl
            . $$src_ref;
    };

    # Install the 'keyword' (meta-)keyword...
    Keyword::Simple::define 'keyword', sub {
        # Unpack trailing code...
        my ($src_ref) = @_;

        # Where was this keyword declared???
        my ($file, $line) = (caller)[1,2];

        # 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
            :               '(?!)';

        # These track error messages and help decompose the parameter list...
        # (they have to be package vars, so they're visible to in-regex code blocks in older Perls)
        our ($expected, $failed_at, $block_start, @params) = ('keyword name', 0, 0);

        # Match and extract the keyword definition...
        use re 'eval';
        $$src_ref =~ s{
            \A
            (?<____K_D___KeywordDeclaration>
                            (?&PerlNWS)
                (?<____K_D___keyword> (?&PerlIdentifier)                  )
                            (?&PerlOWS)
                (?{ $expected = "keyword parameters or block, or 'from' specifier"; $failed_at = pos() })
                (?<____K_D___params>  (?&____K_D___ParamList)                       )
                            (?&PerlOWS)
                (?{ $expected = 'keyword block or attribute'; $failed_at = pos() })
                (?<____K_D___attrs>   (?&PerlAttributes)?+                )
                            (?&PerlOWS)
                (?{ $expected = 'keyword block'; $failed_at = $block_start = pos() })
                (?<____K_D___block>   \{\{\{ .*? \}\}\} | (?&PerlBlock)   )
            )

            (?(DEFINE)
                (?<____K_D___ParamList>
                    \(
                        (?&____K_D___ParamSet)?+
                        (?:
                            (?&PerlOWS) \) (?&PerlOWS) :then\(
                            (?{ push @Keyword::Declare::params, undef; })
                            (?&____K_D___ParamSet)
                        )?+
                    \)
                |
                    # Nothing
                )

                (?<____K_D___ParamSet>
                                        (?&PerlOWS) (?&____K_D___Param)
                    (?: (?&PerlOWS) ,   (?&PerlOWS) (?&____K_D___Param) )*+
                                    ,?+ (?&PerlOWS)
                )

                (?<____K_D___Param>
                    (?{ $expected = 'keyword parameter type'; $failed_at = pos() })
                        (?<____K_D___type> (?&PerlMatch) | (?&PerlString) | $TYPE_JUNCTION )

                    (?{ $expected = 'keyword parameter quantifier or variable'; $failed_at = pos() })
                        (?: (?&PerlOWS)  (?<____K_D___quantifier> [?*+][?+]?+      )  )?+

                    (?{ $expected = 'keyword parameter variable'; $failed_at = pos() })
                        (?: (?&PerlOWS)  (?<____K_D___sigil>    [\$\@]             )
                                         (?<____K_D___name>     (?&PerlIdentifier) )  )?+

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

                             hashline        => "$line $file",
                           );

        # Check for excessive meta-ness...
        if ($keyword_info{keyword} =~ /^(?:keyword|keytype)$/) {
            croak "Can't redefine '$keyword_info{keyword}' keyword";
        }

        # Remember where the block started...
        my $block_location
            = ($line + substr($keyword_info{KeywordDeclaration}, 0, $block_start) =~ tr/\n//) . " $file";

        # Convert any {{{...}}} block...
        if ($keyword_info{block} =~ m{ \A \{\{\{ }xms) {
            $keyword_info{block} = _convert_triple_block(\%keyword_info);
        }

        # Extract and verify any attributes...
        _unpack_attrs(\%keyword_info);

        # Extract various useful components from the parameter list...
        _unpack_signature(\%keyword_info);

        # Prepare for a trailing #line directive to keep trailing line numbers straight...
        $line += $keyword_info{KeywordDeclaration} =~ tr/\n//;

        # Record the keyword definition...
        my $keyword_ID = $keyword_info{ID} = @keyword_impls;
        push @keyword_impls, \%keyword_info;

        # Create the keyword dispatching function...
        my $keyword_defn = _build_keyword_code(\%keyword_info);

        # Report installation of keyword if requested...
        if (${^H}{"Keyword::Declare debug"}) {
            my $msg = ("#" x 50) . "\n"
                      . " Installed keyword macro at $keyword_info{location}:\n\n$keyword_info{syntax}\n\n"
                      . ("#" x 50) . "\n";
            $msg =~ s{^}{###}gm;
            warn $msg;
        }

        # Install the keyword, exporting it as well if it's in an import() or unimport() sub...
        $$src_ref = qq{ if (((caller 0)[3]//q{}) =~ /\\b(?:un)?import\\Z/) { $keyword_defn } }
                  .  q{ Keyword::Declare::_install_data_handler(); }
                  . qq{ BEGIN{ $keyword_defn } }
                  . "\n#line $line $file\n"
                  . $$src_ref;

        # Pre-empt addition of extraneous trailing newline by Keyword::Simple...
        # [REMOVE IF UPSTREAM MODULE (Keyword::Simple) IS FIXED]
        $$src_ref =~ s{\n\z}{};
    };

    # Install the 'unkeyword' (anti-meta-)keyword...
    Keyword::Simple::define 'unkeyword', sub {
        # Unpack trailing code...
        my ($src_ref) = @_;

        # Where was this keyword declared???
        my ($file, $line) = (caller)[1,2];

        # Match and extract the keyword definition...
        use re 'eval';
        $$src_ref =~ s{
            \A
            (?<leadingspace> (?&PerlNWS) )
            (?:
                (?<keyword> (?&PerlIdentifier) )
            |
                (?<unexpected> \S+ )
            )

            $PPR::GRAMMAR
        }{}xms;

        my %keyword_info = %+;

        croak "Invalid unkeyword definition. Expected keyword name (identifier)\n"
            . " but found: $keyword_info{unexpected}"
                if defined $keyword_info{unexpected};

        # Check for excessive meta-ness...
        if ($keyword_info{keyword} =~ /^(?:keyword|keytype)$/) {
            croak "Can't undefine '$keyword_info{keyword}' keyword";
        }

        # Report installation of keyword if requested...
        if (${^H}{"Keyword::Declare debug"}) {
            my $msg = ("#" x 50) . "\n"
                      . " Uninstalled keyword macro: $keyword_info{keyword}(...)\n"
                      . " at $file line $line\n"
                      . ("#" x 50) . "\n";
            $msg =~ s{^}{###}gm;
            warn $msg;
        }

        # How to remove the Keyword::Simple keyword (with workaround for earlier versions)...
        my $keyword_defn = q{Keyword::Simple::undefine( 'KEYWORD' );};
        if ($Keyword::Simple::VERSION < 0.04) {
            $keyword_defn .= "\$^H{'Keyword::Simple/keywords'} =~ s{ KEYWORD:-?\\d*}{}g;" ;
        }

        # How to remove the Keyword::Declare keywords...
        $keyword_defn .= q{
            delete @^H{ grep m{^ Keyword::Declare \s+ active:KEYWORD:}xms, keys %^H };
        };
        $keyword_defn =~ s{KEYWORD}{$keyword_info{keyword}}g;

        # Uninstall the keyword, exporting it as well if it's in an import() or unimport() sub...
        $$src_ref = qq{ if (((caller 0)[3]//q{}) =~ /\\b(?:un)?import\\Z/) { $keyword_defn } }
                  . qq{ BEGIN{ $keyword_defn } }
                  . "\n#line $line $file\n"
                  . $$src_ref;
    };
}

# Keyword::Simple::define() has a bug: it can't define keywords starting with _
# [REMOVE WHEN UPSTREAM MODULE (Keyword::Simple) IS FIXED]
sub _replacement_define {
    package Keyword::Simple;