view release on metacpan or  search on metacpan

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

        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)
                )

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

        }

        # 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;

    my ($kw, $sub) = @_;
    $kw =~ /^[^\W\d]\w*\z/ or croak "'$kw' doesn't look like an identifier";
    ref($sub) eq 'CODE' or croak "'$sub' doesn't look like a coderef";

    if ($Keyword::Simple::VERSION < 0.04) {
        our @meta;
        my $n = @meta;
        push @meta, $sub;

        $^H{+HINTK_KEYWORDS} .= " $kw:$n";
        use B::Hooks::EndOfScope;
        on_scope_end {
            delete $meta[$n];
        };
    }
    else {
        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; };