package Perl6::Parameters;

use 5.006;
use strict;
use warnings;
use Switch 'Perl6';        #given/when

our $VERSION = '0.01';

use Filter::Simple;

sub separate($);
sub makeproto(\@\@);
sub makepopstate(\@\@);

FILTER {
    while(/(sub\s+([\w:]+)\s*\(([^)]*\w.*?)\)\s*\{)/) {
        my($oldsubstate, $subname, $paramlist)=($1, $2, $3);
        my($substate);
        
        die "'is rw' is not implemented but is used in subroutine $sub
+name" if($oldsubstate =~ /is rw/);
        
        #build the new sub statement
        do {
            my($popstate, $proto);
            
            do {
                #separate the parameter list into 3 arrays
                my(@ret)=separate($paramlist);
                my(@seps)=@{$ret[0]}; my(@params)=@{$ret[1]}; my(@name
+s)=@{$ret[2]};

                #form the line-noise prototype
                ($proto, my(@symbols))=makeproto(@params, @seps);
                
                #form the population statements
                $popstate=makepopstate(@names, @symbols);
            };

            #now assemble the new sub statement
            $substate="sub $subname ($proto) {\n\t$popstate";
        };
        #$substate: DONE--contains the new sub statement

        #replace the old sub statement with the new one
        do {
            s/\Q$oldsubstate/$substate/;
        };
    }
    
    if(@_) {
        print STDERR $_ if($_[0] eq '-debug');
    }
};

sub separate($) {
    my($paramlist, @seps, @names, @params)=shift;
    my(@things);
    
    #split the param list on separators--but keep the separators aroun
+d
    @things=split /([,;])/, $paramlist;

    #separate the things into separators and parameters
    for(0..$#things) {
        if($_ % 2) {
            push @seps, $things[$_];
        }
        else {
            push @params, $things[$_];
        }
    }

    #form the names array
    push @names, (/([\$\@\%]\w+)$/)[0] for @params;
    
    return \@seps, \@params, \@names;
}

sub makeproto(\@\@) {
    my($params, $seps)=@_;
    my(@symbols, $proto);
    
    #first, we convert each parameter to the appropriate symbol
    for(@$params) {
        push @symbols, tosymbol($_);
    }
    
    #then we get rid of commas since they don't appear in line-noise p
+rototypes
    @$seps=map {$_ eq ',' ? "" : $_} @$seps;
    push @$seps, '';    #avoid warning
    
    #build the line-noise prototype
    $proto.="$symbols[$_]$seps->[$_]" for(0..$#symbols);
    
    return $proto, @symbols;
}

sub makepopstate(\@\@) {
    my(@names)=@{shift()};
    my(@symbols)=@{shift()};
    my($popstate);
        
    for(0..$#names) {
        given($symbols[$_]) {
            when '\@': {
                if($names[$_] =~ /\@/) {
                    #literal array--use it
                    $popstate .= "my($names[$_])=\@{shift()};\n";
                }
                else {
                    #array ref--just like a normal one
                    $popstate .= "my($names[$_])=shift;\n";
                }
            }
        
            when '\%': {
                if($names[$_] =~ m'%') {
                    #literal hash--use it
                    $popstate .= "my($names[$_])=\%{shift()};\n";
                }
                else {
                    #hash ref--just like a normal one
                    $popstate .= "my($names[$_])=shift;\n";
                }
            }
        
            when '@': {
                if($names[$_] ne '@_') {
                    $popstate .= "my($names[$_])=(\@_);\n";
                }
            }
        
            when '%': {
                if($names[$_] eq '%_') {
                    $popstate .= '(%_)=(@_);'
                }
                else {
                    $popstate .= "my($names[$_])=(\@_);\n"
                }
            }
        
            $popstate .= "my($names[$_])=shift;\n";
        }
    }

    return $popstate;
}



sub tosymbol {
    my $term=shift;
    $term =~ s/^\s+|\s+$//g;    #strip whitespace

    given($term) {
                when /^REF/   : { return '\.' }        #Proposed in p5
+p, but NYI
        when /^GLOB/  : { return '\*' }
        when /^CODE/  : { return '&'  }
        when /^HASH/  : { return '\%' }
        when /^ARRAY/ : { return '\@' }
                when /^REGEXP/: { return '/'  }        #Proposed in p5
+p, but NYI
        when /^SCALAR/: { return '\$' }
        when /^\*\@/  : { return '@'  }
        when /^\*\%/  : { return '%'  }
        when /^\@/    : { return '\@' }
        when /^\%/    : { return '\%' }
                        { return '$'  }
    }
}

1;
[download]

---

---

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

• How do I compose an effective node title?
• How do I post a question effectively?
• Markup in the Monastery

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		&
	<		&lt;
	>		&gt;
	[		&#91;
	]		&#93;

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.