view release on metacpan or  search on metacpan

perl5db.pl  view on Meta::CPAN

		    }
		    $res .= sprintf(qq(<stack level="%d"
				       type="%s"
				       filename="%s"
				       lineno="%s"
				       where="%s"/>),
				    $i,
				    checkForEvalStackType($sub[$#sub]->{sub}),
				    calcFileURI $sub[$#sub]->{file},
				    $sub[$#sub]->{line},
				    'main');
		}
		$res .= "\n</response>\n";
		# dblog("$cmd => $res") if $ldebug;
		printWithLength($res);

	    } elsif ($cmd eq 'context_names') {
		emitContextNames($cmd,
				 $transactionID);

	    } elsif ($cmd eq 'context_get') {
		my $stackDepth = getArg(\@cmdArgs, '-d');
		my $context_id = getArg(\@cmdArgs, '-c');
		$stackDepth = 0 unless defined $stackDepth;
		local $settings{max_depth}[0] = 0
                    unless $xdebug_full_values_in_context;
		my $currStackSize = count_trace(0); # , $numLevelsToShow;
		dblog("main->getContextProperties: \$currStackSize = $currStackSize\n") if $ldebug;
		my $namesAndValues;
		if ($context_id == FunctionArguments) {
		    my @savedArgs;
		    my $actualStackDepth = $stackDepth + 1;
		    while (1) {
			my @unused = caller($actualStackDepth);
			if (!@unused) {
			    last;
			} elsif ($unused[3] eq '(eval)' && !$unused[4]) {
			    $actualStackDepth++;
				# dblog("context_get: moving up to level $actualStackDepth");
			} else {
				# dblog("context_get: settle on caller => [@unused]");
				# dblog("stack depth [$actualStackDepth]: curr args are [", join(", ", @args), "]") if $ldebug;
			    @savedArgs = @args;
			    last;
			}
		    }
		    if (@savedArgs) {
			# Are there args?  This gets around Perl's
			# behavior where if caller fails it doesn't
			# change the value of @args

			# dblog("caller => [@unused]");
			# dblog("stack depth [$stackDepth]: curr args are [", join(", ", @args), "]") if $ldebug;
			$namesAndValues = [];
			for (my $j = 0; $j < @savedArgs; $j++) {
			    push @$namesAndValues, [sprintf('$_[%d]', $j), $savedArgs[$j], 0];
			}
		    }
		} elsif ($context_id == LocalVars) {
		    $namesAndValues = eval {
                        hasPadWalker() ?
                            getProximityVarsViaPadWalker($pkg, $currentFilename, $currentLine, $stackDepth) :
                            getProximityVarsViaB($pkg, $currentFilename, $currentLine, $stackDepth);
                    };
		} else {
		    $namesAndValues = eval { getContextProperties($context_id, $pkg); };
		}
		if ($@) {
		    my ($code, $error) = ($@ =~ /code:(.*):error<:<(.*?)>:>/);
		    if (!$code) {
			$code = DBP_E_ParseError;
			$error = _trimExceptionInfo($@);
		    }
		    makeErrorResponse($cmd,
				      $transactionID,
				      $code,
				      $error);
		    next CMD;
		}
		#dblog("unsorted vars:", DB::Data::Dump::dump($namesAndValues), "\n") if $ldebug;
		my @sortedNames;
		if ($context_id != FunctionArguments) {
		    @sortedNames = sort {
			# For some reason this doesn't work as an external fn
			# All the values come in undef'ed
			my ($a1, $a2) = split(//, $a->[0], 2);
			my ($b1, $b2) = split(//, $b->[0], 2);
			($a2 cmp $b2 || $a1 cmp $b1);
		    } @$namesAndValues;
		} else {
		    @sortedNames = @$namesAndValues;
		}
		if ($ldebug) {
		    my @names = map $_->[NV_NAME], @sortedNames;
		    dblog("Found variables: @names");
		}
		# dblog("sorted vars:", DB::Data::Dump::dump(@sortedNames), "\n") if $ldebug;
		foreach my $entry (@sortedNames) {
		    if ($entry->[NV_NEED_MAIN_LEVEL_EVAL]) {
			eval {
			    $entry->[NV_VALUE] = eval_term($entry->[NV_NAME]);
			};
			if ($@) {
			    $entry->[NV_VALUE] = _trimExceptionInfo($@);
			    $entry->[NV_UNSET_FLAG] = 1;
			}
		    }
		}
		# If anything had to be re-evaluated, and didn't return
		# a value, remove it.
		@sortedNames = grep { !($_->[NV_NEED_MAIN_LEVEL_EVAL])
					  || defined $_->[NV_VALUE] } @sortedNames;
		if ($context_id == PunctuationVariables) {
		    # Filter out unset values, and add the pattern-matching ones.
		    @sortedNames = grep { ! defined $_->[NV_UNSET_FLAG] } @sortedNames;
		    # And add the pattern-match vars
		    $evalarg = '$#-';
		    my ($numPVs) = &eval();
		    for (my $pvnum = $numPVs; $pvnum > 0; $pvnum--) {
			eval {
			    my $pvname = "\$$pvnum";
			    $evalarg = $pvname;