view release on metacpan or  search on metacpan

lib/Filter/signatures.pm  view on Meta::CPAN

            push @argument_positions, pos($splitlist);
        };
        push @argument_positions, length( $splitlist )+1;
        my $lastpos = 0;
        @args = map { kill_comment($_) } map { s!^\s*!!; s!\s*$!!; $_}
                   map { my $r = substr $args, $lastpos, $_-$lastpos-1;
                         #warn "$lastpos:$_:$r";
                         $lastpos=$_;
                         $r
                   } @argument_positions
                   ;
    };
    my $res;
    # Adjust how many newlines we gobble
    $whitespace ||= '';
    #warn "[[$whitespace$args]]";
    my $padding = () = (($whitespace . $args) =~ /\n/smg);
    if( @args ) {
        my @defaults;
        for( 0..$#args ) {
            # Keep everything on one line
            $args[$_] =~ s/\n/ /g;

            # Named argument with default
            if( $args[$_] =~ m!^\s*([\$\%\@]\s*\w+)\s*(//=|\|\|=|=)\s*(.*)$! ) {
                my $named = "$1";
                my $op = "$2";
                my $val = "$3";
                if( $op eq '=' ) {
                    push @defaults, "$named $op $val if \@_ <= $_;";
                } else {
                    push @defaults, "$named $op $val;";
                }
                $args[$_] = $named;

            # Named argument
            } elsif( $args[$_] =~ /^\s*([\$\%\@]\s*\w+)\s*$/ ) {
                my $named = "$1";
                $args[$_] = $named;

            # Slurpy discard
            } elsif( $args[$_] =~ /^\s*\$\s*$/ ) {
                $args[$_] = 'undef';

            # Slurpy discard (at the end)
            } elsif( $args[$_] =~ /^\s*[\%\@]\s*$/ ) {
                $args[$_] = 'undef';
            } else {
                #use Data::Dumper;
                #warn Dumper \@Filter::Simple::components;
                #die "Weird, unparsed argument '$args[$_]'";
            };

        };

        # Make sure we return undef as the last statement of our initialization
        # See t/07*
        push @defaults, "();" if @args;

        $res = sprintf 'sub %s { my (%s)=@_;%s%s', $name, join(",", @args), join( "" , @defaults), "\n" x $padding;
        # die sprintf("Too many arguments for subroutine at %s line %d.\n", (caller)[1, 2]) unless @_ <= 2
        # die sprintf("Too few arguments for subroutine at %s line %d.\n", (caller)[1, 2]) unless @_ >= 2
    } else {
        $res = sprintf 'sub %s { @_==0 or warn "Subroutine %s called with parameters.";();', $name, $name;
    };

    return $res
}

# This is the version that is most downwards compatible but doesn't handle
# parentheses in default assignments
sub transform_arguments {
        # This should also support
        # sub foo($x,$y,@) { ... }, throwing away additional arguments
        # Named or anonymous subs
        no warnings 'uninitialized';
        s{\bsub(\s*)(\w*)(\s*)\((\s*)((?:[^)]*?\@?))(\s*)\)(\s*)\{}{
                parse_argument_list("$2","$5","$1$3$4$6$7")
         }mge;
        $_
}

if( $] >= 5.010 ) {
    # Perl 5.10 onwards has recursive regex patterns, and comments, and stuff

# We have an interesting dependency on the format the string placeholders that
# Filter::Simple supplies. They MUST be four characters wide.
    no warnings 'redefine';
    eval <<'PERL_5010_onwards';
sub transform_arguments {
    # We also want to handle arbitrarily deeply nested balanced parentheses here
        no warnings 'uninitialized';
        # If you are staring at this, somewhere in your source code, you have
        # $/ and you want to make sure there is a second slash on the same line,
        # like `local $/; # / for Filter::signatures`
        # Or "-s _" , this also trips up Filter::Simple. Replace by "-s *_"
        #my $msg = $_;
        #$msg =~ s!([\x00-\x09\x0b-\x1F])!sprintf "\\%03o", ord $1!ge;
        #print "$msg\n---\n";
        #use Regexp::Debugger;
        s{(?<sub>\bsub\b)  #1
           (?>(\s*))       #2
           (?>(\b\w+\b|))  #3
           (\s*)           #4
           \(
           (\s*)           #5
           (               #6
                (          #7
                   (?:
                     \\.            # regex escapes and references
                     |
                     (?>".{5}")     # strings (that are placeholders)
                     |
                     (?>"[^"]+")    # strings (that are not placeholders, mainly for the test suite)
                     |
                     \(
                         (?7)?      # recurse for parentheses
                     \)
                     |
                     \{
                         (?7)?      # recurse for curly brackets
                     \}