"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "Basic/SourceFilter/NiceSlice.pm" between
PDL-2.075.tar.gz and PDL-2.076.tar.gz

About: PDL (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

Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)