view release on metacpan or  search on metacpan

lib/Devel/Trepan/DB/LineCache.pm  view on Meta::CPAN

    $fh->close();
    $opts ||= {};
    $opts->{use_perl_d_file} = 0;
    update_cache($tempfile, $opts);
    $script2file{$script} = $tempfile;

    return $tempfile;
}

sub map_file_line($$)
{
    my ($file, $line) = @_;
    if (exists $file2file_remap_lines{$file}) {
        my $triplet_ref = $file2file_remap_lines{$file};
        for my $triplet (@$triplet_ref) {
            my ($from_file, $range_ref, $start) = @$triplet;
            my @range = @$range_ref;
            if ( $range[0]  >= $line && $range[-1] <= $line) {
                my $from_file = $from_file || $file;
                return [$from_file, $start+$line-$range[0]];
            }
        }
    }
    return ($file, $line);
}

=pod

=head2 filename_is_eval

B<filename_is_eval($filename)> => I<boolean>

Return I<true> if $filename matches one of the pseudo-filename strings
that get created for by I<eval()>.

=cut

sub filename_is_eval($)
{
    my $filename = shift;
    return 0 unless defined $filename;
    return !!
	($filename =~ /^\(eval \d+\)|-e$/
	 # SelfLoader does this:
	 || $filename =~ /^sub \S+::\S+/
	);
}

=pod

=head2 update_script_cache

B<update_script_cache($script, $opts)> => I<boolean>

Update a cache entry for an pseudo eval-string file name. If something
is wrong, return I<undef>. Return I<true> if the cache was updated and
I<false> if not.

=cut

sub update_script_cache($$)
{
    my ($script, $opts) = @_;
    return 0 unless filename_is_eval($script);
    my $string = $opts->{string};
    my $lines_href = {};
    if (defined($string)) {
        my @lines = split(/\n/, $string);
        $lines_href->{plain} = \@lines;
    } else {
        if ($script eq $DB::filename) {
	    ## SelfLoader evals
	    if (!@DB::line && $script =~/^sub (\S+)/) {
	    	my $func = $1;
	    	my $string = $Devel::Trepan::SelfLoader::Cache{$func};
		return 0 unless $string;
	    	$string =~ s/^\n#line 1.+\n//;
	    	@DB::line = split(/\n/, $string);
	    }

            # Should be the same as the else case,
            # but just in case...
            $lines_href->{plain} = \@DB::line;
            $string = join("\n", @DB::line);
        } else {
            no strict;
            $lines_href->{plain} = \@{"_<$script"};
            $string = join("\n", @{"_<$script"});
        }
	return 0 unless length($string);
    }
    $lines_href->{$opts->{output}} = highlight_string($string) if
        $opts->{output} && $opts->{output} ne 'plain';

    my $entry = {
        lines_href => $lines_href,
    };
    $script_cache{$script} = $entry;
    return 1;
  }

=head2

B<dualvar_lines($file_or_string, $is_file, $mark_trace)> =>
#  I<list of dual-var strings>

# Routine to create dual numeric/string values for
# C<$file_or_string>. A list reference is returned. In string context
# it is the line with a trailing "\n". In a numeric context it is 0 or
# 1 if $mark_trace is set and B::CodeLines determines it is a trace
# line.
#
# Note: Perl implementations seem to put a COP address inside
# @DB::db_line when there are trace lines. I am not sure if this is
# specified as part of the API. We don't do that here but (and might
# even if it is not officially defined in the API.) Instead put value
# 1.
#
=cut

# FIXME: $mark_trace may be something of a hack. Without it we can

lib/Devel/Trepan/DB/LineCache.pm  view on Meta::CPAN

a debugger is called via Enbugger which turn on debugging late so source
files might not have been read in.

=cut
sub load_file($;$) {
    my ($filename, $eval_string) = @_;

    # The symbols by which we'll know ye.
    my $base_symname = "_<$filename";
    my $symname      = "main::$base_symname";

    no strict 'refs';

    # Note: dualvar_lines updates @$synmame;
    if (defined($eval_string)) {
	dualvar_lines($eval_string, \@$symname, 0, 1);
    } else {
        dualvar_lines($filename, \@$symname, 1, 1);
    }

    $$symname ||= $filename;

    return;
}

=head2 readlines

B<readlines(I<$filename>)> => I<list of strings>

Return a a list of strings for I<$filename>. If we can't read
I<$filename> retun I<undef>. Each line will have a "\n" at the end.

=cut

sub readlines($)
{
    my $path = shift;
    if (-r $path) {
        my $fh;
        open($fh, '<', $path);
        seek $fh, 0, 0;
        my @lines = <$fh>;
        close $fh;
        return @lines;
    } else {
        return undef;
    }
}

=head2 update_cache

B<update_cache($filename, [, $opts]>

Update a cache entry.  If something's wrong, return I<undef>. Return
the expanded file name if the cache was updated and I<false> if not.  If
$I<$opts-E<gt>{use_perl_d_file}> is I<true>, use that as the source for the
lines of the file.

=cut

sub update_cache($;$)
{
    my ($filename, $opts) = @_;
    my $read_file = 0;
    $opts = {} unless defined $opts;
    my $use_perl_d_file = $opts->{use_perl_d_file};
    $use_perl_d_file = 1 unless defined $use_perl_d_file;

    return undef unless $filename;

    delete $file_cache{$filename};

    my $is_eval = filename_is_eval($filename);
    my $path = $filename;
    unless ($is_eval) {
        $path = abs_path($filename) if -f $filename;
    }
    my $lines_href;
    my $trace_nums = {};
    my $stat;
    if ($use_perl_d_file) {
        my @list = ($filename);
        if ($is_eval) {
            cache_script($filename);
            ## FIXME: create a temporary file in script2file;
        }
        push @list, $file2file_remap{$path} if exists $file2file_remap{$path};
        for my $name (@list) {
            no strict; # Avoid string as ARRAY ref error message
            if (scalar @{"main::_<$name"}) {
                $stat = File::stat::stat($path);
            }
            my $raw_lines = \@{"main::_<$name"};

            # Perl sometimes doesn't seem to save all file data, such
            # as those intended for POD or possibly those after
            # __END__. But we want these, so we'll have to read the
            # file the old-fashioned way and check lines. Variable
            # $incomplete records if there was a mismatch.
            my $incomplete = 0;
            if (-r $path) {
                my @lines_check = readlines($path);
                my @lines = @$raw_lines;
		my $totally_empty = 1;
                for (my $i=1; $i<=$#lines; $i++) {
                    if (defined $raw_lines->[$i]) {
			$totally_empty = 0;
			last;
		    }
		}
		if ($totally_empty) {
		    load_file($filename);
		    $trace_nums =  $file_cache{$filename}{trace_nums};
		} else {
		    for (my $i=1; $i<=$#lines; $i++) {
			if (defined $raw_lines->[$i]) {
			    no warnings;
			    $trace_nums->{$i} = (-$raw_lines->[$i]) if
				(+$raw_lines->[$i]) != 0;
			    $incomplete = 1 if $raw_lines->[$i] ne $lines[$i];
			} else {