view release on metacpan or  search on metacpan

lib/PDL/PP.pm  view on Meta::CPAN

  _pp_addpm_nolineno(@args);
}

sub pp_add_exported {
  shift if !$_[0] or $_[0] eq __PACKAGE__;
  $::PDLPMROUT .= join ' ', @_, '';
}

sub pp_addbegin {
	my ($cmd) = @_;
	if ($cmd =~ /^\s*BOOT\s*$/) {
		pp_beginwrap;
	} else {
		$::PDLBEGIN .= $cmd."\n";
	}
}

#  Sub to call to export nothing (i.e. for building OO package/object)
sub pp_export_nothing {
	$::PDLPMROUT = ' ';
}

sub pp_add_isa {
	push @::PDLPMISA,@_;
}

sub pp_add_boot {
	my ($boot) = @_;
	$boot =~ s/^\s*\n//gm; # XS doesn't like BOOT having blank lines
	$::PDLXSBOOT .= $boot;
}

sub pp_bless{
   my($new_package)=@_;
   $::PDLOBJ = $new_package;
}

# sub to call to set the import list from core on the 'Use Core' line in the .pm file.
#   set to '()' to not import anything from Core, or 'qw/ barf /' to import barf.
sub pp_core_importList{
   $::PDLCOREIMPORT = $_[0];
}

sub printxs {
	shift;
	$::PDLXS .= join'',@_;
}

sub pp_addxs {
	PDL::PP->printxs("\nMODULE = $::PDLMOD PACKAGE = $::CALLPACK\n\n",
                         @_,
                         "\nMODULE = $::PDLMOD PACKAGE = $::PDLOBJ PREFIX=pdl_run_\n\n");
}

# inserts #line directives into source text. Use like this:
#   ...
#   FirstKey => ...,
#   Code => pp_line_numbers(__LINE__, $x . $y . $c),
#   OtherKey => ...
sub pp_line_numbers {
  _pp_line_number_file((caller)[1], @_);
}
sub _pp_line_number_file {
	my ($filename, $line, $string) = @_;
	confess "pp_line_numbers called with undef" if !defined $string;
	# The line needs to be incremented by one for the bookkeeping to work
	$line++;
	$filename = 'lib/PDL/PP.pm' if $filename eq __FILE__;
	$filename =~ s/\\/\\\\/g; # Escape backslashes
	my @to_return = "\nPDL_LINENO_START $line \"$filename\"\n";
	# Look for broadcastloops and loops and add # line directives
	foreach (split (/\n/, $string)) {
		# Always add the current line.
		push @to_return, "$_\n";
		# If we need to add a # line directive, do so after incrementing
		$line++;
		if (/%\{/ or /%}/) {
			push @to_return, "PDL_LINENO_END\n";
			push @to_return, "PDL_LINENO_START $line \"$filename\"\n";
		}
	}
	push @to_return, "PDL_LINENO_END\n";
	return join('', @to_return);
}
my $LINE_RE = qr/^(\s*)PDL_LINENO_(?:START (\S+) "(.*)"|(END))$/;
sub _pp_linenumber_fill {
  local $_; # else get "Modification of a read-only value attempted"
  my ($file, $text) = @_;
  my (@stack, @to_return) = [1, $file];
  my @lines = split /\n/, $text;
  REALLINE: while (defined($_ = shift @lines)) {
    $_->[0]++ for @stack;
    push(@to_return, $_), next if !/$LINE_RE/;
    my ($ci, $new_line, $new_file, $is_end) = ($1, $2, $3, $4);
    if (!$is_end) {
      push @stack, [$new_line-1, $new_file];
      push @to_return, qq{$ci#line @{[$stack[-1][0]+1]} "$stack[-1][1]"} if @lines;
      next REALLINE;
    }
    @stack = [$stack[0][0], $file]; # as soon as any block is left, line numbers for outer blocks become meaningless
    my ($seen_empty, $empty_first, $last_ci, @last_dir) = (0, undef, $ci); # list=(line, file)
    LINE: while (1) {
      last REALLINE if !@lines;
      if (!length $lines[0] && $lines[1] !~ /^=/) {
        $seen_empty = 1;
        shift @lines;
        next LINE;
      }
      if ($lines[0] =~ /$LINE_RE/) { # directive
        ($last_ci, @last_dir) = ($1, !$4 ? ($2, $3) : ());
        $empty_first //= $seen_empty;
        shift @lines;
        next LINE;
      } else { # substantive
        push @stack, \@last_dir if @last_dir;
        push(@to_return, ''), $stack[0][0]++ if $seen_empty and $empty_first;
        push @to_return, qq{$last_ci#line $stack[-1][0] "$stack[-1][1]"};
        push(@to_return, ''), $stack[0][0]++ if $seen_empty and !$empty_first;
        last LINE;
      }
    }