(Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).
| NiceSlice.pm (PDL-2.075) | : | NiceSlice.pm (PDL-2.076) |
|---|
| | |
| skipping to change at line 32 | | skipping to change at line 32 |
|---|
| } | | } |
| } | | } |
| | |
| package PDL::NiceSlice; | | package PDL::NiceSlice; |
| | |
| use strict; | | use strict; |
| use warnings; | | use warnings; |
| our $VERSION = '1.001'; | | our $VERSION = '1.001'; |
| $VERSION = eval $VERSION; | | $VERSION = eval $VERSION; |
| | |
|
| $PDL::NiceSlice::debug = defined($PDL::NiceSlice::debug) ? $PDL::NiceSlice::debu
g : 0; | | $PDL::NiceSlice::debug //= 0; |
| # replace all occurrences of the form | | # replace all occurrences of the form |
| # | | # |
| # $pdl(args); | | # $pdl(args); |
| # or | | # or |
| # $pdl->(args); | | # $pdl->(args); |
| # with | | # with |
| # | | # |
| # $pdl->slice(processed_args); | | # $pdl->slice(processed_args); |
| # | | # |
| # | | # |
| | |
| skipping to change at line 55 | | skipping to change at line 55 |
|---|
| # | | # |
| # Modified 5-Nov-2007: stop processing if we encounter m/^no\s+PDL\;:\;:NiceSlic
e\;\s*$/. | | # Modified 5-Nov-2007: stop processing if we encounter m/^no\s+PDL\;:\;:NiceSlic
e\;\s*$/. |
| | |
| # the next one is largely stolen from Regexp::Common | | # the next one is largely stolen from Regexp::Common |
| my $RE_cmt = qr'(?:(?:\#)(?:[^\n]*)(?:\n))'; | | my $RE_cmt = qr'(?:(?:\#)(?:[^\n]*)(?:\n))'; |
| | |
| require PDL; # get PDL version number | | require PDL; # get PDL version number |
| | |
| use Text::Balanced; # used to find parenthesis-delimited blocks | | use Text::Balanced; # used to find parenthesis-delimited blocks |
| | |
|
| | BEGIN { |
| # this is purely for performance reasons - patch: https://github.com/steve-m-hay
/Text-Balanced/pull/5 | | # this is purely for performance reasons - patch: https://github.com/steve-m-hay
/Text-Balanced/pull/5 |
| my %ref_not_regex = map +($_=>1), qw(CODE Text::Balanced::Extractor); | | my %ref_not_regex = map +($_=>1), qw(CODE Text::Balanced::Extractor); |
| sub my_extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $i
gnoreunknown) | | sub my_extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $i
gnoreunknown) |
| { | | { |
| my $textref = defined($_[0]) ? \$_[0] : \$_; | | my $textref = defined($_[0]) ? \$_[0] : \$_; |
| my $posbug = pos; | | my $posbug = pos; |
| my ($lastpos, $firstpos); | | my ($lastpos, $firstpos); |
| my @fields = (); | | my @fields = (); |
| #for ($$textref) | | #for ($$textref) |
| { | | { |
| | |
| skipping to change at line 156 | | skipping to change at line 157 |
|---|
| } | | } |
| last; | | last; |
| } | | } |
| pos $$textref = $lastpos; | | pos $$textref = $lastpos; |
| return @fields if wantarray; | | return @fields if wantarray; |
| $firstpos ||= 0; | | $firstpos ||= 0; |
| eval { substr($$textref,$firstpos,$lastpos-$firstpos)=""; | | eval { substr($$textref,$firstpos,$lastpos-$firstpos)=""; |
| pos $$textref = $firstpos }; | | pos $$textref = $firstpos }; |
| return $fields[0]; | | return $fields[0]; |
| } | | } |
|
| # fixes false-positive heredoc - patch: https://github.com/steve-m-hay/Text-Bala | | sub my_match_codeblock($$$$$$$); |
| nced/pull/6 | | sub my_match_codeblock($$$$$$$) |
| | { |
| | my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) |
| | = @_; |
| | my $startpos = pos($$textref) = pos($$textref) || 0; |
| | unless ($$textref =~ m/$pre/gc) |
| | { |
| | Text::Balanced::_failmsg qq{Did not match prefix /$pre/ at"} . |
| | substr($$textref,pos($$textref),20) . |
| | q{..."}, |
| | pos $$textref; |
| | return; |
| | } |
| | my $codepos = pos($$textref); |
| | unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER |
| | { |
| | Text::Balanced::_failmsg qq{Did not find expected opening bracket at "} |
| | . |
| | substr($$textref,pos($$textref),20) . |
| | q{..."}, |
| | pos $$textref; |
| | pos $$textref = $startpos; |
| | return; |
| | } |
| | my $closing = $1; |
| | $closing =~ tr/([<{/)]>}/; |
| | my $matched; |
| | my $patvalid = 1; |
| | while (pos($$textref) < length($$textref)) |
| | { |
| | $matched = ''; |
| | if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc) |
| | { |
| | $patvalid = 0; |
| | next; |
| | } |
| | if ($$textref =~ m/\G\s*#.*/gc) |
| | { |
| | next; |
| | } |
| | if ($$textref =~ m/\G\s*($rdel_outer)/gc) |
| | { |
| | unless ($matched = ($closing && $1 eq $closing) ) |
| | { |
| | next if $1 eq '>'; # MIGHT BE A "LESS THAN" |
| | Text::Balanced::_failmsg q{Mismatched closing bracket at "} . |
| | substr($$textref,pos($$textref),20) . |
| | qq{...". Expected '$closing'}, |
| | pos $$textref; |
| | } |
| | last; |
| | } |
| | if (my_match_variable($textref,qr/\G(\s*)/) || |
| | my_match_quotelike($textref,'\s*',$patvalid,$patvalid) ) |
| | { |
| | $patvalid = 0; |
| | next; |
| | } |
| | # NEED TO COVER MANY MORE CASES HERE!!! |
| | if ($$textref =~ m#\G\s*(?!$ldel_inner) |
| | ( [-+*x/%^&|.]=? |
| | | [!=]~ |
| | | =(?!>) |
| | | (\*\*|&&|\|\||<<|>>)=? |
| | | split|grep|map|return |
| | | [([] |
| | )#gcx) |
| | { |
| | $patvalid = 1; |
| | next; |
| | } |
| | if ( my_match_codeblock($textref, qr/\G(\s*)/, $ldel_inner, $rdel_inner, |
| | $ldel_inner, $rdel_inner, $rd) ) |
| | { |
| | $patvalid = 1; |
| | next; |
| | } |
| | if ($$textref =~ m/\G\s*$ldel_outer/gc) |
| | { |
| | Text::Balanced::_failmsg q{Improperly nested codeblock at "} . |
| | substr($$textref,pos($$textref),20) . |
| | q{..."}, |
| | pos $$textref; |
| | last; |
| | } |
| | $patvalid = 0; |
| | $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc; |
| | } |
| | continue { $@ = undef } |
| | unless ($matched) |
| | { |
| | Text::Balanced::_failmsg 'No match found for opening bracket', pos $$tex |
| | tref |
| | unless $@; |
| | return; |
| | } |
| | my $endpos = pos($$textref); |
| | return ( $startpos, $codepos-$startpos, |
| | $codepos, $endpos-$codepos, |
| | $endpos, length($$textref)-$endpos, |
| | ); |
| | } |
| | sub my_match_variable($$); |
| | sub my_match_variable($$) |
| | { |
| | # $# |
| | # $^ |
| | # $$ |
| | my ($textref, $pre) = @_; |
| | my $startpos = pos($$textref) = pos($$textref)||0; |
| | unless ($$textref =~ m/$pre/gc) |
| | { |
| | Text::Balanced::_failmsg "Did not find prefix: /$pre/", pos $$textref; |
| | return; |
| | } |
| | my $varpos = pos($$textref); |
| | unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z |
| | ]?)}gci) |
| | { |
| | unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc) |
| | { |
| | Text::Balanced::_failmsg "Did not find leading dereferencer", pos $$ |
| | textref; |
| | pos $$textref = $startpos; |
| | return; |
| | } |
| | my $deref = $1; |
| | unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci |
| | or my_match_codeblock($textref, qr/\G()/, '\{', '\}', '\{', '\}', 0) |
| | or $deref eq '$#' or $deref eq '$$' ) |
| | { |
| | Text::Balanced::_failmsg "Bad identifier after dereferencer", pos $$ |
| | textref; |
| | pos $$textref = $startpos; |
| | return; |
| | } |
| | } |
| | while (1) |
| | { |
| | next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc; |
| | next if my_match_codeblock($textref, |
| | qr/\G(\s*->\s*(?:[_a-zA-Z]\w+\s*)?)/, |
| | qr/[({[]/, qr/[)}\]]/, |
| | qr/[({[]/, qr/[)}\]]/, 0); |
| | next if my_match_codeblock($textref, |
| | qr/\G(\s*)/, qr/[{[]/, qr/[}\]]/, |
| | qr/[{[]/, qr/[}\]]/, 0); |
| | next if my_match_variable($textref,qr/\G(\s*->\s*)/); |
| | next if $$textref =~ m/\G\s*->\s*\w+(?![\{([])/gc; |
| | last; |
| | } |
| | my $endpos = pos($$textref); |
| | return ($startpos, $varpos-$startpos, |
| | $varpos, $endpos-$varpos, |
| | $endpos, length($$textref)-$endpos |
| | ); |
| | } |
| | sub my_extract_variable (;$$) |
| | { |
| | my $textref = defined $_[0] ? \$_[0] : \$_; |
| | return ("","","") unless defined $$textref; |
| | my $pre = defined $_[1] ? qr/\G($_[1])/ : qr/\G(\s*)/; |
| | my @match = my_match_variable($textref,$pre); |
| | return Text::Balanced::_fail wantarray, $textref unless @match; |
| | return Text::Balanced::_succeed wantarray, $textref, |
| | @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX |
| | } |
| | sub my_extract_codeblock (;$$$$$) |
| | { |
| | my $textref = defined $_[0] ? \$_[0] : \$_; |
| | my $wantarray = wantarray; |
| | my $ldel_inner = defined $_[1] ? $_[1] : '{'; |
| | my $pre = !defined $_[2] ? qr/\G(\s*)/ : qr/\G($_[2])/; |
| | my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner; |
| | my $rd = $_[4]; |
| | my $rdel_inner = $ldel_inner; |
| | my $rdel_outer = $ldel_outer; |
| | my $posbug = pos; |
| | for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds } |
| | for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds } |
| | for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer) |
| | { |
| | $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')' |
| | } |
| | pos = $posbug; |
| | my @match = my_match_codeblock($textref, $pre, |
| | $ldel_outer, $rdel_outer, |
| | $ldel_inner, $rdel_inner, |
| | $rd); |
| | return Text::Balanced::_fail($wantarray, $textref) unless @match; |
| | return Text::Balanced::_succeed($wantarray, $textref, |
| | @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX |
| | ); |
| | } |
| | # fixes false-positive heredoc and false-match {y=>1} in 2.04 - patch: https://g |
| | ithub.com/steve-m-hay/Text-Balanced/pull/6 |
| my %mods = ( | | my %mods = ( |
| 'none' => '[cgimsox]*', 'm'=>'[cgimsox]*', 's'=>'[cegimsox]*', | | 'none' => '[cgimsox]*', 'm'=>'[cgimsox]*', 's'=>'[cegimsox]*', |
| 'tr'=> '[cds]*', 'y'=> '[cds]*', 'qq'=> '', 'qx'=> '', 'qw'=> '', | | 'tr'=> '[cds]*', 'y'=> '[cds]*', 'qq'=> '', 'qx'=> '', 'qw'=> '', |
| 'qr'=> '[imsx]*', 'q'=> '', | | 'qr'=> '[imsx]*', 'q'=> '', |
| ); | | ); |
| sub my_match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) | | sub my_match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) |
| { | | { |
| my ($textref, $pre, $rawmatch, $qmark) = @_; | | my ($textref, $pre, $rawmatch, $qmark) = @_; |
| my ($textlen,$startpos, | | my ($textlen,$startpos, |
| $oppos, | | $oppos, |
| | |
| skipping to change at line 270 | | skipping to change at line 459 |
|---|
| $ld2pos, 0, # NO 2ND STR | | $ld2pos, 0, # NO 2ND STR |
| $ld2pos, 0, # NO 2ND RDEL | | $ld2pos, 0, # NO 2ND RDEL |
| $ld2pos, 0, # NO MODIFIERS | | $ld2pos, 0, # NO MODIFIERS |
| $ld2pos, $textlen-$ld2pos, # REMAINDER | | $ld2pos, $textlen-$ld2pos, # REMAINDER |
| $extrapos, $str1pos-$extrapos, # FILLETED BIT | | $extrapos, $str1pos-$extrapos, # FILLETED BIT |
| ); | | ); |
| } | | } |
| $$textref =~ m/\G\s*/gc; | | $$textref =~ m/\G\s*/gc; |
| $ld1pos = pos($$textref); | | $ld1pos = pos($$textref); |
| $str1pos = $ld1pos+1; | | $str1pos = $ld1pos+1; |
|
| unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD | | if ($$textref !~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD |
| { | | { |
| Text::Balanced::_failmsg "No block delimiter found after quotelike $op", | | Text::Balanced::_failmsg "No block delimiter found after quotelike $op", |
| pos $$textref; | | pos $$textref; |
| pos $$textref = $startpos; | | pos $$textref = $startpos; |
| return; | | return; |
| } | | } |
|
| | elsif (substr($$textref, $ld1pos, 2) eq '=>') |
| | { |
| | Text::Balanced::_failmsg "quotelike $op was actually quoted by '=>'", |
| | pos $$textref; |
| | pos $$textref = $startpos; |
| | return; |
| | } |
| pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN | | pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN |
| my ($ldel1, $rdel1) = ("\Q$1","\Q$1"); | | my ($ldel1, $rdel1) = ("\Q$1","\Q$1"); |
| if ($ldel1 =~ /[[(<\{]/) | | if ($ldel1 =~ /[[(<\{]/) |
| { | | { |
| $rdel1 =~ tr/[({</])}>/; | | $rdel1 =~ tr/[({</])}>/; |
| defined(Text::Balanced::_match_bracketed($textref,"",$ldel1,"","",$rdel1
)) | | defined(Text::Balanced::_match_bracketed($textref,"",$ldel1,"","",$rdel1
)) |
| || do { pos $$textref = $startpos; return }; | | || do { pos $$textref = $startpos; return }; |
| $ld2pos = pos($$textref); | | $ld2pos = pos($$textref); |
| $rd1pos = $ld2pos-1; | | $rd1pos = $ld2pos-1; |
| } | | } |
| | |
| skipping to change at line 352 | | skipping to change at line 548 |
|---|
| $rd2pos, $second_arg, # 2ND RDEL (MAYBE) | | $rd2pos, $second_arg, # 2ND RDEL (MAYBE) |
| $modpos, $endpos-$modpos, # MODIFIERS | | $modpos, $endpos-$modpos, # MODIFIERS |
| $endpos, $textlen-$endpos, # REMAINDER | | $endpos, $textlen-$endpos, # REMAINDER |
| ); | | ); |
| } | | } |
| sub my_extract_quotelike (;$$) | | sub my_extract_quotelike (;$$) |
| { | | { |
| my $textref = $_[0] ? \$_[0] : \$_; | | my $textref = $_[0] ? \$_[0] : \$_; |
| my $wantarray = wantarray; | | my $wantarray = wantarray; |
| my $pre = defined $_[1] ? $_[1] : '\s*'; | | my $pre = defined $_[1] ? $_[1] : '\s*'; |
|
| my @match = Text::Balanced::_match_quotelike($textref,$pre,0,0); # do n
ot match // alone as m// | | my @match = my_match_quotelike($textref,$pre,0,0); # do not match // al
one as m// |
| return Text::Balanced::_fail($wantarray, $textref) unless @match; | | return Text::Balanced::_fail($wantarray, $textref) unless @match; |
| return Text::Balanced::_succeed($wantarray, $textref, | | return Text::Balanced::_succeed($wantarray, $textref, |
| $match[2], $match[18]-$match[2], # MATCH | | $match[2], $match[18]-$match[2], # MATCH |
| @match[18,19], # REMAINDER | | @match[18,19], # REMAINDER |
| @match[0,1], # PREFIX | | @match[0,1], # PREFIX |
| @match[2..17], # THE BITS | | @match[2..17], # THE BITS |
| @match[20,21], # ANY FILLET? | | @match[20,21], # ANY FILLET? |
| ); | | ); |
| } | | } |
|
| BEGIN { | | # fix for problem identified by Ingo - no point in submitting patch to p5p until |
| | above Text-Balanced PR is merged and released |
| | my $ncws = qr/\s+/; |
| | my $comment = qr/(?<![\$\@%])#.*/; |
| | my $id = qr/\b(?!([ysm]|q[rqxw]?|tr)\b)\w+/; |
| | my $EOP = qr/\n\n|\Z/; |
| | my $CUT = qr/\n=cut.*$EOP/; |
| | my $pod_or_DATA = qr/ |
| | ^=(?:head[1-4]|item) .*? $CUT |
| | | ^=pod .*? $CUT |
| | | ^=for .*? $CUT |
| | | ^=begin .*? $CUT |
| | | ^__(DATA|END)__\r?\n.* |
| | /smx; |
| | my %extractor_for = ( |
| | code_no_comments |
| | => [ { DONT_MATCH => $comment }, |
| | $ncws, { DONT_MATCH => $pod_or_DATA }, \&my_extract_variable |
| | , |
| | $id, { DONT_MATCH => \&my_extract_quotelike } ], |
| | ); |
| | use Filter::Simple (); |
| | my $orig_gen_std_filter_for = \&Filter::Simple::gen_std_filter_for; |
| | sub my_gen_std_filter_for { |
| | my ($type, $transform) = @_; |
| | goto &$orig_gen_std_filter_for if !$extractor_for{$type}; |
| | return sub { |
| | my $instr; |
| | my @components; |
| | for (my_extract_multiple($_,$extractor_for{$type})) { |
| | if (ref()) { push @components, $_; $instr=0 } |
| | elsif ($instr) { $components[-1] .= $_ } |
| | else { push @components, $_; $instr=1 } |
| | } |
| | my $count = 0; |
| | my $extractor = qr/\Q$;\E(.{4})\Q$;\E/s; |
| | $_ = join "", |
| | map { ref $_ ? $;.pack('N',$count++).$; : $_ } |
| | @components; |
| | @components = grep { ref $_ } @components; |
| | $transform->(@_); |
| | s/$extractor/${$components[unpack('N',$1)]}/g; |
| | } |
| | } |
| # override the current extract_quotelike() routine | | # override the current extract_quotelike() routine |
| # needed before using Filter::Simple to work around a bug | | # needed before using Filter::Simple to work around a bug |
| # between Text::Balanced and Filter::Simple for our purpose. | | # between Text::Balanced and Filter::Simple for our purpose. |
| no warnings 'redefine'; | | no warnings 'redefine'; |
|
| | *Text::Balanced::extract_variable = \&my_extract_variable; |
| | *Text::Balanced::_match_variable = \&my_match_variable; |
| | *Text::Balanced::extract_codeblock = \&my_extract_codeblock; |
| | *Text::Balanced::_match_codeblock = \&my_match_codeblock; |
| *Text::Balanced::extract_quotelike = \&my_extract_quotelike; | | *Text::Balanced::extract_quotelike = \&my_extract_quotelike; |
| *Text::Balanced::_match_quotelike = \&my_match_quotelike; | | *Text::Balanced::_match_quotelike = \&my_match_quotelike; |
| *Text::Balanced::extract_multiple = \&my_extract_multiple; | | *Text::Balanced::extract_multiple = \&my_extract_multiple; |
|
| | *Filter::Simple::gen_std_filter_for = \&my_gen_std_filter_for; |
| } | | } |
| | |
| # a call stack for error processing | | # a call stack for error processing |
| my @callstack = ('stackbottom'); | | my @callstack = ('stackbottom'); |
| sub curarg { | | sub curarg { |
| my $arg = $callstack[-1]; # return top element of stack | | my $arg = $callstack[-1]; # return top element of stack |
| $arg =~ s/\((.*)\)/$1/s; | | $arg =~ s/\((.*)\)/$1/s; |
| return $arg; | | return $arg; |
| } | | } |
| sub savearg ($) {push @callstack,$_[0]} | | sub savearg ($) {push @callstack,$_[0]} |
| | |
| skipping to change at line 445 | | skipping to change at line 687 |
|---|
| | |
| # a pattern that finds occurrences of the form | | # a pattern that finds occurrences of the form |
| # | | # |
| # $var( | | # $var( |
| # | | # |
| # and | | # and |
| # | | # |
| # ->( | | # ->( |
| # | | # |
| # used as the prefix pattern for findslice | | # used as the prefix pattern for findslice |
|
| | my $wspat = qr/(?:\s|$RE_cmt|\Q$;\E.{4}\Q$;\E)*/; # last bit Filter::Simple |
| my $prefixpat = qr/.*? # arbitrary leading stuff | | my $prefixpat = qr/.*? # arbitrary leading stuff |
| ((?<!&)\$\w+ # $varname not preceded by '&' | | ((?<!&)\$\w+ # $varname not preceded by '&' |
| |->) # or just '->' | | |->) # or just '->' |
|
| (\s|$RE_cmt)* # ignore comments | | $wspat |
| \s* # more whitespace | | |
| (?=\()/smx; # directly followed by open '(' (look ahead) | | (?=\()/smx; # directly followed by open '(' (look ahead) |
| | |
| # translates a single arg into corresponding slice format | | # translates a single arg into corresponding slice format |
| sub onearg ($) { | | sub onearg ($) { |
| my ($arg) = @_; | | my ($arg) = @_; |
| print STDERR "processing arg '$arg'\n" if $PDL::NiceSlice::debug; | | print STDERR "processing arg '$arg'\n" if $PDL::NiceSlice::debug; |
| return q|'X'| if $arg =~ /^\s*:??\s*$/; # empty arg or just colon | | return q|'X'| if $arg =~ /^\s*:??\s*$/; # empty arg or just colon |
| # recursively process args for slice syntax | | # recursively process args for slice syntax |
| $arg = findslice($arg,$PDL::NiceSlice::debug) if $arg =~ $prefixpat; | | $arg = findslice($arg,$PDL::NiceSlice::debug) if $arg =~ $prefixpat; |
| # no doubles colon are matched to avoid confusion with Perl's C<::> | | # no doubles colon are matched to avoid confusion with Perl's C<::> |
| | |
| skipping to change at line 519 | | skipping to change at line 761 |
|---|
| my $processed = ''; | | my $processed = ''; |
| my $ct=0; # protect against infinite loop | | my $ct=0; # protect against infinite loop |
| my ($found,$prefix,$dummy); | | my ($found,$prefix,$dummy); |
| while ( $src =~ m/\G($prefixpat)/ && (($found,$dummy,$prefix) = | | while ( $src =~ m/\G($prefixpat)/ && (($found,$dummy,$prefix) = |
| Text::Balanced::extract_bracketed($src,'()',$prefixpat))[0] | | Text::Balanced::extract_bracketed($src,'()',$prefixpat))[0] |
| && $ct++ < 1000) { | | && $ct++ < 1000) { |
| print STDERR "pass $ct: found slice expr $found at line ".line()."\n" | | print STDERR "pass $ct: found slice expr $found at line ".line()."\n" |
| if $verbose; | | if $verbose; |
| | |
| # Do final check for "for $var(LIST)" and "foreach $var(LIST)" syntax. | | # Do final check for "for $var(LIST)" and "foreach $var(LIST)" syntax. |
|
| # Process into an 'slice' call only if it's not that. | | # Process into a 'slice' call only if it's not that. |
| | |
|
| if ($prefix =~ m/for(each)?(\s+(my|our))?\s+\$\w+(\s|$RE_cmt)*$/s || | | if ($prefix =~ m/for(?:each)?\b(?:$wspat(?:my|our))?$wspat\$\w+$wspat$/s || |
| # foreach statement: Don't translate | | # foreach statement: Don't translate |
| $prefix =~ m/->\s*\$\w+$/s) # e.g. $x->$method(args) | | $prefix =~ m/->\s*\$\w+$/s) # e.g. $x->$method(args) |
| # method invocation via string, don't translate either | | # method invocation via string, don't translate either |
| { | | { |
| # note: even though we reject this one we need to call | | # note: even though we reject this one we need to call |
| # findslice on $found in case | | # findslice on $found in case |
| # it contains slice expressions | | # it contains slice expressions |
|
| $processed .= "$prefix".findslice($found); | | $processed .= $prefix.findslice($found,$verbose); |
| } else { # statement is a real slice and not a foreach | | } else { # statement is a real slice and not a foreach |
| | |
| my ($call,$pre,$post,$arg); | | my ($call,$pre,$post,$arg); |
| | |
| # the following section got an overhaul in v0.99 | | # the following section got an overhaul in v0.99 |
| # to fix modifier parsing and allow >1 modifier | | # to fix modifier parsing and allow >1 modifier |
| # this code still needs polishing | | # this code still needs polishing |
| savearg $found; # error reporting | | savearg $found; # error reporting |
| print STDERR "findslice: found '$found'\n" if $PDL::NiceSlice::debug; | | print STDERR "findslice: found '$found'\n" if $PDL::NiceSlice::debug; |
| $found =~ s/^\s*\((.*)\)\s*$/$1/s; | | $found =~ s/^\s*\((.*)\)\s*$/$1/s; |
| | |
| skipping to change at line 559 | | skipping to change at line 801 |
|---|
| my @modflags = split '', $mod; | | my @modflags = split '', $mod; |
| print STDERR "MODFLAGS: @modflags\n" if $PDL::NiceSlice::debug; | | print STDERR "MODFLAGS: @modflags\n" if $PDL::NiceSlice::debug; |
| filterdie "more than 1 modifier incompatible with ?: @modflags" | | filterdie "more than 1 modifier incompatible with ?: @modflags" |
| if @modflags > 1 && grep (/\?/, @modflags); # only one flag with where | | if @modflags > 1 && grep (/\?/, @modflags); # only one flag with where |
| my %seen = (); | | my %seen = (); |
| if (@modflags) { | | if (@modflags) { |
| for my $mod1 (@modflags) { | | for my $mod1 (@modflags) { |
| if ($mod1 eq '?') { | | if ($mod1 eq '?') { |
| $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; | | $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; |
| $call = 'where'; | | $call = 'where'; |
|
| $arg = "(" . findslice($slicearg) . ")"; | | $arg = "(" . findslice($slicearg,$verbose) . ")"; |
| # $post = ''; # no post action required | | # $post = ''; # no post action required |
| } elsif ($mod1 eq '_') { | | } elsif ($mod1 eq '_') { |
| $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; | | $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; |
| push @pre, 'flat->'; | | push @pre, 'flat->'; |
| $call ||= 'slice'; # do only once | | $call ||= 'slice'; # do only once |
| $arg = procargs($slicearg); | | $arg = procargs($slicearg); |
| # $post = ''; # no post action required | | # $post = ''; # no post action required |
| } elsif ($mod1 eq '|') { | | } elsif ($mod1 eq '|') { |
| $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; | | $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; |
| $call ||= 'slice'; | | $call ||= 'slice'; |
| | |
| skipping to change at line 600 | | skipping to change at line 842 |
|---|
| # $call = 'slice_if_pdl'; # handle runtime checks for $self type | | # $call = 'slice_if_pdl'; # handle runtime checks for $self type |
| # $arg =~ s/\)$/,q{$found})/; # add original argument string | | # $arg =~ s/\)$/,q{$found})/; # add original argument string |
| # in case $self is not an ndarray | | # in case $self is not an ndarray |
| # and the original call must be | | # and the original call must be |
| # generated | | # generated |
| } | | } |
| $pre = join '', @pre; | | $pre = join '', @pre; |
| # assumption here: sever should be last | | # assumption here: sever should be last |
| # and order of other modifiers doesn't matter | | # and order of other modifiers doesn't matter |
| $post = join '', sort @post; # need to ensure that sever is last | | $post = join '', sort @post; # need to ensure that sever is last |
|
| $processed .= "$prefix". ($prefix =~ /->(\s*$RE_cmt*)*$/ ? | | $processed .= $prefix. ($prefix =~ /->$wspat$/ ? |
| '' : '->'). | | '' : '->'). |
| $pre.$call.$arg.$post.$mypostfix; | | $pre.$call.$arg.$post.$mypostfix; |
| } | | } |
| | |
| } # end of while loop | | } # end of while loop |
| | |
| poparg; # clean stack | | poparg; # clean stack |
| pop @srcstr; # clear stack | | pop @srcstr; # clear stack |
| # append the remaining text portion | | # append the remaining text portion |
| # use substr only if we have had at least one pass | | # use substr only if we have had at least one pass |
| # through above loop (otherwise pos is uninitialized) | | # through above loop (otherwise pos is uninitialized) |
|
| $processed .= $ct > 0 ? substr $src, pos($src) : $src; | | $processed . ($ct > 0 ? substr $src, pos($src) : $src); |
| } | | } |
| | |
| ############################## | | ############################## |
| # termstr - generate a regexp to find turn-me-off strings | | # termstr - generate a regexp to find turn-me-off strings |
| # CED 5-Nov-2007 | | # CED 5-Nov-2007 |
| sub terminator_regexp{ | | sub terminator_regexp{ |
| my $clstr = shift; | | my $clstr = shift; |
| $clstr =~ s/([^a-zA-Z0-9])/\\$1/g; | | $clstr =~ s/([^a-zA-Z0-9])/\\$1/g; |
| my $termstr = '^\s*no\s+'.$clstr.'\s*;\s*(#.*)*$'; | | my $termstr = '^\s*no\s+'.$clstr.'\s*;\s*(#.*)*$'; |
| return qr/$termstr/o; # allow trailing comments | | return qr/$termstr/o; # allow trailing comments |
| | |
| skipping to change at line 692 | | skipping to change at line 934 |
|---|
| } | | } |
| if(m/^\s*(__END__|__DATA__)\s*$/) { | | if(m/^\s*(__END__|__DATA__)\s*$/) { |
| $end=$1; $off = 1; | | $end=$1; $off = 1; |
| last; | | last; |
| } | | } |
| $data .= "$_\n"; | | $data .= "$_\n"; |
| $count++; | | $count++; |
| $_=""; | | $_=""; |
| } | | } |
| $_ = $data; | | $_ = $data; |
|
| $_ = findslice $_ ; | | $_ = findslice $_, $PDL::NiceSlice::debug ; |
| $_ .= "no $class;\n" if $off; | | $_ .= "no $class;\n" if $off; |
| $_ .= "$end\n" if $end; | | $_ .= "$end\n" if $end; |
| $new .= "$_"; | | $new .= "$_"; |
| | |
| while($off && @lines) { | | while($off && @lines) { |
| $_ = shift @lines; | | $_ = shift @lines; |
| if(defined($reinstator) && m/$reinstator/) { | | if(defined($reinstator) && m/$reinstator/) { |
| $off = 0; | | $off = 0; |
| $_ = "## $_"; | | $_ = "## $_"; |
| } | | } |
| | | |
| End of changes. 18 change blocks. |
|---|
| 15 lines changed or deleted | | 266 lines changed or added |
|---|
"Fossies" - the Fresh Open Source Software Archive 