Devel-Debug-DBGp
view release on metacpan or search on metacpan
# postponed
$addIt = 1;
}
if ($addIt) {
my $bFileURINo;
my $fileURI = filenameToURI($fileName, 1);
my $fileURINo = internFileURI($fileURI);
my $bkptID = addSubBreakPoint($possibleSub,
$fileURINo,
$lineNumber,
$bState,
$possibleSub,
$bCondition,
$bType,
$bHitCount,
$bHitConditionOperator);
push @bkptIDs, $bkptID;
}
}
return @bkptIDs;
}
# I try to make the types transparent, but we need to give a typemap
# anyway
sub emitTypeMapInfo($$) {
my ($cmd, $transactionID) = @_;
my $res = sprintf(qq(%s\n<response %s %s %s command="%s"
transaction_id="%s" >),
xmlHeader(),
namespaceAttr(),
xsdNamespace(),
xsiNamespace(),
$cmd,
$transactionID);
# Schema, CommonTypeName (type attr) LanguageTypeName (name attr)
foreach my $e (['boolean', 'bool'],
['float'],
['integer', 'int'],
['string'],
[undef, 'undefined', 'undef'],
[undef, 'array', 'ARRAY'],
[undef, 'hash', 'HASH']) {
my $xsdName = $e->[0];
my $commonTypeName = $e->[1] || $xsdName;
my $languageTypeName = $e->[2] || $commonTypeName;
if ($xsdName) {
$res .= qq(<map type="$commonTypeName" name="$languageTypeName" xsi:type="xsd:$xsdName"/>);
} else {
$res .= qq(<map type="$commonTypeName" name="$languageTypeName"/>);
}
}
$res .= "\n</response>";
printWithLength($res);
}
sub decodeCmdLineData($$$$) {
my ($cmd, $transactionID, $dataLength, $argsARef) = @_;
my @args = @$argsARef;
my $currDataEncoding = $settings{data_encoding}->[0];
my $decodedData;
if ($currDataEncoding eq 'none' || $currDataEncoding eq 'binary') {
$decodedData = join(" ", @args);
$dataLength = length ($decodedData);
} elsif (scalar @args == 0) {
printWithLength(sprintf
qq(%s\n<response %s command="%s" transaction_id="%s" ><error code="%d" apperr="4"><message>Expecting exactly 1 argument for %s command, got [nothing].</message></error></response>),
xmlHeader(),
namespaceAttr(),
$cmd,
$transactionID,
DBP_E_CommandUnimplemented,
$cmd,
);
return ();
} else {
$decodedData = decodeData(join("", @args));
$dataLength = length ($decodedData);
}
dblog("decodeCmdLineData: returning [$decodedData]\n") if $ldebug;
return ($dataLength, $currDataEncoding, $decodedData);
}
sub checkForEvalStackType($) {
my ($stackDumpTypeValue) = @_;
if ($stackDumpTypeValue && $stackDumpTypeValue =~ /^eval [\"\'q<]/) {
return 'eval';
} else {
return 'file';
}
}
sub getFileInfo($$$$$) {
my ($bFileURI,
$rbFileURI,
$rbFileURINo,
$rbFileName,
$rperlFileName) = @_;
my ($bFileURINo,
$bFileName,
$perlFileName);
# URIs need to be stored in a canonical format,
# since they're how we look things up.
# Filenames aren't used for lookups directly.
$bFileURI = canonicalizeURI($bFileURI);
$bFileURINo = internFileURI($bFileURI);
if (defined $fileNameTable[$bFileURINo]) {
(undef, $bFileName, $perlFileName) = @{$fileNameTable[$bFileURINo]};
} else {
local $@;
eval {
$bFileName = canonicalizeFName(uriToFilename($bFileURI));
$perlFileName = lookForPerlFileName($bFileName);
if (defined $perlFileName) {
$perlNameToFileURINo{$perlFileName} = $bFileURINo;
$fileNameTable[$bFileURINo] = [$bFileURI,
$bFileName,
$perlFileName];
}
};
if ($@) {
my $error = $@;
dblog("Error in uriToFilename: $error " .
DB::Data::Dump::dump(dump_trace(0))) if $ldebug;
}
}
# And set the references
$$rbFileURI = $bFileURI;
$$rbFileURINo = $bFileURINo;
$$rbFileName = $bFileName;
$$rperlFileName = $perlFileName;
}
sub getBreakpointInfoString($%) {
my ($bkptID, %extraInfo) = @_;
my $bkptInfo = $bkptInfoTable{$bkptID};
my $bType = $opts{t};
my $bException = $opts{x};
my $bCondition = "";
if (exists $opts{f}) {
$opts{f} =~ s@^dbgp:///file:/@file:/@;
$opts{f} =~ s@^file:/([^/])@file://$1@;
# work around broken clients
$opts{f} =~ s@^file%3[Aa]//@file://@;
$opts{f} = 'file://' . $opts{f} unless
$opts{f} =~ m@^(?:file|dbgp)://@;
}
my ($bFileURINo, $bkptID, $bStateVal);
my ($perlFileName, $bFileURI, $bFileName);
my $bptErrorCode = 0;
my $bptErrorMsg = undef;
if (rindex($opts{f}, "$full_dbgp_prefix/", 0) == 0) {
my ($evalIdx, $encodedName) = $opts{f} =~ m{^\Q$full_dbgp_prefix/\E(\d+)/(.*)$};
my $evalName = decodeData($encodedName, 'urlescape');
my $evalInfo = $evalTableIdx[$evalIdx] &&
$evalTableIdx[$evalIdx] &&
$evalTable{$evalTableIdx[$evalIdx]};
if ($evalName && $evalInfo) {
$bFileURI = $opts{f};
$bFileName = $opts{f};
$bFileURINo = internFileURI($bFileURI);
$perlFileName = $evalTableIdx[$evalIdx];
}
} else {
getFileInfo(defined $opts{f} ? $opts{f} : calcFileURI($currentFilename),
\$bFileURI,
\$bFileURINo,
\$bFileName,
\$perlFileName);
}
if ($opts{f} =~ m@^dbgp:///perl//(?:PerlApp/|<.*>)@) {
$bptErrorCode = DBP_E_BreakpointTypeNotSupported;
$bptErrorMsg = "Breakpoints in compiled modules are not supported.";
} elsif (defined $bException) {
# Don't support break on exceptions
$bptErrorCode = DBP_E_BreakpointTypeNotSupported;
$bptErrorMsg = "Breaking on exceptions not supported.";
} elsif (defined $bFunctionName) {
if (!defined $bType || ($bType ne 'call'
&& $bType ne 'return')) {
$bptErrorMsg = "Breaking on functions requires a breakpoint type of 'call' or 'return', got [$bType].";
$bptErrorCode = DBP_E_InvalidOption;
}
} elsif ($bType eq 'conditional') {
if (!defined $bLine) {
$bptErrorCode = DBP_E_InvalidOption;
$bptErrorMsg = "Line number required for setting a conditional breakpoint in Perl.";
} else {
$bType = 'line';
if ($cmdArgs[0] && length $cmdArgs[0]) {
$bCondition = $cmdArgs[0];
dblog("Got raw condition [$bCondition]") if $ldebug;
$bCondition = decodeData($bCondition);
dblog("Got decoded condition [$bCondition]") if $ldebug;
} else {
$bptErrorCode = DBP_E_InvalidOption;
$bptErrorMsg = "Condition required for setting a conditional breakpoint.";
}
}
} elsif ($bType eq 'watch') {
my $bptErrorCode = 0;
my $bptErrorMsg;
if ($cmdArgs[0] && length $cmdArgs[0]) {
$bCondition = $cmdArgs[0];
dblog("Got raw condition [$bCondition]") if $ldebug;
$bCondition = decodeData($bCondition);
dblog("Got decoded condition [$bCondition]") if $ldebug;
if ($bCondition) {
$evalarg = $bCondition;
my ($val) = eval { join(' ', &eval) };
$val = (defined $val) ? "'$val'" : 'undef';
push @watchPoints, $bCondition;
push @watchPointValues, $val;
# We are now watching expressions.
$trace |= 2;
++$numWatchPoints;
}
} else {
$bptErrorCode = DBP_E_InvalidOption;
$bptErrorMsg = "Expression required for setting a watchpoint.";
}
} elsif (defined $bType && $bType ne 'line') {
$bptErrorMsg = "Breakpoint type of $bType not supported -- only 'line' is supported.";
$bptErrorCode = DBP_E_BreakpointTypeNotSupported;
} elsif (!defined $bFileName && !defined $bLine) {
# Need a filename and a line no for breaking
$bptErrorMsg = "Filename and line number required for setting a breakpoint.";
$bptErrorCode = DBP_E_InvalidOption;
} elsif ($bLine < 0) {
$bptErrorMsg = "Negative line numbers not supported (got [$bLine])";
$bptErrorCode = DBP_E_InvalidOption;
} elsif ($bHitConditionOperator && ! defined $bHitCount) {
$bptErrorMsg = "Hit condition operator specified without a target hit count.";
$bptErrorCode = DBP_E_InvalidOption;
}
# Figure out our state
if ($bptErrorCode == 0) {
if ($bState eq BKPT_REQ_ENABLED) {
$bStateVal = $bIsTemporary ? BKPT_TEMPORARY : BKPT_ENABLE;
} elsif ($bState eq BKPT_REQ_DISABLED) {
$bStateVal = BKPT_DISABLE;
} else {
$bptErrorCode = DBP_E_BreakpointStateInvalid;
$bptErrorMsg = "Breakpoint state '$bState' not recognized.";
}
}
if ($bptErrorCode != 0) {
makeErrorResponse($cmd,
$transactionID,
$bptErrorCode,
$bptErrorMsg);
next CMD;
}
if ($bFunctionName) {
my @bptIDs =
findAndAddFunctionBreakPoints($bFunctionName,
defined $opts{f} && $perlFileName,
$opts{n},
$bCondition,
$bStateVal,
$bIsTemporary,
$bType,
$bHitCount,
if ($context_id == FunctionArguments &&
$property_long_name ne '@_' &&
$property_long_name !~ /^\$_\[/) {
makeErrorResponse($cmd,
$transactionID,
DBP_E_CantGetProperty,
"Property $property_long_name doesn't identify an arg");
next CMD;
}
(my $fullName, $propertyKey) = makeFullPropertyName($property_long_name, $propertyKey);
my $nameAndValue = [$fullName, undef, 1];
# + 1 is for the eval BLOCK below
local $evalSkipFrames = $evalSkipFrames + 1;
local $evalStackLevel = $stackDepth;
eval {
$nameAndValue->[NV_VALUE] = eval_term($nameAndValue->[NV_NAME]);
};
if ($@) {
$nameAndValue->[NV_VALUE] = _trimExceptionInfo($@);
$nameAndValue->[NV_UNSET_FLAG] = 1;
}
eval {
emitEvaluatedPropertyGetInfo($cmd,
$transactionID,
$nameAndValue,
$property_long_name,
$propertyKey,
$maxDataSize,
$pageIndex);
};
if ($@) {
dblog("Error in emitEvaluatedPropertyGetInfo: [$@]") if $ldebug;
makeErrorResponse($cmd,
$transactionID,
DBP_E_InternalException,
"Internal error while formatting result");
}
} elsif ($cmd eq 'property_set') {
# First get the args, and then sanity check.
my %opts;
{
local *ARGV = \@cmdArgs;
shift @ARGV;
getopts('a:c:d:l:n:t:', \%opts);
}
my $context_id = $opts{c};
my $stackDepth = $opts{d} || 0;
my $advertisedDataLength = $opts{l} || 0;
my $property_long_name = $opts{n};
$property_long_name = nonXmlChar_Decode($property_long_name);
my $valueType = $opts{t};
if ($context_id == FunctionArguments) {
makeErrorResponse($cmd,
$transactionID,
DBP_E_CantSetProperty,
"This debugger currently doesn't modify function arguments");
next CMD;
}
my ($actualDataLength, $currDataEncoding, $decodedData);
if (scalar @cmdArgs) {
($actualDataLength, $currDataEncoding, $decodedData) =
decodeCmdLineData($cmd, $transactionID, $advertisedDataLength, \@cmdArgs);
}
if (!defined $decodedData) {
dblog("property_set: \$decodedData not defined\n") if $ldebug;
makeErrorResponse($cmd,
$transactionID,
DBP_E_CantSetProperty,
"Can't decode the data");
next CMD;
}
if ($valueType
&& $valueType eq 'string'
&& substr($decodedData, 0, 1) !~ /[\"\']/) {
$decodedData =~ s,\\,\\\\,g;
$decodedData =~ s,',\\',g;
$decodedData = "\'$decodedData\'";
}
my $nameAndValue = doPropertySetInfo($cmd,
$transactionID,
$property_long_name);
if (!$nameAndValue) {
# Already gave an error message
next CMD;
}
if ($nameAndValue->[NV_NEED_MAIN_LEVEL_EVAL]) {
$evalarg = $nameAndValue->[NV_NAME] . '=' . $decodedData;
# here we don't adjust $evalSkipFrames because
# modifying function arguments is not supported
eval {
&eval();
};
if ($@) {
# dblog("Have to deal with error [$@]\n") if $ldebug;
# Fix $@;
my ($code, $error) = ($@ =~ /code:(.*):error<:<(.*?)>:>/);
if (!$code) {
$code = DBP_E_CantGetProperty;
$error = _trimExceptionInfo($@);
}
makeErrorResponse($cmd,
$transactionID,
207, #XXX: Invalid expression
$error);
} else {
my $res = sprintf(qq(%s\n<response %s command="%s"
transaction_id="%s" success="1" />),
xmlHeader(),
namespaceAttr(),
$cmd,
$transactionID);
printWithLength($res);
}
}
} elsif ($cmd eq 'source') {
my %opts;
{
local *ARGV = \@cmdArgs;
dblog("source: args={@ARGV}") if $ldebug;
shift @ARGV;
getopts('b:e:f:', \%opts);
}
# Line 0 contains the 'require perl5db.pl thing'?
my $beginLine = $opts{b} || 1;
$beginLine < 1 and $beginLine = 1;
my $endLine;
my $sourceString;
my $error;
$opts{f} = calcFileURI $currentFilename unless exists $opts{f};
if (defined &INC && $opts{f} =~ m@^dbgp:///perl//(PerlApp/|<.*?>)(.*)@) {
# Definitely three slashes between 'perl' and 'PerlApp'
my $pdkUtilityName = $1;
my @lines = split(/\n/, INC($2));
$endLine = $opts{e} || $#lines;
dblog("Line " . __LINE__ . ": Debugging a $pdkUtilityName module, grab source($1) and get [" . join("\n", @lines[0..2]) . "]") if $ldebug;
($sourceString, $error) =
_fileSource($1,
$beginLine,
$endLine,
\@lines);
# One slash or two in this next pattern?
} elsif ($opts{f} =~ m@^dbgp:///?perl/.*(\d+)(/\(eval\s\d+\).*)$@ || $opts{f} =~ m@^dbgp:///?perl/.*(\d+)(/%28eval%20\d+%29.*)$@) {
dblog("source: it's a dbgp thing ($1/$2)") if $ldebug;
my $dynLocnIdx = $1;
my $dynamicLocation;
next CMD;
}
tie(*STDERR, 'DB::RedirectStdOutput', *ActualSTDERR, $OUT, $cmd, $copyType);
$tiedStderr = 1;
if (logName && logName == \*STDERR) {
setLogFH(\*ActualSTDERR);
}
}
my $res = sprintf(qq(%s\n<response %s command="%s"
transaction_id="%s" success="1" />),
xmlHeader(),
namespaceAttr(),
$cmd,
$transactionID);
{
local $ldebug = $cmd ne 'stderr' && $ldebug;
printWithLength($res);
}
};
if ($@) {
makeErrorResponse($cmd,
$transactionID,
DBP_E_InvalidOption,
"Invalid -c value of $copyType");
}
} elsif ($cmd eq 'stdin') {
=head unsupported
my %opts;
{
local *ARGV = \@cmdArgs;
shift @ARGV;
getopts('c:l:', \%opts);
}
if ($opts{c} == 1) {
} else {
dblog("stdin: opts{c} = $opts{c}\n") if $ldebug;
next CMD;
}
my $dataLength = $opts{l}; # ignore
my $encodedData = join("", @cmdArgs);
my $actualData = decodeData($encodedData, 'base64');
dblog "stdin: [$actualData]\n" if $ldebug;
=cut
makeErrorResponse($cmd,
$transactionID,
DBP_E_CommandUnimplemented,
"stdin not supported via protocol");
} elsif ($cmd eq 'eval') {
my %opts;
{
local *ARGV = \@cmdArgs;
shift @ARGV;
getopts('l:p:', \%opts);
}
my $dataLength = $opts{l};
my $pageIndex = $opts{p} || 0;
my ($actualDataLength, $currDataEncoding, $decodedData);
if (scalar @cmdArgs) {
($actualDataLength, $currDataEncoding, $decodedData) =
decodeCmdLineData($cmd, $transactionID, $dataLength, \@cmdArgs);
}
if (!defined $decodedData) {
next CMD;
}
eval {
local $evalSkipFrames = $evalSkipFrames + 1;
my $res = eval_term($decodedData);
emitEvalResultAsProperty($cmd,
$transactionID,
$decodedData,
$res,
$settings{max_data}[0],
$pageIndex);
1;
} or do {
my $error = $@ || "";
makeErrorResponse($cmd, $transactionID, DBP_E_PropertyEvalError, "Error in eval: $error")
};
} else {
# Fallback
printWithLength(sprintf
(qq(%s\n<response %s command="%s"
transaction_id="%s" ><error code="6" apperr="4">
<message>%s command not recognized</message>
</error></response>),
xmlHeader(),
namespaceAttr(),
$cmd,
$transactionID));
}
}
} elsif ($pkg =~ /^DB::/) {
dblog("Skipping package [$pkg]\n") if $ldebug;
} elsif ($inPostponed) {
dblog("Still postponed: [$pkg/$currentFilename/$currentLine]\n") if $ldebug;
}
# Put the user's globals back where you found them.
($@, $!, $,, $/, $\, $^W) = @saved;
db_alarm($pending_check_interval);
$pending_check_enabled = 1 unless $skip_alarm;
return ();
}
# Avoid re-entrancy problems by putting newly entered files in a
# queue and processing them when it's appropriate.
sub postponed {
local *dbline_arg = shift;
push @postponedFiles, *dbline_arg;
if ($inPostponed || !$ready) {
return;
}
finish_postponed();
return 1;
}
sub finish_postponed {
local $inPostponed = 1;
while (@postponedFiles) {
our ($dbline, %dbline);
local *dbline = shift @postponedFiles;
my $filename = $dbline;
$filename =~ s/^<_//;
# Get the Perl filename, canonical filename, and URI, and see
# if it was set as postponed
my $perlFileName = $filename;
( run in 0.446 second using v1.01-cache-2.11-cpan-39bf76dae61 )